1140 lines
42 KiB
Fortran
1140 lines
42 KiB
Fortran
|
!
|
||
|
|
!=======================================================================
|
||
|
|
!
|
||
|
|
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
|