Commit 7684a40c authored by Daniel Wortmann's avatar Daniel Wortmann

Added functionality to test diagonalization (started ..)

parent cc07bc9d
...@@ -39,7 +39,7 @@ CONTAINS ...@@ -39,7 +39,7 @@ CONTAINS
parallel_solver_available=any((/diag_elpa,diag_elemental,diag_scalapack/)>0) parallel_solver_available=any((/diag_elpa,diag_elemental,diag_scalapack/)>0)
END FUNCTION parallel_solver_available END FUNCTION parallel_solver_available
SUBROUTINE eigen_diag(hmat,smat,ikpt,jsp,iter,ne,eig,ev) SUBROUTINE eigen_diag(mpi,hmat,smat,ikpt,jsp,iter,ne,eig,ev)
USE m_lapack_diag USE m_lapack_diag
USE m_magma USE m_magma
USE m_elpa USE m_elpa
...@@ -47,10 +47,12 @@ CONTAINS ...@@ -47,10 +47,12 @@ CONTAINS
USE m_elemental USE m_elemental
USE m_chase_diag USE m_chase_diag
USE m_types_mpimat USE m_types_mpimat
USE m_matrix_copy
IMPLICIT NONE IMPLICIT NONE
#ifdef CPP_MPI #ifdef CPP_MPI
include 'mpif.h' include 'mpif.h'
#endif #endif
TYPE(t_mpi), INTENT(IN) :: mpi
CLASS(t_mat), INTENT(INOUT) :: smat,hmat CLASS(t_mat), INTENT(INOUT) :: smat,hmat
CLASS(t_mat), ALLOCATABLE, INTENT(OUT) :: ev CLASS(t_mat), ALLOCATABLE, INTENT(OUT) :: ev
INTEGER, INTENT(IN) :: ikpt INTEGER, INTENT(IN) :: ikpt
...@@ -59,15 +61,33 @@ CONTAINS ...@@ -59,15 +61,33 @@ CONTAINS
INTEGER, INTENT(INOUT) :: ne INTEGER, INTENT(INOUT) :: ne
REAL, INTENT(OUT) :: eig(:) REAL, INTENT(OUT) :: eig(:)
!Locals !Locals
LOGICAL :: parallel LOGICAL :: parallel
!For check-mode
TYPE(t_mat) :: s_store,h_store
SELECT TYPE(smat) SELECT TYPE(smat)
CLASS IS (t_mpimat) CLASS IS (t_mpimat)
parallel=.TRUE. parallel=.TRUE.
CLASS default CLASS default
parallel=.FALSE. parallel=.FALSE.
END SELECT END SELECT
!Create a copy of the matrix if in test mode
IF (judft_was_argument("-diag:test")) THEN
SELECT TYPE(hmat)
CLASS IS (t_mpimat)
CALL s_store%init(hmat%l_real,hmat%global_size1,hmat%global_size2)
CALL h_store%init(hmat%l_real,hmat%global_size1,hmat%global_size2)
CLASS default
CALL s_store%init(hmat%l_real,hmat%matsize1,hmat%matsize2)
CALL h_store%init(hmat%l_real,hmat%matsize1,hmat%matsize2)
END SELECT
CALL matrix_copy(smat,s_store)
CALL matrix_copy(hmat,h_store)
END IF
CALL timestart("Diagonalization") CALL timestart("Diagonalization")
!Select the solver !Select the solver
SELECT CASE (priv_select_solver(parallel)) SELECT CASE (priv_select_solver(parallel))
...@@ -90,11 +110,61 @@ CONTAINS ...@@ -90,11 +110,61 @@ CONTAINS
CASE (diag_debugout) CASE (diag_debugout)
CALL priv_debug_out(smat,hmat) CALL priv_debug_out(smat,hmat)
END SELECT END SELECT
!Create test the solution
IF (judft_was_argument("-diag:test")) THEN
CALL priv_test_solution(mpi,ne,s_store,h_store,eig,ev)
CALL judft_error("Diagonalization tested")
END IF
CALL timestop("Diagonalization") CALL timestop("Diagonalization")
! !
END SUBROUTINE eigen_diag END SUBROUTINE eigen_diag
SUBROUTINE priv_test_solution(mpi,ne,s_store,h_store,eig1,ev)
USE m_types
USE m_lapack_diag
USE m_matrix_copy
IMPLICIT NONE
TYPE(t_mpi),INTENT(in):: mpi
INTEGER,INTENT(INOUT) :: ne
TYPE(t_mat) :: s_store,h_store
REAL,INTENT(in) :: eig1(:)
CLASS(t_mat) :: ev
REAL,ALLOCATABLE::eig2(:)
TYPE(t_mat) ::ev1
CLASS(t_mat),ALLOCATABLE ::ev2
INTEGER :: i,irank
ALLOCATE(eig2(ne))
CALL ev1%init(s_store%l_real,s_store%matsize1,s_store%matsize2)
CALL matrix_copy(ev,ev1)
IF (mpi%irank==0) THEN
CALL lapack_diag(h_store,s_store,ne,eig2,ev2)
OPEN(99,file="diag.compare")
WRITE(99,*) "Eigenvalues"
DO i=1,ne
WRITE(99,*) i,eig1(i),eig2(i)
ENDDO
WRITE(99,*) "Eigenvectors"
DO i=1,ne
IF (ev1%l_real) THEN
WRITE(99,"(i0,20(1x,f10.5))") i,ev1%data_r(1:10,i)
WRITE(99,"(i0,20(1x,f10.5))") i,ev2%data_r(1:10,i)
ELSE
WRITE(99,"(i0,20(1x,f10.5))") i,ev1%data_c(1:10,i)
WRITE(99,"(i0,20(1x,f10.5))") i,ev2%data_c(1:10,i)
END IF
ENDDO
CLOSE(99)
END IF
END SUBROUTINE priv_test_solution
SUBROUTINE priv_debug_out(smat,hmat) SUBROUTINE priv_debug_out(smat,hmat)
USE m_types USE m_types
use m_judft use m_judft
......
...@@ -183,7 +183,7 @@ CONTAINS ...@@ -183,7 +183,7 @@ CONTAINS
end select end select
END IF END IF
CALL eigen_diag(hmat,smat,nk,jsp,iter,ne_all,eig,zMat) CALL eigen_diag(mpi,hmat,smat,nk,jsp,iter,ne_all,eig,zMat)
DEALLOCATE(hmat,smat) DEALLOCATE(hmat,smat)
! Output results ! Output results
......
...@@ -32,10 +32,15 @@ CONTAINS ...@@ -32,10 +32,15 @@ CONTAINS
CALL mat_final%init(mat(1,1)%l_real,m,m,mpi%sub_comm,.TRUE.) !here the .true. creates a block-cyclic scalapack distribution CALL mat_final%init(mat(1,1)%l_real,m,m,mpi%sub_comm,.TRUE.) !here the .true. creates a block-cyclic scalapack distribution
!up-up component (or only component in collinear case) !up-up component (or only component in collinear case)
IF (SIZE(mat)==1) THEN
CALL mat_final%move(mat(1,1))
CALL mat(1,1)%free()
RETURN
ENDIF
CALL mat_final%copy(mat(1,1),1,1) CALL mat_final%copy(mat(1,1),1,1)
CALL mat(1,1)%free() CALL mat(1,1)%free()
IF (SIZE(mat)==1) RETURN
!down-down component !down-down component
CALL mat_final%copy(mat(2,2),lapw%nv(1)+atoms%nlotot+1,lapw%nv(1)+atoms%nlotot+1) CALL mat_final%copy(mat(2,2),lapw%nv(1)+atoms%nlotot+1,lapw%nv(1)+atoms%nlotot+1)
CALL mat(2,2)%free() CALL mat(2,2)%free()
......
...@@ -19,6 +19,7 @@ global/savewigner.f ...@@ -19,6 +19,7 @@ global/savewigner.f
) )
set(fleur_F90 ${fleur_F90} set(fleur_F90 ${fleur_F90}
global/constants.f90 global/constants.f90
global/matrix_copy.F90
global/checkdop.F90 global/checkdop.F90
global/checkdopall.f90 global/checkdopall.f90
global/genMTBasis.f90 global/genMTBasis.f90
......
!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------
!<@brief
!<This matrix_copy module is needed to copy a distributed into a non-distributed matrix or vice versa
!<It calls the usual matrix-copy routines in other cases
MODULE m_matrix_copy
IMPLICIT NONE
CONTAINS
SUBROUTINE matrix_copy(mat_in,mat_out)
USE m_types
USE m_types_mpimat
CLASS(t_mat),INTENT(IN) ::mat_in
CLASS(t_mat),INTENT(INOUT)::mat_out
TYPE(t_mpimat)::tmp_mat
#ifdef CPP_MPI
INCLUDE 'mpif.h'
#else
INTEGER:: MPI_COMM_SELF
#endif
SELECT TYPE(mat_in)
CLASS is(t_mpimat)
SELECT TYPE(mat_out)
CLASS is(t_mpimat)
CALL mat_out%copy(mat_in,1,1)
CLASS is(t_mat)
!Copy from t_mpimat to t_mat
CALL tmp_mat%init(mat_in%l_real,mat_in%global_size1,mat_in%global_size2,MPI_COMM_SELF)
CALL tmp_mat%copy(mat_in,1,1) !redistribute to single matrix
IF (tmp_mat%l_real) THEN
CALL move_ALLOC(tmp_mat%data_r,mat_out%data_r)
ELSE
CALL move_ALLOC(tmp_mat%data_r,mat_out%data_r)
ENDIF
END SELECT
CLASS is (t_mat)
SELECT TYPE(mat_out)
CLASS is(t_mpimat)
!Copy from non-distributed t_mat to t_mpimat
CALL tmp_mat%init(mat_in%l_real,mat_in%matsize1,mat_in%matsize1,MPI_COMM_SELF)
IF (tmp_mat%l_real) THEN
tmp_mat%data_r=mat_in%data_r
ELSE
tmp_mat%data_c=mat_in%data_c
ENDIF
CALL mat_out%copy(tmp_mat,1,1)
CLASS is(t_mat)
CALL mat_out%copy(mat_in,1,1)
END SELECT
END SELECT
END SUBROUTINE matrix_copy
END MODULE m_matrix_copy
...@@ -23,6 +23,7 @@ MODULE m_types_mat ...@@ -23,6 +23,7 @@ MODULE m_types_mat
PROCEDURE :: to_packed=>t_mat_to_packed !> convert to packed-storage matrix PROCEDURE :: to_packed=>t_mat_to_packed !> convert to packed-storage matrix
PROCEDURE :: clear => t_mat_clear !> set data arrays to zero PROCEDURE :: clear => t_mat_clear !> set data arrays to zero
PROCEDURE :: copy => t_mat_copy !> copy into another t_mat (overloaded for t_mpimat) PROCEDURE :: copy => t_mat_copy !> copy into another t_mat (overloaded for t_mpimat)
PROCEDURE :: move => t_mat_move !> move data into another t_mat (overloaded for t_mpimat)
PROCEDURE :: init => t_mat_init !> initalize the matrix(overloaded for t_mpimat) PROCEDURE :: init => t_mat_init !> initalize the matrix(overloaded for t_mpimat)
PROCEDURE :: free => t_mat_free !> dealloc the data (overloaded for t_mpimat) PROCEDURE :: free => t_mat_free !> dealloc the data (overloaded for t_mpimat)
PROCEDURE :: add_transpose => t_mat_add_transpose!> add the tranpose/Hermitian conjg. without the diagonal (overloaded for t_mpimat) PROCEDURE :: add_transpose => t_mat_add_transpose!> add the tranpose/Hermitian conjg. without the diagonal (overloaded for t_mpimat)
...@@ -219,24 +220,26 @@ MODULE m_types_mat ...@@ -219,24 +220,26 @@ MODULE m_types_mat
end if end if
end subroutine t_mat_inverse end subroutine t_mat_inverse
SUBROUTINE t_mat_move(mat,mat1)
IMPLICIT NONE
CLASS(t_mat),INTENT(INOUT):: mat
CLASS(t_mat),INTENT(INOUT):: mat1
!Special case, the full matrix is copied. Then use move alloc
IF (mat%l_real) THEN
CALL move_ALLOC(mat1%data_r,mat%data_r)
ELSE
CALL move_ALLOC(mat1%data_c,mat%data_c)
END IF
END SUBROUTINE t_mat_move
SUBROUTINE t_mat_copy(mat,mat1,n1,n2) SUBROUTINE t_mat_copy(mat,mat1,n1,n2)
IMPLICIT NONE IMPLICIT NONE
CLASS(t_mat),INTENT(INOUT):: mat CLASS(t_mat),INTENT(INOUT):: mat
CLASS(t_mat),INTENT(INOUT) :: mat1 CLASS(t_mat),INTENT(IN) :: mat1
INTEGER,INTENT(IN) :: n1,n2 INTEGER,INTENT(IN) :: n1,n2
INTEGER:: i1,i2 INTEGER:: i1,i2
IF (n1==1.AND.n2==1.AND.mat%matsize1==mat1%matsize1.AND.mat%matsize2==mat1%matsize2) THEN
!Special case, the full matrix is copied. Then use move alloc
IF (mat%l_real) THEN
CALL move_ALLOC(mat1%data_r,mat%data_r)
ELSE
CALL move_ALLOC(mat1%data_c,mat%data_c)
END IF
RETURN
END IF
i1=mat%matsize1-n1+1 !space available for first dimension i1=mat%matsize1-n1+1 !space available for first dimension
i2=mat%matsize2-n1+1 i2=mat%matsize2-n1+1
i1=MIN(i1,mat1%matsize1) i1=MIN(i1,mat1%matsize1)
......
...@@ -27,6 +27,7 @@ MODULE m_types_mpimat ...@@ -27,6 +27,7 @@ MODULE m_types_mpimat
INTEGER:: npcol,nprow !> the number of columns/rows in the processor grid INTEGER:: npcol,nprow !> the number of columns/rows in the processor grid
CONTAINS CONTAINS
PROCEDURE,PASS :: copy => mpimat_copy !<overwriten from t_mat, also performs redistribution PROCEDURE,PASS :: copy => mpimat_copy !<overwriten from t_mat, also performs redistribution
PROCEDURE,PASS :: move => mpimat_move !<overwriten from t_mat, also performs redistribution
PROCEDURE,PASS :: free => mpimat_free !<overwriten from t_mat, takes care of blacs-grids PROCEDURE,PASS :: free => mpimat_free !<overwriten from t_mat, takes care of blacs-grids
PROCEDURE,PASS :: init => mpimat_init !<overwriten from t_mat, also calls alloc in t_mat PROCEDURE,PASS :: init => mpimat_init !<overwriten from t_mat, also calls alloc in t_mat
PROCEDURE,PASS :: add_transpose => mpimat_add_transpose !<overwriten from t_mat PROCEDURE,PASS :: add_transpose => mpimat_add_transpose !<overwriten from t_mat
...@@ -178,7 +179,7 @@ CONTAINS ...@@ -178,7 +179,7 @@ CONTAINS
SUBROUTINE mpimat_copy(mat,mat1,n1,n2) SUBROUTINE mpimat_copy(mat,mat1,n1,n2)
IMPLICIT NONE IMPLICIT NONE
CLASS(t_mpimat),INTENT(INOUT)::mat CLASS(t_mpimat),INTENT(INOUT)::mat
CLASS(t_mat),INTENT(INOUT) ::mat1 CLASS(t_mat),INTENT(IN) ::mat1
INTEGER,INTENT(IN) ::n1,n2 INTEGER,INTENT(IN) ::n1,n2
#ifdef CPP_SCALAPACK #ifdef CPP_SCALAPACK
SELECT TYPE(mat1) SELECT TYPE(mat1)
...@@ -193,7 +194,14 @@ CONTAINS ...@@ -193,7 +194,14 @@ CONTAINS
END SELECT END SELECT
#endif #endif
END SUBROUTINE mpimat_copy END SUBROUTINE mpimat_copy
SUBROUTINE mpimat_move(mat,mat1)
IMPLICIT NONE
CLASS(t_mpimat),INTENT(INOUT)::mat
CLASS(t_mat),INTENT(INOUT) ::mat1
CALL mat%copy(mat1,1,1)
END SUBROUTINE mpimat_move
SUBROUTINE mpimat_free(mat) SUBROUTINE mpimat_free(mat)
IMPLICIT NONE IMPLICIT NONE
CLASS(t_mpimat),INTENT(INOUT) :: mat CLASS(t_mpimat),INTENT(INOUT) :: mat
...@@ -217,7 +225,7 @@ CONTAINS ...@@ -217,7 +225,7 @@ CONTAINS
INTEGER,INTENT(IN),OPTIONAL :: matsize1,matsize2,mpi_subcom INTEGER,INTENT(IN),OPTIONAL :: matsize1,matsize2,mpi_subcom
LOGICAL,INTENT(IN),OPTIONAL :: l_real,l_2d LOGICAL,INTENT(IN),OPTIONAL :: l_real,l_2d
INTEGER,INTENT(IN),OPTIONAL :: nb_y,nb_x INTEGER,INTENT(IN),OPTIONAL :: nb_y,nb_x
#ifdef CPP_SCALAPACK
INTEGER::nbx,nby,irank,ierr INTEGER::nbx,nby,irank,ierr
include 'mpif.h' include 'mpif.h'
nbx=DEFAULT_BLOCKSIZE; nby=DEFAULT_BLOCKSIZE nbx=DEFAULT_BLOCKSIZE; nby=DEFAULT_BLOCKSIZE
...@@ -238,6 +246,7 @@ CONTAINS ...@@ -238,6 +246,7 @@ CONTAINS
CALL MPI_COMM_RANK(mpi_subcom,irank,ierr) CALL MPI_COMM_RANK(mpi_subcom,irank,ierr)
IF (irank>0) mat%blacs_desc(2)=-1 IF (irank>0) mat%blacs_desc(2)=-1
END IF END IF
#endif
END SUBROUTINE mpimat_init END SUBROUTINE mpimat_init
SUBROUTINE priv_create_blacsgrid(mpi_subcom,l_2d,m1,m2,nbc,nbr,ictextblacs,sc_desc,local_size1,local_size2,nprow,npcol) SUBROUTINE priv_create_blacsgrid(mpi_subcom,l_2d,m1,m2,nbc,nbr,ictextblacs,sc_desc,local_size1,local_size2,nprow,npcol)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment