191 lines
5.3 KiB
FortranFixed
191 lines
5.3 KiB
FortranFixed
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
|