Commit 6515c5ea authored by Lorenz Huedepohl's avatar Lorenz Huedepohl
Browse files

Transform statement functions into actual functions

parent 991e1b3f
This diff is collapsed.
...@@ -599,16 +599,11 @@ subroutine bandred_real(na, a, lda, nblk, nbw, mpi_comm_rows, mpi_comm_cols, & ...@@ -599,16 +599,11 @@ subroutine bandred_real(na, a, lda, nblk, nbw, mpi_comm_rows, mpi_comm_cols, &
real*8, allocatable :: tmp(:,:), vr(:), vmr(:,:), umc(:,:) real*8, allocatable :: tmp(:,:), vr(:), vmr(:,:), umc(:,:)
integer :: pcol, prow
! needed for blocked QR decomposition ! needed for blocked QR decomposition
integer :: PQRPARAM(11), work_size integer :: PQRPARAM(11), work_size
real*8 :: dwork_size(1) real*8 :: dwork_size(1)
real*8, allocatable :: work_blocked(:), tauvector(:), blockheuristic(:) real*8, allocatable :: work_blocked(:), tauvector(:), blockheuristic(:)
pcol(i) = MOD((i-1)/nblk,np_cols) !Processor col for global col number
prow(i) = MOD((i-1)/nblk,np_rows) !Processor row for global row number
logical, intent(in) :: wantDebug logical, intent(in) :: wantDebug
logical, intent(out):: success logical, intent(out):: success
...@@ -706,7 +701,7 @@ subroutine bandred_real(na, a, lda, nblk, nbw, mpi_comm_rows, mpi_comm_cols, & ...@@ -706,7 +701,7 @@ subroutine bandred_real(na, a, lda, nblk, nbw, mpi_comm_rows, mpi_comm_cols, &
if (nrow == 1) exit ! Nothing to do if (nrow == 1) exit ! Nothing to do
cur_pcol = pcol(ncol) ! Processor column owning current block cur_pcol = pcol(ncol, nblk, np_cols) ! Processor column owning current block
if (my_pcol==cur_pcol) then if (my_pcol==cur_pcol) then
...@@ -715,7 +710,7 @@ subroutine bandred_real(na, a, lda, nblk, nbw, mpi_comm_rows, mpi_comm_cols, & ...@@ -715,7 +710,7 @@ subroutine bandred_real(na, a, lda, nblk, nbw, mpi_comm_rows, mpi_comm_cols, &
vr(1:lr) = a(1:lr,lch) ! vector to be transformed vr(1:lr) = a(1:lr,lch) ! vector to be transformed
if (my_prow==prow(nrow)) then if (my_prow==prow(nrow, nblk, np_rows)) then
aux1(1) = dot_product(vr(1:lr-1),vr(1:lr-1)) aux1(1) = dot_product(vr(1:lr-1),vr(1:lr-1))
aux1(2) = vr(lr) aux1(2) = vr(lr)
else else
...@@ -735,7 +730,7 @@ subroutine bandred_real(na, a, lda, nblk, nbw, mpi_comm_rows, mpi_comm_cols, & ...@@ -735,7 +730,7 @@ subroutine bandred_real(na, a, lda, nblk, nbw, mpi_comm_rows, mpi_comm_cols, &
! Scale vr and store Householder vector for back transformation ! Scale vr and store Householder vector for back transformation
vr(1:lr) = vr(1:lr) * xf vr(1:lr) = vr(1:lr) * xf
if (my_prow==prow(nrow)) then if (my_prow==prow(nrow, nblk, np_rows)) then
a(1:lr-1,lch) = vr(1:lr-1) a(1:lr-1,lch) = vr(1:lr-1)
a(lr,lch) = vrl a(lr,lch) = vrl
vr(lr) = 1. vr(lr) = 1.
...@@ -997,15 +992,12 @@ subroutine trans_ev_band_to_full_real(na, nqc, nblk, nbw, a, lda, tmat, q, ldq, ...@@ -997,15 +992,12 @@ subroutine trans_ev_band_to_full_real(na, nqc, nblk, nbw, a, lda, tmat, q, ldq,
real*8, allocatable :: tmp1(:), tmp2(:), hvb(:), hvm(:,:) real*8, allocatable :: tmp1(:), tmp2(:), hvb(:), hvm(:,:)
integer :: pcol, prow, i integer :: i
real*8, allocatable :: tmat_complete(:,:), t_tmp(:,:), t_tmp2(:,:) real*8, allocatable :: tmat_complete(:,:), t_tmp(:,:), t_tmp2(:,:)
integer :: cwy_blocking, t_blocking, t_cols, t_rows integer :: cwy_blocking, t_blocking, t_cols, t_rows
logical, intent(in) :: useQR logical, intent(in) :: useQR
pcol(i) = MOD((i-1)/nblk,np_cols) !Processor col for global col number
prow(i) = MOD((i-1)/nblk,np_rows) !Processor row for global row number
#ifdef HAVE_DETAILED_TIMINGS #ifdef HAVE_DETAILED_TIMINGS
call timer%start("trans_ev_band_to_full_real") call timer%start("trans_ev_band_to_full_real")
#endif #endif
...@@ -1061,12 +1053,12 @@ subroutine trans_ev_band_to_full_real(na, nqc, nblk, nbw, a, lda, tmat, q, ldq, ...@@ -1061,12 +1053,12 @@ subroutine trans_ev_band_to_full_real(na, nqc, nblk, nbw, a, lda, tmat, q, ldq,
l_rows = local_index(nrow-1, my_prow, np_rows, nblk, -1) ! row length for bcast l_rows = local_index(nrow-1, my_prow, np_rows, nblk, -1) ! row length for bcast
l_colh = local_index(ncol , my_pcol, np_cols, nblk, -1) ! HV local column number l_colh = local_index(ncol , my_pcol, np_cols, nblk, -1) ! HV local column number
if (my_pcol==pcol(ncol)) hvb(nb+1:nb+l_rows) = a(1:l_rows,l_colh) if (my_pcol==pcol(ncol, nblk, np_cols)) hvb(nb+1:nb+l_rows) = a(1:l_rows,l_colh)
nb = nb+l_rows nb = nb+l_rows
if (lc==n_cols .or. mod(ncol,nblk)==0) then if (lc==n_cols .or. mod(ncol,nblk)==0) then
call MPI_Bcast(hvb(ns+1),nb-ns,MPI_REAL8,pcol(ncol),mpi_comm_cols,mpierr) call MPI_Bcast(hvb(ns+1),nb-ns,MPI_REAL8,pcol(ncol, nblk, np_cols),mpi_comm_cols,mpierr)
ns = nb ns = nb
endif endif
enddo enddo
...@@ -1079,7 +1071,7 @@ subroutine trans_ev_band_to_full_real(na, nqc, nblk, nbw, a, lda, tmat, q, ldq, ...@@ -1079,7 +1071,7 @@ subroutine trans_ev_band_to_full_real(na, nqc, nblk, nbw, a, lda, tmat, q, ldq,
l_rows = local_index(nrow-1, my_prow, np_rows, nblk, -1) ! row length for bcast l_rows = local_index(nrow-1, my_prow, np_rows, nblk, -1) ! row length for bcast
hvm(1:l_rows,lc) = hvb(nb+1:nb+l_rows) hvm(1:l_rows,lc) = hvb(nb+1:nb+l_rows)
if (my_prow==prow(nrow)) hvm(l_rows+1,lc) = 1. if (my_prow==prow(nrow, nblk, np_rows)) hvm(l_rows+1,lc) = 1.
nb = nb+l_rows nb = nb+l_rows
enddo enddo
...@@ -1138,12 +1130,12 @@ subroutine trans_ev_band_to_full_real(na, nqc, nblk, nbw, a, lda, tmat, q, ldq, ...@@ -1138,12 +1130,12 @@ subroutine trans_ev_band_to_full_real(na, nqc, nblk, nbw, a, lda, tmat, q, ldq,
l_rows = local_index(nrow-1, my_prow, np_rows, nblk, -1) ! row length for bcast l_rows = local_index(nrow-1, my_prow, np_rows, nblk, -1) ! row length for bcast
l_colh = local_index(ncol , my_pcol, np_cols, nblk, -1) ! HV local column number l_colh = local_index(ncol , my_pcol, np_cols, nblk, -1) ! HV local column number
if (my_pcol==pcol(ncol)) hvb(nb+1:nb+l_rows) = a(1:l_rows,l_colh) if (my_pcol==pcol(ncol, nblk, np_cols)) hvb(nb+1:nb+l_rows) = a(1:l_rows,l_colh)
nb = nb+l_rows nb = nb+l_rows
if (lc==n_cols .or. mod(ncol,nblk)==0) then if (lc==n_cols .or. mod(ncol,nblk)==0) then
call MPI_Bcast(hvb(ns+1),nb-ns,MPI_REAL8,pcol(ncol),mpi_comm_cols,mpierr) call MPI_Bcast(hvb(ns+1),nb-ns,MPI_REAL8,pcol(ncol, nblk, np_cols),mpi_comm_cols,mpierr)
ns = nb ns = nb
endif endif
enddo enddo
...@@ -1156,7 +1148,7 @@ subroutine trans_ev_band_to_full_real(na, nqc, nblk, nbw, a, lda, tmat, q, ldq, ...@@ -1156,7 +1148,7 @@ subroutine trans_ev_band_to_full_real(na, nqc, nblk, nbw, a, lda, tmat, q, ldq,
l_rows = local_index(nrow-1, my_prow, np_rows, nblk, -1) ! row length for bcast l_rows = local_index(nrow-1, my_prow, np_rows, nblk, -1) ! row length for bcast
hvm(1:l_rows,lc) = hvb(nb+1:nb+l_rows) hvm(1:l_rows,lc) = hvb(nb+1:nb+l_rows)
if (my_prow==prow(nrow)) hvm(l_rows+1,lc) = 1. if (my_prow==prow(nrow, nblk, np_rows)) hvm(l_rows+1,lc) = 1.
nb = nb+l_rows nb = nb+l_rows
enddo enddo
...@@ -3277,10 +3269,6 @@ subroutine bandred_complex(na, a, lda, nblk, nbw, mpi_comm_rows, mpi_comm_cols, ...@@ -3277,10 +3269,6 @@ subroutine bandred_complex(na, a, lda, nblk, nbw, mpi_comm_rows, mpi_comm_cols,
complex*16, allocatable :: tmp(:,:), vr(:), vmr(:,:), umc(:,:) complex*16, allocatable :: tmp(:,:), vr(:), vmr(:,:), umc(:,:)
integer :: pcol, prow
pcol(i) = MOD((i-1)/nblk,np_cols) !Processor col for global col number
prow(i) = MOD((i-1)/nblk,np_rows) !Processor row for global row number
logical, intent(in) :: wantDebug logical, intent(in) :: wantDebug
logical, intent(out) :: success logical, intent(out) :: success
#ifdef HAVE_DETAILED_TIMINGS #ifdef HAVE_DETAILED_TIMINGS
...@@ -3347,7 +3335,7 @@ subroutine bandred_complex(na, a, lda, nblk, nbw, mpi_comm_rows, mpi_comm_cols, ...@@ -3347,7 +3335,7 @@ subroutine bandred_complex(na, a, lda, nblk, nbw, mpi_comm_rows, mpi_comm_cols,
if(nrow == 1) exit ! Nothing to do if(nrow == 1) exit ! Nothing to do
cur_pcol = pcol(ncol) ! Processor column owning current block cur_pcol = pcol(ncol, nblk, np_cols) ! Processor column owning current block
if (my_pcol==cur_pcol) then if (my_pcol==cur_pcol) then
...@@ -3356,7 +3344,7 @@ subroutine bandred_complex(na, a, lda, nblk, nbw, mpi_comm_rows, mpi_comm_cols, ...@@ -3356,7 +3344,7 @@ subroutine bandred_complex(na, a, lda, nblk, nbw, mpi_comm_rows, mpi_comm_cols,
vr(1:lr) = a(1:lr,lch) ! vector to be transformed vr(1:lr) = a(1:lr,lch) ! vector to be transformed
if (my_prow==prow(nrow)) then if (my_prow==prow(nrow, nblk, np_rows)) then
aux1(1) = dot_product(vr(1:lr-1),vr(1:lr-1)) aux1(1) = dot_product(vr(1:lr-1),vr(1:lr-1))
aux1(2) = vr(lr) aux1(2) = vr(lr)
else else
...@@ -3376,7 +3364,7 @@ subroutine bandred_complex(na, a, lda, nblk, nbw, mpi_comm_rows, mpi_comm_cols, ...@@ -3376,7 +3364,7 @@ subroutine bandred_complex(na, a, lda, nblk, nbw, mpi_comm_rows, mpi_comm_cols,
! Scale vr and store Householder vector for back transformation ! Scale vr and store Householder vector for back transformation
vr(1:lr) = vr(1:lr) * xf vr(1:lr) = vr(1:lr) * xf
if (my_prow==prow(nrow)) then if (my_prow==prow(nrow, nblk, np_rows)) then
a(1:lr-1,lch) = vr(1:lr-1) a(1:lr-1,lch) = vr(1:lr-1)
a(lr,lch) = vrl a(lr,lch) = vrl
vr(lr) = 1. vr(lr) = 1.
...@@ -3630,10 +3618,7 @@ subroutine trans_ev_band_to_full_complex(na, nqc, nblk, nbw, a, lda, tmat, q, ld ...@@ -3630,10 +3618,7 @@ subroutine trans_ev_band_to_full_complex(na, nqc, nblk, nbw, a, lda, tmat, q, ld
complex*16, allocatable :: tmp1(:), tmp2(:), hvb(:), hvm(:,:) complex*16, allocatable :: tmp1(:), tmp2(:), hvb(:), hvm(:,:)
integer :: pcol, prow, i integer :: i
pcol(i) = MOD((i-1)/nblk,np_cols) !Processor col for global col number
prow(i) = MOD((i-1)/nblk,np_rows) !Processor row for global row number
#ifdef HAVE_DETAILED_TIMINGS #ifdef HAVE_DETAILED_TIMINGS
call timer%start("trans_ev_band_to_full_complex") call timer%start("trans_ev_band_to_full_complex")
...@@ -3675,12 +3660,12 @@ subroutine trans_ev_band_to_full_complex(na, nqc, nblk, nbw, a, lda, tmat, q, ld ...@@ -3675,12 +3660,12 @@ subroutine trans_ev_band_to_full_complex(na, nqc, nblk, nbw, a, lda, tmat, q, ld
l_rows = local_index(nrow-1, my_prow, np_rows, nblk, -1) ! row length for bcast l_rows = local_index(nrow-1, my_prow, np_rows, nblk, -1) ! row length for bcast
l_colh = local_index(ncol , my_pcol, np_cols, nblk, -1) ! HV local column number l_colh = local_index(ncol , my_pcol, np_cols, nblk, -1) ! HV local column number
if (my_pcol==pcol(ncol)) hvb(nb+1:nb+l_rows) = a(1:l_rows,l_colh) if (my_pcol==pcol(ncol, nblk, np_cols)) hvb(nb+1:nb+l_rows) = a(1:l_rows,l_colh)
nb = nb+l_rows nb = nb+l_rows
if (lc==n_cols .or. mod(ncol,nblk)==0) then if (lc==n_cols .or. mod(ncol,nblk)==0) then
call MPI_Bcast(hvb(ns+1),nb-ns,MPI_DOUBLE_COMPLEX,pcol(ncol),mpi_comm_cols,mpierr) call MPI_Bcast(hvb(ns+1),nb-ns,MPI_DOUBLE_COMPLEX,pcol(ncol, nblk, np_cols),mpi_comm_cols,mpierr)
ns = nb ns = nb
endif endif
enddo enddo
...@@ -3693,7 +3678,7 @@ subroutine trans_ev_band_to_full_complex(na, nqc, nblk, nbw, a, lda, tmat, q, ld ...@@ -3693,7 +3678,7 @@ subroutine trans_ev_band_to_full_complex(na, nqc, nblk, nbw, a, lda, tmat, q, ld
l_rows = local_index(nrow-1, my_prow, np_rows, nblk, -1) ! row length for bcast l_rows = local_index(nrow-1, my_prow, np_rows, nblk, -1) ! row length for bcast
hvm(1:l_rows,lc) = hvb(nb+1:nb+l_rows) hvm(1:l_rows,lc) = hvb(nb+1:nb+l_rows)
if (my_prow==prow(nrow)) hvm(l_rows+1,lc) = 1. if (my_prow==prow(nrow, nblk, np_rows)) hvm(l_rows+1,lc) = 1.
nb = nb+l_rows nb = nb+l_rows
enddo enddo
......
...@@ -69,7 +69,7 @@ module ELPA_utilities ...@@ -69,7 +69,7 @@ module ELPA_utilities
PRIVATE ! By default, all routines contained are private PRIVATE ! By default, all routines contained are private
public :: debug_messages_via_environment_variable public :: debug_messages_via_environment_variable, pcol, prow
#ifndef HAVE_ISO_FORTRAN_ENV #ifndef HAVE_ISO_FORTRAN_ENV
integer, parameter :: error_unit = 6 integer, parameter :: error_unit = 6
#endif #endif
...@@ -108,6 +108,24 @@ module ELPA_utilities ...@@ -108,6 +108,24 @@ module ELPA_utilities
end function debug_messages_via_environment_variable end function debug_messages_via_environment_variable
!-------------------------------------------------------------------------------
!Processor col for global col number
pure function pcol(i, nblk, np_cols) result(col)
integer, intent(in) :: i, nblk, np_cols
integer :: col
col = MOD((i-1)/nblk,np_cols)
end function
!-------------------------------------------------------------------------------
!Processor row for global row number
pure function prow(i, nblk, np_rows) result(row)
integer, intent(in) :: i, nblk, np_rows
integer :: row
row = MOD((i-1)/nblk,np_rows)
end function
!------------------------------------------------------------------------------- !-------------------------------------------------------------------------------
end module ELPA_utilities end module ELPA_utilities
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