End of file
Contents
Index

F 3 Roots of Polynomials

F 3.3.2 Muller's Method


      SUBROUTINE MULLRP(NPOL,POLYNM,ITERMX, NZ,ZERO,P,PHELPD)
C
C*****************************************************************
C                                                                *
C  This SUBROUTINE computes all zeros of a polynomial by using   *
C  the method of Muller.                                         *
C                                                                *
C                                                                *
C  INPUT PARAMETERS:                                             *
C  =================                                             *
C  NPOL   : degree of the polynomial                             *
C  POLYNM : (NPOL+1)-vector POLYNM(0:NPOL) of the polynomial     *
C           coefficients in ascending order                      *
C  ITERMX : maximum number of iterations per zero                *
C                                                                *
C                                                                *
C  OUTPUT PARAMETERS:                                            *
C  ==================                                            *
C  NZ     : number of zeros found                                *
C  ZERO   : (2,NZ)-array containing the zeros with real their    *
C           parts stored first and their imaginary parts stored  *
C           in the second component.                             *
C                                                                *
C                                                                *
C  AUXILIARY VECTORS:                                            *
C  ==================                                            *
C  P      : vector P(0:NPOL)  of type DOUBLE PRECISION           *
C  PHELPD : vector PHELPD(0:NPOL)  of type DOUBLE PRECISION      *
C                                                                *
C----------------------------------------------------------------*
C                                                                *
C  subroutines required: MULLER, HORNC, HORNCE, POLDIV,          *
C                        YEPS, COMPAR                            *
C                                                                *
C*****************************************************************
C                                                                *
C  author     : Eberhard Heyne                                   *
C  date       : 06.14.1992                                       *
C  source     : FORTRAN 77                                       *
C                                                                *
C*****************************************************************
C
      INTEGER NPOL,NFND,ITERMX,IERR,NZ,NC,N,I,ITMX,NB,NFIRST,NR
      DOUBLE PRECISION POLYNM(0:NPOL)
      DOUBLE PRECISION P(0:NPOL)
      DOUBLE PRECISION ZERO(2,1:NPOL),X0R,X1R,X2R,X0I,X1I,X2I
      DOUBLE PRECISION F0R,F1R,F2R,F0I,F1I,F2I,F1BQ,F2BQ,F2BQB
      DOUBLE PRECISION XR,XI,XEPS,YEPS
      DOUBLE PRECISION BHELPD(0:2),PHELPD(0:NPOL),R(0:1)
      COMMON /MULLCI/ ITMX
      COMMON /MULLCD/ X0R,X0I,X1R,X1I,X2R,X2I,
     &                F0R,F0I,F1R,F1I,F2R,F2I,F1BQ,F2BQ,F2BQB,XEPS
C
C     The variable IERR (error indicator) may be added to the parameter list
C     as an additional output parameter. Since the number NPOL of zeros
C     of the given polynomial is known, the inquiry (NZ .NE. NPOL) might
C     suffice if the presence of an error needs to be detected but
C     the type of this error does not need to be analyzed.
C
      DATA NFIRST/0/
      IF (NFIRST .NE. 1) THEN
C
C        Determine machine constant
C
         XEPS=YEPS()
         NFIRST=1
      ENDIF
C
C     Initialize: number NZ of zeros found, error indicator IERR
C
      NZ=0
      IERR=0
C
C     Test for meaningful polynomial degree
C
      IF (NPOL .LE. 0) THEN
         IERR=1
         RETURN
      ENDIF
C
C     Relabel polynomial coefficients and determine the polynomial degree N
C
      N=-1
      DO 10 I=0,NPOL
         P(I)=POLYNM(I)
         IF (DABS(P(I)) .NE. 0.0D0) N=I
10    CONTINUE
      IF (N .LE. 0) THEN
         IF (N .EQ. -1) THEN
C
C           The polynomial is identically equal to zero
C
            IERR=2
            RETURN
         ELSE IF (N .EQ. 0) THEN
C
C           The polynomial is identical to a constant different from zero
C
            IERR=3
            RETURN
         ENDIF
      ENDIF
12    CONTINUE
      IF (N .EQ. 0) THEN
         IERR=4
         RETURN
      ENDIF
      IF (N .EQ. 1) THEN
C
C        Solve the linear polynomial if the degree is 1
C
         NZ=NZ+1
         ZERO(1,NZ)=-P(0)/P(1)
         ZERO(2,NZ)=0.0D0
         RETURN
      ENDIF
C
C     Preset the number ITMX of iteration steps allowed per zero
C
      ITMX=ITERMX
C
C     Automatic start
C
      X0R=-1.0D0
      F0R=P(0)-P(1)+P(2)
      X1R=1.0D0
      F1R=P(0)+P(1)+P(2)
      X2R=0.0D0
      F2R=P(0)
      X0I=0.0D0
      F0I=0.0D0
      X1I=0.0D0
      F1I=0.0D0
      X2I=0.0D0
      F2I=0.0D0
C
C     Muller-iteration for one zero
C
      CALL MULLER(N,P,NFND,XR,XI,PHELPD)
      IF (NFND .EQ. 0) RETURN
      IF (NFND .EQ. 1) THEN
C
C        A real zero
C
         NZ=NZ+1
         ZERO(1,NZ)=XR
         ZERO(2,NZ)=0.0D0
         BHELPD(1)=1.0D0
         BHELPD(0)=-XR
         NB=1
      ELSE IF (NFND .EQ. 2) THEN
C
C        If a real polynomial has a complex zero,
C        then its complex-conjugate is a zero as well
C
         NZ=NZ+1
         ZERO(1,NZ)=XR
         ZERO(2,NZ)=XI
         NZ=NZ+1
         ZERO(1,NZ)=XR
         ZERO(2,NZ)=-XI
         BHELPD(2)=1.0D0
         BHELPD(1)=-(XR+XR)
         BHELPD(0)=+(XR**2+XI**2)
         NB=2
      ENDIF
C
C     Deflate by the found zero(s)
C
      CALL POLDIV(P,N,BHELPD,NB,PHELPD,NC,R,NR)
      DO 14 I=0,NC
         P(I)=PHELPD(I)
14    CONTINUE
      N=NC
      IF (ITMX .NE. 0) GOTO 12
      RETURN
      END
C
C

      SUBROUTINE MULLER(N,P,NFND,XR,XI,PHELPD)
C
C*****************************************************************
C                                                                *
C  Auxiliary routine for MULLRP                                  *
C                                                                *
C----------------------------------------------------------------*
C                                                                *
C  subroutines required: HORNC, HORNCE                           *
C                                                                *
C*****************************************************************
C                                                                *
C  author     : Eberhard Heyne                                   *
C  date       : 06.14.1992                                       *
C  source     : FORTRAN 77                                       *
C                                                                *
C*****************************************************************
C
      INTEGER N,NFND,ITMX
      DOUBLE PRECISION P(0:N),F1BQ
      DOUBLE PRECISION F2BQ,F2BQB,XEPS,XEFR,XEFI,XEB1,XEB0,FF
      DOUBLE PRECISION H1R,H1I,H1BQ,H2R,H2I,HHR,HHI,HXR,HXI,HYR,HYI
      DOUBLE PRECISION WSIN,WCOS,WBQ,WSINH,WCOSH
      DOUBLE PRECISION AR,AI,BR,BI,CR,CI,QR,QI,WNR,WNI
      DOUBLE PRECISION XN1R,XN1I,XN1BQ,XN2R,XN2I,XN2BQ
      DOUBLE PRECISION XR,XI,FR,FI,XBR,XBI,PHELPD(0:N)
      DOUBLE PRECISION X0R,X1R,X2R,X0I,X1I,X2I
      DOUBLE PRECISION F0R,F1R,F2R,F0I,F1I,F2I
      DOUBLE PRECISION AHR,AHI,BHR,BHI,CMLR,CMLI
      COMMON /MULLCI/ ITMX
      COMMON /MULLCD/ X0R,X0I,X1R,X1I,X2R,X2I,
     &                F0R,F0I,F1R,F1I,F2R,F2I,F1BQ,F2BQ,F2BQB,XEPS
C
C     Complex multiplication: the real part
C
      CMLR(AHR,AHI,BHR,BHI)=AHR*BHR-AHI*BHI
C
C     Complex multiplication: the imaginary part
C
      CMLI(AHR,AHI,BHR,BHI)=AHR*BHI+AHI*BHR
C
C     The number FF helps decide whether one should iterate further
C     when the computed functional values increase or whether the value
C     with the smallest absolute functional value so far attained is
C     acceptable as a zero.
C     FF=10 means that one decimal place of the computed functional value
C     must be correct. FF=1 means that we only test whether the absolute
C     value of the functional value is less than the rounding error.
C
      DATA FF/10.0D0/
C
C     Automatic start
C
C     H1=X1-X0
C     H2=X2-X1
C     Q=H2/H1
C
      H1R=X1R-X0R
      H1I=0.0D0
      H2R=X2R-X1R
      H2I=0.0D0
C
C     Q=H2R/H1R
C
      H1BQ=H1R**2+H1I**2
      QR=CMLR(H2R,H2I,H1R/H1BQ,-H1I/H1BQ)
      QI=CMLI(H2R,H2I,H1R/H1BQ,-H1I/H1BQ)
      F1BQ=1.0D38
      F2BQ=1.0D38
      XBR=X2R
      XBI=0.0D0
      F2BQB=1.0D38
10    CONTINUE
C
C     A=Q*F2-Q*(1+Q)*F1+Q**2*F0
C     B=(2.*Q+1.)*F2-(1+Q)**2*F1+Q**2*F0
C     C=(1.+Q)*F2
C
      HHR=CMLR(QR,QI,QR,QI)
      HHI=CMLI(QR,QI,QR,QI)
C
C     Compute        A=Q*(F2-F1) + Q**2*(F0-F1)
C     instead of     A=Q*F2-Q*(1+Q)*F1+Q**2*F0
C
      HXR=F2R-F1R
      HXI=F2I-F1I
      HYR=F0R-F1R
      HYI=F0I-F1I
      AR=CMLR(QR,QI,HXR,HXI)+CMLR(HHR,HHI,HYR,HYI)
      AI=CMLI(QR,QI,HXR,HXI)+CMLI(HHR,HHI,HYR,HYI)
C
C     Compute         B=F2-F1+ 2.*Q*(F2-F1)+Q**2*(F0-F1)
C     instead of      B=(2.*Q+1.)*F2-(1+Q)**2*F1+Q**2*F0
C
      BR=HXR+2.0D0*CMLR(QR,QI,HXR,HXI)+CMLR(HHR,HHI,HYR,HYI)
      BI=HXI+2.0D0*CMLI(QR,QI,HXR,HXI)+CMLI(HHR,HHI,HYR,HYI)
C
C     C=(1.+Q)*F2
C
      CR=F2R+CMLR(QR,QI,F2R,F2I)
      CI=F2I+CMLI(QR,QI,F2R,F2I)
C
C     The square-root expression appearing in the denominator
C     of the expression for Q
C
C     WN=B**2-4.*A*C  und WN=SQRT(WN)
C
      WNR=CMLR(BR,BI,BR,BI)-4.0D0*CMLR(AR,AI,CR,CI)
      WNI=CMLI(BR,BI,BR,BI)-4.0D0*CMLI(AR,AI,CR,CI)
      IF (WNR*WNR+WNI*WNI .GE. 1.0D-40) THEN
         WBQ=DSQRT(WNR*WNR+WNI*WNI)
         WSIN=WNI/WBQ
         WCOS=WNR/WBQ
C
C        Half-angle formula
C
         WSINH=DSIGN(1.0D0,WSIN)*DSQRT((1.0D0-WCOS)*0.5D0)
         WCOSH=DSQRT((1.0D0+WCOS)*0.5D0)
         WBQ=DSQRT(WBQ)
         WNR=WBQ*WCOSH
         WNI=WBQ*WSINH
      ELSE
         WNR=0.0D0
         WNI=0.0D0
      ENDIF
C
C     The two possible denominators for this root
C
      XN1R=BR+WNR
      XN1I=BI+WNI
      XN1BQ=XN1R**2+XN1I**2
      XN2R=BR-WNR
      XN2I=BI-WNI
      XN2BQ=XN2R**2+XN2I**2
C
C     The denominator with the larger absolute value determines the X
C     closest to X2
C
      IF (XN1BQ .GT. XN2BQ) THEN
C
C        Q=-2.*C/XN1
C
         QR=-(2.0D0/XN1BQ)*CMLR(CR,CI,XN1R,-XN1I)
         QI=-(2.0D0/XN1BQ)*CMLI(CR,CI,XN1R,-XN1I)
      ELSE IF (XN2BQ .GT. 0.0D0) THEN
C
C        Q=-2.*C/XN2
C
         QR=-(2.0D0/XN2BQ)*CMLR(CR,CI,XN2R,-XN2I)
         QI=-(2.0D0/XN2BQ)*CMLI(CR,CI,XN2R,-XN2I)
      ELSE
C
C        The denominator is zero;
C        Follow the suggestion by Muller: set Q=1 and continue calculations
C
C        Q=(1.,0.)
C
         QR=1.0D0
         QI=0.0D0
      ENDIF
C
C     Prepare the next iteration,
C     in which some instructions become redundant; we will
C     label them as comment lines: C   ...
C
C     X0=X1
C     X1=X2
C     H1=H2
C
      F0R=F1R
      F0I=F1I
      F1R=F2R
      F1I=F2I
C     X0R=X1R
C     X0I=X1I
C     X1R=X2R
C     X1I=X2I
C     H1R=H2R
C     H1I=H2I
C
C     The new value of H2 is calculated before the new X iterate
C
      F1BQ=F2BQ
C
C     H2=H2*Q
C
      HHR=CMLR(H2R,H2I,QR,QI)
      H2I=CMLI(H2R,H2I,QR,QI)
      H2R=HHR
      X2R=X2R+H2R
      X2I=X2I+H2I
12    CONTINUE
C
C     Determine the functional value
C
      XR=X2R
      XI=X2I
      CALL HORNC(P,N,XR,XI,FR,FI,PHELPD)
      F2R=FR
      F2I=FI
      F2BQ=FR**2+FI**2
C
C     Decrease the iteration counter
C
      ITMX=ITMX-1
      IF (ITMX .EQ. 0) THEN
C
C        Maximal number of iterations has been reached
C
C
C        Error estimate for the x-value with the minimal
C        absolute value of the function
C
         CALL HORNCE(XEPS,XEFR,XEFI,XEB1,XEB0,P,N,XBR,XBI,FR,FI,PHELPD)
C
C        Determine whether the x-value with the smallest absolute
C        functional value so far found can be regarded as a zero
C
         IF (DABS(FR)+DABS(FI) .LE. FF*(DABS(XEFR)+DABS(XEFI))) THEN
            XR=XBR
            XI=XBI
            GOTO 14
         ELSE
            NFND=0
            RETURN
         ENDIF
      ENDIF
C
C     Muller-modification for improved convergence
C
      IF (F2BQ .GT. 100.0D0*F1BQ) THEN
         QR=QR/2.0D0
         QI=QI/2.0D0
C
C        H2 and X2 already contain the old Q
C
         H2R=H2R/2.0D0
         H2I=H2I/2.0D0
         X2R=X2R-H2R
         X2I=X2I-H2I
         GOTO 12
      ENDIF
C
C     As long as the absolute value of the functional values decreases,
C     we can hope for an improvement
C
      IF (F2BQ .LT. F1BQ) THEN
         IF (F2BQ .LT. F2BQB) THEN
C
C          The absolute value of the new function value is less than
C          the minimal value so far
C
            F2BQB=F2BQ
            XBR=XR
            XBI=XI
         ENDIF
C
C       We do not continue iterating for an exakt zero
C
         IF (F2BQ .NE. 0.0D0) GOTO 10
      ELSE
C
C        Error estimate the same as for the x-value that, so far, represented
C        the minimal absolute function value
C
         CALL HORNCE(XEPS,XEFR,XEFI,XEB1,XEB0,P,N,XBR,XBI,FR,FI,PHELPD)
C
C        Check whether iteration is to be continued
C
         XR=XBR
         XI=XBI
         IF (DABS(FR)+DABS(FI) .GE. FF*(DABS(XEFR)+DABS(XEFI))) GOTO 10
      ENDIF
14    CONTINUE
C
C     Using an error estimate we determine whether the root
C     may be real
C
      IF (DABS(PHELPD(1))+DABS(PHELPD(0)) .LE. FF*(XEB1+XEB0)) THEN
C
C        Complex-conjugate pair of zeros
C
         NFND=2
      ELSE
C
C        A real solution
C
         NFND=1
         XI=0.0D0
      ENDIF
      RETURN
      END
C
C

      SUBROUTINE HORNC(A,NA,XR,XI,FR,FI,B)
C
C*****************************************************************
C                                                                *
C  auxiliary routine for MULLRP                                  *
C                                                                *
C----------------------------------------------------------------*
C                                                                *
C  subroutines required: none                                    *
C                                                                *
C*****************************************************************
C                                                                *
C  author     : Eberhard Heyne                                   *
C  date       : 05.09.1988                                       *
C  source     : FORTRAN 77                                       *
C                                                                *
C*****************************************************************
C
C     Simple Horner-scheme for a COMPLEX argument
C
      INTEGER NA,I
      DOUBLE PRECISION A(0:NA)
      DOUBLE PRECISION XR,XI,FR,FI,P,Q,B(0:NA)
      P=XR+XR
      Q=-(XR**2+XI**2)
      B(NA)=A(NA)
      B(NA-1)=A(NA-1)+P*B(NA)
      DO 10 I=NA-2,1,-1
         B(I)=A(I)+Q*B(I+2)+P*B(I+1)
10    CONTINUE
      B(0)=A(0)+Q*B(2)
      FR=B(1)*XR+B(0)
      FI=B(1)*XI
      RETURN
      END
C
C

      SUBROUTINE HORNCE(XEPS,XEFR,XEFI,XEB1,XEB0,A,NA,XR,XI,FR,FI,B)
C
C*****************************************************************
C                                                                *
C  auxiliary routine for MULLRP                                  *
C                                                                *
C----------------------------------------------------------------*
C                                                                *
C  subroutines required: none                                    *
C                                                                *
C*****************************************************************
C                                                                *
C  author     : Eberhard Heyne                                   *
C  date       : 06.14.1992                                       *
C  source     : FORTRAN 77                                       *
C                                                                *
C*****************************************************************
C
C     This SUBROUTINE is very similar to HORNC except that
C     error estimates are carried out for each instruction.
C
C     XEFR   error estimate of the real part of F      ( FR )
C     XEFI   error estimate of the imaginary part F of ( FI )
C     XEB1   error estimate of B(1)
C     XEB0   error estimate of B(0)
C
      INTEGER NA,I
      DOUBLE PRECISION A(0:NA)
      DOUBLE PRECISION XEPS,XEP,XEQ,XEB0,XEB1,XEB2,XEFR,XEFI
      DOUBLE PRECISION XR,XI,FR,FI,P,Q,B(0:NA)
      P=XR+XR
      XEP=DABS(P)*XEPS
      Q=-(XR**2+XI**2)
      XEQ=DABS(Q)*XEPS
      B(NA)=A(NA)
      XEB2=0.0D0
      B(NA-1)=A(NA-1)+P*B(NA)
      XEB1=XEP*DABS(B(NA))+XEPS*(DABS(B(NA-1)))
      DO 10 I=NA-2,1,-1
         B(I)=A(I)+Q*B(I+2)+P*B(I+1)
         XEB0=XEQ*DABS(B(I+2))+XEP*DABS(B(I+1))+
     &        XEB2*DABS(Q)+XEB1*DABS(P)+XEPS*(DABS(B(I))+DABS(A(I)))
         XEB2=XEB1
         XEB1=XEB0
10    CONTINUE
      B(0)=A(0)+Q*B(2)
      XEB0=XEQ*DABS(B(2))+XEB2*DABS(Q)+XEPS*(DABS(B(0))+DABS(A(0)))
      FR=B(1)*XR+B(0)
      XEFR=XEB1*DABS(XR)+XEB0
      FI=B(1)*XI
      XEFI=XEB1*DABS(XI)
      RETURN
      END
C
C

      SUBROUTINE POLDIV(A,NA,B,NB,C,NC,R,NR)
C
C*****************************************************************
C                                                                *
C  auxiliary routine for MULLRP                                  *
C                                                                *
C----------------------------------------------------------------*
C                                                                *
C  Subroutines required: none                                    *
C                                                                *
C*****************************************************************
C                                                                *
C  author     : Eberhard Heyne                                   *
C  date       : 05.09.1988                                       *
C  source     : FORTRAN 77                                       *
C                                                                *
C*****************************************************************
C
      INTEGER NA,NB,NC,NR,IC,K,M,IR
      DOUBLE PRECISION A(0:NA)
      DOUBLE PRECISION B(0:NB),C(0:*),SUM,R(0:*)
C
C     Long division of polynomials:
C     determine polynomials C, R so that the following
C     holds:  A = B * C + R, i.e., C = A/B with remainder R
C
      NC=NA-NB
      DO 10 IC=NC,0,-1
         K=IC+NB
         SUM=A(K)
         DO 12 M=IC+1,MIN(NC,K)
            SUM=SUM-B(K-M)*C(M)
12       CONTINUE
         C(IC)=SUM/B(NB)
10    CONTINUE
      NR=NB-1
      DO 14 IR=0,NR
         SUM=A(IR)
         DO 16 M=0,IR
            SUM=SUM-B(IR-M)*C(M)
16       CONTINUE
         R(IR)=SUM
14    CONTINUE
      RETURN
      END
C
C

      DOUBLE PRECISION FUNCTION YEPS()
C
C*****************************************************************
C                                                                *
C  auxiliary routine for MULLRP                                  *
C                                                                *
C----------------------------------------------------------------*
C                                                                *
C  subroutines required: COMPAR                                  *
C                                                                *
C*****************************************************************
C                                                                *
C  author     : Eberhard Heyne                                   *
C  date       : 05.09.1988                                       *
C  source     : FORTRAN 77                                       *
C                                                                *
C*****************************************************************
C
      DOUBLE PRECISION R,S
      INTEGER M
C
C     Function that determines the machine constant
C
      S=1.0D0
10    R=S
      S=S/2.0D0
      CALL COMPAR(M,1.0D0+S,1.0D0+R)
      IF (M .NE. 0) GOTO 10
      YEPS=R
      RETURN
      END
C
C

      SUBROUTINE COMPAR(M,A,B)
C
C*****************************************************************
C                                                                *
C  auxiliary routine for MULLRP                                  *
C                                                                *
C*****************************************************************
C
      DOUBLE PRECISION A,B
      INTEGER M
C
C     The reason behind this routine is to avoid internal
C     compiler optimizations and to force storing the values
C     for A and B.
C
      M=1
      IF (A .EQ. B) M=0
      RETURN
      END


Begin of file
Contents
Index