mirror of
https://gitlab.com/scemama/qp_plugins_scemama.git
synced 2024-11-07 06:33:40 +01:00
56 lines
1.4 KiB
Forth
56 lines
1.4 KiB
Forth
subroutine lapack_g_non_sym_real(n, H, LDH, S, LDS, beta, &
|
|
n_real, vl, LDVL, vr, LDVR)
|
|
implicit none
|
|
integer, intent(in) :: n, LDH, LDS, LDVL, LDVR
|
|
double precision, intent(in) :: H(LDH,n), S(LDS,n)
|
|
double precision, intent(out) :: VL(LDVL,n), VR(LDVR,n), beta(n)
|
|
integer, intent(out) :: n_real
|
|
|
|
integer :: lwork, info, i,j
|
|
double precision, allocatable :: work(:)
|
|
double precision, allocatable :: alphar(:), alphai(:), vltmp(:,:), vrtmp(:,:)
|
|
integer, allocatable :: iorder(:)
|
|
|
|
|
|
lwork = -1
|
|
allocate(work(1), alphar(n), alphai(n), vltmp(n,n), vrtmp(n,n))
|
|
|
|
call dggev('V', 'V', n, H, size(H,1), S, size(S,1), alphar, alphai, beta, &
|
|
vltmp, size(vltmp,1), vrtmp, size(vrtmp,1), work, lwork, info)
|
|
|
|
lwork = int(work(1))
|
|
deallocate(work)
|
|
allocate(work(lwork))
|
|
call dggev('V', 'V', n, H, size(H,1), S, size(S,1), alphar, alphai, beta, &
|
|
vltmp, size(vltmp,1), vrtmp, size(vrtmp,1), work, lwork, info)
|
|
|
|
deallocate(work)
|
|
if (info /= 0) then
|
|
stop 'DGGEV Diagonalization failed'
|
|
endif
|
|
|
|
allocate(iorder(n))
|
|
n_real = 0
|
|
do i=1,n
|
|
iorder(i) = i
|
|
if (dabs(alphai(i)) < 1.d-10) then
|
|
n_real += 1
|
|
alphar(i) = dble(huge(1.0))
|
|
endif
|
|
enddo
|
|
|
|
beta(:) = alphar(:)/beta(:)
|
|
call dsort(beta, iorder, n)
|
|
|
|
do i=1,n_real
|
|
do j=1,n
|
|
vr(j,i) = vrtmp(j,iorder(i))
|
|
vl(j,i) = vltmp(j,iorder(i))
|
|
end do
|
|
end do
|
|
|
|
deallocate(vrtmp, vltmp, iorder)
|
|
|
|
end
|
|
|