**************************************************************************** * freudenstein and roth function * more, garbow, and hillstrom, acm toms vol. 7 no. 1 (march 1981) 17-41 **************************************************************************** subroutine getfun( x, n, f, m, ftf, fj, lfj, g, mode) implicit double precision (a-h,o-z) integer n, m, lfj, mode double precision x(n), f(m), ftf, fj(lfj,n), g(n) integer nprob, nprobs, nstart, nstrts common /PROBLM/ nprob, nprobs, nstart, nstrts integer nout common /IOUNIT/ nout logical lf, lj integer na, nb, nc, nd, nt, nh double precision x1, x2 double precision ddot double precision zero, one, two, three, five, ten double precision thirtn, fourtn, twnine parameter (zero = 0.d0, one = 1.d0, two = 2.d0) parameter (three = 3.d0, five = 5.d0, ten = 10.d0) parameter (thirtn = 13.d0, fourtn = 14.d0, twnine = 29.d0) *======================================================================= if (mode .eq. 0) goto 20 if (mode .eq. -1) goto 10 if (mode .eq. -2) goto 30 x1 = x(1) x2 = x(2) na = mode / 1000 nh = mode - na*1000 nb = nh / 100 nt = nh - nb*100 nc = nt / 10 nd = nt - nc*10 lf = (na .ne. 0) .or. (nb .ne. 0) .or. (nd .ne. 0) lj = (nc .ne. 0) .or. (nd .ne. 0) if (lf .and. lj) goto 300 if (lf) goto 100 if (lj) goto 200 *----------------------------------------------------------------------- 10 continue nprobs = 1 nstrts = 1 n = 2 m = 2 if (nout .gt. 0) write( nout, 9999) n, m return *----------------------------------------------------------------------- 20 continue x(1) = 0.5d0 x(2) = -2.0d0 return *----------------------------------------------------------------------- 30 continue x(1) = 5.d0 x(2) = 4.d0 ftf = zero return *----------------------------------------------------------------------- 100 continue f(1) = -thirtn + x1 + ((five - x2)*x2 - two)*x2 f(2) = -twnine + x1 + (( x2 + one)*x2 - fourtn)*x2 if (nb .ne. 0) ftf = ddot( m, f, 1, f, 1) return 200 continue fj( 1, 1) = one fj( 2, 1) = one fj( 1, 2) = (ten - three*x2)*x2 - two fj( 2, 2) = (three*x2 + two)*x2 - fourtn return 300 continue f(1) = -thirtn + x1 + ((five - x2)*x2 - two)*x2 f(2) = -twnine + x1 + (( x2 + one)*x2 - fourtn)*x2 fj( 1, 1) = one fj( 2, 1) = one fj( 1, 2) = (ten - three*x2)*x2 - two fj( 2, 2) = (three*x2 + two)*x2 - fourtn if (nb .ne. 0) ftf = ddot( m, f, 1, f, 1) if (nd .eq. 0) return do 400 j = 1, n g(j) = ddot( m, fj( 1, j), 1, f, 1) 400 continue return 9999 format(/'1',70('=')//, *' freudenstein and roth function (more et al.)'//, *' number of variables =', i4, ' (2)'/, *' number of functions =', i4, ' (2)'//, * ' ',70('=')/) end ************************************************************************ ************************************************************************ subroutine dfjdxk( k, x, n, dfj, ldfj, m, nonzro) implicit double precision (a-h,o-z) integer k, n, ldfj, m, nonzro(n) double precision x(n), dfj(ldfj,n) integer j double precision s2 double precision zero, two, six, ten parameter (zero = 0.d0, two = 2.d0) parameter (six = 6.d0, ten = 1.d1) *======================================================================= do 100 j = 1, n nonzro(j) = 0 call dcopy( m, zero, 0, dfj( 1, j), 1) 100 continue if (k .eq. 1) return s2 = six*x(2) nonzro(2) = 1 dfj( 1, 2) = ten - s2 dfj( 2, 2) = s2 + two return end ************************************************************************ ************************************************************************ subroutine dfkdij( k, x, n, lhess, hess, linear) implicit double precision (a-h,o-z) logical linear integer k, n, lhess double precision x(n), hess(lhess,n) integer j double precision zero, two, six, ten parameter (zero = 0.d0, two = 2.d0) parameter (six = 6.d0, ten = 10.d0) *======================================================================= do 100 j = 1, n call dcopy( n, zero, 0, hess( 1, j), 1) 100 continue linear = .false. x2 = x(2) goto ( 210, 220), k 210 continue hess( 2, 2) = ten - six*x2 return 220 continue hess( 2, 2) = six*x2 + two return end