! !======================================================================= ! 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