F 3.3.3 Bauhuber's Method
SUBROUTINE BAUPOL(COEFRE,COEFIM,N,COMPL,ROOTRE,ROOTIM,NUMIT)
C
C*****************************************************************
C *
C Without knowing any approximations of the roots, this *
C SUBROUTINE finds N approximate values Z(I), I=1, ..., N for *
C the N zeros of a polynomial PN of degree N with real or *
C complex coefficients. *
C The polynomial is described as follows: *
C *
C PN(Z)=COEF(0)+COEF(1)*Z+COEF(2)*Z**2+...+COEF(N)*Z**N, *
C *
C with COEF(I) = (COEFRE(I),COEFIM(I)) for I=0, ..., N (complex *
C coefficients). *
C *
C *
C INPUT PARAMETERS: *
C ================= *
C COEFRE : (N+1)-vector COEFRE(0:N) containing the real *
C part of each coefficient of the polynomial PN in *
C DOUBLE PRECISION. *
C COEFIM : (N+1)-vector COEFIM(0:N) containing the imaginary *
C part of each coefficient of the polynomial PN in *
C DOUBLE PRECISION. *
C N : degree of the polynomial PN. *
C COMPL : boolean variable : *
C COMPL=.TRUE. , if the coefficients are COMPLEX. *
C COMPL=.FALSE. , if the coefficients are REAL. *
C *
C *
C OUTPUT PARAMETERS: *
C ================== *
C ROOTRE : N-vector ROOTRE(1:N) containing the approximate *
C real parts of the computed zeros of PN in *
C DOUBLE PRECISION. *
C ROOTIM : N-vector ROOTIM(1:N) containing the approximate *
C imaginary parts of the computed zeros of PN in *
C DOUBLE PRECISION. *
C NUMIT : maximum number of iteration steps. *
C *
C----------------------------------------------------------------*
C *
C subroutines required: BAUZRO, ABSCOM, CDIV, SCALFC, COMHOR *
C MCONST. *
C *
C *
C sources: Bauhuber, see [BAUH70]. *
C *
C*****************************************************************
C *
C author : Guido Dubois *
C date : 11.01.1985 *
C source : FORTRAN 77 *
C *
C*****************************************************************
C
COMMON /GLOBAL/A,B,C
DOUBLE PRECISION COEFRE(0:100),COEFIM(0:100),E(101),
+ ROOTRE(100),ROOTIM(100),A(202),B(202),
+ C(200),X0,Y0,XNEW,YNEW,GAMMA,FMACHP,INFINY,
+ SMALNO,BASE,SCALFC,BND,MAX,MIN,X,ABSCOM
LOGICAL COMPL
C
C Initializing the iteration step counter NUMIT and the error
C bound GAMMA.
C
NUMIT=0
GAMMA=5.0D-18
IF(N .EQ. 1) THEN
C
C If the degree of PN is N=1, then the zero of the polynomial PN is
C Z=-COEF(0)/COEF(1), where COEF(I)=(COEFRE(I),COEFIM(I)) for I=0,1.
C
CALL CDIV(-COEFRE(0),-COEFIM(0),COEFRE(1),COEFIM(1),
+ ROOTRE(1),ROOTIM(1))
RETURN
ELSE
N1=N+1
C
C Scaling via SCALFC.
C
DO 10 I=1,N1
E(I)=ABSCOM(COEFRE(N1-I),COEFIM(N1-I))
10 CONTINUE
CALL MCONST(FMACHP,INFINY,SMALNO,BASE)
BND=SCALFC(N1,E,FMACHP,INFINY,SMALNO,BASE)
IF(BND .EQ. 1.0D0) THEN
C
C Normalizing, in case scaling by SCALFC did not normalize the coefficients.
C
MAX=0.0D0
MIN=1.0D+300
DO 20 I=N,0,-1
X=ABSCOM(COEFRE(I),COEFIM(I))
IF(X .GT. MAX) MAX=X
IF(X .LT. MIN .AND. X .NE. 0.0D0) MIN=X
20 CONTINUE
BND=DSQRT(MAX*MIN)
BND=1.0D0/BND
END IF
DO 30 K=1,N1
B(2*K-1)=COEFRE(N1-K)*BND
B(2*K)=0.0D0
IF(COMPL) B(2*K)=COEFIM(N1-K)*BND
30 CONTINUE
X0=0.0D0
Y0=0.0D0
DO 40 I=1,N
L=2*(N+2-I)
DO 50 K=1,L
A(K)=B(K)
50 CONTINUE
C
C Calculating the I-th zero of PN.
C
CALL BAUZRO(X0,Y0,N+1-I,GAMMA,XNEW,YNEW,NUMIT)
ROOTRE(I)=XNEW
ROOTIM(I)=YNEW
X0=XNEW
Y0=-YNEW
40 CONTINUE
END IF
RETURN
END
C
C
SUBROUTINE BAUZRO(X0,Y0,N,GAMMA,XNEW,YNEW,NUMIT)
C
C*****************************************************************
C *
C This SUBROUTINE calculates a zero of a polynomial PN with *
C complex coefficients. *
C We solve the equation PN(Z)/PN'(Z)=0 *
C via Newton's method with spiralization and extrapolation to *
C improve convergence. *
C The initial approximation (X0+I*Y0) can be chosen arbitrarily.*
C *
C *
C INPUT PARAMETERS: *
C ================= *
C X0 : real part of the initial approximation. *
C Y0 : imaginary part of the initial approximation. *
C N : degree of the polynomial PN. *
C GAMMA : error bound. *
C *
C *
C OUTPUT PARAMETERS: *
C ================== *
C XNEW : real part of the computed zero of PN. *
C YNEW : imaginary part of the zero of PN. *
C NUMIT : maximum number of iteration steps. *
C *
C----------------------------------------------------------------*
C *
C subroutines required: ABSCOM, CDIV, COMHOR. *
C *
C *
C sources: Bauhuber, see [BAUH70]. *
C *
C*****************************************************************
C *
C author : Guido Dubois *
C date : 11.01.1985 *
C source : FORTRAN 77 *
C *
C*****************************************************************
C
COMMON /GLOBAL/A,B,C
DOUBLE PRECISION A(202),B(202),C(200),ABSCOM,X0,Y0,XNEW,YNEW,
+ GAMMA,BETA,RHO,BDZE,QR,QI,UNEW,VNEW,UDNEW,VDNEW,
+ UDDNEW,VDDNEW,PBNEW,PBOLD,PSBNEW,BD,BDD,DZMAX,DZMIN,
+ DX,DY,U,V,XOLD,YOLD,H,H1,H2,H3,H4,H5,P1RE,P1IM,Q1RE,
+ Q1IM,P12RE,P12IM,RA1RE,RA1IM,RARE,RAIM,RABE,RTRE,RTIM
LOGICAL ENDIT
C
IF(N .EQ. 2) THEN
C
C Solving the remaining 2nd degree polynomial exactly.
C
CALL CDIV(A(3),A(4),A(1),A(2),P1RE,P1IM)
CALL CDIV(A(5),A(6),A(1),A(2),Q1RE,Q1IM)
P12RE=-P1RE/2.0D0
P12IM=-P1IM/2.0D0
RA1RE=P12RE*P12RE-P12IM*P12IM
RA1IM=2.0D0*P12RE*P12IM
RARE=RA1RE-Q1RE
RAIM=RA1IM-Q1IM
IF(RAIM .EQ. 0.0D0) THEN
IF(RARE .LT. 0.0D0) THEN
C
C Purely imaginary root.
C
RTIM=DSQRT(-RARE)
RTRE=0.0D0
XNEW=P12RE
YNEW=P12IM+RTIM
RETURN
ELSE
C
C Real root.
C
RTRE=DSQRT(RARE)
RTIM=0.0D0
XNEW=P12RE+RTRE
YNEW=P12IM
RETURN
END IF
ELSE
C
C Complex root.
C
RABE=ABSCOM(RARE,RAIM)
IF(RARE .GT. 0.0D0) THEN
RTRE=DSQRT(0.5D0*(RABE+RARE))
IF(RAIM .LT. 0.0D0) RTRE=-RTRE
RTIM=0.5D0*RAIM/RTRE
ELSE
RTIM=DSQRT(0.5D0*(RABE-RARE))
RTRE=0.5D0*RAIM/RTIM
END IF
XNEW=P12RE+RTRE
YNEW=P12IM+RTIM
RETURN
END IF
ELSE IF(N .EQ. 1) THEN
C
C Polynomial of 1st degree.
C
XNEW=P12RE-RTRE
YNEW=P12IM-RTIM
RETURN
ELSE
I=0
ENDIT=.FALSE.
RHO=DSQRT(GAMMA)
BETA=10.0D0*GAMMA
QR=0.1D0
QI=0.9D0
XNEW=X0
YNEW=Y0
CALL COMHOR(XNEW,YNEW,N,GAMMA,UNEW,VNEW,UDNEW,VDNEW,
+ UDDNEW,VDDNEW,BD,BDD)
NUMIT=NUMIT+1
PBNEW=ABSCOM(UNEW,VNEW)
IF(PBNEW .LE. BD) THEN
RETURN
ELSE
PBOLD=2.0D0*PBNEW
DZMIN=BETA*(RHO+ABSCOM(XNEW,YNEW))
10 PSBNEW=ABSCOM(UDNEW,VDNEW)
C
C Spiralization.
C
IF(PBNEW .LT. PBOLD) THEN
DZMAX=1.0D0+ABSCOM(XNEW,YNEW)
NUMIT=NUMIT+1
H1=UDNEW*UDNEW-VDNEW*VDNEW-UNEW*UDDNEW+VNEW*VDDNEW
H2=2.0D0*UDNEW*VDNEW-UNEW*VDDNEW-VNEW*UDDNEW
IF(PSBNEW .GT. 10.0D0*BDD .AND.
+ ABSCOM(H1,H2) .GT. 100.0D0*BDD*BDD) THEN
C
C Applying Newton's method.
C
I=I+1
IF(I .GT. 2) I=2
U=UNEW*UDNEW-VNEW*VDNEW
V=UNEW*VDNEW+VNEW*UDNEW
CALL CDIV(-U,-V,H1,H2,DX,DY)
IF(ABSCOM(DX,DY) .GT. DZMAX) THEN
H=DZMAX/ABSCOM(DX,DY)
DX=DX*H
DY=DY*H
I=0
END IF
IF(I .EQ. 2 .AND. ABSCOM(DX,DY) .LT. DZMIN/RHO .AND.
+ ABSCOM(DX,DY) .GT. 0.0D0) THEN
C
C Extrapolation.
C
I=0
CALL CDIV(XNEW-XOLD,YNEW-YOLD,DX,DY,H3,H4)
H3=1.0D0+H3
H1=H3*H3-H4*H4
H2=2.0D0*H3*H4
CALL CDIV(DX,DY,H1,H2,H3,H4)
IF(ABSCOM(H3,H4) .LT. 50.0D0*DZMIN) THEN
DX=DX+H3
DY=DY+H4
END IF
END IF
XOLD=XNEW
YOLD=YNEW
PBOLD=PBNEW
ELSE
C
C In a neighborhood of a saddle point.
C
I=0
H=DZMAX/PBNEW
DX=H*UNEW
DY=H*VNEW
XOLD=XNEW
YOLD=YNEW
PBOLD=PBNEW
20 CALL COMHOR(XNEW+DX,YNEW+DY,N,GAMMA,U,V,H,H1,
+ H2,H3,H4,H5)
IF(DABS(ABSCOM(U,V)/PBNEW-1.0D0) .LE. RHO) THEN
DX=2.0D0*DX
DY=2.0D0*DY
GOTO 20
END IF
END IF
ELSE
I=0
NUMIT=NUMIT+1
H=QR*DX-QI*DY
DY=QR*DY+QI*DX
DX=H
END IF
IF(ENDIT) THEN
IF(ABSCOM(DX,DY) .LT. 0.1D0*BDZE) THEN
XNEW=XNEW+DX
YNEW=YNEW+DY
END IF
CALL COMHOR(XNEW,YNEW,N,GAMMA,UNEW,VNEW,UDNEW,
+ VDNEW,UDDNEW,VDDNEW,BD,BDD)
RETURN
ELSE
XNEW=XOLD+DX
YNEW=YOLD+DY
DZMIN=BETA*(RHO+ABSCOM(XNEW,YNEW))
CALL COMHOR(XNEW,YNEW,N,GAMMA,UNEW,VNEW,UDNEW,
+ VDNEW,UDDNEW,VDDNEW,BD,BDD)
PBNEW=ABSCOM(UNEW,VNEW)
IF(PBNEW .EQ. 0.0D0) THEN
RETURN
ELSE IF(ABSCOM(DX,DY) .GT. DZMIN .AND.
+ PBNEW .GT. BD) THEN
GOTO 10
ELSE
ENDIT=.TRUE.
BDZE=ABSCOM(DX,DY)
GOTO 10
END IF
END IF
END IF
END IF
END
C
C
SUBROUTINE COMHOR(X,Y,N,GAMMA,U,V,UD,VD,UDD,VDD,BDP,BDPD)
C
C*****************************************************************
C *
C This SUBROUTINE calculates the complex functional value *
C PN(X+I*Y)=(U+I*V), the complex valued derivatives *
C PN'(X+I*Y)=(UD+I*VD) and PN''(X+I*Y)=(UDD+I*VDD) of a polymial*
C PN(Z) of degree N (N>0) with complex coefficients by using *
C the Horner-scheme. *
C Additionally bounds BDP and BDPD are computed for the *
C rounding errors in computing DABS(PN(Z)) and DABS(PN'(Z)). *
C The complex coefficients of PN are stored in a 2-dimensional *
C array A(1:2*(N+1)), arranged in descending order of the *
C powers (they will remain unchanged by this subroutine). *
C The complex coefficients of the polynomial Q(Z) of degree N-1 *
C are stored in the array B(1:2*(N+1)), arranged in descending *
C order. Here Q(Z) is defined by PN(Z)=Q(Z)*(Z-Z0)+PN(Z0). *
C The array C(1:2*N) is used as an auxiliary array. *
C *
C *
C INPUT PARAMETERS: *
C ================= *
C X : real part of the value for which the functional *
C value and its 1st and 2nd derivatives are to be *
C computed for the polynomial PN. *
C Y : imaginary part of the value for which the *
C functional value and its 1st and 2nd derivatives *
C are to be computed for the polynomial PN. *
C GAMMA : error bound. *
C *
C *
C OUTPUT PARAMETERS: *
C ================== *
C U : real part of PN(X+I*Y). *
C V : imaginary part of PN(X+I*Y). *
C *
C UD : real part of PN'(X+I*Y). *
C VD : imaginary part of PN'(X+I*Y). *
C *
C UDD : real part of PN''(X+I*Y). *
C VDD : imaginary part of PN''(X+I*Y). *
C *
C BDP : bound for the rounding error of DABS(PN(Z)). *
C BDPD : bound for the rounding error of DABS(PN'(Z)). *
C *
C----------------------------------------------------------------*
C *
C subroutines required: ABSCOM. *
C *
C *
C sources: Bauhuber, see [BAUH70]. *
C *
C*****************************************************************
C *
C author : Guido Dubois *
C date : 11.01.1985 *
C source : FORTRAN 77 *
C *
C*****************************************************************
C
COMMON /GLOBAL/A,B,C
DOUBLE PRECISION A(202),B(202),C(200),ABSCOM,GAMMA,X,Y,U,V,
+ UD,VD,UDD,VDD,BDP,BDPD,H,H1,H2,H3,H4
C(1)=A(1)
B(1)=A(1)
C(2)=A(2)
B(2)=A(2)
BDPD=ABSCOM(A(1),A(2))
BDP=BDPD
MS=N-1
M=N
J=N
NM2P1=N*2+1
DO 10 K=3,NM2P1,2
J=J-1
H1=X*B(K-2)-Y*B(K-1)
H2=Y*B(K-2)+X*B(K-1)
B(K)=A(K)+H1
B(K+1)=A(K+1)+H2
H3=ABSCOM(A(K),A(K+1))
H4=ABSCOM(H1,H2)
H=H3
IF(H3 .LT. H4) H=H4
IF(H .GT. BDP) THEN
BDP=H
M=J
END IF
IF(K .EQ. NM2P1) THEN
GOTO 20
ELSE
H1=X*C(K-2)-Y*C(K-1)
H2=Y*C(K-2)+X*C(K-1)
C(K)=B(K)+H1
C(K+1)=B(K+1)+H2
H3=ABSCOM(B(K),B(K+1))
H4=ABSCOM(H1,H2)
H=H3
IF(H3 .LT. H4) H=H4
IF(BDPD .LT. H) THEN
BDPD=H
MS=J-1
END IF
END IF
10 CONTINUE
20 CONTINUE
U=B(2*N+1)
V=B(2*N+2)
UD=C(2*N-1)
VD=C(2*N)
H=ABSCOM(X,Y)
IF(H .NE. 0.0D0) THEN
BDP=BDP*FLOAT(M+1)*H**M
BDPD=BDPD*FLOAT(MS+1)*H**MS
ELSE
BDP=ABSCOM(U,V)
BDPD=ABSCOM(UD,VD)
END IF
BDP=BDP*GAMMA
BDPD=BDPD*GAMMA
IF(N .GT. 1) THEN
H1=C(1)
H2=C(2)
NM2M3=N*2-3
DO 30 K=3,NM2M3,2
H=C(K)+X*H1-Y*H2
H2=C(K+1)+Y*H1+X*H2
H1=H
30 CONTINUE
UDD=2.0D0*H1
VDD=2.0D0*H2
RETURN
ELSE
UDD=0.0D0
VDD=0.0D0
RETURN
END IF
END
C
C
DOUBLE PRECISION FUNCTION ABSCOM(X,Y)
C
C*****************************************************************
C *
C This FUNCTION-subroutine calculates the absolute value of a *
C complex number (X+I*Y). *
C *
C *
C INPUT PARAMETERS: *
C ================= *
C X : real part of the complex number. *
C Y : imaginary part of the complex number. *
C *
C *
C OUTPUT PARAMETER: *
C ================= *
C ABSCOM : absolute value of the complex number. *
C *
C----------------------------------------------------------------*
C *
C subroutines required: none. *
C *
C *
C*****************************************************************
C *
C author : Guido Gubois *
C date : 11.01.1985 *
C source : FORTRAN 77 *
C *
C*****************************************************************
C
DOUBLE PRECISION X,Y
IF(X .NE. 0.0D0 .OR. Y .NE. 0.0D0) THEN
IF(DABS(X) .GE. DABS(Y)) THEN
ABSCOM=DABS(X)*DSQRT(Y/X*Y/X+1.0D0)
RETURN
ELSE
ABSCOM=DABS(Y)*DSQRT(X/Y*X/Y+1.0D0)
RETURN
END IF
ELSE
ABSCOM=0.0D0
RETURN
END IF
END
C
C
SUBROUTINE MCONST(FMACHP,INFINY,SMALNO,BASE)
C
C*****************************************************************
C *
C This subroutine sets up some constants that are machine *
C dependent. *
C *
C *
C OUTPUT PARAMETERS: *
C ================== *
C FMACHP : machine constant for DOUBLE PRECISION. *
C INFINY : largest representable floating-point number. *
C SMALNO : smallest representable floating-point number. *
C BASE : base of the floating-point number system used to *
C represent machine numbers. *
C *
C *
C Description of the auxiliary variables: *
C ======================================= *
C I : number of digits of the floating-point mantissa *
C of DOUBLE PRECISION numbers. *
C M : largest allowed exponent. *
C N : smallest allowed exponent. *
C *
C----------------------------------------------------------------*
C *
C subroutines required: none. *
C *
C*****************************************************************
C *
C author : Guido Gubois *
C date : 11.01.1985 *
C source : FORTRAN 77 *
C *
C*****************************************************************
C
DOUBLE PRECISION FMACHP,INFINY,SMALNO,BASE
BASE=8.0D0
I=29
M=322
N=-293
FMACHP=1.0D0
10 FMACHP=0.5D0*FMACHP
IF(1.0D0 .LT. 1.0D0+FMACHP) GOTO 10
FMACHP=2.0D0*FMACHP
INFINY=BASE*(1.0D0-BASE**(-I))*BASE**(M-1)
SMALNO=(BASE**(N+3))/BASE**3
RETURN
END
C
C
DOUBLE PRECISION FUNCTION SCALFC(NN,PT,FMACHP,INFINY,SMALNO,
+ BASE)
C
C*****************************************************************
C *
C This FUNCTION-subroutine calculates a scaling factor which *
C is used to scale the polynomial coefficients. *
C *
C *
C INPUT PARAMETERS: *
C ================= *
C NN : 1 + the degree of the polynomial. *
C PT : nn-vector PT(1:NN) containing the absolute *
C values of the polynomial's coefficients. *
C FMACHP : machine constant for DOUBLE PRECISION. *
C INFINY : largest representable floating-point number. *
C SMALNO : smallest representable floating-point number. *
C BASE : base for the floating-point number system used by *
C the machine. *
C *
C *
C OUTPUT PARAMETER: *
C ================= *
C SCALFC : scaling factor. *
C *
C----------------------------------------------------------------*
C *
C subroutines required: none. *
C *
C*****************************************************************
C *
C author : Guido Dubois *
C date : 11.01.1985 *
C source : FORTRAN 77 *
C *
C*****************************************************************
C
DOUBLE PRECISION PT(NN),FMACHP,INFINY,SMALNO,BASE,HI,LO,
+ MAX,MIN,X,SC
HI=DSQRT(INFINY)
LO=SMALNO/FMACHP
MAX=0.0D0
MIN=INFINY
DO 10 I=1,NN
X=PT(I)
IF(X .GT. MAX) MAX=X
IF(X .NE. 0.0D0 .AND. X .LT. MIN) MIN=X
10 CONTINUE
SCALFC=1.0D0
IF(MIN .GE. LO .AND. MAX .LE. HI) THEN
RETURN
ELSE
X=LO/MIN
IF(X .GT. 1.0D0) THEN
SC=X
IF(INFINY/SC .GT. MAX) SC=1.0D0
ELSE
SC=1.0D0/(DSQRT(MAX)*DSQRT(MIN))
END IF
L=DLOG(SC)/DLOG(BASE)+0.5D0
SCALFC=BASE**L
END IF
RETURN
END
C
C
SUBROUTINE CDIV(A,B,C,D,X,Y)
C
C*****************************************************************
C *
C This SUBROUTINE performs a complex division *
C (X+I*Y) := (A+I*B)/(C+I*D). *
C *
C *
C INPUT PARAMETERS: *
C ================= *
C A : real part of the numerator. *
C B : imaginary part of the numerator. *
C *
C C : real part of the denominator. *
C D : imaginary part of the denominator. *
C *
C *
C OUTPUT PARAMETERS: *
C ================== *
C X : real part of the quotient. *
C Y : imaginary part of the quotient. *
C *
C *
C NOTE: If the denominator's real and imaginary parts are both *
C equal to zero, the program is aborted with a detailed *
C error message. *
C *
C----------------------------------------------------------------*
C *
C subroutines required: none. *
C *
C *
C *
C*****************************************************************
C *
C author : Guido Dubois *
C date : 11.01.1985 *
C source : FORTRAN 77 *
C *
C*****************************************************************
C
DOUBLE PRECISION A,B,C,D,X,Y,U,V,AM,AN,P,Q,F
IF(C .NE. 0.0D0 .OR. D .NE. 0.0D0) THEN
IF(A .NE. 0.0D0 .OR. B .NE. 0.0D0) THEN
IF(DABS(A) .GT. DABS(B)) THEN
U=A
AM=1.0D0
AN=B/A
ELSE
U=B
AM=A/B
AN=1.0D0
END IF
IF(DABS(C) .GT. DABS(D)) THEN
V=C
P=1.0D0
Q=D/C
ELSE
V=D
P=C/D
Q=1.0D0
END IF
F=U/V
V=P*P+Q*Q
U=(AM*P+AN*Q)/V
X=U*F
U=(-AM*Q+AN*P)/V
Y=U*F
RETURN
ELSE
X=0.0D0
Y=0.0D0
RETURN
END IF
ELSE
WRITE(*,*)'DIVISION BY ZERO IN SUBROUTINE CDIV'
STOP
END IF
END