C     ***QUARTIC************************************************25.03.98
C     Solution of a quartic equation:

!     dd(0)+dd(1)*z+dd(2)*z**2+dd(3)*z**3+dd(4)*z**4=0

C     ref.: J. E. Hacke, Amer. Math. Monthly, Vol. 48, 327-328, (1941)
C     NO WARRANTY, ALWAYS TEST THIS SUBROUTINE AFTER DOWNLOADING
C     ******************************************************************
C     dd(0:4)     (i)  vector containing the polynomial coefficients
C     sol(1:4)    (o)  results, real part
C     soli(1:4)   (o)  results, imaginary part
C     Nsol        (o)  number of real solutions 
C     ==================================================================
      subroutine quartic(dd,sol,soli,Nsol)
      implicit double precision (a-h,o-z)
      dimension dd(0:4),sol(4),soli(4)
      dimension AA(0:3),z(3)
C
      Nsol = 0
      a = dd(4)
      b = dd(3)
      c = dd(2)
      d = dd(1)
      e = dd(0)
C
      if (dd(4).eq.0.0d+0) then
	write(*,*)'ERROR: NOT A QUARTIC EQUATION'
	return
      endif
C
      p=-(3.0d0/8.0d0)*(b/a)*(b/a)+c/a
      q =(b/a)*(b/a)*(b/a)/8.0d0-(b/a)*(c/a)/2.0d0+d/a
      r =(-3.0d0/256.0d0)*(b/a)*(b/a)*(b/a)*(b/a)+
     &    (b/a)*(b/a)*(c/a)/16.0d0-(b/a)*(d/a)/4.0d0+ 
     &      e/a

!
!     solve cubic resolvent
      AA(3) =  8.0d0
      AA(2) = -4.0d0*p 
      AA(1) = -8.0d0*r
      AA(0) =  4.0d0*p*r - q*q
      call cubic(AA,z,ncube)
C      
      zsol = -1.0d99
      do 5 i=1,ncube
        zsol = dmax1(zsol,z(i))
5     continue
      z(1) = zsol
      xK2 = 2.0d0 * z(1) - p
      xK  = dsqrt(xK2)
C-----------------------------------------------
      if (xK.eq.0.0d0) then
        xL2 = z(1)*z(1) - r
	if (xL2.lt.0.0d0) then
	  write(*,*)'Sorry, no solution'
	  return
        endif
	xL  = dsqrt(xL2)
      else
        xL = q/(2.0d0 * xK)
      endif
C-----------------------------------------------
      sqp = xK2 - 4.0d0*(z(1) + xL)
      sqm = xK2 - 4.0d0*(z(1) - xL)
C
      do 10 i=1,4
        soli(i) = 0.0d0
10    continue
      if (sqp.ge.0.0d0 .and. sqm.ge.0.0d0) then
	sol(1) = 0.5d+0*( xK + dsqrt(sqp))
	sol(2) = 0.5d+0*( xK - dsqrt(sqp))
	sol(3) = 0.5d+0*(-xK + dsqrt(sqm))
	sol(4) = 0.5d+0*(-xK - dsqrt(sqm))
	Nsol = 4
      else if  (sqp.ge.0.d+0 .and. sqm.lt.0.d+0) then
	sol(1) =  0.5d+0*(xK + dsqrt(sqp))
	sol(2) =  0.5d+0*(xK - dsqrt(sqp))
	sol(3) = -0.5d+0*xK 
	sol(4) = -0.5d+0*xK 
	soli(3) =  dsqrt(-0.25d+0 * sqm)
	soli(4) = -dsqrt(-0.25d+0 * sqm)
	Nsol = 2
      else if  (sqp.lt.0.d+0 .and. sqm.ge.0.d+0) then
	sol(1) = 0.5d+0*(-xK + dsqrt(sqm))
	sol(2) = 0.5d+0*(-xK - dsqrt(sqm))
	sol(3) =  0.5d+0*xK 
	sol(4) =  0.5d+0*xK 
	soli(3) =  dsqrt(-0.25d+0 * sqp)
	soli(4) = -dsqrt(-0.25d+0 * sqp)
	Nsol = 2
      else if  (sqp.lt.0.d+0 .and. sqm.lt.0.d+0) then
	sol(1) = -0.5d+0*xK 
	sol(2) = -0.5d+0*xK 
	soli(1) =  dsqrt(-0.25d+0 * sqm)
	soli(2) = -dsqrt(-0.25d+0 * sqm)
	sol(3) =  0.5d+0*xK 
	sol(4) =  0.5d+0*xK 
	soli(3) =  dsqrt(-0.25d+0 * sqp)
	soli(4) = -dsqrt(-0.25d+0 * sqp)
	Nsol = 0
      endif
      do 20 i=1,4
        sol(i) = sol(i) - b/(4.d+0*a)
20    continue
C
      return
      END

C     ***CUBIC************************************************08.11.1986
C     Solution of a cubic equation
C     Equations of lesser degree are solved by the appropriate formulas.
C     The solutions are arranged in ascending order.
C     NO WARRANTY, ALWAYS TEST THIS SUBROUTINE AFTER DOWNLOADING
C     ******************************************************************
C     A(0:3)      (i)  vector containing the polynomial coefficients
C     X(1:L)      (o)  results
C     L           (o)  number of valid solutions (beginning with X(1))
C     ==================================================================
      SUBROUTINE CUBIC(A,X,L)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION A(0:3),X(3),U(3)
      PARAMETER(PI=3.1415926535897932D+0,THIRD=1.D+0/3.D+0)
      INTRINSIC DMIN1,DMAX1,DACOS
C
C     define cubic root as statement function
      CBRT(Z)=DSIGN(DABS(Z)**THIRD,Z)
C
C     ==== determine the degree of the polynomial ====
C
      IF (A(3).NE.0.D+0) THEN
C
C       cubic problem
	W=A(2)/A(3)*THIRD
	P=(A(1)/A(3)*THIRD-W**2)**3
	Q=-.5D+0*(2.D+0*W**3-(A(1)*W-A(0))/A(3))
	DIS=Q**2+P
	IF (DIS.LT.0.D+0) THEN
C         three real solutions!
C         Confine the argument of ACOS to the interval [-1;1]!
	  PHI=DACOS(DMIN1(1.D+0,DMAX1(-1.D+0,Q/DSQRT(-P))))
	  P=2.D+0*(-P)**(5.D-1*THIRD)
	  DO 100 I=1,3
            U(I)=P*DCOS((PHI+DBLE(2*I)*PI)*THIRD)-W
100       continue
	  X(1)=DMIN1(U(1),U(2),U(3))
	  X(2)=DMAX1(DMIN1(U(1),U(2)),DMIN1(U(1),U(3)),DMIN1(U(2),U(3)))
	  X(3)=DMAX1(U(1),U(2),U(3))
	  L=3
	ELSE
C         only one real solution!
	  DIS=DSQRT(DIS)
	  X(1)=CBRT(Q+DIS)+CBRT(Q-DIS)-W
	  L=1
	END IF
C
      ELSE IF (A(2).NE.0.D+0) THEN
C
C       quadratic problem
	P=5.D-1*A(1)/A(2)
	DIS=P**2-A(0)/A(2)
	IF (DIS.GE.0.D+0) THEN
C         two real solutions!
	  X(1)=-P-DSQRT(DIS)
	  X(2)=-P+DSQRT(DIS)
	  L=2
	ELSE
C         no real solution!
	  L=0
	END IF
C
      ELSE IF (A(1).NE.0.D+0) THEN
C
C       linear equation
	X(1)=-A(0)/A(1)
	L=1
C
      ELSE
C       no equation
	L=0
      END IF
C
C     ==== perform one step of a newton iteration in order to minimize
C          round-off errors ====
      DO 110 I=1,L
	X(I)=X(I)-(A(0)+X(I)*(A(1)+X(I)*(A(2)+X(I)*A(3))))
     *  /(A(1)+X(I)*(2.D+0*A(2)+X(I)*3.D+0*A(3)))
  110 CONTINUE
      RETURN
      END