367 lines
12 KiB
Fortran
367 lines
12 KiB
Fortran
!
|
|
!=======================================================================
|
|
!
|
|
MODULE POLYNOMIAL_EQ
|
|
!
|
|
! This module provides solutions for low-degree polynomial equations
|
|
!
|
|
USE ACCURACY_REAL
|
|
!
|
|
CONTAINS
|
|
!
|
|
!
|
|
!=======================================================================
|
|
!
|
|
SUBROUTINE QUADRATIC_EQUATION(A,B,C,X1,X2)
|
|
!
|
|
! This subroutine solves the quadratic equation:
|
|
!
|
|
! A*X^3 + B*X^2 + C = 0
|
|
!
|
|
! using the general quadratic formula
|
|
!
|
|
! References: (1) https://en.wikipedia.org/wiki/Quadratic_formula
|
|
!
|
|
!
|
|
!
|
|
! Input parameters:
|
|
!
|
|
! * A,B,C : coefficients of cubic formula
|
|
!
|
|
!
|
|
! Output parameters:
|
|
!
|
|
! * X1,X2 : roots of the equation
|
|
!
|
|
!
|
|
! Author : D. Sébilleau
|
|
!
|
|
! Last modified : 5 Jun 2020
|
|
!
|
|
!
|
|
USE REAL_NUMBERS, ONLY : FOUR,HALF
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
COMPLEX (WP) :: A,B,C
|
|
COMPLEX (WP) :: X1,X2
|
|
COMPLEX (WP) :: DD,KK
|
|
!
|
|
! Intermediate formula
|
|
!
|
|
DD=CDSQRT(B*B-FOUR*A*C) !
|
|
KK=HALF/A !
|
|
!
|
|
! Roots
|
|
!
|
|
X1=KK*(-B+DD) !
|
|
X2=KK*(-B-DD) !
|
|
!
|
|
END SUBROUTINE QUADRATIC_EQUATION
|
|
!
|
|
!=======================================================================
|
|
!
|
|
SUBROUTINE CUBIC_EQUATION(A,B,C,D,X1,X2,X3)
|
|
!
|
|
! This subroutine solves the cubic equation:
|
|
!
|
|
! A*X^3 + B*X^2 + C*X + D = 0
|
|
!
|
|
! using the general cubic formula
|
|
!
|
|
! References: (1) https://en.wikipedia.org/wiki/Cubic_equation
|
|
!
|
|
!
|
|
!
|
|
! Input parameters:
|
|
!
|
|
! * A,B,C,D : coefficients of cubic formula
|
|
!
|
|
!
|
|
! Output parameters:
|
|
!
|
|
! * X1,X2,X3 : roots of the equation
|
|
!
|
|
!
|
|
! Author : D. Sébilleau
|
|
!
|
|
! Last modified : 5 Jun 2020
|
|
!
|
|
!
|
|
USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FOUR,NINE,HALF,THIRD
|
|
USE COMPLEX_NUMBERS, ONLY : ONEC,IC
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
COMPLEX (WP) :: A,B,C,D
|
|
COMPLEX (WP) :: X1,X2,X3
|
|
COMPLEX (WP) :: D0,D1,CC
|
|
COMPLEX (WP) :: SQ,KK
|
|
COMPLEX (WP) :: Z0,Z1,Z2
|
|
!
|
|
REAL (WP) :: EPS
|
|
REAL (WP) :: CP
|
|
!
|
|
EPS=1.0E-6_WP ! accuracy
|
|
!
|
|
! Intermediate formulas
|
|
!
|
|
D0=B*B-THREE*A*C !
|
|
D1=TWO*B*B*B - NINE*A*B*C + 27.0E0_WP*A*A*D !
|
|
SQ=CDSQRT(D1*D1-FOUR*D0*D0*D0) !
|
|
CP=CDABS(D1-SQ) !
|
|
!
|
|
IF(CP < EPS) THEN !
|
|
CC=(HALF*(D1+SQ))**THIRD !
|
|
ELSE !
|
|
CC=(HALF*(D1-SQ))**THIRD !
|
|
END IF !
|
|
!
|
|
KK=-THIRD/A !
|
|
!
|
|
Z0=ONEC !
|
|
Z1=HALF*(IC*DSQRT(THREE)-ONE) !
|
|
Z2=Z1*Z1 !
|
|
!
|
|
! Roots
|
|
!
|
|
X1=KK*(B + Z0*CC + D0/(Z0*CC)) !
|
|
X2=KK*(B + Z1*CC + D0/(Z1*CC)) !
|
|
X3=KK*(B + Z2*CC + D0/(Z2*CC)) !
|
|
!
|
|
END SUBROUTINE CUBIC_EQUATION
|
|
!
|
|
!=======================================================================
|
|
!
|
|
SUBROUTINE QUARTIC_EQUATION(A,B,C,D,E,X1,X2,X3,X4)
|
|
!
|
|
! This subroutine solves the quartic equation:
|
|
!
|
|
! A*X^4 + B*X^3 + C*X^2 + D*X + E = 0
|
|
!
|
|
! using the general quartic formula
|
|
!
|
|
! References: (1) https://en.wikipedia.org/wiki/Quartic_function
|
|
!
|
|
!
|
|
!
|
|
! Input parameters:
|
|
!
|
|
! * A,B,C,D,E : coefficients of cubic formula
|
|
!
|
|
!
|
|
! Output parameters:
|
|
!
|
|
! * X1,X2,X3,X4 : roots of the equation
|
|
!
|
|
!
|
|
! Author : D. Sébilleau
|
|
!
|
|
! Last modified : 5 Jun 2020
|
|
!
|
|
!
|
|
USE REAL_NUMBERS, ONLY : TWO,THREE,FOUR,EIGHT,NINE,HALF,THIRD
|
|
USE COMPLEX_NUMBERS, ONLY : ONEC,IC
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
COMPLEX (WP) :: A,B,C,D,E
|
|
COMPLEX (WP) :: X1,X2,X3,X4
|
|
COMPLEX (WP) :: PP,QQ,S,Q
|
|
COMPLEX (WP) :: D0,D1
|
|
!
|
|
! Intermediate formulas
|
|
!
|
|
PP=0.125E0_WP*(EIGHT*A*C-THREE*B*B)/(A*A) !
|
|
QQ=0.125E0_WP*(B*B*B-FOUR*A*B*C+EIGHT*A*A*D)/(A*A*A) !
|
|
!
|
|
D0=C*C - THREE*B*D + 12.0E0_WP*A*E !
|
|
D1=TWO*C*C*C - NINE*B*C*D + 27.0E0_WP*B*B*E + & !
|
|
27.0E0_WP*A*D*D - 72.0E0_WP*A*C*E !
|
|
!
|
|
Q=(HALF*(D1 + CDSQRT(D1*D1-FOUR*D0*D0*D0)) )**THIRD !
|
|
S=HALF*CDSQRT( -TWO*THIRD*PP + THIRD*(Q + D0/Q)/A ) !
|
|
!
|
|
! Roots
|
|
!
|
|
X1=-B*HALF*HALF/A - S + HALF*CDSQRT(-FOUR*S*S-TWO*PP+QQ/S) !
|
|
X2=-B*HALF*HALF/A - S - HALF*CDSQRT(-FOUR*S*S-TWO*PP+QQ/S) !
|
|
X3=-B*HALF*HALF/A + S + HALF*CDSQRT(-FOUR*S*S-TWO*PP-QQ/S) !
|
|
X4=-B*HALF*HALF/A + S - HALF*CDSQRT(-FOUR*S*S-TWO*PP-QQ/S) !
|
|
!
|
|
END SUBROUTINE QUARTIC_EQUATION
|
|
!
|
|
!=======================================================================
|
|
!
|
|
SUBROUTINE CHECK_ROOTS3(X1,X2,X3,Y)
|
|
!
|
|
! This subroutine checks among the three roots of a
|
|
! cubic equation if one is real and positive
|
|
!
|
|
! Input parameters:
|
|
!
|
|
! * X1,X2,X3 : roots of the equation
|
|
!
|
|
!
|
|
! Output parameters:
|
|
!
|
|
! * Y : real and positive of the equation
|
|
!
|
|
!
|
|
! Author : D. Sébilleau
|
|
!
|
|
! Last modified : 5 Jun 2020
|
|
!
|
|
!
|
|
USE REAL_NUMBERS, ONLY : ZERO
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
COMPLEX (WP) :: X1,X2,X3
|
|
!
|
|
REAL (WP) :: R1,R2,R3,I1,I2,I3
|
|
REAL (WP) :: Y
|
|
REAL (WP) :: EPS
|
|
!
|
|
INTEGER :: IM1,IM2,IM3
|
|
INTEGER :: IR1,IR2,IR3
|
|
INTEGER :: IR,IM
|
|
INTEGER :: LOGF
|
|
!
|
|
EPS=1.0E-6_WP ! accuracy
|
|
!
|
|
LOGF=6 !
|
|
!
|
|
R1=DREAL(X1) !
|
|
R2=DREAL(X2) !
|
|
R3=DREAL(X3) !
|
|
!
|
|
I1=DIMAG(X1) !
|
|
I2=DIMAG(X2) !
|
|
I3=DIMAG(X3) !
|
|
!
|
|
IR1=0 !
|
|
IR2=0 !
|
|
IR3=0 !
|
|
!
|
|
IM1=0 !
|
|
IM2=0 !
|
|
IM3=0 !
|
|
!
|
|
IF(R1 >= ZERO) IR1=1 !
|
|
IF(R2 >= ZERO) IR2=1 !
|
|
IF(R3 >= ZERO) IR3=1 !
|
|
!
|
|
IF(DABS(I1) < EPS) IM1=1 !
|
|
IF(DABS(I2) < EPS) IM2=1 !
|
|
IF(DABS(I3) < EPS) IM3=1 !
|
|
!
|
|
IR=MAX(IR1,IR2,IR3) !
|
|
IM=MAX(IM1,IM2,IM3) !
|
|
!
|
|
! Result
|
|
!
|
|
IF(IR*IM == 0) THEN !
|
|
WRITE(LOGF,10) !
|
|
STOP !
|
|
ELSE
|
|
IF(IR1*IM1 == 1) THEN !
|
|
Y=R1 !
|
|
ELSE IF(IR2*IM2 == 1) THEN !
|
|
Y=R2 !
|
|
ELSE IF(IR3*IM3 == 1) THEN !
|
|
Y=R3 !
|
|
END IF !
|
|
END IF !
|
|
!
|
|
! Format
|
|
!
|
|
10 FORMAT(//,5X,'<<<<< Subroutine CUBIC_EQUATION: >>>>>',/, &
|
|
5X,'<<<<< No real positive value X^2 >>>>>')
|
|
!
|
|
END SUBROUTINE CHECK_ROOTS3
|
|
!
|
|
!=======================================================================
|
|
!
|
|
SUBROUTINE CHECK_ROOTS2(X1,X2,Y)
|
|
!
|
|
! This subroutine checks among the two roots of a
|
|
! quadratic equation if one is real and positive
|
|
!
|
|
! Input parameters:
|
|
!
|
|
! * X1,X2 : roots of quadratic formula
|
|
!
|
|
!
|
|
! Output parameters:
|
|
!
|
|
! * Y : real and positive of the equation
|
|
!
|
|
!
|
|
! Author : D. Sébilleau
|
|
!
|
|
! Last modified : 5 Jun 2020
|
|
!
|
|
!
|
|
USE REAL_NUMBERS, ONLY : ZERO
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
COMPLEX (WP) :: X1,X2
|
|
!
|
|
REAL (WP) :: R1,R2,I1,I2
|
|
REAL (WP) :: Y
|
|
REAL (WP) :: EPS
|
|
!
|
|
INTEGER :: IM1,IM2
|
|
INTEGER :: IR1,IR2
|
|
INTEGER :: IR,IM
|
|
INTEGER :: LOGF
|
|
!
|
|
EPS=1.0E-6_WP ! accuracy
|
|
!
|
|
LOGF=6 !
|
|
!
|
|
R1=DREAL(X1) !
|
|
R2=DREAL(X2) !
|
|
!
|
|
I1=DIMAG(X1) !
|
|
I2=DIMAG(X2) !
|
|
!
|
|
IR1=0 !
|
|
IR2=0 !
|
|
!
|
|
IM1=0 !
|
|
IM2=0 !
|
|
!
|
|
IF(R1 >= ZERO) IR1=1 !
|
|
IF(R2 >= ZERO) IR2=1 !
|
|
!
|
|
IF(DABS(I1) < EPS) IM1=1 !
|
|
IF(DABS(I2) < EPS) IM2=1 !
|
|
!
|
|
IR=MAX(IR1,IR2) !
|
|
IM=MAX(IM1,IM2) !
|
|
!
|
|
! Result
|
|
!
|
|
IF(IR*IM == 0) THEN !
|
|
WRITE(LOGF,10) !
|
|
STOP !
|
|
ELSE
|
|
IF(IR1*IM1 == 1) THEN !
|
|
Y=R1 !
|
|
ELSE IF(IR2*IM2 == 1) THEN !
|
|
Y=R2 !
|
|
END IF !
|
|
END IF !
|
|
!
|
|
! Format
|
|
!
|
|
10 FORMAT(//,5X,'<<<<< Subroutine QUADRATIC_EQUATION: >>>>>',/,&
|
|
5X,'<<<<< No real positive value of X >>>>>')
|
|
!
|
|
END SUBROUTINE CHECK_ROOTS2
|
|
!
|
|
END MODULE POLYNOMIAL_EQ
|