Commit 5870ffa6 authored by Daniel Wortmann's avatar Daniel Wortmann

Added functionality to measure memory footprint for -debugtime option

parent 16e1f8aa
......@@ -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
!
......
This diff is collapsed.
MODULE m_judft_sysinfo
IMPLICIT NONE
CONTAINS
SUBROUTINE checkstack()
CHARACTER(LEN=10):: l1,l2,l3,l4
INTEGER :: err
LOGICAL :: unlimited
unlimited=.TRUE. !set to true by default.
!If /proc/self/limits does not exist
!or parsing fails no warning is issued
OPEN(99,FILE="/proc/self/limits",ERR=999)
DO
READ(99,*,ERR=999,END=999) l1,l2,l3,l4
IF (ALL((/INDEX(l1,"Max"),INDEX(l2,"stack"),INDEX(l3,"size")/)==1)) THEN
unlimited=INDEX(l4,"unlim")==1
ENDIF
ENDDO
999 CLOSE(99,IOSTAT=err)
IF (.NOT.unlimited) THEN
WRITE(*,*) "*********** WARNING! ************"
WRITE(*,*) "Your stacksize seems to be small"
WRITE(*,*) "FLEUR might crash without further"
!--------------------------------------------------------------------------------
! 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.
!--------------------------------------------------------------------------------
!To generate Memory usage info on LINUX we need to know the pagesize
!a default of 4096 bytes is assumed
#ifndef CPP_PAGESIZE
#define CPP_PAGESIZE 4096
#endif
MODULE m_judft_sysinfo
IMPLICIT NONE
CONTAINS
!Dump status file into out file (should be done only at end of run)
SUBROUTINE print_memory_info()
IMPLICIT NONE
CHARACTER(LEN=1024):: line
INTEGER :: err
OPEN(99,FILE="/proc/self/status",ERR=999)
DO
READ(99,"(a)",ERR=999,END=999) line
WRITE(6,*) trim(line)
ENDDO
999 CLOSE(99,IOSTAT=err)
END SUBROUTINE print_memory_info
!Read mstat to find out current memory usage
FUNCTION memory_usage_string()
IMPLICIT NONE
CHARACTER(len=10):: memory_usage_string
INTEGER:: fid=543,idum
LOGICAL:: firstcall=.TRUE.
LOGICAL:: available=.FALSE.
IF (firstcall) THEN
firstcall=.FALSE.
OPEN(fid,FILE="/proc/self/statm",status='old',action='read',iostat=idum)
available=(idum==0)
ENDIF
IF (available) THEN
REWIND(fid)
READ(fid,*) idum
WRITE(memory_usage_string,"(f8.3,a)") idum*CPP_PAGESIZE/(1024.*1024.*1024.),"GB"
ELSE
memory_usage_string=""
ENDIF
END FUNCTION memory_usage_string
SUBROUTINE checkstack()
CHARACTER(LEN=10):: l1,l2,l3,l4
INTEGER :: err
LOGICAL :: unlimited
unlimited=.TRUE. !set to true by default.
!If /proc/self/limits does not exist
!or parsing fails no warning is issued
OPEN(99,FILE="/proc/self/limits",ERR=999)
DO
READ(99,*,ERR=999,END=999) l1,l2,l3,l4
IF (ALL((/INDEX(l1,"Max"),INDEX(l2,"stack"),INDEX(l3,"size")/)==1)) THEN
unlimited=INDEX(l4,"unlim")==1
ENDIF
ENDDO
999 CLOSE(99,IOSTAT=err)
IF (.NOT.unlimited) THEN
WRITE(*,*) "*********** WARNING! ************"
WRITE(*,*) "Your stacksize seems to be small"
WRITE(*,*) "FLEUR might crash without further"
WRITE(*,*) "notice. Try 'ulimit -s unlimited'"
WRITE(*,*) "*********** WARNING! ************"
ENDIF
......
......@@ -148,6 +148,7 @@ CONTAINS
!>
SUBROUTINE priv_debug_output(startstop,name)
USE m_judft_sysinfo
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN):: startstop,name
#ifdef CPP_MPI
......@@ -157,9 +158,9 @@ CONTAINS
IF (.NOT.l_debug) RETURN
#ifdef CPP_MPI
CALL MPI_COMM_RANK(MPI_COMM_WORLD,irank,ierr)
WRITE(*,"(i3,3a,f20.3)") irank,startstop,name," at:",cputime()
WRITE(*,"(i3,3a,f20.2,5x,a)") irank,startstop,name," at:",cputime(),memory_usage_string()
#else
WRITE(*,"(3a,f20.3)") startstop,name," at:",cputime()
WRITE(*,"(3a,f20.2,5x,a)") startstop,name," at:",cputime(),memory_usage_string()
#endif
END SUBROUTINE priv_debug_output
......
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