mirror of https://github.com/pfloos/quack
238 lines
5.4 KiB
Fortran
238 lines
5.4 KiB
Fortran
subroutine sort_ppRPA(nOO,nVV,Om,Z,Om1,X1,Y1,Om2,X2,Y2)
|
|
|
|
! Compute the metric matrix for pp-RPA
|
|
|
|
implicit none
|
|
include 'parameters.h'
|
|
|
|
! Input variables
|
|
|
|
integer,intent(in) :: nOO
|
|
integer,intent(in) :: nVV
|
|
double precision,intent(in) :: Om(nOO+nVV)
|
|
double precision,intent(in) :: Z(nOO+nVV,nOO+nVV)
|
|
|
|
! Local variables
|
|
|
|
integer :: pq,ab,ij
|
|
! integer :: deg1,ab_start,ab_end
|
|
! integer :: deg2,ij_start,ij_end
|
|
double precision,allocatable :: M(:,:)
|
|
double precision,allocatable :: Z1(:,:)
|
|
double precision,allocatable :: Z2(:,:)
|
|
double precision,allocatable :: S1(:,:)
|
|
double precision,allocatable :: S2(:,:)
|
|
double precision,allocatable :: O1(:,:)
|
|
double precision,allocatable :: O2(:,:)
|
|
double precision,allocatable :: tmp1(:,:)
|
|
double precision,allocatable :: tmp2(:,:)
|
|
|
|
integer,allocatable :: order1(:)
|
|
integer,allocatable :: order2(:)
|
|
|
|
! Output variables
|
|
|
|
double precision,intent(out) :: Om1(nVV)
|
|
double precision,intent(out) :: X1(nVV,nVV)
|
|
double precision,intent(out) :: Y1(nOO,nVV)
|
|
double precision,intent(out) :: Om2(nOO)
|
|
double precision,intent(out) :: X2(nVV,nOO)
|
|
double precision,intent(out) :: Y2(nOO,nOO)
|
|
|
|
! Memory allocation
|
|
|
|
allocate(M(nOO+nVV,nOO+nVV),Z1(nOO+nVV,nVV),Z2(nOO+nVV,nOO),order1(nVV),order2(nOO))
|
|
|
|
! Initializatiom
|
|
|
|
Om1(:) = 0d0
|
|
X1(:,:) = 0d0
|
|
Y1(:,:) = 0d0
|
|
|
|
Om2(:) = 0d0
|
|
X2(:,:) = 0d0
|
|
Y2(:,:) = 0d0
|
|
|
|
! Compute metric
|
|
|
|
M(:,:) = 0d0
|
|
|
|
do ab=1,nVV
|
|
M(ab,ab) = 1d0
|
|
end do
|
|
|
|
do ij=1,nOO
|
|
M(nVV+ij,nVV+ij) = -1d0
|
|
end do
|
|
|
|
! Start sorting eigenvectors
|
|
|
|
ab = 0
|
|
ij = 0
|
|
|
|
do pq=1,nOO+nVV
|
|
|
|
if(Om(pq) > 0d0) then
|
|
|
|
ab = ab + 1
|
|
Om1(ab) = Om(pq)
|
|
Z1(1:nOO+nVV,ab) = Z(1:nOO+nVV,pq)
|
|
|
|
else
|
|
|
|
ij = ij + 1
|
|
Om2(ij) = Om(pq)
|
|
Z2(1:nOO+nVV,ij) = Z(1:nOO+nVV,pq)
|
|
|
|
end if
|
|
|
|
end do
|
|
|
|
if(minval(Om1) < 0d0 .or. ab /= nVV) call print_warning('You may have instabilities in pp-RPA!!')
|
|
if(maxval(Om2) > 0d0 .or. ij /= nOO) call print_warning('You may have instabilities in pp-RPA!!')
|
|
|
|
if(nVV > 0) then
|
|
|
|
do ab=1,nVV
|
|
order1(ab) = ab
|
|
end do
|
|
|
|
call quick_sort(Om1,order1,nVV)
|
|
call set_order(Z1,order1,nOO+nVV,nVV)
|
|
|
|
end if
|
|
|
|
if(nOO > 0) then
|
|
|
|
do ij=1,nOO
|
|
order2(ij) = ij
|
|
end do
|
|
|
|
call quick_sort(Om2,order2,nOO)
|
|
call set_order(Z2,order2,nOO+nVV,nOO)
|
|
|
|
end if
|
|
|
|
! Orthogonalize eigenvectors
|
|
|
|
! deg1 = 1
|
|
! ab_start = 1
|
|
|
|
! do ab=2,nVV
|
|
|
|
! if(abs(Om1(ab-1) - Om1(ab)) < 1d-6) then
|
|
|
|
! deg1 = deg1 + 1
|
|
|
|
! if(ab == nVV) then
|
|
|
|
! ab_end = ab
|
|
|
|
! allocate(S1(deg1,deg1),O1(deg1,deg1))
|
|
|
|
! S1 = matmul(transpose(Z1(:,ab_start:ab_end)),matmul(M,Z1(:,ab_start:ab_end)))
|
|
! call orthogonalization_matrix(1,deg1,S1,O1)
|
|
! Z1(:,ab_start:ab_end) = matmul(Z1(:,ab_start:ab_end),O1)
|
|
|
|
! deallocate(S1,O1)
|
|
|
|
! end if
|
|
|
|
! else
|
|
|
|
! ab_end = ab - 1
|
|
|
|
! allocate(S1(deg1,deg1),O1(deg1,deg1))
|
|
|
|
! S1 = matmul(transpose(Z1(:,ab_start:ab_end)),matmul(M,Z1(:,ab_start:ab_end)))
|
|
! call orthogonalization_matrix(1,deg1,S1,O1)
|
|
! Z1(:,ab_start:ab_end) = matmul(Z1(:,ab_start:ab_end),O1)
|
|
|
|
! deallocate(S1,O1)
|
|
|
|
! deg1 = 1
|
|
! ab_start = ab
|
|
|
|
! end if
|
|
! end do
|
|
|
|
! deg2 = 1
|
|
! ij_start = 1
|
|
|
|
! do ij=2,nOO
|
|
|
|
! if(abs(Om2(ij-1) - Om2(ij)) < 1d-6) then
|
|
|
|
! deg2 = deg2 + 1
|
|
|
|
! if(ij == nOO) then
|
|
|
|
! ij_end = ij
|
|
!
|
|
! allocate(S2(deg2,deg2),O2(deg2,deg2))
|
|
!
|
|
! S2 = - matmul(transpose(Z2(:,ij_start:ij_end)),matmul(M,Z2(:,ij_start:ij_end)))
|
|
! call orthogonalization_matrix(1,deg2,S2,O2)
|
|
! Z2(:,ij_start:ij_end) = matmul(Z2(:,ij_start:ij_end),O2)
|
|
!
|
|
! deallocate(S2,O2)
|
|
|
|
! end if
|
|
|
|
! else
|
|
|
|
! ij_end = ij - 1
|
|
|
|
! allocate(S2(deg2,deg2),O2(deg2,deg2))
|
|
|
|
! S2 = - matmul(transpose(Z2(:,ij_start:ij_end)),matmul(M,Z2(:,ij_start:ij_end)))
|
|
! call orthogonalization_matrix(1,deg2,S2,O2)
|
|
! Z2(:,ij_start:ij_end) = matmul(Z2(:,ij_start:ij_end),O2)
|
|
|
|
! deallocate(S2,O2)
|
|
|
|
! deg2 = 1
|
|
! ij_start = ij
|
|
|
|
! end if
|
|
! end do
|
|
|
|
allocate(S1(nVV,nVV),S2(nOO,nOO),O1(nVV,nVV),O2(nOO,nOO))
|
|
allocate(tmp1(nOO+nVV,nVV),tmp2(nOO+nVV,nOO))
|
|
|
|
if(nVV > 0) call dgemm ('N', 'N', nOO+nVV, nVV, nOO+nVV, 1d0, M, nOO+nVV, Z1, nOO+nVV, 0d0, tmp1, nOO+nVV)
|
|
if(nVV > 0) call dgemm ('T', 'N', nVV , nVV, nOO+nVV, 1d0, Z1, nOO+nVV, tmp1, nOO+nVV, 0d0, S1, nVV)
|
|
|
|
if(nOO > 0) call dgemm ('N', 'N', nOO+nVV, nOO, nOO+nVV, 1d0, M, nOO+nVV, -1d0*Z2, nOO+nVV, 0d0, tmp2, nOO+nVV)
|
|
if(nOO > 0) call dgemm ('T', 'N', nOO , nOO, nOO+nVV, 1d0, Z2, nOO+nVV, tmp2, nOO+nVV, 0d0, S2, nOO)
|
|
|
|
! S1 = + matmul(transpose(Z1),matmul(M,Z1))
|
|
! S2 = - matmul(transpose(Z2),matmul(M,Z2))
|
|
|
|
if(nVV > 0) call orthogonalization_matrix(nVV,S1,O1)
|
|
if(nOO > 0) call orthogonalization_matrix(nOO,S2,O2)
|
|
|
|
if(nVV > 0) call dgemm ('N', 'N', nOO+nVV,nVV,nVV, 1d0, Z1, nOO+nVV, O1, nVV,0d0, tmp1, nOO+nVV)
|
|
Z1 = tmp1
|
|
if(nOO > 0) call dgemm ('N', 'N', nOO+nVV,nOO,nOO, 1d0, Z2, nOO+nVV, O2, nOO,0d0, tmp2, nOO+nVV)
|
|
Z2 = tmp2
|
|
|
|
! Z1 = matmul(Z1,O1)
|
|
! Z2 = matmul(Z2,O2)
|
|
|
|
! Define submatrices X1, Y1, X2, & Y2
|
|
|
|
X1(1:nVV,1:nVV) = + Z1( 1: nVV,1:nVV)
|
|
Y1(1:nOO,1:nVV) = - Z1(nVV+1:nOO+nVV,1:nVV)
|
|
|
|
X2(1:nVV,1:nOO) = + Z2( 1: nVV,1:nOO)
|
|
Y2(1:nOO,1:nOO) = - Z2(nVV+1:nOO+nVV,1:nOO)
|
|
|
|
! call matout(nVV,nVV,X1)
|
|
! call matout(nOO,nVV,Y1)
|
|
|
|
! call matout(nVV,nOO,X2)
|
|
! call matout(nOO,nOO,Y2)
|
|
|
|
end subroutine
|