!
!=======================================================================
!
MODULE CPOLY_VAR
!
!  This module contains input values for print switches
!
!
      USE ACCURACY_REAL
!
      IMPLICIT NONE
!
      INTEGER               ::  NN
!
      REAL (WP)             ::  PR(50),PI(50),HR(50),HI(50)
      REAL (WP)             ::  QPR(50),QPI(50),QHR(50),QHI(50)
      REAL (WP)             ::  SHR(50),SHI(50)
      REAL (WP)             ::  SR,SI,TR,TI,PVR,PVI
      REAL (WP)             ::  ARE,MRE,ETA,INFIN
!
END MODULE CPOLY_VAR
!
!=======================================================================
!
MODULE FIND_ZERO 
!
      USE ACCURACY_REAL
!
CONTAINS
!
!
!=======================================================================
!
      SUBROUTINE FIND_ZERO_FUNC(X,F,N_X,ZEROF)
!
!  This subroutine finds the solution of F_Y(X) = 0 in the interval [A,B]
!
!
!  Input parameters:
!
!       * X        : array representing the abscissae of f_y
!       * F        : array representing the function f_y
!       * N_X      : size of the X and F arrays
!
!
!  Output variables :
!
!       * ZEROF    : zero of f(x) in [A,B]
!
!
!
!   Author :  D. Sébilleau
!
!                                           Last modified : 14 Oct 2020
!
!
      USE DIMENSION_CODE,   ONLY : NSIZE
      USE REAL_NUMBERS,     ONLY : ZERO
!
      IMPLICIT NONE
!
      INTEGER               ::  I,N_X
!
      REAL (WP)             ::  A,B,FA,FB
      REAL (WP)             ::  X(NSIZE),F(NSIZE)
      REAL (WP)             ::  PROD,ZEROF
!
      REAL (WP), PARAMETER  ::  TOL = 0.00001E0_WP
!
!  Finding the intervals containing a zero
!
      DO I = 2,N_X                                                  !
!
        PROD = F(I) * F(I-1)                                        !
!
        IF(PROD < ZERO) THEN                                        !
          A     = X(I-1)                                            !
          B     = X(I)                                              !
          FA    = F(I-1)                                            !
          FB    = F(I)                                              !
          ZEROF = ZEROIN(A,B,FA,FB,TOL)                             !
        END IF                                                      !
!
      END DO                                                        !
!
      END SUBROUTINE FIND_ZERO_FUNC
!
!=======================================================================
!
      SUBROUTINE PRINT_ZERO_FUNC(Y,X,F,N_X)
!
!  This subroutine finds the solution of F_Y(X) = 0 in the interval [A,B]
!
!
!  Input parameters:
!
!       * Y        : actual abcissa point
!       * X        : array representing the abscissae of f_y
!       * F        : array representing the function f_y
!       * N_X      : size of the X and F arrays
!
!
!  Output variables :
!
!       * ZEROF    : zero of f(x) in [A,B]
!
!
!
!   Author :  D. Sébilleau
!
!                                           Last modified : 14 Oct 2020
!
!
      USE DIMENSION_CODE,   ONLY : NSIZE
      USE REAL_NUMBERS,     ONLY : ZERO
!
      USE PRINT_FILES,      ONLY : IO_ZE
!
      IMPLICIT NONE
!
      INTEGER               ::  I,N_X
!
      REAL (WP)             ::  Y
      REAL (WP)             ::  A,B,FA,FB
      REAL (WP)             ::  X(NSIZE),F(NSIZE)
      REAL (WP)             ::  PROD,ZEROF
!
      REAL (WP), PARAMETER  ::  TOL = 0.00001E0_WP
!
!  Finding the intervals containing a zero
!
      DO I = 2,N_X                                                  !
!
        PROD = F(I) * F(I-1)                                        !
!
        IF(PROD < ZERO) THEN                                        !
          A     = X(I-1)                                            !
          B     = X(I)                                              !
          FA    = F(I-1)                                            !
          FB    = F(I)                                              !
          ZEROF = ZEROIN(A,B,FA,FB,TOL)                             !
          WRITE(IO_ZE,*) Y,ZEROF                                    !
        END IF                                                      !
!
      END DO                                                        !
!
      END SUBROUTINE PRINT_ZERO_FUNC
!
!=======================================================================
!
      FUNCTION ZEROIN(AX,BX,FAX,FBX,TOL)
!
!      A zero of the function  F(X)  is computed in the interval AX,BX 
!
!  Input parameters:
!
!       * AX       :  left endpoint of initial interval    
!       * BX       :  right endpoint of initial interval
!       * FAX      :  value of F(X) at AX
!       * FBX      :  value of F(X) at BX
!       * TOL      :  desired length of the interval of uncertainty of the
!                       final result ( .GE. 0.0D0)
!
!  Output parameters:
!
!       * ZEROIN   :  abcissa approximating a zero of F(X) 
!                       in the interval AX,BX
!
!
!  It is assumed  that   F(AX)   and   F(BX)   have  opposite  signs
!    without  a  check.  ZEROIN  returns a zero  X  in the given interval
!    AX,BX  to within a tolerance  4*MACHEPS*ABS(X) + TOL, where MACHEPS
!    is the relative machine precision.
!
!  This function subprogram is a slightly modified translation of
!    the ALGOL 60 procedure ZERO given in Richard Brent, "Algorithms for
!    Minimization Without Derivatives", Prentice-Hall, Inc. (1973).
!
!
!  Last Modified : 18 Jun 2020 by D. Sébilleau
!
!
      USE REAL_NUMBERS,     ONLY : ZERO,ONE,TWO,THREE,  &
                                   HALF
!
      IMPLICIT NONE
!
      REAL (WP), INTENT(IN) ::  AX,BX,FAX,FBX,TOL
      REAL (WP)             ::  ZEROIN
      REAL (WP)             ::  A,B,C,D,E,EPS
      REAL (WP)             ::  FA,FB,FC,TOL1,XM
      REAL (WP)             ::  P,Q,R,S
!
      REAL (WP)             ::  ABS,SIGN
!
!  Compute EPS, the relative machine precision
!
      EPS  = ONE                                                    !
  10  EPS  = EPS / TWO                                              !
      TOL1 = ONE + EPS                                              !
      IF(TOL1 > ONE) GO TO 10                                       !
!
! Initialization
!
      A  = AX                                                       !
      B  = BX                                                       !
      FA = FAX                                                      !
      FB = FBX                                                      !
!
! Begin step
!
  20  C  = A                                                        !
      FC = FA                                                       !
      D  = B - A                                                    !
      E  = D                                                        !
!
  30  IF(ABS(FC) >= ABS(FB)) GO TO 40                               !
!
      A  = B                                                        !
      B  = C                                                        !
      C  = A                                                        !
      FA = FB                                                       !
      FB = FC                                                       !
      FC = FA                                                       !
!
! Convergence test
!  
  40  TOL1 = TWO * EPS * ABS(B) + HALF * TOL                        !
      XM = HALF * (C - B)                                           !
      IF(ABS(XM) <= TOL1) GO TO 90                                  !
      IF(FB == ZERO) GO TO 90                                       !
!
! Is bisection necessary ?
!
      IF(ABS(E) < TOL1) GO TO 70                                    !
      IF(ABS(FA) <= ABS(FB)) GO TO 70                               !
!
! Is quadratic interpolation possible ?
!
      IF(A /= C) GO TO 50                                           !
!
! Linear interpolation
!
      S = FB / FA                                                   !
      P = TWO * XM * S                                              !
      Q = ONE - S                                                   !
      GO TO 60                                                      !
!
! Inverse quadratic interpolation
!
  50  Q = FA / FC                                                   !
      R = FB / FC                                                   !
      S = FB / FA                                                   !
      P = S * ( TWO * XM * Q * (Q - R) - (B - A) * (R - ONE) )      !
      Q = (Q - ONE) * (R - ONE) * (S - ONE)                         !
!
! Adjust signs
!
  60  IF(P > ZERO) Q = -Q                                           !
      P = ABS(P)                                                    !
!
! Is interpolation acceptable ?
!
      IF((TWO*P) >= (THREE * XM * Q - ABS(TOL1 * Q))) GO TO 70      !
      IF (P >= ABS(HALF * E * Q)) GO TO 70                          !
      E = D                                                         !
      D = P / Q                                                     !
      GO TO 80                                                      !
!
! Bisection
!
  70  D = XM                                                        !
      E = D                                                         !
!
! Complete step
!
  80  A  = B                                                        !
      FA = FB                                                       !
      IF(ABS(D).GT.TOL1) B = B + D                                  !
      IF(ABS(D).LE.TOL1) B = B + SIGN(TOL1,XM)                      !
      FB = FBX                                                      !
      IF((FB * (FC / ABS(FC))) > ZERO) GO TO 20                     !
      GO TO 30                                                      !
!
! Done
!
  90  ZEROIN = B                                                    !
!
      END FUNCTION ZEROIN
!
!=======================================================================
!
!     Algorithm 419 collected algorithms from ACM.
!
!     Algorithm appeared in Comm. ACM, Vol. 15, No. 02, p. 097.
!
      SUBROUTINE CPOLY(OPR,OPI,DEGREE,ZEROR,ZEROI,FAIL) 
!
! Finds the zeros of a complex polynomial.
!
! OPR, OPI      :  double precision vectors of real and
!                    imaginary parts of the coefficients in
!                    order of decreasing powers.
! DEGREE        :  integer degree of polynomial.
! ZEROR, ZEROI  :  output double precision vectors of
!                  real and imaginary parts of the zeros.
! FAIL          :  output logical parameter,  .true.  only if
!                    leading coefficient is zero or if CPOLY
!                    has found fewer than degree zeros.
!
! The program has been written to reduce the chance of overflow
! occurring. If it does occur, there is still a possibility that
! the zerofinder will work provided the overflowed quantity is
! replaced by a large number.
!
!
!  Last Modified : 18 Jun 2020 by D. Sébilleau
!
!
      USE CPOLY_VAR
      USE REAL_NUMBERS,     ONLY : ZERO,ONE,TWO
      USE SQUARE_ROOTS,     ONLY : SQR2
!
      IMPLICIT NONE
!
! To change the size of polynomials which can be solved, replace
!   the dimension of the arrays in the common area
!
!
      REAL (WP)             ::  XX,YY,COSR,SINR,SMALNO,BASE
      REAL (WP)             ::  XXX,ZR,ZI,BND
      REAL (WP)             ::  OPR(101),OPI(101)
      REAL (WP)             ::  ZEROR(101),ZEROI(101)
!
      LOGICAL               ::  FAIL,CONV
!
      INTEGER               ::  DEGREE,CNT1,CNT2
      INTEGER               ::  I,IDNN2
!
! Initialization of constants
!
      CALL MCON(ETA,INFIN,SMALNO,BASE)                              !
      ARE = ETA                                                     !
      MRE = TWO*SQR2*ETA                                            !
      XX = 0.70710678E0_WP                                          !
      YY = -XX                                                      !
      COSR = -0.060756474E0_WP                                      !
      SINR = 0.99756405E0_WP                                        !
      FAIL = .FALSE.                                                !
      NN = DEGREE+1                                                 !
!
! Algorithm fails if the leading coefficient is zero.
!
      IF (OPR(1) /= ZERO .OR. OPI(1) /= ZERO) GO TO 10              !
      FAIL = .TRUE.                                                 !
      RETURN                                                        !
!
! Remove the zeros at the origin if any
!
   10 IF (OPR(NN) /= ZERO .OR. OPI(NN) /= ZERO) GO TO 20            !
      IDNN2 = DEGREE-NN+2                                           !
      ZEROR(IDNN2) = ZERO                                           !
      ZEROI(IDNN2) = ZERO                                           !
      NN = NN-1                                                     !
      GO TO 10                                                      !
!
! Make a copy of the coefficients
!
   20 DO I = 1,NN                                                   !
        PR(I) = OPR(I)                                              !
        PI(I) = OPI(I)                                              !
        SHR(I) = CMOD(PR(I),PI(I))                                  !
      END DO                                                        !
!
! Scale the polynomial
!
      BND = RESCALE(NN,SHR,ETA,INFIN,SMALNO,BASE)                   !
      IF (BND == ONE) GO TO 40                                      !
      DO I = 1,NN                                                   !
        PR(I) = BND*PR(I)                                           !
        PI(I) = BND*PI(I)                                           !
      END DO                                                        !
!
! Start the algorithm for one zero
!
   40 IF (NN > 2) GO TO 50                                          !
!
! Calculate the final zero and return
!
      CALL CDIVID(-PR(2),-PI(2),PR(1),PI(1),ZEROR(DEGREE),        & !
                  ZEROI(DEGREE))                                    !
      RETURN                                                        !
!
! Calculate BND, a lower bound on the modulus of the zeros
!
   50 DO I = 1,NN                                                   !
        SHR(I) = CMOD(PR(I),PI(I))                                  !
      END DO                                                        !
      BND = CAUCHY(NN,SHR,SHI)                                      !
!
! Outer loop to control 2 major passes with different sequences
!     of shifts
!
      DO CNT1 = 1,2                                                 !
!
! First stage calculation, no shift
!
        CALL NOSHFT(5)                                              !
!
! Inner loop to select a shift
!
        DO CNT2 = 1,9                                               !
!
! Shift is chosen with modulus BND and amplitude rotated by
! 94 degrees from the previous shift
!
            XXX = COSR*XX-SINR*YY                                   !
            YY  = SINR*XX+COSR*YY                                   !
            XX  = XXX                                               !
            SR   = BND*XX                                           !
            SI = BND*YY                                             !
!
! Second stage calculation, fixed shift
!
            CALL FXSHFT(10*CNT2,ZR,ZI,CONV)                         !
!
            IF (.NOT. CONV) GO TO 80                                !
!
! The second stage jumps directly to the third stage iteration.
! If successful the zero is stored and the polynomial deflated
!
            IDNN2 = DEGREE-NN+2                                     !
            ZEROR(IDNN2) = ZR                                       !
            ZEROI(IDNN2) = ZI                                       !
            NN = NN-1                                               !
            DO I = 1,NN                                             !
              PR(I) = QPR(I)                                        !
              PI(I) = QPI(I)                                        !
            END DO                                                  !
!
            GO TO 40                                                !
!
   80       CONTINUE                                                !
!
! If the iteration is unsuccessful another shift is chosen
!
       END DO                                                       !
!
! If 9 shifts fail, the outer loop is repeated with another
!   sequence of shifts
!
      END DO                                                        !
!
! The zerofinder has failed on two major passes.
! Return empty handed
!
      FAIL = .TRUE.                                                 !
!
      END SUBROUTINE CPOLY
!
!=======================================================================
!
      SUBROUTINE NOSHFT(L1) 
!
! Computes  the derivative  polynomial as the initial H
! polynomial and computes L1 no-shift H polynomials.
!
!
!  Last Modified : 18 Jun 2020 by D. Sébilleau
!
!
      USE CPOLY_VAR
      USE REAL_NUMBERS,     ONLY : ZERO,TEN
!
      IMPLICIT NONE
!
      REAL (WP)             ::  XNI,T1,T2
!
      REAL (WP)             ::  FLOAT
!
      INTEGER               ::  L1,N,NM1,I,J,JJ
!
      N = NN-1                                                      !
      NM1 = N-1                                                     !
      DO I = 1,N                                                    !
        XNI = FLOAT(NN-I)                                           !
        HR(I) = XNI*PR(I)/FLOAT(N)                                  !
        HI(I) = XNI*PI(I)/FLOAT(N)                                  !
      END DO                                                        !
!
      DO JJ = 1,L1                                                  !
!
        IF (CMOD(HR(N),HI(N)) <= ETA*TEN*CMOD(PR(N),PI(N)))       & !
        GO TO 30                                                    !
        CALL CDIVID(-PR(NN),-PI(NN),HR(N),HI(N),TR,TI)              !
        DO I = 1,NM1                                                !
          J     = NN-I                                              !
          T1    = HR(J-1)                                           !
          T2    = HI(J-1)                                           !
          HR(J) = TR*T1-TI*T2+PR(J)                                 !
          HI(J) = TR*T2+TI*T1+PI(J)                                 !
        END DO                                                      !
        HR(1) = PR(1)                                               !
        HI(1) = PI(1)                                               !
        GO TO 50                                                    !
!
! If the constant term is essentially zero, shift H coefficients
!
   30   DO I = 1,NM1                                                !
          J = NN-I                                                  !
          HR(J) = HR(J-1)                                           !
          HI(J) = HI(J-1)                                           !
        END DO                                                      !
        HR(1) = ZERO                                                !
        HI(1) = ZERO                                                !
   50   CONTINUE                                                    !
!
      END DO                                                        !
!
      END SUBROUTINE NOSHFT
!
!=======================================================================
!
      SUBROUTINE FXSHFT(L2,ZR,ZI,CONV) 
!
! Computes L2 fixed-shift H polynomials and tests for
!   convergence.
! Initiates a variable-shift iteration and returns with the
!   approximate zero if successful.
!
! L2    : limit of fixed shift steps
! ZR,ZI : approximate zero if conv is .TRUE.
! CONV  : logical indicating convergence of stage 3 iteration
!
!
!  Last Modified : 18 Jun 2020 by D. Sébilleau
!
!
      USE CPOLY_VAR
      USE REAL_NUMBERS,     ONLY : HALF
!
      IMPLICIT NONE
!
      REAL (WP)             ::  ZR,ZI,OTR,OTI,SVSR,SVSI
!
      INTEGER               ::  L2,N,J,I
!
      LOGICAL               ::  CONV,TEST,PASD,BOOL
!
      N = NN-1                                                      !
!
! Evaluate P at S
!
      CALL POLYEV(NN,SR,SI,PR,PI,QPR,QPI,PVR,PVI)                   !
      TEST = .TRUE.                                                 !
      PASD = .FALSE.                                                !
!
! Calculate first T = -P(S)/H(S)
!
      CALL CALCT(BOOL)                                              !
!
! Main loop for one second stage step
!
      DO J = 1,L2                                                   !
!
        OTR = TR                                                    !
        OTI = TI                                                    !
!
! Compute next H polynomial and new T
!
        CALL NEXTH(BOOL)                                            !
        CALL CALCT(BOOL)                                            !
        ZR = SR+TR                                                  !
        ZI = SI+TI                                                  !
!
! Test for convergence unless stage 3 has failed once or this
!   is the last H polynomial .
!
        IF ( BOOL .OR. .NOT. TEST .OR. J .EQ. L2)      GO TO 50     !
        IF (CMOD(TR-OTR,TI-OTI) >= HALF*CMOD(ZR,ZI))   GO TO 40     !
        IF (.NOT. PASD)                                GO TO 30     !
!
! The weak convergence test has been passed twice, start the
!   third stage iteration, after saving the current H polynomial
!   and shift
!
        DO I = 1,N                                                  !
          SHR(I) = HR(I)                                            !
          SHI(I) = HI(I)                                            !
       END DO                                                       !
        SVSR = SR                                                   !
        SVSI = SI                                                   !
        CALL VRSHFT(10,ZR,ZI,CONV)                                  !
        IF (CONV) RETURN                                            !
!
! The iteration failed to converge. turn off testing and restore
!   H,S,PV and T
!
        TEST = .FALSE.                                              !
        DO I = 1,N                                                  !
          HR(I) = SHR(I)                                            !
          HI(I) = SHI(I)                                            !
        END DO                                                      !
        SR = SVSR                                                   !
        SI = SVSI                                                   !
        CALL POLYEV(NN,SR,SI,PR,PI,QPR,QPI,PVR,PVI)                 !
        CALL CALCT(BOOL)                                            !
        GO TO 50                                                    !
!
   30   PASD = .TRUE.                                               !  
        GO TO 50                                                    !
!
   40   PASD = .FALSE.                                              !
   50   CONTINUE                                                    !
!
      END DO                                                        !
!
! Attempt an iteration with final H polynomial from second stage
!
      CALL VRSHFT(10,ZR,ZI,CONV)                                    !
!
      END SUBROUTINE FXSHFT
!
!=======================================================================
!
      SUBROUTINE VRSHFT(L3,ZR,ZI,CONV)  
!
! Carries out the third stage iteration.
!
! L3      : limit of steps in stage 3.
! ZR,ZI   : on entry contains the initial iterate, if the
!             iteration converges it contains the final iterate
!             on exit.
! CONV    :  .TRUE. if iteration converges
!
!
!  Last Modified : 18 Jun 2020 by D. Sébilleau
!
!
      USE CPOLY_VAR
      USE REAL_NUMBERS,     ONLY : ONE
!
      IMPLICIT NONE
!
      REAL (WP)             ::  ZR,ZI,MP,MS,OMP,RELSTP
      REAL (WP)             ::  R1,R2,TP
!
      REAL (WP)             ::  SQRT
!
      INTEGER               ::  L3,I,J
!
      LOGICAL               ::  CONV,B,BOOL
!
      CONV = .FALSE.                                                !
      B = .FALSE.                                                   !
      SR = ZR                                                       !
      SI = ZI                                                       !
!
! Main loop for stage three
!
      DO I = 1,L3                                                    !
!
! Evaluate P at S and test for convergence
!
        CALL POLYEV(NN,SR,SI,PR,PI,QPR,QPI,PVR,PVI)                 !
        MP = CMOD(PVR,PVI)                                          !
        MS = CMOD(SR,SI)                                            !
        IF (MP > 20.0E0_WP*ERREV(NN,QPR,QPI,MS,MP,ARE,MRE))       & !
           GO TO 10                                                 !
!
! Polynomial value is smaller in value than a bound on the error
!   in evaluating P, terminate the iteration
!
        CONV = .TRUE.                                               !
        ZR = SR                                                     !
        ZI = SI                                                     !
        RETURN                                                      !
!
   10   IF (I == 1) GO TO 40                                        !
        IF (B .OR. MP < OMP .OR. RELSTP >= 0.05E0_WP)             & !
                  GO TO 30                                          !
!
! Iteration has stalled. Probably a cluster of zeros. Do 5 fixed
!   shift steps into the cluster to force one zero to dominate
!
        TP = RELSTP                                                 !
        B = .TRUE.                                                  !
        IF (RELSTP < ETA) TP = ETA                                  !
        R1 = SQRT(TP)                                               !
        R2 = SR*(ONE+R1)-SI*R1                                      !
        SI = SR*R1+SI*(ONE+R1)                                      !
        SR = R2                                                     !
        CALL POLYEV(NN,SR,SI,PR,PI,QPR,QPI,PVR,PVI)                 !
        DO J = 1,5                                                  !
          CALL CALCT(BOOL)                                          !
          CALL NEXTH(BOOL)                                          !
        END DO                                                      !
        OMP = INFIN                                                 !
        GO TO 50                                                    !
!
! Exit if polynomial value increases significantly
!
   30   IF (MP*0.1E0_WP > OMP) RETURN                               !
   40   OMP = MP                                                    !
!
! Calculate next iterate
!
   50   CALL CALCT(BOOL)                                            !
        CALL NEXTH(BOOL)                                            !
        CALL CALCT(BOOL)                                            !
!
        IF (BOOL) GO TO 60                                          !
!
        RELSTP = CMOD(TR,TI)/CMOD(SR,SI)                            !
        SR = SR+TR                                                  !
        SI = SI+TI                                                  !
   60   CONTINUE                                                    !
      END DO                                                        !
!
      END SUBROUTINE VRSHFT
!
!=======================================================================
!
      SUBROUTINE CALCT(BOOL) 
!
! Computes  T = -P(S)/H(S).
!
! BOOL   : logical, set true if H(S) is essentially zero.
!
!
!  Last Modified : 18 Jun 2020 by D. Sébilleau
!
!
      USE CPOLY_VAR
      USE REAL_NUMBERS,     ONLY : ZERO,TEN
!
      IMPLICIT NONE
!
      REAL (WP)             ::  HVR,HVI
!
      LOGICAL               ::  BOOL
!
      INTEGER               ::  N
!
      N = NN-1                                                      !
!
!
! Evaluate H(S)
!
      CALL POLYEV(N,SR,SI,HR,HI,QHR,QHI,HVR,HVI)                    !
      BOOL = CMOD(HVR,HVI) <= ARE*TEN*CMOD(HR(N),HI(N))             !
!
      IF (BOOL) GO TO 10                                            !
!
      CALL CDIVID(-PVR,-PVI,HVR,HVI,TR,TI)                          !
      RETURN                                                        !
!
   10 TR = ZERO                                                     !
      TI = ZERO                                                     !
! 
      END SUBROUTINE CALCT
!
!=======================================================================
!
      SUBROUTINE NEXTH(BOOL) 
!
! Calculates the next shifted H polynomial.
!
! BOOL   :  logical, if .TRUE. H(S) is essentially zero
!
!
!  Last Modified : 18 Jun 2020 by D. Sébilleau
!
!
      USE CPOLY_VAR
      USE REAL_NUMBERS,     ONLY : ZERO
!
      IMPLICIT NONE
!
      REAL (WP)             ::  T1,T2
!
      LOGICAL               ::  BOOL
!
      INTEGER               ::  N,NM1,J
!
      N = NN-1                                                      !
      NM1 = N-1                                                     !
!
      IF (BOOL) GO TO 20                                            !
!
      DO J = 2,N                                                    !
        T1 = QHR(J-1)                                               !
        T2 = QHI(J-1)                                               !
        HR(J) = TR*T1-TI*T2+QPR(J)                                  !
        HI(J) = TR*T2+TI*T1+QPI(J)                                  !
      END DO                                                        !
!
      HR(1) = QPR(1)                                                !
      HI(1) = QPI(1)                                                !
      RETURN                                                        !
!
! If H(S) is zero replace H with QH
!
   20 DO J = 2,N                                                    !
        HR(J) = QHR(J-1)                                            !
        HI(J) = QHI(J-1)                                            !
      END DO                                                        !
!
      HR(1) = ZERO                                                  !
      HI(1) = ZERO                                                  !
!
      END SUBROUTINE NEXTH
!
!=======================================================================
!
      SUBROUTINE POLYEV(NN,SR,SI,PR,PI,QR,QI,PVR,PVI)
!
! Evaluates a polynomial  P  at  S  by the Horner recurrence
! Placing the partial sums in Q and the computed value in PV.
!
!
!
      IMPLICIT NONE
!
      REAL (WP)             ::  PR(NN),PI(NN),QR(NN),QI(NN)
      REAL (WP)             ::  SR,SI,PVR,PVI,T
!
      INTEGER               ::  NN,I
!
      QR(1) = PR(1)                                                 !
      QI(1) = PI(1)                                                 !
      PVR = QR(1)                                                   !
      PVI = QI(1)                                                   !
      DO I = 2,NN                                                   !
        T = PVR*SR-PVI*SI+PR(I)                                     !
        PVI = PVR*SI+PVI*SR+PI(I)                                   !
        PVR = T                                                     !
        QR(I) = PVR                                                 !
        QI(I) = PVI                                                 !
      END DO                                                        !
!
      END SUBROUTINE POLYEV
!
!=======================================================================
!
      FUNCTION ERREV(NN,QR,QI,MS,MP,ARE,MRE)
!
! Bounds the error in evaluating the polynomial by the Horner
!   recurrence.
!
!   QR,QI    :  the partial sums
!   MS       :  modulus of the point
!   MP       :  modulus of polynomial value
!   ARE, MRE :  error bounds on complex addition and multiplication
!
!
!
      IMPLICIT NONE
!
      REAL (WP)             ::  QR(NN),QI(NN),MS,MP,ARE,MRE,E
      REAL (WP)             ::  ERREV
!
      INTEGER               ::  NN,I
!
      E = CMOD(QR(1),QI(1))*MRE/(ARE+MRE)                           !
!
      DO I = 1,NN                                                   !
        E = E*MS+CMOD(QR(I),QI(I))                                  !
      END DO                                                        !
!
      ERREV = E*(ARE+MRE)-MP*MRE                                    !
!
      END FUNCTION ERREV
!
!=======================================================================
!
      FUNCTION CAUCHY(NN,PT,Q)
!
! Cauchy computes a lower bound on the moduli of the zeros of a
!   polynomial 
!
!   PT   : modulus of the coefficients.
!
!  Last Modified : 18 Jun 2020 by D. Sébilleau
!
!
      USE REAL_NUMBERS,     ONLY : ZERO
!
      IMPLICIT NONE
!
      REAL (WP)             ::  Q(NN),PT(NN),X,XM,F,DX,DF
      REAL (WP)             ::  CAUCHY
!
      REAL (WP)             ::  ABS,EXP,LOG,FLOAT
!
      INTEGER               ::  NN,N,I
!
      PT(NN) = -PT(NN)                                              !
!
! Compute upper estimate of bound
!
      N = NN-1                                                      !
      X = EXP( (LOG(-PT(NN)) - LOG(PT(1)))/FLOAT(N) )               !
!
      IF (PT(N) == ZERO) GO TO 20                                   !
!
! If Newton step at the origin is better, use it
!
      XM = -PT(NN)/PT(N)                                            !
      IF (XM.LT.X) X=XM                                             !
!
! Chop the interval (0,X) until F <= 0
!
   20 XM = X*0.1E0_WP                                               !
      F = PT(1)                                                     !
      DO I = 2,NN                                                   !
        F = F*XM+PT(I)                                              !
      END DO                                                        !
!
      IF (F <= ZERO) GO TO 40                                       !
!
      X = XM                                                        !
      GO TO 20                                                      !
!
   40 DX = X                                                        !
!
! Do Newton iteration until X converges to two decimal places
!
   50 IF (ABS(DX/X) <= 0.005E0_WP) GO TO 70                         !
!
      Q(1) = PT(1)                                                  !
      DO I = 2,NN                                                   !
        Q(I) = Q(I-1)*X+PT(I)                                       !
      END DO                                                        !
!
      F = Q(NN)                                                     ! 
      DF = Q(1)                                                     !
      DO I = 2,N                                                    !
        DF = DF*X+Q(I)                                              !
      END DO                                                        !
!
      DX = F/DF                                                     !
      X = X-DX                                                      !
      GO TO 50                                                      !
!
   70 CAUCHY = X                                                    !
!
      END FUNCTION CAUCHY
!
!=======================================================================
!
      FUNCTION RESCALE(NN,PT,ETA,INFIN,SMALNO,BASE)
!
! Returns a scale factor to multiply the coefficients of the
!  polynomial. The scaling is done to avoid overflow and to avoid
!  undetected underflow interfering with the convergence
!  criterion.  The factor is a power of the base.
!
!   PT                    :  modulus of coefficients of P
!   ETA,INFIN,SMALNO,BASE :  constants describing the
!                              floating point arithmetic.
!
!  Last Modified : 18 Jun 2020 by D. Sébilleau
!
!
      USE REAL_NUMBERS,     ONLY : ZERO,ONE,HALF
!
      IMPLICIT NONE
!
      REAL (WP)             ::  PT(NN),ETA,INFIN,SMALNO,BASE
      REAL (WP)             ::  RESCALE
      REAL (WP)             ::  HI,LO,X,SC
      REAL (WP)             ::  MAX,MIN,SQRT,LOG
!
      INTEGER               ::  NN,I,L
!
! Find largest and smallest moduli of coefficients.
!
      HI = SQRT(INFIN)                                              !
      LO = SMALNO/ETA                                               !
      MAX = ZERO                                                    !
      MIN = INFIN                                                   !
!
      DO I = 1,NN                                                   !
        X = PT(I)                                                   !
        IF (X > MAX) MAX = X                                        !
        IF (X /= ZERO .AND. X < MIN) MIN = X                        !
      END DO                                                        !
!
! Scale only if there are very large or very small components
!
      RESCALE = ONE                                                 !
!
      IF (MIN >= LO .AND. MAX <= HI) RETURN                         !
!
      X = LO/MIN                                                    !
      IF (X > ONE) GO TO 20                                         !
!
      SC = ONE/(SQRT(MAX)*SQRT(MIN))                                !
      GO TO 30                                                      !
!
   20 SC = X                                                        !
      IF (INFIN/SC > MAX) SC = ONE                                  !
!
   30 L = LOG(SC)/LOG(BASE) + HALF                                  !
      RESCALE = BASE**L                                             !
!
      END FUNCTION RESCALE
!
!=======================================================================
!
      SUBROUTINE CDIVID(AR,AI,BR,BI,CR,CI)
!
! Complex division C = A/B, avoiding overflow.
!
!  Last Modified : 18 Jun 2020 by D. Sébilleau
!
!
      USE REAL_NUMBERS,     ONLY : ZERO
!
      IMPLICIT NONE
!
      REAL (WP)             ::  AR,AI,BR,BI,CR,CI,R,D,T,INFIN
      REAL (WP)             ::  ABS
!
      IF (BR /= ZERO  .OR. BI /= ZERO) GO TO 10                     !
!
! Division by zero, C = infinity
!
      CALL MCON (T,INFIN,T,T)                                       !
      CR = INFIN                                                    !
      CI = INFIN                                                    !
      RETURN                                                        !
!
   10 IF (ABS(BR) >= ABS(BI)) GO TO 20                              !
!
      R = BR/BI                                                     !
      D = BI+R*BR                                                   !
      CR = (AR*R+AI)/D                                              !
      CI = (AI*R-AR)/D                                              !
      RETURN                                                        !
!
   20 R = BI/BR                                                     !
      D = BR+R*BI                                                   !  
      CR = (AR+AI*R)/D                                              !
      CI = (AI-AR*R)/D                                              !
      RETURN                                                        !
!
      END SUBROUTINE CDIVID
!
!=======================================================================
!
      FUNCTION CMOD(R,I)
!
! Modulus of a complex number avoiding overflow.
!
!
!  Last Modified : 18 Jun 2020 by D. Sébilleau
!
!
      USE REAL_NUMBERS,     ONLY : ONE
      USE SQUARE_ROOTS,     ONLY : SQR2
!
      IMPLICIT NONE
!
      REAL (WP)             ::  R,I,AR,AI
      REAL (WP)             ::  CMOD
!
      REAL (WP)             ::  ABS,SQRT
!
      AR = ABS(R)                                                   !
      AI = ABS(I)                                                   !
!
      IF (AR >= AI) GO TO 10                                        !
!
      CMOD = AI*SQRT(ONE+(AR/AI)**2)                                !
      RETURN                                                        !
!
   10 IF (AR <= AI) GO TO 20                                        !
!
      CMOD = AR*SQRT(ONE+(AI/AR)**2)                                !
      RETURN                                                        !
!
   20 CMOD = AR*SQR2                                                !
      RETURN                                                        !
!
      END FUNCTION CMOD
!
!=======================================================================
!
      SUBROUTINE MCON(ETA,INFINY,SMALNO,BASE)
!
! MCON provides machine constants used in various parts of the
!   program. The user may either set them directly or use the
!   statements below to compute them. The meaning of the four
!   constants are:
!
!   ETA    :   The maximum relative representation error
!                which can be described as the smallest positive
!                floating-point number such that 1.0D0 + ETA is
!                greater than 1.0D0.
!   INFINY :   the largest floating-point number
!   SMALNO :   the smallest positive floating-point number
!   BASE   :   the base of the floating-point number system used
!
! Let T be the number of base-digits in each floating-point
!   number(DOUBLE PRECISION). Then ETA is either .5*B**(1-T)
!   or B**(1-T) depending on whether rounding or truncation
!   is used.
!
! Let M be the largest exponent and N the smallest exponent
!   in the number system. Then INFINY is (1-BASE**(-T))*BASE**M
!   and SMALNO IS BASE**N.
!
! The values for BASE,T,M,N below correspond to the ibm/360.
!
!
!  Last Modified : 18 Jun 2020 by D. Sébilleau
!
!
      USE REAL_NUMBERS,     ONLY : ONE
!
      IMPLICIT NONE
!
      REAL (WP)             ::  ETA,INFINY,SMALNO,BASE
!
      INTEGER               ::  M,N,T
!
      BASE = 16.0E0_WP                                              !
      T =  14                                                       !
      M =  63                                                       !
      N = -65                                                       !
      ETA    = BASE**(1-T)                                          !
      INFINY = BASE*(ONE-BASE**(-T))*BASE**(M-1)                    !
      SMALNO = (BASE**(N+3))/BASE**3                                !
!
      END SUBROUTINE MCON
!
END MODULE FIND_ZERO
