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