2003-12-10 22:57:07 +08:00
|
|
|
!
|
2013-04-28 00:44:01 +08:00
|
|
|
! Copyright (C) 2003-2013 Quantum ESPRESSO group
|
2003-12-10 22:57:07 +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 .
|
|
|
|
!
|
|
|
|
!
|
|
|
|
!----------------------------------------------------------------------------
|
|
|
|
SUBROUTINE rdiaghg( n, m, h, s, ldh, e, v )
|
2013-04-28 00:44:01 +08:00
|
|
|
!----------------------------------------------------------------------------
|
2006-08-09 05:14:26 +08:00
|
|
|
! ... Hv=eSv, with H symmetric matrix, S overlap matrix.
|
2004-03-15 23:25:20 +08:00
|
|
|
! ... On output both matrix are unchanged
|
2003-12-10 22:57:07 +08:00
|
|
|
!
|
2006-08-09 05:14:26 +08:00
|
|
|
! ... LAPACK version - uses both DSYGV and DSYGVX
|
2003-12-10 22:57:07 +08:00
|
|
|
!
|
2017-08-09 05:44:44 +08:00
|
|
|
USE la_param, ONLY : DP
|
KS_Solvers directory has been created with three subdirectories:
KS_Solvers/CG, KS_Solvers/Davidson, KS_Solvers/Davidson_RCI.
Two are currently used by QE, the third one implements the Davidson
diagonalization within the Reverse Communication Interface paradigm,
courtesy of Micael Oliveira.
KS_Solvers routines depend only on lower level libraries, notably UtilXlib,
LAXlib, (SCA)LAPACK, and BLAS.
reorganization can be improved. For instance some duplicated routines like
cdiaghg and rdiaghg could/should be moved in LAXlib. This could reduce the need
to include KS_Solvers directories in the link step of many codes.
Minimal changes to calling sequence have been made, essentially just adding
h_psi,s_psi,g_psi and h_1psi,s_1psi routines names as arguments (with a
specific calling sequence ihardcode inside the routines that agree with PWSCF one).
This could be avoided adopting the RCI paradigm.
Compiled in serial and parallel, 177/182 pw tests passed (3 that were failing
even before on my laptop pw-berry, pw-langevin, pw-pawatom + 2 unknown==not tested),
12 /17 cp tests passed (some o2-us-para-pbe-X fail but the same was for the
original version)
I assume the modified calling procedure is working and the problem lies somewhere else.
Randomly tested some examples in pw, ph, pwcond and it seams to work.
Please report any problem.
git-svn-id: http://qeforge.qe-forge.org/svn/q-e/trunk/espresso@13644 c92efa57-630b-4861-b058-cf58834340f0
2017-07-29 20:19:19 +08:00
|
|
|
USE mp, ONLY : mp_bcast
|
2017-08-09 05:44:44 +08:00
|
|
|
USE mp_bands_util, ONLY : me_bgrp, root_bgrp, intra_bgrp_comm
|
2003-12-10 22:57:07 +08:00
|
|
|
!
|
2006-08-09 05:14:26 +08:00
|
|
|
IMPLICIT NONE
|
2003-12-10 22:57:07 +08:00
|
|
|
!
|
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 calculated
|
|
|
|
! leading dimension of h, as declared in the calling pgm unit
|
2007-07-14 03:59:38 +08:00
|
|
|
REAL(DP), INTENT(INOUT) :: h(ldh,n), s(ldh,n)
|
2004-03-08 01:18:22 +08:00
|
|
|
! matrix to be diagonalized
|
|
|
|
! overlap matrix
|
2003-12-10 22:57:07 +08:00
|
|
|
!
|
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
|
|
|
REAL(DP), INTENT(OUT) :: v(ldh,m)
|
2004-03-08 01:18:22 +08:00
|
|
|
! eigenvectors (column-wise)
|
2003-12-10 22:57:07 +08:00
|
|
|
!
|
KS_Solvers directory has been created with three subdirectories:
KS_Solvers/CG, KS_Solvers/Davidson, KS_Solvers/Davidson_RCI.
Two are currently used by QE, the third one implements the Davidson
diagonalization within the Reverse Communication Interface paradigm,
courtesy of Micael Oliveira.
KS_Solvers routines depend only on lower level libraries, notably UtilXlib,
LAXlib, (SCA)LAPACK, and BLAS.
reorganization can be improved. For instance some duplicated routines like
cdiaghg and rdiaghg could/should be moved in LAXlib. This could reduce the need
to include KS_Solvers directories in the link step of many codes.
Minimal changes to calling sequence have been made, essentially just adding
h_psi,s_psi,g_psi and h_1psi,s_1psi routines names as arguments (with a
specific calling sequence ihardcode inside the routines that agree with PWSCF one).
This could be avoided adopting the RCI paradigm.
Compiled in serial and parallel, 177/182 pw tests passed (3 that were failing
even before on my laptop pw-berry, pw-langevin, pw-pawatom + 2 unknown==not tested),
12 /17 cp tests passed (some o2-us-para-pbe-X fail but the same was for the
original version)
I assume the modified calling procedure is working and the problem lies somewhere else.
Randomly tested some examples in pw, ph, pwcond and it seams to work.
Please report any problem.
git-svn-id: http://qeforge.qe-forge.org/svn/q-e/trunk/espresso@13644 c92efa57-630b-4861-b058-cf58834340f0
2017-07-29 20:19:19 +08:00
|
|
|
INTEGER :: lwork, nb, mm, info, i, j
|
2004-03-08 01:18:22 +08:00
|
|
|
! mm = number of calculated eigenvectors
|
2007-07-14 03:59:38 +08:00
|
|
|
REAL(DP) :: abstol
|
2007-08-14 00:27:37 +08:00
|
|
|
REAL(DP), PARAMETER :: one = 1_DP
|
|
|
|
REAL(DP), PARAMETER :: zero = 0_DP
|
2006-08-09 05:14:26 +08:00
|
|
|
INTEGER, ALLOCATABLE :: iwork(:), ifail(:)
|
2007-07-14 03:59:38 +08:00
|
|
|
REAL(DP), ALLOCATABLE :: work(:), sdiag(:), hdiag(:)
|
2006-08-09 05:14:26 +08:00
|
|
|
LOGICAL :: all_eigenvalues
|
2007-07-14 03:59:38 +08:00
|
|
|
INTEGER, EXTERNAL :: ILAENV
|
2006-08-09 05:14:26 +08:00
|
|
|
! ILAENV returns optimal block size "nb"
|
2003-12-10 22:57:07 +08:00
|
|
|
!
|
2007-11-24 00:00:25 +08:00
|
|
|
CALL start_clock( 'rdiaghg' )
|
2003-12-10 22:57:07 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
! ... only the first processor diagonalize the matrix
|
|
|
|
!
|
2011-12-05 19:02:07 +08:00
|
|
|
IF ( me_bgrp == root_bgrp ) THEN
|
2007-08-18 23:48:07 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
! ... save the diagonal of input S (it will be overwritten)
|
2006-08-09 05:14:26 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
ALLOCATE( sdiag( n ) )
|
|
|
|
DO i = 1, n
|
|
|
|
sdiag(i) = 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 )
|
2007-08-14 00:27:37 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
! ... check for optimal block size
|
2007-09-20 19:56:46 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
nb = ILAENV( 1, 'DSYTRD', 'U', n, -1, -1, -1 )
|
2007-09-20 19:56:46 +08:00
|
|
|
!
|
2010-05-27 03:32:04 +08:00
|
|
|
IF ( nb < 5 .OR. nb >= n ) THEN
|
2007-09-20 19:56:46 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
lwork = 8*n
|
2007-09-20 19:56:46 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
ELSE
|
2007-09-20 19:56:46 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
lwork = ( nb + 3 )*n
|
2007-09-20 19:56:46 +08:00
|
|
|
!
|
|
|
|
END IF
|
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
ALLOCATE( work( lwork ) )
|
2007-09-20 19:56:46 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
IF ( all_eigenvalues ) THEN
|
2007-09-20 19:56:46 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
! ... calculate all eigenvalues
|
2007-09-20 19:56:46 +08:00
|
|
|
!
|
2018-08-14 07:36:48 +08:00
|
|
|
!$omp parallel do
|
|
|
|
do i =1, n
|
|
|
|
v(1:ldh,i) = h(1:ldh,i)
|
|
|
|
end do
|
|
|
|
!$omp end parallel do
|
2007-09-20 19:56:46 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
#if defined (__ESSL)
|
2007-09-20 19:56:46 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
! ... there is a name conflict between essl and lapack ...
|
2007-09-20 19:56:46 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
CALL DSYGV( 1, v, ldh, s, ldh, e, v, ldh, n, work, lwork )
|
2007-09-20 19:56:46 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
info = 0
|
|
|
|
#else
|
|
|
|
CALL DSYGV( 1, 'V', 'U', n, v, ldh, s, ldh, e, work, lwork, info )
|
|
|
|
#endif
|
2007-09-20 19:56:46 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
ELSE
|
2007-09-20 19:56:46 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
! ... calculate only m lowest eigenvalues
|
2007-09-20 19:56:46 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
ALLOCATE( iwork( 5*n ) )
|
|
|
|
ALLOCATE( ifail( n ) )
|
2007-07-14 03:59:38 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
! ... save the diagonal of input H (it will be overwritten)
|
2007-07-14 03:59:38 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
ALLOCATE( hdiag( n ) )
|
2007-07-14 03:59:38 +08:00
|
|
|
DO i = 1, n
|
2007-11-29 17:03:28 +08:00
|
|
|
hdiag(i) = h(i,i)
|
2007-07-14 03:59:38 +08:00
|
|
|
END DO
|
2003-12-10 22:57:07 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
abstol = 0.D0
|
|
|
|
! abstol = 2.D0*DLAMCH( 'S' )
|
2003-12-10 22:57:07 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
CALL DSYGVX( 1, 'V', 'I', 'U', n, h, ldh, s, ldh, &
|
|
|
|
0.D0, 0.D0, 1, m, abstol, mm, e, v, ldh, &
|
|
|
|
work, lwork, iwork, ifail, info )
|
2003-12-10 22:57:07 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
DEALLOCATE( ifail )
|
|
|
|
DEALLOCATE( iwork )
|
2004-03-08 01:18:22 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
! ... restore input H matrix from saved diagonal and lower triangle
|
2007-07-14 03:59:38 +08:00
|
|
|
!
|
2018-08-14 07:36:48 +08:00
|
|
|
!$omp parallel do
|
2007-07-14 03:59:38 +08:00
|
|
|
DO i = 1, n
|
2007-11-29 17:03:28 +08:00
|
|
|
h(i,i) = hdiag(i)
|
2007-07-14 03:59:38 +08:00
|
|
|
DO j = i + 1, n
|
2007-11-29 17:03:28 +08:00
|
|
|
h(i,j) = h(j,i)
|
2007-07-14 03:59:38 +08:00
|
|
|
END DO
|
|
|
|
DO j = n + 1, ldh
|
2007-11-29 17:03:28 +08:00
|
|
|
h(j,i) = 0.0_DP
|
2007-07-14 03:59:38 +08:00
|
|
|
END DO
|
|
|
|
END DO
|
2018-08-14 07:36:48 +08:00
|
|
|
!$omp end parallel do
|
2007-07-14 03:59:38 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
DEALLOCATE( hdiag )
|
2007-07-14 03:59:38 +08:00
|
|
|
!
|
2003-12-10 22:57:07 +08:00
|
|
|
END IF
|
2004-03-08 01:18:22 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
DEALLOCATE( work )
|
|
|
|
!
|
2012-06-11 17:45:25 +08:00
|
|
|
IF ( info > n ) THEN
|
|
|
|
CALL errore( 'rdiaghg', 'S matrix not positive definite', ABS( info ) )
|
|
|
|
ELSE IF ( info > 0 ) THEN
|
|
|
|
CALL errore( 'rdiaghg', 'eigenvectors failed to converge', ABS( info ) )
|
|
|
|
ELSE IF ( info < 0 ) THEN
|
|
|
|
CALL errore( 'rdiaghg', 'incorrect call to DSYGV*', ABS( info ) )
|
|
|
|
END IF
|
2008-07-31 23:59:22 +08:00
|
|
|
|
2007-11-29 17:03:28 +08:00
|
|
|
! ... restore input S matrix from saved diagonal and lower triangle
|
|
|
|
!
|
2018-08-14 07:36:48 +08:00
|
|
|
!$omp parallel do
|
2007-11-29 17:03:28 +08:00
|
|
|
DO i = 1, n
|
|
|
|
s(i,i) = sdiag(i)
|
|
|
|
DO j = i + 1, n
|
|
|
|
s(i,j) = s(j,i)
|
|
|
|
END DO
|
|
|
|
DO j = n + 1, ldh
|
|
|
|
s(j,i) = 0.0_DP
|
|
|
|
END DO
|
|
|
|
END DO
|
2018-08-14 07:36:48 +08:00
|
|
|
!$omp end parallel do
|
2004-03-08 01:18:22 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
DEALLOCATE( sdiag )
|
2004-03-08 01:18:22 +08:00
|
|
|
!
|
2003-12-10 22:57:07 +08:00
|
|
|
END IF
|
2004-03-08 01:18:22 +08:00
|
|
|
!
|
2007-11-29 17:03:28 +08:00
|
|
|
! ... broadcast eigenvectors and eigenvalues to all other processors
|
|
|
|
!
|
2011-12-05 19:02:07 +08:00
|
|
|
CALL mp_bcast( e, root_bgrp, intra_bgrp_comm )
|
|
|
|
CALL mp_bcast( v, root_bgrp, intra_bgrp_comm )
|
2007-11-29 17:03:28 +08:00
|
|
|
!
|
2007-11-24 00:00:25 +08:00
|
|
|
CALL stop_clock( 'rdiaghg' )
|
2003-12-10 22:57:07 +08:00
|
|
|
!
|
|
|
|
RETURN
|
|
|
|
!
|
2016-08-29 06:23:24 +08:00
|
|
|
END SUBROUTINE rdiaghg
|
2007-08-18 23:48:07 +08:00
|
|
|
!
|
|
|
|
!----------------------------------------------------------------------------
|
|
|
|
SUBROUTINE prdiaghg( n, h, s, ldh, e, v, desc )
|
|
|
|
!----------------------------------------------------------------------------
|
|
|
|
!
|
|
|
|
! ... calculates eigenvalues and eigenvectors of the generalized problem
|
|
|
|
! ... Hv=eSv, with H symmetric matrix, S overlap matrix.
|
|
|
|
! ... On output both matrix are unchanged
|
|
|
|
!
|
2010-05-27 03:32:04 +08:00
|
|
|
! ... Parallel version with full data distribution
|
2007-08-18 23:48:07 +08:00
|
|
|
!
|
2017-08-09 05:44:44 +08:00
|
|
|
USE la_param, ONLY : DP
|
KS_Solvers directory has been created with three subdirectories:
KS_Solvers/CG, KS_Solvers/Davidson, KS_Solvers/Davidson_RCI.
Two are currently used by QE, the third one implements the Davidson
diagonalization within the Reverse Communication Interface paradigm,
courtesy of Micael Oliveira.
KS_Solvers routines depend only on lower level libraries, notably UtilXlib,
LAXlib, (SCA)LAPACK, and BLAS.
reorganization can be improved. For instance some duplicated routines like
cdiaghg and rdiaghg could/should be moved in LAXlib. This could reduce the need
to include KS_Solvers directories in the link step of many codes.
Minimal changes to calling sequence have been made, essentially just adding
h_psi,s_psi,g_psi and h_1psi,s_1psi routines names as arguments (with a
specific calling sequence ihardcode inside the routines that agree with PWSCF one).
This could be avoided adopting the RCI paradigm.
Compiled in serial and parallel, 177/182 pw tests passed (3 that were failing
even before on my laptop pw-berry, pw-langevin, pw-pawatom + 2 unknown==not tested),
12 /17 cp tests passed (some o2-us-para-pbe-X fail but the same was for the
original version)
I assume the modified calling procedure is working and the problem lies somewhere else.
Randomly tested some examples in pw, ph, pwcond and it seams to work.
Please report any problem.
git-svn-id: http://qeforge.qe-forge.org/svn/q-e/trunk/espresso@13644 c92efa57-630b-4861-b058-cf58834340f0
2017-07-29 20:19:19 +08:00
|
|
|
USE mp, ONLY : mp_bcast
|
|
|
|
USE descriptors, ONLY : la_descriptor
|
2017-08-19 21:27:51 +08:00
|
|
|
USE mp_diag, ONLY : ortho_parent_comm
|
2008-11-23 02:13:30 +08:00
|
|
|
#if defined __SCALAPACK
|
KS_Solvers directory has been created with three subdirectories:
KS_Solvers/CG, KS_Solvers/Davidson, KS_Solvers/Davidson_RCI.
Two are currently used by QE, the third one implements the Davidson
diagonalization within the Reverse Communication Interface paradigm,
courtesy of Micael Oliveira.
KS_Solvers routines depend only on lower level libraries, notably UtilXlib,
LAXlib, (SCA)LAPACK, and BLAS.
reorganization can be improved. For instance some duplicated routines like
cdiaghg and rdiaghg could/should be moved in LAXlib. This could reduce the need
to include KS_Solvers directories in the link step of many codes.
Minimal changes to calling sequence have been made, essentially just adding
h_psi,s_psi,g_psi and h_1psi,s_1psi routines names as arguments (with a
specific calling sequence ihardcode inside the routines that agree with PWSCF one).
This could be avoided adopting the RCI paradigm.
Compiled in serial and parallel, 177/182 pw tests passed (3 that were failing
even before on my laptop pw-berry, pw-langevin, pw-pawatom + 2 unknown==not tested),
12 /17 cp tests passed (some o2-us-para-pbe-X fail but the same was for the
original version)
I assume the modified calling procedure is working and the problem lies somewhere else.
Randomly tested some examples in pw, ph, pwcond and it seams to work.
Please report any problem.
git-svn-id: http://qeforge.qe-forge.org/svn/q-e/trunk/espresso@13644 c92efa57-630b-4861-b058-cf58834340f0
2017-07-29 20:19:19 +08:00
|
|
|
USE mp_diag, ONLY : ortho_cntx, me_blacs, np_ortho, me_ortho, ortho_comm
|
|
|
|
USE dspev_module, ONLY : pdsyevd_drv
|
2008-11-23 02:13:30 +08:00
|
|
|
#endif
|
2007-08-18 23:48:07 +08:00
|
|
|
!
|
|
|
|
!
|
|
|
|
IMPLICIT NONE
|
|
|
|
!
|
|
|
|
INTEGER, INTENT(IN) :: n, ldh
|
|
|
|
! dimension of the matrix to be diagonalized and number of eigenstates to be calculated
|
|
|
|
! leading dimension of h, as declared in the calling pgm unit
|
2007-08-21 06:02:08 +08:00
|
|
|
REAL(DP), INTENT(INOUT) :: h(ldh,ldh), s(ldh,ldh)
|
2007-08-18 23:48:07 +08:00
|
|
|
! matrix to be diagonalized
|
|
|
|
! overlap matrix
|
|
|
|
!
|
|
|
|
REAL(DP), INTENT(OUT) :: e(n)
|
|
|
|
! eigenvalues
|
2007-08-21 06:02:08 +08:00
|
|
|
REAL(DP), INTENT(OUT) :: v(ldh,ldh)
|
2007-08-18 23:48:07 +08:00
|
|
|
! eigenvectors (column-wise)
|
2011-07-25 05:56:14 +08:00
|
|
|
TYPE(la_descriptor), INTENT(IN) :: desc
|
2007-08-18 23:48:07 +08:00
|
|
|
!
|
2017-08-19 21:27:51 +08:00
|
|
|
INTEGER, PARAMETER :: root = 0
|
2008-12-08 20:55:54 +08:00
|
|
|
INTEGER :: nx
|
2007-08-18 23:48:07 +08:00
|
|
|
! local block size
|
|
|
|
REAL(DP), PARAMETER :: one = 1_DP
|
|
|
|
REAL(DP), PARAMETER :: zero = 0_DP
|
|
|
|
REAL(DP), ALLOCATABLE :: hh(:,:)
|
|
|
|
REAL(DP), ALLOCATABLE :: ss(:,:)
|
2016-09-13 00:34:38 +08:00
|
|
|
#if defined(__SCALAPACK)
|
2008-11-23 02:13:30 +08:00
|
|
|
INTEGER :: desch( 16 ), info
|
|
|
|
#endif
|
2018-08-14 07:36:48 +08:00
|
|
|
INTEGER :: i
|
2007-08-18 23:48:07 +08:00
|
|
|
!
|
2007-11-24 00:00:25 +08:00
|
|
|
CALL start_clock( 'rdiaghg' )
|
2007-09-20 19:56:46 +08:00
|
|
|
!
|
2011-07-25 05:56:14 +08:00
|
|
|
IF( desc%active_node > 0 ) THEN
|
2007-08-18 23:48:07 +08:00
|
|
|
!
|
2011-07-25 05:56:14 +08:00
|
|
|
nx = desc%nrcx
|
2007-08-18 23:48:07 +08:00
|
|
|
!
|
|
|
|
IF( nx /= ldh ) &
|
|
|
|
CALL errore(" prdiaghg ", " inconsistent leading dimension ", ldh )
|
|
|
|
!
|
|
|
|
ALLOCATE( hh( nx, nx ) )
|
|
|
|
ALLOCATE( ss( nx, nx ) )
|
|
|
|
!
|
2018-08-14 07:36:48 +08:00
|
|
|
!$omp parallel do
|
|
|
|
do i=1,nx
|
|
|
|
hh(1:nx,i) = h(1:nx,i)
|
|
|
|
ss(1:nx,i) = s(1:nx,i)
|
|
|
|
end do
|
|
|
|
!$omp end parallel do
|
2007-08-18 23:48:07 +08:00
|
|
|
!
|
|
|
|
END IF
|
|
|
|
!
|
2007-11-24 00:00:25 +08:00
|
|
|
CALL start_clock( 'rdiaghg:choldc' )
|
2007-08-18 23:48:07 +08:00
|
|
|
!
|
|
|
|
! ... Cholesky decomposition of s ( L is stored in s )
|
|
|
|
!
|
2011-07-25 05:56:14 +08:00
|
|
|
IF( desc%active_node > 0 ) THEN
|
2007-08-18 23:48:07 +08:00
|
|
|
!
|
2016-09-13 00:34:38 +08:00
|
|
|
#if defined(__SCALAPACK)
|
2011-07-25 05:56:14 +08:00
|
|
|
CALL descinit( desch, n, n, desc%nrcx, desc%nrcx, 0, 0, ortho_cntx, SIZE( hh, 1 ) , info )
|
2008-11-23 02:13:30 +08:00
|
|
|
|
2012-10-13 00:32:23 +08:00
|
|
|
IF( info /= 0 ) CALL errore( ' rdiaghg ', ' descinit ', ABS( info ) )
|
2008-11-23 02:13:30 +08:00
|
|
|
#endif
|
|
|
|
!
|
2016-09-13 00:34:38 +08:00
|
|
|
#if defined(__SCALAPACK)
|
2008-11-23 02:13:30 +08:00
|
|
|
CALL PDPOTRF( 'L', n, ss, 1, 1, desch, info )
|
|
|
|
IF( info /= 0 ) CALL errore( ' rdiaghg ', ' problems computing cholesky ', ABS( info ) )
|
|
|
|
#else
|
2008-11-20 06:16:41 +08:00
|
|
|
CALL qe_pdpotrf( ss, nx, n, desc )
|
2008-11-23 02:13:30 +08:00
|
|
|
#endif
|
2007-08-18 23:48:07 +08:00
|
|
|
!
|
|
|
|
END IF
|
|
|
|
!
|
2007-11-24 00:00:25 +08:00
|
|
|
CALL stop_clock( 'rdiaghg:choldc' )
|
2007-08-18 23:48:07 +08:00
|
|
|
!
|
|
|
|
! ... L is inverted ( s = L^-1 )
|
|
|
|
!
|
2007-11-24 00:00:25 +08:00
|
|
|
CALL start_clock( 'rdiaghg:inversion' )
|
2007-08-18 23:48:07 +08:00
|
|
|
!
|
2011-07-25 05:56:14 +08:00
|
|
|
IF( desc%active_node > 0 ) THEN
|
2007-08-18 23:48:07 +08:00
|
|
|
!
|
2016-09-13 00:34:38 +08:00
|
|
|
#if defined(__SCALAPACK)
|
2008-12-08 20:55:54 +08:00
|
|
|
!
|
|
|
|
CALL sqr_dsetmat( 'U', n, zero, ss, size(ss,1), desc )
|
2008-11-23 02:13:30 +08:00
|
|
|
|
|
|
|
CALL PDTRTRI( 'L', 'N', n, ss, 1, 1, desch, info )
|
|
|
|
!
|
|
|
|
IF( info /= 0 ) CALL errore( ' rdiaghg ', ' problems computing inverse ', ABS( info ) )
|
|
|
|
#else
|
2008-11-20 06:16:41 +08:00
|
|
|
CALL qe_pdtrtri ( ss, nx, n, desc )
|
2008-11-23 02:13:30 +08:00
|
|
|
#endif
|
2007-08-18 23:48:07 +08:00
|
|
|
!
|
|
|
|
END IF
|
|
|
|
!
|
2007-11-24 00:00:25 +08:00
|
|
|
CALL stop_clock( 'rdiaghg:inversion' )
|
2007-08-18 23:48:07 +08:00
|
|
|
!
|
|
|
|
! ... v = L^-1*H
|
|
|
|
!
|
2007-11-24 00:00:25 +08:00
|
|
|
CALL start_clock( 'rdiaghg:paragemm' )
|
2007-08-18 23:48:07 +08:00
|
|
|
!
|
2011-07-25 05:56:14 +08:00
|
|
|
IF( desc%active_node > 0 ) THEN
|
2007-08-18 23:48:07 +08:00
|
|
|
!
|
|
|
|
CALL sqr_mm_cannon( 'N', 'N', n, ONE, ss, nx, hh, nx, ZERO, v, nx, desc )
|
|
|
|
!
|
|
|
|
END IF
|
|
|
|
!
|
|
|
|
! ... h = ( L^-1*H )*(L^-1)^T
|
|
|
|
!
|
2011-07-25 05:56:14 +08:00
|
|
|
IF( desc%active_node > 0 ) THEN
|
2007-08-18 23:48:07 +08:00
|
|
|
!
|
|
|
|
CALL sqr_mm_cannon( 'N', 'T', n, ONE, v, nx, ss, nx, ZERO, hh, nx, desc )
|
|
|
|
!
|
|
|
|
END IF
|
|
|
|
!
|
2007-11-24 00:00:25 +08:00
|
|
|
CALL stop_clock( 'rdiaghg:paragemm' )
|
2007-08-18 23:48:07 +08:00
|
|
|
!
|
2011-07-25 05:56:14 +08:00
|
|
|
IF ( desc%active_node > 0 ) THEN
|
2007-08-18 23:48:07 +08:00
|
|
|
!
|
|
|
|
! Compute local dimension of the cyclically distributed matrix
|
|
|
|
!
|
2016-09-13 00:34:38 +08:00
|
|
|
#if defined(__SCALAPACK)
|
2016-01-24 04:10:10 +08:00
|
|
|
CALL pdsyevd_drv( .true., n, desc%nrcx, hh, SIZE(hh,1), e, ortho_cntx, ortho_comm )
|
2008-10-26 17:28:59 +08:00
|
|
|
#else
|
2008-12-08 20:55:54 +08:00
|
|
|
CALL qe_pdsyevd( .true., n, desc, hh, SIZE(hh,1), e )
|
2008-10-26 17:28:59 +08:00
|
|
|
#endif
|
2007-08-18 23:48:07 +08:00
|
|
|
!
|
|
|
|
END IF
|
|
|
|
!
|
|
|
|
! ... v = (L^T)^-1 v
|
|
|
|
!
|
2007-11-24 00:00:25 +08:00
|
|
|
CALL start_clock( 'rdiaghg:paragemm' )
|
2007-08-18 23:48:07 +08:00
|
|
|
!
|
2011-07-25 05:56:14 +08:00
|
|
|
IF ( desc%active_node > 0 ) THEN
|
2007-08-18 23:48:07 +08:00
|
|
|
!
|
|
|
|
CALL sqr_mm_cannon( 'T', 'N', n, ONE, ss, nx, hh, nx, ZERO, v, nx, desc )
|
|
|
|
!
|
|
|
|
DEALLOCATE( ss )
|
|
|
|
DEALLOCATE( hh )
|
|
|
|
!
|
|
|
|
END IF
|
|
|
|
!
|
2017-08-19 21:27:51 +08:00
|
|
|
CALL mp_bcast( e, root, ortho_parent_comm )
|
2007-08-18 23:48:07 +08:00
|
|
|
!
|
2007-11-24 00:00:25 +08:00
|
|
|
CALL stop_clock( 'rdiaghg:paragemm' )
|
2007-08-18 23:48:07 +08:00
|
|
|
!
|
2007-11-24 00:00:25 +08:00
|
|
|
CALL stop_clock( 'rdiaghg' )
|
2007-09-20 19:56:46 +08:00
|
|
|
!
|
2007-08-18 23:48:07 +08:00
|
|
|
RETURN
|
2008-10-26 17:28:59 +08:00
|
|
|
!
|
2007-08-18 23:48:07 +08:00
|
|
|
END SUBROUTINE prdiaghg
|