Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
On Thursday, 7th July from 1 to 3 pm there will be a maintenance with a short downtime of GitLab.
Open sidebar
elpa
elpa
Commits
6515c5ea
Commit
6515c5ea
authored
Mar 06, 2015
by
Lorenz Huedepohl
Browse files
Transform statement functions into actual functions
parent
991e1b3f
Changes
3
Expand all
Hide whitespace changes
Inline
Side-by-side
src/elpa1.F90
View file @
6515c5ea
This diff is collapsed.
Click to expand it.
src/elpa2.F90
View file @
6515c5ea
...
...
@@ -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
(:,:)
integer
::
pcol
,
prow
! needed for blocked QR decomposition
integer
::
PQRPARAM
(
11
),
work_size
real
*
8
::
dwork_size
(
1
)
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
(
out
)::
success
...
...
@@ -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
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
...
...
@@ -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
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
(
2
)
=
vr
(
lr
)
else
...
...
@@ -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
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
(
lr
,
lch
)
=
vrl
vr
(
lr
)
=
1.
...
...
@@ -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
(:,:)
integer
::
pcol
,
prow
,
i
integer
::
i
real
*
8
,
allocatable
::
tmat_complete
(:,:),
t_tmp
(:,:),
t_tmp2
(:,:)
integer
::
cwy_blocking
,
t_blocking
,
t_cols
,
t_rows
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
call
timer
%
start
(
"trans_ev_band_to_full_real"
)
#endif
...
...
@@ -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_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
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
endif
enddo
...
...
@@ -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
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
enddo
...
...
@@ -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_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
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
endif
enddo
...
...
@@ -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
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
enddo
...
...
@@ -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
(:,:)
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
(
out
)
::
success
#ifdef HAVE_DETAILED_TIMINGS
...
...
@@ -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
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
...
...
@@ -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
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
(
2
)
=
vr
(
lr
)
else
...
...
@@ -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
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
(
lr
,
lch
)
=
vrl
vr
(
lr
)
=
1.
...
...
@@ -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
(:,:)
integer
::
pcol
,
prow
,
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
integer
::
i
#ifdef HAVE_DETAILED_TIMINGS
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
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
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
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
endif
enddo
...
...
@@ -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
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
enddo
...
...
src/elpa_utilities.F90
View file @
6515c5ea
...
...
@@ -69,7 +69,7 @@ module ELPA_utilities
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
integer
,
parameter
::
error_unit
=
6
#endif
...
...
@@ -108,6 +108,24 @@ module ELPA_utilities
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
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment