module funcAux
implicit none

private printVec , printMat, IprintVec, IprintMat, printTen
public AddEye, MatInv3, MatInv2, MatInv, calcI1, calcI2 , calcI3 , dot_product2, &
crossProduct,  crossProduct2, T4xT2, calc_a0, calc_he, calc_he_tri, calc_he_tri_max, &
init_seed, PI, deltaKron, deltaKron2, VotimesW,  getIJfromK, iShiftKL, iShiftIJKL, numPrint, getSlice, getSliceAllocate, &
getT2fromV, getT4fromV,  getVfromT2, getVfromT4, &
setAEandBEfib, setAEandBE_lagrangeMultipliers, setAEandBE_LM, setAEandBE_LM_full, &
 setCoupling_lagrangeMultipliers, setCoupling_pureDisplacement, &
isOnBoundary, getNormalBoundary, norm2, setBlockToMatrix, setBlockToVector, setBlockToMatrixSquare, &
setBlockDiagonalConstantToMatrix, setSimbolicBlockToMatrixSquare, setSimbolicBlockToMatrix, setSimbolicBlockDiagonalToMatrix, &
voigtTen4toTen2, voigtTen2toVec, MatDet, getNormal, solveQuadraticEquation, &
VotimesW_fun, VodotW_fun, VodotW, transposeT4, FindKeyword

interface numPrint !! overloading of subroutines
	module procedure :: IprintMat
	module procedure :: IprintVec
	module procedure :: printMat
	module procedure :: printVec
	module procedure :: printTen
end interface

interface VotimesW !! overloading of subroutines
	module procedure :: VotimesW_vec_vec
	module procedure :: VotimesW_mat_mat
end interface

interface VotimesW_fun !! overloading of function
	module procedure :: VotimesW_vec_vec_fun
	module procedure :: VotimesW_mat_mat_fun
end interface

private
integer :: I,J
real*8 , dimension(3,3) :: deltaKron
real*8 , dimension(2,2) :: deltaKron2
DATA((deltaKron(I,J),I=1,3),J=1,3) /1.0d0,0.0d0,0.0d0,0.0d0,1.0d0,0.0d0,0.0d0,0.0d0,1.0d0/
DATA((deltaKron2(I,J),I=1,2),J=1,2) /1.0d0,0.0d0,0.0d0,1.0d0/

real*8, parameter :: PI=4.D0*DATAN(1.D0)

contains

subroutine getT2fromV(T,V)
	real*8 , intent(in) :: V(:)
	real*8 , intent(out) :: T(:,:)
	integer :: i,j , ip, n

	n = size(T,1)

	do j = 1 , n
	do i = 1 , n
		ip = iShiftKL(i,j,n)
		T(i,j) = V(ip + 1)
	end do
	end do

end subroutine

subroutine getT4fromV(T,V)
	real*8 , intent(in) :: V(:)
	real*8 , intent(out) :: T(:,:,:,:)
	integer :: i,j,k,l , ip, n

	n = size(T,1)

	do l = 1 , n
	do k = 1 , n
	do j = 1 , n
	do i = 1 , n
		ip = iShiftIJKL(i,j,k,l,n)
		T(i,j,k,l) = V(ip + 1)
	end do
	end do
	end do
	end do

end subroutine

subroutine getVfromT2(V,T)
	real*8 , intent(out) :: V(:)
	real*8 , intent(in) :: T(:,:)
	integer :: i,j , ip, n

	n = size(T,1)

	do j = 1 , n
	do i = 1 , n
		ip = iShiftKL(i,j,n)
		V(ip + 1) = T(i,j)
	end do
	end do

end subroutine

subroutine getVfromT4(V,T)
	real*8 , intent(out) :: V(:)
	real*8 , intent(in) :: T(:,:,:,:)
	integer :: i,j,k,l , ip, n

	n = size(T,1)

	do l = 1 , n
	do k = 1 , n
	do j = 1 , n
	do i = 1 , n
		ip = iShiftIJKL(i,j,k,l,n)
		V(ip + 1) = T(i,j,k,l)
	end do
	end do
	end do
	end do

end subroutine

subroutine getSlice(Vout,Vin,row0,row1,col0,col1,Ncol)
	real*8 , intent(out) :: Vout(:)
	real*8 , intent(in) :: Vin(*)
	integer , intent(in) :: row0, row1, col0, col1, Ncol
	integer :: i,j,ip, k

	k = 0
	do i = row0, row1
		ip = (i-1)*Ncol
		do j = col0, col1
			k = k + 1
			Vout(k) = Vin(ip + j)
		end do
	end do

end subroutine

subroutine getSliceAllocate(Vout,Vin,row0,row1,col0,col1,Ncol)
	real*8 , allocatable, intent(out) :: Vout(:)
	real*8 , intent(in) :: Vin(*)
	integer , intent(in) :: row0, row1, col0, col1, Ncol
	integer :: i,j,ip, k, alocErr

	allocate(Vout((row1-row0 + 1)*(col1-col0 + 1)), stat = alocErr)

!~ 	write(*,*) "alocErr = " , alocErr

	k = 0
	do i = row0, row1
		ip = (i-1)*Ncol
		do j = col0, col1
			k = k + 1
			Vout(k) = Vin(ip + j)
		end do
	end do

end subroutine

integer function iShiftIJKL(i,j,k,l,NdimE)
	integer, intent(in) :: i,j,k,l,NdimE
	iShiftIJKL = ( ( (i-1)*NdimE + j - 1 )*NdimE + k - 1 )*NdimE + l - 1
end function

integer function iShiftKL(k,l,NdimE)
	integer, intent(in) :: k,l,NdimE
	iShiftKL = (k-1)*NdimE + l - 1
end function

subroutine getIJfromK(i,j,k)
	integer , intent(out) :: i,j
	integer , intent(in) :: k

	if(k==1) then
		i=1; j=1
	else if(k==2) then
		i=1; j=2
	else if(k==3) then
		i=2; j=1
	else if(k==4) then
		i=2; j=2
	end if

end subroutine

subroutine calc_he(XLL,he) !! just for tetrahedra
	integer,parameter :: NodElt = 4 , Ndim = 3
	real*8 , intent(in) :: XLL(NodElt*Ndim)
	real*8 , intent(out) :: he
	real*8 :: edgeVec(Ndim)

	edgeVec = XLL(1:3) - XLL(4:6) !! 1 - 2
	he = dsqrt(dot_product(edgeVec,edgeVec))
	edgeVec = XLL(1:3) - XLL(7:9) !! 1 - 3
	he = he + dsqrt(dot_product(edgeVec,edgeVec))
	edgeVec = XLL(1:3) - XLL(10:12) !! 1 - 4
	he = he + dsqrt(dot_product(edgeVec,edgeVec))
	edgeVec = XLL(4:6) - XLL(7:9) !! 2 - 3
	he = he + dsqrt(dot_product(edgeVec,edgeVec))
	edgeVec = XLL(4:6) - XLL(10:12) !! 2 - 4
	he = he + dsqrt(dot_product(edgeVec,edgeVec))
	edgeVec = XLL(7:9) - XLL(10:12) !! 3 - 4
	he = he + dsqrt(dot_product(edgeVec,edgeVec))

	he = he/6.0d0

end subroutine

subroutine calc_he_tri(he,XLL) !! just for triangles
	integer,parameter :: NodElt = 3 , Ndim = 2
	real*8 , intent(in) :: XLL(NodElt*Ndim)
	real*8 , intent(out) :: he
	real*8 :: V(Ndim),U(Ndim), area

	U = XLL(3:4) - XLL(1:2) !! 2 - 1
	V = XLL(5:6) - XLL(1:2) !! 3 - 1

	call crossProduct2(area,U,V)
	area = 0.5d0*dabs(area)

!~ 	he = dsqrt(area)
	he = dsqrt(2.0d0*area)

end subroutine

subroutine calc_he_tri_max(he,XLL) !! just for triangles
	integer,parameter :: NodElt = 3 , Ndim = 2
	real*8 , intent(in) :: XLL(NodElt*Ndim)
	real*8 , intent(out) :: he
	real*8 :: V(Ndim), area, maxHe2, HeV2
	integer :: i , j, ip,jp

	maxHe2 = 0.0d0

	do i = 1,NodElt
		j = mod(i,NodElt) + 1
		ip = (i-1)*Ndim
		jp = (j-1)*Ndim

		V = XLL(ip + 1 : ip + Ndim) - XLL(jp + 1 : jp + Ndim)

		HeV2 = dot_product(V,V)
		if(HeV2 > maxHe2) maxHe2 = HeV2
	end do

	he = dsqrt(maxHe2)

end subroutine

subroutine calc_a0(a0,XLL,betaAngle,Ndim,NodElt)
	integer, intent(in) :: Ndim,NodElt
	real*8 , intent(in) :: XLL(NodElt*Ndim), betaAngle
	real*8, intent(out) :: a0(3)
	real*8 ::  G(Ndim), sinTheta, cosTheta, rAux ! angle from the baricentric
	integer :: i,j,ip

	G(:)=0.0d0
	do i = 1,NodElt !!!! Maybe is just until 4
		ip = (i-1)*Ndim
		do j = 1 , Ndim
			G(j) = G(j) + XLL(ip+j)
		end do
	end do

	G=G/real(NodElt)

	rAux = dsqrt(G(1)*G(1) + G(2)*G(2))
	sinTheta = G(1)/rAux
	cosTheta = G(2)/rAux

	rAux = PI*betaAngle/180.0d0

	a0(1) = - dcos(rAux) * sinTheta
	a0(2) = dcos(rAux) * cosTheta
	a0(3) = dsin(rAux)

end subroutine

subroutine calcI1(I1,M)
	implicit none
	real*8 , intent(out) :: I1
	real*8 , intent(in) :: M(:,:)
	integer n
	n = size(M,1)

	if(n==3) then
		I1 = M(1,1) + M(2,2) + M(3,3)
	else if(n==2) then
		I1 = M(1,1) + M(2,2) + 1.0d0
	end if

	return
end subroutine

subroutine calcI2(I2,M)
	implicit none
	real*8 , intent(out) :: I2
	real*8 , intent(in) :: M(:,:)
	integer n
	n = size(M,1)

	if(n==3) then
		I2 = M(1,1)*M(2,2) + M(1,1)*M(3,3) + M(2,2)*M(3,3) - M(1,2)*M(2,1) - M(1,3)*M(3,1) - M(2,3)*M(3,2)
	else if(n==2) then
		I2 = M(1,1)*M(2,2) + M(1,1) + M(2,2) - M(1,2)*M(2,1)
	end if

	return
end subroutine

subroutine calcI3(I3,M)
	implicit none
	real*8 , intent(out) :: I3
	real*8 , intent(in) :: M(:,:)
	integer n
	n = size(M,1)

	if(n==3) then
		I3 = M(1,1)*M(2,2)*M(3,3) + M(1,2)*M(2,3)*M(3,1) + M(1,3)*M(2,1)*M(3,2) &
			- M(1,1)*M(2,3)*M(3,2) - M(1,2)*M(2,1)*M(3,3) - M(1,3)*M(2,2)*M(3,1)
	else if(n==2) then
		I3 = M(1,1)*M(2,2) - M(1,2)*M(2,1)
	end if

	return
end subroutine

real*8 function dot_product2(A,B) result(dot)
	real*8, intent(in) :: A(:,:) , B(:,:)
	integer :: n , i, j
	n = size(A,1)

	dot = 0.0d0
	do i = 1,n
		do j = 1,n
			dot = dot + A(i,j)*B(i,j)
		end do
	end do

end function

subroutine addEye(M)
	implicit none
	real*8, intent(inout) :: M(:,:)
	integer :: i,n
	n = size(M,1)

	do i=1,n
		M(i,i) = M(i,i) + 1.0d0
	end do

	return
end subroutine

SubRoutine T4xT2(S,C,T) ! S = C : T
!~  Implicit none
 integer NDim
 real*8 ::  C(:,:,:,:), S(:,:) , T(:,:)
 integer :: i,j,k,l

 Ndim = size(S,1) !! all the same dimension (2 or 3)

	S = 0.0d0
	do i = 1 , NDim
	do j = 1 , NDim
	do k = 1 , NDim
	do l = 1 , NDim
			S(i,j) = S(i,j) + C(i,j,k,l)*T(k,l)
	end do
	end do
	end do
	end do

Return
End subroutine

subroutine crossProduct(w,normW,u,v) ! w = (u x v)/|u x v|
	real*8 , intent(out) :: w(3), normW
	real*8 , intent(in) :: u(3),v(3)
	w(1) = u(2)*v(3) - v(2)*u(3)
	w(2) = u(3)*v(1) - v(3)*u(1)
	w(3) = u(1)*v(2) - v(1)*u(2)

	normW = dsqrt(dot_product(w,w))
	w = w/normW

end subroutine

subroutine crossProduct2(w,u,v)
	real*8 , intent(out) :: w
	real*8 , intent(in) :: u(2),v(2)
	w = u(1)*v(2) - v(1)*u(2)

end subroutine

function VotimesW_vec_vec_fun(v,w) result(M)
	real*8, intent(in) :: v(:), w(:)
	real*8, allocatable :: M(:,:)
	integer :: n1, n2

	n1 = size(v,1)
	n2 = size(w,1)

	allocate(M(n1,n2))

	call VotimesW_vec_vec(M,v,w)

end function

function VotimesW_mat_mat_fun(V,W) result(M)
	real*8, intent(in) :: V(:,:), W(:,:)
	real*8, allocatable :: M(:,:,:,:)
	integer :: n1, n2, n3, n4

	n1 = size(V,1)
	n2 = size(V,2)
	n3 = size(W,1)
	n4 = size(W,2)

	allocate(M(n1,n2,n3,n4))

	call VotimesW_mat_mat(M,V,W)

end function

subroutine VotimesW_vec_vec(M,v,w)
	implicit none
	real*8, intent(in) :: v(:), w(:)
	real*8, intent(out) :: M(:,:)
	integer :: n1, n2 , j, i

	n1 = size(v,1)
	n2 = size(w,1)

	M = 0.0d0

	do i = 1,n1
		do j = 1,n2
			M(i,j) = v(i)*w(j)
		end do
	end do

end subroutine

subroutine VotimesW_mat_mat(M,V,W)
	implicit none
	real*8, intent(in) :: V(:,:), W(:,:)
	real*8, intent(out) :: M(:,:,:,:)
	integer :: n1, n2 , n3, n4, i, j, k, l

	n1 = size(V,1)
	n2 = size(V,2)
	n3 = size(W,1)
	n4 = size(W,2)

	M = 0.0d0

	do i = 1,n1
	do j = 1,n2
	do k = 1,n3
	do l = 1,n4
		M(i,j,k,l) = V(i,j)*W(k,l)
	end do
	end do
	end do
	end do

end subroutine

function VodotW_fun(V,W) result(M) ! always with matrices
	real*8, intent(in) :: V(:,:), W(:,:)
	real*8, allocatable :: M(:,:,:,:)
	integer :: n1, n2, n3, n4

	n1 = size(V,1)
	n2 = size(W,1)
	n3 = size(V,2)
	n4 = size(W,2)

	allocate(M(n1,n2,n3,n4))

	call VodotW(M,V,W)

end function

subroutine VodotW(M,V,W) ! always with matrices
	implicit none
	real*8, intent(in) :: V(:,:), W(:,:)
	real*8, intent(out) :: M(:,:,:,:)
	integer :: n1, n2 , n3, n4, i, j, k, l

	n1 = size(V,1)
	n2 = size(W,1)
	n3 = size(V,2)
	n4 = size(W,2)

	M = 0.0d0

	do i = 1,n1
	do j = 1,n2
	do k = 1,n3
	do l = 1,n4
		M(i,j,k,l) = V(i,k)*W(j,l)
	end do
	end do
	end do
	end do

end subroutine

Subroutine MatDet(detM,M)
	implicit none
	real*8, intent(in) :: M(:,:)
	real*8, intent(out) :: detM
	real*8 :: A1, A2, A3, B1, B2, B3, C1, C2, C3
	integer :: n

	n = size(M,1)

	if (n == 2) then
		detM= M(1,1)*M(2,2) - M(1,2)*M(2,1)
	else if(n==3) then
		A1 = M(3,3)*M(2,2) - M(3,2)*M(2,3)
		B1 = M(3,3)*M(2,1) - M(3,1)*M(2,3)
		C1 = M(3,2)*M(2,1) - M(3,1)*M(2,2)

		A2 = M(3,3)*M(1,2) - M(3,2)*M(1,3)
		B2 = M(3,3)*M(1,1) - M(3,1)*M(1,3)
		C2 = M(3,2)*M(1,1) - M(3,1)*M(1,2)

		A3 = M(2,3)*M(1,2) - M(2,2)*M(1,3)
		B3 = M(2,3)*M(1,1) - M(2,1)*M(1,3)
		C3 = M(2,2)*M(1,1) - M(2,1)*M(1,2)

		detM= M(1,1)*A1 - M(1,2)*B1 + M(1,3)*C1
	else
		write(0,*) 'WARNING, compute determinant is not possible (n=2 or n=3)'
	end if

end subroutine

subroutine MatInv(Minv,detM,M)
	implicit none
	real*8, intent(in) :: M(:,:)
	real*8, intent(out) :: Minv(:,:), detM
	integer :: n

	n = size(M,1)

	if(n==3) then
		call MatInv3(Minv,detM,M)
	else if(n==2) then
		call MatInv2(Minv,detM,M)
	end if

end subroutine

Subroutine MatInv2(Minv,detM,M)
	implicit none
	real*8, intent(in) :: M(2,2)
	real*8, intent(out) :: Minv(2,2), detM
	real*8 , parameter :: tol = 10.0e-10

	detM= M(1,1)*M(2,2) - M(1,2)*M(2,1)

	if (dabs(detM) > tol ) then
		Minv(1,1)    = M(2,2) / detM
		Minv(1,2)    =-M(1,2) / detM
		Minv(2,1)    =-M(2,1) / detM
		Minv(2,2)    = M(1,1) / detM
	else
		write(0,*) 'WARNING, Matrix Determinat = 0 in MatInv2() Felipe'
	end if

end subroutine

 Subroutine MatInv3(Minv,detM,M)
	implicit none
	real*8, intent(in) :: M(3,3)
	real*8, intent(out) :: Minv(3,3), detM
	real*8 :: A1,B1,C1,A2,B2,C2,A3,B3,C3 ! minors
	real*8 , parameter :: tol = 10.0e-10

	A1 = M(3,3)*M(2,2) - M(3,2)*M(2,3)
	B1 = M(3,3)*M(2,1) - M(3,1)*M(2,3)
	C1 = M(3,2)*M(2,1) - M(3,1)*M(2,2)

	A2 = M(3,3)*M(1,2) - M(3,2)*M(1,3)
	B2 = M(3,3)*M(1,1) - M(3,1)*M(1,3)
	C2 = M(3,2)*M(1,1) - M(3,1)*M(1,2)

	A3 = M(2,3)*M(1,2) - M(2,2)*M(1,3)
	B3 = M(2,3)*M(1,1) - M(2,1)*M(1,3)
	C3 = M(2,2)*M(1,1) - M(2,1)*M(1,2)

	detM= M(1,1)*A1 - M(1,2)*B1 + M(1,3)*C1

	if (dabs(detM) > tol ) then
		Minv(1,1)    = A1 / detM
		Minv(1,2)    =-A2 / detM
		Minv(1,3)    = A3 / detM
		Minv(2,1)    =-B1 / detM
		Minv(2,2)    = B2 / detM
		Minv(2,3)    =-B3 / detM
		Minv(3,1)    = C1 / detM
		Minv(3,2)    =-C2 / detM
		Minv(3,3)    = C3 / detM
	else
		write(0,*) 'WARNING, Matrix Determinat = 0 in MatInv3() Felipe'
!~ 		call stop_error('WARNING, Matrix Determinat = 0 in MatInv3()')
	end if

end subroutine

subroutine printVec(v)
	real*8 :: v(:)
	integer n , i

	n = size(v)
	write(0,*) "=============="
	do i = 1, n
		write(0,"(e15.9)") v(i)
	end do
	write(0,*) "=============="

end subroutine

subroutine IprintVec(v)
	integer :: v(:)
	integer n , i

	n = size(v)
	write(0,*) "=============="
	do i = 1, n
		write(0,"(g15.5)") v(i)
	end do
	write(0,*) "=============="

end subroutine
!~
subroutine printMat(A)
	real*8 :: A(:,:)
	integer n , m, i , j

	n = size(A,1)
	m = size(A,2)

	write(0,*) "============================="
	do i = 1, n
		write(0,"(100(e15.6,1X))") ( A(i,j) , j = 1 , m)
!~ 		write(0,"(100(e15.5,2X))") ( A(i,j) , j = 1 , m)
	end do
	write(0,*) "============================="

end subroutine

subroutine IprintMat(A)
	integer :: A(:,:)
	integer n , m, i , j

	n = size(A,1)
	m = size(A,2)

	write(0,*) "=============================="
	do i = 1, n
		write(0,"(100I3)") ( A(i,j) , j = 1 , m)
!~ 		write(0,"(100g10.5)") ( A(i,j) , j = 1 , m)
	end do
	write(0,*) "=============================="

end subroutine

subroutine printTen(C)
	real*8 :: C(:,:,:,:)
	integer :: n , i , j , k , l

	n = size(C,1)
	write(0,*) "=============================="

	do i = 1, n
	do j = 1, n
	do k = 1, n
	do l = 1, n
		write(0,"(4(I1,1X),'=',e15.5)") i,j,k,l, C(i,j,k,l)
	end do
	end do
	end do
	end do
	write(0,*) "=============================="

end subroutine

Subroutine init_seed()
	implicit none
	Integer i , size_seed , clock
    Integer, dimension(:), allocatable :: seed

	call random_seed(size = size_seed)
	allocate(seed(size_seed))
	call system_clock(COUNT=clock)
	seed = clock + 37 * (/ (i - 1, i = 1, size_seed) /)
	call random_seed(put = seed)
	deallocate(seed)

End subroutine

subroutine setAEandBEfib(AE,BE,K,Res,NodG,idofT,iShiftU,NdimE)
	integer, intent(in) :: NodG,idofT,iShiftU,NdimE
	real*8 , intent(in) :: K(:,:), Res(:)
	real*8 , intent(out) :: AE(:,:), BE(:)
	Integer :: A, B, p, q, ApRow, BpCol, App, Bqp, signal

	Do A=1, NodG !LoopRow
		ApRow  = (A-1)*iDofT + iShiftU

		Do p = 1 , NdimE
			App = ApRow+p

			signal = (-1.0d0)**A

			BE(App) = signal*Res(p)

			do B= 1 , NodG ! LoopCol ! not considering the simmetry
				BpCol  = (B-1)*iDofT + iShiftU

				signal = (-1.0d0)**(A + B)
				do q=1,NdimE
					Bqp = BpCol+q

					AE(App,Bqp) = signal*K(p,q)

				end do ! loop Bq
			Enddo !LoopCol
		end do ! loop Ap
	Enddo !LoopRow

end subroutine

subroutine setAEandBE_lagrangeMultipliers(AE,BE,matB,matC,Sol1,eps,pen,NodG,NodLag,idofT,NdofLag,iShiftU,iShiftLag,NdimE)
	integer, intent(in) :: NodG,NodLag,idofT,NdofLag,iShiftU,iShiftLag,NdimE
	real*8 , intent(in) :: matB(:,:), matC(:,:), Sol1(*), eps,pen
	real*8 , intent(out) :: AE(:,:), BE(:)
	Integer :: A, B, p, q, ApRow, BpCol, App, Bqp, Apdim, AppDim

	B = NodLag
	BpCol = (B-1)*iDofT + iShiftLag

	Do A=1,NodG
		ApRow  = (A-1)*iDofT + iShiftU
		ApDim = (A-1)*NdimE

		Do p = 1 , NdimE
			App = ApRow+p
			AppDim = ApDim + p

			Do q = 1 , NdofLag
				Bqp = BpCol + q

				AE(Bqp,App) = pen*MatB(q,AppDim)
				AE(App,Bqp) = MatB(q,AppDim)

				AE(Bqp,Bqp) = MatC(q,q)

				BE(Bqp) = eps*Sol1(Bqp)

			end do
		end do ! loop Ap
	Enddo !LoopRow

end subroutine

! better version of setAEandBE_lagrangeMultipliers AE = [0 , B ; C , D] , BE = [0 , G]
subroutine setAEandBE_LM(AE,BE,matB,matC,matD,vecG,NodG,NodLag,idofT,NdofLag,iShiftU,iShiftLag,NdimE) !
	integer, intent(in) :: NodG,NodLag,idofT,NdofLag,iShiftU,iShiftLag,NdimE
	real*8 , intent(in) :: matB(:,:), matC(:,:), matD(:,:), vecG(:)
	real*8 , intent(out) :: AE(:,:), BE(:)
	Integer :: A, B, p, q, ApRow, BpCol, App, Bqp, Apdim, AppDim

	B = NodLag
	BpCol = (B-1)*iDofT + iShiftLag

	Do A=1,NodG
		ApRow  = (A-1)*iDofT + iShiftU
		ApDim = (A-1)*NdimE

		Do p = 1 , NdimE
			App = ApRow+p
			AppDim = ApDim + p

			Do q = 1 , NdofLag
				Bqp = BpCol + q

				AE(Bqp,App) = MatC(q,AppDim)
				AE(App,Bqp) = MatB(AppDim,q)

				AE(Bqp,Bqp) = MatD(q,q)

				BE(Bqp) = vecG(q)

			end do
		end do ! loop Ap
	Enddo !LoopRow

end subroutine

! more complete version of setAEandBE_LM AE = [0 , B ; C , D] , BE = [F , G]
subroutine setAEandBE_LM_full(AE,BE,matB,matC,matD,vecF,vecG,NodG,NodLag,idofT,NdofLag,iShiftU,iShiftLag,NdimE) !
	integer, intent(in) :: NodG,NodLag,idofT,NdofLag,iShiftU,iShiftLag,NdimE
	real*8 , intent(in) :: matB(:,:), matC(:,:), matD(:,:), vecG(:), vecF(:)
	real*8 , intent(out) :: AE(:,:), BE(:)
	Integer :: A, B, p, q, ApRow, BpCol, App, Bqp, Apdim, AppDim

	B = NodLag
	BpCol = (B-1)*iDofT + iShiftLag

	Do A=1,NodG
		ApRow  = (A-1)*iDofT + iShiftU
		ApDim = (A-1)*NdimE

		Do p = 1 , NdimE
			App = ApRow+p
			AppDim = ApDim + p

			BE(App) = VecF(AppDim)

			Do q = 1 , NdofLag
				Bqp = BpCol + q

				AE(Bqp,App) = MatC(q,AppDim)
				AE(App,Bqp) = MatB(AppDim,q)

				AE(Bqp,Bqp) = MatD(q,q)

				BE(Bqp) = vecG(q)

			end do
		end do ! loop Ap
	Enddo !LoopRow

end subroutine

subroutine setCoupling_lagrangeMultipliers(Coupling,NodG,NodLag,idofT,NdofLag,iShiftU,iShiftLag,NdimE)

	integer, intent(in) :: NodG,NodLag,idofT,NdofLag,iShiftU,iShiftLag,NdimE
	integer, intent(out) :: Coupling(:,:)
	Integer :: A, B, p, q, ApRow, BpCol, App, Bqp

	B = NodLag
	BpCol = (B-1)*iDofT + iShiftLag

	Do A=1,NodG
		ApRow  = (A-1)*iDofT + iShiftU

		Do p = 1 , NdimE
			App = ApRow+p

			Do q = 1 , NdofLag
				Bqp = BpCol + q
!~
				Coupling(App,Bqp) = 1
				Coupling(Bqp,App) = 1
				Coupling(Bqp,Bqp) = 1
			end do
		end do ! loop Ap
	Enddo !LoopRow

end subroutine

subroutine setCoupling_pureDisplacement(Coupling,NodG,idofT,iShiftU,NdimE)
	integer, intent(in) :: NodG,idofT,iShiftU,NdimE
	integer, intent(out) :: Coupling(:,:)
	Integer :: A, B, p, q, ApRow, BpCol

    do A = 1,NodG
        ApRow = (A-1) * iDofT + iShiftU

		do B = 1,NodG
			BpCol = (B-1) * iDofT + iShiftU

			do p=1,nDimE
			do q=1,nDimE

				Coupling (ApRow + p, BpCol + q) = 1

			enddo
            enddo
		enddo
	enddo

end subroutine

logical function isOnBoundary(y) result(flag)
	real*8, intent(in) :: y(:)
	real*8, parameter :: a = 0.0d0, b = 0.0d0 , c = 1.0d0 , d = 1.0d0, eps = 1.0e-10

	flag = .false.

	if(dabs(y(1) - a) < eps) then
		flag = .true.
	else if(dabs(y(2) - b) < eps) then
		flag = .true.
	else if(dabs(y(1) - c) < eps) then
		flag = .true.
	else if(dabs(y(2) - d) < eps) then
		flag = .true.
	end if

end function

subroutine getNormalBoundary(normal,flag,y)
	real*8, intent(out) :: normal(:)
	logical , intent(out) :: flag
	real*8, intent(in) :: y(:)
	real*8, parameter :: a = 0.0d0, b = 0.0d0 , c = 1.0d0 , d = 1.0d0, eps = 1.0e-10

	flag = .false.

	if(dabs(y(1) - a) < eps) then
		flag = .true.
		normal(1) = -1.0d0
		normal(2) = 0.0d0
	else if(dabs(y(2) - b) < eps) then
		flag = .true.
		normal(1) = 0.0d0
		normal(2) = -1.0d0
	else if(dabs(y(1) - c) < eps) then
		flag = .true.
		normal(1) = 1.0d0
		normal(2) = 0.0d0
	else if(dabs(y(2) - d) < eps) then
		flag = .true.
		normal(1) = 0.0d0
		normal(2) = 1.0d0
	end if

end subroutine

real*8 function norm2(v) result(normV)
	real*8, intent(in) :: v(:)

	normV = dsqrt(dot_product(v,v))

end function

subroutine setBlockToVector(A,B, NodG, iDofA, iDofB, iShiftA)
	real*8, intent(out) :: A(:)
	real*8, intent(in) :: B(:)
	integer , intent(in) :: NodG, iDofA, iDofB, iShiftA
	integer :: i,p,ipA,ipB

	do i=1, NodG !LoopRow
		ipA  = (i-1)*iDofA + iShiftA
		ipB  = (i-1)*iDofB

		do p = 1 , iDofB

			A(ipA + p) = B(ipB + p)

		end do ! loop Ap
	end do !LoopRow

end subroutine

subroutine setBlockToMatrixSquare(A,B, NodG, iDofA, iDofB, iShiftA)
	real*8, intent(out) :: A(:,:)
	real*8, intent(in) :: B(:,:)
	integer , intent(in) :: NodG, iDofA, iDofB, iShiftA

	call setBlockToMatrix(A,B,NodG,NodG, iDofA, iDofA, iDofB, iDofB, iShiftA, iShiftA)

end subroutine

subroutine setBlockToMatrix(A,B, NodGi,NodGj, iDofAi,iDofAj, iDofBi,iDofBj, iShiftAi, iShiftAj)
	real*8, intent(out) :: A(:,:)
	real*8, intent(in) :: B(:,:)
	integer , intent(in) :: NodGi,NodGj, iDofAi,iDofAj, iDofBi,iDofBj, iShiftAi, iShiftAj
	integer :: i,j,p,q,ipA,ipB,jqA,jqB

	do i=1, NodGi !LoopRow
		ipA  = (i-1)*iDofAi + iShiftAi
		ipB  = (i-1)*iDofBi

		do p = 1 , iDofBi

			do j= 1 , NodGj !
				jqA  = (j-1)*iDofAj + iShiftAj
				jqB  = (j-1)*iDofBj

				do q=1, iDofBj

					A(ipA + p, jqA + q) = B(ipB + p, jqB + q)

				end do ! loop Bq
			end do !LoopCol
		end do ! loop Ap
	end do !LoopRow

end subroutine

subroutine setBlockDiagonalConstantToMatrix(A,cte,NodG, iDofA, iDofB, iShiftAi, iShiftAj)
	real*8, intent(out) :: A(:,:)
	real*8, intent(in) :: cte
	integer , intent(in) :: NodG, iDofA, iDofB, iShiftAi, iShiftAj
	integer :: i,p,ipAi,ipAj

	Do i=1, NodG !LoopRow
		ipAi  = (i-1)*iDofA + iShiftAi
		ipAj  = (i-1)*iDofA + iShiftAj

		Do p = 1 , iDofB

			A(ipAi + p , ipAj + p) = cte

		end do ! loop Ap
	end do !LoopRow

end subroutine

subroutine setSimbolicBlockToMatrixSquare(A, NodG, iDofA, iDofB, iShiftA)
	integer, intent(out) :: A(:,:)
	integer , intent(in) :: NodG, iDofA, iDofB, iShiftA

	call setSimbolicBlockToMatrix(A,NodG,NodG, iDofA, iDofA, iDofB, iDofB, iShiftA, iShiftA)

end subroutine

subroutine setSimbolicBlockToMatrix(A,NodGi,NodGj, iDofAi,iDofAj, iDofBi,iDofBj, iShiftAi, iShiftAj)
	integer, intent(out) :: A(:,:)
	integer , intent(in) :: NodGi,NodGj, iDofAi,iDofAj, iDofBi,iDofBj, iShiftAi, iShiftAj
	integer :: i,j,p,q,ipA,jqA

	do i=1, NodGi !LoopRow
		ipA  = (i-1)*iDofAi + iShiftAi

		do p = 1 , iDofBi

			do j= 1 , NodGj !
				jqA  = (j-1)*iDofAj + iShiftAj

				do q=1, iDofBj

					A(ipA + p, jqA + q) = 1

				end do ! loop Bq
			end do !LoopCol
		end do ! loop Ap
	end do !LoopRow

end subroutine

subroutine setSimbolicBlockDiagonalToMatrix(A,NodG, iDofA, iDofB, iShiftAi, iShiftAj)
	integer, intent(out) :: A(:,:)
	integer , intent(in) :: NodG, iDofA, iDofB, iShiftAi, iShiftAj
	integer :: i,p,ipAi,ipAj

	Do i=1, NodG !LoopRow
		ipAi  = (i-1)*iDofA + iShiftAi
		ipAj  = (i-1)*iDofA + iShiftAj

		Do p = 1 , iDofB

			A(ipAi + p , ipAj + p) = 1

		end do ! loop Ap
	end do !LoopRow

end subroutine

subroutine voigtTen4toTen2(V,W)
	real*8 , intent(out) :: V(:,:)
	real*8 , intent(in) :: W(:,:,:,:)

	integer , parameter :: n = 2, n2 = 4
	integer :: voigtMapI(n2), voigtMapJ(n2)

	voigtMapI = (/1,1,2,2/)
	voigtMapJ = (/1,2,1,2/)

	do i = 1,n2
	do j = 1,n2
		V(i,j) = W(voigtMapI(i),voigtMapJ(i),voigtMapI(j),voigtMapJ(j))
	end do
	end do

end subroutine

subroutine voigtTen2toVec(V,W)
	real*8 , intent(out) :: V(:)
	real*8 , intent(in) :: W(:,:)

	integer , parameter :: n = 2, n2 = 4
	integer :: voigtMapI(n2), voigtMapJ(n2)

	voigtMapI = (/1,1,2,2/)
	voigtMapJ = (/1,2,1,2/)

	do i = 1,n2
		V(i) = W(voigtMapI(i),voigtMapJ(i))
	end do

end subroutine

subroutine getNormal(n,flag)
	implicit none
	integer, intent(in) :: flag
	real*8 , intent(out) :: n(2,2) ! it may have two normals

	n = 0.0d0

	select case(flag)

		case(1)
			n(1,1) = 0.0d0 ; n(2,1) = -1.0d0
		case(2)
			n(1,1) = 1.0d0 ; n(2,1) = 0.0d0
		case(3)
			n(1,1) = 0.0d0 ; n(2,1) = 1.0d0
		case(4)
			n(1,1) = -1.0d0 ; n(2,1) = 0.0d0
		case(5)
			n(1,1) = -1.0d0 ; n(2,1) = 0.0d0
			n(1,2) = 0.0d0 ; n(2,2) = -1.0d0
		case(6)
			n(1,1) = 1.0d0 ; n(2,1) = 0.0d0
			n(1,2) = 0.0d0 ; n(2,2) = -1.0d0
		case(7)
			n(1,1) = 1.0d0 ; n(2,1) = 0.0d0
			n(1,2) = 0.0d0 ; n(2,2) = 1.0d0
		case(8)
			n(1,1) = -1.0d0 ; n(2,1) = 0.0d0
			n(1,2) = 0.0d0 ; n(2,2) = 1.0d0
	end select

end subroutine

real*8 function solveQuadraticEquation(a,b,c,sig) result(x)
	real*8 , intent(in) :: a,b,c
	integer , intent(in) :: sig
	real*8 :: Delta

	Delta = b*b - 4.0d0*a*c
	x = (-b + sig * dsqrt(Delta))/(2.0d0*a)

end function

function transposeT4(A) result(B)
	real*8, intent(in) :: A(:,:,:,:)
	real*8 , allocatable :: B(:,:,:,:)
	integer :: n1 , n2, n3, n4, i, j, k, l

	n1 = size(A,1)
	n2 = size(A,2)
	n3 = size(A,3)
	n4 = size(A,4)

	allocate(B(n4,n3,n2,n1))

	do i = 1, n1
	do j = 1, n2
	do k = 1, n3
	do l = 1, n4
		B(l,k,j,i) = A(i,j,k,l)
	end do
	end do
	end do
	end do

end function

subroutine FindKeyword(ioUnit,str1)
! Str1: String to find, ioUnit: Unit assigned to Input File
	Character(*) str1,str2*120
	integer :: n , iError, ioUnit

!	rewind(IoUnit)
	iError=0
	n = Len_Trim(str1)
	!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
	do while (.true.)
		read(ioUnit, "(1A120)",iostat=iError) str2
		if (iError.lt.0 ) then
			write(0,*) "Keyword not finded"
			STOP
		end if
		if ( str2(1:n) == str1(1:n) )  exit
	end do

end subroutine

end module


c     tmpl matching to calculate sigma_TOA, for rms calu both assuming re-chi^2=1 and from baseline in frequency domain

      subroutine tmplmatch(profile,template,nbins,shift,eshift,
     +                     eshift2,scale)

      implicit none

      integer nbins
      real*8 profile(nbins),template(nbins)
      real*8 eshift, shift, snr, esnr,eshift2,scale
      real*8 amp(nbins/2), pha(nbins/2)

      call makeFtempl(amp,pha,template,nbins)

c-----Do the frequency domain template fit, get shift in rad
      call fftfit(profile,amp,pha,nbins,shift,eshift,snr,esnr,
     +            eshift2,scale)

c     if(snr<5.0) write(*,*)"Warning: individual channel SNR low"

      return
      end

ccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine makeFtempl(amp,pha,da,nbins)

C     Converts a standard profile into normalized harmonic-squared form
c
c     based on a subroutine by AW
c

      implicit none

      integer maxsam,i,nh,ipos, nbins
      real*8 fixoff, twopi,da,amp,pha,pmax

      parameter (MAXSAM=4096,twopi=3.141592653589793*2,fixoff=0.0)

      dimension da(nbins),amp(MAXSAM/2),pha(MAXSAM/2)

      complex cstd(0:MAXSAM/2)

      nh=nbins/2

c-------Computefrequency-domaintemplate
      call cprof_old(da,nbins,nh,cstd,amp,pha)

      end

ccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	subroutine cprof_old(y,nmax,nh,c,amp,pha)

C  Compute FFT of profile in array y(nmax), and return amplitude and phase
C  in arrays amp(nh) and pha(nh).  Note that nh=nmax/2, and that the DC term
C  is returned in c(0), fundamental in c(1), ..., Nyquist freq in c(nh).

	parameter(MAXSAM=4096)
	real*8 y(nmax),amp(nh),pha(nh)
	complex c(0:nh),temp(MAXSAM)

	do 10 i=1,nh
10	 temp(i)=cmplx(y(2*i-1),y(2*i))
	call ffft_cdft(temp,nmax,1,1)
	c(0)=temp(1)
	do 20 i=1,nh
	 c(i)=temp(i+1)
	 amp(i)=cabs(c(i))
	 pha(i)=0.
20	if(amp(i).gt.0.) pha(i)=aimag(clog(c(i)))
	return
	end
ccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	subroutine fftfit(prof,s,phi,nmax,shift,eshift,snr,esnr,eshift2,scale)

C  Fourier transform domain routine for determining pulse TOAs.
C  Input data:
C	prof(nmax)	profile
C	s(nh)		standard profile amplitude
C	phi(nh)	standard profile phase
C	nmax		length of prof

C  Outputs:
C	shift		shift required to align std with prof, in bins
C	eshift	uncertainty in shift
C	snr		signal to noise ratio of prof
C	esnr		uncertainty in snr

C  Method:
C  It is assumed that prof(j)=a + b*std(j-tau) + noise(j), where the
C  (j-tau) subscript is supposed to mean that the time-shift between the
C  observed and standard profiles need not be an integer number of bins.
C  The algorithm is a straightforward Chi-squared minimization with respect
C  to a, b, and tau.  (The result for a, being of no physical or instrumental
C  interest, is not actually evaluated -- though it easily could be.)
C  First and second partial derivatives of Chisqr with respect to b and tau
C  are computed, and used to evaluate s, snr, and their "standard errors,"
C  or one-sigma uncertainties.  The only special trick is that the expression
C  for the best-fit value of tau defines it implicitly, and cannot be solved
C  analytically.  It is solved numerically instead, finding the minimum of
C  Chisqr near a best guess from a CCF at 32 lags done in the Fourier domain.

C  Also note that it may
C  be desirable to return the scale factor b relating prof to std, instead
C  of snr.  In that case you could also return the noise estimate rms.
c
c  Changed a lower bound to iterate the transcendental equation from 5 to 4,
c  in accord with changing nprof from 64 to 32 in fccf32.f.
c  AW, March 1992.

	parameter (twopi=3.141592653589793*2,MAXSAM=4096)
	real*8 prof(MAXSAM),p(MAXSAM/2),theta(MAXSAM/2)
	real*8 s(MAXSAM/2),phi(MAXSAM/2),r(MAXSAM/2),tmp(MAXSAM/2)
        real*8 shift,eshift,snr,esnr,eshift2,scale
	complex cp(0:MAXSAM/2)
	logical low,high

c       if (phi(1).ne.0) then
c	  write (0,*) ' Phase of fundamental not zero, check .hm file'
c	  stop
c	end if

	nh=nmax/2
	call cprof_old(prof,nmax,nh,cp,p,theta)

        rmsbegin =nh/8*5
c       calculate rms from the high frequency harmonics
        readrms=0.0
        do i=rmsbegin,nh
           readrms=readrms+(p(i))**2
        end do
        readrms=sqrt(readrms/(nh-rmsbegin+1))

c-------DefineTOAsuch that phase of fundamental = 0
c       do i=1,nh
c        theta(i)=mod(theta(i)-float(i)*theta(1),twopi)
c       enddo

	do 10 k=1,nh
	 tmp(k)=p(k)*s(k)
10	 r(k)=theta(k)-phi(k)

        fac=nmax/twopi

	call fccf_cdft(tmp,r,shift)

C  The "DO 60" loop solves the transcendental equation yielding the best-fit
C  value of tau.  Here the number starts at 16 (number used in CCF)
C  and increases by factors of 2, at each step finding the function
C  zero closest to the starting point from the previous iteration.

 	tau=shift

	do 60 isum=4,99
	 nsum=2.0**isum
	 if(nsum.gt.nh) go to 70
	 dtau=twopi/(nsum*5)
	 edtau=1./(2.*nsum+1.)
         if (nsum.gt.(nh/2.+.5)) edtau=1.e-5

	 ntries=0
	 low=.false.
	 high=.false.
50	 ftau=dchisqr(tau,tmp,r,nsum)
	 ntries=ntries+1
	 if(ftau.lt.0.0) then
	   a=tau
	   fa=ftau
	   tau=tau+dtau
	   low=.true.
	 else
	   b=tau
	   fb=ftau
	   tau=tau-dtau
	   high=.true.
	 end if
	 if (ntries.gt.10) then
	   shift=0.
	   eshift=999.
	   snr=0.
	   esnr=0.
	   return
	 end if
	 if (low.neqv.high) go to 50
	 tau=zbrent(a,b,fa,fb,edtau,tmp,r,nsum)
60	continue

70	s1=0.
	s2=0.
	s3=0.
	do 80 k=1,nh
	 cosfac=cos(-r(k)+k*tau)
	 s1=s1 + tmp(k)*cosfac
	 s2=s2 + s(k)**2
80	 s3=s3 + k**2 *tmp(k)*cosfac
	b=s1/s2
	s1=0.
	do 90 k=1,nh
	 sq=p(k)**2-2.*b*p(k)*s(k)*cos(r(k)-k*tau)+(b*s(k))**2
90	 if(s(k).ne.0.) s1=s1+sq
	rms=sqrt(s1/nh)
	errb=rms/sqrt(2.0*s2)
	errtau=rms/sqrt(2.0*b*s3)
	snr=2.0*sqrt(2.0*nh)*b/rms

	shift=tau
	eshift=errtau
	esnr=snr*errb/b
        scale=b

c       new eshift from readrms
	errtau=readrms/sqrt(2.0*b*s3)
        eshift2=errtau

        rchisq = (s1/readrms**2)/(nh-3)
c       write(*,*)"rms (re chi^2=1):",rms," real:",readrms,
c    +  " re chi^2:",rchisq

	return
	end
ccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	subroutine fccf_cdft(amp,pha,shift)

C  Calculates CCF in Fourier domain using 8 harmonics of amp and pha arrays
C  amp=p*s,pha=theta-phi.  Finds maximum of CCF at 32 lags over the pulsar
C  period, and returns value of shift in radians.
c
c  Changed nprof from 64 to 32 (and all the appropriate hardwired constants)
c  to deal with 32-point profiles.  AW -- March 1992

	parameter (nprof=32,nprof1=nprof-1)
	parameter (MAXSAM=4096,twopi=3.141592653589793*2)
	real*8 amp(MAXSAM/2),pha(MAXSAM/2),shift
	complex ccf(0:nprof1)

	nh=nprof/2
	ccf(0)=(0.,0.)
	do 10 i=1,nh/2
	 ccf(i)=cmplx(amp(i)*cos(pha(i)),amp(i)*sin(pha(i)))
10	 ccf(nprof-i)=conjg(ccf(i))
	do 20 i=nh/2+1,nh
	 ccf(i)=(0.,0.)
20	 ccf(nprof-i)=(0.,0.)
	call ffft_cdft(ccf,nprof,-1,0)
	cmax=-1.e30
	do 30 i=0,nprof1
	 rc=real(ccf(i))
	 if (rc.gt.cmax) then
	   cmax=rc
	   imax=i
	 end if
30	continue

	fb=cmax
	ia=imax-1
	if(ia.eq.-1) ia=nprof-1
	fa=real(ccf(ia))
	ic=imax+1
	if(ic.eq.nprof) ic=0
	fc=real(ccf(ic))
	if ((2*fb-fc-fa).ne.0) then
	  shift=imax+0.5*(fa-fc)/(2*fb-fc-fa)
	else
	  shift=imax
	end if
c	if(shift.gt.nh) shift=shift-nprof
	shift=shift*twopi/nprof

	return
	end
ccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	function zbrent(x1,x2,f1,f2,tol,tmp,pha,nsum)

C Brent's method root finding, calls dchisqr(x,tmp,r,nsum) function for fftfit
C Fit refined till output accuracy is tol

	parameter (itmax=100,eps=6.e-8,MAXSAM=4096)
	real*8 tmp(MAXSAM/2),pha(MAXSAM/2)

	a=x1
	b=x2
	fa=f1
	fb=f2
	fc=fb
	do 11 iter=1,itmax
	if(fb*fc.gt.0.) then
	  c=a
	  fc=fa
	  d=b-a
	  e=d
	end if
	if(abs(fc).lt.abs(fb)) then
	  a=b
	  b=c
	  c=a
	  fa=fb
	  fb=fc
	  fc=fa
	end if
	tol1=2.*eps*abs(b)+0.5*tol
	xm=.5*(c-b)
	if(abs(xm).le.tol1 .or. fb.eq.0.) then
	  zbrent=b
	  return
	end if
	if(abs(e).ge.tol1 .and. abs(fa).gt.abs(fb)) then
	  s=fb/fa
	  if(a.eq.c) then
	    p=2.*xm*s
	    q=1.-s
	  else
	    q=fa/fc
	    r=fb/fc
	    p=s*(2.*xm*q*(q-r)-(b-a)*(r-1.))
	    q=(q-1.)*(r-1.)*(s-1.)
	  end if
	  if(p.gt.0.) q=-q
	  p=abs(p)
	  if(2.*p .lt. min(3.*xm*q-abs(tol1*q),abs(e*q))) then
	    e=d
	    d=p/q
	  else
	    d=xm
	    e=d
	  end if
	else
	  d=xm
	  e=d
	end if
	a=b
	fa=fb
	if(abs(d) .gt. tol1) then
	  b=b+d
	else
	  b=b+sign(tol1,xm)
	end if
	fb=dchisqr(b,tmp,pha,nsum)
11	continue
	zbrent=b
	return
	end

	function dchisqr(tau,tmp,r,nsum)

	parameter (MAXSAM=8192)
	real*8 tmp(MAXSAM/2),r(MAXSAM/2)

	s=0.
	do 40 k=1,nsum
40	 s=s+k*tmp(k)*sin(-r(k)+k*tau)
	dchisqr=s
	return
	end

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc


subroutine solve_laplace(source,nsd,nn,nn_solid,ien,ne,nen,x_fluid,node_sbc,nn_sbc,I_fluid,flag_fnode)
! 1 decide interior, outer, boundary fluid nodes
! 2 set id matrix for laplace equation
! 3 sovle for laplace equation
use delta_nonuniform, only: cnn, ncnn
real(8) source(nsd,nn)
integer nsd
integer nn
integer nn_solid
integer ien(nen,ne)
integer ne
integer nen
integer node_sbc(nn_sbc)
integer nn_sbc
real(8) x_fluid(nsd,nn)
real(8) I_fluid(nn)
integer flag_fnode(nn)
!----------------------
integer flag_node(nn)
integer flag_el(ne)
integer i
integer j
integer inn
integer count_el
integer, allocatable ::  lp_el(:)
integer node
real(8) dg(nn)
integer lp_id(nn)
real(8) p_inter(nn)
real(8) w_inter(nn)
integer icount

flag_node(:)=0 ! set out node
flag_el(:)=0
p_inter(:)=0.0
w_inter(:)=0.0
dg(:)=0.0

lp_id(:)=0
I_fluid(:)=0.0

do i=1,nn_solid
	do j=1,ncnn(i)
		node=cnn(j,i)
		flag_node(node)=1 ! set interior node
		I_fluid(node)=1.0
	end do
end do

do i=1,nn_sbc
	inn=node_sbc(i)
	do j=1,ncnn(inn)
		node=cnn(j,inn)
		flag_node(node)=2 ! set boundary node
		I_fluid(node)=0.0
	end do
end do
!------------------------
! reset inside boundary based on fnode
!do i=1,nn
!        if (flag_fnode(i) == 1) then
!                I_fluid(i)=1.0
!                flag_node(i)=1
!        end if
!end do

count_el=0
do i=1,ne
	do j=1,nen
		node=ien(j,i)
		if (flag_node(node) .eq. 2) then
		lp_id(node)=1  ! set id vector for laplace eq
		flag_el(i)=1 ! elements need to be looped
		else
		w_inter(node)=1.0 ! prevent diagonal preconditioner to be zero
		end if
	end do
	if (flag_el(i) == 1) then
		count_el=count_el+1
	end if
end do

allocate(lp_el(count_el))
!do i=1,nn
!write(*,*) 'id flag_node', i, flag_node(i)
!end do
count_el=0

do i=1,ne
	if (flag_el(i) == 1) then
		count_el=count_el+1
		lp_el(count_el)=i ! element index needs to be looped
	end if
end do

!open(unit=8406, file='lpsource.txt', status='new')
!do i=1,nn_solid
!j=ncnn(i)
!write(8406,*) 'cnn', i,j,'aaa', cnn(1:J,i)
!end do
!close(8406)
!source(:,:)=0.0

call block_Laplace(x_fluid,I_fluid,p_inter,w_inter,ien,lp_el,count_el,source)
continue
call setid(p_inter,lp_id,1)

!open(unit=8406, file='source.txt', status='unknown')
!do i=1,nn
!j=ncnn(i)
!write(8406,*) 'node', i ,'lp_id', lp_id(i), 'source', source(:,i)
!end do
!close(8406)

!write(*,*) 'w_inter', minval( w_inter(:)), maxval(w_inter(:))

call gmres_Laplace(x_fluid,I_fluid,w_inter,p_inter,dg,ien,lp_id,lp_el,count_el)

!do i=1,nn
	!write(*,*) 'dg', maxval(dg(:)), minval(dg(:))
!end do

dg(:) = abs(dg(:)) / maxval(dg(:))

    I_fluid(:)=dg(:)+I_fluid(:)
return

deallocate(lp_el)
end


C
C	$Id: srface.f,v 1.5 2008-07-27 00:17:26 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE SRFACE (X,Y,Z,M,MX,NX,NY,S,STEREO)
C
C DIMENSION OF           X(NX),Y(NY),Z(MX,NY),M(2,NX,NY),S(6)
C ARGUMENTS
C
C PURPOSE                SRFACE draws a perspective picture of a
C                        function of two variables with hidden lines
C                        removed.  The function is approximated by a
C                        two-dimensional array of heights.
C
C USAGE                  If the following assumptions are met, use
C
C                             CALL EZSRFC (Z,M,N,ANGH,ANGV,WORK)
C
C                          assumptions:
C                              .the entire array is to be drawn,
C                              .the data are equally spaced (in the
C                               X-Y plane),
C                              .no stereo pairs,
C                              .scaling is chosen internally.
C
C                        If these assumptions are not met use
C
C                             CALL SRFACE (X,Y,Z,M,MX,NX,NY,S,
C                                          STEREO)
C
C ARGUMENTS
C
C ON INPUT               Z
C FOR EZSRFC               The M by N array to be drawn.
C
C                        M
C                          The first dimension of Z.
C
C                        N
C                          The second dimension of Z.
C
C                        ANGH
C                          Angle in degrees in the X-Y plane to the
C                          line of sight (counter-clockwise from
C                          the plus-X axis).
C
C                        ANGV
C                          Angle in degrees from the X-Y plane to
C                          the line of sight (positive angles are
C                          above the middle Z, negative below).
C
C                        WORK
C                          A scratch storage dimensioned at least
C                          2*M*N+M+N.
C
C ON OUTPUT              Z, M, N, ANGH, ANGV are unchanged.  WORK
C FOR EZSRFC             has been written in.
C
C
C ARGUMENTS
C
C ON INPUT               X
C FOR SRFACE               A linear array NX long containing the X
C                          coordinates of the points in the surface
C                          approximation, in increasing numerical order.
C                          See note, below.
C
C                        Y
C                          A linear array NY long containing the Y
C                          coordinates of the points in the surface
C                          approximation, in increasing numerical order.
C                          See note, below.
C
C                        Z
C                          An array MX by NY containing the surface
C                          to be drawn in NX by NY cells.
C                          Z(I,J) = F(X(I),Y(J)).  See note, below.
C
C                        M
C                          Scratch array at least 2*NX*NY words
C                          long.
C
C                        MX
C                          First dimension of Z.
C
C                        NX
C                          Number of data values in the X direction
C                          (the first subscript direction) in Z.
C                          to be plotted. When plotting an entire
C                          array, MX=NX.
C
C                        NY
C                          Number of data values in the Y direction
C                          (the second subscript direction) to be
C                          plotted.
C
C                        S
C                          S defines the line of sight.  The viewer's
C                          eye is at (S(1), S(2), S(3)) and the
C                          point looked at is at (S(4), S(5), S(6)).
C                          The eye should be outside the block with
C                          opposite corners (X(1), Y(1), ZMIN) and
C                          (X(NX), Y(NY), ZMAX) and the point looked
C                          at should be inside it.  For a nice
C                          perspective effect, the distance between
C                          the eye and the point looked at should be
C                          5 to 10 times the size of the block.  See
C                          note, below.
C
C                        STEREO
C                          Flag to indicate if stereo pairs are to
C                          be drawn.  0.0 means no stereo pair (one
C                          picture).  Non-zero means put out two
C                          pictures.  The value of STEREO is the
C                          relative angle between the eyes.  A value
C                          of 1.0 produces standard separation.
C                          Negative STEREO reverses the left and
C                          right figures.  See the documentation below
C                          for internal variable ISTP for additional
C                          information.
C
C ON OUTPUT              X, Y, Z, MX, NX, NY, S, STEREO are
C FOR SRFACE             unchanged.  M has been written in.
C
C NOTES                  . The range of Z compared with the range
C                          of X and Y determines the shape of the
C                          picture.  They are assumed to be in the
C                          same units and not wildly different in
C                          magnitude.  S is assumed to be in the
C                          same units as X, Y, and Z.
C                        . Picture size can be made relative to
C                          distance.  See comments in SETR.
C                        . TRN32S can be used to translate from 3
C                          space to 2 space.  See comments there.
C                        . Data with extreme discontinuities may
C                          cause visibility errors.  If this problem
C                          occurs, use a distant eye position
C                          away from the +Z axis.
C                        . The default line color is set to
C                          color index 1.  If the user wishes to
C                          change the line color, he can do so by
C                          defining color index 1 before calling
C                          SRFACE, or by putting the common block
C                          SRFINT in his calling program and
C                          defining and using color index ISRFMJ
C                          (defaulted to 1 in BLOCKDATA.)
C
C ENTRY POINTS           SRFACE, SRFGK, EZSRFC, SETR, DRAWS, TRN32S,
C                        CLSET, CTCELL, SRFABD
C
C COMMON BLOCKS          SRFACE, SRFINT, SRFBLK, PWRZIS, SRFIP1
C
C REQUIRED LIBRARY       The SPPS.
C ROUTINES
C
C REQUIRED GKS LEVEL     0A
C
C I/O                    Plots
C
C PRECISION              Single
C
C LANGUAGE               FORTRAN
C
C HISTORY                Converted to FORTRAN 77 and GKS in March 1984.
C
C                        Prepared for SIGGRAPH, August 1976.
C
C                        Standardized in January 1973.
C
C                        Written in December 1971.  Replaced K.S.+G.
C                        algorithm called SOLIDS at NCAR.
C
C
C ALGORITHM              The data are processed from the near side of
C                        of the surface to the far side.  Visibility
C                        information is stored (see reference.)
C                        Highest so far is visible from above.
C
C REFERENCE              Wright, T.J., A Two Space Solution to the
C                        Hidden Line Problem for Plotting a Function
C                        of Two Variables.  IEEE Trans. Comp.,
C                        pp 28-33, January 1973.
C
C ACCURACY               If the ends of a line segment are visible,
C                        the middle is assumed visible.
C
C TIMING                 Proportional to NX*NY.
C
C
C INTERNAL PARAMETERS    name   default  function
C                        ----   -------  --------
C                        IFR        1    -1  Call FRAME first.
C                                         0  Do not call FRAME.
C                                        +1  Call FRAME when done.
C
C                        ISTP       0    STEREO type if STEREO
C                                        non-zero.
C                                        -1  Alternating frames,
C                                            slightly offset (for
C                                            movies,  IROTS = 0).
C                                         0  Blank frame between
C                                            for stereo slide.
C                                            IROTS = 1).
C                                        +1  Both on same frame.
C                                            (left picture to left
C                                            side.  IROTS = 0).
C
C                        IROTS      0     0  +Z in vertical plotting
C                                            direction (CINE mode).
C                                        +1  +Z in horizontal
C                                            plotting direction
C                                            (COMIC mode).
C
C                        IDRX       1    +1  Draw lines of constant
C                                            X.
C                                         0  Do not.
C
C                        IDRY       1    +1  Draw lines of constant
C                                            Y.
C                                         0  Do not.
C
C                        IDRZ       0    +1  Draw lines of constant
C                                            Z (contour lines).
C                                         0  Do not.
C
C                        IUPPER     0    +1  Draw upper side of
C                                            surface.
C                                         0  Draw both sides.
C                                        -1  Draw lower side.
C
C                        ISKIRT     0    +1  Draw a skirt around the
C                                            surface.
C                                            BOTTOM = HSKIRT.
C                                         0  Do not.
C
C                        NCLA       6    Approximate number of
C                                        levels of constant Z that
C                                        are drawn if levels are not
C                                        specified.  40 levels
C                                        maximum.
C
C                        THETA    .02    Angle, in radians, between
C                                        eyes for stereo pairs.
C
C                        HSKIRT    0.    Height of skirt
C                                            (if ISKIRT = 1).
C
C                        CHI       0.    Highest level of constant
C                                        Z.
C
C                        CLO       0.    Lowest level of constant Z.
C
C                        CINC      0.    Increment between levels.
C
C                          [If CHI, CLO, or CINC is zero, a nice
C                           value is generated automatically.]
C
C                        IOFFP     0     Flag to control use of special
C                                        value feature.  Do not have
C                                        both IOFFP=1 and ISKIRT=1.
C                                         0 Feature not in use
C                                        +1  Feature in use.  No lines
C                                            drawn to data points in Z
C                                            that are equal to SPVAL.
C
C                        SPVAL     0.    Special value used to mark un-
C                                        known data when IOFFP=1.
C
C
C
      DIMENSION       X(NX)      ,Y(NY)      ,Z(MX,NY)   ,M(2,NX,NY) ,
     1                S(6)
      DIMENSION       WIND(4)    ,VIEW(4)    ,LASF(13)
      COMMON /SRFINT/ ISRFMJ     ,ISRFMN     ,ISRFTX
C
C  Do a call forcing a BLOCKDATA to be loaded from a binary library.
C
      CALL SRFABD
C
      CALL Q8QST4 ('GRAPHX','SRFACE','SRFACE','VERSION 01')
C
C     THIS DRIVER SAVES THE CURRENT NORMALIZATION TRANSFORMATION
C     INFORMATION, DEFINES THE NORMALIZATION TRANSFORMATION
C     APPROPRIATE FOR SRFGK, CALLS SRFGK, AND RESTORES THE ORIGINAL
C     NORMALIZATION TRANSFORMATION.
C
C     Save current SET parameters.
C
      CALL GETSET (VIEW(1),VIEW(2),VIEW(3),VIEW(4),
     +             WIND(1),WIND(2),WIND(3),WIND(4),IOLLS)
C
C
C
C
C
C     SET WINDOW AND VIEWPORT FOR SRFGK
C
      CALL SET(0.,1.,0.,1.,1.,1024.,1.,1024.,1)
C
C     SET LINE COLOR TO INDIVIDUAL (SAVE CURRENT SETTING)
C
      CALL GQASF (IER,LASF)
      LASFSV  = LASF(3)
      LASF(3) = 1
      CALL GSASF(LASF)
C
C     SET LINE COLOR INDEX TO COMMON VARIABLE ISRFMJ (SAVE
C     CURRENT SETTING)
C
      CALL GQPLCI (IER,LCISV)
      CALL GSPLCI (ISRFMJ)
C
C     DRAW PLOT
C
      CALL SRFGK (X,Y,Z,M,MX,NX,NY,S,STEREO)
C
C     RESTORE INITIAL LINE COLOR SETTINGS
C
      LASF(3) = LASFSV
      CALL GSASF(LASF)
      CALL GSPLCI (LCISV)
C
C     RESTORE ORIGINAL NORMALIZATION TRANSFORMATION
C
      CALL SET(VIEW(1),VIEW(2),VIEW(3),VIEW(4),
     +         WIND(1),WIND(2),WIND(3),WIND(4),IOLLS)
C
C
      RETURN
      END


*deck dnode
      subroutine dnode(k,a,rt)
c
c  return in rt(i) the ith root of a polynomial
c  of order k whose mth coefficient is stored in a(m+1).
c  the initial values in rt must bracket the final values.
c
*mdc*if real16 vax cray ibm
*      implicit real*16 (a-h,o-z)
*mdc*else
      implicit real*8 (a-h,o-z)
*mdc*endif
*mdc*if real16q ibm vax
*c *** this mdc block is not necessary since the constants will be ***
*c *** correctly converted at compile time.  should it be removed? ***
*      parameter (a0=0.0q0, a1s16=6.25q-2, a1s4=0.25q0, a3s4=0.75q0)
*mdc*else
      parameter (a0=0.0d0, a1s16=6.25d-2, a1s4=0.25d0, a3s4=0.75d0)
*mdc*endif
*mdc*if cray
*      parameter (accrt=1.0d-21)
*mdc*elseif real16q vax ibm rs6000 fujitsu
*      parameter (accrt=1.0q-21)
*mdc*else
      parameter (accrt=1.0d-12)
*mdc*endif
c
      integer   nunits
      parameter(nunits=4)
      integer        iunits
      common /units/ iunits(nunits)
      integer                  nlist
      equivalence ( iunits(1), nlist )
c
c     common /ffm/ x,nn,n1,k
      dimension a(*), rt(*)
c
c     # bummer error types.
      integer    wrnerr,  nfterr,  faterr
      parameter (wrnerr=0,nfterr=1,faterr=2)
c
      k1=k+1
      r2=a0
      p2=a(1)
      do 95 m=1,k
      r1=r2
      p1=p2
      r2=rt(m)
      p2=a(k1)
      do 10 i=1,k
        p2=p2*r2+a(k1-i)
   10 continue
      prod=p1*p2
      if(prod.ge.a0) then
        write (nlist,15) m,k
   15   format(/' dnode: root number',i4,
     +    ' was not found for polynomial of order',i4//)
        call bummer('dnode: root not found, m=',m,faterr)
      endif
c
      r5=r1
      p5=p1
      r6=r2
      p6=p2
   30 r3=r5
      p3=p5
      r4=r6
      p4=p6
      r =(r3*p4-r4*p3)/(p4-p3)
      dr=r4-r3
      delta=dr
      dr = a1s16 * dr
      r5=r-dr
      r6=r+dr
      if(abs(delta).lt.accrt.or.r5.eq.r.or.r6.eq.r) go to 90
      if(r5.lt.r3) r5=r3
      if(r6.gt.r4) r6=r4
      p5=a(k1)
      p6=p5
      do 40 i=1,k
        p5=p5*r5+a(k1-i)
        p6=p6*r6+a(k1-i)
   40 continue
   45 prod=p5*p6
      if(prod.lt.a0) go to 30
      prod=p3*p5
      if(prod.gt.a0) go to 60
      r5=a1s4*r3+a3s4*r5
      p5=a(k1)
      do 50 i=1,k
        p5=p5*r5+a(k1-i)
   50 continue
      go to 45
   60 r6=a1s4*r4+a3s4*r6
      p6=a(k1)
      do 70 i=1,k
        p6=p6*r6+a(k1-i)
   70 continue
      go to 45
   90 rt(m)=r
   95 continue
      return
      end


!
!
!
!   "Green's function and coupled cluster calculations of spectral function
!  for a pairing model"
!
!
!   This code is based on the lectures of the TALENT school, course #2, held at
!  GANIL on July 6th-24th, 2015 and it has been later improved to perform the
!  benchmark calcuations presented in chapters 8 and 11 of the Lecture Notes
!  in Physics
!
!
!   This version uses the SCGF and CC methods to solve the toy pairing model
!  with 4 levels and 4 spin-1/2 particles that was introduced during the first
!  week of the Talent lectures (see
!   http://nucleartalent.github.io/Course2ManyBodyMethods/doc/web/course.html )
!  and in chapters 8 and 11 of the above book. The present version on the code
!  is publishes under the GNU general public licence and it is available at:
!  https://github.com/ManyBodyPhysics/LectureNotesPhysics/blob/master/doc/src/Chapter11-programs/Pair_Model
!
!   If you are using this software (or any part of it) for publication, we ask
!  you that its origin is formally acknowledged by citing the following chapter:
!
!   C. Barbieri and A. Carbone, "Self-consistent Green's function approaches",
!  chapter 11 of Lecture Notes in Physics "An advanced course in computational
!  nuclear physics: Bridging the scales from quarks to neutron stars",
!  Edited by Hjorth-Jensen, M. P. Lombardo, U. van Kolck, Editors
!  ISBN:
!  http://arxiv.org/abs/1611.03923
!
!
!
!
!   Calculations can be done at different levels of SCGF theory by using the ADC(2)
!  approach at second order, by adding all order resummations of the two-particle
!  and two-hole ladders [the so-called 2p1h-TDA, which is an extension of ADC(2)],
!  in the full ADC(3) approximation and finally by adding CCD corrections to
!  obtain the ADC(3)-D scheme.
!
!   It also iterates the energy independent self-energy (i.e. the 'correlated HF'
!  diagram with the dressed propagator to achieve self-consistency at the sc0
!  level.
!
!   The coupled cluster equations can be solved by either including on only pp
!  and hh ladders or in the full CCD approximation scheme.
!
!   Note that for this particular model does not allow for ph (ring) TDA-like
!  resummation in any of the methods.
!
!
!   The ground state is then calculated in FCI to obtain the exact fundamental
!  energy and correlation energy, for comparison with the Koltun Sr result. It
!  is up to you, as an exercise, to do FCI for the N=3 and N=5 particle systems
!  and to extract the exact spectral function to compare with the results from
!  the ADC(n) method.
!
!   The coupled cluster equations are also solved to resum the pp and hh ladders.
!  These diagrams are a subset of the full CCD method that could be compared to the
!  correlations added in the 2p1h-ADC(2).
!
!   The particular pairing Hamiltonian used in this exercise allows us to use
!  the following two simplifications:
!
!   - The spin-up and spin-down parts of the Dyson equation completely decouple
!    and are equal because of symmetry. Hence, we need to calculate only one
!    of the two.
!
!   - The particle-hole contribution from the pairing interactions is zero in
!    the ring summation. So, we don't need to worry about rings.
!
!
!
!
!  Compile as:    gfortran Pairing_GF_CC.f90  -llapack -o Pairing.exe
!
!
!   You will need to link to the LAPACK library to compile this program.
!
!
!  (c) C. Barbieri and A. Carbone,   Surrey/Darmstadt,   October 2016.
!
!

module Bases
  !
  !  Global array to store the tables for the single-particle basis (model
  ! space) and the (quantum numbers of the) intermediate state configurations
  !

  implicit none

  ! Max dimension to be allocated for the mod. sp.
  integer, parameter :: MaxVectsDim = 16 ! Well redundant...

  integer ::   N_1b_mdsp  !  Actual sp basis size (all levels including spin)
  integer ::   isp_lv(MaxVectsDim),  isp_sp(MaxVectsDim),  isp_oc(MaxVectsDim)
  real*8  ::   xsp_en(MaxVectsDim) ! sp energies for the unperturbed Hamiltoniann

  real*8  ::   esp0_en(MaxVectsDim) ! unperturbed sp energies
  real*8  ::   Utld_en(MaxVectsDim) ! unperturbed sp energies
  real*8  ::   vhf_en(MaxVectsDim)  ! mtx els of HF potential
  real*8  ::   vhf_3rd(MaxVectsDim) ! mtx els 3rd order tadpole corrections

  integer :: N_1b_bas  !  Actual mod. sp. size (only # of levels)
  integer :: i_1b_bas(MaxVectsDim),i_1b_occ(MaxVectsDim)

  integer :: N_2p1h_bas, N_2h1p_bas  !  ADC(3) ISCs
  integer ::  innk_n1(MaxVectsDim), innk_n2(MaxVectsDim), innk_k3(MaxVectsDim)
  integer ::  ikkn_k1(MaxVectsDim), ikkn_k2(MaxVectsDim), ikkn_n3(MaxVectsDim)
  real*8  ::  xnnk_en(MaxVectsDim), xkkn_en(MaxVectsDim)

  integer :: N_2p_bas, N_2h_bas  !  partial 2p and 2h configurations
  integer ::  i_2p_n1(MaxVectsDim), i_2h_k1(MaxVectsDim)
  integer ::  i_2p_n2(MaxVectsDim), i_2h_k2(MaxVectsDim)
  real*8  ::  x_2p_en(MaxVectsDim), x_2h_en(MaxVectsDim)

  !
  !  We will use the following to store the poles and overlap
  ! amplitudes of the propagator
  integer, parameter :: MaxDySols = 20 ! Well redundant...
  integer :: N_bk_poles,  N_fw_poles
  real*8 ::  E_bk_poles(MaxVectsDim),            E_fw_poles(MaxVectsDim)
  real*8 :: SF_bk_poles(MaxVectsDim),           SF_fw_poles(MaxVectsDim)
  real*8 ::  Y_bk_poles(MaxVectsDim,MaxDySols),  X_fw_poles(MaxVectsDim,MaxDySols)
  real*8 :: E_Fermi

  !
  !  We will used the following global flags to select the level
  ! of approximation to be used.
  logical :: ADC2TDA, ADC3, ADC3CCD, TsqLadd, FullCCD

contains

subroutine Build_bases(xdlt)
  !
  !  Builds the single particle basis for the multi-level system. Since each
  ! energy level has spin 1/2, the total number of states will be twice the
  ! number of levels.
  !
  !  This can be controlled with the variable N_1b_mdsp which is the total number
  ! of basis states and
  !
  !  xdlt is the level spacing (the \xi of chapter 11)
  !
  implicit none
  real*8, intent(in) :: xdlt

  integer :: i, i1, i2, i3, k
  integer :: n1,n2

  N_1b_bas = 0
  N_2p_bas = 0
  N_2h_bas = 0
  N_2p1h_bas = 0
  N_2h1p_bas = 0

  write(6,*)
  write(6,*) ' Building the single particle basis...  (''p'' is the level number)'

  N_1b_mdsp=8  !  2 (spin orientations) * 4 (energy levels)

  write(6,*) '          #           p          m_s         occ     e(p) '

  i1 = 0
  do i = 1 , N_1b_mdsp

    ! Sets the occupation. Note that the number of particle must be even.
    isp_oc(i) = 0
    if (i <= 4) isp_oc(i) = 1 ! Here, 4 is the # of particles

    isp_lv(i) = (i-1)/2           ! level number
    isp_sp(i) = -1 + 2*MOD(i,2)   ! spin orientation
    xsp_en(i) = isp_lv(i) * xdlt  ! level energy

    write(6,*) i, isp_lv(i), isp_sp(i), isp_oc(i),  xsp_en(i)

    !
    ! Counts the energy levels in the basis
    if (0 < isp_sp(i)) then
     i1=i1+1
     i_1b_bas(i1) = i
     i_1b_occ(i1) = isp_oc(i)
    end if

  end do

  N_1b_bas = i1  ! eventually it must be   N_1b_mdsp = 2 * N_1b_bas

  !
  ! Builds tables for all the 2p1h and 2h1p intermediate state configurations (ISCs)
  !
  i1 = 0
  i2 = 0
  do n1 =  1 , N_1b_mdsp
  do n2 = n1+1 , N_1b_mdsp
   do k  = 1 , N_1b_mdsp

    if (isp_lv(n1) /=  isp_lv(n2)) cycle
    if (isp_sp(n1) /= -isp_sp(n2)) cycle
    if (isp_sp(k)  > 0) cycle

    if ( (0 == isp_oc(n1)) .AND. (0 == isp_oc(n2)) .AND. (1 == isp_oc(k)) ) then
      i1=i1+1
      innk_n1(i1) = n1
      innk_n2(i1) = n2
      innk_k3(i1) = k
      xnnk_en(i1) = xsp_en(n1) + xsp_en(n2) - xsp_en(k)
    end if

    if ( (1 == isp_oc(n1)) .AND. (1 == isp_oc(n2)) .AND. (0 == isp_oc(k)) ) then
      i2=i2+1
      ikkn_k1(i2) = n1
      ikkn_k2(i2) = n2
      ikkn_n3(i2) = k
      xkkn_en(i2) = xsp_en(n1) + xsp_en(n2) - xsp_en(k)
    end if

   end do
  end do
  end do

  N_2p1h_bas = i1
  N_2h1p_bas = i2

  !
  !  Build the (Pauli ordered) 2qp and 2qh ISCs. These are used to calculate
  ! the corrections for the ADC(3) coupling and the CCD(ladder) resummations
  !if (ADC3) then

    i1 = 0
    i2 = 0
    do n1 =  1 , N_1b_mdsp
     do n2 = n1+1 , N_1b_mdsp

      if (isp_lv(n1) /=  isp_lv(n2)) cycle
      if (isp_sp(n1) /= -isp_sp(n2)) cycle

      if ( (0 == isp_oc(n1)) .AND. (0 == isp_oc(n2)) ) then
        i1=i1+1
        i_2p_n1(i1) = n1
        i_2p_n2(i1) = n2
        x_2p_en(i1) = xsp_en(n1) + xsp_en(n2)
      end if

      if ( (1 == isp_oc(n1)) .AND. (1 == isp_oc(n2)) ) then
        i2=i2+1
        i_2h_k1(i2) = n1
        i_2h_k2(i2) = n2
        x_2h_en(i2) = xsp_en(n1) + xsp_en(n2)
      end if

     end do
    end do
    N_2p_bas = i1
    N_2h_bas = i2

  !end if

end subroutine Build_bases

subroutine Refresh_ISCs_energies(verbose)
  !
  !  Recalculate the unperturbed energies of ISCs, to be used in SCGF iterations
  !
  implicit none
  logical, intent(in) :: verbose

  integer :: i, i1, i2, i3, k
  integer :: n1,n2

  do i1 = 1 , N_2p1h_bas
    n1 = innk_n1(i1)
    n2 = innk_n2(i1)
    k  = innk_k3(i1)
    xnnk_en(i1) = esp0_en(n1) + esp0_en(n2) - esp0_en(k)
  end do

  do i2 = 1 , N_2h1p_bas
    n1 = ikkn_k1(i2)
    n2 = ikkn_k2(i2)
    k  = ikkn_n3(i2)
    xkkn_en(i2) = esp0_en(n1) + esp0_en(n2) - esp0_en(k)
  end do

  if (verbose) then
    !
    !  'verbose' controls the amount of output messages
    !
    write(6,*)
    write(6,*) '  I am recalculating the unperturbed energies doe the ISCs:'
    write(6,*) '  ---------------------------------------------------------'
    write(6,*)
    write(6,*) ' Single particle states in the spin-up channel...'
    write(6,*)
    do i = 1 , N_1b_bas
      i1 = i_1b_bas(i)
      write(6,*) i,i_1b_bas(i),i_1b_occ(i),isp_lv(i1),isp_sp(i1),isp_oc(i1),esp0_en(i1)
    end do
    !
    write(6,*)
    write(6,*)
    write(6,*) ' 2p1h basis...'
    write(6,*)
    do i = 1 , N_2p1h_bas
      i1 = innk_n1(i)
      i2 = innk_n2(i)
      i3 = innk_k3(i)
      write(6,101) i,i1,i2,i3,isp_lv(i1),isp_sp(i1),isp_lv(i2),isp_sp(i2),isp_lv(i3),isp_sp(i3),xnnk_en(i)
    end do
101 format(i4,2x,3I3,' - (',i2,',',i2') (',i2,',',i2') (',i2,',',i2')',f10.4)
    !
    write(6,*)
    write(6,*)
    write(6,*) ' 2h1p basis...'
    write(6,*)
    do i = 1 , N_2h1p_bas
      i1 = ikkn_k1(i)
      i2 = ikkn_k2(i)
      i3 = ikkn_n3(i)
      write(6,101) i,i1,i2,i3,isp_lv(i1),isp_sp(i1),isp_lv(i2),isp_sp(i2),isp_lv(i3),isp_sp(i3),xkkn_en(i)
    end do
    write(6,*)
    !
  end if ! end if (verbose)...

  do i1 = 1 , N_2p_bas
    n1 = i_2p_n1(i1)
    n2 = i_2p_n2(i1)
    x_2p_en(i1) = esp0_en(n1) + esp0_en(n2)
  end do

  do i2 = 1 , N_2h_bas
    n1 = i_2h_k1(i2)
    n2 = i_2h_k2(i2)
    x_2h_en(i2) = esp0_en(n1) + esp0_en(n2)
  end do

  if (verbose) then
    !
    !  'verbose' controls the amount of output messages
    !
    write(6,*)
    write(6,*)
    write(6,*) ' 2p basis...'
    write(6,*)
    do i = 1 , N_2p_bas
      i1 = i_2p_n1(i)
      i2 = i_2p_n2(i)
      write(6,106) i,i1,i2,isp_lv(i1),isp_sp(i1),isp_lv(i2),isp_sp(i2),x_2p_en(i)
    end do
106 format(i4,2x,2I3,' - (',i2,',',i2') (',i2,',',i2')',f10.4)
    !
    write(6,*)
    write(6,*)
    write(6,*) ' 2h basis...'
    write(6,*)
    do i = 1 , N_2h_bas
      i1 = i_2h_k1(i)
      i2 = i_2h_k2(i)
      write(6,106) i,i1,i2,isp_lv(i1),isp_sp(i1),isp_lv(i2),isp_sp(i2),x_2h_en(i)
    end do
  end if

end subroutine Refresh_ISCs_energies

end module Bases

module CoupledCluster
  !
  !  Here we store the T2 CCD amplitudes and the relative 2p and 2h configurations
  ! so that they can be used in the calculation of ADC(3)-D vertices.
  !
  !  In principle exactly the same 2-particle and the 2-hole configurations
  ! enter *both* the CCD equations and the formulas for the ADC(3) vertices. However,
  ! the configurations built in the module Bases are optimized to take into account
  ! the symmetries of the pairing Hamiltonian.
  !  For CCD, we take a more straightforward approach and and release these constraints.
  ! This simplifies coding the CCD calculation (of course) but at the price that we will
  ! explicitly sum over many zero contributions and that we need to construct the most
  ! general 2p and 2h bases as well.  For a a problem of very small dimension as this
  ! 4-level pairing the extra computing time remains negligible.
  !
  !  This module also stores the CCD amplitudes to be used for calculating ADC(3)-D
  ! later on.
  !

  use Bases
  implicit none

  ! T2 are the CCD amplitudes
  real*8,  allocatable :: index_xsng(:,:) , T2(:,:)
  integer, allocatable :: index_ijab(:,:)

  ! These are the most general 2p and 2h configuration, to be constructed in an
  ! analogous way to the ones in Bases::Build_bases
  integer              :: N_CC2p_bas, N_CC2h_bas
  integer, allocatable ::  i_CC2p_n1(:), i_CC2h_k1(:)
  integer, allocatable ::  i_CC2p_n2(:), i_CC2h_k2(:)
  real*8,  allocatable ::  xe_CC2p(:), xe_CC2h(:)

contains

subroutine Build_CCD_bases

  implicit none

  integer :: i1, i2, n1, n2, n2bas

  !  mod sp indices are ordered because of Pauli, these tables are to recover the correct
  ! indices in the list of configuration give the two separate sp indices. If they are
  ! inverted w.r.t. the ones in the list, index_xsng=-1 to account for antisymmetry.
  if ( allocated(index_ijab) ) deallocate(index_ijab)
  if ( allocated(index_xsng) ) deallocate(index_xsng)

  allocate ( index_ijab(N_1b_mdsp,N_1b_mdsp) )
  allocate ( index_xsng(N_1b_mdsp,N_1b_mdsp) )

  n2bas = ((N_1b_mdsp+1) * N_1b_mdsp) / 2  ! max possible numebr of 2p  of 2h

  if ( allocated( i_CC2p_n1 ) ) deallocate( i_CC2p_n1 ) ;    if ( allocated( i_CC2h_k1 ) ) deallocate( i_CC2h_k1 )
  if ( allocated( i_CC2p_n2 ) ) deallocate( i_CC2p_n2 ) ;    if ( allocated( i_CC2h_k2 ) ) deallocate( i_CC2h_k2 )
  if ( allocated(  xe_CC2p  ) ) deallocate(  xe_CC2p  ) ;    if ( allocated(  xe_CC2h  ) ) deallocate(  xe_CC2h  )

  allocate ( i_CC2p_n1(n2bas) ) ;                            allocate ( i_CC2h_k1(n2bas) )
  allocate ( i_CC2p_n2(n2bas) ) ;                            allocate ( i_CC2h_k2(n2bas) )
  allocate (   xe_CC2p(n2bas) ) ;                            allocate (   xe_CC2h(n2bas) )

  ! Now let's generate the 2p and 2h bases without symmetry constraints:
  i1 = 0
  i2 = 0
  index_ijab(:,:) = -100 ! < 0  means the configuration is not in the basis (e.g. n1=n2 is forbidden by Pauli)
  index_xsng(:,:) = 0.d0
  do n1 =  1 , N_1b_mdsp
    do n2 = n1+1 , N_1b_mdsp

    if ( (0 == isp_oc(n1)) .AND. (0 == isp_oc(n2)) ) then
      i1=i1+1
      i_CC2p_n1(i1) = n1
      i_CC2p_n2(i1) = n2
      xe_CC2p(i1) = esp0_en(n1) + esp0_en(n2)
      index_ijab(n1,n2) = i1;    index_xsng(n1,n2) =  1.d0
      index_ijab(n2,n1) = i1;    index_xsng(n2,n1) = -1.d0
    end if

    if ( (1 == isp_oc(n1)) .AND. (1 == isp_oc(n2)) ) then
      i2=i2+1
      i_CC2h_k1(i2) = n1
      i_CC2h_k2(i2) = n2
      xe_CC2h(i2) = esp0_en(n1) + esp0_en(n2)
      index_ijab(n1,n2) = i2;    index_xsng(n1,n2) =  1.d0
      index_ijab(n2,n1) = i2;    index_xsng(n2,n1) = -1.d0
    end if

    end do
  end do
  N_CC2p_bas = i1
  N_CC2h_bas = i2

  if ( allocated( T2 ) ) deallocate(  T2  );    allocate ( T2(N_CC2p_bas,N_CC2h_bas) )

  T2(:,:) = 0.d0

end subroutine Build_CCD_bases

end module CoupledCluster

program pairing
  !
  ! This is the main program
  !

  use Bases
  implicit none

  integer :: n1

  real*8  :: xdlt, xg, x1, x2, x3, x4

  integer :: n_sc_itrs,  i_sc_type

  real*8, external :: Exact_energy, Dyson, SolveCCD

  logical :: OptnAccptd

  xdlt = 1.d0
  xg = -1.0d0

  write(6,*)
  write(6,*) ' Value of g ? '
  read(5,*) xg

  ! pre initialise running flags
  ADC2TDA  = .false.  !  to summ the 2p1h/2h1p TDA ladders
  ADC3     = .false.  !  to add the ADC(3) coupling corrections
  ADC3CCD  = .false.  !  to add the ADC(3) coupling corrections in the CCD approx
  TsqLadd  = .false.  !  pure ladders in the CC equations
  FullCCD  = .false.  !  quatratic ladders in the CC equations (these are those generating a ladder-RPA)

  OptnAccptd = .false.
  do while(OptnAccptd)
    !
    OptnAccptd = .true.  ! Because we belive in the presumption of innocence
    !
    write(6,*)
    write(6,*) ' Type  1 for ADC(2),  2 for 2p1h-TDA,  3 for ADC(3)  and  4 for ADC(3)-D ? '
    read(5,*) n1
    if (1 == n1) then
      ADC2TDA = .false.
      ADC3    = .false.
      ADC3CCD = .false.
    else if (2 == n1) then
      ADC2TDA = .true.
      ADC3    = .false.
      ADC3CCD = .false.
    else if (3 == n1) then
      ADC2TDA = .true.
      ADC3    = .true.
     !ADC3CCD = .false.
    else if (4 == n1) then
      ADC2TDA = .true.
     !ADC3    = .false.
      ADC3CCD = .true.
    else
      ! input is not recognized
      OptnAccptd = .false.
    end if
  end do

  if (ADC3CCD) then ADC3 = .false. ! For safety: it must be EITHER one OR the other (see 'Build_ADCmtx()' below)

  OptnAccptd = .false.
  do while(OptnAccptd)
    !
    OptnAccptd = .true.  ! Because we belive in the presumption of innocence
    !
    write(6,*)
    write(6,*) ' Type 1 for CC(ladder)(2),  2 adding the TVT(ladders) or 3 for Full CCD ? '
    read(5,*) n1
    if (1 == n1) then
      TsqLadd = .false.
      FullCCD = .false.
    else if (2 == n1) then
      TsqLadd = .true.
      FullCCD = .false.
    else if (3 == n1) then
      TsqLadd = .true.
      FullCCD = .true.
    else
      ! input is not recognized
      OptnAccptd = .false.
    end if
  end do

  write(6,*)
  write(6,*) ' Type  0  for using unperturbed s.p. energies from H_0, anything else to use HF as the reference state: '
  read(5,*)  i_sc_type

  ! Build bases and ISCs for SCGF
  call Build_bases(xdlt)

  !
  ! If one want to plot the results to a file:
  !
  !open(UNIT=8,FILE='Pair_sol_CCM.dat')
  !open(UNIT=9,FILE='Pair_sol_Dyson.dat')
  !open(UNIT=10,FILE='Pair_sol_Exact.dat')

  !do n1 = 0, 52
  ! xg = -1.3d0 + n1* 0.05d0

  !n_sc_itrs = 0   ! Just do one dyagonalization with the unperturbed HF diagram
  n_sc_itrs = 10  ! Iterate the sc0 scheme a given number of times

  !
  !  Remember if ADC3CCD is set we MUST call CCD before doing Dyson because the
  ! coupling vertices in ADC(3)-D need the T2 amplitudes
  !
  x4 = SolveCCD(xg,x2,i_sc_type) ! x2 returns MBPT2

  x1 = Dyson(xg,n_sc_itrs, i_sc_type)

  x3 = Exact_energy(xdlt,xg)

  !
  ! If one want to plot the results to a file:
  !
  !write( 8,*) xg,      x4,     x2
  !write( 9,*) xg,   x1+xg-2.0, x2
  !write(10,*) xg,   x3+xg-2.0, x2
  !
  !end do
  !
  !close(UNIT=8)
  !close(UNIT=9)
  !close(UNIT=10)

end program pairing

real*8 function Dyson(xg,n_sc_itrs, i_sc_type)

  use Bases
  implicit none
  real*8,  intent(in) :: xg  !  xdlt is alrady set in module Bases by calling 'Build_bases(xdlt)'
  integer, intent(in) :: n_sc_itrs, i_sc_type

  ! This is the stuff needed by the LAPACK eigenvalue pakage:
  ! For 'DSYEV':
  integer, parameter :: LDA = 40
  integer, parameter :: LWORK  = 2+(6+2*LDA)*(LDA)  ! For 'DSYEVD' only...
  integer, parameter :: LIWORK = 3+5*LDA            ! For 'DSYEVD' only...
  real*8  :: A(LDA,LDA), B(LDA,LDA)
  real*8  :: W(LDA), WORK(LWORK)
  integer :: IWORK(LIWORK)

  integer :: INFO, LWopt, LIWopt

  integer :: i, i1, i2, i3, i4, j, k, n1,   ih1, ih2

  real*8  :: x1, x2, xA, xSF, xNorm, xKolt, xA_run, xKolt_run, x3,x4 ,x5

  integer :: Ntot, itr, max_itrs

  real*8, external :: Vpair

  write(6,*)
  write(6,*) ' --- --- ---'
  write(6,*)
  write(6,*) '  Start calculations with the GF method...'
  write(6,*)

  !
  ! This is the HF potential, which is diagonal in s.p. basis
  !
  vhf_en(:) = 0.d0
  do j = 1 , N_1b_mdsp
   x1 = 0.d0
   do k = 1 , N_1b_mdsp
    if (1 == isp_oc(k)) x1 = x1 + Vpair(j,k,j,k,xg)
   end do
   vhf_en(j) = x1
  end do

  Ntot = N_1b_bas + N_2p1h_bas + N_2h1p_bas

  esp0_en(:) = xsp_en(:)
  Utld_en(:) = 0.d0
  if (0 == i_sc_type) then
    !
    !  Use  the energy levels for the unprturbed H_0:
    esp0_en(:) = xsp_en(:)
    Utld_en(:) = vhf_en(:)

  else if (1 <= i_sc_type) then
    !
    !  Use the Hf basis to define H_0 (here Vhf is diagonal!)
    esp0_en(:) = xsp_en(:) + vhf_en
    Utld_en(:) = 0.d0

  end if

  call Refresh_ISCs_energies(.true.)
  call Build_ADCmtx(B,LDA,xg)

  x4 = 0.d0; x5 = 0.d0
  vhf_3rd(:) = 0.d0
  do k = 1 , N_1b_mdsp

    i1 = (k-1)/2 + 1;
    i4 = i_1b_bas(i1)
    if ( (k /= i4 ).and.(k /= 1+i4 ) ) then; write(6,*) ' Some trouble occurred ',i1, j,i_1b_bas(i1)  ; stop; end if
    if (1 == isp_oc(k)) then
      !
      ! Must connect with the 2p1h states
      !
      x1 = 0.d0
      do j = 1 , N_2p1h_bas
        x3 = Vpair(i4,innk_k3(j),innk_n1(j),innk_n2(j),xg)
        x2 = x3 / (-esp0_en(k) + xnnk_en(j) )
        x1 = x1 + x2*x2
        x4 = x4 - x2*x3
      end do

    else
      !
      ! Must connect with the 2h1p states
      !
      x1 = 0.d0
      do j = 1 , N_2h1p_bas
        x3 = Vpair(ikkn_k1(j),ikkn_k2(j),i4,ikkn_n3(j),xg)
        x2 = x3 / (-esp0_en(k) + xkkn_en(j) )
        x1 = x1 - x2*x2
        x5 = x5 + x3*x2
      end do

    end if
    vhf_3rd(k) = x1
  end do

  write(6,*)
  write(6,*) 'MBPT2 = ', x4/2.d0, x5/2.d0
  write(6,*)

  !
  !  Seek for an estimation of the Fermi energy,  to be used later
  ! for separating qps and qhs
  x1 = -1.d20
  x2 = +1.d20
  do  i = 1 , N_1b_bas
    k = i_1b_bas(i)
    if (1 == isp_oc(k)) x1 = MAX(x1,xsp_en(k)+vhf_en(k))
    if (0 == isp_oc(k)) x2 = MIN(x2,xsp_en(k)+vhf_en(k))
  end do
  E_Fermi = (x1+x2)/2.d0
  write(6,'(A,f10.4)') ' The Fermi energy will be taken to be ',E_Fermi

  max_itrs = MAX(0, n_sc_itrs)
  do itr = 0 , max_itrs

    ! load the part fothe Dyson matrix that will not change with iterations
    A = B

    !
    ! Add the HF(cHF) self energy:
    !
    do i = 1 , N_1b_bas
     i1 = i_1b_bas(i)
     do j = 1 , N_1b_bas
      i2 = i_1b_bas(j)

      if (0 == itr) then
        !
        !  At the first iterations, just use the 1st
        ! order HF diagram
        x1 = 0.d0
        do k = 1 , N_1b_mdsp
          if (1 == isp_oc(k)) x1 = x1 + Vpair(i1,k,i2,k,xg)
        end do
      else
        !
        !  Now we have a propagator and thus we can do
        ! the fully correlated 1
        x1 = 0.d0
        do i3 = 1 , N_1b_bas
         do i4 = 1 , N_1b_bas
          do k  = 1 , N_bk_poles
            !
            !  We are using a trick here: in principle we should be calculating also the
            ! spin down part of the spectral function (which we are skipping because it is
            ! exactly the same as the the spin up part--in this model). In fact, both spin
            ! up and down spectral functions can contribute to the static self-energy. For
            ! this particular pairing model, it is only the spin down that contributes to the
            ! spin up HF diagram (because of the interaction we have chosen)!!!
            !  Here we use the calculated spin-up part in which is stored in Y_bk_poles but
            ! then we need to use the corresponding spin-down s.p. states in for the
            ! interaction matrix elements (hence the i_1b_bas(i...)+1 indices).
            x1 = x1 + Vpair(i1,i_1b_bas(i3)+1,i2,i_1b_bas(i4)+1,xg) * Y_bk_poles(k,i3)*Y_bk_poles(k,i4)
          end do
         end do
        end do
      end if

      A(i,j) = A(i,j) + x1
     end do

     !if ((0 == itr) .and. (ADC3 .or. ADC3CCD)) A(i,i) = A(i,i) + vhf_3rd(i1)
    end do

    !
    ! Show the initial and final Dyson matrix
    if ((max_itrs == itr) .OR. (0 == itr)) then
      write(6,*)
      write(6,*)
      if (0 == itr) then
        write(6,*) ' The initial Dyson matrix is:'
      else
        write(6,*) ' The Dyson matrix is:'
      end if
        write(6,*)
        do i = 1 , Ntot
          write(6,110) i, A(i,1:Ntot)
          if (0 == MOD(i,4)) write(6,*)
        end do
    end if
110 format(i4,3(3X,4f7.3))

    ! LAPACK library (w/ DSYEVD):
    INFO = 0;
    LWopt=0
    LIWopt=0
    call dsyevd('Vectors','Upper',Ntot,A,LDA,W,WORK, LWORK,IWORK,LIWORK,INFO);
    if (0 /= INFO) write(6,*) 'Dyson (DSYEV), Wrong value of IFAIL: INFO= ',INFO
    if (0 == INFO) then
      LWopt = MAX(int(WORK(1) + 0.01) , LWopt)
      LIWopt = MAX(IWORK(1) , LIWopt)
    else
      write(6,*) ' ''DEEGV'' gave INFO = ', INFO
      if (INFO < 0) write(6,*) ' The ',-INFO,'-th aggument in line 408 was illegal:'
      write(6,*) ' Program has been aborted since IERR != 0.'
      write(6,*) ' Aborted at the line 410, Dyson.f!'
      write(6,*) '   --> stop.'
      stop
    end if

    if ((max_itrs == itr) .OR. (0 == itr)) then
      write(6,*)
      write(6,*) '              e^+/-      \sum A        SF       \sum KRS          KSR      Corr. En                Check norm'
    end if

    xA = 0.d0
    xKolt = 0.d0
    xA_run = 0.d0
    xKolt_run = 0.d0
    N_bk_poles = 0
    N_fw_poles = 0
    do i = 1 , Ntot

      xNorm = 0.d0; xSF = 0.d0
      x2 = 0.d0
      do j = 1 , Ntot
        x1 = A(j,i)
        xNorm = xNorm + x1*x1
        if (j <= N_1b_bas) then
          xSF = xSF + x1*x1
!          write(6,*) j,xsp_en(i_1b_bas(j))
          x2  = x2  + x1*x1*(xsp_en(i_1b_bas(j)) + W(i))
        end if
      end do
      x2 = x2 / xNorm / 2.0
      xSF   = xSF / xNorm
      xNorm = DSQRT(xNorm)

      if (W(i) < E_Fermi) then
        ! quasiholes
         N_bk_poles = N_bk_poles + 1
         E_bk_poles(N_bk_poles) = W(i)
        SF_bk_poles(N_bk_poles) = xSF
         Y_bk_poles(N_bk_poles,1:N_1b_bas) = A(1:N_1b_bas,i) / xNorm
        xKolt = xKolt + x2
        xA    = xA  + xSF
      else
        ! quasiparticles
         N_fw_poles = N_fw_poles + 1
         E_fw_poles(N_fw_poles) = W(i)
        SF_fw_poles(N_fw_poles) = xSF
         X_fw_poles(N_fw_poles,1:N_1b_bas) = A(1:N_1b_bas,i) / xNorm
      end if

      xKolt_run = xKolt_run + x2
      xA_run    = xA_run  + xSF

      if ((max_itrs == itr) .OR. (0 == itr)) then
         write(6,120) i, W(i),  xA_run, xSF, xKolt_run, xKolt_run*2.d0, xKolt_run*2.d0 - 2.d0 + xg, x2, xNorm
         if (0 == MOD(i,6)) write(6,*)
      end if
120   format(i4,3(4X,4f12.5))

    end do

    !
    !  We have calculated only the spectral function for particles with
    ! spin up  but the spin spin down would be exactly the same and give
    ! another equal contribution. The factor 2.d0 is to account for this.
    !
    write(6,121) ' Particle number and Koltun SR :  ', 2.d0*xA, 2.d0*xKolt,   &
                        '    (corr. en. = ',2*(xKolt-1.0)+xg,')'
121 format(A,2f12.5,A,f12.5,A)

    Dyson = 2.d0*xKolt
  end do ! itr loop

end function Dyson

subroutine Build_ADCmtx(ADCmtx,LDA,xg)
  use Bases
  use CoupledCluster
  implicit none
  integer, intent(in)  :: LDA
  real*8,  intent(out) :: ADCmtx(LDA,LDA)
  real*8,  intent(in)  :: xg

  integer :: i, i4, j, k, n1, Ntot,  ih1, ih2,  i_ab

  real*8  :: x1, x_ab

  real*8, external :: Vpair

  ADCmtx(:,:) = 0.d0
  Ntot = N_1b_bas + N_2p1h_bas + N_2h1p_bas
  do i = 1 , N_1b_bas

    i4 = i_1b_bas(i)

    ADCmtx(i,i) = ADCmtx(i,i) + xsp_en(i4)

    do j = 1 , N_2p1h_bas
      x1 = Vpair(i4,innk_k3(j),innk_n1(j),innk_n2(j),xg)
      ADCmtx(i,N_1b_bas+j) = x1
      ADCmtx(N_1b_bas+j,i) = x1
    end do

    do j = 1 , N_2h1p_bas
      x1 = Vpair(ikkn_k1(j),ikkn_k2(j),i4,ikkn_n3(j),xg)
      ADCmtx(i,N_1b_bas+N_2p1h_bas+j) = x1
      ADCmtx(N_1b_bas+N_2p1h_bas+j,i) = x1
    end do

  end do

  do j = 1 , N_2p1h_bas
    n1 = N_1b_bas+j
    ADCmtx( n1 , n1 ) = xnnk_en(j) + Utld_en(innk_n1(j)) + Utld_en(innk_n2(j)) - Utld_en(innk_k3(j))
  end do
  do j = 1 , N_2h1p_bas
    n1 = N_1b_bas+N_2p1h_bas+j
    ADCmtx( n1 , n1 ) = xkkn_en(j) + Utld_en(ikkn_k1(j)) + Utld_en(ikkn_k2(j)) - Utld_en(ikkn_n3(j))
  end do

  if (ADC2TDA) then
    !
    !  Add the pp and hh ladders that define the extended-ADC(2) approximation
    ! and are also included in the ADC(3) method.
    !
    !  A comment: diagonalizing these sub matrices separately, would let you
    ! calculate the very same pp or hh ladders that were done during the
    ! coupled cluster CCD exercises.
    !
    n1 = N_1b_bas
    do i = 1 , N_2p1h_bas
     do j = 1 , N_2p1h_bas
      if (innk_k3(i) /= innk_k3(j)) cycle
      x1 = Vpair(innk_n1(i),innk_n2(i),innk_n1(j),innk_n2(j),xg)
      ADCmtx( n1 + i , n1 + j ) = ADCmtx( n1 + i , n1 + j ) + x1
     end do
    end do
    !
    n1 = N_1b_bas + N_2p1h_bas
    do i = 1 , N_2h1p_bas
     do j = 1 , N_2h1p_bas
      if (ikkn_n3(i) /= ikkn_n3(j)) cycle
      x1 = Vpair(ikkn_k1(i),ikkn_k2(i),ikkn_k1(j),ikkn_k2(j),xg)
      ADCmtx( n1 + i , n1 + j ) = ADCmtx( n1 + i , n1 + j ) - x1
     end do
    end do
    !
  end if

  if (ADC3) then
    !
    !  Add the ADC(3) corrections for the \alpha-2p1h and \alpha-2h1p
    ! coupling terms.
    !  ONLY the pp/hh ladder corrections are included here because the
    ! rings do not contribute to this model...(?)
    !
    !
    do i = 1 , N_1b_bas
     i4 = i_1b_bas(i)
     do j = 1 ,  N_2p1h_bas

      x1 = 0.d0
      do k = 1 , N_2h_bas
        ih1 = i_2h_k1(k)
        ih2 = i_2h_k2(k)
        x1 = x1 + Vpair(i4,innk_k3(j),ih1,ih2,xg) * Vpair(ih1,ih2,innk_n1(j),innk_n2(j),xg) /   &
            (x_2h_en(k) - esp0_en(innk_n1(j)) - esp0_en(innk_n2(j)) )
      end do

      ADCmtx(i,N_1b_bas+j) = ADCmtx(i,N_1b_bas+j) + x1
      ADCmtx(N_1b_bas+j,i) = ADCmtx(N_1b_bas+j,i) + x1

     end do
    end do
    !
    do i = 1 , N_1b_bas
     i4 = i_1b_bas(i)
     do j = 1 , N_2h1p_bas

      x1 = 0.d0
      do k = 1 , N_2p_bas
        ih1 = i_2p_n1(k)
        ih2 = i_2p_n2(k)
        x1 = x1 + Vpair(ikkn_k1(j),ikkn_k2(j),ih1,ih2,xg) * Vpair(ih1,ih2,i4,ikkn_n3(j),xg) /   &
            (esp0_en(ikkn_k1(j)) + esp0_en(ikkn_k2(j)) - x_2p_en(k))
      end do

      ADCmtx(i,N_1b_bas+N_2p1h_bas+j) = ADCmtx(i,N_1b_bas+N_2p1h_bas+j) + x1
      ADCmtx(N_1b_bas+N_2p1h_bas+j,i) = ADCmtx(N_1b_bas+N_2p1h_bas+j,i) + x1
     end do
    end do
    !
  else if (ADC3CCD) then
    !
    !  Add the ADC(3)-D corrections for the \alpha-2p1h and \alpha-2h1p
    ! coupling terms.
    !  ONLY the pp/hh ladder corrections are included here because the
    ! rings do not contribute to this model...(?)
    !
    !
    do i = 1 , N_1b_bas
     i4 = i_1b_bas(i)
     do j = 1 ,  N_2p1h_bas

       !  Get the index in the extended 2p/2h bases (used by the CCD program) and also
       ! read the symmetry factor to account for the -1 if the fermion n1 and n2 are inverted
       i_ab = index_ijab(innk_n1(j),innk_n2(j));   x_ab = index_xsng(innk_n1(j),innk_n2(j))
       if (i_ab < 0) cycle  ! if 1_ab < 0 that means that this configuration does not exists.

       x1 = 0.d0
       do k = 1 , N_CC2h_bas
         ih1 = i_CC2h_k1(k)
         ih2 = i_CC2h_k2(k)
         x1 = x1 + Vpair(i4,innk_k3(j),ih1,ih2,xg) * T2(i_ab,k) * x_ab
       end do

       ADCmtx(i,N_1b_bas+j) = ADCmtx(i,N_1b_bas+j) + x1
       ADCmtx(N_1b_bas+j,i) = ADCmtx(N_1b_bas+j,i) + x1

     end do
    end do
    !
    do i = 1 , N_1b_bas
     i4 = i_1b_bas(i)
     do j = 1 , N_2h1p_bas

       i_ab = index_ijab(ikkn_k1(j),ikkn_k2(j));   x_ab = index_xsng(ikkn_k1(j),ikkn_k2(j))
       if (i_ab < 0) cycle

      x1 = 0.d0
      do k = 1 , N_CC2p_bas
        ih1 = i_CC2p_n1(k)
        ih2 = i_CC2p_n2(k)
        x1 = x1 + x_ab * T2(k,i_ab) * Vpair(ih1,ih2,i4,ikkn_n3(j),xg)
      end do

      ADCmtx(i,N_1b_bas+N_2p1h_bas+j) = ADCmtx(i,N_1b_bas+N_2p1h_bas+j) + x1
      ADCmtx(N_1b_bas+N_2p1h_bas+j,i) = ADCmtx(N_1b_bas+N_2p1h_bas+j,i) + x1
     end do
    end do
    !
   end if

end subroutine Build_ADCmtx

real*8 function Exact_energy(xdlt,xg)
  !
  ! Calculates all the exact eigenstates by full CI.
  !
  implicit none
  real*8, intent(in) :: xdlt, xg

  integer :: Ntot

  ! The stuff needed by the LAPACK eigenvalue pakage:
  ! For 'DSYEV':
  integer, parameter :: LDA = 6
  integer, parameter :: LWORK  = 2+(6+2*LDA)*(LDA)  ! For 'DSYEVD' only...
  integer, parameter :: LIWORK = 3+5*LDA              ! For 'DSYEVD' only...
  real*8  :: A(LDA,LDA)
  real*8  :: W(LDA), WORK(LWORK)
  integer :: IWORK(LIWORK)

  integer :: INFO, LWopt, LIWopt, i

  write(6,*)
  write(6,*) ' --- --- ---'
  write(6,*)
  write(6,*) '  Solving the exact ground state energy by diagonalising the '
  write(6,*) ' following hamiltonian:'
  write(6,*)

  A(:,:) = -xg / 2.d0
  Ntot = 6
  do i = 1 , Ntot
    A(i, Ntot+1-i) = 0.d0
    A(i,i) = 2.d0 * i - xg
    if (i > Ntot/2) A(i,i) = xdlt * 2.d0 * (i-1) - xg
  end do

  do i = 1 , Ntot
  write(6,130) i, A(i,1:Ntot)
  if (0 == MOD(i,3)) write(6,*)
  end do
130 format(i4,3(3X,3f7.3))

  ! LAPACK library (w/ DSYEVD):
  INFO = 0;
  LWopt=0
  LIWopt=0
  Ntot = 6
  call dsyevd('Vectors','Upper',Ntot,A,LDA,W,WORK, LWORK,IWORK,LIWORK,INFO);
  if (0 /= INFO) write(6,*) 'Dyson (DSYEV), Wrong value of IFAIL: INFO= ',INFO
  if (0 == INFO) then
    LWopt = MAX(int(WORK(1) + 0.01) , LWopt)
    LIWopt = MAX(IWORK(1) , LIWopt)
  else
    write(6,*) ' ''DEEGV'' gave INFO = ', INFO
    if (INFO < 0) write(6,*) ' The ',-INFO,'-th aggument in line 408 was illegal:'
    write(6,*) ' Program has been aborted since IERR != 0.'
    write(6,*) ' Aborted at the line 410, Dyson.f!'
    write(6,*) '   --> stop.'
    stop
  end if

  Exact_energy = W(1)

  write(6,*)
  write(6,*)
  write(6,142) ' The exact correlation energy is: ', W(1) - 2.d0 + xg
  write(6,*)
  write(6,*)
  write(6,*) 'Eigenvalues:'
  write(6,140) W(1:Ntot)
  write(6,*)
  write(6,*) 'Eivenvectors:'
  do i = 1 , Ntot
    write(6,141) i, A(i,1:Ntot)
  end do
  write(6,*)

140 format(4X,5(3X,3f10.4))
141 format(i4,5(3X,3f10.4))
142 format(A,f12.5)

  return
end function Exact_energy

real*8 function SolveCCD(xg,dEmbpt2,i_sc_type)
  use Bases
  use CoupledCluster

  implicit none
  real*8, intent(in)  :: xg  !  xdlt is alrady set in module Bases by calling 'Build_bases(xdlt)'
  real*8, intent(out) :: dEmbpt2
  integer, intent(in) :: i_sc_type

  real*8, allocatable :: V2(:,:), E0(:,:), Vpp(:,:), Vhh(:,:), TT(:,:)
  real*8, allocatable :: TVX1(:,:), TVX2(:,:), u1b_no(:)

  integer ::  r, q, itr, ia, ib, ii, ij
  real*8  ::  xv, xe, xe_new
  real*8  ::  x1, x2, x3, x4, x5
  integer ::  r2,q2, ik, il, ic, id
  integer :: i1, i2, n1, n2

  integer ::  i_ac, i_ad, i_bc, i_bd,  i_ik, i_il, i_jk, i_jl
  real*8  ::  x_ac, x_ad, x_bc, x_bd,  x_ik, x_il, x_jk, x_jl

  real*8, external :: Vpair

  write(6,*)
  write(6,*) ' --- --- ---'
  write(6,*)
  write(6,*) '  Solving the CC equation for the correlation. This will also yield'
  write(6,*) ' the MBPT2 result as its 0-th iteration...'
  write(6,*)
       if (FullCCD) then; write(6,*) ' The full CCD equations will be solved.'
  else if (TsqLadd) then; write(6,*) ' The pp-hh RPA term will be added.'
  else;                   write(6,*) ' Ony the pp/hh ladders will be included.'
  end if
  write(6,*)

  allocate (u1b_no(MaxVectsDim))

  !
  ! Calculate the HF potential (here Vhf is diagonal!)
  vhf_en(:) = 0.d0
  do r = 1 , N_1b_mdsp
   x1 = 0.d0
   do q = 1 , N_1b_mdsp
    if (1 == isp_oc(q)) x1 = x1 + Vpair(r,q,r,q,xg)
   end do
   vhf_en(r) = x1
  end do

  !
  !  Normal ordered 1b mtx elment is:
  esp0_en(:) = xsp_en(:)
  u1b_no(:)  = vhf_en(:)
  if (1 <= i_sc_type) then
    !
    !  In this case, use the HF basis to define H_0
    esp0_en(:) = xsp_en(:) + vhf_en(:)
    u1b_no(:) = 0.d0
  end if

  call Build_CCD_bases

  ! T2(N_CC2p_bas,N_CC2h_bas)  has already been allocated by 'Build_CCD_bases'
  allocate (  V2(N_CC2h_bas,N_CC2p_bas) )
  allocate (  E0(N_CC2p_bas,N_CC2h_bas) )

  allocate ( TVX1(N_CC2p_bas,N_CC2p_bas) )
  allocate ( TVX2(N_CC2h_bas,N_CC2h_bas) )

  allocate ( Vpp(N_CC2p_bas,N_CC2p_bas) )
  allocate ( Vhh(N_CC2h_bas,N_CC2h_bas) )

  dEmbpt2 = 0.d0
  do r = 1 , N_CC2p_bas
    ia = i_CC2p_n1(r)
    ib = i_CC2p_n2(r)
    do q = 1 , N_CC2h_bas
      ii = i_CC2h_k1(q)
      ij = i_CC2h_k2(q)

      xv = Vpair(ia,ib,ii,ij,xg)
      xe = xe_CC2h(q) - xe_CC2p(r)
      V2(q,r) = xv
      E0(r,q) = xe
      T2(r,q) = xv / xe

      dEmbpt2 = dEmbpt2 + xv*xv/xe
    end do
  end do

  do r = 1 , N_CC2p_bas
   ia = i_CC2p_n1(r)
   ib = i_CC2p_n2(r)
   do q = 1 , N_CC2p_bas
    ii = i_CC2p_n1(q)
    ij = i_CC2p_n2(q)
    Vpp(r,q) = Vpair(ia,ib,ii,ij,xg)
   end do
  end do
  do r = 1 , N_CC2h_bas
   ia = i_CC2h_k1(r)
   ib = i_CC2h_k2(r)
   do q = 1 , N_CC2h_bas
    ii = i_CC2h_k1(q)
    ij = i_CC2h_k2(q)
    Vhh(r,q) = Vpair(ia,ib,ii,ij,xg)
   end do
  end do

  write(6,*)
  write(6,*) ' E_corr from MBPT2 : ',dEmbpt2
  write(6,*)

  write(6,*) '                     dE_old           dE_new'

  xe_new = dEmbpt2
  itr = 0
  do while (ABS(xe - xe_new) > 1.d-7)

    xe = xe_new
    itr = itr + 1

    TT = TRANSPOSE( V2 ) + MATMUL(T2, Vhh ) + MATMUL(Vpp, T2)

    if (TsqLadd .or. FullCCD) TT = TT + MATMUL( MATMUL (T2 , V2) , T2 )

    !
    !  The TVT ring term is zero for this model because the pairing interaciton
    ! does not connect p-h states
    !

    if (FullCCD) then
      !
      ! The remaining thems needed to complete the CCD approximation
      !
      TVX1 = MATMUL (T2 , V2)
      TVX2 = MATMUL (V2 , T2)
      !
      do r = 1 , N_CC2p_bas
        ia = i_CC2p_n1(r)
        ib = i_CC2p_n2(r)
        do q = 1 , N_CC2h_bas
          ii = i_CC2h_k1(q)
          ij = i_CC2h_k2(q)
          x1 = 0.d0
          x2 = 0.d0
          x3 = 0.d0
          do r2 = 1 , N_CC2p_bas
            ic = i_CC2p_n1(r2)
            id = i_CC2p_n2(r2)
            i_ac = index_ijab(ia,ic);   x_ac = index_xsng(ia,ic)
            i_ad = index_ijab(ia,id);   x_ad = index_xsng(ia,id)
            i_bc = index_ijab(ib,ic);   x_bc = index_xsng(ib,ic)
            i_bd = index_ijab(ib,id);   x_bd = index_xsng(ib,id)

            if ((i_ac > 0) .and. (i_bd > 0)) x1 = x1 - x_ac * x_bd * TVX1(i_ac,r2) * T2(i_bd,q)
            if ((i_ad > 0) .and. (i_bc > 0)) x1 = x1 + x_ad * x_bc * TVX1(i_ad,r2) * T2(i_bc,q)
            if ((i_bc > 0) .and. (i_ad > 0)) x1 = x1 + x_bc * x_ad * TVX1(i_bc,r2) * T2(i_ad,q)
            if ((i_bd > 0) .and. (i_ac > 0)) x1 = x1 - x_bd * x_ac * TVX1(i_bd,r2) * T2(i_ac,q)
            do q2 = 1 , N_CC2h_bas
              ik = i_CC2h_k1(q2)
              il = i_CC2h_k2(q2)
              i_ik = index_ijab(ii,ik);   x_ik = index_xsng(ii,ik)
              i_il = index_ijab(ii,il);   x_il = index_xsng(ii,il)
              i_jk = index_ijab(ij,ik);   x_jk = index_xsng(ij,ik)
              i_jl = index_ijab(ij,il);   x_jl = index_xsng(ij,il)

              x4 = 0.d0; x5 = 0.d0
              if ((i_ac > 0) .and. (i_bd > 0)) then
                if ((i_ik > 0) .and. (i_jl > 0)) x4 = x4 + x_ac * x_bd * x_ik * x_jl * T2(i_ac,i_ik) * T2(i_bd,i_jl)
                if ((i_il > 0) .and. (i_jk > 0)) x4 = x4 - x_ac * x_bd * x_il * x_jk * T2(i_ac,i_il) * T2(i_bd,i_jk)
                if ((i_jk > 0) .and. (i_il > 0)) x4 = x4 - x_ac * x_bd * x_jk * x_il * T2(i_ac,i_jk) * T2(i_bd,i_il)
                if ((i_jl > 0) .and. (i_ik > 0)) x4 = x4 + x_ac * x_bd * x_jl * x_ik * T2(i_ac,i_jl) * T2(i_bd,i_ik)
              end if
              if ((i_bc > 0) .and. (i_ad > 0)) then
                if ((i_ik > 0) .and. (i_jl > 0)) x5 = x5 - x_bc * x_ad * x_ik * x_jl * T2(i_bc,i_ik) * T2(i_ad,i_jl)
                if ((i_il > 0) .and. (i_jk > 0)) x5 = x5 + x_bc * x_ad * x_il * x_jk * T2(i_bc,i_il) * T2(i_ad,i_jk)
                if ((i_jk > 0) .and. (i_il > 0)) x5 = x5 + x_bc * x_ad * x_jk * x_il * T2(i_bc,i_jk) * T2(i_ad,i_il)
                if ((i_jl > 0) .and. (i_ik > 0)) x5 = x5 - x_bc * x_ad * x_jl * x_ik * T2(i_bc,i_jl) * T2(i_ad,i_ik)
              end if
              x3 = x3 + V2(q2,r2) * (x4 + x5)
            end do
          end do
          do q2 = 1 , N_CC2h_bas
            ik = i_CC2h_k1(q2)
            il = i_CC2h_k2(q2)
            i_ik = index_ijab(ii,ik);   x_ik = index_xsng(ii,ik)
            i_il = index_ijab(ii,il);   x_il = index_xsng(ii,il)
            i_jk = index_ijab(ij,ik);   x_jk = index_xsng(ij,ik)
            i_jl = index_ijab(ij,il);   x_jl = index_xsng(ij,il)

            if ((i_ik > 0) .and. (i_jl > 0)) x2 = x2 - x_ik * x_jl * T2(r,i_jl) * TVX2(q2,i_ik)
            if ((i_il > 0) .and. (i_jk > 0)) x2 = x2 + x_il * x_jk * T2(r,i_jk) * TVX2(q2,i_il)
            if ((i_jk > 0) .and. (i_il > 0)) x2 = x2 + x_jk * x_il * T2(r,i_il) * TVX2(q2,i_jk)
            if ((i_jl > 0) .and. (i_ik > 0)) x2 = x2 - x_jl * x_ik * T2(r,i_ik) * TVX2(q2,i_jl)

          end do

          x4 = (u1b_no(ia) + u1b_no(ib) - u1b_no(ii) - u1b_no(ij) ) * T2(r,q)

          TT(r,q) = TT(r,q) + (x1 + x2 + x3 + x4)

        end do
      end do
    end if

    xe_new = 0.d0
    do r = 1 , N_CC2p_bas
     do q = 1 , N_CC2h_bas
      TT(r,q) = TT(r,q) / E0(r,q)
      T2(r,q) = 0.5*T2(r,q) + 0.5*TT(r,q)
      xe_new = xe_new + V2(q,r)*T2(r,q)
     end do
    end do

    write(6,'(A,I5,2f17.7)') 'Itr n, ',itr, xe, xe_new

  end do

  write(6,*)
  write(6,*) ' The converged CC corr. energy is : ',xe_new
  write(6,*)

  SolveCCD = xe_new

  deallocate (u1b_no)

  !!!deallocate (  T2 )   this is needed by ADC(3)-D
  deallocate (  V2 )
  deallocate (  E0 )
  deallocate ( Vpp )
  deallocate ( Vhh )
  deallocate ( TVX1 )
  deallocate ( TVX2 )
  !!!deallocate ( index_ijab )   this is needed by ADC(3)-D
  !!!deallocate ( index_xsng )   this is needed by ADC(3)-D

  return
end function SolveCCD

real*8 function Vpair(a,b,c,d,xg)
  !
  ! Matrix elements of the pairing interaction
  !
  use Bases
  implicit none
  integer, intent(in) :: a,b,c,d
  real*8,  intent(in) :: xg
  Vpair = 0.d0
  if (isp_lv(a) /=  isp_lv(b)) return
  if (isp_sp(a) /= -isp_sp(b)) return
  if (isp_lv(c) /=  isp_lv(d)) return
  if (isp_sp(c) /= -isp_sp(d)) return
  Vpair = -xg/2.d0
  if (isp_sp(a) /=  isp_sp(c)) Vpair = -Vpair
  return
end function Vpair