Merge pull request #469 from mikibonacci/fix/segfault-hamiltonian_get_hr

Fix/segfault hamiltonian get hr

src/hamiltonian.F90

@@ -280,10 +280,10 @@ subroutine hamiltonian_get_hr(atom_data, dis_manifold, ham_logical, real_space_h
     ! local variables
     integer          :: loop_kpt, i, j, m, irpt, ierr, counter
     real(kind=dp)    :: rdotk
-    real(kind=dp)    :: eigval_opt(num_bands, num_kpts)
-    real(kind=dp)    :: eigval2(num_wann, num_kpts)
+    real(kind=dp), allocatable    :: eigval_opt(:, :) !(num_bands, num_kpts)
+    real(kind=dp), allocatable    :: eigval2(:, :)    !(num_wann, num_kpts)
     real(kind=dp)    :: irvec_tmp(3)
-    complex(kind=dp) :: utmp(num_bands, num_wann)
+    complex(kind=dp), allocatable :: utmp(:, :)       !(num_bands, num_wann)
     complex(kind=dp) :: fac
 
     if (print_output%timing_level > 1) call io_stopwatch_start('hamiltonian: get_hr', timer)
@@ -299,11 +299,33 @@ subroutine hamiltonian_get_hr(atom_data, dis_manifold, ham_logical, real_space_h
     if (ham_logical%have_ham_k) go to 100
 
     ham_k = cmplx_0
-    eigval_opt = 0.0_dp
+
+    allocate (eigval2(num_wann, num_kpts), stat=ierr)
+    if (ierr /= 0) then
+      call set_error_alloc(error, 'Error in allocating eigval2 in hamiltonian_get_hr', comm)
+      return
+    endif
+
     eigval2 = 0.0_dp
 
     if (have_disentangled) then
 
+      ! start allocation of eigval_opt, utmp; used only if have_disentangled.
+      allocate (eigval_opt(num_bands, num_kpts), stat=ierr)
+      if (ierr /= 0) then
+        call set_error_alloc(error, 'Error in allocating eigval_opt in hamiltonian_get_hr', comm)
+        return
+      endif
+
+      allocate (utmp(num_bands, num_wann), stat=ierr)
+      if (ierr /= 0) then
+        call set_error_alloc(error, 'Error in allocating utmp in hamiltonian_get_hr', comm)
+        return
+      endif
+
+      eigval_opt = 0.0_dp
+      ! end allocation of eigval_opt, utmp
+
       ! slim down eigval to contain states within the outer window
 
       do loop_kpt = 1, num_kpts
@@ -452,6 +474,30 @@ subroutine hamiltonian_get_hr(atom_data, dis_manifold, ham_logical, real_space_h
       endif
     end if
 
+    if (allocated(eigval2)) then
+      deallocate (eigval2, stat=ierr)
+      if (ierr /= 0) then
+        call set_error_dealloc(error, 'Error in deallocating eigval2 in hamiltonian_get_hr', comm)
+        return
+      endif
+    end if
+
+    if (allocated(eigval_opt)) then
+      deallocate (eigval_opt, stat=ierr)
+      if (ierr /= 0) then
+        call set_error_dealloc(error, 'Error in deallocating eigval_opt in hamiltonian_get_hr', comm)
+        return
+      endif
+    end if
+
+    if (allocated(utmp)) then
+      deallocate (utmp, stat=ierr)
+      if (ierr /= 0) then
+        call set_error_dealloc(error, 'Error in deallocating utmp in hamiltonian_get_hr', comm)
+        return
+      endif
+    end if
+
     if (print_output%timing_level > 1) call io_stopwatch_stop('hamiltonian: get_hr', timer)
 
     return

src/sitesym.F90

@@ -560,7 +560,7 @@ subroutine sitesym_dis_extract_symmetry(sitesym, lambda, umat, zmat, ik, n, num_
     !================================================!
 
     use w90_wannier90_types, only: sitesym_type
-    use w90_error, only: w90_error_type, set_error_fatal
+    use w90_error, only: w90_error_type, set_error_fatal, set_error_alloc, set_error_dealloc
 
     implicit none
 
@@ -579,15 +579,40 @@ subroutine sitesym_dis_extract_symmetry(sitesym, lambda, umat, zmat, ik, n, num_
     complex(kind=dp), intent(inout) :: umat(:, :) !(num_bands, num_wann)
 
     ! local variables
-    complex(kind=dp) :: umatnew(num_bands, num_wann) !jj normally don't we alloc explicitly?
-    complex(kind=dp) :: ZU(num_bands, num_wann)
-    complex(kind=dp) :: deltaU(num_bands, num_wann), carr(num_bands)
+    complex(kind=dp), allocatable :: umatnew(:, :) !(num_bands, num_wann)
+    complex(kind=dp), allocatable :: ZU(:, :) !(num_bands, num_wann)
+    complex(kind=dp), allocatable :: deltaU(:, :) !(num_bands, num_wann)
+    complex(kind=dp), allocatable :: carr(:) !(num_bands)
     integer :: i, m, INFO, IFAIL(2), IWORK(5*2)
     complex(kind=dp) :: HP(3), SP(3), V(2, 2), CWORK(2*2)
     real(kind=dp)    :: W(2), RWORK(7*2), sp3
-    integer :: iter
+    integer :: iter, ierr
     integer, parameter :: niter = 50
 
+    allocate (umatnew(num_bands, num_wann), stat=ierr)
+    if (ierr /= 0) then
+      call set_error_alloc(error, 'Error in allocating umatnew in sitesym_dis_extract_symmetry', comm)
+      return
+    endif
+
+    allocate (ZU(num_bands, num_wann), stat=ierr)
+    if (ierr /= 0) then
+      call set_error_alloc(error, 'Error in allocating ZU in sitesym_dis_extract_symmetry', comm)
+      return
+    endif
+
+    allocate (deltaU(num_bands, num_wann), stat=ierr)
+    if (ierr /= 0) then
+      call set_error_alloc(error, 'Error in allocating deltaU in sitesym_dis_extract_symmetry', comm)
+      return
+    endif
+
+    allocate (carr(num_bands), stat=ierr)
+    if (ierr /= 0) then
+      call set_error_alloc(error, 'Error in allocating carr in sitesym_dis_extract_symmetry', comm)
+      return
+    endif
+
     do iter = 1, niter
       !  Z*U
       call zgemm('N', 'N', n, num_wann, n, cmplx_1, zmat, num_bands, umat, num_bands, cmplx_0, ZU, &
@@ -642,6 +667,30 @@ subroutine sitesym_dis_extract_symmetry(sitesym, lambda, umat, zmat, ik, n, num_
       umat(:, :) = umatnew(:, :)
     enddo ! iter
 
+    deallocate (umatnew, stat=ierr)
+    if (ierr /= 0) then
+      call set_error_dealloc(error, 'Error in deallocating umatnew in sitesym_dis_extract_symmetry', comm)
+      return
+    endif
+
+    deallocate (ZU, stat=ierr)
+    if (ierr /= 0) then
+      call set_error_dealloc(error, 'Error in deallocating ZU in sitesym_dis_extract_symmetry', comm)
+      return
+    endif
+
+    deallocate (deltaU, stat=ierr)
+    if (ierr /= 0) then
+      call set_error_dealloc(error, 'Error in deallocating deltaU in sitesym_dis_extract_symmetry', comm)
+      return
+    endif
+
+    deallocate (carr, stat=ierr)
+    if (ierr /= 0) then
+      call set_error_dealloc(error, 'Error in deallocating carr in sitesym_dis_extract_symmetry', comm)
+      return
+    endif
+
     return
   end subroutine sitesym_dis_extract_symmetry