├── deps ├── build.jl ├── singleshift │ ├── src │ │ ├── init_random_seed.f90 │ │ ├── normalpoly.f90 │ │ ├── cnormalpoly.f90 │ │ ├── buildbulge.f90 │ │ ├── modified_quadratic.f90 │ │ ├── crgivens.f90 │ │ ├── throughdiag.f90 │ │ ├── balance.f90 │ │ ├── factor.f90 │ │ ├── chasebulge.f90 │ │ ├── diagblock.f90 │ │ ├── deflation.f90 │ │ ├── zamvw.f90 │ │ ├── fuse.f90 │ │ ├── zamvw2.f90 │ │ ├── turnovers │ │ │ └── dto4.f90 │ │ └── rescheck.f90 │ ├── README │ ├── environment │ └── tests │ │ ├── rootstocoeffs.f90 │ │ ├── backward.f90 │ │ ├── zamvw2test.f90 │ │ ├── rootrace_jt.f95 │ │ └── rootrace_unit.f95 ├── doubleshift │ ├── src │ │ ├── init_random_seed.f90 │ │ ├── DNORMALPOLY.f90 │ │ ├── DCFD.f90 │ │ ├── DFGR.f90 │ │ ├── DRANDPOLYJT.f90 │ │ ├── DGR.f90 │ │ ├── DMQF.f90 │ │ ├── DFCC.f90 │ │ ├── DCFT.f90 │ │ ├── balance.f90 │ │ ├── DCDB.f90 │ │ ├── DCB.f90 │ │ ├── turnovers │ │ │ └── DGTO2.f90 │ │ ├── DAMVW.f90 │ │ └── RESCHECK.f90 │ ├── README │ ├── environment │ └── tests │ │ ├── backward.f95 │ │ ├── rootstocoeffs.f90 │ │ ├── testDAMVW.f95 │ │ ├── rootrace_jt.f95 │ │ ├── rootrace_unit.f95 │ │ ├── rootrace_backward_stability.f95 │ │ └── rootrace.f95 └── Makefile ├── README.md ├── test └── tests.jl └── src └── AMVW.jl /deps/build.jl: -------------------------------------------------------------------------------- 1 | p = pwd() 2 | cd(Pkg.dir("AMVW/deps/")) 3 | run(`make`) 4 | cd(p) 5 | -------------------------------------------------------------------------------- /deps/singleshift/src/init_random_seed.f90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Initialize random seed based on CPU clock 3 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 4 | SUBROUTINE init_random_seed() 5 | 6 | implicit none 7 | 8 | INTEGER :: i, n, clock 9 | INTEGER, DIMENSION(:), ALLOCATABLE :: seed 10 | 11 | CALL RANDOM_SEED(size = n) 12 | ALLOCATE(seed(n)) 13 | 14 | CALL SYSTEM_CLOCK(COUNT=clock) 15 | 16 | seed = clock + 37 * (/ (i - 1, i = 1, n) /) 17 | CALL RANDOM_SEED(PUT = seed) 18 | 19 | DEALLOCATE(seed) 20 | 21 | END SUBROUTINE 22 | 23 | 24 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # AMVW.jl - Fast and backward stable computation of roots of polynomials 2 | This package is a Julia wrapper of code accompanying the article written by Jared L. Aurentz, Thomas Mach, Raf Vandebril and David S. Watkins. 3 | 4 | ## Installation 5 | ``` 6 | Pkg.clone("https://github.com/andreasnoackjensen/AMVW.jl") 7 | Pkg.build("AMVW") 8 | ``` 9 | ## Example: Roots of a polynomial of degree 10,000 10 | ```julia 11 | julia> using AMVW 12 | 13 | julia> p = Poly(randn(10000)); 14 | 15 | julia> @time AMVW.rootsAMVW(p); 16 | elapsed time: 48.162882002 seconds (1987560 bytes allocated) 17 | ``` 18 | Don't try `roots(p)` -------------------------------------------------------------------------------- /test/tests.jl: -------------------------------------------------------------------------------- 1 | using AMVW, Base.Test 2 | 3 | # Standard normal coefficients 4 | p = Poly(randn(50)) 5 | @test_approx_eq sort(abs(roots(p))) sort(abs(AMVW.rootsAMVW(p))) 6 | 7 | # Standard normal complex coefficient 8 | p = Poly(complex(randn(50), randn(50))) 9 | @test_approx_eq sort(abs(roots(p))) sort(abs(AMVW.rootsAMVW(p))) 10 | 11 | # Possible to calculate roots of large polynomial 12 | p = Poly(randn(5000)) 13 | @time AMVW.rootsAMVW(p) 14 | 15 | # But polynomial root finding is ill conditioned 16 | rts = 1:100.0 17 | p = mapreduce(t -> Poly([1, -t]), *, Poly(Float64[1]), rts) 18 | 19 | println(norm(sort(abs(AMVW.rootsAMVW(p))) - rts)) -------------------------------------------------------------------------------- /deps/singleshift/src/normalpoly.f90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! computes n random complex coefficients 3 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 4 | subroutine normalpoly(n,rcoeffs,icoeffs) 5 | 6 | implicit none 7 | 8 | ! input variables 9 | integer, intent(in) :: n 10 | double precision, intent(inout) :: rcoeffs(n), icoeffs(n) 11 | 12 | ! compute variables 13 | double precision :: u,v,s,pi = 3.141592653589793239d0 14 | integer :: ii,jj 15 | 16 | do ii=1,n 17 | do jj=1,100 18 | 19 | call random_number(u) 20 | call random_number(v) 21 | 22 | s = u**2 + v**2 23 | 24 | if(s > 0 .and. s < 1)then 25 | rcoeffs(ii) = dcos(2.d0*pi*v)*dsqrt(-2.d0*dlog(u)) 26 | icoeffs(ii) = dsin(2.d0*pi*v)*dsqrt(-2.d0*dlog(u)) 27 | exit 28 | end if 29 | end do 30 | 31 | end do 32 | 33 | end subroutine 34 | 35 | -------------------------------------------------------------------------------- /deps/doubleshift/src/init_random_seed.f90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Initialize Random Seed 3 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 4 | ! 5 | ! This subroutine initializes the random number generator using the 6 | ! CPU clock. 7 | ! 8 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 9 | subroutine INIT_RANDOM_SEED() 10 | 11 | implicit none 12 | 13 | ! compute variables 14 | integer :: ii, n, clock 15 | integer, allocatable :: seed(:) 16 | 17 | call RANDOM_SEED(size = n) 18 | allocate(seed(n)) 19 | 20 | call SYSTEM_CLOCK(COUNT=clock) 21 | 22 | seed = clock + 37 * (/ (ii - 1, ii = 1, n) /) 23 | call RANDOM_SEED(PUT = seed) 24 | 25 | deallocate(seed) 26 | 27 | end subroutine 28 | -------------------------------------------------------------------------------- /deps/singleshift/src/cnormalpoly.f90: -------------------------------------------------------------------------------- 1 | ! **************************************************************************** 2 | ! 3 | ! This subroutine generates a one dimensional complex array whose entries are 4 | ! normally distributed with mean 0 and variance 1 in both the real and imaginary parts 5 | ! 6 | ! **************************************************************************** 7 | subroutine cnormalpoly(degree,poly) 8 | 9 | implicit none 10 | 11 | integer, intent(in) :: degree 12 | complex(kind(1d0)), intent(inout) :: poly(degree) 13 | 14 | double precision :: u,v,s,pi = 3.141592653589793239d0 15 | integer :: i,j 16 | 17 | do i=1,degree 18 | do j=1,20 19 | 20 | call random_number(u) 21 | call random_number(v) 22 | 23 | s = u**2 + v**2 24 | 25 | if(s > 0 .and. s < 1)then 26 | poly(i) = complex(dcos(2.d0*pi*v)*dsqrt(-2.d0*dlog(u)),dsin(2.d0*pi*v)*dsqrt(-2.d0*dlog(u))) 27 | exit 28 | end if 29 | end do 30 | 31 | end do 32 | 33 | 34 | end subroutine 35 | 36 | -------------------------------------------------------------------------------- /deps/singleshift/README: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Aurentz² Mach³ Vandebril³ Watkins² 3 | ! 4 | ! ²Dept. Mathematics, Washington State University 5 | ! ³Dept. Computer Science, KU Leuven 6 | ! 7 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8 | ! Last modified 22 August 2014 9 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 10 | 11 | Polynomial Rootfinder ZAMVW 12 | complex single shift code 13 | 14 | The algorithm uses Francis's implicitly shifted QR algorithm to compute the 15 | roots of a given complex polynomial via the Companion matrix. The available 16 | unitary plus rank 1 structure is exploited. Thus the complexity of the algorithm 17 | is in O(n²). 18 | 19 | To compile the Fortran code it is necessary to set some parameters in the file 20 | environment. 21 | 22 | For the test of the special polynomials is the package MPFUN necessary, which 23 | is provided at http://crd.lbl.gov/~dhbailey/mpdist/mpfun90.tar.gz by David H. Bailey; 24 | see also http://www.netlib.org/mpfun/. 25 | 26 | Please extract the files into a directory and run the makefile in the f90 directory. 27 | Then at the change the path MPDIR in environment. -------------------------------------------------------------------------------- /deps/doubleshift/README: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Aurentz² Mach³ Vandebril³ Watkins² 3 | ! 4 | ! ²Dept. Mathematics, Washington State University 5 | ! ³Dept. Computer Science, KU Leuven 6 | ! 7 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8 | ! Last modified 22 August 2014 9 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 10 | 11 | Polynomial Rootfinder ZAMVW 12 | real double shift code 13 | 14 | The algorithm uses Francis's implicitly shifted QR algorithm to compute the 15 | roots of a given polynomial with real coefficients via the companion matrix. The 16 | available unitary plus rank 1 structure is exploited. Thus the complexity of the 17 | algorithm is in O(n²). 18 | 19 | To compile the Fortran code it is necessary to set some parameters in the file 20 | environment. 21 | 22 | For the test of the special polynomials is the package MPFUN necessary, which 23 | is provided at http://crd.lbl.gov/~dhbailey/mpdist/mpfun90.tar.gz by David H. Bailey; 24 | see also http://www.netlib.org/mpfun/. 25 | 26 | Please extract the files into a directory and run the makefile in the f90 directory. 27 | Then at the change the path MPDIR in environment. -------------------------------------------------------------------------------- /deps/singleshift/environment: -------------------------------------------------------------------------------- 1 | ################################################## 2 | # Enviroment file set some paths here 3 | ################################################## 4 | # Set HOMEDIR, e.g. 5 | #HOMEDIR := /home/thomasm/AMVW/singleshift 6 | HOMEDIR := /home/thomasm/work/paper/130801_Watkins_Companion/svn/AMVW/fortran/branches/singleshift 7 | 8 | ################################################## 9 | # Don't change anything! 10 | TESTDIR := $(HOMEDIR)/tests 11 | SRCDIR := $(HOMEDIR)/src 12 | TODIR := $(SRCDIR)/turnovers 13 | ################################################## 14 | # set path to mpfun f90 files 15 | MPDIR := $(HOMEDIR)/mpfun 16 | 17 | ################################################## 18 | # compiler 19 | ################################################## 20 | FC := gfortran 21 | # compiler flags 22 | FFLAGS := -O3 23 | # debugging flags 24 | # FFLAGS := -pg -g 25 | 26 | ################################################## 27 | # BLAS and LAPACK 28 | ################################################## 29 | # Set LIBS parameters for BLAS and LAPACK, e.g., 30 | LIBS := /usr/lib/lapack/liblapack.so.3gf /usr/lib/libblas.so.3gf -lm 31 | # LIBS := -llapack -lblas -lm 32 | # LIBS := /usr/lib/liblapack.so.3gf /usr/lib/libblas.so.3gf -lm 33 | 34 | -------------------------------------------------------------------------------- /deps/doubleshift/environment: -------------------------------------------------------------------------------- 1 | ################################################## 2 | # Enviroment file set some paths here 3 | ################################################## 4 | # Set HOMEDIR, e.g. 5 | #HOMEDIR := /home/thomasm/AMVW/doubleshift 6 | HOMEDIR := /home/thomasm/work/paper/130801_Watkins_Companion/svn/AMVW/fortran/branches/doubleshift 7 | 8 | ################################################## 9 | # Don't change anything! 10 | TESTDIR := $(HOMEDIR)/tests 11 | SRCDIR := $(HOMEDIR)/src 12 | TODIR := $(SRCDIR)/turnovers 13 | ################################################## 14 | # set path to mpfun f90 files 15 | MPDIR := $(HOMEDIR)/mpfun 16 | 17 | 18 | ################################################## 19 | # compiler 20 | ################################################## 21 | FC := gfortran 22 | # compiler flags 23 | FFLAGS := -O3 24 | # debugging flags 25 | # FFLAGS := -pg -g 26 | 27 | ################################################## 28 | # BLAS and LAPACK 29 | ################################################## 30 | # Set LIBS parameters for BLAS and LAPACK, e.g., 31 | LIBS := /usr/lib/lapack/liblapack.so.3gf /usr/lib/libblas.so.3gf -lm 32 | # LIBS := -llapack -lblas -lm 33 | # LIBS := /usr/lib/liblapack.so.3gf /usr/lib/libblas.so.3gf -lm 34 | 35 | -------------------------------------------------------------------------------- /deps/singleshift/src/buildbulge.f90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Aurentz² Mach³ Vandebril³ Watkins² 3 | ! 4 | ! ²Dept. Mathematics, Washington State University 5 | ! ³Dept. Computer Science, KU Leuven 6 | ! 7 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8 | ! Last modified 22 August 2014 9 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 10 | ! 11 | ! build initial bulge from shifts 12 | ! 13 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 14 | ! 15 | ! n problem size 16 | ! 17 | ! strt start index of current block 18 | ! 19 | ! bulge(3) (out) rotation, initial bulge 20 | ! 21 | ! shift complex shift 22 | ! 23 | ! Q,D,C,B generators of A 24 | ! 25 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 26 | subroutine buildbulge(n,strt,bulge,shift,Q,D,C,B) 27 | 28 | implicit none 29 | 30 | ! input variables 31 | integer, intent(in) :: n, strt 32 | double precision, intent(in) :: Q(3*n), D(2*n), C(3*n), B(3*n) 33 | complex(kind(1d0)), intent(in) :: shift 34 | double precision, intent(inout) :: bulge(3) 35 | 36 | ! compute variables 37 | complex(kind(1d0)) :: block(2,2) 38 | 39 | ! top block 40 | call diagblock(n,strt,block,Q,D,C,B) 41 | 42 | ! shift 43 | block(1,1) = block(1,1) - shift 44 | 45 | ! bulge 46 | call crgivens(block(1,1),block(2,1),bulge) 47 | 48 | end subroutine 49 | -------------------------------------------------------------------------------- /src/AMVW.jl: -------------------------------------------------------------------------------- 1 | if isdir(Pkg.dir("Polynomials")) 2 | using Polynomials 3 | end 4 | 5 | module AMVW 6 | 7 | const dpath = joinpath(Pkg.dir("AMVW"), "deps", "libamvwdouble") 8 | const spath = joinpath(Pkg.dir("AMVW"), "deps", "libamvwsingle") 9 | 10 | function rootsAMVW(a::Vector{Float64}) 11 | 12 | pl = reverse!(a[1:end - 1] ./ a[end]) 13 | np = length(pl) 14 | reigs = similar(pl) 15 | ieigs = similar(pl) 16 | its = Array(Int32, np) 17 | flag = Int32[0] 18 | 19 | ccall((:damvw_, dpath), Void, 20 | (Ptr{Int32}, Ptr{Float64}, Ptr{Float64}, Ptr{Float64}, Ptr{Int32}, Ptr{Int32}), 21 | &np, pl, reigs, ieigs, its, flag) 22 | 23 | if flag[1] != 0 error("error code: $(flag[1])") end 24 | return complex(reigs, ieigs) 25 | end 26 | 27 | function rootsAMVW(a::Vector{Complex{Float64}}) 28 | 29 | pl = reverse!(a[1:end - 1] ./ a[end]) 30 | plr = real(pl) 31 | pli = imag(pl) 32 | np = length(pl) 33 | reigs = similar(plr) 34 | ieigs = similar(plr) 35 | its = Array(Int32, np) 36 | flag = Int32[0] 37 | 38 | ccall((:zamvw_, spath), Void, 39 | (Ptr{Int32}, Ptr{Float64}, Ptr{Float64}, Ptr{Float64}, Ptr{Float64}, Ptr{Int32}, Ptr{Int32}), 40 | &np, plr, pli, reigs, ieigs, its, flag) 41 | 42 | if flag[1] != 0 error("error code: $(flag[1])") end 43 | return complex(reigs, ieigs) 44 | end 45 | 46 | # Promotion 47 | 48 | if isdir(Pkg.dir("Polynomials")) 49 | using Polynomials: Poly 50 | rootsAMVW(p::Union(Poly{Float64},Poly{Complex{Float64}})) = rootsAMVW(p.a) 51 | rootsAMVW{T<:Integer}(p::Poly{T}) = rootsAMVW(convert(Poly{Float64}, p)) 52 | end 53 | 54 | end -------------------------------------------------------------------------------- /deps/singleshift/src/modified_quadratic.f90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Aurentz² Mach³ Vandebril³ Watkins² 3 | ! 4 | ! ²Dept. Mathematics, Washington State University 5 | ! ³Dept. Computer Science, KU Leuven 6 | ! 7 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8 | ! Last modified 22 August 2014 9 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 10 | ! 11 | ! modified quadratic formula to compute eigenvalues 12 | ! of 2x2 matrix 13 | ! 14 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 15 | ! 16 | ! block(2,2) complex 2x2 matrix 17 | ! 18 | ! e1,e2 complex, eigenvalues of block 19 | ! 20 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 21 | subroutine modified_quadratic(BLOCK,e1,e2) 22 | 23 | implicit none 24 | 25 | ! input variables 26 | complex(kind(1d0)), intent(in) :: BLOCK(2,2) 27 | complex(kind(1d0)), intent(inout) :: e1, e2 28 | 29 | ! compute variables 30 | complex(kind(1d0)) :: trace, detm, disc 31 | 32 | ! compute intermediate values 33 | trace = BLOCK(1,1) + BLOCK(2,2) 34 | detm = BLOCK(1,1)*BLOCK(2,2) - BLOCK(2,1)*BLOCK(1,2) 35 | disc = zsqrt(trace*trace - 4d0*detm) 36 | 37 | ! compute e1 and e2 38 | if(zabs(trace+disc) > zabs(trace-disc))then 39 | if(zabs(trace+disc) == 0)then 40 | e1 = complex(0d0,0d0) 41 | e2 = complex(0d0,0d0) 42 | else 43 | e1 = (trace+disc)/complex(2d0,0d0) 44 | e2 = detm/e1 45 | end if 46 | else 47 | if(zabs(trace-disc) == 0)then 48 | e1 = complex(0d0,0d0) 49 | e2 = complex(0d0,0d0) 50 | else 51 | e1 = (trace-disc)/complex(2d0,0d0) 52 | e2 = detm/e1 53 | end if 54 | end if 55 | 56 | end subroutine 57 | -------------------------------------------------------------------------------- /deps/Makefile: -------------------------------------------------------------------------------- 1 | FC = gfortran 2 | ifeq ($(OS), Windows_NT) 3 | SLIB = dll 4 | else 5 | UNAME := $(shell uname) 6 | ifeq ($(UNAME), Darwin) 7 | SLIB = dylib 8 | else 9 | SLIB = so 10 | endif 11 | endif 12 | LBLAS = -lblas 13 | FFLAGS = -shared -fPIC -O3 14 | 15 | OBJD = doubleshift/src/DAMVW.f90 \ 16 | doubleshift/src/DCB.f90 \ 17 | doubleshift/src/DCDB.f90 \ 18 | doubleshift/src/DCFD.f90 \ 19 | doubleshift/src/DCFT.f90 \ 20 | doubleshift/src/DFCC.f90 \ 21 | doubleshift/src/DFGR.f90 \ 22 | doubleshift/src/DGR.f90 \ 23 | doubleshift/src/DMQF.f90 \ 24 | doubleshift/src/DNORMALPOLY.f90 \ 25 | doubleshift/src/DRANDPOLYJT.f90 \ 26 | doubleshift/src/RESCHECK.f90 \ 27 | doubleshift/src/balance.f90 \ 28 | doubleshift/src/init_random_seed.f90 \ 29 | doubleshift/src/turnovers/DGTO2.f90 30 | OBJS = singleshift/src/balance.f90 \ 31 | singleshift/src/buildbulge.f90 \ 32 | singleshift/src/chasebulge.f90 \ 33 | singleshift/src/cnormalpoly.f90 \ 34 | singleshift/src/crgivens.f90 \ 35 | singleshift/src/deflation.f90 \ 36 | singleshift/src/diagblock.f90 \ 37 | singleshift/src/factor.f90 \ 38 | singleshift/src/fuse.f90 \ 39 | singleshift/src/init_random_seed.f90 \ 40 | singleshift/src/modified_quadratic.f90 \ 41 | singleshift/src/normalpoly.f90 \ 42 | singleshift/src/rescheck.f90 \ 43 | singleshift/src/throughdiag.f90 \ 44 | singleshift/src/zamvw.f90 \ 45 | singleshift/src/zamvw2.f90 \ 46 | singleshift/src/turnovers/dto4.f90 47 | 48 | all: 49 | $(FC) $(FFLAGS) $(OBJD) -o libamvwdouble.$(SLIB) $(LBLAS) 50 | $(FC) $(FFLAGS) $(OBJS) -o libamvwsingle.$(SLIB) $(LBLAS) 51 | 52 | clean: 53 | rm *.$(SLIB) -------------------------------------------------------------------------------- /deps/doubleshift/src/DNORMALPOLY.f90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Aurentz² Mach³ Vandebril³ Watkins² 3 | ! 4 | ! ²Dept. Mathematics, Washington State University 5 | ! ³Dept. Computer Science, KU Leuven 6 | ! 7 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8 | ! Last modified 22 August 2014 9 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 10 | ! D Normally Distributed Polynomial 11 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 12 | ! 13 | ! This subroutine generates double precision, normally distributed 14 | ! coefficients for a monic polynomial of degree N. 15 | ! 16 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 17 | ! 18 | ! N degree of the polynomial 19 | ! 20 | ! POLY array containing coefficients of P(x), 21 | ! POLY = [a_N-1, ... , a_0] 22 | ! 23 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 24 | subroutine DNORMALPOLY(N,POLY) 25 | 26 | implicit none 27 | 28 | ! input variables 29 | integer, intent(in) :: N 30 | double precision, intent(inout) :: POLY(N) 31 | 32 | ! compute variables 33 | double precision :: u,v,s,pi = 3.141592653589793239d0 34 | integer :: ii,jj 35 | 36 | ! generate normally distributed numbers using Box-Muller 37 | do ii=1,N 38 | do jj=1,200 39 | 40 | call random_number(u) 41 | call random_number(v) 42 | 43 | s = u**2 + v**2 44 | 45 | if(s > 0d0 .and. s < 1d0)then 46 | POLY(ii) = dcos(2.d0*pi*v)*dsqrt(-2.d0*dlog(u)) 47 | exit 48 | end if 49 | end do 50 | 51 | end do 52 | 53 | 54 | end subroutine 55 | -------------------------------------------------------------------------------- /deps/singleshift/src/crgivens.f90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Aurentz² Mach³ Vandebril³ Watkins² 3 | ! 4 | ! ²Dept. Mathematics, Washington State University 5 | ! ³Dept. Computer Science, KU Leuven 6 | ! 7 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8 | ! Last modified 22 August 2014 9 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 10 | ! 11 | ! generates a rotation G zeroing b if applied to 12 | ! (a;b) 13 | ! 14 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 15 | ! 16 | ! a complex 17 | ! 18 | ! b complex 19 | ! 20 | ! G(3) rotation 21 | ! 22 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 23 | subroutine crgivens(a,b,G) 24 | 25 | implicit none 26 | 27 | ! input variables 28 | complex(kind(1d0)), intent(inout) :: a,b 29 | double precision, intent(inout) :: G(3) 30 | 31 | ! compute variables 32 | double precision :: t1r, t1i, t2r, t2i 33 | double precision :: nrm, T(2) 34 | complex(kind(1d0)) :: temp 35 | 36 | ! BLAS DNRM2 37 | double precision :: dnrm2 38 | 39 | ! check for 0 40 | nrm = abs(b) 41 | if(nrm == 0)then 42 | G(1) = 1d0 43 | G(2) = 0d0 44 | G(3) = 0d0 45 | return 46 | 47 | end if 48 | 49 | t2r = dble(b) 50 | t2i = dimag(b) 51 | nrm = abs(b) 52 | t2r = t2r/nrm 53 | t2i = t2i/nrm 54 | 55 | ! store nrm 56 | G(3) = nrm 57 | 58 | ! compute complex part 59 | G(1) = dble(a*complex(t2r,-t2i)) 60 | G(2) = dimag(a*complex(t2r,-t2i)) 61 | 62 | ! normalize 63 | nrm = dnrm2(3,G,1) 64 | G = G/nrm 65 | 66 | ! update a and b 67 | a = a*complex(G(1),-G(2)) + b*complex(G(3),0d0) 68 | b = complex(0d0,0d0) 69 | 70 | end subroutine 71 | -------------------------------------------------------------------------------- /deps/doubleshift/src/DCFD.f90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Aurentz² Mach³ Vandebril³ Watkins² 3 | ! 4 | ! ²Dept. Mathematics, Washington State University 5 | ! ³Dept. Computer Science, KU Leuven 6 | ! 7 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8 | ! Last modified 22 August 2014 9 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 10 | ! D Check For Deflation 11 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 12 | ! 13 | ! N size of problem 14 | ! 15 | ! strt start index of current block 16 | ! 17 | ! stp stop index of current block 18 | ! 19 | ! zero last zero above the current block 20 | ! 21 | ! QCB generators for A 22 | ! 23 | ! its number of iterations 24 | ! 25 | ! itcnt iteration counter 26 | ! 27 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 28 | subroutine DCFD(N,strt,stp,zero,QCB,its,itcnt) 29 | 30 | implicit none 31 | 32 | ! input variables 33 | integer, intent(in) :: N 34 | integer, intent(inout) :: strt, stp , zero, its(N), itcnt 35 | double precision, intent(inout) :: QCB(6*N) 36 | 37 | ! compute variables 38 | integer :: ii,ind 39 | double precision :: tol 40 | 41 | ! set tol 42 | tol = epsilon(1d0) 43 | 44 | ! loop for deflation 45 | do ii=1,stp 46 | ind = 6*(stp-ii) 47 | if(abs(QCB(ind+2)) < tol)then 48 | ! set sub-diagonal to 0 49 | QCB(ind+2) = 0d0 50 | QCB(ind+1) = QCB(ind+1)/abs(QCB(ind+1)) 51 | 52 | ! update indices 53 | zero = stp+1-ii 54 | strt = zero + 1 55 | 56 | ! store it_count 57 | ITS(zero) = itcnt 58 | itcnt = 0 59 | 60 | exit 61 | 62 | end if 63 | 64 | end do 65 | 66 | end subroutine 67 | -------------------------------------------------------------------------------- /deps/doubleshift/src/DFGR.f90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Aurentz² Mach³ Vandebril³ Watkins² 3 | ! 4 | ! ²Dept. Mathematics, Washington State University 5 | ! ³Dept. Computer Science, KU Leuven 6 | ! 7 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8 | ! Last modified 22 August 2014 9 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 10 | ! D Fuse Givens Rotations 11 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 12 | ! 13 | ! This subroutine fuses two givens rotations Q1, Q2 and stores the 14 | ! output in Q1 or Q2 depending on FTYPE 15 | ! 16 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 17 | ! 18 | ! FTYPE FTYPE = 0 if stored in Q1, FTYPE = 1 if stored in Q2 19 | ! 20 | ! Q1, Q2 generators for two givens rotations 21 | ! 22 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 23 | subroutine DFGR(FTYPE,Q1,Q2) 24 | 25 | implicit none 26 | 27 | ! input variables 28 | integer, intent(in) :: FTYPE 29 | double precision, intent(inout) :: Q1(2), Q2(2) 30 | 31 | ! compute variables 32 | double precision :: temp 33 | 34 | ! store in Q1 35 | if(FTYPE == 0)then 36 | ! compute new generators 37 | temp = Q1(1)*Q2(1) - Q1(2)*Q2(2) 38 | Q1(2) = Q1(2)*Q2(1) + Q1(1)*Q2(2) 39 | Q1(1) = temp 40 | 41 | ! enforce orthogonality 42 | !temp = dsqrt(Q1(1)**2 + Q1(2)**2) 43 | !Q1(1) = Q1(1)/temp 44 | !Q1(2) = Q1(2)/temp 45 | ! store in Q2 46 | else if(FTYPE == 1)then 47 | ! compute new generators 48 | temp = Q1(1)*Q2(1) - Q1(2)*Q2(2) 49 | Q2(2) = Q1(2)*Q2(1) + Q1(1)*Q2(2) 50 | Q2(1) = temp 51 | 52 | ! enforce orthogonality 53 | !temp = dsqrt(Q2(1)**2 + Q2(2)**2) 54 | !Q2(1) = Q2(1)/temp 55 | !Q2(2) = Q2(2)/temp 56 | ! bad input 57 | else 58 | print*, "Not a valid input for FTYPE!" 59 | return 60 | end if 61 | 62 | end subroutine 63 | -------------------------------------------------------------------------------- /deps/doubleshift/src/DRANDPOLYJT.f90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Aurentz² Mach³ Vandebril³ Watkins² 3 | ! 4 | ! ²Dept. Mathematics, Washington State University 5 | ! ³Dept. Computer Science, KU Leuven 6 | ! 7 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8 | ! Last modified 22 August 2014 9 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 10 | ! D RANDom POLYnomial following Jenkins Traub (iv) 11 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 12 | ! 13 | ! This subroutine generates random polynomial as 14 | ! (iv) in [Jenkins, Traub 1970]: 15 | ! 16 | ! "(iv) polynomials whose coefficients are chosen 17 | ! randomly by taking the mantissa and exponents 18 | ! from separate uniform distributions. The 19 | ! resulting polynomials have widely varying zeros 20 | ! and hence yield a reasonable test that the 21 | ! program has wide applications." 22 | ! 23 | ! [Jenkins, Traub 1970] M. A. Jenkins and J. F. 24 | ! Traub, Principles for testing polynomial 25 | ! zerofinding programs, ACM Transactions on 26 | ! Mathematical Software, 1 (1975), pp. 26–34. 27 | ! 28 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 29 | ! 30 | ! N degree of the polynomial 31 | ! 32 | ! POLY array coefficients of P(x), 33 | ! POLY = [a_N-1, ... , a_0] 34 | ! 35 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 36 | subroutine DRANDPOLYJT(N,POLY,R) 37 | 38 | implicit none 39 | 40 | ! input variables 41 | integer, intent(in) :: N 42 | double precision, intent(inout) :: POLY(N), R 43 | 44 | ! compute variables 45 | double precision :: u,v,s,pi = 3.141592653589793239d0 46 | integer :: ii,jj 47 | 48 | 49 | do ii=1,N 50 | 51 | call random_number(u) ! uniform distribution in [0,1) 52 | call random_number(v) ! uniform distribution in [0,1) 53 | 54 | POLY(ii) = (2d0*u-1d0) * 10**(2d0*R*v-R) 55 | 56 | end do 57 | 58 | 59 | end subroutine DRANDPOLYJT 60 | -------------------------------------------------------------------------------- /deps/singleshift/src/throughdiag.f90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Aurentz² Mach³ Vandebril³ Watkins² 3 | ! 4 | ! ²Dept. Mathematics, Washington State University 5 | ! ³Dept. Computer Science, KU Leuven 6 | ! 7 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8 | ! Last modified 22 August 2014 9 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 10 | ! 11 | ! pass rotation B through diagonal D 12 | ! 13 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 14 | ! 15 | ! n problem size 16 | ! 17 | ! k index of bulge 18 | ! 19 | ! 20 | ! D nx2 real matrix, generator of A, 21 | ! 22 | ! B(3) bulge to pass thru diagonal 23 | ! 24 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 25 | subroutine throughdiag(n,k,D,B) 26 | 27 | implicit none 28 | 29 | ! input variables 30 | integer, intent(in) :: n,k 31 | double precision, intent(inout) :: D(2*n+2), B(3) 32 | 33 | ! compute variables 34 | integer :: strt 35 | double precision :: c1r, c1i, s1 36 | double precision :: d1r, d1i 37 | double precision :: d2r, d2i 38 | double precision :: nrm 39 | double precision :: tol 40 | 41 | ! set tol 42 | tol = epsilon(1d0) 43 | 44 | ! set inputs 45 | c1r = B(1) 46 | c1i = B(2) 47 | s1 = B(3) 48 | 49 | ! retrieve D 50 | strt = 2*(k-1) 51 | d1r = D(strt+1) 52 | d1i = D(strt+2) 53 | d2r = D(strt+3) 54 | d2i = D(strt+4) 55 | 56 | ! pass through diagonal 57 | nrm = (d1r*d2r + d1i*d2i)*c1r - (-d1r*d2i + d1i*d2r)*c1i 58 | c1i = (d1r*d2r + d1i*d2i)*c1i + (-d1r*d2i + d1i*d2r)*c1r 59 | c1r = nrm 60 | 61 | ! renormalize 62 | nrm = c1r*c1r + c1i*c1i + s1*s1 63 | if(abs(nrm-1d0) > tol)then 64 | nrm = sqrt(nrm) 65 | c1r = c1r/nrm 66 | c1i = c1i/nrm 67 | s1 = s1/nrm 68 | end if 69 | 70 | ! set B 71 | B(1) = c1r 72 | B(2) = c1i 73 | B(3) = s1 74 | 75 | ! set D 76 | strt = 2*(k-1) 77 | D(strt+1) = d2r 78 | D(strt+2) = d2i 79 | D(strt+3) = d1r 80 | D(strt+4) = d1i 81 | 82 | end subroutine 83 | -------------------------------------------------------------------------------- /deps/doubleshift/src/DGR.f90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Aurentz² Mach³ Vandebril³ Watkins² 3 | ! 4 | ! ²Dept. Mathematics, Washington State University 5 | ! ³Dept. Computer Science, KU Leuven 6 | ! 7 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8 | ! Last modified 22 August 2014 9 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 10 | ! D Givens Rotation 11 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 12 | ! 13 | ! This subroutine computes c and s such that, 14 | ! 15 | ! -s*a + c*b = 0, |c|^2 + |s|^2 = 1, 16 | ! 17 | ! and 18 | ! 19 | ! r = sqrt(|a|^2 + |b|^2). 20 | ! 21 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 22 | ! 23 | ! a,b input coefficients 24 | ! 25 | ! c,s givens rotation generators 26 | ! 27 | ! r output norm 28 | ! 29 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 30 | subroutine DGR(a,b,c,s,r) 31 | 32 | implicit none 33 | 34 | ! input variables 35 | double precision, intent(in) :: a,b 36 | double precision, intent(inout) :: c,s,r 37 | 38 | ! tol to avoid unnecessary sqrt computations not implemented 39 | ! double precision :: tol 40 | ! set tol 41 | ! tol = epsilon(1d0) 42 | 43 | if (b == 0) then 44 | if (a<0) then 45 | c = -1d0 46 | s = 0d0 47 | r = -a 48 | else 49 | c = 1d0 50 | s = 0d0 51 | r = a 52 | endif 53 | else if (dabs(a) >= dabs(b)) then 54 | s = b/a 55 | r = dsqrt(1.d0 + s**2) 56 | if (a<0) then 57 | c = -1.d0/r 58 | s = s*c 59 | r = -a*r 60 | else 61 | c = 1.d0/r 62 | s = s*c 63 | r = a*r 64 | end if 65 | else 66 | c = a/b; 67 | r = dsqrt(1.d0 + c**2) 68 | if (b<0) then 69 | s = -1.d0/r 70 | c = c*s 71 | r = -b*r 72 | else 73 | s = 1.d0/r 74 | c = c*s 75 | r = b*r 76 | end if 77 | end if 78 | 79 | end subroutine 80 | -------------------------------------------------------------------------------- /deps/doubleshift/tests/backward.f95: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Aurentz² Mach³ Vandebril³ Watkins² 3 | ! 4 | ! ²Dept. Mathematics, Washington State University 5 | ! ³Dept. Computer Science, KU Leuven 6 | ! 7 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8 | ! Last modified 22 August 2014 9 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 10 | ! D Aurentz Mach Vandebril Watkins 11 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 12 | ! Compute coefficients from roots and check backward error 13 | ! only for polynomials with real coefficients! 14 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 15 | ! 16 | ! N degree of the polynomial 17 | ! 18 | ! POLY array containing coefficients of P(x), 19 | ! POLY = [a_N-1, ... , a_0] 20 | ! 21 | ! RROOTS array for real part of eigenvalues 22 | ! 23 | ! IROOTS array for imaginary part of eigenvalues 24 | ! 25 | ! POLY2 array with coefficients obtained from roots 26 | ! 27 | ! ERR array, absolute error |POLY(i)-POLY2(i)| 28 | ! 29 | ! RELERR array, relative error |POLY(i)-POLY2(i)|/|POLY(i)| 30 | ! 31 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 32 | 33 | subroutine backward(n, poly, rroots, iroots, poly2, err, relerr) 34 | 35 | use mpmodule 36 | implicit none 37 | 38 | !input variables 39 | integer, intent(in):: n 40 | !complex(kind(1d0)), intent(in) :: poly(n) 41 | double precision, intent(in) :: poly(n), rroots(n), iroots(n) 42 | !complex(kind(1d0)), intent(out) :: poly2(n) 43 | double precision, intent(inout) :: poly2(n), err(n), relerr(n) 44 | 45 | ! compute variables 46 | integer :: ii 47 | 48 | call rootstocoeffs(n, rroots, iroots, poly2) 49 | do ii=1,n 50 | err(ii)=abs(poly(ii)-poly2(ii)) 51 | relerr(ii)=err(ii)/abs(poly(ii)) 52 | end do 53 | 54 | print*, "poly", poly 55 | print*, "poly2", poly2 56 | 57 | 58 | print*, "abs err", err 59 | print*, "rel err", relerr 60 | 61 | 62 | end subroutine backward 63 | -------------------------------------------------------------------------------- /deps/doubleshift/tests/rootstocoeffs.f90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Last modified 22 August 2014 3 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 4 | ! 5 | ! Compute the real coefficients of a polynomial 6 | ! from its roots 7 | ! roots have to be real or in conj complex pairs 8 | ! 9 | ! uses MPFUN 10 | ! 11 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 12 | ! 13 | ! n (in) problem size 14 | ! 15 | ! rroots (in) real parts of the roots 16 | ! iroots (in) imag parts of the roots 17 | ! 18 | ! coeffs (out) real coefficients of the polynomial 19 | ! 20 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 21 | subroutine rootstocoeffs(n,rroots,iroots,coeffs) 22 | use mpmodule 23 | implicit none 24 | 25 | integer, intent(in):: n 26 | double precision, intent(in) :: rroots(n), iroots(n) 27 | double precision, intent(inout) :: coeffs(n) 28 | type (mp_real) :: rr(n), ir(n), c(n), alpha, beta, zero 29 | 30 | ! compute variables 31 | integer :: ii, jj 32 | 33 | ! convert to mp-type 34 | zero = 0.0d0 35 | do ii=1,n 36 | rr(ii) = rroots(ii) 37 | ir(ii) = iroots(ii) 38 | c(ii) = 0.0d0 39 | end do 40 | 41 | ii=1 42 | 43 | do while (ii .LE. n) 44 | if (ir(ii) .EQ. zero) then 45 | alpha = -rr(ii) 46 | do jj=ii,1,-1 47 | if (jj==1) then 48 | c(jj) = c(jj) + alpha*1d0 49 | else 50 | c(jj) = c(jj) + alpha*c(jj-1) 51 | end if 52 | end do 53 | ii=ii+1 54 | else 55 | alpha = - rr(ii)*2 56 | beta = rr(ii)**2 + ir(ii)**2 57 | do jj=ii+1,1,-1 58 | if (jj == 2) then 59 | c(jj) = c(jj) + alpha*c(jj-1) + beta 60 | elseif (jj == 1) then 61 | c(jj) = c(jj) + alpha 62 | else 63 | c(jj) = c(jj) + alpha*c(jj-1) + beta*c(jj-2) 64 | endif 65 | enddo 66 | ii=ii+2 67 | endif 68 | enddo 69 | 70 | 71 | ! convert to double precision 72 | do ii=1,n 73 | coeffs(ii) = c(ii) 74 | end do 75 | 76 | end subroutine rootstocoeffs 77 | -------------------------------------------------------------------------------- /deps/doubleshift/src/DMQF.f90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Aurentz² Mach³ Vandebril³ Watkins² 3 | ! 4 | ! ²Dept. Mathematics, Washington State University 5 | ! ³Dept. Computer Science, KU Leuven 6 | ! 7 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8 | ! Last modified 22 August 2014 9 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 10 | ! D Modified Quadratic Formula 11 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 12 | ! 13 | ! This subroutine computes the eigenvalues of a 2x2 matrix using the 14 | ! modified quadratic formula. 15 | ! 16 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 17 | ! 18 | ! BLOCK 2x2 block matrix 19 | ! 20 | ! re1, re2 real parts of eig1 and eig2 21 | ! 22 | ! ie1, rie2 imaginary parts of eig1 and eig2 23 | ! 24 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 25 | subroutine DMQF(BLOCK,re1,ie1,re2,ie2) 26 | 27 | implicit none 28 | 29 | ! input variables 30 | double precision, intent(in) :: BLOCK(2,2) 31 | double precision, intent(inout) :: re1, ie1, re2, ie2 32 | 33 | ! compute variables 34 | double precision :: trace, detm, disc 35 | 36 | ! compute intermediate values 37 | trace = BLOCK(1,1) + BLOCK(2,2) 38 | detm = BLOCK(1,1)*BLOCK(2,2) - BLOCK(2,1)*BLOCK(1,2) 39 | disc = trace*trace - 4d0*detm 40 | 41 | ! compute e1 and e2 42 | ! complex eigenvalues 43 | if(disc < 0)then 44 | re1 = trace/2d0 45 | ie1 = sqrt(-disc)/2d0 46 | re2 = re1 47 | ie2 = -ie1 48 | ! real eigenvalues 49 | else if(abs(trace+sqrt(disc)) > abs(trace-sqrt(disc)))then 50 | if(abs(trace+sqrt(disc)) == 0)then 51 | re1 = 0d0 52 | ie1 = 0d0 53 | re2 = 0d0 54 | ie2 = 0d0 55 | else 56 | re1 = (trace+sqrt(disc))/2d0 57 | ie1 = 0d0 58 | re2 = detm/re1 59 | ie2 = 0d0 60 | end if 61 | else 62 | if(abs(trace-sqrt(disc)) == 0)then 63 | re1 = 0d0 64 | ie1 = 0d0 65 | re2 = 0d0 66 | ie2 = 0d0 67 | else 68 | re1 = (trace-sqrt(disc))/2d0 69 | ie1 = 0d0 70 | re2 = detm/re1 71 | ie2 = 0d0 72 | end if 73 | end if 74 | 75 | end subroutine 76 | 77 | -------------------------------------------------------------------------------- /deps/singleshift/tests/rootstocoeffs.f90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Last modified 22 August 2014 3 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 4 | ! 5 | ! Compute the real coefficients of a polynomial 6 | ! from its roots 7 | ! roots have to be real or in conj complex pairs 8 | ! 9 | ! uses MPFUN 10 | ! 11 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 12 | ! 13 | ! n (in) problem size 14 | ! 15 | ! rroots (in) real parts of the roots 16 | ! iroots (in) imag parts of the roots 17 | ! 18 | ! coeffs (out) real coefficients of the polynomial 19 | ! 20 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 21 | subroutine rootstocoeffs(n,rroots,iroots,coeffs) 22 | use mpmodule 23 | implicit none 24 | 25 | integer, intent(in):: n 26 | double precision, intent(in) :: rroots(n), iroots(n) 27 | double precision, intent(inout) :: coeffs(n) 28 | type (mp_real) :: rr(n), ir(n), c(n), alpha, beta, zero 29 | 30 | ! compute variables 31 | integer :: ii, jj 32 | 33 | ! convert to mp-type 34 | zero = 0.0d0 35 | do ii=1,n 36 | rr(ii) = rroots(ii) 37 | ir(ii) = iroots(ii) 38 | c(ii) = 0.0d0 39 | end do 40 | 41 | ii=1 42 | 43 | do while (ii .LE. n) 44 | if (ir(ii) .EQ. zero) then 45 | alpha = -rr(ii) 46 | do jj=ii,1,-1 47 | if (jj==1) then 48 | c(jj) = c(jj) + alpha*1d0 49 | else 50 | c(jj) = c(jj) + alpha*c(jj-1) 51 | end if 52 | end do 53 | ii=ii+1 54 | else 55 | alpha = - rr(ii)*2 56 | beta = rr(ii)**2 + ir(ii)**2 57 | do jj=ii+1,1,-1 58 | if (jj == 2) then 59 | c(jj) = c(jj) + alpha*c(jj-1) + beta 60 | elseif (jj == 1) then 61 | c(jj) = c(jj) + alpha 62 | else 63 | c(jj) = c(jj) + alpha*c(jj-1) + beta*c(jj-2) 64 | endif 65 | enddo 66 | ii=ii+2 67 | endif 68 | enddo 69 | 70 | 71 | ! convert to double precision 72 | do ii=1,n 73 | coeffs(ii) = c(ii) 74 | end do 75 | 76 | end subroutine rootstocoeffs 77 | 78 | -------------------------------------------------------------------------------- /deps/doubleshift/src/DFCC.f90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Aurentz² Mach³ Vandebril³ Watkins² 3 | ! 4 | ! ²Dept. Mathematics, Washington State University 5 | ! ³Dept. Computer Science, KU Leuven 6 | ! 7 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8 | ! Last modified 22 August 2014 9 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 10 | ! D Factor Column Companion 11 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 12 | ! 13 | ! This subroutine computes a factorization of the column companion 14 | ! matrix for P(x), 15 | ! 16 | ! P(x) = x^N-1 + a_N-2 x^N-2 + ... + a_1 x + a_0. 17 | ! 18 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 19 | ! 20 | ! N-1 degree of the polynomial 21 | ! 22 | ! POLY array containing coefficients of P(x), 23 | ! POLY = [a_N-2, ... , a_0] 24 | ! 25 | ! QCB array of generators for A 26 | ! 27 | ! ALPHA parameter for balancing, currently not implemented 28 | ! 29 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 30 | subroutine DFCC(N,POLY,QCB,ALPHA) 31 | 32 | implicit none 33 | 34 | ! input variables 35 | integer, intent(in) :: N 36 | double precision, intent(inout) :: POLY(N) 37 | double precision, intent(inout) :: QCB(6*N) 38 | double precision, intent(out) :: ALPHA 39 | 40 | ! compute variables 41 | integer :: ii,strt 42 | double precision :: temp1,temp2 43 | 44 | ! balance parameter (currently not used) 45 | ALPHA = 1d0 46 | 47 | ! build Q 48 | QCB = 0d0 49 | do ii=1,N-1 50 | strt = 6*(ii-1) 51 | QCB(strt+2) = 1d0 52 | end do 53 | strt = 6*(N-1) 54 | QCB(strt+1) = 1d0 55 | 56 | ! build C and B 57 | strt = 6*(N-1)+2 58 | temp1 = dble((-1)**(N-1)) 59 | call DGR(dble((-1)**(N))*POLY(N),temp1,QCB(strt+1),QCB(strt+2),temp2) 60 | QCB(strt+3) = QCB(strt+2)*dble((-1)**(N)) 61 | QCB(strt+4) = QCB(strt+1)*dble((-1)**(N)) 62 | 63 | do ii=2,N 64 | strt = 6*(N-ii)+2 65 | temp1 = temp2 66 | call DGR(-POLY(ii-1),temp1,QCB(strt+1),QCB(strt+2),temp2) 67 | QCB(strt+3) = QCB(strt+1) 68 | QCB(strt+4) = -QCB(strt+2) 69 | end do 70 | 71 | end subroutine 72 | -------------------------------------------------------------------------------- /deps/doubleshift/src/DCFT.f90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Aurentz² Mach³ Vandebril³ Watkins² 3 | ! 4 | ! ²Dept. Mathematics, Washington State University 5 | ! ³Dept. Computer Science, KU Leuven 6 | ! 7 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8 | ! Last modified 22 August 2014 9 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 10 | ! D Compute First Transformation 11 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 12 | ! 13 | ! This subroutine computes the first two givens rotation to initialize 14 | ! the bulge chase. The shifts rho1 and rho2 are expected to be both 15 | ! real or a complex conjugate pair. 16 | ! 17 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 18 | ! 19 | ! N problem size 20 | ! 21 | ! str index for first relevant column of A 22 | ! 23 | ! Q,C,B generators for A 24 | ! 25 | ! rrho1, rrho2 real parts of shifts 26 | ! 27 | ! irho1, irho2 imaginary parts of shifts 28 | ! 29 | ! B1, B2 generators for the first two givens transforms 30 | ! 31 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 32 | subroutine DCFT(N,str,QCB,rrho1,irho1,rrho2,irho2,B1,B2) 33 | 34 | implicit none 35 | 36 | ! input variables 37 | integer, intent(in) :: N, str 38 | double precision, intent(in) :: QCB(6*N) 39 | double precision, intent(inout) :: B1(2), B2(2) 40 | double precision, intent(in) :: rrho1, irho1, rrho2, irho2 41 | 42 | ! compute variables 43 | double precision :: scrap, COL(3), scrap2 44 | double precision :: TEMP(3,2), T(3,2) 45 | 46 | ! compure first two columns of A 47 | TEMP = 0d0 48 | call DCDB(N,str,T,QCB) 49 | TEMP(1:2,1:2) = T(1:2,1:2) 50 | call DCDB(N,str+1,T,QCB) 51 | TEMP(3,2) = T(2,1) 52 | 53 | ! compute (A-rho1)(A-rho2)e_1 54 | COL(1) = TEMP(1,1)*TEMP(1,1) + TEMP(1,2)*TEMP(2,1) + rrho1*rrho2 - irho1*irho2 - TEMP(1,1)*(rrho1+rrho2) 55 | COL(2) = TEMP(2,1)*(TEMP(1,1)+TEMP(2,2)-(rrho1+rrho2)) 56 | COL(3) = TEMP(2,1)*TEMP(3,2) 57 | 58 | ! compute first two givens rotations 59 | call DGR(COL(2),COL(3),B1(1),B1(2),scrap) 60 | call DGR(COL(1),scrap,B2(1),B2(2),scrap2) 61 | 62 | end subroutine 63 | 64 | -------------------------------------------------------------------------------- /deps/doubleshift/src/balance.f90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Aurentz² Mach³ Vandebril³ Watkins² 3 | ! 4 | ! ²Dept. Mathematics, Washington State University 5 | ! ³Dept. Computer Science, KU Leuven 6 | ! 7 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8 | ! Last modified 22 August 2014 9 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 10 | ! 11 | ! Balancing of a real polynomial 12 | ! 13 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 14 | ! ! 15 | ! !! This is a simple balancing routine. !! ! 16 | ! !! Numerical experiments show that it !! ! 17 | ! !! is not always advantageous. Further !! ! 18 | ! research is necessary. ! 19 | ! !! Use with caution. !! ! 20 | ! ! 21 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 22 | ! 23 | ! N (in) problem size 24 | ! 25 | ! rcoeffs (in) real coefficients of the polynomial 26 | ! 27 | ! nnew (out) deflated problem size 28 | ! 29 | ! rnew (out) balanced coefficients 30 | ! 31 | ! alpha (out) balancing parameter 32 | ! 33 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 34 | subroutine balance(n,rcoeffs,nnew,rnew,alpha) 35 | 36 | implicit none 37 | 38 | ! input variables 39 | integer, intent(in) :: n 40 | double precision, intent(in) :: rcoeffs(n) 41 | integer, intent(inout) :: nnew 42 | double precision, intent(inout) :: rnew(n), alpha 43 | 44 | ! compute variables 45 | integer :: ii 46 | double precision :: nrm, a, b 47 | 48 | ! check size 49 | if(n < 3)then 50 | write(*,*) "n should be at least 3!" 51 | stop 52 | end if 53 | 54 | ! check for zeros 55 | nnew = 0 56 | do ii=1,n 57 | nrm = abs(rcoeffs(n+1-ii)) 58 | if(nrm /= 0)then 59 | nnew = n+1-ii 60 | exit 61 | end if 62 | end do 63 | 64 | ! check deflated size 65 | if(nnew == 0)then 66 | write(*,*) "enter a non-zero polynomial" 67 | stop 68 | end if 69 | 70 | ! compute balance factor 71 | nrm = abs(rcoeffs(nnew)) 72 | a = 1d0/dble(nnew) 73 | alpha = nrm**(a) 74 | a = 1d0/alpha 75 | b = a 76 | 77 | ! compute new coefficients 78 | do ii=1,nnew 79 | rnew(ii) = b*rcoeffs(ii) 80 | b = a*b 81 | end do 82 | print*, "balancing alpha", alpha 83 | 84 | end subroutine 85 | -------------------------------------------------------------------------------- /deps/singleshift/src/balance.f90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Aurentz² Mach³ Vandebril³ Watkins² 3 | ! 4 | ! ²Dept. Mathematics, Washington State University 5 | ! ³Dept. Computer Science, KU Leuven 6 | ! 7 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8 | ! Last modified 22 August 2014 9 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 10 | ! 11 | ! balance the coefficients of a complex polynomial 12 | ! simple scaling by p*(z) = p(alpha z) 13 | ! 14 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 15 | ! ! 16 | ! !! This is a simple balancing routine. !! ! 17 | ! !! Numerical experiments show that it !! ! 18 | ! !! is not always advantageous. Further !! ! 19 | ! research is necessary. ! 20 | ! !! Use with caution. !! ! 21 | ! ! 22 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 23 | ! 24 | ! n problem size 25 | ! 26 | ! rcoeffs real parts coefficients 27 | ! icoeffs imag parts coefficients 28 | ! 29 | ! nnew deflated problem size 30 | ! 31 | ! rnew real parts balanced coefficients 32 | ! inew imag parts balanced coefficients 33 | ! 34 | ! alpha scaling parameter 35 | ! 36 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 37 | subroutine balance(n,rcoeffs,icoeffs,nnew,rnew,inew,alpha) 38 | 39 | implicit none 40 | 41 | ! input variables 42 | integer, intent(in) :: n 43 | double precision, intent(in) :: rcoeffs(n), icoeffs(n) 44 | integer, intent(inout) :: nnew 45 | double precision, intent(inout) :: rnew(n), inew(n), alpha 46 | 47 | ! compute variables 48 | integer :: ii 49 | double precision :: nrm, a, b 50 | 51 | ! check size 52 | if(n < 3)then 53 | write(*,*) "n should be at least 3!" 54 | stop 55 | end if 56 | 57 | ! check for zeros 58 | nnew = 0 59 | do ii=1,n 60 | nrm = abs(complex(rcoeffs(n+1-ii),icoeffs(n+1-ii))) 61 | if(nrm /= 0)then 62 | nnew = n+1-ii 63 | exit 64 | end if 65 | end do 66 | 67 | ! check deflated size 68 | if(nnew == 0)then 69 | write(*,*) "enter a non-zero polynomial" 70 | return 71 | end if 72 | 73 | ! compute balance factor 74 | nrm = abs(complex(rcoeffs(nnew),icoeffs(nnew))) 75 | a = 1d0/dble(nnew) 76 | alpha = nrm**(a) 77 | a = 1d0/alpha 78 | b = a 79 | 80 | ! compute new coefficients 81 | do ii=1,nnew 82 | rnew(ii) = b*rcoeffs(ii) 83 | inew(ii) = b*icoeffs(ii) 84 | b = a*b 85 | end do 86 | print*, "balancing alpha", alpha 87 | 88 | end subroutine 89 | -------------------------------------------------------------------------------- /deps/singleshift/src/factor.f90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Aurentz² Mach³ Vandebril³ Watkins² 3 | ! 4 | ! ²Dept. Mathematics, Washington State University 5 | ! ³Dept. Computer Science, KU Leuven 6 | ! 7 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8 | ! Last modified 22 August 2014 9 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 10 | ! 11 | ! computes generators of Companion matrix of p 12 | ! 13 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 14 | ! 15 | ! n problem size 16 | ! 17 | ! rcoeffs, icoeffs ... coefficients of p: 18 | ! 19 | ! a_j = rcoeffs(j) + i*icoeffs(j) 20 | ! 21 | ! p(z) = z^n + a_1 z^{n-1} + a_2 z^(n-2} + ... + a_{n-1} z + a_n 22 | ! 23 | ! 24 | ! Q,D,C,B (out) generators of A 25 | ! 26 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 27 | 28 | subroutine factor(n,rcoeffs,icoeffs,Q,D,C,B) 29 | 30 | implicit none 31 | 32 | ! input variables 33 | integer, intent(in) :: n 34 | double precision, intent(in) :: rcoeffs(n), icoeffs(n) 35 | double precision, intent(inout) :: Q(3*n),D(2*(n+1)),C(3*n),B(3*n) 36 | 37 | ! compute variables 38 | integer :: ii,strt,stp 39 | complex(kind(1d0)) :: t1, t2 40 | double precision :: phr, phi, nrm 41 | 42 | ! check n 43 | if(n <= 2)then 44 | write(*,*) "In factor: n must be > 2!" 45 | stop 46 | end if 47 | 48 | ! set Q 49 | do ii=1,(n-1) 50 | Q(3*(ii-1) + 1) = 0d0 51 | Q(3*(ii-1) + 2) = 0d0 52 | Q(3*(ii-1) + 3) = 1d0 53 | end do 54 | Q(3*(n-1) + 1) = 1d0 55 | Q(3*(n-1) + 2) = 0d0 56 | Q(3*(n-1) + 3) = 0d0 57 | 58 | ! set D 59 | do ii=1,n+1 60 | D(2*(ii-1) + 1) = 1d0 61 | D(2*(ii-1) + 2) = 0d0 62 | end do 63 | 64 | ! initialize B and C 65 | t1 = complex((-1d0)**(n),0d0)*complex(rcoeffs(n),icoeffs(n)) 66 | t2 = complex((-1d0)**(n-1),0d0) 67 | strt = 3*(n-1) + 1 68 | stp = strt + 2 69 | call crgivens(t1,t2,C(strt:stp)) 70 | B(strt) = C(strt) 71 | B(strt+1) = -C(strt+1) 72 | B(strt+2) = -C(strt+2) 73 | 74 | do ii=2,n 75 | t2 = t1 76 | t1 = -complex(rcoeffs(ii-1),icoeffs(ii-1)) 77 | strt = 3*(n-ii) + 1 78 | stp = strt + 2 79 | call crgivens(t1,t2,C(strt:stp)) 80 | B(strt) = C(strt) 81 | B(strt+1) = -C(strt+1) 82 | B(strt+2) = -C(strt+2) 83 | 84 | end do 85 | 86 | ! B_n 87 | strt = 3*(n-1) + 1 88 | t1 = complex(B(strt),B(strt+1)) 89 | nrm = abs(t1) 90 | if(nrm == 0)then 91 | phr = 1d0 92 | phi = 0d0 93 | else 94 | phr = B(strt)/nrm 95 | phi = B(strt+1)/nrm 96 | end if 97 | B(strt) = -B(strt+2)*phr 98 | B(strt+1) = -B(strt+2)*phi 99 | B(strt+2) = nrm 100 | 101 | ! update D 102 | nrm = (-1d0)**(n) 103 | nrm = nrm/abs(nrm) 104 | D(2*(n) + 1) = nrm*phr 105 | D(2*(n) + 2) = nrm*phi 106 | D(2*(n-2) + 1) = nrm*phr 107 | D(2*(n-2) + 2) = -nrm*phi 108 | 109 | end subroutine 110 | -------------------------------------------------------------------------------- /deps/doubleshift/src/DCDB.f90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Aurentz² Mach³ Vandebril³ Watkins² 3 | ! 4 | ! ²Dept. Mathematics, Washington State University 5 | ! ³Dept. Computer Science, KU Leuven 6 | ! 7 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8 | ! Last modified 22 August 2014 9 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 10 | ! D Compute Diagonal Blocks 11 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 12 | ! 13 | ! This subroutine computes A(K:K+2,K:K+1) 14 | ! 15 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 16 | ! 17 | ! N size of problem 18 | ! 19 | ! K desired block index 20 | ! 21 | ! A storage location for A(K:K+1,K:K+1) 22 | ! 23 | ! QCB generators for A 24 | ! 25 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 26 | subroutine DCDB(N,K,A,QCB) 27 | 28 | implicit none 29 | 30 | ! input variables 31 | integer, intent(in) :: N, K 32 | double precision, intent(in) :: QCB(6*N) 33 | double precision, intent(inout) :: A(3,2) 34 | 35 | ! compute variables 36 | integer :: ii, ind 37 | double precision :: temp, R(3,2) 38 | 39 | ! initialize 40 | A = 0d0 41 | R = 0d0 42 | 43 | ! case K = 1 44 | if(K == 1)then 45 | 46 | ! first column of R 47 | R(1,1) = -QCB(6)/QCB(4) 48 | 49 | ! second column of R 50 | R(2,2) = -QCB(12)/QCB(10) 51 | R(1,2) = -(QCB(5)*QCB(11) - R(2,2)*QCB(3)*QCB(9))/QCB(4) 52 | 53 | ! A 54 | ! index for first Q 55 | ind = 6*(k) 56 | R(2,2) = QCB(ind+1)*R(2,2) 57 | 58 | ! index for second Q 59 | ind = 6*(k-1) 60 | A(1,1) = QCB(ind+1) 61 | A(2,1) = QCB(ind+2) 62 | A(1,2) = -QCB(ind+2) 63 | A(2,2) = QCB(ind+1) 64 | R(1:2,:) = matmul(A(1:2,1:2),R(1:2,:)) 65 | 66 | 67 | 68 | A(1:2,:) = R(1:2,:) 69 | 70 | ! other cases 71 | else 72 | 73 | ! first column of R 74 | ind = 6*(k-1) 75 | R(2,1) = -QCB(ind+6)/QCB(ind+4) 76 | R(1,1) = -(QCB(ind-1)*QCB(ind+5) - R(2,1)*QCB(ind-3)*QCB(ind+3))/QCB(ind-2) 77 | 78 | ! second column of R 79 | ind = 6*(k) 80 | R(3,2) = -QCB(ind+6)/QCB(ind+4) 81 | R(2,2) = -(QCB(ind-1)*QCB(ind+5) - R(3,2)*QCB(ind-3)*QCB(ind+3))/QCB(ind-2) 82 | R(1,2) = (QCB(ind-7)*QCB(ind)*QCB(ind+5) - QCB(ind-9)*(QCB(ind-3)*QCB(ind-1)*QCB(ind+5) & 83 | - QCB(ind+3)*R(3,2))/QCB(ind-2))/QCB(ind-8) 84 | 85 | ! A = QR 86 | ! index for first Q 87 | ind = 6*(k) 88 | R(3,2) = QCB(ind+1)*R(3,2) 89 | 90 | ! index for second Q 91 | ind = 6*(k-1) 92 | A(1,1) = QCB(ind+1) 93 | A(2,1) = QCB(ind+2) 94 | A(1,2) = -QCB(ind+2) 95 | A(2,2) = QCB(ind+1) 96 | R(2:3,:) = matmul(A(1:2,1:2),R(2:3,:)) 97 | 98 | ! index for third Q 99 | ind = 6*(k-2) 100 | A(1,1) = QCB(ind+1) 101 | A(2,1) = QCB(ind+2) 102 | A(1,2) = -QCB(ind+2) 103 | A(2,2) = QCB(ind+1) 104 | R(1:2,:) = matmul(A(1:2,1:2),R(1:2,:)) 105 | 106 | A(1:2,:) = R(2:3,:) 107 | 108 | end if 109 | 110 | end subroutine DCDB 111 | -------------------------------------------------------------------------------- /deps/singleshift/src/chasebulge.f90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Aurentz² Mach³ Vandebril³ Watkins² 3 | ! 4 | ! ²Dept. Mathematics, Washington State University 5 | ! ³Dept. Computer Science, KU Leuven 6 | ! 7 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8 | ! Last modified 22 August 2014 9 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 10 | ! 11 | ! chase bulge thru A 12 | ! 13 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 14 | ! 15 | ! n problem size 16 | ! 17 | ! strt start index of current block 18 | ! 19 | ! stp stop index of current block 20 | ! 21 | ! bulge(3) rotation, initial bulge 22 | ! 23 | ! Q,D,C,B generators of A 24 | ! 25 | ! tr first tr rotations in B are equal to C* 26 | ! 27 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 28 | subroutine chasebulge(n,strt,stp,bulge,Q,D,C,B,tr) 29 | 30 | implicit none 31 | 32 | ! input variables 33 | integer, intent(in) :: n, strt, stp 34 | double precision, intent(inout) :: Q(3*n), D(2*n+2), C(3*n), B(3*n) 35 | double precision, intent(inout) :: bulge(3) 36 | integer, intent(inout) :: tr 37 | 38 | ! compute variables 39 | integer :: ind1,ind2,ii,str,ll 40 | double precision :: binv(3) 41 | 42 | double precision :: T1(3), T2(3), T3(3), D1(4), error 43 | double precision :: Q2(6), D2(6), bulge2(3) 44 | 45 | ! bulge inverse 46 | binv(1) = bulge(1) 47 | binv(2) = -bulge(2) 48 | binv(3) = -bulge(3) 49 | 50 | ! fusion at top 51 | call fuse(n,strt,stp,Q,D,binv,1) 52 | 53 | ! main chasing loop 54 | do ii=strt,(stp-1) 55 | 56 | ! set indices for B and C 57 | ind1 = 3*(ii-1) + 1 58 | ind2 = ind1+2 59 | 60 | 61 | if (ii n-1)then 40 | write(*,*) 'k must be <= n-1 in diagblock' 41 | stop 42 | end if 43 | 44 | R = complex(0d0,0d0) 45 | 46 | ! case K = 1 47 | if(k == 1)then 48 | ! R 49 | R(1,1) = -complex(B(3)/C(3),0d0) 50 | R(2,2) = -complex(B(6)/C(6),0d0) 51 | R(1,2) = (complex(-B(1),B(2))*complex(B(4),B(5)) + R(2,2)*complex(C(1),C(2))*complex(C(4),-C(5)))/complex(C(3),0d0) 52 | 53 | ! diag 54 | R(1,:) = complex(D(1),D(2))*R(1,:) 55 | R(2,:) = complex(D(3),D(4))*R(2,:) 56 | 57 | ! block 58 | R(2,2) = complex(Q(4),Q(5))*R(2,2) 59 | 60 | block(1,1) = complex(Q(1),Q(2)) 61 | block(2,1) = complex(Q(3),0d0) 62 | block(1,2) = complex(-Q(3),0d0) 63 | block(2,2) = complex(Q(1),-Q(2)) 64 | 65 | block = matmul(block,R(1:2,1:2)) 66 | 67 | ! other cases 68 | else 69 | 70 | ! first column of R 71 | strt = 3*(k-1) + 1 72 | R(2,1) = complex(-B(strt+2)/C(strt+2),0d0) 73 | R(1,1) = (complex(-B(strt-3),B(strt-2))*complex(B(strt),B(strt+1)) & 74 | + R(2,1)*complex(C(strt-3),C(strt-2))*complex(C(strt),-C(strt+1)))/complex(C(strt-1),0d0) 75 | 76 | ! second column of R 77 | strt = 3*k + 1 78 | R(3,2) = complex(-B(strt+2)/C(strt+2),0d0) 79 | 80 | R(2,2) = (complex(-B(strt-3),B(strt-2))*complex(B(strt),B(strt+1)) & 81 | + R(3,2)*complex(C(strt-3),C(strt-2))*complex(C(strt),-C(strt+1)))/complex(C(strt-1),0d0) 82 | 83 | R(1,2) = (complex(B(strt-6),-B(strt-5))*complex(B(strt-1),0d0)*complex(B(strt),B(strt+1)) - & 84 | complex(C(strt-6),C(strt-5))/complex(C(strt-1),0d0)* & 85 | (complex(C(strt-3),-C(strt-2))*complex(B(strt-3),-B(strt-2))*complex(B(strt),B(strt+1)) - & 86 | complex(C(strt),-C(strt+1))*R(3,2)))/complex(C(strt-4),0d0) 87 | 88 | ! diag 89 | strt = 2*(k-1) + 1 90 | R(1,:) = complex(D(strt-2),D(strt-1))*R(1,:) 91 | R(2,:) = complex(D(strt),D(strt+1))*R(2,:) 92 | R(3,:) = complex(D(strt+2),D(strt+3))*R(3,:) 93 | 94 | ! start index for Q 95 | strt = 3*(k-1) + 1 96 | 97 | ! block 98 | R(3,2) = complex(Q(strt+3),Q(strt+4))*R(3,2) 99 | 100 | block(1,1) = complex(Q(strt),Q(strt+1)) 101 | block(2,1) = complex(Q(strt+2),0d0) 102 | block(1,2) = complex(-Q(strt+2),0d0) 103 | block(2,2) = complex(Q(strt),-Q(strt+1)) 104 | 105 | R(2:3,1:2) = matmul(block,R(2:3,1:2)) 106 | 107 | block(1,1) = complex(Q(strt-3),Q(strt-2)) 108 | block(2,1) = complex(Q(strt-1),0d0) 109 | block(1,2) = complex(-Q(strt-1),0d0) 110 | block(2,2) = complex(Q(strt-3),-Q(strt-2)) 111 | 112 | R(1:2,1:2) = matmul(block,R(1:2,1:2)) 113 | 114 | block = R(2:3,1:2) 115 | 116 | end if 117 | 118 | end subroutine 119 | -------------------------------------------------------------------------------- /deps/singleshift/src/deflation.f90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Aurentz² Mach³ Vandebril³ Watkins² 3 | ! 4 | ! ²Dept. Mathematics, Washington State University 5 | ! ³Dept. Computer Science, KU Leuven 6 | ! 7 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8 | ! Last modified 22 August 2014 9 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 10 | ! 11 | ! checks for deflations and deflates if possible 12 | ! 13 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 14 | ! 15 | ! n problem size 16 | ! 17 | ! strt start index of current block 18 | ! 19 | ! stp stop index of current block 20 | ! 21 | ! zero index of last zero above current block 22 | ! 23 | ! Q,D,C,B generators of A 24 | ! 25 | ! its, itcnt iteration counter 26 | ! 27 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 28 | subroutine deflation(n,strt,stp,zero,Q,D,C,B,its,itcnt) 29 | 30 | implicit none 31 | 32 | ! input variables 33 | integer, intent(in) :: n 34 | integer, intent(inout) :: strt, stp, zero, itcnt 35 | double precision, intent(inout) :: Q(3*n), D(2*n+2), C(3*n), B(3*n) 36 | integer, intent(inout) :: its(n) 37 | 38 | ! compute variables 39 | integer :: ii, ind1, ll, jj, k 40 | double precision :: tol, nrm 41 | double precision :: d1r, d1i, c1r, c1i, s 42 | 43 | ! set tolerance 44 | tol = 1d0*epsilon(1d0) 45 | 46 | ! check for deflation 47 | do ii=1,stp 48 | ind1 = 3*(stp-ii) 49 | 50 | nrm = abs(Q(ind1+3)) 51 | 52 | if(nrm < tol)then 53 | 54 | ! set sub-diagonal to 0 55 | Q(ind1+3) = 0d0 56 | 57 | ! update first diagonal 58 | c1r = Q(ind1+1) 59 | c1i = Q(ind1+2) 60 | Q(ind1+1) = 1d0 61 | Q(ind1+2) = 0d0 62 | 63 | ind1 = 2*(stp-ii) 64 | d1r = D(ind1+1) 65 | d1i = D(ind1+2) 66 | 67 | nrm = c1r*d1r - c1i*d1i 68 | d1i = c1r*d1i + c1i*d1r 69 | d1r = nrm 70 | nrm = d1r*d1r + d1i*d1i 71 | if(abs(nrm-1d0) > tol)then 72 | nrm = sqrt(nrm) 73 | d1r = d1r/nrm 74 | d1i = d1i/nrm 75 | end if 76 | 77 | D(ind1+1) = d1r 78 | D(ind1+2) = d1i 79 | 80 | ! 1x1 deflation 81 | if(ii == 1)then 82 | ! update second diagonal 83 | ind1 = 2*(stp-ii) 84 | d1r = D(ind1+3) 85 | d1i = D(ind1+4) 86 | 87 | nrm = c1r*d1r + c1i*d1i 88 | d1i = c1r*d1i - c1i*d1r 89 | d1r = nrm 90 | nrm = d1r*d1r + d1i*d1i 91 | if(abs(nrm-1d0) > tol)then 92 | nrm = sqrt(nrm) 93 | d1r = d1r/nrm 94 | d1i = d1i/nrm 95 | end if 96 | 97 | D(ind1+3) = d1r 98 | D(ind1+4) = d1i 99 | 100 | ! 2x2 or bigger 101 | else 102 | ! update Q 103 | do ll=(stp+1-ii),(stp-1) 104 | ind1 = 3*(ll) 105 | d1r = Q(ind1+1) 106 | d1i = Q(ind1+2) 107 | s = Q(ind1+3) 108 | 109 | nrm = c1r*d1r + c1i*d1i 110 | d1i = c1r*d1i - c1i*d1r 111 | d1r = nrm 112 | nrm = d1r*d1r + d1i*d1i + s*s 113 | if(abs(nrm-1d0) > tol)then 114 | nrm = sqrt(nrm) 115 | d1r = d1r/nrm 116 | d1i = d1i/nrm 117 | s = s/nrm 118 | end if 119 | 120 | Q(ind1+1) = d1r 121 | Q(ind1+2) = d1i 122 | Q(ind1+3) = s 123 | end do 124 | 125 | ! update second diagonal 126 | ind1 = 2*(stp) 127 | d1r = D(ind1+1) 128 | d1i = D(ind1+2) 129 | 130 | nrm = c1r*d1r + c1i*d1i 131 | d1i = c1r*d1i - c1i*d1r 132 | d1r = nrm 133 | nrm = d1r*d1r + d1i*d1i 134 | if(abs(nrm-1d0) > tol)then 135 | nrm = sqrt(nrm) 136 | d1r = d1r/nrm 137 | d1i = d1i/nrm 138 | end if 139 | 140 | D(ind1+1) = d1r 141 | D(ind1+2) = d1i 142 | end if 143 | 144 | ! update indices 145 | zero = stp+1-ii 146 | strt = zero + 1 147 | 148 | ! store it_count 149 | its(zero) = itcnt 150 | itcnt = 0 151 | 152 | 153 | exit 154 | end if 155 | end do 156 | 157 | end subroutine 158 | -------------------------------------------------------------------------------- /deps/singleshift/src/zamvw.f90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Aurentz² Mach³ Vandebril³ Watkins² 3 | ! 4 | ! ²Dept. Mathematics, Washington State University 5 | ! ³Dept. Computer Science, KU Leuven 6 | ! 7 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8 | ! Last modified 22 August 2014 9 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 10 | ! 11 | ! zamvw computes roots of a complex polynomial 12 | ! 13 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 14 | ! 15 | ! n problem size 16 | ! 17 | ! rcoeffs real parts polynomial coefficients 18 | ! icoeffs imag parts polynomial coefficients 19 | ! 20 | ! a_j = rcoeffs(j) + i*icoeffs(j) 21 | ! p(z) = z^n + a_1 z^{n-1} + a_2 z^(n-2} + ... + a_{n-1} z + a_n 22 | ! 23 | ! 24 | ! reigs real parts roots 25 | ! ieigs imag parts roots 26 | ! 27 | ! its array, no of iteration between subsequent deflation 28 | ! 29 | ! flag error flag 30 | ! 0 no error, all eigenvalues found 31 | ! k>0 QR algorithm did not converge, 32 | ! k eigenvalues are found (first k 33 | ! entries of reigs,ieigs) 34 | ! 35 | ! 36 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 37 | 38 | subroutine zamvw(n,rcoeffs,icoeffs,reigs,ieigs,its,flag) 39 | implicit none 40 | 41 | ! input variables 42 | integer, intent(in) :: n 43 | double precision, intent(in) :: rcoeffs(n), icoeffs(n) 44 | double precision, intent(inout) :: reigs(n), ieigs(n) 45 | integer, intent(inout) :: its(n), flag 46 | 47 | 48 | ! compute variables 49 | double precision :: Q(3*n),D(2*(n+1)),C(3*n),B(3*n) 50 | double precision :: nrm 51 | complex(kind(1d0)) :: trace, detm, disc, e1, e2 52 | integer :: ii, nnew, ry 53 | 54 | ! print*, "here" 55 | ry = flag 56 | flag = 0 57 | 58 | !print*, rcoeffs, icoeffs 59 | 60 | reigs = 0d0 61 | ieigs = 0d0 62 | 63 | ! check dimension 64 | if (n<=0) then 65 | flag = -1 66 | return 67 | end if 68 | 69 | 70 | do ii=1,n 71 | nrm = abs(complex(rcoeffs(n+1-ii),icoeffs(n+1-ii))) 72 | if(nrm /= 0)then 73 | nnew = n+1-ii 74 | exit 75 | end if 76 | end do 77 | 78 | if (nnew <= 0) then 79 | ! polynomial of zero coefficients, return zeros as roots 80 | flag = 0 81 | return 82 | end if 83 | 84 | 85 | if (nnew == 1) then 86 | ! it remains a polynomial of degree 1 87 | reigs(1) = -rcoeffs(1) 88 | ieigs(1) = -icoeffs(1) 89 | FLAG = 0 90 | return 91 | end if 92 | 93 | if (nnew == 2) then 94 | ! modified quadratic formula 95 | trace = -complex(rcoeffs(1),icoeffs(1)) 96 | detm = complex(rcoeffs(2),icoeffs(2)) 97 | disc = zsqrt(trace*trace - 4d0*detm) 98 | 99 | ! compute e1 and e2 100 | if(zabs(trace+disc) > zabs(trace-disc))then 101 | if(zabs(trace+disc) == 0)then 102 | reigs(1) = 0d0 103 | ieigs(1) = 0d0 104 | reigs(2) = 0d0 105 | ieigs(2) = 0d0 106 | else 107 | e1 = (trace+disc)/complex(2d0,0d0) 108 | e2 = detm/e1 109 | reigs(1) = dble(e1) 110 | ieigs(1) = imag(e1) 111 | reigs(2) = dble(e2) 112 | ieigs(2) = imag(e2) 113 | end if 114 | else 115 | if(zabs(trace-disc) == 0)then 116 | reigs(1) = 0d0 117 | ieigs(1) = 0d0 118 | reigs(2) = 0d0 119 | ieigs(2) = 0d0 120 | else 121 | e1 = (trace-disc)/complex(2d0,0d0) 122 | e2 = detm/e1 123 | reigs(1) = dble(e1) 124 | ieigs(1) = imag(e1) 125 | reigs(2) = dble(e2) 126 | ieigs(2) = imag(e2) 127 | end if 128 | end if 129 | flag = 0 130 | return 131 | end if 132 | 133 | call factor(n,rcoeffs,icoeffs,Q,D,C,B) 134 | call zamvw2(n,Q,D,C,B,reigs,ieigs,its,flag,n-1,ry) 135 | 136 | 137 | end subroutine zamvw 138 | -------------------------------------------------------------------------------- /deps/doubleshift/src/DCB.f90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Aurentz² Mach³ Vandebril³ Watkins² 3 | ! 4 | ! ²Dept. Mathematics, Washington State University 5 | ! ³Dept. Computer Science, KU Leuven 6 | ! 7 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8 | ! Last modified 22 August 2014 9 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 10 | ! D Chase Bulge 11 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 12 | ! 13 | ! This subroutine chases the bulge. 14 | ! 15 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 16 | ! 17 | ! N problem size 18 | ! 19 | ! str index for first relevant column of A 20 | ! 21 | ! stp index for last relevant block of A 22 | ! 23 | ! QCB generators for A 24 | ! 25 | ! WORK workspace to compute blocks 26 | ! 27 | ! B2,B3 generators for the first givens rotations 28 | ! 29 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 30 | subroutine DCB(N,str,stp,QCB,B1,B2,tr) 31 | 32 | implicit none 33 | 34 | ! input variables 35 | integer, intent(in) :: N, str, stp 36 | double precision, intent(inout) :: QCB(6*N), B1(2), B2(2) 37 | integer, intent(in) :: tr 38 | 39 | ! compute variables 40 | integer :: ii, jj, ind 41 | double precision :: TEMP(2), B3(2), B1b(2), B2b(2) 42 | 43 | ! starting at the top 44 | if(str == 1)then 45 | TEMP(1) = B2(1) 46 | TEMP(2) = -B2(2) 47 | B3(1) = B1(1) 48 | B3(2) = -B1(2) 49 | call DGTO2(TEMP,B3,QCB(1:2)) 50 | call DFGR(1,B3,QCB(7:8)) 51 | B3 = QCB(1:2) 52 | QCB(1:2) = TEMP 53 | 54 | ! otherwise 55 | else 56 | ind = 6*(str-1) 57 | TEMP(1) = B2(1) 58 | TEMP(2) = -QCB(ind-5)*B2(2) 59 | B3(1) = B1(1) 60 | B3(2) = -B1(2) 61 | call DGTO2(TEMP,B3,QCB((ind+1):(ind+2))) 62 | call DFGR(1,B3,QCB((ind+7):(ind+8))) 63 | B3 = QCB((ind+1):(ind+2)) 64 | QCB((ind+1):(ind+2)) = TEMP 65 | end if 66 | 67 | ! main chasing loop 68 | do ii=str,(stp-2) 69 | 70 | ! set ind 71 | ind = 6*(ii-1) 72 | 73 | 74 | if (ii tol)then 99 | nrm = sqrt(nrm) 100 | c2r = c2r/nrm 101 | c2i = c2i/nrm 102 | s2 = s2/nrm 103 | end if 104 | k = 3*(stp-1) 105 | Q(k+1) = c2r 106 | Q(k+2) = c2i 107 | Q(k+3) = s2 108 | 109 | ! update D 110 | c1r = phr*d1r - phi*d1i 111 | c1i = phr*d1i + phi*d1r 112 | nrm = c1r*c1r + c1i*c1i 113 | if(abs(nrm-1d0) > tol)then 114 | nrm = sqrt(nrm) 115 | c1r = c1r/nrm 116 | c1i = c1i/nrm 117 | end if 118 | c2r = phr*d2r + phi*d2i 119 | c2i = phr*d2i - phi*d2r 120 | nrm = c2r*c2r + c2i*c2i 121 | if(abs(nrm-1d0) > tol)then 122 | nrm = sqrt(nrm) 123 | c2r = c2r/nrm 124 | c2i = c2i/nrm 125 | end if 126 | k = 2*(stp-1) 127 | D(k+1) = c1r 128 | D(k+2) = c1i 129 | D(k+3) = c2r 130 | D(k+4) = c2i 131 | 132 | ! fusion from the left 133 | else 134 | ! retrieve Q 135 | k = 3*(strt-1) 136 | c1r = Q(k+1) 137 | c1i = Q(k+2) 138 | s1 = Q(k+3) 139 | 140 | ! retrieve D 141 | k = 2*(strt-1) 142 | d1r = D(k+1) 143 | d1i = D(k+2) 144 | k = 2*(stp) 145 | d2r = D(k+1) 146 | d2i = D(k+2) 147 | 148 | ! compute givens product 149 | c3r = c1r*c2r - c1i*c2i - s1*s2 150 | c3i = c1r*c2i + c1i*c2r 151 | s3r = s1*c2r + s2*c1r 152 | s3i = -(s1*c2i - s2*c1i) 153 | 154 | ! compute phase 155 | nrm = abs(complex(s3r,s3i)) 156 | if(nrm /= 0)then 157 | phr = s3r/nrm 158 | phi = s3i/nrm 159 | else 160 | phr = 1d0 161 | phi = 0d0 162 | end if 163 | 164 | ! update Q 165 | c2r = c3r*phr + c3i*phi 166 | c2i = -c3r*phi + c3i*phr 167 | s2 = nrm 168 | nrm = c2r*c2r + c2i*c2i + s2*s2 169 | if(abs(nrm-1d0) > tol)then 170 | nrm = sqrt(nrm) 171 | c2r = c2r/nrm 172 | c2i = c2i/nrm 173 | s2 = s2/nrm 174 | end if 175 | k = 3*(strt-1) 176 | Q(k+1) = c2r 177 | Q(k+2) = c2i 178 | Q(k+3) = s2 179 | 180 | do ii=(strt+1),stp 181 | k = 3*(ii-1) 182 | c1r = Q(k+1) 183 | c1i = Q(k+2) 184 | s1 = Q(k+3) 185 | nrm = c1r*phr + c1i*phi 186 | c1i = -c1r*phi + c1i*phr 187 | c1r = nrm 188 | nrm = c1r*c1r + c1i*c1i + s1*s1 189 | if(abs(nrm-1d0) > tol)then 190 | nrm = sqrt(nrm) 191 | c1r = c1r/nrm 192 | c1i = c1i/nrm 193 | s1 = s1/nrm 194 | end if 195 | Q(k+1) = c1r 196 | Q(k+2) = c1i 197 | Q(k+3) = s1 198 | end do 199 | 200 | ! update D 201 | c1r = phr*d1r - phi*d1i 202 | c1i = phr*d1i + phi*d1r 203 | nrm = c1r*c1r + c1i*c1i 204 | if(abs(nrm-1d0) > tol)then 205 | nrm = sqrt(nrm) 206 | c1r = c1r/nrm 207 | c1i = c1i/nrm 208 | end if 209 | c2r = phr*d2r + phi*d2i 210 | c2i = phr*d2i - phi*d2r 211 | nrm = c2r*c2r + c2i*c2i 212 | if(abs(nrm-1d0) > tol)then 213 | nrm = sqrt(nrm) 214 | c2r = c2r/nrm 215 | c2i = c2i/nrm 216 | end if 217 | k = 2*(strt-1) 218 | D(k+1) = c1r 219 | D(k+2) = c1i 220 | k = 2*(stp) 221 | D(k+1) = c2r 222 | D(k+2) = c2i 223 | 224 | end if 225 | 226 | end subroutine 227 | -------------------------------------------------------------------------------- /deps/doubleshift/tests/testDAMVW.f95: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Aurentz² Mach³ Vandebril³ Watkins² 3 | ! 4 | ! ²Dept. Mathematics, Washington State University 5 | ! ³Dept. Computer Science, KU Leuven 6 | ! 7 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8 | ! Last modified 22 August 2014 9 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 10 | ! 11 | ! Test program for random polynomials of given 12 | ! size 13 | ! 14 | ! The roots are computed by Francis's implicitly 15 | ! shifted QR algorithm via the Companion matrix. 16 | ! The rank-structure in the iterates is used. 17 | ! 18 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 19 | ! 20 | ! input parameter 21 | ! 22 | ! 1) problem size, default 4096 23 | ! 24 | ! 2) seed for random number generator, 25 | ! default random seed based on CPU clock, 26 | ! set fixed seed for reproducibility 27 | ! 28 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 29 | program testDAMVW 30 | 31 | implicit none 32 | 33 | ! input variables 34 | integer :: N, FLAG, NEWTNUM, rsize 35 | complex(kind(1d0)), allocatable :: COEFFS(:), ALLROOTS(:,:), ROOTS(:), WPOLY(:) 36 | double precision, allocatable :: POLY(:), REIGS(:), IEIGS(:), RESIDUALS(:,:) 37 | integer, allocatable :: ITS(:), seed(:) 38 | 39 | ! compute variables 40 | integer :: ii, noits, mri, mri1, mri2, mri3, kk 41 | integer :: clock_start, clock_end, clock_rate 42 | real :: time 43 | double precision :: rpart, ipart, temp, mr, mr1, mr2, mr3 44 | character(len=32) :: arg 45 | 46 | FLAG = 1 47 | if (iargc()>0) then 48 | if (iargc()>2) then 49 | FLAG=101 50 | end if 51 | call RANDOM_SEED(size = rsize) 52 | allocate(seed(rsize)) 53 | call RANDOM_SEED(GET = seed) 54 | 55 | !print*, iargc() 56 | !print*, arg 57 | if (iargc()>1) then 58 | call getarg(2, arg) 59 | print*, arg 60 | 61 | read (arg,'(I10)') ii 62 | !print*, seed 63 | seed(1) = ii 64 | seed(2) = ii+1000000 65 | seed(3) = ii+2100000 66 | seed(4) = ii+3210000 67 | seed(5) = ii+43210000 68 | seed(6) = ii+5432100 69 | seed(7) = ii+6543210 70 | seed(8) = ii+7654321 71 | seed(9) = ii+8765432 72 | seed(10) = ii+9876543 73 | seed(11) = ii+10987654 74 | seed(12) = ii+11109876 75 | call RANDOM_SEED(PUT = seed) 76 | else 77 | call init_random_seed() 78 | end if 79 | 80 | call getarg(1, arg) 81 | read (arg,'(I10)') kk 82 | else 83 | kk = 4096 84 | end if 85 | 86 | N = kk 87 | print*, N 88 | 89 | NEWTNUM = 1 90 | 91 | ! open (unit=7, file='poly.txt', status='unknown') 92 | ! read(7,*) N 93 | 94 | allocate(POLY(N),REIGS(N),IEIGS(N),ITS(N),COEFFS(1),ALLROOTS(N,NEWTNUM+1),RESIDUALS(N,3*(NEWTNUM+1))) 95 | allocate(WPOLY(N),ROOTS(N)) 96 | 97 | 98 | call DNORMALPOLY(N,POLY) 99 | 100 | ! roots of x^n - 1 = 0 101 | ! POLY=0d0 102 | ! POLY(N)=-1d0 103 | 104 | if (iargc()>1) then 105 | seed(1) = ii 106 | seed(2) = ii+1000000 107 | seed(3) = ii+2100000 108 | seed(4) = ii+3210000 109 | seed(5) = ii+43210000 110 | seed(6) = ii+5432100 111 | seed(7) = ii+6543210 112 | seed(8) = ii+7654321 113 | seed(9) = ii+8765432 114 | seed(10) = ii+9876543 115 | seed(11) = ii+10987654 116 | seed(12) = ii+11109876 117 | call RANDOM_SEED(PUT = seed) 118 | end if 119 | 120 | !open (unit=7, file='poly.txt', status='unknown') 121 | !write(7,*) N 122 | !do ii=1,N 123 | ! write(7,*) poly(ii) 124 | !end do 125 | !close(7) 126 | 127 | ! start timer 128 | CALL SYSTEM_CLOCK(COUNT_RATE=clock_rate) 129 | CALL SYSTEM_CLOCK(COUNT=clock_start) 130 | ! compute roots 131 | call DAMVW(N,POLY,REIGS,IEIGS,ITS,FLAG) 132 | 133 | do ii=1,N 134 | ROOTS(ii) = complex(REIGS(ii),IEIGS(ii)) 135 | WPOLY(ii) = complex(poly(ii),0d0) 136 | end do 137 | ! check roots 138 | call RESCHECK(0,N,0,NEWTNUM,WPOLY,COEFFS,ROOTS,ALLROOTS,RESIDUALS) 139 | ! stop timer 140 | CALL SYSTEM_CLOCK(COUNT=clock_end) 141 | time = real(clock_end - clock_start)/real(clock_rate) 142 | 143 | print*, "Residuals" 144 | temp = 0 145 | mr = 0.d0 146 | mr1 = 0.d0 147 | mr2 = 0.d0 148 | mr3 = 0.d0 149 | mri = 0 150 | mri1 = 0 151 | mri2 = 0 152 | mri3 = 0 153 | do ii=1,N 154 | temp = temp + abs(RESIDUALS(ii,1))**2 155 | if (RESIDUALS(ii,1)>mr) then 156 | mr3 = mr2 157 | mr2 = mr1 158 | mr1 = mr 159 | mr = RESIDUALS(ii,1) 160 | mri3 = mri2 161 | mri2 = mri1 162 | mri1 = mri 163 | mri = ii 164 | else if (RESIDUALS(ii,1)>mr1) then 165 | mr3 = mr2 166 | mr2 = mr1 167 | mr1 = RESIDUALS(ii,1) 168 | mri3 = mri2 169 | mri2 = mri1 170 | mri1 = ii 171 | else if (RESIDUALS(ii,1)>mr2) then 172 | mr3 = mr2 173 | mr2 = RESIDUALS(ii,1) 174 | mri3 = mri2 175 | mri2 = ii 176 | else if (RESIDUALS(ii,1)>mr3) then 177 | mr3 = RESIDUALS(ii,1) 178 | mri3 = ii 179 | end if 180 | end do 181 | print*, "" 182 | print*, "||Residual||_2 = ", dsqrt(temp) 183 | print*, "max(Residual) = ", mr, mr1, mr2, mr3 184 | print*, "imax(Residual) = ", mri, mri1, mri2, mri3 185 | 186 | print*, "its", its(n),its(n-1),its(n-2),its(n-3),its(n-4),its(n-5),its(n-6) 187 | print*, "its", its(n-7),its(n-8),its(n-9),its(n-10),its(n-11),its(n-12),its(n-13) 188 | 189 | print*, "#IT = ", noits 190 | print*, "#IT/N = ", real(noits)/real(N) 191 | 192 | print*, "N =",N 193 | print*,'Total time =', time, 'secs' 194 | 195 | 196 | if (N<=20) then 197 | do ii=1,N 198 | print*, REIGS(ii), IEIGS(ii) 199 | end do 200 | end if 201 | 202 | deallocate(POLY,REIGS,IEIGS,ITS,COEFFS,ALLROOTS,RESIDUALS,WPOLY,ROOTS); 203 | 204 | end program 205 | -------------------------------------------------------------------------------- /deps/doubleshift/src/turnovers/DGTO2.f90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Aurentz² Mach³ Vandebril³ Watkins² 3 | ! 4 | ! ²Dept. Mathematics, Washington State University 5 | ! ³Dept. Computer Science, KU Leuven 6 | ! 7 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8 | ! Last modified 22 August 2014 9 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 10 | ! D Givens Turn Over 11 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 12 | ! 13 | ! This subroutine passes the givens rotation Q3 from the left down 14 | ! through Q1 and Q2. 15 | ! 16 | ! It overwrites Q1, Q2 and Q3. 17 | ! 18 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 19 | ! 20 | ! Q1, Q2, Q3 generators for two givens rotations 21 | ! 22 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 23 | subroutine DGTO2(Q1,Q2,Q3) 24 | 25 | implicit none 26 | 27 | ! input variables 28 | double precision, intent(inout) :: Q1(2), Q2(2), Q3(2) 29 | 30 | ! compute variables 31 | double precision :: tol, nrm, T(3), dnrm2 32 | double precision :: a, b 33 | double precision :: c1, s1 34 | double precision :: c2, s2 35 | double precision :: c3, s3 36 | double precision :: c4, s4 37 | double precision :: c5, s5 38 | double precision :: c6, s6 39 | 40 | ! set tol 41 | tol = epsilon(1d0) 42 | 43 | ! set local variables 44 | c1 = Q1(1) 45 | s1 = Q1(2) 46 | c2 = Q2(1) 47 | s2 = Q2(2) 48 | c3 = Q3(1) 49 | s3 = Q3(2) 50 | 51 | ! initialize c4 and s4 52 | a = s1*c3 + c1*c2*s3 53 | b = s2*s3 54 | !nrm = a*a + b*b 55 | !if (abs(nrm-1d0)= abs(b)) then 155 | 156 | s = b/a 157 | r = sqrt(1.d0 + s*s) 158 | 159 | if (a<0) then 160 | c= -1.d0/r 161 | s= s*c 162 | r=-a*r 163 | else 164 | c = 1.d0/r 165 | s = s*c 166 | r = a*r 167 | end if 168 | 169 | else 170 | 171 | c = a/b; 172 | r = sqrt(1.d0 + c*c) 173 | 174 | if (b<0) then 175 | s =-1.d0/r 176 | c = c*s 177 | r =-b*r 178 | else 179 | s = 1.d0/r 180 | c = c*s 181 | r = b*r 182 | end if 183 | 184 | end if 185 | 186 | end subroutine rot1 187 | 188 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 189 | ! D Givens Rotation 190 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 191 | ! 192 | ! This subroutine computes a givens rotation G1 zeroing b 193 | ! 194 | ! [ c -s ] [ a ] = [ r ] 195 | ! [ s c ] [ b ] = [ 0 ] 196 | ! 197 | ! 198 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 199 | ! 200 | ! in 201 | ! a scalar 202 | ! b scalar 203 | ! 204 | ! out 205 | ! c cosine of rotation 206 | ! s sine of rotation 207 | ! 208 | ! Remark: Faster than rot1 since r is not computed. 209 | ! 210 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 211 | subroutine rot2(a,b,c,s) 212 | 213 | implicit none 214 | 215 | ! input variables 216 | double precision, intent(in) :: a,b 217 | double precision, intent(inout) :: c,s 218 | 219 | ! compute variables 220 | double precision :: r 221 | 222 | if (b == 0 .AND. a < 0) then 223 | c = -1d0 224 | s = 0d0 225 | 226 | else if (b == 0) then 227 | c = 1d0 228 | s = 0d0 229 | 230 | else if (abs(a) >= abs(b)) then 231 | 232 | s = b/a 233 | r = sqrt(1.d0 + s*s) 234 | 235 | if (a<0) then 236 | c= -1.d0/r 237 | s= s*c 238 | else 239 | c = 1.d0/r 240 | s = s*c 241 | end if 242 | 243 | else 244 | 245 | c = a/b; 246 | r = sqrt(1.d0 + c*c) 247 | 248 | if (b<0) then 249 | s =-1.d0/r 250 | c = c*s 251 | else 252 | s = 1.d0/r 253 | c = c*s 254 | end if 255 | 256 | end if 257 | 258 | end subroutine rot2 259 | -------------------------------------------------------------------------------- /deps/singleshift/tests/zamvw2test.f90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Aurentz² Mach³ Vandebril³ Watkins² 3 | ! 4 | ! ²Dept. Mathematics, Washington State University 5 | ! ³Dept. Computer Science, KU Leuven 6 | ! 7 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8 | ! Last modified 22 August 2014 9 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 10 | ! 11 | ! Test program for random polynomials with complex 12 | ! coefficients of given size 13 | ! 14 | ! The roots are computed by Francis's implicitly 15 | ! shifted QR algorithm via the Companion matrix. 16 | ! The rank-structure in the iterates is used. 17 | ! 18 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 19 | ! 20 | ! input parameter 21 | ! 22 | ! 1) problem size, default 4096 23 | ! 24 | ! 2) seed for random number generator, 25 | ! default random seed based on CPU clock, 26 | ! set fixed seed for reproducibility 27 | ! 28 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 29 | program blocktest 30 | 31 | implicit none 32 | 33 | ! compute variables 34 | integer :: n, nnew, ii, strt, newtnum 35 | integer, allocatable :: its(:), seed(:) 36 | double precision, allocatable :: Q(:),D(:),C(:),B(:) 37 | double precision, allocatable :: rcoeffs(:),icoeffs(:) 38 | double precision, allocatable :: rnew(:),inew(:) 39 | double precision, allocatable :: reigs(:),ieigs(:) 40 | complex(kind(1d0)), allocatable :: poly(:),eigs(:),allroots(:,:) 41 | double precision, allocatable ::residuals(:,:) 42 | complex(kind(1d0)) :: block(2,2),coeffs 43 | double precision :: time, error1, error2, alpha 44 | integer :: clock_start, clock_end, clock_rate, rsize, flag 45 | character(len=32) :: arg 46 | 47 | 48 | ! initial random seed 49 | ! call init_random_seed() 50 | 51 | if (iargc()>0) then 52 | call RANDOM_SEED(size = rsize) 53 | allocate(seed(rsize)) 54 | call RANDOM_SEED(GET = seed) 55 | 56 | print*, iargc() 57 | if (iargc()>1) then 58 | call getarg(2, arg) 59 | print*, arg 60 | 61 | read (arg,'(I10)') ii 62 | !print*, seed 63 | seed(1) = ii 64 | seed(2) = ii+1000000 65 | seed(3) = ii+2100000 66 | seed(4) = ii+3210000 67 | seed(5) = ii+43210000 68 | seed(6) = ii+5432100 69 | seed(7) = ii+6543210 70 | seed(8) = ii+7654321 71 | seed(9) = ii+8765432 72 | seed(10) = ii+9876543 73 | seed(11) = ii+10987654 74 | seed(12) = ii+11109876 75 | call RANDOM_SEED(PUT = seed) 76 | else 77 | print*, "random seed" 78 | call init_random_seed() 79 | end if 80 | 81 | call getarg(1, arg) 82 | read (arg,'(I10)') n 83 | else 84 | ! set degree 85 | n = 2**12 86 | end if 87 | 88 | 89 | ! set newtnum 90 | newtnum = 1 91 | 92 | ! allocate memory 93 | allocate(Q(3*n),D(2*n+2),C(3*n),B(3*n),rcoeffs(n),icoeffs(n)) 94 | allocate(rnew(n),inew(n)) 95 | allocate(its(n),reigs(n),ieigs(n)) 96 | allocate(poly(n),eigs(n),allroots(n,newtnum+1),residuals(n,3*(newtnum+1))) 97 | 98 | ! initialize arrays 99 | Q = 0d0 100 | D = 0d0 101 | C = 0d0 102 | B = 0d0 103 | rcoeffs = 0d0 104 | icoeffs = 0d0 105 | rnew = 0d0 106 | inew = 0d0 107 | its = 0 108 | reigs = 0d0 109 | ieigs = 0d0 110 | poly = complex(0d0,0d0) 111 | eigs = complex(0d0,0d0) 112 | allroots = complex(0d0,0d0) 113 | residuals = 0d0 114 | 115 | ! build random poly 116 | !call init_random_seed() 117 | call normalpoly(n,rcoeffs,icoeffs) 118 | ! rcoeffs = 0d0 119 | ! icoeffs = 0d0 120 | !icoeffs(n) = -1d0!/sqrt(2d0) 121 | ! rcoeffs(n) = -1d0!/sqrt(2d0) 122 | 123 | ! print poly 124 | ! print*,"poly" 125 | ! do ii=1,n 126 | ii = 1 127 | print*,rcoeffs(ii),icoeffs(ii) 128 | ! end do 129 | ! print*,"" 130 | 131 | ! balance 132 | call balance(n,rcoeffs,icoeffs,nnew,rnew,inew, alpha) 133 | print*,"alpha =",alpha 134 | print*,"" 135 | 136 | ! print poly 137 | ! print*,"poly" 138 | ! do ii=1,nnew 139 | ! print*,rnew(ii),inew(ii) 140 | ! end do 141 | ! print*,"" 142 | 143 | ! check new degree 144 | if(n /= nnew)then 145 | print*,"poly has trivial zeros" 146 | end if 147 | 148 | ! store in complex array 149 | do ii=1,nnew 150 | poly(ii) = complex(rcoeffs(ii),icoeffs(ii)) 151 | end do 152 | 153 | ! print random poly 154 | ! print*,"coeffs" 155 | ! do ii=1,n 156 | ! print*,rcoeffs(ii),icoeffs(ii) 157 | ! end do 158 | ! print*,"" 159 | 160 | ! start timer 161 | CALL SYSTEM_CLOCK(COUNT_RATE=clock_rate) 162 | CALL SYSTEM_CLOCK(COUNT=clock_start) 163 | ! factor companion matrix 164 | call factor(nnew,rnew,inew,Q,D,C,B) 165 | 166 | ! print*,"Q" 167 | ! do ii=1,n 168 | ! strt = 3*(ii-1) 169 | ! print*,Q(strt+1),Q(strt+2) 170 | ! print*,Q(strt+3),0d0 171 | ! print*,"" 172 | ! end do 173 | ! print*,"" 174 | 175 | ! print*,"D" 176 | ! do ii=1,n+1 177 | ! strt = 2*(ii-1) 178 | ! print*,D(strt+1),D(strt+2) 179 | ! print*,"" 180 | ! end do 181 | ! print*,"" 182 | 183 | ! print*,"C" 184 | ! do ii=1,n 185 | ! strt = 3*(ii-1) 186 | ! print*,C(strt+1),C(strt+2) 187 | ! print*,C(strt+3),0d0 188 | ! print*,"" 189 | ! end do 190 | ! print*,"" 191 | 192 | ! print*,"B" 193 | ! do ii=1,n 194 | ! strt = 3*(ii-1) 195 | ! print*,B(strt+1),B(strt+2) 196 | ! print*,B(strt+3),0d0 197 | ! print*,"" 198 | ! end do 199 | ! print*,"" 200 | 201 | ! store in complex array 202 | do ii=1,nnew 203 | poly(ii) = complex(rcoeffs(ii),icoeffs(ii)) 204 | end do 205 | 206 | ! start timer 207 | CALL SYSTEM_CLOCK(COUNT_RATE=clock_rate) 208 | CALL SYSTEM_CLOCK(COUNT=clock_start) 209 | ! factor companion matrix 210 | call factor(nnew,rnew,inew,Q,D,C,B) 211 | 212 | ! compute eigs 213 | call zamvw2(nnew,Q,D,C,B,reigs,ieigs,its,flag,nnew-1) 214 | 215 | ! store eigs in complex array 216 | do ii=1,n 217 | eigs(ii) = alpha*complex(reigs(ii),ieigs(ii)) 218 | end do 219 | 220 | ! compute residuals 221 | call rescheck(0,nnew,0,1,poly,coeffs,eigs,allroots,residuals) 222 | 223 | ! stop timer 224 | CALL SYSTEM_CLOCK(COUNT=clock_end) 225 | time = dble(clock_end - clock_start)/dble(clock_rate) 226 | print*, "n =",n 227 | print*,'Total time =', time, 'secs' 228 | 229 | ! compute worst error 230 | error1 = 0d0 231 | do ii=1,nnew 232 | if(residuals(ii,1) > error1)then 233 | error1 = residuals(ii,1) 234 | end if 235 | end do 236 | 237 | ! compute worst error 238 | error2 = 0d0 239 | do ii=1,nnew 240 | if(residuals(ii,4) > error2)then 241 | error2 = residuals(ii,4) 242 | end if 243 | end do 244 | 245 | ! print worst error 246 | print*,"worst error =",error1,error2 247 | print*,"" 248 | 249 | ! print residuals 250 | ! print*,"residuals,reigs,ieigs" 251 | ! do ii=1,n 252 | ! print*,residuals(ii,1:3),reigs(ii),ieigs(ii) 253 | ! end do 254 | ! print*,"" 255 | 256 | ! print output 257 | ! print*,"reigs,ieigs,its" 258 | ! do ii=1,n 259 | ! print*,reigs(ii),ieigs(ii),its(ii) 260 | ! end do 261 | ! print*,"" 262 | 263 | ! free memory 264 | deallocate(Q,D,C,B,rcoeffs,icoeffs) 265 | deallocate(its,reigs,ieigs) 266 | deallocate(poly,eigs,allroots,residuals) 267 | deallocate(rnew,inew) 268 | 269 | end program 270 | -------------------------------------------------------------------------------- /deps/singleshift/src/zamvw2.f90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Aurentz² Mach³ Vandebril³ Watkins² 3 | ! 4 | ! ²Dept. Mathematics, Washington State University 5 | ! ³Dept. Computer Science, KU Leuven 6 | ! 7 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8 | ! Last modified 22 August 2014 9 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 10 | ! 11 | ! zamvw runs Francis's implicity shifted QR 12 | ! algorithm on a factored form of the companion 13 | ! matrix, the rank structure in the upper 14 | ! triangular is exploited 15 | ! 16 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 17 | ! 18 | ! n problem size 19 | ! 20 | ! Q,D,C,B generators of A 21 | ! 22 | ! reigs (out) real parts of eigenvalues 23 | ! ieigs (out) imag parts of eigenvalues 24 | ! 25 | ! its (out) array, number of iteration 26 | ! between two subsequent deflations 27 | ! 28 | ! flag error flag 29 | ! 0 no error, all eigenvalues found 30 | ! k>0 QR algorithm did not converge, 31 | ! k eigenvalues are found (first k 32 | ! entries of reigs,ieigs) 33 | ! 34 | ! tr first tr rotations in B and C* are equal 35 | ! 36 | ! rayleigh 0 (default) Wilkinson shift 37 | ! 1 Rayleigh shift 38 | ! 39 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 40 | subroutine zamvw2(n,Q,D,C,B,reigs,ieigs,its,flag,tr,rayleigh) 41 | 42 | implicit none 43 | 44 | ! input variables 45 | integer, intent(in) :: n 46 | double precision, intent(inout) :: Q(3*n), D(2*n+2), C(3*n), B(3*n) 47 | double precision, intent(inout) :: reigs(n), ieigs(n) 48 | integer, intent(inout) :: its(n), flag 49 | integer, optional :: rayleigh 50 | integer, intent(inout) :: tr 51 | 52 | ! compute variables 53 | integer :: ii, jj, kk, ind1, ind2, ll, strt, k, ray, bc 54 | integer :: start_index, stop_index, zero_index, it_max, it_count 55 | double precision :: tol, nrm 56 | complex(kind(1d0)) :: shift, block(2,2), e1, e2 57 | double precision :: bulge(3), s1, s2 58 | 59 | flag = 0 60 | bc = 0 61 | 62 | ! rayleigh: 0 for Wilkinson shift, 1 for Rayleigh shift 63 | if (present(rayleigh)) then 64 | if (rayleigh .NE. 0) then 65 | ray = 1 66 | else 67 | ray = 0 68 | end if 69 | else 70 | ray = 0 71 | end if 72 | 73 | ! set tol 74 | tol = epsilon(1d0) 75 | 76 | ! check to make sure it's worth the effort 77 | if(n <= 2)then 78 | print*, "n =", n 79 | print*, "n should be atleast 3 to use this algorithm!" 80 | stop 81 | end if 82 | 83 | ! initialize storage 84 | its = 0 85 | 86 | ! initialize indices 87 | start_index = 1 88 | stop_index = n-1 89 | zero_index = 0 90 | it_max = 30*n 91 | it_count = 0 92 | 93 | ! loop for bulgechasing 94 | do kk=1,it_max 95 | ! check for completion 96 | if(stop_index <= 0)then 97 | !print*, "Algorithm is complete!" 98 | exit 99 | end if 100 | 101 | ! check for deflation 102 | call deflation(n,start_index,stop_index,zero_index,Q,D,C,B,its,it_count) 103 | 104 | ! if 1x1 block remove and check again 105 | if(stop_index == zero_index)then 106 | ! get 2x2 block 107 | call diagblock(n,stop_index,block,Q,D,C,B) 108 | 109 | ! zero at top 110 | if(stop_index == 1)then 111 | ! store the eigenvalue 112 | reigs(stop_index) = dble(block(1,1)) 113 | ieigs(stop_index) = dimag(block(1,1)) 114 | reigs(stop_index+1) = dble(block(2,2)) 115 | ieigs(stop_index+1) = dimag(block(2,2)) 116 | 117 | ! update stop_index 118 | stop_index = 0 119 | 120 | ! anywhere else 121 | else 122 | ! store the eigenvalue 123 | reigs(stop_index+1) = dble(block(2,2)) 124 | ieigs(stop_index+1) = dimag(block(2,2)) 125 | 126 | ! update indices 127 | stop_index = stop_index - 1 128 | zero_index = 0 129 | start_index = 1 130 | 131 | end if 132 | 133 | 134 | ! if 2x2 block remove and check again 135 | else if(stop_index-1 == zero_index)then 136 | ! get 2x2 block 137 | call diagblock(n,stop_index,block,Q,D,C,B) 138 | 139 | ! zero at top 140 | if(stop_index == 2)then 141 | ! store the eigenvalues 142 | call modified_quadratic(block,e1,e2) 143 | reigs(stop_index) = dble(e1) 144 | ieigs(stop_index) = dimag(e1) 145 | reigs(stop_index+1) = dble(e2) 146 | ieigs(stop_index+1) = dimag(e2) 147 | call diagblock(n,1,block,Q,D,C,B) 148 | reigs(1) = dble(block(1,1)) 149 | ieigs(1) = dimag(block(1,1)) 150 | 151 | ! update indices 152 | stop_index = 0 153 | !zero_index = 0 154 | !start_index = 0 155 | 156 | ! otherwise 157 | else 158 | ! store the eigenvalues 159 | call modified_quadratic(block,e1,e2) 160 | reigs(stop_index) = dble(e1) 161 | ieigs(stop_index) = dimag(e1) 162 | reigs(stop_index+1) = dble(e2) 163 | ieigs(stop_index+1) = dimag(e2) 164 | 165 | ! update indices 166 | stop_index = stop_index - 2 167 | zero_index = 0 168 | start_index = 1 169 | 170 | end if 171 | 172 | ! if greater than 2x2 chase a bulge and check again 173 | else 174 | 175 | ! it_count 176 | it_count = it_count + 1 177 | 178 | ! compute first transformation 179 | if(kk == 1)then 180 | call normalpoly(1,s1,s2) 181 | if (ray == 0) then 182 | shift = complex(s1,s2) 183 | else 184 | shift = complex(s1,0d0) 185 | end if 186 | else if(mod(it_count,15) == 0)then 187 | call normalpoly(1,s1,s2) 188 | if (ray == 0) then 189 | shift = complex(s1,s2) 190 | else 191 | shift = complex(s1,0d0) 192 | end if 193 | !print*, "Random shift!", shift 194 | else 195 | call diagblock(n,stop_index,block,Q,D,C,B) 196 | 197 | if (ray == 0) then 198 | call modified_quadratic(block,e1,e2) 199 | if(zabs(block(2,2)-e1) < zabs(block(2,2)-e2))then 200 | shift = e1 201 | else 202 | shift = e2 203 | end if 204 | else 205 | shift = block(2,2) 206 | end if 207 | end if 208 | 209 | ! build bulge 210 | call buildbulge(n,start_index,bulge,shift,Q,D,C,B) 211 | 212 | ! chase bulge 213 | call chasebulge(n,start_index,stop_index,bulge,Q,D,C,B,tr) 214 | bc = bc + 1 215 | tr = tr - 1 216 | 217 | end if 218 | end do 219 | 220 | if (kk>=it_max-1) then 221 | if (stop_index < N-1) then 222 | ! there some found eigenvalues, but not all have been found 223 | FLAG = N - 1 - stop_index 224 | print*, "QR algorithm did not converged within 30*N& 225 | & iterations, although FLAG = ", FLAG ,& 226 | & "eigenvalues have been found. This is a very rare case." 227 | print*, "Try to increase it_max & 228 | & or consider a bug-report to email:& 229 | & thomas.mach+zamvw.bugreport@gmail.com." 230 | do ii=1,FLAG 231 | reigs(ii) = reigs(stop_index+1+ii) 232 | ieigs(ii) = ieigs(stop_index+1+ii) 233 | reigs(stop_index+1+ii) = 0d0 234 | ieigs(stop_index+1+ii) = 0d0 235 | end do 236 | end if 237 | end if 238 | !print*, "Total number of bulgechases: ", bc 239 | end subroutine 240 | -------------------------------------------------------------------------------- /deps/singleshift/src/turnovers/dto4.f90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Aurentz² Mach³ Vandebril³ Watkins² 3 | ! 4 | ! ²Dept. Mathematics, Washington State University 5 | ! ³Dept. Computer Science, KU Leuven 6 | ! 7 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8 | ! Last modified 22 August 2014 9 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 10 | ! Computes Givens rotation turnover 11 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 12 | ! 13 | ! input/output 14 | ! G1, G2, B rotations given as 15 | ! cr + i*ci, s, with cr, ci, s \in R 16 | ! 17 | ! 18 | ! G1 B G1 19 | ! G1 G2 B => B G1 G2 20 | ! G2 B G2 21 | ! 22 | ! or 23 | ! G2 B G2 24 | ! G1 G2 B => B G1 G2 25 | ! G1 B G1 26 | ! 27 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 28 | subroutine dto4(G1,G2,B) 29 | 30 | implicit none 31 | 32 | ! input variables 33 | double precision, intent(inout) :: G1(3) 34 | double precision, intent(inout) :: G2(3) 35 | double precision, intent(inout) :: B(3) 36 | 37 | ! compute variables 38 | double precision :: nrm, tol, dnrm2, T(3) 39 | 40 | double precision :: c1r 41 | double precision :: c1i 42 | double precision :: s1 43 | double precision :: c2r 44 | double precision :: c2i 45 | double precision :: s2 46 | double precision :: c3r 47 | double precision :: c3i 48 | double precision :: s3 49 | 50 | double precision :: c4r 51 | double precision :: c4i 52 | double precision :: s4 53 | double precision :: c5r 54 | double precision :: c5i 55 | double precision :: s5 56 | double precision :: c6r 57 | double precision :: c6i 58 | double precision :: s6 59 | 60 | ! set tol 61 | tol = epsilon(1d0) 62 | !tol = 3e-14 63 | 64 | ! set local variables 65 | c1r = G1(1) 66 | c1i = G1(2) 67 | s1 = G1(3) 68 | c2r = G2(1) 69 | c2i = G2(2) 70 | s2 = G2(3) 71 | c3r = B(1) 72 | c3i = B(2) 73 | s3 = B(3) 74 | 75 | ! initialize c4r, c4i and s4 76 | T(1) = s1*c3r + (c1r*c2r + c1i*c2i)*s3 77 | T(2) = s1*c3i + (-c1i*c2r + c1r*c2i)*s3 78 | T(3) = s2*s3 79 | nrm = T(1)*T(1) + T(2)*T(2) + T(3)*T(3) 80 | if (dabs(nrm-1d0) nai)then 159 | ai = ai/ar 160 | nrm = sqrt(1d0 + ai*ai) 161 | if(ar < 0)then 162 | cr = -1d0/nrm 163 | ci = ai*cr 164 | s = 0d0 165 | nrm = -ar*nrm 166 | else 167 | cr = 1d0/nrm 168 | ci = ai*cr 169 | s = 0d0 170 | nrm = ar*nrm 171 | end if 172 | else if(nb == 0)then 173 | ar = ar/ai 174 | nrm = sqrt(1d0 + ar*ar) 175 | if(ai < 0)then 176 | ci = -1d0/nrm 177 | cr = ar*ci 178 | s = 0d0 179 | nrm = -ai*nrm 180 | else 181 | ci = 1d0/nrm 182 | cr = ar*ci 183 | s = 0d0 184 | nrm = ai*nrm 185 | end if 186 | else if(nar >= nb .AND. nar >= nai)then 187 | b = b/ar 188 | ai = ai/ar 189 | nrm = sqrt(1d0 + b*b + ai*ai) 190 | if(ar < 0)then 191 | cr = -1d0/nrm 192 | ci = ai*cr 193 | s = b*cr 194 | nrm = -ar*nrm 195 | else 196 | cr = 1d0/nrm 197 | ci = ai*cr 198 | s = b*cr 199 | nrm = ar*nrm 200 | end if 201 | else if(nai >= nb .AND. nai >= nar)then 202 | b = b/ai 203 | ar = ar/ai 204 | nrm = sqrt(1d0 + b*b + ar*ar) 205 | if(ai < 0)then 206 | ci = -1d0/nrm 207 | cr = ar*ci 208 | s = b*ci 209 | nrm = -ai*nrm 210 | else 211 | ci = 1d0/nrm 212 | cr = ar*ci 213 | s = b*ci 214 | nrm = ai*nrm 215 | end if 216 | else 217 | ar = ar/b 218 | ai = ai/b 219 | nrm = sqrt(1d0 + ai*ai + ar*ar) 220 | if(b < 0)then 221 | s = -1d0/nrm 222 | cr = ar*s 223 | ci = ai*s 224 | nrm = -b*nrm 225 | else 226 | s = 1d0/nrm 227 | cr = ar*s 228 | ci = ai*s 229 | nrm = b*nrm 230 | end if 231 | end if 232 | 233 | 234 | end subroutine rot3 235 | 236 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 237 | ! Compute Givens rotation zeroing b 238 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 239 | ! identical with rot3, but nrm is not computed 240 | ! => faster 241 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 242 | subroutine rot4(ar,ai,b,cr,ci,s) 243 | 244 | implicit none 245 | 246 | ! input variables 247 | double precision, intent(inout) :: ar, ai, b, cr, ci, s 248 | 249 | ! compute variables 250 | double precision :: nar, nai, nb, nrm, tol 251 | 252 | ! set tol 253 | tol = epsilon(1d0) 254 | 255 | ! set local variables 256 | nar = abs(ar) 257 | nai = abs(ai) 258 | nb = abs(b) 259 | 260 | if(nar == 0 .AND. nai == 0 .AND. nb == 0)then 261 | cr = 1d0 262 | ci = 0d0 263 | s = 0d0 264 | nrm = 0d0 265 | else if(nb == 0 .AND. nar > nai)then 266 | ai = ai/ar 267 | cr = 1d0/sqrt(1d0 + ai*ai) 268 | if(ar < 0)then 269 | cr = -cr 270 | end if 271 | ci = ai*cr 272 | s = 0d0 273 | else if(nb == 0)then 274 | ar = ar/ai 275 | ci = 1d0/sqrt(1d0 + ar*ar) 276 | if(ai < 0)then 277 | ci = -ci 278 | end if 279 | cr = ar*ci 280 | s = 0d0 281 | else if(nar >= nb .AND. nar >= nai)then 282 | b = b/ar 283 | ai = ai/ar 284 | cr = 1d0/sqrt(1d0 + b*b + ai*ai) 285 | if(ar < 0)then 286 | cr = -cr 287 | ! cr = -1d0/sqrt(1d0 + b*b + ai*ai) 288 | !else 289 | ! cr = 1d0/sqrt(1d0 + b*b + ai*ai) 290 | end if 291 | ci = ai*cr 292 | s = b*cr 293 | else if(nai >= nb .AND. nai >= nar)then 294 | b = b/ai 295 | ar = ar/ai 296 | ci = 1d0/sqrt(1d0 + b*b + ar*ar) 297 | if(ai < 0)then 298 | ci = -ci 299 | end if 300 | cr = ar*ci 301 | s = b*ci 302 | else 303 | ar = ar/b 304 | ai = ai/b 305 | s = 1.d0/sqrt(1d0 + ai*ai + ar*ar) 306 | if(b < 0)then 307 | s = -s 308 | end if 309 | cr = ar*s 310 | ci = ai*s 311 | end if 312 | 313 | 314 | end subroutine rot4 315 | -------------------------------------------------------------------------------- /deps/doubleshift/src/DAMVW.f90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Aurentz² Mach³ Vandebril³ Watkins² 3 | ! 4 | ! ²Dept. Mathematics, Washington State University 5 | ! ³Dept. Computer Science, KU Leuven 6 | ! 7 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8 | ! Last modified 22 August 2014 9 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 10 | ! D Aurentz Mach Vandebril Watkins 11 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 12 | ! Real Doubleshift Code 13 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 14 | ! 15 | ! This subroutine computes the eigenvalues of the companion matrix for P(x), 16 | ! 17 | ! P(x) = x^N + a_N-1 x^N-1 + ... + a_1 x + a_0, 18 | ! 19 | ! using a variant of Francis' real, doubleshift algorithm that 20 | ! exploits the rank-structure in the upper triangular part. 21 | ! 22 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 23 | ! 24 | ! N degree of the polynomial 25 | ! 26 | ! POLY array containing coefficients of P(x), 27 | ! POLY = [a_N-1, ... , a_0] 28 | ! 29 | ! REIGS array for real part of eigenvalues 30 | ! 31 | ! IEIGS array for imaginary part of eigenvalues 32 | ! 33 | ! ITS array for iteration counts 34 | ! 35 | ! FLAG flag for errors 36 | ! 37 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 38 | 39 | subroutine DAMVW(NP,POLY,REIGS,IEIGS,ITS,FLAG) 40 | 41 | implicit none 42 | 43 | ! input variables 44 | integer, intent(in) :: NP 45 | double precision, intent(in) :: POLY(NP) 46 | double precision, intent(inout) :: REIGS(NP), IEIGS(NP) 47 | integer, intent(inout) :: ITS(NP), FLAG 48 | 49 | ! compute variables 50 | integer :: ii, jj, kk, N, strt, nnew, tr 51 | integer :: start_index, stop_index, zero_index, it_max, it_count, chase_count 52 | double precision :: tol = 1d-16 53 | double precision :: scrap, num, temp(3,2), B1(2), B2(2), re1, ie1, re2, ie2 54 | double precision :: Q1(2), Q2(2), Q3(2) 55 | double precision, allocatable :: QCB(:) 56 | double precision :: ALPHA, nrm, trace, disc, detm 57 | 58 | FLAG = 0 59 | 60 | ! check to make sure it's worth the effort 61 | if(NP <= 0)then 62 | print*, "N =", NP 63 | print*, "N should be at least 3 to use this algorithm!" 64 | FLAG = -1 65 | return 66 | end if 67 | 68 | REIGS = 0d0 69 | IEIGS = 0d0 70 | 71 | ! check for deflatable zero coefficients 72 | N = NP 73 | nnew = 0 74 | do ii=1,n 75 | nrm = abs(POLY(N+1-ii)) 76 | if ( nrm /= 0) then 77 | nnew = n+1 - ii 78 | exit 79 | end if 80 | end do 81 | 82 | N = nnew 83 | !print*, N 84 | !print*, POLY 85 | if (N == 0) then 86 | ! all coefficients 0 => all roots 0 87 | FLAG = 0 88 | return 89 | end if 90 | if (N == 1) then 91 | ! it remains a polynomial of degree 1 92 | reigs(1) = -POLY(1) 93 | FLAG = 0 94 | return 95 | end if 96 | if (N == 2) then 97 | ! it remains a polynomial of degree 2 98 | ! use modified quadratic formula 99 | ! compute intermediate values 100 | trace = -POLY(1) 101 | detm = POLY(2) 102 | disc = trace*trace - 4d0*detm 103 | 104 | ! compute e1 and e2 105 | ! complex eigenvalues 106 | if(disc < 0)then 107 | reigs(1) = trace/2d0 108 | ieigs(1) = sqrt(-disc)/2d0 109 | reigs(2) = reigs(1) 110 | ieigs(2) = -ieigs(1) 111 | ! real eignevalues 112 | else if(abs(trace+sqrt(disc)) > abs(trace-sqrt(disc)))then 113 | if(abs(trace+sqrt(disc)) == 0)then 114 | reigs(1) = 0d0 115 | ieigs(1) = 0d0 116 | reigs(2) = 0d0 117 | ieigs(2) = 0d0 118 | else 119 | reigs(1) = (trace+sqrt(disc))/2d0 120 | ieigs(1) = 0d0 121 | reigs(2) = detm/reigs(1) 122 | ieigs(2) = 0d0 123 | end if 124 | else 125 | if(abs(trace-sqrt(disc)) == 0)then 126 | reigs(1) = 0d0 127 | ieigs(1) = 0d0 128 | reigs(2) = 0d0 129 | ieigs(2) = 0d0 130 | else 131 | reigs(1) = (trace-sqrt(disc))/2d0 132 | ieigs(1) = 0d0 133 | reigs(2) = detm/reigs(1) 134 | ieigs(2) = 0d0 135 | end if 136 | end if 137 | FLAG = 0 138 | return 139 | end if 140 | 141 | ! remaining polynomial has a degree larger than 2 142 | 143 | ! allocate memory 144 | allocate(QCB(6*N)) 145 | 146 | ! factor column companion matrix 147 | call DFCC(N,POLY,QCB,ALPHA) 148 | tr = n-2 149 | 150 | ! initialize storage 151 | ITS = 0 152 | REIGS = 0d0 153 | IEIGS = 0d0 154 | 155 | ! initialize indices 156 | start_index = 1 157 | stop_index = N-1 158 | zero_index = 0 159 | it_max = 30*N 160 | it_count = 0 161 | chase_count = 0 162 | 163 | ! loop for bulge chasing 164 | do kk=1,it_max 165 | 166 | ! check for completion 167 | if(stop_index <= 0)then 168 | !print*, "Algorithm is complete!" 169 | exit 170 | end if 171 | 172 | 173 | ! check for deflation 174 | call DCFD(N,start_index,stop_index,zero_index,QCB,its,it_count) 175 | 176 | ! if 1x1 block remove and check again 177 | if(stop_index == zero_index)then 178 | ! get 2x2 block 179 | call DCDB(N,stop_index,TEMP,QCB) 180 | 181 | ! zero at top 182 | if(stop_index == 1)then 183 | ! store the eigenvalue 184 | REIGS(stop_index) = TEMP(1,1) 185 | REIGS(stop_index+1) = TEMP(2,2) 186 | 187 | ! update stop_index 188 | stop_index = 0 189 | 190 | ! anywhere else 191 | else 192 | ! store the eigenvalue 193 | REIGS(stop_index+1) = TEMP(2,2) 194 | 195 | ! update indices 196 | stop_index = stop_index - 1 197 | zero_index = 0 198 | start_index = 1 199 | 200 | end if 201 | 202 | ! if 2x2 block remove and check again 203 | else if(stop_index-1 == zero_index)then 204 | ! get 2x2 block 205 | call DCDB(N,stop_index,TEMP,QCB) 206 | 207 | ! zero at top 208 | if(stop_index == 2)then 209 | ! store the eigenvalues 210 | call DMQF(TEMP(1:2,:),REIGS(stop_index),IEIGS(stop_index),REIGS(stop_index+1),IEIGS(stop_index+1)) 211 | call DCDB(N,1,TEMP,QCB) 212 | REIGS(1) = TEMP(1,1) 213 | 214 | ! update indices 215 | stop_index = stop_index - 2 216 | zero_index = 0 217 | start_index = 1 218 | 219 | ! otherwise 220 | else 221 | ! store the eigenvalues 222 | call DMQF(TEMP(1:2,:),REIGS(stop_index),IEIGS(stop_index),REIGS(stop_index+1),IEIGS(stop_index+1)) 223 | 224 | ! update indices 225 | stop_index = stop_index - 2 226 | zero_index = 0 227 | start_index = 1 228 | 229 | end if 230 | 231 | ! if greater than 2x2 chase a bulge and check again 232 | else 233 | 234 | ! it_count 235 | it_count = it_count + 1 236 | 237 | ! compute shifts 238 | if(kk == 1) then 239 | call DCDB(N,stop_index,TEMP,QCB) 240 | call DMQF(TEMP(1:2,:),re1,ie1,re2,ie2) 241 | elseif (mod(it_count,15) == 0)then 242 | call dnormalpoly(1,re1) 243 | call dnormalpoly(1,ie1) 244 | re2 = re1 245 | ie2 = -ie1 246 | !print*, "Random shift!" 247 | else 248 | call DCDB(N,stop_index,TEMP,QCB) 249 | call DMQF(TEMP(1:2,:),re1,ie1,re2,ie2) 250 | end if 251 | 252 | ! build bulge 253 | call DCFT(N,start_index,QCB,re1,ie1,re2,ie2,B1,B2) 254 | 255 | ! chase bulge 256 | chase_count = chase_count + 1 257 | call DCB(N,start_index,stop_index,QCB,B1,B2,tr) 258 | tr = tr - 2 259 | end if 260 | end do 261 | 262 | !print*, chase_count 263 | 264 | if (kk>=it_max-1) then 265 | if (stop_index < N-1) then 266 | ! some eigenvalues have been found, but not all of them 267 | ! this is a rare case 268 | FLAG = N - 1 - stop_index 269 | print*, "QR algorithm did not converged within 30*N& 270 | & iterations, although FLAG = ", FLAG ,& 271 | & "eigenvalues have been found.& 272 | & This is a very rare case." 273 | print*, "Try to increase it_max & 274 | & or consider a bug-report to email:& 275 | & thomas.mach+damvw.bugreport@gmail.com." 276 | do ii=1,FLAG 277 | reigs(ii) = reigs(stop_index+1+ii) 278 | ieigs(ii) = ieigs(stop_index+1+ii) 279 | reigs(stop_index+1+ii) = 0d0 280 | ieigs(stop_index+1+ii) = 0d0 281 | end do 282 | end if 283 | ! debugging 284 | 285 | !print*, kk 286 | !print*, it_max 287 | !print*, start_index, stop_index 288 | !print*, reigs 289 | !print*, ieigs 290 | 291 | !do ii=1,N-1 292 | !print*, "" 293 | ! print*, poly(ii) 294 | !end do 295 | !print*, "" 296 | end if 297 | 298 | ! free memory 299 | deallocate(QCB) 300 | 301 | 302 | end subroutine 303 | -------------------------------------------------------------------------------- /deps/doubleshift/tests/rootrace_jt.f95: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Aurentz² Mach³ Vandebril³ Watkins² 3 | ! 4 | ! ²Dept. Mathematics, Washington State University 5 | ! ³Dept. Computer Science, KU Leuven 6 | ! 7 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8 | ! Last modified 22 August 2014 9 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 10 | ! 11 | ! Rootrace 12 | ! 13 | ! comparing DAMVW with LAPACK's DHSEQR 14 | ! polynomials with random coefficients 15 | ! 16 | ! 17 | ! a * exp(b) 18 | ! a random uniform in [-1,1] 19 | ! b random uniform in [-R,R] 20 | ! 21 | ! R given as argument, default R=5 22 | ! 23 | !!!!!!!!!!!!!!!!!!!! 24 | ! 25 | ! Random polynomials chosen as (iv) in 26 | ! Jenkins, Traub 1970 27 | ! 28 | ! "(iv) polynomials whose coefficients are chosen 29 | ! randomly by taking the mantissa and exponents 30 | ! from seprate uniform distributions. The resulting 31 | ! polynomials have widely varying zeros and hence 32 | ! yield a reasonable test that the program has wide 33 | ! applications." 34 | ! 35 | ! [Jenkins, Traub 1970] M. A. Jenkins and J. F. 36 | ! Traub, Principles for testing polynomial 37 | ! zerofinding programs, ACM Transactions on 38 | ! Mathematical Software, 1 (1975), pp. 26–34. 39 | ! 40 | ! 41 | ! 42 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 43 | ! 44 | ! Remark: In the paper we include a comparison 45 | ! with CGXZ (and BBEGG). Since we cannot 46 | ! redistribute their code, these 47 | ! comparisons have been removed. 48 | ! 49 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 50 | program main 51 | 52 | implicit none 53 | 54 | double precision, allocatable :: poly(:),C(:,:),rroots(:),iroots(:),Z(:,:),work(:) 55 | double precision, allocatable :: res(:,:) 56 | complex(kind(1d0)), allocatable :: wpoly(:),wcoeffs(:,:),wroots(:),wallroots(:,:) 57 | integer, allocatable :: iterations(:) 58 | double precision :: time,error(6) 59 | 60 | integer :: ii,jj,kk,ll,mm,N,flag,info=0,R 61 | integer :: clock_start,clock_end,clock_rate 62 | integer :: Deg(22),num_trials(22), num_trials_error(22), lapack_trials 63 | character(len=32) :: arg 64 | ! set path 65 | character (len=*), parameter :: path = "./" 66 | 67 | open (unit=7, file=path//"degrees.txt", status='unknown', position="append") 68 | open (unit=8, file=path//"damvw_times.txt", status='unknown', position="append") 69 | open (unit=18, file=path//"damvw_errors.txt", status='unknown', position="append") 70 | open (unit=28, file=path//"fig_damvw_times.txt", status='unknown', position="append") 71 | open (unit=38, file=path//"fig_damvw_errors.txt", status='unknown', position="append") 72 | open (unit=11, file=path//"lapack_times.txt", status='unknown', position="append") 73 | open (unit=21, file=path//"lapack_errors.txt", status='unknown', position="append") 74 | open (unit=31, file=path//"fig_lapack_times.txt", status='unknown', position="append") 75 | open (unit=41, file=path//"fig_lapack_errors.txt", status='unknown', position="append") 76 | 77 | if (iargc()>0) then 78 | call getarg(1, arg) 79 | read (arg,'(I10)') R 80 | else 81 | R = 5d0 82 | end if 83 | 84 | ! the number of runs is for small polynomials higher 85 | ! => there are enough runs for small polynomials to 86 | ! get timings 87 | num_trials(1) = 2**(14) 88 | num_trials(2) = 2**(14) 89 | num_trials(3) = 2**(14) 90 | num_trials(4) = 2**(13) 91 | num_trials(5) = 2**(12) 92 | num_trials(6) = 2**(11) 93 | num_trials(7) = 2**(10) 94 | num_trials(8) = 2**(09) 95 | num_trials(9) = 2**(08) 96 | num_trials(10) = 2**(07) 97 | num_trials(11) = 2**(06) 98 | num_trials(12) = 2**(05) 99 | num_trials(13) = 2**(04) 100 | num_trials(14) = 2**(03) 101 | num_trials(15) = 2**(02) 102 | num_trials(16) = 2**(01) 103 | num_trials(17) = 2**(00) 104 | ! => errors depend on the number of runs! 105 | num_trials_error = 10 106 | 107 | Deg(1) = 6 108 | Deg(2) = 7 109 | Deg(3) = 8 110 | Deg(4) = 10 111 | Deg(5) = 12 112 | Deg(6) = 14 113 | Deg(7) = 16 114 | Deg(8) = 32 115 | Deg(9) = 64 116 | Deg(10) = 128 117 | Deg(11) = 256 118 | Deg(12) = 512 119 | Deg(13) = 1024 120 | Deg(14) = 2048 121 | ! LAPACK is turnoff for larger polynomials, see below 122 | Deg(15) = 4096 123 | Deg(16) = 8192 124 | Deg(17) = 16384 125 | 126 | do kk=1,17 127 | write (7,*) Deg(kk), num_trials(kk), R, "(iv)" 128 | end do 129 | close(7) 130 | 131 | call init_random_seed() 132 | 133 | 134 | write (28,*) "% JT, random polynomials, coefficients with uniform distribution for mant. and exp.", R 135 | write (38,*) "% JT, random polynomials, coefficients with uniform distribution for mant. and exp.", R 136 | write (31,*) "% JT, random polynomials, coefficients with uniform distribution for mant. and exp.", R 137 | write (41,*) "% JT, random polynomials, coefficients with uniform distribution for mant. and exp.", R 138 | 139 | write (28,*) "\addplot coordinates{ % AMVW" 140 | write (38,*) "\addplot coordinates{ % AMVW" 141 | 142 | write (31,*) "\addplot coordinates{ % LAPACK DHSEQR" 143 | write (41,*) "\addplot coordinates{ % LAPACK DHSEQR" 144 | 145 | 146 | do ll=1,17 147 | time = 0d0 148 | N = Deg(ll) 149 | write(*,*) "Current N =",N, num_trials(ll) 150 | 151 | 152 | if (num_trials(ll) > num_trials_error(ll)) then 153 | mm = num_trials(ll) 154 | else 155 | mm = num_trials_error(ll) 156 | end if 157 | 158 | allocate(poly(N*mm),iterations(N),res(N,6)) 159 | allocate(C(N,N),Z(N,N),work(N),rroots(N),iroots(N)) 160 | allocate(wpoly(N),wcoeffs(N,1),wroots(N),wallroots(N,2)) 161 | 162 | do ii=1,N 163 | wcoeffs(ii,1) = complex(1d0,0d0) 164 | end do 165 | 166 | error = 0d0 167 | 168 | call drandpolyjt(N*mm,poly(1:mm),R) 169 | 170 | ! DAMVW 171 | 172 | write(*,*) "DAMVW" 173 | CALL SYSTEM_CLOCK(COUNT_RATE=clock_rate) 174 | CALL SYSTEM_CLOCK(COUNT=clock_start) 175 | 176 | do ii=1,num_trials(ll) 177 | call DAMVW(N,poly((ii-1)*N+1:ii*N),rroots,iroots,ITERATIONS,FLAG) 178 | end do 179 | 180 | CALL SYSTEM_CLOCK(COUNT=clock_end) 181 | time = dble(clock_end - clock_start)/dble(clock_rate) 182 | time = time/dble(num_trials(ll)) 183 | 184 | do ii=1,num_trials_error(ll) 185 | call DAMVW(N,poly((ii-1)*N+1:ii*N),rroots,iroots,ITERATIONS,FLAG) 186 | 187 | do jj=1,N 188 | wpoly(jj) = complex(poly((ii-1)*N+jj),0d0) 189 | wroots(jj) = complex(rroots(jj),iroots(jj)) 190 | end do 191 | 192 | call RESCHECK(0,N,0,1,wpoly,wcoeffs,wroots,wallroots,res) 193 | 194 | do jj=1,6 195 | do kk=1,N 196 | if(res(kk,jj) > error(jj))then 197 | error(jj) = res(kk,jj) 198 | end if 199 | end do 200 | end do 201 | end do 202 | 203 | 204 | write (8,*) time 205 | print*, time 206 | write (18,*) error(:) 207 | 208 | write(*,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 209 | & time, ")%" 210 | write(28,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 211 | & time, ")%" 212 | 213 | write(*,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 214 | & error(1), ")%" 215 | write(38,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 216 | & error(1), ")%" 217 | 218 | if (ll == 15) then 219 | write(28,"(A,1x,F6.3,1x,A,1x,I7,1x,A,1x,ES10.4E2,1x,A)"), & 220 | &"%\node[coordinate,pin=below:{AMVW:", time,& 221 | &"}] at (axis cs:",deg(ll),",",time,"){};" 222 | write(*,"(A,1x,F6.3,1x,A,1x,I7,1x,A,1x,ES10.4E2,1x,A)"), & 223 | &"%\node[coordinate,pin=below:{AMVW:", time,& 224 | &"}] at (axis cs:",deg(ll),",",time,"){};" 225 | end if 226 | 227 | 228 | ! LAPACK 229 | if (ll<=14) then 230 | write(*,*) "LAPACK" 231 | error = 0d0 232 | res = 0d0 233 | 234 | CALL SYSTEM_CLOCK(COUNT_RATE=clock_rate) 235 | CALL SYSTEM_CLOCK(COUNT=clock_start) 236 | 237 | do ii=1,num_trials(ll) 238 | 239 | C = 0d0 240 | C(1,:) = -poly((ii-1)*N+1:ii*N) 241 | do kk=1,(N-1) 242 | C(kk+1,kk) = 1.d0 243 | end do 244 | 245 | call DHSEQR('E','N',N,1,N,C,N,rroots,iroots,Z,N,work,N,info) 246 | 247 | end do 248 | 249 | CALL SYSTEM_CLOCK(COUNT=clock_end) 250 | time = dble(clock_end - clock_start)/dble(clock_rate) 251 | time = time/dble(num_trials(ll)) 252 | 253 | do ii=1,num_trials_error(ll) 254 | 255 | C = 0d0 256 | C(1,:) = -poly((ii-1)*N+1:ii*N) 257 | do kk=1,(N-1) 258 | C(kk+1,kk) = 1.d0 259 | end do 260 | 261 | call DHSEQR('E','N',N,1,N,C,N,rroots,iroots,Z,N,work,N,info) 262 | 263 | do jj=1,N 264 | wpoly(jj) = complex(poly((ii-1)*N+jj),0d0) 265 | wroots(jj) = complex(rroots(jj),iroots(jj)) 266 | end do 267 | 268 | call RESCHECK(0,N,0,1,wpoly,wcoeffs,wroots,wallroots,res) 269 | 270 | do jj=1,6 271 | do kk=1,N 272 | if(res(kk,jj) > error(jj))then 273 | error(jj) = res(kk,jj) 274 | end if 275 | end do 276 | end do 277 | 278 | end do 279 | write (11,*) time 280 | print*, time 281 | write (21,*) error(:) 282 | 283 | write(*,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 284 | & time, ")%" 285 | write(31,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 286 | & time, ")%" 287 | 288 | write(*,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 289 | & error(1), ")%" 290 | write(41,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 291 | & error(1), ")%" 292 | end if 293 | 294 | deallocate(poly,iterations,res) 295 | deallocate(C,Z,work,rroots,iroots) 296 | deallocate(wpoly,wcoeffs,wroots,wallroots) 297 | 298 | end do 299 | 300 | write (28,*) "};" 301 | write (38,*) "};" 302 | write (31,*) "};" 303 | write (41,*) "};" 304 | 305 | write (28,*) "" 306 | write (38,*) "" 307 | write (31,*) "" 308 | write (41,*) "" 309 | 310 | close(8) 311 | close(18) 312 | close(28) 313 | close(38) 314 | close(11) 315 | close(21) 316 | close(31) 317 | close(41) 318 | 319 | end program main 320 | -------------------------------------------------------------------------------- /deps/singleshift/tests/rootrace_jt.f95: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Aurentz² Mach³ Vandebril³ Watkins² 3 | ! 4 | ! ²Dept. Mathematics, Washington State University 5 | ! ³Dept. Computer Science, KU Leuven 6 | ! 7 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8 | ! Last modified 22 August 2014 9 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 10 | ! 11 | ! Rootrace 12 | ! 13 | ! comparing DAMVW with LAPACK's DHSEQR 14 | ! polynomials with random coefficients 15 | ! 16 | ! 17 | ! a * exp(b) 18 | ! a random uniform in [-1,1] 19 | ! b random uniform in [-R,R] 20 | ! 21 | ! R given as argument, default R=5 22 | ! 23 | !!!!!!!!!!!!!!!!!!!! 24 | ! 25 | ! Random polynomials chosen as (iv) in 26 | ! Jenkins, Traub 1970 27 | ! 28 | ! "(iv) polynomials whose coefficients are chosen 29 | ! randomly by taking the mantissa and exponents 30 | ! from seprate uniform distributions. The resulting 31 | ! polynomials have widely varying zeros and hence 32 | ! yield a reasonable test that the program has wide 33 | ! applications." 34 | ! 35 | ! [Jenkins, Traub 1970] M. A. Jenkins and J. F. 36 | ! Traub, Principles for testing polynomial 37 | ! zerofinding programs, ACM Transactions on 38 | ! Mathematical Software, 1 (1975), pp. 26–34. 39 | ! 40 | ! 41 | ! 42 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 43 | ! 44 | ! Remark: In the paper we include a comparison 45 | ! with BBEGG and BEGG. Since we cannot 46 | ! distribute their code, these 47 | ! comparisons have been removed. 48 | ! 49 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 50 | program main 51 | 52 | implicit none 53 | 54 | complex(kind(1d0)), allocatable :: poly(:),roots(:),allroots(:,:) 55 | complex(kind(1d0)), allocatable :: B(:,:),Y(:,:),cwork(:) 56 | integer, allocatable :: iterations(:),its(:) 57 | double precision, allocatable :: res(:,:) 58 | double precision :: time,begg_time,lapack_time,pdble,error(6) 59 | double precision, allocatable :: Q(:),D(:),C(:),B2(:) 60 | double precision, allocatable :: rcoeffs(:),icoeffs(:),rnew(:),inew(:),alpha(:) 61 | double precision, allocatable :: reigs(:),ieigs(:) 62 | !double precision, allocatable :: rn(:),in(:) 63 | complex(kind(1d0)), allocatable :: eigs(:) 64 | double precision, allocatable ::residuals(:,:) 65 | 66 | complex(kind(1d0)) :: coeffs 67 | 68 | integer :: ii,jj,kk,ll,mm,N,zero,flag,info=0,str,stp,nnew,it,R 69 | integer :: clock_start,clock_end,clock_rate, newtnum, c1,c2 70 | integer :: Deg(20),num_trials(20), lapack_trials, num_trials_error(22) 71 | character (len=*), parameter :: path = "./" 72 | character(len=32) :: arg 73 | 74 | open (unit=7, file=path//"degrees.txt", status='unknown', position="append") 75 | open (unit=8, file=path//"damvw_times.txt", status='unknown', position="append") 76 | open (unit=18, file=path//"damvw_errors.txt", status='unknown', position="append") 77 | open (unit=28, file=path//"fig_damvw_times.txt", status='unknown', position="append") 78 | open (unit=38, file=path//"fig_damvw_errors.txt", status='unknown', position="append") 79 | open (unit=11, file=path//"lapack_times.txt", status='unknown', position="append") 80 | open (unit=21, file=path//"lapack_errors.txt", status='unknown', position="append") 81 | open (unit=31, file=path//"fig_lapack_times.txt", status='unknown', position="append") 82 | open (unit=41, file=path//"fig_lapack_errors.txt", status='unknown', position="append") 83 | 84 | if (iargc()>0) then 85 | call getarg(1, arg) 86 | read (arg,'(I10)') R 87 | else 88 | R = 5d0 89 | end if 90 | 91 | num_trials(1) = 2**(14) 92 | num_trials(2) = 2**(14) 93 | num_trials(3) = 2**(14) 94 | num_trials(4) = 2**(13) 95 | num_trials(5) = 2**(12) 96 | num_trials(6) = 2**(11) 97 | num_trials(7) = 2**(10) 98 | num_trials(8) = 2**(09) 99 | num_trials(9) = 2**(08) 100 | num_trials(10) = 2**(07) 101 | num_trials(11) = 2**(06) 102 | num_trials(12) = 2**(05) 103 | num_trials(13) = 2**(04) 104 | num_trials(14) = 2**(03) 105 | num_trials(15) = 2**(02) 106 | num_trials(16) = 2**(01) 107 | num_trials(17) = 2**(00) 108 | num_trials_error = 10 109 | 110 | Deg(1) = 6 111 | Deg(2) = 7 112 | Deg(3) = 8 113 | Deg(4) = 10 114 | Deg(5) = 12 115 | Deg(6) = 14 116 | Deg(7) = 16 117 | Deg(8) = 32 118 | Deg(9) = 64 119 | Deg(10) = 128 120 | Deg(11) = 256 121 | Deg(12) = 512 122 | Deg(13) = 1024 123 | Deg(14) = 2048 124 | Deg(15) = 4096 125 | Deg(16) = 8192 126 | Deg(17) = 16384 127 | 128 | do kk=1,17 129 | write (7,*) Deg(kk), num_trials(kk) 130 | print*, num_trials(kk) 131 | end do 132 | 133 | call init_random_seed() 134 | 135 | 136 | write (28,*) "% random polynomials, JT", R 137 | write (38,*) "% random polynomials, JT", R 138 | write (31,*) "% random polynomials, JT", R 139 | write (41,*) "% random polynomials, JT", R 140 | 141 | write (28,*) "\addplot coordinates{ % AMVW" 142 | write (38,*) "\addplot coordinates{ % AMVW" 143 | 144 | write (31,*) "\addplot coordinates{ % LAPACK ZHSEQR" 145 | write (41,*) "\addplot coordinates{ % LAPACK ZHSEQR" 146 | 147 | ! set newtnum 148 | newtnum = 1 149 | 150 | do ll=1,3 151 | 152 | time = 0d0 153 | 154 | N = Deg(ll) 155 | 156 | 157 | 158 | if (num_trials(ll) > num_trials_error(ll)) then 159 | mm = num_trials(ll) 160 | else 161 | mm = num_trials_error(ll) 162 | end if 163 | 164 | ! allocate memory 165 | allocate(Q(3*n),D(2*(n+1)),C(3*n),B2(3*n),rcoeffs(n*mm)) 166 | allocate(icoeffs(n*mm)) 167 | allocate(rnew(n*mm)) 168 | allocate(inew(n*mm)) 169 | allocate(its(n),reigs(n),ieigs(n),alpha(mm)) 170 | allocate(residuals(n,3*(newtnum+1))) 171 | 172 | write(*,*) "Current degree =",N, num_trials(ll), mm 173 | 174 | allocate(poly((N+1)*mm),roots(N),allroots(N,2),iterations(N),res(N,6)) 175 | allocate(B(N,N),Y(N,N),cwork(N)) 176 | 177 | rcoeffs=0d0 178 | icoeffs=0d0 179 | 180 | do ii=1,mm 181 | rcoeffs(N*ii)=-1d0 182 | 183 | do jj=1,N 184 | poly(jj+(ii-1)*n) = complex(rcoeffs(jj+(ii-1)*n),icoeffs(jj+(ii-1)*n)) 185 | end do 186 | end do 187 | 188 | error = 0d0 189 | 190 | ! ZAMVW 191 | write(*,*) "ZAMVW" 192 | CALL SYSTEM_CLOCK(COUNT_RATE=clock_rate) 193 | CALL SYSTEM_CLOCK(COUNT=clock_start) 194 | 195 | do ii=1,num_trials(ll) 196 | call factor(n,rcoeffs((ii-1)*n+1:(ii)*n),icoeffs((ii-1)*n+1:(ii)*n),Q,D,C,B2) 197 | call zamvw2(n,Q,D,C,B2,reigs,ieigs,its,flag,n-1,0) 198 | 199 | end do 200 | 201 | 202 | CALL SYSTEM_CLOCK(COUNT=clock_end) 203 | time = dble(clock_end - clock_start)/dble(clock_rate) 204 | time = time/dble(num_trials(ll)) 205 | 206 | do ii=1,num_trials_error(ll) 207 | call factor(n,rcoeffs((ii-1)*n+1:(ii)*n),icoeffs((ii-1)*n+1:(ii)*n),Q,D,C,B2) 208 | call zamvw2(n,Q,D,C,B2,reigs,ieigs,its,flag,n-1,0) 209 | 210 | it = 0 211 | do jj=1,n 212 | it = it + its(jj) 213 | roots(jj) = complex(reigs(jj),ieigs(jj)) 214 | !print*, roots(jj), abs(roots(jj)) 215 | end do 216 | call RESCHECK(0,N,0,1,POLY((ii-1)*n+1:ii*n),COEFFS,ROOTS,ALLROOTS,RES) 217 | 218 | do jj=1,6 219 | do kk=1,N 220 | if(res(kk,jj) > error(jj))then 221 | error(jj) = res(kk,jj) 222 | end if 223 | end do 224 | end do 225 | 226 | end do 227 | 228 | 229 | print*, time 230 | print*, error(:) 231 | 232 | write (8,*) time 233 | write (18,*) error(:) 234 | 235 | write(*,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 236 | & time, ")%" 237 | write(28,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 238 | & time, ")%" 239 | 240 | write(*,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 241 | & error(1), ")%" 242 | write(38,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 243 | & error(1), ")%" 244 | 245 | if (ll == 15) then 246 | write(28,"(A,1x,F6.3,1x,A,1x,I7,1x,A,1x,ES10.4E2,1x,A)"), & 247 | &"%\node[coordinate,pin=below:{AMVW:", time,& 248 | &"}] at (axis cs:",deg(ll),",",time,"){};" 249 | write(*,"(A,1x,F6.3,1x,A,1x,I7,1x,A,1x,ES10.4E2,1x,A)"), & 250 | &"%\node[coordinate,pin=below:{AMVW:", time,& 251 | &"}] at (axis cs:",deg(ll),",",time,"){};" 252 | end if 253 | 254 | 255 | 256 | ! LAPACK 257 | if (ll<=14) then 258 | write(*,*) "LAPACK" 259 | error = 0d0 260 | res = 0d0 261 | CALL SYSTEM_CLOCK(COUNT_RATE=clock_rate) 262 | CALL SYSTEM_CLOCK(COUNT=clock_start) 263 | do ii=1,num_trials(ll) 264 | do jj=1,N 265 | poly(jj) = complex(rcoeffs(jj+(ii-1)*n),icoeffs(jj+(ii-1)*n)) 266 | end do 267 | 268 | B = complex(0.d0,0.d0) 269 | B(1,:) = -poly(2:N+1) 270 | do kk=1,(N-1) 271 | B(kk+1,kk) = complex(1.d0,0.d0) 272 | end do 273 | 274 | call ZHSEQR('E','N',N,1,N,B,N,roots,Y,N,cwork,N,info) 275 | end do 276 | 277 | CALL SYSTEM_CLOCK(COUNT=clock_end) 278 | time = dble(clock_end - clock_start)/dble(clock_rate) 279 | time = time/dble(num_trials(ll)) 280 | do ii=1,num_trials_error(ll) 281 | do jj=1,N 282 | poly(jj) = complex(rcoeffs(jj+(ii-1)*n),icoeffs(jj+(ii-1)*n)) 283 | end do 284 | 285 | B = complex(0.d0,0.d0) 286 | B(1,:) = -poly(2:N+1) 287 | do kk=1,(N-1) 288 | B(kk+1,kk) = complex(1.d0,0.d0) 289 | end do 290 | 291 | call ZHSEQR('E','N',N,1,N,B,N,roots,Y,N,cwork,N,info) 292 | call RESCHECK(0,N,0,1,POLY(2:N+1),COEFFS,ROOTS,ALLROOTS,RES) 293 | 294 | do jj=1,6 295 | do kk=1,N 296 | if(res(kk,jj) > error(jj))then 297 | error(jj) = res(kk,jj) 298 | end if 299 | end do 300 | end do 301 | end do 302 | 303 | print*, time 304 | print*, error(:) 305 | write (11,*) time 306 | write (21,*) error(:) 307 | write(*,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 308 | & time, ")%" 309 | write(31,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 310 | & time, ")%" 311 | 312 | write(*,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 313 | & error(1), ")%" 314 | write(41,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 315 | & error(1), ")%" 316 | end if 317 | 318 | 319 | ! free memory 320 | deallocate(Q,D,C,B2,rcoeffs,icoeffs) 321 | deallocate(its,reigs,ieigs,rnew,inew) 322 | deallocate(residuals) 323 | deallocate(poly,roots,allroots,iterations,res) 324 | deallocate(B,Y,cwork,alpha) 325 | 326 | end do 327 | 328 | write (28,*) "};" 329 | write (38,*) "};" 330 | write (31,*) "};" 331 | write (41,*) "};" 332 | 333 | write (28,*) "" 334 | write (38,*) "" 335 | write (31,*) "" 336 | write (41,*) "" 337 | 338 | 339 | close(8) 340 | close(18) 341 | close(28) 342 | close(38) 343 | close(11) 344 | close(21) 345 | close(31) 346 | close(41) 347 | 348 | 349 | end program 350 | -------------------------------------------------------------------------------- /deps/doubleshift/tests/rootrace_unit.f95: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Aurentz² Mach³ Vandebril³ Watkins² 3 | ! 4 | ! ²Dept. Mathematics, Washington State University 5 | ! ³Dept. Computer Science, KU Leuven 6 | ! 7 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8 | ! Last modified 22 August 2014 9 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 10 | ! 11 | ! Rootrace 12 | ! 13 | ! comparing DAMVW with LAPACK's DHSEQR and DGEEV 14 | ! for polynomials x^n - 1 15 | ! 16 | ! Remark: In the paper we include a comparison 17 | ! with CGXZ (and BBEGG). Since we cannot 18 | ! redistribute their code, these 19 | ! comparisons have been removed. 20 | ! 21 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 22 | program main 23 | 24 | implicit none 25 | 26 | double precision, allocatable :: poly(:),C(:,:),rroots(:),iroots(:),Z(:,:),work(:) 27 | double precision, allocatable :: res(:,:) 28 | complex(kind(1d0)), allocatable :: wpoly(:),wcoeffs(:,:),wROOTS(:),wALLROOTS(:,:) 29 | integer, allocatable :: iterations(:) 30 | double precision :: time,error(6) 31 | 32 | integer :: ii,jj,kk,ll,mm,N,zero,flag,info=0 33 | integer :: clock_start,clock_end,clock_rate 34 | integer :: Deg(22),num_trials(22), num_trials_error(22), lapack_trials 35 | ! set path 36 | character (len=*), parameter :: path = "./" 37 | 38 | open (unit=7, file=path//"degrees.txt", status='unknown', position="append") 39 | open (unit=8, file=path//"damvw_times.txt", status='unknown', position="append") 40 | open (unit=18, file=path//"damvw_errors.txt", status='unknown', position="append") 41 | open (unit=28, file=path//"fig_damvw_times.txt", status='unknown', position="append") 42 | open (unit=38, file=path//"fig_damvw_errors.txt", status='unknown', position="append") 43 | open (unit=11, file=path//"lapack_times.txt", status='unknown', position="append") 44 | open (unit=21, file=path//"lapack_errors.txt", status='unknown', position="append") 45 | open (unit=31, file=path//"fig_lapack_times.txt", status='unknown', position="append") 46 | open (unit=41, file=path//"fig_lapack_errors.txt", status='unknown', position="append") 47 | open (unit=33, file=path//"fig_dgeev_times.txt", status='unknown', position="append") 48 | open (unit=43, file=path//"fig_dgeev_errors.txt", status='unknown', position="append") 49 | 50 | 51 | 52 | ! the number of runs is for small polynomials higher 53 | ! => there are enough runs for small polynomials to 54 | ! get timings 55 | num_trials(1) = 2**(14) 56 | num_trials(2) = 2**(14) 57 | num_trials(3) = 2**(14) 58 | num_trials(4) = 2**(13) 59 | num_trials(5) = 2**(12) 60 | num_trials(6) = 2**(11) 61 | num_trials(7) = 2**(10) 62 | num_trials(8) = 2**(09) 63 | num_trials(9) = 2**(08) 64 | num_trials(10) = 2**(07) 65 | num_trials(11) = 2**(06) 66 | num_trials(12) = 2**(05) 67 | num_trials(13) = 2**(04) 68 | num_trials(14) = 2**(03) 69 | num_trials(15) = 2**(02) 70 | num_trials(16) = 2**(01) 71 | num_trials(17) = 2**(00) 72 | ! => errors depend on the number of runs! 73 | num_trials_error = 1 74 | 75 | Deg(1) = 6 76 | Deg(2) = 7 77 | Deg(3) = 8 78 | Deg(4) = 10 79 | Deg(5) = 12 80 | Deg(6) = 14 81 | Deg(7) = 16 82 | Deg(8) = 32 83 | Deg(9) = 64 84 | Deg(10) = 128 85 | Deg(11) = 256 86 | Deg(12) = 512 87 | Deg(13) = 1024 88 | Deg(14) = 2048 89 | Deg(15) = 4096 90 | Deg(16) = 8192 91 | Deg(17) = 16384 92 | 93 | do kk=1,17 94 | write (7,*) Deg(kk), num_trials(kk) 95 | end do 96 | close(7) 97 | 98 | call init_random_seed() 99 | 100 | write (28,*) "% roots of unity" 101 | write (38,*) "% roots of unity" 102 | write (31,*) "% roots of unity" 103 | write (41,*) "% roots of unity" 104 | write (33,*) "% roots of unity" 105 | write (43,*) "% roots of unity" 106 | 107 | write (28,*) "\addplot coordinates{ % AMVW" 108 | write (38,*) "\addplot coordinates{ % AMVW" 109 | 110 | write (31,*) "\addplot coordinates{ % LAPACK" 111 | write (41,*) "\addplot coordinates{ % LAPACK" 112 | 113 | write (33,*) "\addplot coordinates{ % LAPACK DGEEV" 114 | write (43,*) "\addplot coordinates{ % LAPACK DGEEV" 115 | 116 | do ll=1,17 117 | time = 0d0 118 | 119 | N = Deg(ll) 120 | 121 | write(*,*) "Current N =",N, num_trials(ll) 122 | 123 | 124 | if (num_trials(ll) > num_trials_error(ll)) then 125 | mm = num_trials(ll) 126 | else 127 | mm = num_trials_error(ll) 128 | end if 129 | 130 | allocate(poly(N*mm),iterations(N),res(N,6)) 131 | allocate(C(N,N),Z(N,N),work(5*N),rroots(N),iroots(N)) 132 | allocate(wpoly(N),wCOEFFS(N,1),wROOTS(N),wALLROOTS(N,2)) 133 | 134 | do ii=1,N 135 | wcoeffs(ii,1) = complex(1d0,0d0) 136 | end do 137 | 138 | error = 0d0 139 | 140 | poly = 0d0 141 | do ii=1,mm 142 | poly(N*ii) = -1d0 143 | end do 144 | 145 | ! DAMVW 146 | 147 | write(*,*) "DAMVW" 148 | CALL SYSTEM_CLOCK(COUNT_RATE=clock_rate) 149 | CALL SYSTEM_CLOCK(COUNT=clock_start) 150 | 151 | do ii=1,num_trials(ll) 152 | 153 | call DAMVW(N,POLY((ii-1)*N+1:ii*N),RROOTS,IROOTS,ITERATIONS,FLAG) 154 | 155 | end do 156 | 157 | CALL SYSTEM_CLOCK(COUNT=clock_end) 158 | time = dble(clock_end - clock_start)/dble(clock_rate) 159 | time = time/dble(num_trials(ll)) 160 | 161 | do ii=1,num_trials_error(ll) 162 | call DAMVW(N,POLY((ii-1)*N+1:ii*N),RROOTS,IROOTS,ITERATIONS,FLAG) 163 | 164 | do jj=1,N 165 | wpoly(jj) = complex(POLY((ii-1)*N+jj),0d0) 166 | wroots(jj) = complex(rroots(jj),iroots(jj)) 167 | end do 168 | 169 | call RESCHECK(0,N,0,1,wPOLY,wCOEFFS,wROOTS,wALLROOTS,RES) 170 | 171 | do jj=1,6 172 | do kk=1,N 173 | if(res(kk,jj) > error(jj))then 174 | error(jj) = res(kk,jj) 175 | end if 176 | end do 177 | end do 178 | end do 179 | 180 | 181 | write (8,*) time 182 | print*, time 183 | write (18,*) error(:) 184 | 185 | write(*,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 186 | & time, ")%" 187 | write(28,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 188 | & time, ")%" 189 | 190 | write(*,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 191 | & error(1), ")%" 192 | write(38,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 193 | & error(1), ")%" 194 | 195 | if (ll == 15) then 196 | write(28,"(A,1x,F6.3,1x,A,1x,I7,1x,A,1x,ES10.4E2,1x,A)"), & 197 | &"%\node[coordinate,pin=below:{AMVW:", time,& 198 | &"}] at (axis cs:",deg(ll),",",time,"){};" 199 | write(*,"(A,1x,F6.3,1x,A,1x,I7,1x,A,1x,ES10.4E2,1x,A)"), & 200 | &"%\node[coordinate,pin=below:{AMVW:", time,& 201 | &"}] at (axis cs:",deg(ll),",",time,"){};" 202 | end if 203 | 204 | 205 | ! LAPACK 206 | if (ll<=14) then 207 | write(*,*) "LAPACK" 208 | error = 0d0 209 | res = 0d0 210 | 211 | CALL SYSTEM_CLOCK(COUNT_RATE=clock_rate) 212 | CALL SYSTEM_CLOCK(COUNT=clock_start) 213 | 214 | do ii=1,num_trials(ll) 215 | 216 | C = 0d0 217 | C(1,:) = -POLY((ii-1)*N+1:ii*N) 218 | do kk=1,(N-1) 219 | C(kk+1,kk) = 1.d0 220 | end do 221 | 222 | call DHSEQR('E','N',N,1,N,C,N,rroots,iroots,Z,N,work,N,info) 223 | 224 | end do 225 | 226 | CALL SYSTEM_CLOCK(COUNT=clock_end) 227 | time = dble(clock_end - clock_start)/dble(clock_rate) 228 | time = time/dble(num_trials(ll)) 229 | 230 | 231 | do ii=1,num_trials_error(ll) 232 | 233 | C = 0d0 234 | C(1,:) = -POLY((ii-1)*N+1:ii*N) 235 | do kk=1,(N-1) 236 | C(kk+1,kk) = 1.d0 237 | end do 238 | 239 | call DHSEQR('E','N',N,1,N,C,N,rroots,iroots,Z,N,work,N,info) 240 | 241 | do jj=1,N 242 | wpoly(jj) = complex(POLY((ii-1)*N+jj),0d0) 243 | wroots(jj) = complex(rroots(jj),iroots(jj)) 244 | end do 245 | 246 | call RESCHECK(0,N,0,1,wPOLY,wCOEFFS,wROOTS,wALLROOTS,RES) 247 | 248 | do jj=1,6 249 | do kk=1,N 250 | if(res(kk,jj) > error(jj))then 251 | error(jj) = res(kk,jj) 252 | end if 253 | end do 254 | end do 255 | 256 | end do 257 | write (11,*) time 258 | print*, time 259 | write (21,*) error(:) 260 | 261 | write(*,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 262 | & time, ")%" 263 | write(31,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 264 | & time, ")%" 265 | 266 | write(*,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 267 | & error(1), ")%" 268 | write(41,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 269 | & error(1), ")%" 270 | 271 | ! LAPACK 272 | write(*,*) "LAPACK" 273 | error = 0d0 274 | res = 0d0 275 | 276 | CALL SYSTEM_CLOCK(COUNT_RATE=clock_rate) 277 | CALL SYSTEM_CLOCK(COUNT=clock_start) 278 | 279 | do ii=1,num_trials(ll) 280 | 281 | C = 0d0 282 | C(1,:) = -POLY((ii-1)*N+1:ii*N) 283 | do kk=1,(N-1) 284 | C(kk+1,kk) = 1.d0 285 | end do 286 | 287 | call DGEEV('N','N',N,C,N,rroots,iroots,Z,N,Z,N,work,5*N,info) 288 | 289 | end do 290 | 291 | CALL SYSTEM_CLOCK(COUNT=clock_end) 292 | time = dble(clock_end - clock_start)/dble(clock_rate) 293 | time = time/dble(num_trials(ll)) 294 | 295 | 296 | do ii=1,num_trials_error(ll) 297 | 298 | C = 0d0 299 | C(1,:) = -POLY((ii-1)*N+1:ii*N) 300 | do kk=1,(N-1) 301 | C(kk+1,kk) = 1.d0 302 | end do 303 | 304 | call DGEEV('N','N',N,C,N,rroots,iroots,Z,N,Z,N,work,5*N,info) 305 | 306 | do jj=1,N 307 | wpoly(jj) = complex(POLY((ii-1)*N+jj),0d0) 308 | wroots(jj) = complex(rroots(jj),iroots(jj)) 309 | end do 310 | 311 | call RESCHECK(0,N,0,1,wPOLY,wCOEFFS,wROOTS,wALLROOTS,RES) 312 | 313 | do jj=1,6 314 | do kk=1,N 315 | if(res(kk,jj) > error(jj))then 316 | error(jj) = res(kk,jj) 317 | end if 318 | end do 319 | end do 320 | 321 | end do 322 | write (33,*) time 323 | print*, time 324 | write (43,*) error(:) 325 | end if 326 | 327 | deallocate(poly,iterations,res) 328 | deallocate(C,Z,work,rroots,iroots) 329 | deallocate(wpoly,wCOEFFS,wROOTS,wALLROOTS) 330 | 331 | end do 332 | 333 | write (28,*) "};" 334 | write (38,*) "};" 335 | write (31,*) "};" 336 | write (41,*) "};" 337 | write (33,*) "};" 338 | write (43,*) "};" 339 | write (28,*) "" 340 | write (38,*) "" 341 | write (31,*) "" 342 | write (41,*) "" 343 | write (33,*) "" 344 | write (43,*) "" 345 | 346 | close(8) 347 | close(18) 348 | close(28) 349 | close(38) 350 | close(11) 351 | close(21) 352 | close(31) 353 | close(41) 354 | close(13) 355 | close(23) 356 | close(33) 357 | close(43) 358 | 359 | 360 | end program main 361 | -------------------------------------------------------------------------------- /deps/doubleshift/tests/rootrace_backward_stability.f95: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Aurentz² Mach³ Vandebril³ Watkins² 3 | ! 4 | ! ²Dept. Mathematics, Washington State University 5 | ! ³Dept. Computer Science, KU Leuven 6 | ! 7 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8 | ! Last modified 22 August 2014 9 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 10 | ! 11 | ! Rootrace 12 | ! 13 | ! special backward stability test Table 8.16 and 14 | ! Table 8.17 in the paper 15 | ! 16 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 17 | 18 | program main 19 | 20 | implicit none 21 | 22 | double precision, allocatable :: poly(:),C(:,:),rroots(:),iroots(:),Z(:,:),work(:) 23 | double precision, allocatable :: coeffs(:,:),rallroots(:,:),iallroots(:,:),res(:,:) 24 | complex(kind(1d0)), allocatable :: wpoly(:),wCOEFFS(:,:),wROOTS(:),wALLROOTS(:,:) 25 | integer, allocatable :: iterations(:) 26 | double precision :: time,error(6),lerror(6), lzerror(6), alpha 27 | 28 | integer :: ii,jj,kk,ll,mm,N,zero,flag,info=0 29 | integer :: clock_start,clock_end,clock_rate 30 | integer :: Deg(400), num_trials(400), lapack_trials 31 | real :: sss_time 32 | character (len=*), parameter :: path = "/home/thomasm/data/" 33 | double precision :: normx(400),azero(400), normofp 34 | 35 | ! BLAS functions 36 | double precision :: dznrm2, dnrm2 37 | 38 | open (unit=7, file="table_bs.txt", status='unknown') 39 | 40 | write (7,*) "Table 1" 41 | 42 | do kk=1,1!,20 43 | do ll=1,20 44 | num_trials(20*(kk-1)+ll) = 2**(00) 45 | Deg(20*(kk-1)+ll) = 32 46 | normx(ll) = 10d0**(ll-8) 47 | azero(ll) = 0d0 48 | end do 49 | end do 50 | 51 | call init_random_seed() 52 | 53 | do ll=8,20 54 | 55 | time = 0d0 56 | 57 | N = Deg(ll) 58 | 59 | print*, "Current N =",N, num_trials(ll) 60 | 61 | allocate(poly(N*num_trials(ll)),coeffs(N,1),iterations(N),res(N,6)) 62 | allocate(C(N,N),Z(N,N),work(5*N),rroots(N),iroots(N)) 63 | allocate(wpoly(N),wCOEFFS(N,1),wROOTS(N),wALLROOTS(N,2)) 64 | 65 | do ii=1,N 66 | coeffs(ii,1) = 1d0 67 | wcoeffs(ii,1) = complex(1d0,0d0) 68 | end do 69 | 70 | error = 0d0 71 | 72 | 73 | call dnormalpoly(N*num_trials(ll),poly(1:N*num_trials(ll))) 74 | do ii=1,num_trials(ll) 75 | if (normx(ll)/=0d0) then 76 | alpha = normx(ll)/dnrm2(N,poly((ii-1)*N+1:ii*N),1) 77 | call dscal(N,alpha,poly((ii-1)*N+1:ii*N),1) 78 | end if 79 | if (azero(ll)/=0d0) then 80 | POLY(ii*N)=POLY(ii*N)/abs(POLY(ii*N))*azero(ll) 81 | end if 82 | do jj=1,N 83 | wpoly(jj) = complex(POLY((ii-1)*N+jj),0d0) 84 | end do 85 | end do 86 | 87 | normofp = dsqrt(dznrm2(N,wpoly,1)**2 + 1d0) 88 | 89 | 90 | ! DAMVW 91 | 92 | write(*,*) "DAMVW" 93 | 94 | do ii=1,num_trials(ll) 95 | 96 | call DAMVW(N,POLY((ii-1)*N+1:ii*N),RROOTS,IROOTS,ITERATIONS,FLAG) 97 | 98 | do jj=1,N 99 | wroots(jj) = complex(rroots(jj),iroots(jj)) 100 | end do 101 | 102 | call RESCHECK(0,N,0,1,wPOLY,wCOEFFS,wROOTS,wALLROOTS,RES) 103 | 104 | do jj=1,6 105 | do kk=1,N 106 | if(res(kk,jj) > error(jj))then 107 | error(jj) = res(kk,jj) 108 | end if 109 | end do 110 | end do 111 | 112 | end do 113 | 114 | 115 | ! LAPACK 116 | write(*,*) "LAPACK" 117 | lerror = 0d0 118 | res = 0d0 119 | 120 | do ii=1,num_trials(ll) 121 | C = 0d0 122 | ! quadratic formula test from Edelman-Murakami-1995 123 | if (n==2) then 124 | C(1,2) = -POLY(2) 125 | C(2,2) = -POLY(1) 126 | else if (n==4) then 127 | C(1,4) = -POLY(4) 128 | C(2,4) = -POLY(3) 129 | C(3,4) = -POLY(2) 130 | C(4,4) = -POLY(1) 131 | else if (n==3) then 132 | C(1,3) = -POLY(3) 133 | C(2,3) = -POLY(2) 134 | C(3,3) = -POLY(1) 135 | else 136 | C(1,:) = -POLY((ii-1)*N+1:ii*N) 137 | end if 138 | 139 | do kk=1,(N-1) 140 | C(kk+1,kk) = 1.d0 141 | end do 142 | 143 | call DHSEQR('E','N',N,1,N,C,N,rroots,iroots,Z,N,work,N,info) 144 | 145 | do jj=1,N 146 | !wpoly(jj) = complex(POLY((ii-1)*N+jj),0d0) 147 | wroots(jj) = complex(rroots(jj),iroots(jj)) 148 | end do 149 | 150 | call RESCHECK(0,N,0,1,wPOLY,wCOEFFS,wROOTS,wALLROOTS,RES) 151 | print*, "lapack info", info 152 | do jj=1,6 153 | do kk=1,N 154 | if(res(kk,jj) > lerror(jj))then 155 | lerror(jj) = res(kk,jj) 156 | end if 157 | end do 158 | end do 159 | end do 160 | 161 | 162 | 163 | ! LAPACK 164 | write(*,*) "LAPACK" 165 | lzerror = 0d0 166 | res = 0d0 167 | 168 | do ii=1,num_trials(ll) 169 | C = 0d0 170 | ! quadratic formula test from Edelman-Murakami-1995 171 | if (n==2) then 172 | C(1,2) = -POLY(2) 173 | C(2,2) = -POLY(1) 174 | else if (n==4) then 175 | C(1,4) = -POLY(4) 176 | C(2,4) = -POLY(3) 177 | C(3,4) = -POLY(2) 178 | C(4,4) = -POLY(1) 179 | else if (n==3) then 180 | C(1,3) = -POLY(3) 181 | C(2,3) = -POLY(2) 182 | C(3,3) = -POLY(1) 183 | else 184 | C(1,:) = -POLY((ii-1)*N+1:ii*N) 185 | end if 186 | 187 | do kk=1,(N-1) 188 | C(kk+1,kk) = 1.d0 189 | end do 190 | 191 | !call DHSEQR('E','N',N,1,N,C,N,rroots,iroots,Z,N,work,N,info) 192 | call DGEEV('N','N',N,C,N,rroots,iroots,Z,N,Z,N,work,5*N,info) 193 | 194 | do jj=1,N 195 | !wpoly(jj) = complex(POLY((ii-1)*N+jj),0d0) 196 | wroots(jj) = complex(rroots(jj),iroots(jj)) 197 | end do 198 | 199 | call RESCHECK(0,N,0,1,wPOLY,wCOEFFS,wROOTS,wALLROOTS,RES) 200 | print*, "lapack info", info 201 | do jj=1,6 202 | do kk=1,N 203 | if(res(kk,jj) > lzerror(jj))then 204 | lzerror(jj) = res(kk,jj) 205 | end if 206 | end do 207 | end do 208 | end do 209 | 210 | 211 | 212 | 213 | write (7,"(ES10.0E2,1x,A,1x,ES10.4E2,1x,A,1x,& 214 | &ES10.4E2,1x,A,1x,ES10.4E2,1x,A,1x,ES10.4E2,1x,A,I3)"), normx(ll),& 215 | & "&", error(1), "&", lerror(1), "&", lzerror(1), "&", normofp, "\\%", ll 216 | write (*,"(ES10.0E2,1x,A,1x,ES10.4E2,1x,A,1x,& 217 | &ES10.4E2,1x,A,1x,ES10.4E2,1x,A,1x,ES10.4E2,1x,A,I3)"), normx(ll),& 218 | & "&", error(1), "&", lerror(1), "&", lzerror(1), "&", normofp, "\\%", ll 219 | 220 | deallocate(poly,coeffs,iterations,res) 221 | deallocate(C,Z,work,rroots,iroots) 222 | deallocate(wpoly,wCOEFFS,wROOTS,wALLROOTS) 223 | 224 | end do 225 | 226 | write (7,*) "Table 2" 227 | 228 | do kk=1,1!,20 229 | do ll=1,20 230 | num_trials(20*(kk-1)+ll) = 2**(00) 231 | Deg(20*(kk-1)+ll) = 512 232 | normx(ll) = 0d0 233 | azero(ll) = 10d0**(ll-8) 234 | end do 235 | end do 236 | 237 | do ll=1,10 238 | 239 | time = 0d0 240 | 241 | N = Deg(ll) 242 | 243 | print*, "Current N =",N, num_trials(ll) 244 | 245 | allocate(poly(N*num_trials(ll)),coeffs(N,1),iterations(N),res(N,6)) 246 | allocate(C(N,N),Z(N,N),work(5*N),rroots(N),iroots(N)) 247 | allocate(wpoly(N),wCOEFFS(N,1),wROOTS(N),wALLROOTS(N,2)) 248 | 249 | do ii=1,N 250 | coeffs(ii,1) = 1d0 251 | wcoeffs(ii,1) = complex(1d0,0d0) 252 | end do 253 | 254 | error = 0d0 255 | 256 | 257 | call dnormalpoly(N*num_trials(ll),poly(1:N*num_trials(ll))) 258 | do ii=1,num_trials(ll) 259 | if (normx(ll)/=0d0) then 260 | alpha = normx(ll)/dnrm2(N,poly((ii-1)*N+1:ii*N),1) 261 | call dscal(N,alpha,poly((ii-1)*N+1:ii*N),1) 262 | end if 263 | if (azero(ll)/=0d0) then 264 | POLY(ii*N)=POLY(ii*N)/abs(POLY(ii*N))*azero(ll) 265 | end if 266 | do jj=1,N 267 | wpoly(jj) = complex(POLY((ii-1)*N+jj),0d0) 268 | end do 269 | end do 270 | 271 | normofp = dsqrt(dznrm2(N,wpoly,1)**2 + 1d0) 272 | 273 | ! DAMVW 274 | write(*,*) "DAMVW" 275 | 276 | do ii=1,num_trials(ll) 277 | 278 | call DAMVW(N,POLY((ii-1)*N+1:ii*N),RROOTS,IROOTS,ITERATIONS,FLAG) 279 | 280 | do jj=1,N 281 | wpoly(jj) = complex(POLY((ii-1)*N+jj),0d0) 282 | wroots(jj) = complex(rroots(jj),iroots(jj)) 283 | end do 284 | 285 | call RESCHECK(0,N,0,1,wPOLY,wCOEFFS,wROOTS,wALLROOTS,RES) 286 | 287 | do jj=1,6 288 | do kk=1,N 289 | if(res(kk,jj) > error(jj))then 290 | error(jj) = res(kk,jj) 291 | end if 292 | end do 293 | end do 294 | 295 | end do 296 | 297 | 298 | ! LAPACK 299 | write(*,*) "LAPACK" 300 | lerror = 0d0 301 | res = 0d0 302 | 303 | do ii=1,num_trials(ll) 304 | C = 0d0 305 | C(1,:) = -POLY((ii-1)*N+1:ii*N) 306 | 307 | do kk=1,(N-1) 308 | C(kk+1,kk) = 1.d0 309 | end do 310 | 311 | call DHSEQR('E','N',N,1,N,C,N,rroots,iroots,Z,N,work,N,info) 312 | 313 | do jj=1,N 314 | wpoly(jj) = complex(POLY((ii-1)*N+jj),0d0) 315 | wroots(jj) = complex(rroots(jj),iroots(jj)) 316 | end do 317 | 318 | call RESCHECK(0,N,0,1,wPOLY,wCOEFFS,wROOTS,wALLROOTS,RES) 319 | print*, "lapack info", info 320 | do jj=1,6 321 | do kk=1,N 322 | if(res(kk,jj) > lerror(jj))then 323 | lerror(jj) = res(kk,jj) 324 | end if 325 | end do 326 | end do 327 | end do 328 | 329 | 330 | ! LAPACK 331 | write(*,*) "LAPACK" 332 | lzerror = 0d0 333 | res = 0d0 334 | 335 | do ii=1,num_trials(ll) 336 | C = 0d0 337 | C(1,:) = -POLY((ii-1)*N+1:ii*N) 338 | 339 | do kk=1,(N-1) 340 | C(kk+1,kk) = 1.d0 341 | end do 342 | 343 | call DGEEV('N','N',N,C,N,rroots,iroots,Z,N,Z,N,work,5*N,info) 344 | 345 | do jj=1,N 346 | wpoly(jj) = complex(POLY((ii-1)*N+jj),0d0) 347 | wroots(jj) = complex(rroots(jj),iroots(jj)) 348 | end do 349 | 350 | call RESCHECK(0,N,0,1,wPOLY,wCOEFFS,wROOTS,wALLROOTS,RES) 351 | print*, "lapack info", info 352 | do jj=1,6 353 | do kk=1,N 354 | if(res(kk,jj) > lzerror(jj))then 355 | lzerror(jj) = res(kk,jj) 356 | end if 357 | end do 358 | end do 359 | end do 360 | 361 | 362 | 363 | 364 | write (7,"(ES10.0E2,1x,A,1x,ES10.4E2,1x,A,1x,& 365 | &ES10.4E2,1x,A,1x,ES10.4E2,1x,A,1x,ES10.4E2,1x,A,I3)"), azero(ll),& 366 | & "&", error(1), "&", lerror(1), "&", lzerror(1), "&", normofp, "\\%", ll 367 | write (*,"(ES10.0E2,1x,A,1x,ES10.4E2,1x,A,1x,& 368 | &ES10.4E2,1x,A,1x,ES10.4E2,1x,A,1x,ES10.4E2,1x,A,I3)"), azero(ll),& 369 | & "&", error(1), "&", lerror(1), "&", lzerror(1), "&", normofp, "\\%", ll 370 | 371 | deallocate(poly,coeffs,iterations,res) 372 | deallocate(C,Z,work,rroots,iroots) 373 | deallocate(wpoly,wCOEFFS,wROOTS,wALLROOTS) 374 | 375 | end do 376 | close(7) 377 | 378 | 379 | end program main 380 | -------------------------------------------------------------------------------- /deps/doubleshift/tests/rootrace.f95: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Aurentz² Mach³ Vandebril³ Watkins² 3 | ! 4 | ! ²Dept. Mathematics, Washington State University 5 | ! ³Dept. Computer Science, KU Leuven 6 | ! 7 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8 | ! Last modified 22 August 2014 9 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 10 | ! 11 | ! Rootrace 12 | ! 13 | ! comparing DAMVW with LAPACK's DHSEQR and DGEEV 14 | ! polynomials with random coefficients 15 | ! 16 | ! Remark: In the paper we include a comparison 17 | ! with CGXZ (and BBEGG). Since we cannot 18 | ! redistribute their code, these 19 | ! comparisons have been removed. 20 | ! 21 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 22 | 23 | program main 24 | 25 | implicit none 26 | 27 | double precision, allocatable :: poly(:),C(:,:),rroots(:),iroots(:),Z(:,:),work(:) 28 | double precision, allocatable :: res(:,:) 29 | complex(kind(1d0)), allocatable :: wpoly(:),wcoeffs(:,:),wroots(:),wallroots(:,:) 30 | integer, allocatable :: iterations(:) 31 | double precision :: time,error(6) 32 | 33 | integer :: ii,jj,kk,ll,mm,N,flag,info=0 34 | integer :: clock_start,clock_end,clock_rate 35 | integer :: Deg(22),num_trials(22),num_trials_error(22) 36 | ! set path 37 | character (len=*), parameter :: path = "./" 38 | 39 | ! Files with fig_* contain the LaTeX lines of the Figures in the paper. 40 | open (unit=7, file=path//"degrees.txt", status='unknown', position="append") 41 | open (unit=8, file=path//"damvw_times.txt", status='unknown', position="append") 42 | open (unit=18, file=path//"damvw_errors.txt", status='unknown', position="append") 43 | open (unit=28, file=path//"fig_damvw_times.txt", status='unknown', position="append") 44 | open (unit=38, file=path//"fig_damvw_errors.txt", status='unknown', position="append") 45 | open (unit=11, file=path//"lapack_times.txt", status='unknown', position="append") 46 | open (unit=21, file=path//"lapack_errors.txt", status='unknown', position="append") 47 | open (unit=31, file=path//"fig_lapack_times.txt", status='unknown', position="append") 48 | open (unit=41, file=path//"fig_lapack_errors.txt", status='unknown', position="append") 49 | open (unit=33, file=path//"fig_dgeev_times.txt", status='unknown', position="append") 50 | open (unit=43, file=path//"fig_dgeev_errors.txt", status='unknown', position="append") 51 | 52 | 53 | ! the number of runs is for small polynomials higher 54 | ! => there are enough runs for small polynomials to 55 | ! get timings 56 | num_trials(1) = 2**(14) 57 | num_trials(2) = 2**(14) 58 | num_trials(3) = 2**(14) 59 | num_trials(4) = 2**(13) 60 | num_trials(5) = 2**(12) 61 | num_trials(6) = 2**(11) 62 | num_trials(7) = 2**(10) 63 | num_trials(8) = 2**(09) 64 | num_trials(9) = 2**(08) 65 | num_trials(10) = 2**(07) 66 | num_trials(11) = 2**(06) 67 | num_trials(12) = 2**(05) 68 | num_trials(13) = 2**(04) 69 | num_trials(14) = 2**(03) 70 | num_trials(15) = 2**(02) 71 | num_trials(16) = 2**(01) 72 | num_trials(17) = 2**(00) 73 | ! => errors depend on the number of runs! 74 | num_trials_error = 10 75 | 76 | Deg(1) = 6 77 | Deg(2) = 7 78 | Deg(3) = 8 79 | Deg(4) = 10 80 | Deg(5) = 12 81 | Deg(6) = 14 82 | Deg(7) = 16 83 | ! O(n²) for DAMVW and O(n³) for LAPACK 84 | Deg(8) = 32 85 | Deg(9) = 64 86 | Deg(10) = 128 87 | Deg(11) = 256 88 | Deg(12) = 512 89 | Deg(13) = 1024 90 | Deg(14) = 2048 91 | ! LAPACK is turnoff for larger polynomials, see below 92 | Deg(15) = 4096 93 | Deg(16) = 8192 94 | Deg(17) = 16384 95 | 96 | do kk=1,17 97 | write (7,*) Deg(kk), num_trials(kk) 98 | end do 99 | close(7) 100 | 101 | call init_random_seed() 102 | 103 | 104 | 105 | write (28,*) "% random polynomials, normal distributed coefficients" 106 | write (38,*) "% random polynomials, normal distributed coefficients" 107 | write (31,*) "% random polynomials, normal distributed coefficients" 108 | write (41,*) "% random polynomials, normal distributed coefficients" 109 | write (33,*) "% random polynomials, normal distributed coefficients" 110 | write (43,*) "% random polynomials, normal distributed coefficients" 111 | 112 | write (28,*) "\addplot coordinates{ % AMVW" 113 | write (38,*) "\addplot coordinates{ % AMVW" 114 | 115 | write (31,*) "\addplot coordinates{ % LAPACK DHSEQR" 116 | write (41,*) "\addplot coordinates{ % LAPACK DHSEQR" 117 | 118 | write (33,*) "\addplot coordinates{ % LAPACK DGEEV" 119 | write (43,*) "\addplot coordinates{ % LAPACK DGEEV" 120 | 121 | do ll=1,17 122 | 123 | time = 0d0 124 | 125 | N = Deg(ll) 126 | 127 | write(*,*) "Current N =",N, num_trials(ll) 128 | 129 | 130 | if (num_trials(ll) > num_trials_error(ll)) then 131 | mm = num_trials(ll) 132 | else 133 | mm = num_trials_error(ll) 134 | end if 135 | 136 | allocate(poly(N*mm),iterations(N),res(N,6)) 137 | allocate(C(N,N),Z(N,N),work(5*N),rroots(N),iroots(N)) 138 | allocate(wpoly(N),wCOEFFS(N,1),wROOTS(N),wALLROOTS(N,2)) 139 | 140 | do ii=1,N 141 | wcoeffs(ii,1) = complex(1d0,0d0) 142 | end do 143 | 144 | error = 0d0 145 | res = 0d0 146 | ! choose random polynomials for all test runs 147 | call dnormalpoly(N*mm,poly(1:mm)) 148 | 149 | 150 | ! DAMVW 151 | write(*,*) "DAMVW" 152 | ! start timer 153 | CALL SYSTEM_CLOCK(COUNT_RATE=clock_rate) 154 | CALL SYSTEM_CLOCK(COUNT=clock_start) 155 | do ii=1,num_trials(ll) 156 | 157 | call DAMVW(N,POLY((ii-1)*N+1:ii*N),RROOTS,IROOTS,ITERATIONS,FLAG) 158 | 159 | end do 160 | 161 | CALL SYSTEM_CLOCK(COUNT=clock_end) 162 | time = dble(clock_end - clock_start)/dble(clock_rate) 163 | time = time/dble(num_trials(ll)) 164 | 165 | do ii=1,num_trials_error(ll) 166 | 167 | ! compute roots 168 | call DAMVW(N,POLY((ii-1)*N+1:ii*N),rroots,iroots,iterations,flag) 169 | 170 | do jj=1,N 171 | wpoly(jj) = complex(poly((ii-1)*N+jj),0d0) 172 | wroots(jj) = complex(rroots(jj),iroots(jj)) 173 | end do 174 | 175 | ! check residual 176 | call RESCHECK(0,N,0,1,wpoly,wcoeffs,wroots,wallroots,res) 177 | 178 | do jj=1,6 179 | do kk=1,N 180 | if(res(kk,jj) > error(jj))then 181 | error(jj) = res(kk,jj) 182 | end if 183 | end do 184 | end do 185 | 186 | end do 187 | 188 | 189 | write (8,*) time 190 | print*, time 191 | write (18,*) error(:) 192 | 193 | write(*,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 194 | & time, ")%" 195 | write(28,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 196 | & time, ")%" 197 | 198 | write(*,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 199 | & error(1), ")%" 200 | write(38,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 201 | & error(1), ")%" 202 | 203 | if (ll == 15) then 204 | write(28,"(A,1x,F6.3,1x,A,1x,I7,1x,A,1x,ES10.4E2,1x,A)"), & 205 | &"%\node[coordinate,pin=below:{AMVW:", time,& 206 | &"}] at (axis cs:",deg(ll),",",time,"){};" 207 | write(*,"(A,1x,F6.3,1x,A,1x,I7,1x,A,1x,ES10.4E2,1x,A)"), & 208 | &"%\node[coordinate,pin=below:{AMVW:", time,& 209 | &"}] at (axis cs:",deg(ll),",",time,"){};" 210 | end if 211 | 212 | if (ll<=14) then 213 | ! LAPACK 214 | write(*,*) "LAPACK" 215 | error = 0d0 216 | res = 0d0 217 | 218 | CALL SYSTEM_CLOCK(COUNT_RATE=clock_rate) 219 | CALL SYSTEM_CLOCK(COUNT=clock_start) 220 | 221 | do ii=1,num_trials(ll) 222 | 223 | C = 0d0 224 | C(1,:) = -POLY((ii-1)*N+1:ii*N) 225 | do kk=1,(N-1) 226 | C(kk+1,kk) = 1.d0 227 | end do 228 | 229 | call DHSEQR('E','N',N,1,N,C,N,rroots,iroots,Z,N,work,N,info) 230 | 231 | end do 232 | 233 | CALL SYSTEM_CLOCK(COUNT=clock_end) 234 | time = dble(clock_end - clock_start)/dble(clock_rate) 235 | time = time/dble(num_trials(ll)) 236 | 237 | 238 | do ii=1,num_trials_error(ll) 239 | 240 | C = 0d0 241 | C(1,:) = -POLY((ii-1)*N+1:ii*N) 242 | do kk=1,(N-1) 243 | C(kk+1,kk) = 1.d0 244 | end do 245 | 246 | call DHSEQR('E','N',N,1,N,C,N,rroots,iroots,Z,N,work,N,info) 247 | 248 | do jj=1,N 249 | wpoly(jj) = complex(POLY((ii-1)*N+jj),0d0) 250 | wroots(jj) = complex(rroots(jj),iroots(jj)) 251 | end do 252 | 253 | call RESCHECK(0,N,0,1,wPOLY,wCOEFFS,wROOTS,wALLROOTS,RES) 254 | 255 | do jj=1,6 256 | do kk=1,N 257 | if(res(kk,jj) > error(jj))then 258 | error(jj) = res(kk,jj) 259 | end if 260 | end do 261 | end do 262 | 263 | end do 264 | write (11,*) time 265 | print*, time 266 | write (21,*) error(:) 267 | 268 | write(*,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 269 | & time, ")%" 270 | write(31,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 271 | & time, ")%" 272 | 273 | write(*,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 274 | & error(1), ")%" 275 | write(41,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 276 | & error(1), ")%" 277 | 278 | 279 | write(*,*) "LAPACK" 280 | error = 0d0 281 | res = 0d0 282 | 283 | CALL SYSTEM_CLOCK(COUNT_RATE=clock_rate) 284 | CALL SYSTEM_CLOCK(COUNT=clock_start) 285 | 286 | do ii=1,num_trials(ll) 287 | 288 | C = 0d0 289 | C(1,:) = -POLY((ii-1)*N+1:ii*N) 290 | do kk=1,(N-1) 291 | C(kk+1,kk) = 1.d0 292 | end do 293 | 294 | call DGEEV('N','N',N,C,N,rroots,iroots,Z,N,Z,N,work,5*N,info) 295 | 296 | end do 297 | 298 | CALL SYSTEM_CLOCK(COUNT=clock_end) 299 | time = dble(clock_end - clock_start)/dble(clock_rate) 300 | time = time/dble(num_trials(ll)) 301 | 302 | 303 | do ii=1,num_trials_error(ll) 304 | 305 | C = 0d0 306 | C(1,:) = -POLY((ii-1)*N+1:ii*N) 307 | do kk=1,(N-1) 308 | C(kk+1,kk) = 1.d0 309 | end do 310 | 311 | call DGEEV('N','N',N,C,N,rroots,iroots,Z,N,Z,N,work,5*N,info) 312 | 313 | do jj=1,N 314 | wpoly(jj) = complex(POLY((ii-1)*N+jj),0d0) 315 | wroots(jj) = complex(rroots(jj),iroots(jj)) 316 | end do 317 | 318 | call RESCHECK(0,N,0,1,wpoly,wcoeffs,wroots,wallroots,res) 319 | 320 | do jj=1,6 321 | do kk=1,N 322 | if(res(kk,jj) > error(jj))then 323 | error(jj) = res(kk,jj) 324 | end if 325 | end do 326 | end do 327 | 328 | end do 329 | write (11,*) time 330 | print*, time 331 | write (21,*) error(:) 332 | 333 | write(*,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 334 | & time, ")%" 335 | write(33,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 336 | & time, ")%" 337 | 338 | write(*,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 339 | & error(1), ")%" 340 | write(43,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 341 | & error(1), ")%" 342 | end if 343 | 344 | deallocate(poly,iterations,res) 345 | deallocate(C,Z,work,rroots,iroots) 346 | deallocate(wpoly,wcoeffs,wroots,wallroots) 347 | 348 | end do 349 | 350 | write (28,*) "};" 351 | write (38,*) "};" 352 | write (31,*) "};" 353 | write (41,*) "};" 354 | write (33,*) "};" 355 | write (43,*) "};" 356 | 357 | write (28,*) "" 358 | write (38,*) "" 359 | write (31,*) "" 360 | write (41,*) "" 361 | write (33,*) "" 362 | write (43,*) "" 363 | 364 | close(8) 365 | close(18) 366 | close(28) 367 | close(38) 368 | close(11) 369 | close(21) 370 | close(31) 371 | close(41) 372 | close(13) 373 | close(23) 374 | close(33) 375 | close(43) 376 | 377 | 378 | end program main 379 | -------------------------------------------------------------------------------- /deps/singleshift/tests/rootrace_unit.f95: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Aurentz² Mach³ Vandebril³ Watkins² 3 | ! 4 | ! ²Dept. Mathematics, Washington State University 5 | ! ³Dept. Computer Science, KU Leuven 6 | ! 7 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8 | ! Last modified 22 August 2014 9 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 10 | ! 11 | ! Rootrace 12 | ! 13 | ! comparing ZAMVW with LAPACK's ZHSEQR 14 | ! polynomials z^n - 1 15 | ! 16 | ! Remark: In the paper we include a comparison 17 | ! with BBEGG and BEGG. Since we cannot 18 | ! distribute their code, these 19 | ! comparisons have been removed. 20 | ! 21 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 22 | program main 23 | 24 | implicit none 25 | 26 | complex(kind(1d0)), allocatable :: poly(:),roots(:),allroots(:,:) 27 | complex(kind(1d0)), allocatable :: B(:,:),Y(:,:),cwork(:) 28 | integer, allocatable :: iterations(:),its(:) 29 | double precision, allocatable :: res(:,:) 30 | double precision :: time,begg_time,lapack_time,pdble,error(6) 31 | double precision, allocatable :: Q(:),D(:),C(:),B2(:) 32 | double precision, allocatable :: rcoeffs(:),icoeffs(:),rnew(:),inew(:),alpha(:) 33 | double precision, allocatable :: reigs(:),ieigs(:) 34 | !double precision, allocatable :: rn(:),in(:) 35 | complex(kind(1d0)), allocatable :: eigs(:) 36 | double precision, allocatable ::residuals(:,:), rwork(:) 37 | 38 | complex(kind(1d0)) :: coeffs 39 | 40 | integer :: ii,jj,kk,ll,mm,N,zero,flag,info=0,str,stp,nnew,it 41 | integer :: clock_start,clock_end,clock_rate, newtnum, c1,c2 42 | integer :: Deg(20),num_trials(20), lapack_trials, num_trials_error(22) 43 | character (len=*), parameter :: path = "./" 44 | 45 | open (unit=7, file=path//"degrees.txt", status='unknown', position="append") 46 | open (unit=8, file=path//"damvw_times.txt", status='unknown', position="append") 47 | open (unit=18, file=path//"damvw_errors.txt", status='unknown', position="append") 48 | open (unit=28, file="fig_damvw_times.txt", status='unknown', position="append") 49 | open (unit=38, file="fig_damvw_errors.txt", status='unknown', position="append") 50 | open (unit=11, file=path//"lapack_times.txt", status='unknown', position="append") 51 | open (unit=21, file=path//"lapack_errors.txt", status='unknown', position="append") 52 | open (unit=31, file="fig_lapack_times.txt", status='unknown', position="append") 53 | open (unit=41, file="fig_lapack_errors.txt", status='unknown', position="append") 54 | open (unit=33, file="fig_zgeev_times.txt", status='unknown', position="append") 55 | open (unit=43, file="fig_zgeev_errors.txt", status='unknown', position="append") 56 | 57 | num_trials(1) = 2**(14) 58 | num_trials(2) = 2**(14) 59 | num_trials(3) = 2**(14) 60 | num_trials(4) = 2**(13) 61 | num_trials(5) = 2**(12) 62 | num_trials(6) = 2**(11) 63 | num_trials(7) = 2**(10) 64 | num_trials(8) = 2**(09) 65 | num_trials(9) = 2**(08) 66 | num_trials(10) = 2**(07) 67 | num_trials(11) = 2**(06) 68 | num_trials(12) = 2**(05) 69 | num_trials(13) = 2**(04) 70 | num_trials(14) = 2**(03) 71 | num_trials(15) = 2**(02) 72 | num_trials(16) = 2**(01) 73 | num_trials(17) = 2**(00) 74 | ! error depend on number of runs 75 | num_trials_error = 10 76 | 77 | Deg(1) = 6 78 | Deg(2) = 7 79 | Deg(3) = 8 80 | Deg(4) = 10 81 | Deg(5) = 12 82 | Deg(6) = 14 83 | Deg(7) = 16 84 | Deg(8) = 32 85 | Deg(9) = 64 86 | Deg(10) = 128 87 | Deg(11) = 256 88 | Deg(12) = 512 89 | Deg(13) = 1024 90 | Deg(14) = 2048 91 | Deg(15) = 4096 92 | Deg(16) = 8192 93 | Deg(17) = 16384 94 | 95 | do kk=1,17 96 | write (7,*) Deg(kk), num_trials(kk) 97 | print*, num_trials(kk) 98 | end do 99 | 100 | call init_random_seed() 101 | 102 | 103 | write (28,*) "% polynomials z^n - 1" 104 | write (38,*) "% polynomials z^n - 1" 105 | write (31,*) "% polynomials z^n - 1" 106 | write (41,*) "% polynomials z^n - 1" 107 | write (33,*) "% polynomials z^n - 1" 108 | write (43,*) "% polynomials z^n - 1" 109 | 110 | write (28,*) "\addplot coordinates{ % AMVW" 111 | write (38,*) "\addplot coordinates{ % AMVW" 112 | 113 | write (31,*) "\addplot coordinates{ % LAPACK ZHSEQR" 114 | write (41,*) "\addplot coordinates{ % LAPACK ZHSEQR" 115 | 116 | write (33,*) "\addplot coordinates{ % LAPACK ZGEEV" 117 | write (43,*) "\addplot coordinates{ % LAPACK ZGEEV" 118 | 119 | ! set newtnum 120 | newtnum = 1 121 | 122 | do ll=1,17 123 | 124 | time = 0d0 125 | 126 | N = Deg(ll) 127 | 128 | if (num_trials(ll) > num_trials_error(ll)) then 129 | mm = num_trials(ll) 130 | else 131 | mm = num_trials_error(ll) 132 | end if 133 | 134 | ! allocate memory 135 | allocate(Q(3*n),D(2*(n+1)),C(3*n),B2(3*n),rcoeffs(n*mm)) 136 | allocate(icoeffs(n*mm)) 137 | allocate(rnew(n*mm)) 138 | allocate(inew(n*mm)) 139 | allocate(its(n),reigs(n),ieigs(n),alpha(mm)) 140 | allocate(residuals(n,3*(newtnum+1))) 141 | 142 | write(*,*) "Current degree =",N, num_trials(ll), mm 143 | 144 | allocate(poly((N+1)*mm),roots(N),allroots(N,2),iterations(N),res(N,6)) 145 | allocate(B(N,N),Y(N,N),cwork(5*N),rwork(N)) 146 | 147 | rcoeffs=0d0 148 | icoeffs=0d0 149 | 150 | do ii=1,mm 151 | rcoeffs(N*ii)=-1d0 152 | 153 | do jj=1,N 154 | poly(jj+(ii-1)*n) = complex(rcoeffs(jj+(ii-1)*n),icoeffs(jj+(ii-1)*n)) 155 | end do 156 | end do 157 | 158 | error = 0d0 159 | 160 | ! ZAMVW 161 | write(*,*) "ZAMVW" 162 | CALL SYSTEM_CLOCK(COUNT_RATE=clock_rate) 163 | CALL SYSTEM_CLOCK(COUNT=clock_start) 164 | 165 | do ii=1,num_trials(ll) 166 | call factor(n,rcoeffs((ii-1)*n+1:(ii)*n),icoeffs((ii-1)*n+1:(ii)*n),Q,D,C,B2) 167 | call zamvw2(n,Q,D,C,B2,reigs,ieigs,its,flag,n-1,0) 168 | 169 | end do 170 | 171 | 172 | CALL SYSTEM_CLOCK(COUNT=clock_end) 173 | time = dble(clock_end - clock_start)/dble(clock_rate) 174 | time = time/dble(num_trials(ll)) 175 | 176 | do ii=1,num_trials_error(ll) 177 | call factor(n,rcoeffs((ii-1)*n+1:(ii)*n),icoeffs((ii-1)*n+1:(ii)*n),Q,D,C,B2) 178 | call zamvw2(n,Q,D,C,B2,reigs,ieigs,its,flag,n-1,0) 179 | 180 | it = 0 181 | do jj=1,n 182 | it = it + its(jj) 183 | roots(jj) = complex(reigs(jj),ieigs(jj)) 184 | !print*, roots(jj), abs(roots(jj)) 185 | end do 186 | call RESCHECK(0,N,0,1,POLY((ii-1)*n+1:ii*n),COEFFS,ROOTS,ALLROOTS,RES) 187 | 188 | do jj=1,6 189 | do kk=1,N 190 | if(res(kk,jj) > error(jj))then 191 | error(jj) = res(kk,jj) 192 | end if 193 | end do 194 | end do 195 | 196 | end do 197 | 198 | 199 | print*, time 200 | print*, error(:) 201 | 202 | write (8,*) time 203 | write (18,*) error(:) 204 | 205 | write(*,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 206 | & time, ")%" 207 | write(28,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 208 | & time, ")%" 209 | 210 | write(*,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 211 | & error(1), ")%" 212 | write(38,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 213 | & error(1), ")%" 214 | 215 | if (ll == 15) then 216 | write(28,"(A,1x,F6.3,1x,A,1x,I7,1x,A,1x,ES10.4E2,1x,A)"), & 217 | &"%\node[coordinate,pin=below:{AMVW:", time,& 218 | &"}] at (axis cs:",deg(ll),",",time,"){};" 219 | write(*,"(A,1x,F6.3,1x,A,1x,I7,1x,A,1x,ES10.4E2,1x,A)"), & 220 | &"%\node[coordinate,pin=below:{AMVW:", time,& 221 | &"}] at (axis cs:",deg(ll),",",time,"){};" 222 | end if 223 | 224 | 225 | 226 | ! LAPACK 227 | if (ll<=14) then 228 | write(*,*) "LAPACK" 229 | error = 0d0 230 | res = 0d0 231 | CALL SYSTEM_CLOCK(COUNT_RATE=clock_rate) 232 | CALL SYSTEM_CLOCK(COUNT=clock_start) 233 | do ii=1,num_trials(ll) 234 | do jj=1,N 235 | poly(jj) = complex(rcoeffs(jj+(ii-1)*n),icoeffs(jj+(ii-1)*n)) 236 | end do 237 | 238 | B = complex(0.d0,0.d0) 239 | B(1,:) = -poly(2:N+1) 240 | do kk=1,(N-1) 241 | B(kk+1,kk) = complex(1.d0,0.d0) 242 | end do 243 | 244 | call ZHSEQR('E','N',N,1,N,B,N,roots,Y,N,cwork,N,info) 245 | end do 246 | 247 | CALL SYSTEM_CLOCK(COUNT=clock_end) 248 | time = dble(clock_end - clock_start)/dble(clock_rate) 249 | time = time/dble(num_trials(ll)) 250 | do ii=1,num_trials_error(ll) 251 | do jj=1,N 252 | poly(jj) = complex(rcoeffs(jj+(ii-1)*n),icoeffs(jj+(ii-1)*n)) 253 | end do 254 | 255 | B = complex(0.d0,0.d0) 256 | B(1,:) = -poly(2:N+1) 257 | do kk=1,(N-1) 258 | B(kk+1,kk) = complex(1.d0,0.d0) 259 | end do 260 | 261 | call ZHSEQR('E','N',N,1,N,B,N,roots,Y,N,cwork,N,info) 262 | call RESCHECK(0,N,0,1,POLY(2:N+1),COEFFS,ROOTS,ALLROOTS,RES) 263 | 264 | do jj=1,6 265 | do kk=1,N 266 | if(res(kk,jj) > error(jj))then 267 | error(jj) = res(kk,jj) 268 | end if 269 | end do 270 | end do 271 | end do 272 | 273 | print*, time 274 | print*, error(:) 275 | write (11,*) time 276 | write (21,*) error(:) 277 | write(*,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 278 | & time, ")%" 279 | write(31,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 280 | & time, ")%" 281 | 282 | write(*,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 283 | & error(1), ")%" 284 | write(41,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 285 | & error(1), ")%" 286 | end if 287 | 288 | ! LAPACK 289 | if (ll<=14) then 290 | write(*,*) "LAPACK" 291 | error = 0d0 292 | res = 0d0 293 | CALL SYSTEM_CLOCK(COUNT_RATE=clock_rate) 294 | CALL SYSTEM_CLOCK(COUNT=clock_start) 295 | do ii=1,num_trials(ll) 296 | do jj=1,N 297 | poly(jj) = complex(rcoeffs(jj+(ii-1)*n),icoeffs(jj+(ii-1)*n)) 298 | end do 299 | 300 | B = complex(0.d0,0.d0) 301 | B(1,:) = -poly(2:N+1) 302 | do kk=1,(N-1) 303 | B(kk+1,kk) = complex(1.d0,0.d0) 304 | end do 305 | 306 | call ZGEEV('N','N',N,B,N,roots,Y,N,Y,N,cwork,5*N,rwork,info) 307 | end do 308 | 309 | CALL SYSTEM_CLOCK(COUNT=clock_end) 310 | time = dble(clock_end - clock_start)/dble(clock_rate) 311 | time = time/dble(num_trials(ll)) 312 | do ii=1,num_trials_error(ll) 313 | do jj=1,N 314 | poly(jj) = complex(rcoeffs(jj+(ii-1)*n),icoeffs(jj+(ii-1)*n)) 315 | end do 316 | 317 | B = complex(0.d0,0.d0) 318 | B(1,:) = -poly(2:N+1) 319 | do kk=1,(N-1) 320 | B(kk+1,kk) = complex(1.d0,0.d0) 321 | end do 322 | 323 | call ZGEEV('N','N',N,B,N,roots,Y,N,Y,N,cwork,5*N,rwork,info) 324 | call RESCHECK(0,N,0,1,POLY(2:N+1),COEFFS,ROOTS,ALLROOTS,RES) 325 | 326 | do jj=1,6 327 | do kk=1,N 328 | if(res(kk,jj) > error(jj))then 329 | error(jj) = res(kk,jj) 330 | end if 331 | end do 332 | end do 333 | end do 334 | 335 | print*, time 336 | print*, error(:) 337 | write (11,*) time 338 | write (21,*) error(:) 339 | write(*,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 340 | & time, ")%" 341 | write(33,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 342 | & time, ")%" 343 | 344 | write(*,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 345 | & error(1), ")%" 346 | write(43,"(A,I7,1x,A,1x,ES10.4E2,1x,A)"), "(", deg(ll), ",", & 347 | & error(1), ")%" 348 | end if 349 | 350 | 351 | ! free memory 352 | deallocate(Q,D,C,B2,rcoeffs,icoeffs) 353 | deallocate(its,reigs,ieigs,rnew,inew) 354 | deallocate(residuals) 355 | deallocate(poly,roots,allroots,iterations,res) 356 | deallocate(B,Y,cwork,alpha,rwork) 357 | 358 | end do 359 | 360 | write (28,*) "};" 361 | write (38,*) "};" 362 | write (31,*) "};" 363 | write (41,*) "};" 364 | write (33,*) "};" 365 | write (43,*) "};" 366 | 367 | write (28,*) "" 368 | write (38,*) "" 369 | write (31,*) "" 370 | write (41,*) "" 371 | write (33,*) "" 372 | write (43,*) "" 373 | 374 | close(8) 375 | close(18) 376 | close(28) 377 | close(38) 378 | close(11) 379 | close(21) 380 | close(31) 381 | close(41) 382 | close(33) 383 | close(43) 384 | 385 | 386 | end program 387 | -------------------------------------------------------------------------------- /deps/singleshift/src/rescheck.f90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Aurentz² Vandebril³ Watkins² 3 | ! 4 | ! ²Dept. Mathematics, Washington State University 5 | ! ³Dept. Computer Science, KU Leuven 6 | ! 7 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8 | ! 9 | ! Residual check, includes newton steps 10 | ! 11 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 12 | subroutine RESCHECK(BANDSWITCH,N,K,NEWTNUM,POLY,COEFFS,ROOTS,ALLROOTS,RESIDUALS) 13 | 14 | implicit none 15 | 16 | integer, intent(in) :: BANDSWITCH,N,K,newtnum 17 | complex(kind(1d0)), intent(in) :: poly(N),roots(N),coeffs(N,K) 18 | double precision, intent(inout) :: residuals(N,3*(newtnum+1)) 19 | complex(kind(1d0)), intent(inout) :: allroots(N,newtnum+1) 20 | 21 | if(BANDSWITCH == 0)then 22 | 23 | call COMPRESCHECK(N,newtnum,poly,roots,allroots,residuals) 24 | 25 | else if(BANDSWITCH == 1)then 26 | 27 | call CONGRESCHECK(N,K,NEWTNUM,POLY,COEFFS,ROOTS,ALLROOTS,RESIDUALS) 28 | 29 | else 30 | 31 | write(*,*) "Not a valid argument for BANDSWITCH!" 32 | return 33 | 34 | end if 35 | 36 | 37 | end subroutine 38 | 39 | ! ********************************************** 40 | ! August 17, 2012 41 | ! ********************************************** 42 | ! 43 | ! This subroutine computes three residuals for each computed root, lambda, 44 | ! of a polynomial P(x). It is also capable of applying an arbitrary number 45 | ! of Newton iterations to each computed root. 46 | ! 47 | ! The residuals are |P(lambda)/P'(lambda)|, |P(lambda)/P'(lambda)/lambda|, and 48 | ! ||Cv-lambda v||/||C||/||v||, in the inifinity norm where C is the Companion Matrix 49 | ! and v is the eigenvectro associated with lambda. 50 | ! 51 | ! ************************************************************** 52 | ! 53 | ! Input variables: 54 | ! 55 | ! POLY complex array of length N, containing the nonleading 56 | ! coefficients of P (ordered with decreasing N). P must be 57 | ! monic 58 | ! 59 | ! N N of polynomial 60 | ! 61 | ! 62 | ! ROOTS complex array of length N, containing the computed roots 63 | ! of Poly 64 | ! 65 | ! NEWTNUM a non-negative integer specifying the number of Newton iterations 66 | ! zero is acceptable. 67 | ! 68 | ! Output variables: 69 | ! 70 | ! ALLROOTS complex array of dimension (N,NEWTNUM+1) contains the original roots 71 | ! as well as any newton corrections 72 | ! 73 | ! RESIDUALS double precision array of dimension (N,3*(NEWTNUM+1)). 74 | ! each row of RESIDUALS corresponds to one root of POLY. 75 | ! columns are in sets of three, with the columns 1, 2 and 3 corresponding 76 | ! to the three residuals mentioned above respectively. Every set of three 77 | ! columns corresponds to a Newton iteration except for the first one. 78 | ! 79 | ! *************************************************************** 80 | 81 | subroutine COMPRESCHECK(N,newtnum,poly,roots,allroots,residuals) 82 | 83 | implicit none 84 | 85 | integer, intent(in) :: N,newtnum 86 | complex(kind(1d0)), intent(in) :: poly(N),roots(N) 87 | double precision, intent(inout) :: residuals(N,3*(newtnum+1)) 88 | complex(kind(1d0)), intent(inout) :: allroots(N,newtnum+1) 89 | 90 | integer ii,jj,kk 91 | double precision :: Cnorm 92 | complex(kind(1d0)) :: f, fprime, lambda 93 | 94 | ! initialize allroots 95 | allroots = complex(0d0,0d0) 96 | allroots(:,1) = roots 97 | 98 | ! Matrix infinity norms 99 | Cnorm = 0d0 100 | do ii=1,N 101 | Cnorm = Cnorm + abs(poly(ii)) 102 | end do 103 | 104 | Cnorm = dmax1(1d0,Cnorm) 105 | 106 | ! Function evaluations and Newton Corrections 107 | do ii=1,N 108 | 109 | do jj=1,(newtnum+1) 110 | ! Roots inside or on the unit circle 111 | if(abs(allroots(ii,jj)) <= 1d0)then 112 | ! function evals 113 | lambda = allroots(ii,jj) 114 | f = lambda + poly(1) 115 | fprime = complex(dble(N),0d0)*f - poly(1) 116 | do kk=2,(N-1) 117 | f = lambda*f + poly(kk) 118 | fprime = lambda*fprime + complex(dble(N-kk),0d0)*poly(kk) 119 | end do 120 | f = f*lambda + poly(N) 121 | 122 | ! Store residuals 123 | residuals(ii,3*(jj-1)+1) = abs(f/fprime) 124 | residuals(ii,3*(jj-1)+2) = abs(f/fprime/lambda) 125 | residuals(ii,3*(jj-1)+3) = abs(f)/Cnorm 126 | 127 | ! Newton correction 128 | if((newtnum+1-jj) > 0)then 129 | lambda = lambda - f/fprime 130 | allroots(ii,jj+1) = lambda 131 | end if 132 | ! Roots outside the unit circle 133 | else 134 | ! function evals 135 | lambda = complex(1d0,0d0)/allroots(ii,jj) 136 | f = poly(N)*lambda + poly(N-1) 137 | fprime = complex(dble(N),0d0)*f - poly(N-1) 138 | do kk=2,(N-1) 139 | f = lambda*f + poly(N-kk) 140 | fprime = lambda*fprime + complex(dble(N-kk),0d0)*poly(N-kk) 141 | end do 142 | f = f*lambda + complex(1d0,0d0) 143 | 144 | ! Store residuals 145 | residuals(ii,3*(jj-1)+1) = abs(f/fprime*lambda*lambda) 146 | residuals(ii,3*(jj-1)+2) = abs(f/fprime*lambda) 147 | residuals(ii,3*(jj-1)+3) = abs(f*lambda)/Cnorm 148 | 149 | ! Newton correction 150 | if((newtnum+1-jj) > 0)then 151 | lambda = lambda - f/fprime 152 | allroots(ii,jj+1) = complex(1d0,0d0)/lambda 153 | end if 154 | end if 155 | end do 156 | end do 157 | 158 | 159 | end subroutine 160 | 161 | 162 | ! ********************************************** 163 | ! August 17, 2012 164 | ! ********************************************** 165 | ! 166 | ! This subroutine computes three residuals for each computed root, lambda, 167 | ! of a polynomial P(x). It is also capable of applying an arbitrary number 168 | ! of Newton iterations to each computed root. 169 | ! 170 | ! The residuals are |P(lambda)/P'(lambda)|, |P(lambda)/P'(lambda)/lambda|, and 171 | ! ||Cv-lambda v||/||C||/||v||, in the inifinity norm where C is the Companion Matrix 172 | ! and v is the eigenvectro associated with lambda. 173 | ! 174 | ! ************************************************************** 175 | ! 176 | ! Input variables: 177 | ! 178 | ! N degree of polynomial 179 | ! 180 | ! K Bandwidth of upper-triangular matrix 181 | ! 182 | ! POLY complex array of length N, containing the nonleading 183 | ! coefficients of P (ordered with decreasing N). P must be 184 | ! monic 185 | ! 186 | ! COEFFS complex array of dimension (N,K) containing the recursion 187 | ! coefficients for the polynomial basis, COEFFS(1,1) must be 1 188 | ! 189 | ! 190 | ! ROOTS complex array of length N, containing the computed roots 191 | ! of Poly 192 | ! 193 | ! NEWTNUM a non-negative integer specifying the number of Newton iterations 194 | ! zero is acceptable. 195 | ! 196 | ! Output variables: 197 | ! 198 | ! ALLROOTS complex array of dimension (N,NEWTNUM+1) contains the original roots 199 | ! as well as any newton corrections 200 | ! 201 | ! RESIDUALS double precision array of dimension (N,3*(NEWTNUM+1)). 202 | ! each row of RESIDUALS corresponds to one root of POLY. 203 | ! columns are in sets of three, with the columns 1, 2 and 3 corresponding 204 | ! to the three residuals mentioned above respectively. Every set of three 205 | ! columns corresponds to a Newton iteration except for the first one. 206 | ! 207 | ! *************************************************************** 208 | 209 | subroutine CONGRESCHECK(N,K,NEWTNUM,POLY,COEFFS,ROOTS,ALLROOTS,RESIDUALS) 210 | 211 | implicit none 212 | 213 | integer, intent(in) :: N,K,newtnum 214 | complex(kind(1d0)), intent(in) :: poly(N),roots(N),coeffs(N,K) 215 | double precision, intent(inout) :: residuals(N,3*(newtnum+1)) 216 | complex(kind(1d0)), intent(inout) :: allroots(N,newtnum+1) 217 | 218 | integer ii,jj,kk,ll,length 219 | double precision :: Cnorm,temp,Pnorm 220 | complex(kind(1d0)) :: f, fprime, lambda 221 | complex(kind(1d0)), allocatable :: P(:),Pprime(:) 222 | 223 | ! allocate memory 224 | allocate(P(N+1),Pprime(N+1)) 225 | 226 | ! initialize residuals 227 | residuals = 10d0 228 | 229 | ! initialize allroots 230 | allroots = complex(0d0,0d0) 231 | allroots(:,1) = roots 232 | 233 | ! Matrix infinity norm 234 | P = poly 235 | P(1:(K-1)) = P(1:(K-1))- Coeffs(1,2:K) 236 | 237 | Cnorm = 0d0 238 | do ii=1,N 239 | Cnorm = Cnorm + abs(P(ii)) 240 | end do 241 | 242 | do ii=2,N 243 | temp = 0d0 244 | length = min(K,N+2-ii) 245 | do jj=1,length 246 | temp = temp + abs(Coeffs(ii,jj)) 247 | end do 248 | 249 | if(temp > Cnorm)then 250 | Cnorm = temp 251 | end if 252 | end do 253 | 254 | ! Function evaluations and Newton Corrections 255 | do ii=1,N 256 | 257 | do jj=1,(newtnum+1) 258 | ! Roots inside or on the unit circle 259 | if(abs(allroots(ii,jj)) <= 1d0)then 260 | ! function evals 261 | lambda = allroots(ii,jj) 262 | 263 | ! P_k(lambda) 264 | P(1) = complex(1d0,0d0) 265 | 266 | if(K == 1)then 267 | P(2) = lambda/Coeffs(N,1) 268 | else 269 | P(2) = (lambda - Coeffs(N,2))/Coeffs(N,1) 270 | end if 271 | 272 | do kk=1,(N-1) 273 | if(K == 1)then 274 | P(kk+2) = lambda*P(kk+1)/Coeffs(N-kk,1) 275 | else 276 | P(kk+2) = (lambda - Coeffs(N-kk,2))*P(kk+1) 277 | 278 | length=min(kk,K-2) 279 | do ll=1,length 280 | P(kk+2) = P(kk+2) - Coeffs(N-kk,2+ll)*P(kk+1-ll) 281 | end do 282 | 283 | P(kk+2) = P(kk+2)/Coeffs(N-kk,1) 284 | end if 285 | end do 286 | 287 | ! P'_k(lambda) 288 | Pprime(1) = complex(0d0,0d0) 289 | 290 | Pprime(2) = complex(1d0,0d0)/Coeffs(N,1) 291 | 292 | do kk=1,(N-1) 293 | if(K == 1)then 294 | Pprime(kk+2) = (lambda*Pprime(kk+1) + P(kk+1))/Coeffs(N-kk,1) 295 | else 296 | Pprime(kk+2) = (lambda - Coeffs(N-kk,2))*Pprime(kk+1) + P(kk+1) 297 | length=min(kk,K-2) 298 | do ll=1,length 299 | Pprime(kk+2) = Pprime(kk+2) - Coeffs(N-kk,2+ll)*Pprime(kk+1-ll) 300 | end do 301 | 302 | Pprime(kk+2) = Pprime(kk+2)/Coeffs(N-kk,1) 303 | 304 | end if 305 | end do 306 | 307 | ! compute vector norm 308 | Pnorm = abs(P(1)) 309 | do kk=2,N+1 310 | temp = abs(P(kk)) 311 | if(temp > Pnorm)then 312 | Pnorm = temp 313 | end if 314 | end do 315 | 316 | !P(lambda) and P'(lambda) 317 | f = P(N+1) 318 | fprime = Pprime(N+1) 319 | do kk=1,N 320 | f = f + poly(kk)*P(N+1-kk) 321 | fprime = fprime + poly(kk)*Pprime(N+1-kk) 322 | end do 323 | 324 | 325 | !write(*,*) "f' =",fprime 326 | !write(*,*) "f =",f 327 | !P(1) = (lambda - Coeffs(1,2))/Coeffs(1,1) + poly(1) 328 | !P(2) = (lambda - Coeffs(2,2))*P(1)/Coeffs(2,1) - Coeffs(1,3)/Coeffs(1,1) + poly(2) 329 | !do kk = 3,N 330 | !P(kk) = (lambda - Coeffs(kk,2))*P(kk-1)/Coeffs(kk,1) - Coeffs(kk-1,3)*P(kk-2)/Coeffs(kk-1,1) + poly(kk) 331 | !end do 332 | !write(*,*) "f =",P(N) 333 | !return 334 | ! Store residuals 335 | residuals(ii,3*(jj-1)+1) = abs(f/fprime) 336 | residuals(ii,3*(jj-1)+2) = abs(f/fprime/lambda) 337 | residuals(ii,3*(jj-1)+3) = abs(f)/Cnorm/Pnorm 338 | 339 | ! Newton correction 340 | if((newtnum+1-jj) > 0)then 341 | lambda = lambda - f/fprime 342 | allroots(ii,jj+1) = lambda 343 | end if 344 | ! Roots outside the unit circle 345 | else 346 | ! function evals 347 | lambda = allroots(ii,jj) 348 | 349 | ! P_k(lambda) 350 | P(1) = complex(1d0,0d0)/lambda 351 | Pprime(1) = complex(0d0,0d0) 352 | 353 | if(K == 1)then 354 | P(2) = P(1)/Coeffs(N,1) 355 | Pprime(2) = complex(1d0,0d0)/Coeffs(N,1)/lambda/lambda 356 | else 357 | P(2) = (lambda - Coeffs(N,2))*P(1)/Coeffs(N,1)/lambda 358 | Pprime(2) = complex(1d0,0d0)/Coeffs(N,1)/lambda/lambda 359 | end if 360 | 361 | P(1) = P(1)/lambda 362 | 363 | do kk=1,(N-1) 364 | if(K == 1)then 365 | P(kk+2) = P(kk+1)/Coeffs(N-kk,1) 366 | Pprime(kk+2) = (lambda*Pprime(kk+1) + P(kk+1))/Coeffs(N-kk,1) 367 | else 368 | P(kk+2) = (lambda - Coeffs(N-kk,2))*P(kk+1)/lambda 369 | Pprime(kk+2) = (lambda - Coeffs(N-kk,2))*Pprime(kk+1) + P(kk+1) 370 | 371 | length=min(kk,K-2) 372 | do ll=1,length 373 | P(kk+2) = P(kk+2) - Coeffs(N-kk,2+ll)*P(kk+1-ll)/lambda 374 | Pprime(kk+2) = Pprime(kk+2) - Coeffs(N-kk,2+ll)*Pprime(kk+1-ll) 375 | end do 376 | 377 | P(kk+2) = P(kk+2)/Coeffs(N-kk,1) 378 | Pprime(kk+2) = Pprime(kk+2)/Coeffs(N-kk,1) 379 | 380 | end if 381 | 382 | P(1:kk+1) = P(1:kk+1)/lambda 383 | Pprime(2:kk+2) = Pprime(2:kk+2)/lambda 384 | 385 | end do 386 | 387 | ! compute vector norm 388 | Pnorm = abs(P(1)) 389 | do kk=2,N+1 390 | temp = abs(P(kk)) 391 | if(temp > Pnorm)then 392 | Pnorm = temp 393 | end if 394 | end do 395 | 396 | !P(lambda) and P'(lambda) 397 | f = P(N+1) 398 | fprime = Pprime(N+1) 399 | 400 | do kk=1,N 401 | f = f + poly(kk)*P(N+1-kk) 402 | fprime = fprime + poly(kk)*Pprime(N+1-kk) 403 | end do 404 | 405 | ! Store residuals 406 | residuals(ii,3*(jj-1)+1) = abs(f/fprime) 407 | residuals(ii,3*(jj-1)+2) = abs(f/fprime/lambda) 408 | residuals(ii,3*(jj-1)+3) = abs(f)/Cnorm/Pnorm 409 | 410 | ! Newton correction 411 | if((newtnum+1-jj) > 0)then 412 | lambda = lambda - f/fprime 413 | allroots(ii,jj+1) = lambda 414 | end if 415 | end if 416 | end do 417 | end do 418 | 419 | ! free memory 420 | deallocate(P,Pprime) 421 | 422 | 423 | end subroutine 424 | -------------------------------------------------------------------------------- /deps/doubleshift/src/RESCHECK.f90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | ! Aurentz² Vandebril³ Watkins² 3 | ! 4 | ! ²Dept. Mathematics, Washington State University 5 | ! ³Dept. Computer Science, KU Leuven 6 | ! 7 | ! see http://www.math.wsu.edu/students/jaurentz/ 8 | ! 9 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 10 | ! Residual check, function can also perform a 11 | ! Newton step 12 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 13 | subroutine RESCHECK(BANDSWITCH,N,K,NEWTNUM,POLY,COEFFS,ROOTS,ALLROOTS,RESIDUALS) 14 | 15 | implicit none 16 | 17 | integer, intent(in) :: BANDSWITCH,N,K,newtnum 18 | complex(kind(1d0)), intent(in) :: poly(N),roots(N),coeffs(N,K) 19 | double precision, intent(inout) :: residuals(N,3*(newtnum+1)) 20 | complex(kind(1d0)), intent(inout) :: allroots(N,newtnum+1) 21 | 22 | if(BANDSWITCH == 0)then 23 | 24 | call COMPRESCHECK(N,newtnum,poly,roots,allroots,residuals) 25 | 26 | else if(BANDSWITCH == 1)then 27 | 28 | call CONGRESCHECK(N,K,NEWTNUM,POLY,COEFFS,ROOTS,ALLROOTS,RESIDUALS) 29 | 30 | else 31 | 32 | write(*,*) "Not a valid argument for BANDSWITCH!" 33 | return 34 | 35 | end if 36 | 37 | 38 | end subroutine 39 | 40 | ! ********************************************** 41 | ! August 17, 2012 42 | ! ********************************************** 43 | ! 44 | ! This subroutine computes three residuals for each computed root, lambda, 45 | ! of a polynomial P(x). It is also capable of applying an arbitrary number 46 | ! of Newton iterations to each computed root. 47 | ! 48 | ! The residuals are |P(lambda)/P'(lambda)|, |P(lambda)/P'(lambda)/lambda|, and 49 | ! ||Cv-lambda v||/||C||/||v||, in the inifinity norm where C is the Companion Matrix 50 | ! and v is the eigenvectro associated with lambda. 51 | ! 52 | ! ************************************************************** 53 | ! 54 | ! Input variables: 55 | ! 56 | ! POLY complex array of length N, containing the nonleading 57 | ! coefficients of P (ordered with decreasing N). P must be 58 | ! monic 59 | ! 60 | ! N N of polynomial 61 | ! 62 | ! 63 | ! ROOTS complex array of length N, containing the computed roots 64 | ! of Poly 65 | ! 66 | ! NEWTNUM a non-negative integer specifying the number of Newton iterations 67 | ! zero is acceptable. 68 | ! 69 | ! Output variables: 70 | ! 71 | ! ALLROOTS complex array of dimension (N,NEWTNUM+1) contains the original roots 72 | ! as well as any newton corrections 73 | ! 74 | ! RESIDUALS double precision array of dimension (N,3*(NEWTNUM+1)). 75 | ! each row of RESIDUALS corresponds to one root of POLY. 76 | ! columns are in sets of three, with the columns 1, 2 and 3 corresponding 77 | ! to the three residuals mentioned above respectively. Every set of three 78 | ! columns corresponds to a Newton iteration except for the first one. 79 | ! 80 | ! *************************************************************** 81 | 82 | subroutine COMPRESCHECK(N,newtnum,poly,roots,allroots,residuals) 83 | 84 | implicit none 85 | 86 | integer, intent(in) :: N,newtnum 87 | complex(kind(1d0)), intent(in) :: poly(N),roots(N) 88 | double precision, intent(inout) :: residuals(N,3*(newtnum+1)) 89 | complex(kind(1d0)), intent(inout) :: allroots(N,newtnum+1) 90 | 91 | integer ii,jj,kk 92 | double precision :: Cnorm 93 | complex(kind(1d0)) :: f, fprime, lambda 94 | 95 | ! initialize allroots 96 | allroots = complex(0d0,0d0) 97 | allroots(:,1) = roots 98 | 99 | ! Matrix infinity norms 100 | Cnorm = 0d0 101 | do ii=1,N 102 | Cnorm = Cnorm + abs(poly(ii)) 103 | end do 104 | 105 | Cnorm = dmax1(1d0,Cnorm) 106 | 107 | ! Function evaluations and Newton Corrections 108 | do ii=1,N 109 | 110 | do jj=1,(newtnum+1) 111 | ! Roots inside or on the unit circle 112 | if(abs(allroots(ii,jj)) <= 1d0)then 113 | ! function evals 114 | lambda = allroots(ii,jj) 115 | f = lambda + poly(1) 116 | fprime = complex(dble(N),0d0)*f - poly(1) 117 | do kk=2,(N-1) 118 | f = lambda*f + poly(kk) 119 | fprime = lambda*fprime + complex(dble(N-kk),0d0)*poly(kk) 120 | end do 121 | f = f*lambda + poly(N) 122 | 123 | ! Store residuals 124 | residuals(ii,3*(jj-1)+1) = abs(f/fprime) 125 | residuals(ii,3*(jj-1)+2) = abs(f/fprime/lambda) 126 | residuals(ii,3*(jj-1)+3) = abs(f)/Cnorm 127 | 128 | ! Newton correction 129 | if((newtnum+1-jj) > 0)then 130 | lambda = lambda - f/fprime 131 | allroots(ii,jj+1) = lambda 132 | end if 133 | ! Roots outside the unit circle 134 | else 135 | ! function evals 136 | lambda = complex(1d0,0d0)/allroots(ii,jj) 137 | f = poly(N)*lambda + poly(N-1) 138 | fprime = complex(dble(N),0d0)*f - poly(N-1) 139 | do kk=2,(N-1) 140 | f = lambda*f + poly(N-kk) 141 | fprime = lambda*fprime + complex(dble(N-kk),0d0)*poly(N-kk) 142 | end do 143 | f = f*lambda + complex(1d0,0d0) 144 | 145 | ! Store residuals 146 | residuals(ii,3*(jj-1)+1) = abs(f/fprime*lambda*lambda) 147 | residuals(ii,3*(jj-1)+2) = abs(f/fprime*lambda) 148 | residuals(ii,3*(jj-1)+3) = abs(f*lambda)/Cnorm 149 | 150 | ! Newton correction 151 | if((newtnum+1-jj) > 0)then 152 | lambda = lambda - f/fprime 153 | allroots(ii,jj+1) = complex(1d0,0d0)/lambda 154 | end if 155 | end if 156 | end do 157 | end do 158 | 159 | 160 | end subroutine 161 | 162 | 163 | ! ********************************************** 164 | ! August 17, 2012 165 | ! ********************************************** 166 | ! 167 | ! This subroutine computes three residuals for each computed root, lambda, 168 | ! of a polynomial P(x). It is also capable of applying an arbitrary number 169 | ! of Newton iterations to each computed root. 170 | ! 171 | ! The residuals are |P(lambda)/P'(lambda)|, |P(lambda)/P'(lambda)/lambda|, and 172 | ! ||Cv-lambda v||/||C||/||v||, in the inifinity norm where C is the Companion Matrix 173 | ! and v is the eigenvectro associated with lambda. 174 | ! 175 | ! ************************************************************** 176 | ! 177 | ! Input variables: 178 | ! 179 | ! N degree of polynomial 180 | ! 181 | ! K Bandwidth of upper-triangular matrix 182 | ! 183 | ! POLY complex array of length N, containing the nonleading 184 | ! coefficients of P (ordered with decreasing N). P must be 185 | ! monic 186 | ! 187 | ! COEFFS complex array of dimension (N,K) containing the recursion 188 | ! coefficients for the polynomial basis, COEFFS(1,1) must be 1 189 | ! 190 | ! 191 | ! ROOTS complex array of length N, containing the computed roots 192 | ! of Poly 193 | ! 194 | ! NEWTNUM a non-negative integer specifying the number of Newton iterations 195 | ! zero is acceptable. 196 | ! 197 | ! Output variables: 198 | ! 199 | ! ALLROOTS complex array of dimension (N,NEWTNUM+1) contains the original roots 200 | ! as well as any newton corrections 201 | ! 202 | ! RESIDUALS double precision array of dimension (N,3*(NEWTNUM+1)). 203 | ! each row of RESIDUALS corresponds to one root of POLY. 204 | ! columns are in sets of three, with the columns 1, 2 and 3 corresponding 205 | ! to the three residuals mentioned above respectively. Every set of three 206 | ! columns corresponds to a Newton iteration except for the first one. 207 | ! 208 | ! *************************************************************** 209 | 210 | subroutine CONGRESCHECK(N,K,NEWTNUM,POLY,COEFFS,ROOTS,ALLROOTS,RESIDUALS) 211 | 212 | implicit none 213 | 214 | integer, intent(in) :: N,K,newtnum 215 | complex(kind(1d0)), intent(in) :: poly(N),roots(N),coeffs(N,K) 216 | double precision, intent(inout) :: residuals(N,3*(newtnum+1)) 217 | complex(kind(1d0)), intent(inout) :: allroots(N,newtnum+1) 218 | 219 | integer ii,jj,kk,ll,length 220 | double precision :: Cnorm,temp,Pnorm 221 | complex(kind(1d0)) :: f, fprime, lambda 222 | complex(kind(1d0)), allocatable :: P(:),Pprime(:) 223 | 224 | ! allocate memory 225 | allocate(P(N+1),Pprime(N+1)) 226 | 227 | ! initialize residuals 228 | residuals = 10d0 229 | 230 | ! initialize allroots 231 | allroots = complex(0d0,0d0) 232 | allroots(:,1) = roots 233 | 234 | ! Matrix infinity norm 235 | P = poly 236 | P(1:(K-1)) = P(1:(K-1))- Coeffs(1,2:K) 237 | 238 | Cnorm = 0d0 239 | do ii=1,N 240 | Cnorm = Cnorm + abs(P(ii)) 241 | end do 242 | 243 | do ii=2,N 244 | temp = 0d0 245 | length = min(K,N+2-ii) 246 | do jj=1,length 247 | temp = temp + abs(Coeffs(ii,jj)) 248 | end do 249 | 250 | if(temp > Cnorm)then 251 | Cnorm = temp 252 | end if 253 | end do 254 | 255 | ! Function evaluations and Newton Corrections 256 | do ii=1,N 257 | 258 | do jj=1,(newtnum+1) 259 | ! Roots inside or on the unit circle 260 | if(abs(allroots(ii,jj)) <= 1d0)then 261 | ! function evals 262 | lambda = allroots(ii,jj) 263 | 264 | ! P_k(lambda) 265 | P(1) = complex(1d0,0d0) 266 | 267 | if(K == 1)then 268 | P(2) = lambda/Coeffs(N,1) 269 | else 270 | P(2) = (lambda - Coeffs(N,2))/Coeffs(N,1) 271 | end if 272 | 273 | do kk=1,(N-1) 274 | if(K == 1)then 275 | P(kk+2) = lambda*P(kk+1)/Coeffs(N-kk,1) 276 | else 277 | P(kk+2) = (lambda - Coeffs(N-kk,2))*P(kk+1) 278 | 279 | length=min(kk,K-2) 280 | do ll=1,length 281 | P(kk+2) = P(kk+2) - Coeffs(N-kk,2+ll)*P(kk+1-ll) 282 | end do 283 | 284 | P(kk+2) = P(kk+2)/Coeffs(N-kk,1) 285 | end if 286 | end do 287 | 288 | ! P'_k(lambda) 289 | Pprime(1) = complex(0d0,0d0) 290 | 291 | Pprime(2) = complex(1d0,0d0)/Coeffs(N,1) 292 | 293 | do kk=1,(N-1) 294 | if(K == 1)then 295 | Pprime(kk+2) = (lambda*Pprime(kk+1) + P(kk+1))/Coeffs(N-kk,1) 296 | else 297 | Pprime(kk+2) = (lambda - Coeffs(N-kk,2))*Pprime(kk+1) + P(kk+1) 298 | length=min(kk,K-2) 299 | do ll=1,length 300 | Pprime(kk+2) = Pprime(kk+2) - Coeffs(N-kk,2+ll)*Pprime(kk+1-ll) 301 | end do 302 | 303 | Pprime(kk+2) = Pprime(kk+2)/Coeffs(N-kk,1) 304 | 305 | end if 306 | end do 307 | 308 | ! compute vector norm 309 | Pnorm = abs(P(1)) 310 | do kk=2,N+1 311 | temp = abs(P(kk)) 312 | if(temp > Pnorm)then 313 | Pnorm = temp 314 | end if 315 | end do 316 | 317 | !P(lambda) and P'(lambda) 318 | f = P(N+1) 319 | fprime = Pprime(N+1) 320 | do kk=1,N 321 | f = f + poly(kk)*P(N+1-kk) 322 | fprime = fprime + poly(kk)*Pprime(N+1-kk) 323 | end do 324 | 325 | 326 | !write(*,*) "f' =",fprime 327 | !write(*,*) "f =",f 328 | !P(1) = (lambda - Coeffs(1,2))/Coeffs(1,1) + poly(1) 329 | !P(2) = (lambda - Coeffs(2,2))*P(1)/Coeffs(2,1) - Coeffs(1,3)/Coeffs(1,1) + poly(2) 330 | !do kk = 3,N 331 | !P(kk) = (lambda - Coeffs(kk,2))*P(kk-1)/Coeffs(kk,1) - Coeffs(kk-1,3)*P(kk-2)/Coeffs(kk-1,1) + poly(kk) 332 | !end do 333 | !write(*,*) "f =",P(N) 334 | !return 335 | ! Store residuals 336 | residuals(ii,3*(jj-1)+1) = abs(f/fprime) 337 | residuals(ii,3*(jj-1)+2) = abs(f/fprime/lambda) 338 | residuals(ii,3*(jj-1)+3) = abs(f)/Cnorm/Pnorm 339 | 340 | ! Newton correction 341 | if((newtnum+1-jj) > 0)then 342 | lambda = lambda - f/fprime 343 | allroots(ii,jj+1) = lambda 344 | end if 345 | ! Roots outside the unit circle 346 | else 347 | ! function evals 348 | lambda = allroots(ii,jj) 349 | 350 | ! P_k(lambda) 351 | P(1) = complex(1d0,0d0)/lambda 352 | Pprime(1) = complex(0d0,0d0) 353 | 354 | if(K == 1)then 355 | P(2) = P(1)/Coeffs(N,1) 356 | Pprime(2) = complex(1d0,0d0)/Coeffs(N,1)/lambda/lambda 357 | else 358 | P(2) = (lambda - Coeffs(N,2))*P(1)/Coeffs(N,1)/lambda 359 | Pprime(2) = complex(1d0,0d0)/Coeffs(N,1)/lambda/lambda 360 | end if 361 | 362 | P(1) = P(1)/lambda 363 | 364 | do kk=1,(N-1) 365 | if(K == 1)then 366 | P(kk+2) = P(kk+1)/Coeffs(N-kk,1) 367 | Pprime(kk+2) = (lambda*Pprime(kk+1) + P(kk+1))/Coeffs(N-kk,1) 368 | else 369 | P(kk+2) = (lambda - Coeffs(N-kk,2))*P(kk+1)/lambda 370 | Pprime(kk+2) = (lambda - Coeffs(N-kk,2))*Pprime(kk+1) + P(kk+1) 371 | 372 | length=min(kk,K-2) 373 | do ll=1,length 374 | P(kk+2) = P(kk+2) - Coeffs(N-kk,2+ll)*P(kk+1-ll)/lambda 375 | Pprime(kk+2) = Pprime(kk+2) - Coeffs(N-kk,2+ll)*Pprime(kk+1-ll) 376 | end do 377 | 378 | P(kk+2) = P(kk+2)/Coeffs(N-kk,1) 379 | Pprime(kk+2) = Pprime(kk+2)/Coeffs(N-kk,1) 380 | 381 | end if 382 | 383 | P(1:kk+1) = P(1:kk+1)/lambda 384 | Pprime(2:kk+2) = Pprime(2:kk+2)/lambda 385 | 386 | end do 387 | 388 | ! compute vector norm 389 | Pnorm = abs(P(1)) 390 | do kk=2,N+1 391 | temp = abs(P(kk)) 392 | if(temp > Pnorm)then 393 | Pnorm = temp 394 | end if 395 | end do 396 | 397 | !P(lambda) and P'(lambda) 398 | f = P(N+1) 399 | fprime = Pprime(N+1) 400 | 401 | do kk=1,N 402 | f = f + poly(kk)*P(N+1-kk) 403 | fprime = fprime + poly(kk)*Pprime(N+1-kk) 404 | end do 405 | 406 | ! Store residuals 407 | residuals(ii,3*(jj-1)+1) = abs(f/fprime) 408 | residuals(ii,3*(jj-1)+2) = abs(f/fprime/lambda) 409 | residuals(ii,3*(jj-1)+3) = abs(f)/Cnorm/Pnorm 410 | 411 | ! Newton correction 412 | if((newtnum+1-jj) > 0)then 413 | lambda = lambda - f/fprime 414 | allroots(ii,jj+1) = lambda 415 | end if 416 | end if 417 | end do 418 | end do 419 | 420 | ! free memory 421 | deallocate(P,Pprime) 422 | 423 | 424 | end subroutine 425 | --------------------------------------------------------------------------------