Skip to content

GitLab

fleur
fleur
Commit 5870ffa6 authored by Daniel Wortmann's avatar Daniel Wortmann
Browse files
Options

Added functionality to measure memory footprint for -debugtime option

parent 16e1f8aa
Hide whitespace changes
Inline Side-by-side
Showing with 341 additions and 298 deletions
diagonalization/chani.F90
View file @ 5870ffa6
......@@ -30,7 +30,7 @@ CONTAINS
!
!----------------------------------------------------
!
!#include"cpp_arch.h"
!#include"cpp_arch.h"
#include"cpp_double.h"
USE m_juDFT
USE m_types
......@@ -45,7 +45,7 @@ CONTAINS
REAL, INTENT (OUT) :: eig(neigd)
TYPE(t_hamOvlp),INTENT(INOUT) :: hamOvlp
TYPE(t_zMat),INTENT(INOUT) :: zMat
!... Local variables
!
INTEGER nc,ic,ir,n_sym,jsym,num_j,icm,n_bound
......@@ -79,7 +79,7 @@ CONTAINS
EXTERNAL CPP_LAPACK_slamch, descinit
EXTERNAL blacs_pinfo, blacs_gridinit
EXTERNAL MPI_COMM_DUP
!
! determine actual number of columns of input matrices A and B
! nc is number of columns the local processor will get, must be <=n
......@@ -293,52 +293,52 @@ CONTAINS
! Compute size of workspace
!
if (hamovlp%l_real) THEN
uplo='U'
CALL CPP_LAPACK_pdsygvx(1,'V','I','U',m,asca_r,1,1,desca,bsca_r,1,1, desca,&
0.0,1.0,1,num,abstol,num1,num2,eig2,orfac,eigvec_r,1,1,&
desceigv,work2_r,-1,iwork,-1,ifail,iclustr, gap,ierr)
IF ( work2_r(1).GT.lwork2) THEN
lwork2 = work2_r(1)
DEALLOCATE (work2_r)
ALLOCATE ( work2_r(lwork2+20*m), stat=err ) ! Allocate even more in case of clusters
IF (err.NE.0) THEN
WRITE (*,*) 'work2 :',err,lwork2
CALL juDFT_error('Failed to allocated "work2"', calledby ='chani')
ENDIF
ENDIF
else
lrwork=4*m+MAX(5*nn,np0*mq0)+ iceil(neigd,nprow*npcol)*nn
! Allocate more in case of clusters
ALLOCATE(rwork(lrwork+10*m), stat=ierr)
IF (err /= 0) THEN
WRITE (*,*) 'ERROR: chani.F: Allocating rwork failed'
CALL juDFT_error('Failed to allocated "rwork"', calledby ='chani')
ENDIF
CALL CPP_LAPACK_pzhegvx(1,'V','I','U',m,asca_c,1,1,desca,bsca_c,1,1, desca,&
0.0,1.0,1,num,abstol,num1,num2,eig2,orfac,eigvec_c,1,1,&
desceigv,work2_c,-1,rwork,-1,iwork,-1,ifail,iclustr,&
gap,ierr)
IF (ABS(work2_c(1)).GT.lwork2) THEN
lwork2=work2_c(1)
DEALLOCATE (work2_c)
ALLOCATE (work2_c(lwork2), stat=err)
IF (err /= 0) THEN
WRITE (*,*) 'ERROR: chani.F: Allocating rwork failed:',lwork2
CALL juDFT_error('Failed to allocated "work2"', calledby ='chani')
uplo='U'
CALL CPP_LAPACK_pdsygvx(1,'V','I','U',m,asca_r,1,1,desca,bsca_r,1,1, desca,&
0.0,1.0,1,num,abstol,num1,num2,eig2,orfac,eigvec_r,1,1,&
desceigv,work2_r,-1,iwork,-1,ifail,iclustr, gap,ierr)
IF ( work2_r(1).GT.lwork2) THEN
lwork2 = work2_r(1)
DEALLOCATE (work2_r)
ALLOCATE ( work2_r(lwork2+20*m), stat=err ) ! Allocate even more in case of clusters
IF (err.NE.0) THEN
WRITE (*,*) 'work2 :',err,lwork2
CALL juDFT_error('Failed to allocated "work2"', calledby ='chani')
ENDIF
ENDIF
ENDIF
IF (rwork(1).GT.lrwork) THEN
lrwork=rwork(1)
DEALLOCATE(rwork)
! Allocate even more in case of clusters
ALLOCATE (rwork(lrwork+20*m), stat=err)
else
lrwork=4*m+MAX(5*nn,np0*mq0)+ iceil(neigd,nprow*npcol)*nn
! Allocate more in case of clusters
ALLOCATE(rwork(lrwork+10*m), stat=ierr)
IF (err /= 0) THEN
WRITE (*,*) 'ERROR: chani.F: Allocating rwork failed: ', lrwork+20*m
WRITE (*,*) 'ERROR: chani.F: Allocating rwork failed'
CALL juDFT_error('Failed to allocated "rwork"', calledby ='chani')
ENDIF
ENDIF
endif
CALL CPP_LAPACK_pzhegvx(1,'V','I','U',m,asca_c,1,1,desca,bsca_c,1,1, desca,&
0.0,1.0,1,num,abstol,num1,num2,eig2,orfac,eigvec_c,1,1,&
desceigv,work2_c,-1,rwork,-1,iwork,-1,ifail,iclustr,&
gap,ierr)
IF (ABS(work2_c(1)).GT.lwork2) THEN
lwork2=work2_c(1)
DEALLOCATE (work2_c)
ALLOCATE (work2_c(lwork2), stat=err)
IF (err /= 0) THEN
WRITE (*,*) 'ERROR: chani.F: Allocating rwork failed:',lwork2
CALL juDFT_error('Failed to allocated "work2"', calledby ='chani')
ENDIF
ENDIF
IF (rwork(1).GT.lrwork) THEN
lrwork=rwork(1)
DEALLOCATE(rwork)
! Allocate even more in case of clusters
ALLOCATE (rwork(lrwork+20*m), stat=err)
IF (err /= 0) THEN
WRITE (*,*) 'ERROR: chani.F: Allocating rwork failed: ', lrwork+20*m
CALL juDFT_error('Failed to allocated "rwork"', calledby ='chani')
ENDIF
ENDIF
endif
IF (iwork(1) .GT. liwork) THEN
liwork = iwork(1)
DEALLOCATE (iwork)
......@@ -351,18 +351,20 @@ endif
!
! Now solve generalized eigenvalue problem
!
if (hamovlp%l_real) THEN
CALL CPP_LAPACK_pdsygvx(1,'V','I','U',m,asca_r,1,1,desca,bsca_r,1,1, desca,&
1.0,1.0,1,num,abstol,num1,num2,eig2,orfac,eigvec_r,1,1,&
desceigv,work2_r,lwork2,iwork,liwork,ifail,iclustr,&
gap,ierr)
else
CALL CPP_LAPACK_pzhegvx(1,'V','I','U',m,asca_c,1,1,desca,bsca_c,1,1, desca,&
1.0,1.0,1,num,abstol,num1,num2,eig2,orfac,eigvec_c,1,1,&
desceigv,work2_c,lwork2,rwork,lrwork,iwork,liwork,&
ifail,iclustr,gap,ierr)
DEALLOCATE(rwork)
endif
CALL timestart("SCALAPACK call")
if (hamovlp%l_real) THEN
CALL CPP_LAPACK_pdsygvx(1,'V','I','U',m,asca_r,1,1,desca,bsca_r,1,1, desca,&
1.0,1.0,1,num,abstol,num1,num2,eig2,orfac,eigvec_r,1,1,&
desceigv,work2_r,lwork2,iwork,liwork,ifail,iclustr,&
gap,ierr)
else
CALL CPP_LAPACK_pzhegvx(1,'V','I','U',m,asca_c,1,1,desca,bsca_c,1,1, desca,&
1.0,1.0,1,num,abstol,num1,num2,eig2,orfac,eigvec_c,1,1,&
desceigv,work2_c,lwork2,rwork,lrwork,iwork,liwork,&
ifail,iclustr,gap,ierr)
DEALLOCATE(rwork)
endif
CALL timestop("SCALAPACK call")
IF (ierr .NE. 0) THEN
IF (ierr /= 2) WRITE (6,*) myid,' error in pzhegvx/pdsygvx, ierr=',ierr
IF (ierr <= 0) WRITE (6,*) myid,' illegal input argument'
......@@ -426,7 +428,7 @@ endif
!
if (hamovlp%l_real) THEN
CALL subredist2(m,num2,myrowssca,SUB_COMM,nprow,npcol, myid,ierr,nb,zmat%z_r,eigvec_r)
ELSE
ELSE
CALL subredist2(m,num2,myrowssca,SUB_COMM,nprow,npcol, myid,ierr,nb,achi_c=zmat%z_c,asca_c=eigvec_c)
end if
!
......
juDFT/stop.F90
View file @ 5870ffa6
......@@ -4,244 +4,232 @@
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------
MODULE m_juDFT_stop
!-----------------------------------------------
! module to terminate Calculation, should be used instead
! of a simple STOP
!
! error(message,calledby,hint,no,warning)
! message : message string
! calledby : subroutine in which error occurs(optional)
! hint : string with more information (optional)
! no : error number (optional)
! warning : logical indicating a warning message (optional)
!
! warn(message,calledby,hint,no)
! shortcut for calling error with warning=.true.
!
! juDFT_end(message)
! call this to terminate without error
!
! IF the file "JUDFT_WARN_ONLY" is not present, warnings will lead to errors.
!
! If the file "JUDFT_TRACE" is present, a stacktrace will be generated
! on some compilers
!
!
! Daniel Wortmann (2010)
!-----------------------------------------------
USE m_judft_time
IMPLICIT NONE
PRIVATE
PUBLIC juDFT_error,juDFT_warn,juDFT_end,judft_file_readable,print_memory_info
CONTAINS
SUBROUTINE judfT_file_readable(filename,warning)
IMPLICIT NONE
CHARACTER(len=*),INTENT(IN):: filename
LOGICAL,INTENT(IN),OPTIONAL:: warning
LOGICAL :: l_exist
INQUIRE(file=filename,exist=l_exist)
IF (.not.l_exist) CALL judft_error("File not readable:"//filename,hint="FLEUR wants to read a file that is not present",warning=warning)
END SUBROUTINE judfT_file_readable
SUBROUTINE juDFT_error(message,calledby,hint,no,warning,file,line)
IMPLICIT NONE
CHARACTER*(*),INTENT(IN) :: message
CHARACTER*(*),OPTIONAL,INTENT(IN) :: calledby,hint
INTEGER,OPTIONAL,INTENT(IN) :: no
LOGICAL,OPTIONAL,INTENT(IN) :: warning
CHARACTER*(*),OPTIONAL,INTENT(IN) :: file
INTEGER,INTENT(IN),OPTIONAL :: line
LOGICAL :: callstop,warn
CHARACTER(LEN=4)::PE
!store all output in variable for single call to write in MPI case
CHARACTER(len=300)::text(10)
INTEGER ::linenr,n
MODULE m_juDFT_stop
!-----------------------------------------------
! module to terminate Calculation, should be used instead
! of a simple STOP
!
! error(message,calledby,hint,no,warning)
! message : message string
! calledby : subroutine in which error occurs(optional)
! hint : string with more information (optional)
! no : error number (optional)
! warning : logical indicating a warning message (optional)
!
! warn(message,calledby,hint,no)
! shortcut for calling error with warning=.true.
!
! juDFT_end(message)
! call this to terminate without error
!
! IF the file "JUDFT_WARN_ONLY" is not present, warnings will lead to errors.
!
! If the file "JUDFT_TRACE" is present, a stacktrace will be generated
! on some compilers
!
!
! Daniel Wortmann (2010)
!-----------------------------------------------
USE m_judft_time
USE m_judft_sysinfo
IMPLICIT NONE
PRIVATE
PUBLIC juDFT_error,juDFT_warn,juDFT_end,judft_file_readable
CONTAINS
SUBROUTINE judfT_file_readable(filename,warning)
IMPLICIT NONE
CHARACTER(len=*),INTENT(IN):: filename
LOGICAL,INTENT(IN),OPTIONAL:: warning
LOGICAL :: l_exist
INQUIRE(file=filename,exist=l_exist)
IF (.not.l_exist) CALL judft_error("File not readable:"//filename,hint="FLEUR wants to read a file that is not present",warning=warning)
END SUBROUTINE judfT_file_readable
SUBROUTINE juDFT_error(message,calledby,hint,no,warning,file,line)
IMPLICIT NONE
CHARACTER*(*),INTENT(IN) :: message
CHARACTER*(*),OPTIONAL,INTENT(IN) :: calledby,hint
INTEGER,OPTIONAL,INTENT(IN) :: no
LOGICAL,OPTIONAL,INTENT(IN) :: warning
CHARACTER*(*),OPTIONAL,INTENT(IN) :: file
INTEGER,INTENT(IN),OPTIONAL :: line
LOGICAL :: callstop,warn
CHARACTER(LEN=4)::PE
!store all output in variable for single call to write in MPI case
CHARACTER(len=300)::text(10)
INTEGER ::linenr,n
#ifdef CPP_MPI
include 'mpif.h'
INTEGER :: irank,e
CALL MPI_COMM_RANK(MPI_COMM_WORLD,irank,e)
WRITE(PE,"(i4)") irank
include 'mpif.h'
INTEGER :: irank,e
CALL MPI_COMM_RANK(MPI_COMM_WORLD,irank,e)
WRITE(PE,"(i4)") irank
#else
PE="****"
PE="****"
#endif
warn = .FALSE.
IF (PRESENT(warning)) warn = warning
IF (warn) THEN
!check if we stop nevertheless
INQUIRE(FILE ="JUDFT_WARN_ONLY",EXIST= callstop)
callstop = .NOT.callstop
ELSE
callstop = .TRUE.
ENDIF
IF (.NOT.warn) THEN
WRITE(text(1),*) PE,"**************juDFT-Error*****************"
ELSE
WRITE(text(1),*) PE,"************juDFT-Warning*****************"
ENDIF
WRITE(text(2),"(3a)") PE,"Error message:",message
linenr=3
IF (PRESENT(calledby)) THEN
WRITE(text(3),"(3a)") PE,"Error occurred in subroutine:",calledby
linenr=4
ENDIF
IF (PRESENT(hint)) THEN
WRITE(text(linenr),"(3a)") PE,"Hint:",hint
linenr=linenr+1
ENDIF
IF (PRESENT(no)) THEN
WRITE(text(linenr),"(2a,i0)") PE,"Error number:",no
linenr=linenr+1
ENDIF
IF (present(file)) THEN
if (present(line)) THEN
write(text(linenr),"(4a,i0)") PE,"Source:",file,":",line
ELSE
write(text(linenr),"(3a)") PE,"Source:",file
ENDIF
warn = .FALSE.
IF (PRESENT(warning)) warn = warning
IF (warn) THEN
!check if we stop nevertheless
INQUIRE(FILE ="JUDFT_WARN_ONLY",EXIST= callstop)
callstop = .NOT.callstop
ELSE
callstop = .TRUE.
ENDIF
IF (.NOT.warn) THEN
WRITE(text(1),*) PE,"**************juDFT-Error*****************"
ELSE
WRITE(text(1),*) PE,"************juDFT-Warning*****************"
ENDIF
WRITE(text(2),"(3a)") PE,"Error message:",message
linenr=3
IF (PRESENT(calledby)) THEN
WRITE(text(3),"(3a)") PE,"Error occurred in subroutine:",calledby
linenr=4
ENDIF
IF (PRESENT(hint)) THEN
WRITE(text(linenr),"(3a)") PE,"Hint:",hint
linenr=linenr+1
ENDIF
IF (PRESENT(no)) THEN
WRITE(text(linenr),"(2a,i0)") PE,"Error number:",no
linenr=linenr+1
ENDIF
IF (present(file)) THEN
if (present(line)) THEN
write(text(linenr),"(4a,i0)") PE,"Source:",file,":",line
ELSE
write(text(linenr),"(3a)") PE,"Source:",file
ENDIF
linenr=linenr+1
ENDIF
WRITE(text(linenr),*) PE,"*****************************************"
if (.not.warn) CALL juDFT_time_lastlocation(PE)
IF (callstop) THEN
IF (warn) THEN
linenr=linenr+1
ENDIF
WRITE(text(linenr),*) PE,"*****************************************"
if (.not.warn) CALL juDFT_time_lastlocation(PE)
IF (callstop) THEN
IF (warn) THEN
linenr=linenr+1
WRITE(text(linenr),'(a)')"Warnings not ignored. Touch 'JUDFT_WARN_ONLY' to make the warning nonfatal"
ENDIF
write(0,"(10(a,/))") (trim(text(n)),n=1,linenr)
CALL juDFT_STOP()
ENDIF
write(0,"(10(a,/))") (trim(text(n)),n=1,linenr)
END SUBROUTINE juDFT_error
SUBROUTINE juDFT_warn(message,calledby,hint,no,file,line)
IMPLICIT NONE
CHARACTER*(*),INTENT(IN) :: message
CHARACTER*(*),OPTIONAL,INTENT(IN) :: calledby,hint
INTEGER,OPTIONAL,INTENT(IN) :: no
CHARACTER*(*),OPTIONAL,INTENT(IN) :: file
INTEGER,INTENT(IN),OPTIONAL :: line
CALL juDFT_error(message,calledby,hint,no,warning = .TRUE.,file=file,line=line)
END SUBROUTINE juDFT_warn
SUBROUTINE juDFT_END(message, irank, l_endXML)
! If irank is present every mpi process has to call this routine.
! Otherwise only a single mpi process is allowed to call the routine.
USE m_xmlOutput
IMPLICIT NONE
WRITE(text(linenr),'(a)')"Warnings not ignored. Touch 'JUDFT_WARN_ONLY' to make the warning nonfatal"
ENDIF
write(0,"(10(a,/))") (trim(text(n)),n=1,linenr)
CALL juDFT_STOP()
ENDIF
write(0,"(10(a,/))") (trim(text(n)),n=1,linenr)
END SUBROUTINE juDFT_error
SUBROUTINE juDFT_warn(message,calledby,hint,no,file,line)
IMPLICIT NONE
CHARACTER*(*),INTENT(IN) :: message
CHARACTER*(*),OPTIONAL,INTENT(IN) :: calledby,hint
INTEGER,OPTIONAL,INTENT(IN) :: no
CHARACTER*(*),OPTIONAL,INTENT(IN) :: file
INTEGER,INTENT(IN),OPTIONAL :: line
CALL juDFT_error(message,calledby,hint,no,warning = .TRUE.,file=file,line=line)
END SUBROUTINE juDFT_warn
SUBROUTINE juDFT_END(message, irank, l_endXML)
! If irank is present every mpi process has to call this routine.
! Otherwise only a single mpi process is allowed to call the routine.
USE m_xmlOutput
IMPLICIT NONE
#ifdef CPP_MPI
INCLUDE 'mpif.h'
INTEGER :: ierr
INCLUDE 'mpif.h'
INTEGER :: ierr
#endif
CHARACTER*(*), INTENT(IN) :: message
INTEGER, OPTIONAL, INTENT(IN) :: irank
LOGICAL, OPTIONAL, INTENT(IN) :: l_endXML
LOGICAL l_endXML_local
l_endXML_local = .TRUE.
IF(PRESENT(l_endXML)) THEN
l_endXML_local = l_endXML
END IF
IF(l_endXML_local) THEN
IF(PRESENT(irank)) THEN
IF (irank.EQ.0) CALL endXMLOutput()
ELSE
! It is assumed that this is the only mpi process calling this routine.
CALL endXMLOutput()
END IF
END IF
WRITE(0,*) "*****************************************"
WRITE(0,*) "Run finished successfully"
WRITE(0,*) "Stop message:"
WRITE(0,*) " ",message
WRITE(0,*) "*****************************************"
CALL writetimes()
CALL print_memory_info()
CHARACTER*(*), INTENT(IN) :: message
INTEGER, OPTIONAL, INTENT(IN) :: irank
LOGICAL, OPTIONAL, INTENT(IN) :: l_endXML
LOGICAL l_endXML_local
l_endXML_local = .TRUE.
IF(PRESENT(l_endXML)) THEN
l_endXML_local = l_endXML
END IF
IF(l_endXML_local) THEN
IF(PRESENT(irank)) THEN
IF (irank.EQ.0) CALL endXMLOutput()
ELSE
! It is assumed that this is the only mpi process calling this routine.
CALL endXMLOutput()
END IF
END IF
WRITE(0,*) "*****************************************"
WRITE(0,*) "Run finished successfully"
WRITE(0,*) "Stop message:"
WRITE(0,*) " ",message
WRITE(0,*) "*****************************************"
CALL writetimes()
CALL print_memory_info()
#ifdef CPP_MPI
IF(PRESENT(irank)) THEN
CALL MPI_BARRIER(MPI_COMM_WORLD,ierr)
CALL MPI_FINALIZE(ierr)
ELSE
CALL juDFT_STOP(0)
END IF
IF(PRESENT(irank)) THEN
CALL MPI_BARRIER(MPI_COMM_WORLD,ierr)
CALL MPI_FINALIZE(ierr)
ELSE
CALL juDFT_STOP(0)
END IF
#endif
STOP 'OK'
END SUBROUTINE juDFT_END
STOP 'OK'
END SUBROUTINE juDFT_END
!this is a private subroutine that stops the calculations
!different compilers might have to be added here
SUBROUTINE juDFT_stop(errorCode)
!this is a private subroutine that stops the calculations
!different compilers might have to be added here
SUBROUTINE juDFT_stop(errorCode)
#ifdef __INTEL_COMPILER
USE ifcore
USE ifcore
#endif
#ifdef CPP_MPI
INCLUDE 'mpif.h'
INCLUDE 'mpif.h'
#endif
INTEGER, OPTIONAL, INTENT(IN) :: errorCode
INTEGER :: error
LOGICAL :: calltrace
LOGICAL,ALLOCATABLE:: a(:)
INTEGER, OPTIONAL, INTENT(IN) :: errorCode
INTEGER :: error
LOGICAL :: calltrace
LOGICAL,ALLOCATABLE:: a(:)
#ifdef CPP_MPI
INTEGER :: ierr
INTEGER :: ierr
#endif
error = 0
IF(PRESENT(errorCode)) THEN
error = errorCode
END IF
!try to print times
call writelocation()
CALL writetimes(.TRUE.)
CALL print_memory_info()
INQUIRE(FILE="JUDFT_TRACE",EXIST=calltrace)
IF (error.EQ.1) calltrace = .TRUE.
IF (calltrace) THEN
error = 0
IF(PRESENT(errorCode)) THEN
error = errorCode
END IF
!try to print times
call writelocation()
CALL writetimes(.TRUE.)
CALL print_memory_info()
INQUIRE(FILE="JUDFT_TRACE",EXIST=calltrace)
IF (error.EQ.1) calltrace = .TRUE.
IF (calltrace) THEN
#ifdef __INTEL_COMPILER
CALL tracebackqq(USER_EXIT_CODE=-1) !return after traceback
CALL tracebackqq(USER_EXIT_CODE=-1) !return after traceback
#elif (defined(CPP_AIX)&&!defined(__PGI))
CALL xl__trbk()
CALL xl__trbk()
#endif
DEALLOCATE(a)!will generate an error that can be found by the compiler
ENDIF
DEALLOCATE(a)!will generate an error that can be found by the compiler
ENDIF
#if defined(CPP_MPI)
IF(error.EQ.0) THEN
WRITE(0,*) ""
WRITE(0,*) "Terminating all MPI processes."
WRITE(0,*) "Note: This is a normal procedure."
WRITE(0,*) " Error messages in the following lines can be ignored."
WRITE(0,*) ""
END IF
CALL MPI_ABORT(MPI_COMM_WORLD,error,ierr)
IF(error.EQ.0) THEN
WRITE(0,*) ""
WRITE(0,*) "Terminating all MPI processes."
WRITE(0,*) "Note: This is a normal procedure."
WRITE(0,*) " Error messages in the following lines can be ignored."
WRITE(0,*) ""
END IF
CALL MPI_ABORT(MPI_COMM_WORLD,error,ierr)
#endif
STOP 'juDFT-STOPPED'
END SUBROUTINE juDFT_stop
STOP 'juDFT-STOPPED'
END SUBROUTINE juDFT_stop
SUBROUTINE print_memory_info()
IMPLICIT NONE
CHARACTER(LEN=1024):: line