subroutine CUBIC( t, f, fp, ta, fa, fpa, tlower, tupper ) c----------------------------------------- c arguments c----------------------------------------- double precision t, f, fp, ta, fa, fpa, tlower, tupper c----------------------------------------- c local variables c----------------------------------------- double precision sign, den, anum double precision z1, b, discri c----------------------------------------- c Using f and fp at t and ta, c computes new t by cubic formula c safeguarded inside [tlower,tupper]. c----------------------------------------- z1 = dble(fp) + dble(fpa) - 3.d0*dble(fa-f)/dble(ta-t) b = z1 + dble(fp) c----------------------------------------- c first compute the discriminant c (without overflow) c----------------------------------------- if (abs(z1).le.1.) then discri = z1*z1-dble(fp)*dble(fpa) if (discri .lt. 0.d0) then if (fp.lt.0.) t = tupper if (fp.ge.0.) t = tlower return else discri = dsqrt(discri) end
if else discri = dble(fp)/z1 discri = discri*dble(fpa) discri = z1-discri if (z1.ge.0.d0 .and. discri.ge.0.d0) then discri = dsqrt(z1)*dsqrt(discri) else if (z1.le.0.d0 .and. discri.le.0.d0) then discri = dsqrt(-z1)*dsqrt(-discri) else if (fp.lt.0.) t = tupper if (fp.ge.0.) t = tlower return end
if end
if c----------------------------------------- c discriminant nonnegative, c compute solution (without overflow) c----------------------------------------- if (t-ta .lt. 0.0) then discri = -discri end
if sign = (t-ta)/abs(t-ta) if (sngl(b)*sign .gt. 0.0) then t = t + fp*(ta-t)/sngl(b+discri) else den = sngl(z1+b+dble(fpa)) anum = sngl(b-discri) if (abs((t-ta)*anum).lt.(tupper-tlower)*abs(den)) then t = t + anum*(ta-t)/den else t = tupper end
if end
if t = max( t, tlower ) t = min( t, tupper ) return end