Commit 55d11190 authored by Daniel Wortmann's avatar Daniel Wortmann

Chase for MPI should be working now...

parent 82a2ff80
......@@ -298,7 +298,7 @@ IMPLICIT NONE
!Simple driver to solve Generalized Eigenvalue Problem using the ChASE library
IMPLICIT NONE
TYPE(t_mpimat), INTENT(INOUT) :: hmat,smat
TYPE(t_mpimat), INTENT(INOUT) :: hmat,smat
INTEGER, INTENT(IN) :: ikpt
INTEGER, INTENT(IN) :: jsp
INTEGER, INTENT(IN) :: iter
......@@ -310,7 +310,7 @@ IMPLICIT NONE
INTEGER :: info,myid,np
REAL :: scale !scaling of eigenvalues from scalapack
CLASS(t_mat), ALLOCATABLE :: zMatTemp
TYPE(t_mat) :: zMatTemp
TYPE(t_mpimat) :: chase_mat
REAL, ALLOCATABLE :: eigenvalues(:)
include 'mpif.h'
......@@ -356,9 +356,9 @@ IMPLICIT NONE
CALL chase_mat%generate_full_matrix()
ALLOCATE(eigenvalues(nev+nex))
eigenvalues = 0.0
ALLOCATE(t_mpimat::zmatTemp)
!ALLOCATE(t_mpimat::zmatTemp)
CALL zMatTemp%init(hmat%l_real,hmat%global_size1,nev+nex,MPI_COMM_SELF,.TRUE.) !Generate a pseudo-distributed matrix
IF (hmat%l_real) THEN
IF(iter.EQ.1) THEN
CALL mpi_chase_r(chase_mat%data_r, zMatTemp%data_r, eigenvalues, 25, 1e-10, 'R', 'S' )
......@@ -374,33 +374,26 @@ IMPLICIT NONE
CALL mpi_chase_c(chase_mat%data_c, zMatTemp%data_c, eigenvalues, 25, 1e-10, 'A', 'S' )
END IF
ENDIF
ne = nev
IF (myid==0) CALL write_eig(chase_eig_id,ikpt,jsp,nev+nex,nev+nex,&
eigenvalues(:(nev+nex)),zmat=zMatTemp)
!Back-Transform
CALL hmat%from_non_dist(zmattemp)
call zmatTemp%free()
! --> recover the generalized eigenvectors z by solving z' = l^t * z
IF (smat%l_real) THEN
CALL PDTRTRI('U','N',smat%global_size1,smat%data_r,1,1,smat%blacs_desc,info)
CALL PDGEMM('N','N',smat%global_size1,smat%global_size1,smat%global_size1,1.0,smat%data_r,1,1,smat%blacs_desc,zmatTemp%data_r,1,1,zmattemp%blacs_desc,0.0,hmat%data_r,1,1,hmat%blacs_desc)
CALL pdtrtrs('U','N','N',hmat%global_size1,hmat%global_size1,smat%data_r,1,1,smat%blacs_desc,&
hmat%data_r,1,1,smat%blacs_desc,info)
ELSE
STOP 'chase no complex'
CALL pztrtrs('U','N','N',hmat%global_size1,hmat%global_size1,smat%data_c,1,1,smat%blacs_desc,&
hmat%data_c,1,1,smat%blacs_desc,info)
END IF
IF (info.NE.0) THEN
WRITE (6,*) 'Error in p?trtrs: info =',info
CALL juDFT_error("Diagonalization failed",calledby="chase_diag")
ENDIF
!!$ CALL hmat%copy(zmatTemp,1,1) !Copy matrix into distributed form
!!$ call zmatTemp%free()
!!$
!!$ ! --> recover the generalized eigenvectors z by solving z' = l^t * z
!!$ IF (smat%l_real) THEN
!!$ CALL pdtrtrs('U','N','N',hmat%global_size1,hmat%global_size1,smat%data_r,1,1,smat%blacs_desc,&
!!$ hmat%data_r,1,1,smat%blacs_desc,info)
!!$ ELSE
!!$ CALL pztrtrs('U','N','N',hmat%global_size1,hmat%global_size1,smat%data_c,1,1,smat%blacs_desc,&
!!$ hmat%data_c,1,1,smat%blacs_desc,info)
!!$ END IF
!!$ IF (info.NE.0) THEN
!!$ WRITE (6,*) 'Error in p?trtrs: info =',info
!!$ CALL juDFT_error("Diagonalization failed",calledby="chase_diag")
!!$ ENDIF
! Redistribute eigvec from ScaLAPACK distribution to each process
! having all eigenvectors corresponding to his eigenvalues as above
......
......@@ -34,6 +34,7 @@ MODULE m_types_mpimat
PROCEDURE,PASS :: generate_full_matrix ! construct full matrix if only upper triangle of hermitian matrix is given
PROCEDURE,PASS :: print_matrix
PROCEDURE,PASS :: from_non_dist
END TYPE t_mpimat
......@@ -198,7 +199,7 @@ CONTAINS
SELECT TYPE(mat1)
TYPE IS(t_mpimat)
IF (mat%l_real) THEN
CALL pdgemr2d(mat1%global_size1,mat1%global_size2,mat1%data_r,1,1,mat1%blacs_desc,mat%data_r,n1,n2,mat%blacs_desc,mat%blacs_ctext)
CALL pdgemr2d(Mat1%global_size1,mat1%global_size2,mat1%data_r,1,1,mat1%blacs_desc,mat%data_r,n1,n2,mat%blacs_desc,mat%blacs_ctext)
ELSE
CALL pzgemr2d(mat1%global_size1,mat1%global_size2,mat1%data_c,1,1,mat1%blacs_desc,mat%data_c,n1,n2,mat%blacs_desc,mat%blacs_ctext)
END IF
......@@ -208,6 +209,28 @@ CONTAINS
#endif
END SUBROUTINE mpimat_copy
SUBROUTINE from_non_dist(mat,mat1)
IMPLICIT NONE
CLASS(t_mpimat),INTENT(INOUT)::mat
TYPE(t_mat),INTENT(IN) ::mat1
INTEGER:: blacs_desc(9),irank,ierr,umap(1,1),np
blacs_desc=(/1,-1,mat1%matsize1,mat1%matsize2,mat1%matsize1,mat1%matsize2,0,0,mat1%matsize1/)
CALL MPI_COMM_RANK(mat%mpi_com,irank,ierr)
umap(1,1)=0
CALL BLACS_GET(mat%blacs_ctext,10,blacs_desc(2))
CALL BLACS_GRIDMAP(blacs_desc(2),umap,1,1,1)
IF (mat%l_real) THEN
CALL pdgemr2d(Mat1%matsize1,mat1%matsize2,mat1%data_r,1,1,blacs_desc,mat%data_r,1,1,mat%blacs_desc,mat%blacs_ctext)
ELSE
CALL pzgemr2d(mat1%matsize1,mat1%matsize2,mat1%data_c,1,1,blacs_desc,mat%data_c,1,1,mat%blacs_desc,mat%blacs_ctext)
END IF
END SUBROUTINE from_non_dist
SUBROUTINE mpimat_move(mat,mat1)
IMPLICIT NONE
CLASS(t_mpimat),INTENT(INOUT)::mat
......
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