2003-01-20 05:58:50 +08:00
|
|
|
!
|
2006-08-09 05:14:26 +08:00
|
|
|
! Copyright (C) 2001-2006 Quantum-ESPRESSO group
|
2003-01-20 05:58:50 +08:00
|
|
|
! This file is distributed under the terms of the
|
|
|
|
! GNU General Public License. See the file `License'
|
|
|
|
! in the root directory of the present distribution,
|
|
|
|
! or http://www.gnu.org/copyleft/gpl.txt .
|
|
|
|
!
|
2004-06-26 01:25:37 +08:00
|
|
|
#include "f_defs.h"
|
2004-03-08 01:18:22 +08:00
|
|
|
!
|
2006-08-09 05:14:26 +08:00
|
|
|
#define ZERO ( 0.D0, 0.D0 )
|
|
|
|
#define ONE ( 1.D0, 0.D0 )
|
|
|
|
!
|
2004-03-08 01:18:22 +08:00
|
|
|
!----------------------------------------------------------------------------
|
|
|
|
SUBROUTINE cdiaghg( n, m, h, s, ldh, e, v )
|
|
|
|
!----------------------------------------------------------------------------
|
|
|
|
!
|
|
|
|
! ... calculates eigenvalues and eigenvectors of the generalized problem
|
2006-08-09 05:14:26 +08:00
|
|
|
! ... Hv=eSv, with H hermitean matrix, S overlap matrix.
|
2004-03-08 01:18:22 +08:00
|
|
|
! ... On output both matrix are unchanged
|
|
|
|
!
|
2004-03-15 18:07:07 +08:00
|
|
|
! ... LAPACK version - uses both ZHEGV and ZHEGVX
|
2004-03-08 01:18:22 +08:00
|
|
|
!
|
2006-08-09 05:14:26 +08:00
|
|
|
USE kinds, ONLY : DP
|
2007-08-14 00:27:37 +08:00
|
|
|
USE mp, ONLY : mp_bcast, mp_sum
|
2007-11-29 17:03:28 +08:00
|
|
|
USE mp_global, ONLY : me_pool, root_pool, intra_pool_comm
|
2004-03-08 01:18:22 +08:00
|
|
|
!
|
|
|
|
IMPLICIT NONE
|
|
|
|
!
|
2006-08-09 05:14:26 +08:00
|
|
|
INTEGER, INTENT(IN) :: n, m, ldh
|
2004-03-08 01:18:22 +08:00
|
|
|
! dimension of the matrix to be diagonalized
|
|
|
|
! number of eigenstates to be calculate
|
|
|
|
! leading dimension of h, as declared in the calling pgm unit
|
2007-07-11 18:58:34 +08:00
|
|
|
COMPLEX(DP), INTENT(INOUT) :: h(ldh,n), s(ldh,n)
|
|
|
|
! actually intent(in) but compilers don't know and complain
|
2004-03-08 01:18:22 +08:00
|
|
|
! matrix to be diagonalized
|
|
|
|
! overlap matrix
|
2006-08-09 05:14:26 +08:00
|
|
|
REAL(DP), INTENT(OUT) :: e(n)
|
2004-03-08 01:18:22 +08:00
|
|
|
! eigenvalues
|
2006-08-09 05:14:26 +08:00
|
|
|
COMPLEX(DP), INTENT(OUT) :: v(ldh,m)
|
2004-03-08 01:18:22 +08:00
|
|
|
! eigenvectors (column-wise)
|
|
|
|
!
|
2007-08-10 04:48:22 +08:00
|
|
|
INTEGER :: lwork, nb, mm, info, i, j, k
|
2004-03-08 01:18:22 +08:00
|
|
|
! mm = number of calculated eigenvectors
|
2007-07-14 03:59:38 +08:00
|
|
|
REAL(DP) :: abstol
|
2006-08-09 05:14:26 +08:00
|
|
|
INTEGER, ALLOCATABLE :: iwork(:), ifail(:)
|
2007-07-11 18:58:34 +08:00
|
|
|
REAL(DP), ALLOCATABLE :: rwork(:), sdiag(:), hdiag(:)
|
|
|
|
COMPLEX(DP), ALLOCATABLE :: work(:)
|
|
|
|
! various work space
|
2006-08-09 05:14:26 +08:00
|
|
|
LOGICAL :: all_eigenvalues
|
2007-07-14 03:59:38 +08:00
|
|
|
! REAL(DP), EXTERNAL :: DLAMCH
|
|
|
|
INTEGER, EXTERNAL :: ILAENV
|
|
|
|
! ILAENV returns optimal block size "nb"
|
2004-03-15 23:25:20 +08:00
|
|
|
!
|
2004-03-08 01:18:22 +08:00
|
|
|
!
|
2007-11-24 00:00:25 +08:00
|
|
|
CALL start_clock( 'cdiaghg' )
|
2004-03-08 01:18:22 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
! ... only the first processor diagonalizes the matrix
|
2004-03-08 01:18:22 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
IF ( me_pool == root_pool ) THEN
|
2004-03-08 01:18:22 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
! ... save the diagonal of input S (it will be overwritten)
|
2004-03-08 01:18:22 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
ALLOCATE( sdiag( n ) )
|
|
|
|
DO i = 1, n
|
|
|
|
sdiag(i) = DBLE( s(i,i) )
|
|
|
|
END DO
|
2006-08-09 05:14:26 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
all_eigenvalues = ( m == n )
|
2006-08-09 05:14:26 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
! ... check for optimal block size
|
2006-08-09 05:14:26 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
nb = ILAENV( 1, 'ZHETRD', 'U', n, -1, -1, -1 )
|
2006-08-09 05:14:26 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
IF ( nb < 1 ) nb = MAX( 1, n )
|
2004-03-08 01:18:22 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
IF ( nb == 1 .OR. nb >= n ) THEN
|
2007-08-10 04:48:22 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
lwork = 2*n
|
2007-08-10 04:48:22 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
ELSE
|
2007-08-10 04:48:22 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
lwork = ( nb + 1 )*n
|
2007-08-10 04:48:22 +08:00
|
|
|
!
|
|
|
|
END IF
|
2006-08-09 05:14:26 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
ALLOCATE( work( lwork ) )
|
2006-08-09 05:14:26 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
IF ( all_eigenvalues ) THEN
|
2007-08-10 04:48:22 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
ALLOCATE( rwork( 3*n - 2 ) )
|
2007-08-10 04:48:22 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
! ... calculate all eigenvalues (overwritten to v)
|
2007-08-10 04:48:22 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
v(:,:) = h(:,:)
|
2007-08-10 04:48:22 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
CALL ZHEGV( 1, 'V', 'U', n, v, ldh, &
|
|
|
|
s, ldh, e, work, lwork, rwork, info )
|
2007-08-10 04:48:22 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
ELSE
|
2007-08-10 04:48:22 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
ALLOCATE( rwork( 7*n ) )
|
2007-07-11 18:58:34 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
! ... save the diagonal of input H (it will be overwritten)
|
2007-07-11 18:58:34 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
ALLOCATE( hdiag( n ) )
|
2007-07-11 18:58:34 +08:00
|
|
|
DO i = 1, n
|
2007-11-29 17:03:28 +08:00
|
|
|
hdiag(i) = DBLE( h(i,i) )
|
2007-07-11 18:58:34 +08:00
|
|
|
END DO
|
2006-08-09 05:14:26 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
ALLOCATE( iwork( 5*n ) )
|
|
|
|
ALLOCATE( ifail( n ) )
|
2003-01-20 05:58:50 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
! ... calculate only m lowest eigenvalues
|
2004-03-08 01:18:22 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
abstol = 0.D0
|
|
|
|
! abstol = 2.D0*DLAMCH( 'S' )
|
2004-03-08 01:18:22 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
CALL ZHEGVX( 1, 'V', 'I', 'U', n, h, ldh, s, ldh, &
|
|
|
|
0.D0, 0.D0, 1, m, abstol, mm, e, v, ldh, &
|
|
|
|
work, lwork, rwork, iwork, ifail, info )
|
2006-08-09 05:14:26 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
DEALLOCATE( ifail )
|
|
|
|
DEALLOCATE( iwork )
|
2003-01-20 05:58:50 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
! ... restore input H matrix from saved diagonal and lower triangle
|
2007-07-11 18:58:34 +08:00
|
|
|
!
|
|
|
|
DO i = 1, n
|
2007-11-29 17:03:28 +08:00
|
|
|
h(i,i) = CMPLX( hdiag(i), 0.0_DP )
|
2007-07-11 18:58:34 +08:00
|
|
|
DO j = i + 1, n
|
2007-11-29 17:03:28 +08:00
|
|
|
h(i,j) = CONJG( h(j,i) )
|
2007-07-11 18:58:34 +08:00
|
|
|
END DO
|
|
|
|
DO j = n + 1, ldh
|
2007-11-29 17:03:28 +08:00
|
|
|
h(j,i) = ( 0.0_DP, 0.0_DP )
|
2007-07-11 18:58:34 +08:00
|
|
|
END DO
|
|
|
|
END DO
|
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
DEALLOCATE( hdiag )
|
2007-07-11 18:58:34 +08:00
|
|
|
!
|
2004-03-08 01:18:22 +08:00
|
|
|
END IF
|
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
DEALLOCATE( rwork )
|
|
|
|
DEALLOCATE( work )
|
|
|
|
!
|
|
|
|
CALL errore( 'cdiaghg', 'info =/= 0', ABS( info ) )
|
2004-03-08 01:18:22 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
! ... restore input S matrix from saved diagonal and lower triangle
|
|
|
|
!
|
|
|
|
DO i = 1, n
|
|
|
|
s(i,i) = CMPLX( sdiag(i), 0.0_DP )
|
|
|
|
DO j = i + 1, n
|
|
|
|
s(i,j) = CONJG( s(j,i) )
|
|
|
|
END DO
|
|
|
|
DO j = n + 1, ldh
|
|
|
|
s(j,i) = ( 0.0_DP, 0.0_DP )
|
|
|
|
END DO
|
|
|
|
END DO
|
|
|
|
!
|
|
|
|
DEALLOCATE( sdiag )
|
2004-03-08 01:18:22 +08:00
|
|
|
!
|
|
|
|
END IF
|
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
! ... broadcast eigenvectors and eigenvalues to all other processors
|
|
|
|
!
|
|
|
|
CALL mp_bcast( e, root_pool, intra_pool_comm )
|
|
|
|
CALL mp_bcast( v, root_pool, intra_pool_comm )
|
|
|
|
!
|
2007-11-24 00:00:25 +08:00
|
|
|
CALL stop_clock( 'cdiaghg' )
|
2003-01-20 05:58:50 +08:00
|
|
|
!
|
2004-03-08 01:18:22 +08:00
|
|
|
RETURN
|
2003-01-20 05:58:50 +08:00
|
|
|
!
|
2004-03-08 01:18:22 +08:00
|
|
|
END SUBROUTINE cdiaghg
|
2007-08-21 06:03:48 +08:00
|
|
|
!
|
|
|
|
!----------------------------------------------------------------------------
|
|
|
|
SUBROUTINE pcdiaghg( n, h, s, ldh, e, v, desc )
|
|
|
|
!----------------------------------------------------------------------------
|
|
|
|
!
|
|
|
|
! ... calculates eigenvalues and eigenvectors of the generalized problem
|
|
|
|
! ... Hv=eSv, with H hermitean matrix, S overlap matrix.
|
|
|
|
! ... On output both matrix are unchanged
|
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
! ... Parallel version, with full data distribution
|
2007-08-21 06:03:48 +08:00
|
|
|
!
|
|
|
|
USE kinds, ONLY : DP
|
|
|
|
USE mp, ONLY : mp_bcast
|
|
|
|
USE mp_global, ONLY : root_pool, intra_pool_comm
|
2008-01-04 07:37:21 +08:00
|
|
|
USE zhpev_module, ONLY : pzhpev_drv, zhpev_drv
|
2007-08-21 06:03:48 +08:00
|
|
|
USE descriptors, ONLY : descla_siz_ , lambda_node_ , nlax_ , la_nrl_ , la_nrlx_ , &
|
2008-01-04 07:37:21 +08:00
|
|
|
la_npc_ , la_npr_ , la_me_ , la_comm_ , la_myc_ , la_myr_
|
|
|
|
USE parallel_toolkit, ONLY : zsqmdst, zsqmcll
|
2007-08-21 06:03:48 +08:00
|
|
|
!
|
|
|
|
IMPLICIT NONE
|
|
|
|
!
|
|
|
|
INTEGER, INTENT(IN) :: n, ldh
|
|
|
|
! dimension of the matrix to be diagonalized
|
|
|
|
! leading dimension of h, as declared in the calling pgm unit
|
|
|
|
COMPLEX(DP), INTENT(INOUT) :: h(ldh,ldh), s(ldh,ldh)
|
|
|
|
! actually intent(in) but compilers don't know and complain
|
|
|
|
! matrix to be diagonalized
|
|
|
|
! overlap matrix
|
|
|
|
REAL(DP), INTENT(OUT) :: e(n)
|
|
|
|
! eigenvalues
|
|
|
|
COMPLEX(DP), INTENT(OUT) :: v(ldh,ldh)
|
|
|
|
! eigenvectors (column-wise)
|
|
|
|
INTEGER, INTENT(IN) :: desc( descla_siz_ )
|
|
|
|
!
|
|
|
|
INTEGER :: nx, nrl, nrlx
|
|
|
|
! local block size
|
|
|
|
COMPLEX(DP), ALLOCATABLE :: ss(:,:), hh(:,:)
|
|
|
|
COMPLEX(DP), ALLOCATABLE :: diag(:,:), vv(:,:)
|
|
|
|
! work space used only in parallel diagonalization
|
2008-01-04 07:37:21 +08:00
|
|
|
INTEGER :: i, j, k
|
2007-08-21 06:03:48 +08:00
|
|
|
!
|
|
|
|
! ... input s and h are copied so that they are not destroyed
|
|
|
|
!
|
2007-11-24 00:00:25 +08:00
|
|
|
CALL start_clock( 'cdiaghg' )
|
2007-09-20 19:55:13 +08:00
|
|
|
!
|
2007-08-21 06:03:48 +08:00
|
|
|
IF( desc( lambda_node_ ) > 0 ) THEN
|
|
|
|
!
|
|
|
|
nx = desc( nlax_ )
|
|
|
|
nrl = desc( la_nrl_ )
|
|
|
|
nrlx = desc( la_nrlx_ )
|
|
|
|
!
|
|
|
|
IF( nx /= ldh ) &
|
|
|
|
CALL errore(" pcdiaghg ", " inconsistent leading dimension ", ldh )
|
|
|
|
!
|
|
|
|
ALLOCATE( hh( nx, nx ) )
|
|
|
|
ALLOCATE( ss( nx, nx ) )
|
|
|
|
!
|
|
|
|
hh(1:nx,1:nx) = h(1:nx,1:nx)
|
|
|
|
ss(1:nx,1:nx) = s(1:nx,1:nx)
|
|
|
|
!
|
|
|
|
END IF
|
|
|
|
|
2007-11-24 00:00:25 +08:00
|
|
|
CALL start_clock( 'cdiaghg:choldc' )
|
2007-08-21 06:03:48 +08:00
|
|
|
!
|
|
|
|
! ... Cholesky decomposition of sl ( L is stored in sl )
|
|
|
|
!
|
|
|
|
IF( desc( lambda_node_ ) > 0 ) THEN
|
|
|
|
!
|
|
|
|
CALL pzpotf( ss, nx, n, desc )
|
|
|
|
!
|
|
|
|
END IF
|
|
|
|
!
|
2007-11-24 00:00:25 +08:00
|
|
|
CALL stop_clock( 'cdiaghg:choldc' )
|
2007-08-21 06:03:48 +08:00
|
|
|
!
|
|
|
|
! ... L is inverted ( sl = L^-1 )
|
|
|
|
!
|
2007-11-26 17:35:30 +08:00
|
|
|
CALL start_clock( 'cdiaghg:inversion' )
|
2007-08-21 06:03:48 +08:00
|
|
|
!
|
|
|
|
IF( desc( lambda_node_ ) > 0 ) THEN
|
|
|
|
!
|
|
|
|
CALL pztrtri( ss, nx, n, desc )
|
|
|
|
!
|
|
|
|
END IF
|
|
|
|
!
|
2007-11-24 00:00:25 +08:00
|
|
|
CALL stop_clock( 'cdiaghg:inversion' )
|
2007-08-21 06:03:48 +08:00
|
|
|
!
|
|
|
|
! ... vl = L^-1*H
|
|
|
|
!
|
2007-11-24 00:00:25 +08:00
|
|
|
CALL start_clock( 'cdiaghg:paragemm' )
|
2007-08-21 06:03:48 +08:00
|
|
|
!
|
|
|
|
IF( desc( lambda_node_ ) > 0 ) THEN
|
|
|
|
!
|
|
|
|
CALL sqr_zmm_cannon( 'N', 'N', n, ONE, ss, nx, hh, nx, ZERO, v, nx, desc )
|
|
|
|
!
|
|
|
|
END IF
|
|
|
|
!
|
|
|
|
! ... hl = ( L^-1*H )*(L^-1)^T
|
|
|
|
!
|
|
|
|
IF( desc( lambda_node_ ) > 0 ) THEN
|
|
|
|
!
|
|
|
|
CALL sqr_zmm_cannon( 'N', 'C', n, ONE, v, nx, ss, nx, ZERO, hh, nx, desc )
|
|
|
|
!
|
|
|
|
END IF
|
|
|
|
!
|
2007-11-24 00:00:25 +08:00
|
|
|
CALL stop_clock( 'cdiaghg:paragemm' )
|
2007-08-21 06:03:48 +08:00
|
|
|
!
|
|
|
|
IF ( desc( lambda_node_ ) > 0 ) THEN
|
|
|
|
!
|
|
|
|
! Compute local dimension of the cyclically distributed matrix
|
|
|
|
!
|
2008-01-04 07:37:21 +08:00
|
|
|
#ifdef WORKING_PZHPEV
|
2007-08-21 06:03:48 +08:00
|
|
|
ALLOCATE( diag( nrlx, n ) )
|
|
|
|
ALLOCATE( vv( nrlx, n ) )
|
|
|
|
!
|
|
|
|
CALL blk2cyc_zredist( n, diag, nrlx, hh, nx, desc )
|
|
|
|
!
|
|
|
|
CALL pzhpev_drv( 'V', diag, nrlx, e, vv, nrlx, nrl, n, &
|
|
|
|
desc( la_npc_ ) * desc( la_npr_ ), desc( la_me_ ), desc( la_comm_ ) )
|
|
|
|
!
|
|
|
|
CALL cyc2blk_zredist( n, vv, nrlx, hh, nx, desc )
|
|
|
|
!
|
|
|
|
DEALLOCATE( vv )
|
|
|
|
DEALLOCATE( diag )
|
2008-01-04 07:37:21 +08:00
|
|
|
#else
|
|
|
|
ALLOCATE( diag( n*(n+1)/2, 1 ) )
|
|
|
|
ALLOCATE( vv( n, n ) )
|
|
|
|
CALL zsqmcll( n, hh, nx, vv, n, desc, desc( la_comm_ ) )
|
|
|
|
IF( desc( la_myc_ ) == 0 .AND. desc( la_myr_ ) == 0 ) THEN
|
|
|
|
k = 1
|
|
|
|
DO j = 1, n
|
|
|
|
DO i = j, n
|
|
|
|
diag( k, 1 ) = vv( i, j )
|
|
|
|
k = k + 1
|
|
|
|
END DO
|
|
|
|
END DO
|
|
|
|
call zhpev_drv( 'V', 'L', N, diag(:,1), e, vv, n )
|
|
|
|
END IF
|
|
|
|
CALL mp_bcast( vv, 0, desc( la_comm_ ) )
|
|
|
|
CALL zsqmdst( n, vv, n, hh, nx, desc )
|
|
|
|
DEALLOCATE( diag )
|
|
|
|
DEALLOCATE( vv )
|
|
|
|
#endif
|
2007-08-21 06:03:48 +08:00
|
|
|
!
|
|
|
|
END IF
|
|
|
|
!
|
|
|
|
! ... v = (L^T)^-1 v
|
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
CALL start_clock( 'cdiaghg:paragemm' )
|
2007-08-21 06:03:48 +08:00
|
|
|
!
|
|
|
|
IF ( desc( lambda_node_ ) > 0 ) THEN
|
|
|
|
!
|
|
|
|
CALL sqr_zmm_cannon( 'C', 'N', n, ONE, ss, nx, hh, nx, ZERO, v, nx, desc )
|
|
|
|
!
|
|
|
|
END IF
|
|
|
|
!
|
|
|
|
CALL mp_bcast( e, root_pool, intra_pool_comm )
|
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
CALL stop_clock( 'cdiaghg:paragemm' )
|
2007-08-21 06:03:48 +08:00
|
|
|
!
|
|
|
|
IF ( desc( lambda_node_ ) > 0 ) THEN
|
|
|
|
DEALLOCATE( ss, hh )
|
|
|
|
END IF
|
|
|
|
!
|
2007-11-24 00:00:25 +08:00
|
|
|
CALL stop_clock( 'cdiaghg' )
|
2007-09-20 19:55:13 +08:00
|
|
|
!
|
2007-08-21 06:03:48 +08:00
|
|
|
RETURN
|
|
|
|
!
|
|
|
|
END SUBROUTINE pcdiaghg
|
2007-11-29 17:03:28 +08:00
|
|
|
!
|
|
|
|
!----------------------------------------------------------------------------
|
|
|
|
SUBROUTINE pcdiaghg_nodist( n, m, h, s, ldh, e, v )
|
|
|
|
!----------------------------------------------------------------------------
|
|
|
|
!
|
|
|
|
! ... calculates eigenvalues and eigenvectors of the generalized problem
|
|
|
|
! ... Hv=eSv, with H hermitean matrix, S overlap matrix.
|
|
|
|
! ... On output both matrix are unchanged
|
|
|
|
!
|
|
|
|
! ... Parallel version, matrices are NOT distributed
|
|
|
|
!
|
|
|
|
USE kinds, ONLY : DP
|
|
|
|
USE control_flags, ONLY : use_para_diag
|
|
|
|
USE mp, ONLY : mp_bcast, mp_sum
|
|
|
|
USE mp_global, ONLY : npool, nproc_pool, me_pool, root_pool, &
|
|
|
|
intra_pool_comm, init_ortho_group, &
|
|
|
|
ortho_comm, np_ortho, me_ortho, ortho_comm_id
|
|
|
|
USE zhpev_module, ONLY : pzhpev_drv
|
|
|
|
USE descriptors, ONLY : descla_siz_ , descla_init , lambda_node_ , &
|
|
|
|
nlax_ , la_nrl_ , ilac_ , ilar_ , nlar_ , &
|
|
|
|
nlac_ , la_npc_ , la_npr_ , la_me_ , la_comm_
|
|
|
|
!
|
|
|
|
IMPLICIT NONE
|
|
|
|
!
|
|
|
|
INTEGER, INTENT(IN) :: n, m, ldh
|
|
|
|
! dimension of the matrix to be diagonalized
|
|
|
|
! number of eigenstates to be calculate
|
|
|
|
! leading dimension of h, as declared in the calling pgm unit
|
|
|
|
COMPLEX(DP), INTENT(INOUT) :: h(ldh,n), s(ldh,n)
|
|
|
|
! actually intent(in) but compilers don't know and complain
|
|
|
|
! matrix to be diagonalized
|
|
|
|
! overlap matrix
|
|
|
|
REAL(DP), INTENT(OUT) :: e(n)
|
|
|
|
! eigenvalues
|
|
|
|
COMPLEX(DP), INTENT(OUT) :: v(ldh,m)
|
|
|
|
! eigenvectors (column-wise)
|
|
|
|
!
|
|
|
|
INTEGER :: lwork, nb, mm, info, i, j, k
|
|
|
|
! mm = number of calculated eigenvectors
|
|
|
|
INTEGER :: nr, nc, ir, ic, nx, nrl
|
|
|
|
! local block size
|
|
|
|
REAL(DP) :: abstol
|
|
|
|
INTEGER, ALLOCATABLE :: iwork(:), ifail(:)
|
|
|
|
REAL(DP), ALLOCATABLE :: rwork(:), sdiag(:), hdiag(:)
|
|
|
|
COMPLEX(DP), ALLOCATABLE :: work(:)
|
|
|
|
! various work space
|
|
|
|
COMPLEX(DP), ALLOCATABLE :: sl(:,:), hl(:,:), vl(:,:)
|
|
|
|
COMPLEX(DP), ALLOCATABLE :: diag(:,:), vv(:,:)
|
|
|
|
! work space used only in parallel diagonalization
|
|
|
|
LOGICAL :: all_eigenvalues
|
|
|
|
! REAL(DP), EXTERNAL :: DLAMCH
|
|
|
|
INTEGER, EXTERNAL :: ILAENV
|
|
|
|
! ILAENV returns optimal block size "nb"
|
|
|
|
INTEGER :: desc( descla_siz_ )
|
|
|
|
!
|
|
|
|
!
|
|
|
|
CALL start_clock( 'cdiaghg' )
|
|
|
|
!
|
|
|
|
CALL descla_init( desc, n, n, np_ortho, me_ortho, ortho_comm, ortho_comm_id )
|
|
|
|
!
|
|
|
|
! ... input s and h are copied so that they are not destroyed
|
|
|
|
!
|
|
|
|
IF( desc( lambda_node_ ) > 0 ) THEN
|
|
|
|
ir = desc( ilar_ )
|
|
|
|
ic = desc( ilac_ )
|
|
|
|
nr = desc( nlar_ )
|
|
|
|
nc = desc( nlac_ )
|
|
|
|
nx = desc( nlax_ )
|
|
|
|
nrl = desc( la_nrl_ )
|
|
|
|
ALLOCATE( sl( nx , nx ) )
|
|
|
|
ALLOCATE( vl( nx , nx ) )
|
|
|
|
ALLOCATE( hl( nx , nx ) )
|
|
|
|
DO j = 1, nc
|
|
|
|
DO i = 1, nr
|
|
|
|
sl( i, j ) = s( i + ir - 1, j + ic - 1 )
|
|
|
|
END DO
|
|
|
|
DO i = nr+1, nx
|
|
|
|
sl( i, j ) = 0.0d0
|
|
|
|
END DO
|
|
|
|
END DO
|
|
|
|
DO j = nc + 1, nx
|
|
|
|
DO i = 1, nx
|
|
|
|
sl( i, j ) = 0.0d0
|
|
|
|
END DO
|
|
|
|
END DO
|
|
|
|
DO j = 1, nc
|
|
|
|
DO i = 1, nr
|
|
|
|
hl( i, j ) = h( i + ir - 1, j + ic - 1 )
|
|
|
|
END DO
|
|
|
|
DO i = nr+1, nx
|
|
|
|
hl( i, j ) = 0.0d0
|
|
|
|
END DO
|
|
|
|
END DO
|
|
|
|
DO j = nc + 1, nx
|
|
|
|
DO i = 1, nx
|
|
|
|
hl( i, j ) = 0.0d0
|
|
|
|
END DO
|
|
|
|
END DO
|
|
|
|
END IF
|
|
|
|
|
|
|
|
CALL start_clock( 'cdiaghg:choldc' )
|
|
|
|
!
|
|
|
|
! ... Cholesky decomposition of sl ( L is stored in sl )
|
|
|
|
!
|
|
|
|
IF( desc( lambda_node_ ) > 0 ) THEN
|
|
|
|
!
|
|
|
|
CALL pzpotf( sl, nx, n, desc )
|
|
|
|
!
|
|
|
|
END IF
|
|
|
|
!
|
|
|
|
CALL stop_clock( 'cdiaghg:choldc' )
|
|
|
|
!
|
|
|
|
! ... L is inverted ( sl = L^-1 )
|
|
|
|
!
|
|
|
|
CALL start_clock( 'cdiaghg:inversion' )
|
|
|
|
!
|
|
|
|
IF( desc( lambda_node_ ) > 0 ) THEN
|
|
|
|
!
|
|
|
|
CALL pztrtri( sl, nx, n, desc )
|
|
|
|
!
|
|
|
|
END IF
|
|
|
|
!
|
|
|
|
CALL stop_clock( 'cdiaghg:inversion' )
|
|
|
|
!
|
|
|
|
! ... vl = L^-1*H
|
|
|
|
!
|
|
|
|
CALL start_clock( 'cdiaghg:paragemm' )
|
|
|
|
!
|
|
|
|
IF( desc( lambda_node_ ) > 0 ) THEN
|
|
|
|
!
|
|
|
|
CALL sqr_zmm_cannon( 'N', 'N', n, ONE, sl, nx, hl, nx, ZERO, vl, nx, desc )
|
|
|
|
!
|
|
|
|
END IF
|
|
|
|
!
|
|
|
|
! ... hl = ( L^-1*H )*(L^-1)^T
|
|
|
|
!
|
|
|
|
IF( desc( lambda_node_ ) > 0 ) THEN
|
|
|
|
!
|
|
|
|
CALL sqr_zmm_cannon( 'N', 'C', n, ONE, vl, nx, sl, nx, ZERO, hl, nx, desc )
|
|
|
|
!
|
|
|
|
END IF
|
|
|
|
!
|
|
|
|
CALL stop_clock( 'cdiaghg:paragemm' )
|
|
|
|
!
|
|
|
|
IF ( desc( lambda_node_ ) > 0 ) THEN
|
|
|
|
!
|
|
|
|
! Compute local dimension of the cyclically distributed matrix
|
|
|
|
!
|
|
|
|
ALLOCATE( diag( nrl, n ) )
|
|
|
|
ALLOCATE( vv( nrl, n ) )
|
|
|
|
!
|
|
|
|
CALL blk2cyc_zredist( n, diag, nrl, hl, nx, desc )
|
|
|
|
!
|
|
|
|
CALL pzhpev_drv( 'V', diag, nrl, e, vv, nrl, nrl, n, &
|
|
|
|
desc( la_npc_ ) * desc( la_npr_ ), desc( la_me_ ), desc( la_comm_ ) )
|
|
|
|
!
|
|
|
|
CALL cyc2blk_zredist( n, vv, nrl, vl, nx, desc )
|
|
|
|
!
|
|
|
|
DEALLOCATE( vv )
|
|
|
|
DEALLOCATE( diag )
|
|
|
|
!
|
|
|
|
END IF
|
|
|
|
!
|
|
|
|
! ... v = (L^T)^-1 v
|
|
|
|
!
|
|
|
|
CALL start_clock( 'cdiaghg:paragemm' )
|
|
|
|
!
|
|
|
|
v(1:n,1:n) = ZERO
|
|
|
|
!
|
|
|
|
IF ( desc( lambda_node_ ) > 0 ) THEN
|
|
|
|
!
|
|
|
|
CALL sqr_zmm_cannon( 'C', 'N', n, ONE, sl, nx, vl, nx, ZERO, hl, nx, desc )
|
|
|
|
!
|
|
|
|
DO j = 1, nc
|
|
|
|
DO i = 1, nr
|
|
|
|
v( i + ir - 1, j + ic - 1 ) = hl( i, j )
|
|
|
|
END DO
|
|
|
|
END DO
|
|
|
|
!
|
|
|
|
END IF
|
|
|
|
!
|
|
|
|
CALL mp_bcast( e, root_pool, intra_pool_comm )
|
|
|
|
CALL mp_sum( v(1:n,1:n), intra_pool_comm )
|
|
|
|
!
|
|
|
|
CALL stop_clock( 'cdiaghg:paragemm' )
|
|
|
|
!
|
|
|
|
IF ( desc( lambda_node_ ) > 0 ) THEN
|
|
|
|
DEALLOCATE( sl, vl, hl )
|
|
|
|
END IF
|
|
|
|
!
|
|
|
|
CALL stop_clock( 'cdiaghg' )
|
|
|
|
!
|
|
|
|
RETURN
|
|
|
|
!
|
|
|
|
END SUBROUTINE pcdiaghg_nodist
|