Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
elpa
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
15
Issues
15
List
Boards
Labels
Service Desk
Milestones
Merge Requests
0
Merge Requests
0
Operations
Operations
Incidents
Environments
Analytics
Analytics
Repository
Value Stream
Wiki
Wiki
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Commits
Issue Boards
Open sidebar
elpa
elpa
Commits
69972fbf
Commit
69972fbf
authored
Aug 06, 2020
by
Andreas Marek
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Some cleanup
parent
03d44007
Changes
8
Pipelines
1
Expand all
Hide whitespace changes
Inline
Side-by-side
Showing
8 changed files
with
2629 additions
and
2424 deletions
+2629
-2424
configure.ac
configure.ac
+11
-2
m4/ax_check_gcc_version.m4
m4/ax_check_gcc_version.m4
+24
-0
m4/ax_compare_version.m4
m4/ax_compare_version.m4
+174
-0
src/elpa1/elpa1_merge_systems_real_template.F90
src/elpa1/elpa1_merge_systems_real_template.F90
+1005
-1005
src/elpa1/elpa1_solve_tridi_real_template.F90
src/elpa1/elpa1_solve_tridi_real_template.F90
+502
-502
src/elpa1/elpa1_tools_template.F90
src/elpa1/elpa1_tools_template.F90
+211
-211
src/elpa1/elpa1_trans_ev_template.F90
src/elpa1/elpa1_trans_ev_template.F90
+392
-392
src/elpa1/elpa1_tridiag_template.F90
src/elpa1/elpa1_tridiag_template.F90
+310
-312
No files found.
configure.ac
View file @
69972fbf
...
@@ -46,7 +46,7 @@ AC_DEFINE([EARLIEST_AUTOTUNE_VERSION], [20171201], [Earliest ELPA API version, w
...
@@ -46,7 +46,7 @@ AC_DEFINE([EARLIEST_AUTOTUNE_VERSION], [20171201], [Earliest ELPA API version, w
AC_DEFINE([CURRENT_AUTOTUNE_VERSION], [20200417], [Current ELPA autotune version])
AC_DEFINE([CURRENT_AUTOTUNE_VERSION], [20200417], [Current ELPA autotune version])
AC_DEFINE_SUBST(CURRENT_AUTOTUNE_VERSION, 20200417, "Current ELPA autotune version")
AC_DEFINE_SUBST(CURRENT_AUTOTUNE_VERSION, 20200417, "Current ELPA autotune version")
AC_DEFINE_UNQUOTED([ELPA_BUILDTIME], [$ELPA_BUILDTIME], ["Time of build"])
AC_DEFINE_UNQUOTED([ELPA_BUILDTIME], [$ELPA_BUILDTIME], ["Time of build"])
AX_COMPARE_VERSION([$ELPA_BUILDTIME], [gt], [1604905771],[old_elpa_version=yes],[old_elpa_version=no])
AX_CHECK_GNU_MAKE()
AX_CHECK_GNU_MAKE()
if test x$_cv_gnu_make_command = x ; then
if test x$_cv_gnu_make_command = x ; then
...
@@ -1776,6 +1776,9 @@ else
...
@@ -1776,6 +1776,9 @@ else
echo "build config should be compiled into the library: no"
echo "build config should be compiled into the library: no"
fi
fi
if test x"$have_loop_blocking" = x"yes"; then
AC_DEFINE([LOOP_BLOCKING],[1],[use blocking in loops])
fi
AC_SUBST([SUFFIX])
AC_SUBST([SUFFIX])
AC_SUBST([PKG_CONFIG_FILE],[elpa${SUFFIX}-${PACKAGE_VERSION}.pc])
AC_SUBST([PKG_CONFIG_FILE],[elpa${SUFFIX}-${PACKAGE_VERSION}.pc])
...
@@ -1986,4 +1989,10 @@ else
...
@@ -1986,4 +1989,10 @@ else
make -f $srcdir/generated_headers.am generated-headers top_srcdir="$srcdir" CPP="$CPP"
make -f $srcdir/generated_headers.am generated-headers top_srcdir="$srcdir" CPP="$CPP"
fi
fi
if test x"$old_elpa_version" = x"yes"; then
echo " "
echo " It is possible that your current version of ELPA is not the latest one."
echo " You might want to have a look at https://elpa.mpcdf.mpg.de, whether a more recent"
echo " version has been released already"
echo " "
fi
m4/ax_check_gcc_version.m4
0 → 100644
View file @
69972fbf
AC_DEFUN([AX_GCC_VERSION], [
GCC_VERSION=""
echo "calling gcc"
echo $CC
$CC | grep gcc
echo $?
AX_CHECK_COMPILE_FLAG([-dumpversion],
[ax_gcc_version_option=yes],
[ax_gcc_version_option=no])
AS_IF([test "x$GCC" = "xyes"],[
AS_IF([test "x$ax_gcc_version_option" != "xno"],[
AC_CACHE_CHECK([gcc version],[ax_cv_gcc_version],[
ax_cv_gcc_version="`$CC -dumpversion`"
AS_IF([test "x$ax_cv_gcc_version" = "x"],[
ax_cv_gcc_version=""
])
])
GCC_VERSION=$ax_cv_gcc_version
])
])
AC_SUBST([GCC_VERSION])
])
m4/ax_compare_version.m4
0 → 100644
View file @
69972fbf
# ===========================================================================
# https://www.gnu.org/software/autoconf-archive/ax_compare_version.html
# ===========================================================================
#
# SYNOPSIS
#
# AX_COMPARE_VERSION(VERSION_A, OP, VERSION_B, [ACTION-IF-TRUE], [ACTION-IF-FALSE])
#
# DESCRIPTION
#
# This macro compares two version strings. Due to the various number of
# minor-version numbers that can exist, and the fact that string
# comparisons are not compatible with numeric comparisons, this is not
# necessarily trivial to do in a autoconf script. This macro makes doing
# these comparisons easy.
#
# The six basic comparisons are available, as well as checking equality
# limited to a certain number of minor-version levels.
#
# The operator OP determines what type of comparison to do, and can be one
# of:
#
# eq - equal (test A == B)
# ne - not equal (test A != B)
# le - less than or equal (test A <= B)
# ge - greater than or equal (test A >= B)
# lt - less than (test A < B)
# gt - greater than (test A > B)
#
# Additionally, the eq and ne operator can have a number after it to limit
# the test to that number of minor versions.
#
# eq0 - equal up to the length of the shorter version
# ne0 - not equal up to the length of the shorter version
# eqN - equal up to N sub-version levels
# neN - not equal up to N sub-version levels
#
# When the condition is true, shell commands ACTION-IF-TRUE are run,
# otherwise shell commands ACTION-IF-FALSE are run. The environment
# variable 'ax_compare_version' is always set to either 'true' or 'false'
# as well.
#
# Examples:
#
# AX_COMPARE_VERSION([3.15.7],[lt],[3.15.8])
# AX_COMPARE_VERSION([3.15],[lt],[3.15.8])
#
# would both be true.
#
# AX_COMPARE_VERSION([3.15.7],[eq],[3.15.8])
# AX_COMPARE_VERSION([3.15],[gt],[3.15.8])
#
# would both be false.
#
# AX_COMPARE_VERSION([3.15.7],[eq2],[3.15.8])
#
# would be true because it is only comparing two minor versions.
#
# AX_COMPARE_VERSION([3.15.7],[eq0],[3.15])
#
# would be true because it is only comparing the lesser number of minor
# versions of the two values.
#
# Note: The characters that separate the version numbers do not matter. An
# empty string is the same as version 0. OP is evaluated by autoconf, not
# configure, so must be a string, not a variable.
#
# The author would like to acknowledge Guido Draheim whose advice about
# the m4_case and m4_ifvaln functions make this macro only include the
# portions necessary to perform the specific comparison specified by the
# OP argument in the final configure script.
#
# LICENSE
#
# Copyright (c) 2008 Tim Toolan <toolan@ele.uri.edu>
#
# Copying and distribution of this file, with or without modification, are
# permitted in any medium without royalty provided the copyright notice
# and this notice are preserved. This file is offered as-is, without any
# warranty.
#serial 13
dnl #########################################################################
AC_DEFUN([AX_COMPARE_VERSION], [
AC_REQUIRE([AC_PROG_AWK])
# Used to indicate true or false condition
ax_compare_version=false
# Convert the two version strings to be compared into a format that
# allows a simple string comparison. The end result is that a version
# string of the form 1.12.5-r617 will be converted to the form
# 0001001200050617. In other words, each number is zero padded to four
# digits, and non digits are removed.
AS_VAR_PUSHDEF([A],[ax_compare_version_A])
A=`echo "$1" | sed -e 's/\([[0-9]]*\)/Z\1Z/g' \
-e 's/Z\([[0-9]]\)Z/Z0\1Z/g' \
-e 's/Z\([[0-9]][[0-9]]\)Z/Z0\1Z/g' \
-e 's/Z\([[0-9]][[0-9]][[0-9]]\)Z/Z0\1Z/g' \
-e 's/[[^0-9]]//g'`
AS_VAR_PUSHDEF([B],[ax_compare_version_B])
B=`echo "$3" | sed -e 's/\([[0-9]]*\)/Z\1Z/g' \
-e 's/Z\([[0-9]]\)Z/Z0\1Z/g' \
-e 's/Z\([[0-9]][[0-9]]\)Z/Z0\1Z/g' \
-e 's/Z\([[0-9]][[0-9]][[0-9]]\)Z/Z0\1Z/g' \
-e 's/[[^0-9]]//g'`
dnl # In the case of le, ge, lt, and gt, the strings are sorted as necessary
dnl # then the first line is used to determine if the condition is true.
dnl # The sed right after the echo is to remove any indented white space.
m4_case(m4_tolower($2),
[lt],[
ax_compare_version=`echo "x$A
x$B" | sed 's/^ *//' | sort -r | sed "s/x${A}/false/;s/x${B}/true/;1q"`
],
[gt],[
ax_compare_version=`echo "x$A
x$B" | sed 's/^ *//' | sort | sed "s/x${A}/false/;s/x${B}/true/;1q"`
],
[le],[
ax_compare_version=`echo "x$A
x$B" | sed 's/^ *//' | sort | sed "s/x${A}/true/;s/x${B}/false/;1q"`
],
[ge],[
ax_compare_version=`echo "x$A
x$B" | sed 's/^ *//' | sort -r | sed "s/x${A}/true/;s/x${B}/false/;1q"`
],[
dnl Split the operator from the subversion count if present.
m4_bmatch(m4_substr($2,2),
[0],[
# A count of zero means use the length of the shorter version.
# Determine the number of characters in A and B.
ax_compare_version_len_A=`echo "$A" | $AWK '{print(length)}'`
ax_compare_version_len_B=`echo "$B" | $AWK '{print(length)}'`
# Set A to no more than B's length and B to no more than A's length.
A=`echo "$A" | sed "s/\(.\{$ax_compare_version_len_B\}\).*/\1/"`
B=`echo "$B" | sed "s/\(.\{$ax_compare_version_len_A\}\).*/\1/"`
],
[[0-9]+],[
# A count greater than zero means use only that many subversions
A=`echo "$A" | sed "s/\(\([[0-9]]\{4\}\)\{m4_substr($2,2)\}\).*/\1/"`
B=`echo "$B" | sed "s/\(\([[0-9]]\{4\}\)\{m4_substr($2,2)\}\).*/\1/"`
],
[.+],[
AC_WARNING(
[invalid OP numeric parameter: $2])
],[])
# Pad zeros at end of numbers to make same length.
ax_compare_version_tmp_A="$A`echo $B | sed 's/./0/g'`"
B="$B`echo $A | sed 's/./0/g'`"
A="$ax_compare_version_tmp_A"
# Check for equality or inequality as necessary.
m4_case(m4_tolower(m4_substr($2,0,2)),
[eq],[
test "x$A" = "x$B" && ax_compare_version=true
],
[ne],[
test "x$A" != "x$B" && ax_compare_version=true
],[
AC_WARNING([invalid OP parameter: $2])
])
])
AS_VAR_POPDEF([A])dnl
AS_VAR_POPDEF([B])dnl
dnl # Execute ACTION-IF-TRUE / ACTION-IF-FALSE.
if test "$ax_compare_version" = "true" ; then
have_loop_blocking=yes
m4_ifvaln([$4],[$4],[:])dnl
m4_ifvaln([$5],[else $5])dnl
fi
]) dnl AX_COMPARE_VERSION
src/elpa1/elpa1_merge_systems_real_template.F90
View file @
69972fbf
This diff is collapsed.
Click to expand it.
src/elpa1/elpa1_solve_tridi_real_template.F90
View file @
69972fbf
This diff is collapsed.
Click to expand it.
src/elpa1/elpa1_tools_template.F90
View file @
69972fbf
...
@@ -56,304 +56,304 @@
...
@@ -56,304 +56,304 @@
#if REALCASE == 1
#if REALCASE == 1
subroutine
v_add_s_
&
subroutine
v_add_s_
&
&
PRECISION
&
&
PRECISION
&
&(
obj
,
v
,
n
,
s
)
&(
obj
,
v
,
n
,
s
)
use
precision
use
precision
use
elpa_abstract_impl
use
elpa_abstract_impl
implicit
none
implicit
none
#include "../general/precision_kinds.F90"
#include "../general/precision_kinds.F90"
class
(
elpa_abstract_impl_t
),
intent
(
inout
)
::
obj
class
(
elpa_abstract_impl_t
),
intent
(
inout
)
::
obj
integer
(
kind
=
ik
)
::
n
integer
(
kind
=
ik
)
::
n
real
(
kind
=
rk
)
::
v
(
n
),
s
real
(
kind
=
rk
)
::
v
(
n
),
s
v
(:)
=
v
(:)
+
s
v
(:)
=
v
(:)
+
s
end
subroutine
v_add_s_
&
end
subroutine
v_add_s_
&
&
PRECISION
&
PRECISION
subroutine
distribute_global_column_
&
subroutine
distribute_global_column_
&
&
PRECISION
&
&
PRECISION
&
&(
obj
,
g_col
,
l_col
,
noff
,
nlen
,
my_prow
,
np_rows
,
nblk
)
&(
obj
,
g_col
,
l_col
,
noff
,
nlen
,
my_prow
,
np_rows
,
nblk
)
use
precision
use
precision
use
elpa_abstract_impl
use
elpa_abstract_impl
implicit
none
implicit
none
#include "../general/precision_kinds.F90"
#include "../general/precision_kinds.F90"
class
(
elpa_abstract_impl_t
),
intent
(
inout
)
::
obj
class
(
elpa_abstract_impl_t
),
intent
(
inout
)
::
obj
integer
(
kind
=
ik
)
::
noff
,
nlen
,
my_prow
,
np_rows
,
nblk
integer
(
kind
=
ik
)
::
noff
,
nlen
,
my_prow
,
np_rows
,
nblk
real
(
kind
=
rk
)
::
g_col
(
nlen
),
l_col
(
*
)
! chnage this to proper 2d 1d matching ! remove assumed size
real
(
kind
=
rk
)
::
g_col
(
nlen
),
l_col
(
*
)
! chnage this to proper 2d 1d matching ! remove assumed size
integer
(
kind
=
ik
)
::
nbs
,
nbe
,
jb
,
g_off
,
l_off
,
js
,
je
integer
(
kind
=
ik
)
::
nbs
,
nbe
,
jb
,
g_off
,
l_off
,
js
,
je
nbs
=
noff
/(
nblk
*
np_rows
)
nbs
=
noff
/(
nblk
*
np_rows
)
nbe
=
(
noff
+
nlen
-1
)/(
nblk
*
np_rows
)
nbe
=
(
noff
+
nlen
-1
)/(
nblk
*
np_rows
)
do
jb
=
nbs
,
nbe
do
jb
=
nbs
,
nbe
g_off
=
jb
*
nblk
*
np_rows
+
nblk
*
my_prow
g_off
=
jb
*
nblk
*
np_rows
+
nblk
*
my_prow
l_off
=
jb
*
nblk
l_off
=
jb
*
nblk
js
=
MAX
(
noff
+1
-
g_off
,
1
)
js
=
MAX
(
noff
+1
-
g_off
,
1
)
je
=
MIN
(
noff
+
nlen
-
g_off
,
nblk
)
je
=
MIN
(
noff
+
nlen
-
g_off
,
nblk
)
if
(
je
<
js
)
cycle
if
(
je
<
js
)
cycle
l_col
(
l_off
+
js
:
l_off
+
je
)
=
g_col
(
g_off
+
js
-
noff
:
g_off
+
je
-
noff
)
l_col
(
l_off
+
js
:
l_off
+
je
)
=
g_col
(
g_off
+
js
-
noff
:
g_off
+
je
-
noff
)
enddo
enddo
end
subroutine
distribute_global_column_
&
end
subroutine
distribute_global_column_
&
&
PRECISION
&
PRECISION
subroutine
solve_secular_equation_
&
subroutine
solve_secular_equation_
&
&
PRECISION
&
&
PRECISION
&
&(
obj
,
n
,
i
,
d
,
z
,
delta
,
rho
,
dlam
)
&(
obj
,
n
,
i
,
d
,
z
,
delta
,
rho
,
dlam
)
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
! This routine solves the secular equation of a symmetric rank 1 modified
! This routine solves the secular equation of a symmetric rank 1 modified
! diagonal matrix:
! diagonal matrix:
!
!
! 1. + rho*SUM(z(:)**2/(d(:)-x)) = 0
! 1. + rho*SUM(z(:)**2/(d(:)-x)) = 0
!
!
! It does the same as the LAPACK routine DLAED4 but it uses a bisection technique
! It does the same as the LAPACK routine DLAED4 but it uses a bisection technique
! which is more robust (it always yields a solution) but also slower
! which is more robust (it always yields a solution) but also slower
! than the algorithm used in DLAED4.
! than the algorithm used in DLAED4.
!
!
! The same restictions than in DLAED4 hold, namely:
! The same restictions than in DLAED4 hold, namely:
!
!
! rho > 0 and d(i+1) > d(i)
! rho > 0 and d(i+1) > d(i)
!
!
! but this routine will not terminate with error if these are not satisfied
! but this routine will not terminate with error if these are not satisfied
! (it will normally converge to a pole in this case).
! (it will normally converge to a pole in this case).
!
!
! The output in DELTA(j) is always (D(j) - lambda_I), even for the cases
! The output in DELTA(j) is always (D(j) - lambda_I), even for the cases
! N=1 and N=2 which is not compatible with DLAED4.
! N=1 and N=2 which is not compatible with DLAED4.
! Thus this routine shouldn't be used for these cases as a simple replacement
! Thus this routine shouldn't be used for these cases as a simple replacement
! of DLAED4.
! of DLAED4.
!
!
! The arguments are the same as in DLAED4 (with the exception of the INFO argument):
! The arguments are the same as in DLAED4 (with the exception of the INFO argument):
!
!
!
!
! N (input) INTEGER
! N (input) INTEGER
! The length of all arrays.
! The length of all arrays.
!
!
! I (input) INTEGER
! I (input) INTEGER
! The index of the eigenvalue to be computed. 1 <= I <= N.
! The index of the eigenvalue to be computed. 1 <= I <= N.
!
!
! D (input) DOUBLE PRECISION array, dimension (N)
! D (input) DOUBLE PRECISION array, dimension (N)
! The original eigenvalues. It is assumed that they are in
! The original eigenvalues. It is assumed that they are in
! order, D(I) < D(J) for I < J.
! order, D(I) < D(J) for I < J.
!
!
! Z (input) DOUBLE PRECISION array, dimension (N)
! Z (input) DOUBLE PRECISION array, dimension (N)
! The components of the updating Vector.
! The components of the updating Vector.
!
!
! DELTA (output) DOUBLE PRECISION array, dimension (N)
! DELTA (output) DOUBLE PRECISION array, dimension (N)
! DELTA contains (D(j) - lambda_I) in its j-th component.
! DELTA contains (D(j) - lambda_I) in its j-th component.
! See remark above about DLAED4 compatibility!
! See remark above about DLAED4 compatibility!
!
!
! RHO (input) DOUBLE PRECISION
! RHO (input) DOUBLE PRECISION
! The scalar in the symmetric updating formula.
! The scalar in the symmetric updating formula.
!
!
! DLAM (output) DOUBLE PRECISION
! DLAM (output) DOUBLE PRECISION
! The computed lambda_I, the I-th updated eigenvalue.
! The computed lambda_I, the I-th updated eigenvalue.
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
use
precision
use
precision
use
elpa_abstract_impl
use
elpa_abstract_impl
implicit
none
implicit
none
#include "../../src/general/precision_kinds.F90"
#include "../../src/general/precision_kinds.F90"
class
(
elpa_abstract_impl_t
),
intent
(
inout
)
::
obj
class
(
elpa_abstract_impl_t
),
intent
(
inout
)
::
obj
integer
(
kind
=
ik
)
::
n
,
i
integer
(
kind
=
ik
)
::
n
,
i
real
(
kind
=
rk
)
::
d
(
n
),
z
(
n
),
delta
(
n
),
rho
,
dlam
real
(
kind
=
rk
)
::
d
(
n
),
z
(
n
),
delta
(
n
),
rho
,
dlam
integer
(
kind
=
ik
)
::
iter
integer
(
kind
=
ik
)
::
iter
real
(
kind
=
rk
)
::
a
,
b
,
x
,
y
,
dshift
real
(
kind
=
rk
)
::
a
,
b
,
x
,
y
,
dshift
! In order to obtain sufficient numerical accuracy we have to shift the problem
! In order to obtain sufficient numerical accuracy we have to shift the problem
! either by d(i) or d(i+1), whichever is closer to the solution
! either by d(i) or d(i+1), whichever is closer to the solution
! Upper and lower bound of the shifted solution interval are a and b
! Upper and lower bound of the shifted solution interval are a and b
call
obj
%
timer
%
start
(
"solve_secular_equation"
//
PRECISION_SUFFIX
)
call
obj
%
timer
%
start
(
"solve_secular_equation"
//
PRECISION_SUFFIX
)
if
(
i
==
n
)
then
if
(
i
==
n
)
then
! Special case: Last eigenvalue
! Special case: Last eigenvalue
! We shift always by d(n), lower bound is d(n),
! We shift always by d(n), lower bound is d(n),
! upper bound is determined by a guess:
! upper bound is determined by a guess:
dshift
=
d
(
n
)
dshift
=
d
(
n
)
delta
(:)
=
d
(:)
-
dshift
delta
(:)
=
d
(:)
-
dshift
a
=
0.0_rk
! delta(n)
a
=
0.0_rk
! delta(n)
b
=
rho
*
SUM
(
z
(:)
**
2
)
+
1.0_rk
! rho*SUM(z(:)**2) is the lower bound for the guess
b
=
rho
*
SUM
(
z
(:)
**
2
)
+
1.0_rk
! rho*SUM(z(:)**2) is the lower bound for the guess
else
else
! Other eigenvalues: lower bound is d(i), upper bound is d(i+1)
! Other eigenvalues: lower bound is d(i), upper bound is d(i+1)
! We check the sign of the function in the midpoint of the interval
! We check the sign of the function in the midpoint of the interval
! in order to determine if eigenvalue is more close to d(i) or d(i+1)
! in order to determine if eigenvalue is more close to d(i) or d(i+1)
x
=
0.5_rk
*
(
d
(
i
)
+
d
(
i
+1
))
x
=
0.5_rk
*
(
d
(
i
)
+
d
(
i
+1
))
y
=
1.0_rk
+
rho
*
SUM
(
z
(:)
**
2
/(
d
(:)
-
x
))
y
=
1.0_rk
+
rho
*
SUM
(
z
(:)
**
2
/(
d
(:)
-
x
))
if
(
y
>
0
)
then
if
(
y
>
0
)
then
! solution is next to d(i)
! solution is next to d(i)
dshift
=
d
(
i
)
dshift
=
d
(
i
)
else
else
! solution is next to d(i+1)
! solution is next to d(i+1)
dshift
=
d
(
i
+1
)
dshift
=
d
(
i
+1
)
endif
endif
delta
(:)
=
d
(:)
-
dshift
delta
(:)
=
d
(:)
-
dshift
a
=
delta
(
i
)
a
=
delta
(
i
)
b
=
delta
(
i
+1
)
b
=
delta
(
i
+1
)
endif
endif
! Bisection:
! Bisection:
do
iter
=
1
,
200
do
iter
=
1
,
200
! Interval subdivision
! Interval subdivision
x
=
0.5_rk
*
(
a
+
b
)
x
=
0.5_rk
*
(
a
+
b
)
if
(
x
==
a
.or.
x
==
b
)
exit
! No further interval subdivisions possible
if
(
x
==
a
.or.
x
==
b
)
exit
! No further interval subdivisions possible
#ifdef DOUBLE_PRECISION_REAL
#ifdef DOUBLE_PRECISION_REAL
if
(
abs
(
x
)
<
1.e-200_rk8
)
exit
! x next to pole
if
(
abs
(
x
)
<
1.e-200_rk8
)
exit
! x next to pole
#else
#else
if
(
abs
(
x
)
<
1.e-20_rk4
)
exit
! x next to pole
if
(
abs
(
x
)
<
1.e-20_rk4
)
exit
! x next to pole
#endif
#endif
! evaluate value at x
! evaluate value at x
y
=
1.
+
rho
*
SUM
(
z
(:)
**
2
/(
delta
(:)
-
x
))
y
=
1.
+
rho
*
SUM
(
z
(:)
**
2
/(
delta
(:)
-
x
))
if
(
y
==
0
)
then
if
(
y
==
0
)
then
! found exact solution
! found exact solution
exit
exit
elseif
(
y
>
0
)
then
elseif
(
y
>
0
)
then
b
=
x
b
=
x
else
else
a
=
x
a
=
x
endif
endif
enddo
enddo
! Solution:
! Solution:
dlam
=
x
+
dshift
dlam
=
x
+
dshift
delta
(:)
=
delta
(:)
-
x
delta
(:)
=
delta
(:)
-
x
call
obj
%
timer
%
stop
(
"solve_secular_equation"
//
PRECISION_SUFFIX
)
call
obj
%
timer
%
stop
(
"solve_secular_equation"
//
PRECISION_SUFFIX
)
end
subroutine
solve_secular_equation_
&
end
subroutine
solve_secular_equation_
&
&
PRECISION
&
PRECISION
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
#endif
#endif
#if REALCASE == 1
#if REALCASE == 1
subroutine
hh_transform_real_
&
subroutine
hh_transform_real_
&
#endif
#endif
#if COMPLEXCASE == 1
#if COMPLEXCASE == 1
subroutine
hh_transform_complex_
&
subroutine
hh_transform_complex_
&
#endif
#endif
&
PRECISION
&
&
PRECISION
&
(
obj
,
alpha
,
xnorm_sq
,
xf
,
tau
,
wantDebug
)
(
obj
,
alpha
,
xnorm_sq
,
xf
,
tau
,
wantDebug
)
#if REALCASE == 1
#if REALCASE == 1
! Similar to LAPACK routine DLARFP, but uses ||x||**2 instead of x(:)
! Similar to LAPACK routine DLARFP, but uses ||x||**2 instead of x(:)
#endif
#endif
#if COMPLEXCASE == 1
#if COMPLEXCASE == 1
! Similar to LAPACK routine ZLARFP, but uses ||x||**2 instead of x(:)
! Similar to LAPACK routine ZLARFP, but uses ||x||**2 instead of x(:)
#endif
#endif
! and returns the factor xf by which x has to be scaled.
! and returns the factor xf by which x has to be scaled.
! It also hasn't the special handling for numbers < 1.d-300 or > 1.d150
! It also hasn't the special handling for numbers < 1.d-300 or > 1.d150
! since this would be expensive for the parallel implementation.
! since this would be expensive for the parallel implementation.
use
precision
use
precision
use
elpa_abstract_impl
use
elpa_abstract_impl
implicit
none
implicit
none
#include "../general/precision_kinds.F90"
#include "../general/precision_kinds.F90"
class
(
elpa_abstract_impl_t
),
intent
(
inout
)
::
obj
class
(
elpa_abstract_impl_t
),
intent
(
inout
)
::
obj
logical
,
intent
(
in
)
::
wantDebug
logical
,
intent
(
in
)
::
wantDebug
#if REALCASE == 1
#if REALCASE == 1
real
(
kind
=
rk
),
intent
(
inout
)
::
alpha
real
(
kind
=
rk
),
intent
(
inout
)
::
alpha
#endif
#endif
#if COMPLEXCASE == 1
#if COMPLEXCASE == 1
complex
(
kind
=
ck
),
intent
(
inout
)
::
alpha
complex
(
kind
=
ck
),
intent
(
inout
)
::
alpha
#endif
#endif