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