************************************************************************* * bard 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 integer i, j double precision x1, x2, x3 double precision di, qi, ui, vi, wi double precision ddot intrinsic dble, min double precision y common /PARAM1/ y(15) save /PARAM1/ double precision zero, one parameter (zero = 0.d0, one = 1.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) x3 = x(3) na = mode / 1000 nt = mode - na*1000 nb = nt / 100 nh = nt - nb*100 nc = nh / 10 nd = nh - 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 = 3 m = 15 y( 1) = 0.14d0 y( 2) = 0.18d0 y( 3) = 0.22d0 y( 4) = 0.25d0 y( 5) = 0.29d0 y( 6) = 0.32d0 y( 7) = 0.35d0 y( 8) = 0.39d0 y( 9) = 0.37d0 y(10) = 0.58d0 y(11) = 0.73d0 y(12) = 0.96d0 y(13) = 1.34d0 y(14) = 2.10d0 y(15) = 4.39d0 if (nout .gt. 0) write( nout, 9999) n, m return *----------------------------------------------------------------------- 20 continue x(1) = one x(2) = one x(3) = one return *----------------------------------------------------------------------- 30 continue ftf = 8.21487d-3 return *----------------------------------------------------------------------- 100 continue do 110 i = 1, m ui = dble(i) vi = dble(16-i) wi = min( ui, vi) di = vi*x2 + wi*x3 if (di .eq. zero) then write(6,*) '+++ getfun : attempt to divide by zero' stop end if f(i) = x1 + (ui/di) - y(i) 110 continue if (nb .ne. 0) ftf = ddot( m, f, 1, f, 1) return 200 continue do 210 i = 1, m ui = dble(i) vi = dble(16-i) wi = min( ui, vi ) di = vi*x2 + wi*x3 if (di .eq. zero) then write(6,*) '+++ getfun : attempt to divide by zero' stop end if qi = -ui / (di*di) fj(i,1) = one fj(i,2) = qi * vi fj(i,3) = qi * wi 210 continue return 300 continue do 310 i = 1, m ui = dble(i) vi = dble(16-i) wi = min( ui, vi ) di = vi*x2 + wi*x3 if (di .eq. zero) then write(6,*) '+++ getfun : attempt to divide by zero' stop end if qi = -ui / (di*di) f(i) = x1 + (ui/di) - y(i) fj(i,1) = one fj(i,2) = qi * vi fj(i,3) = qi * wi 310 continue if (nb .ne. 0) ftf = ddot( m, f, 1, f, 1) if (nd .eq. 0) return do 320 j = 1, n g(j) = ddot( m, fj( 1, j), 1, f, 1) 320 continue return 9999 format(/'1',70('=')//, *' bard function (more et al.)'//, *' number of variables =', i4, ' ( 3) '/, *' number of functions =', i4, ' (15) '//, * ' ',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 i, j double precision x1, x2, x3 double precision di, qi, ti, ui, vi, wi, tv intrinsic dble, min double precision zero, one, two parameter (zero = 0.d0, one = 1.d0, two = 2.d0) *======================================================================= goto ( 100, 200, 300), k 100 continue do 110 j = 1, n nonzro(j) = 0 call dcopy( m, zero, 0, dfj( 1, j), 1) 110 continue return 200 continue x1 = x(1) x2 = x(2) x3 = x(3) nonzro(1) = 0 nonzro(2) = 1 nonzro(3) = 1 do 210 i = 1, m ui = dble(i) vi = dble(16-i) wi = min( ui, vi) di = vi*x2 + wi*x3 if (di .eq. zero) then write(6,*) '+++ getfun : attempt to divide by zero' stop end if qi = one / (di*di) ti = two * di * qi * qi * ui tv = ti * vi dfj(i,1) = zero dfj(i,2) = tv * vi dfj(i,3) = tv * wi 210 continue return 300 continue x1 = x(1) x2 = x(2) x3 = x(3) nonzro(1) = 0 nonzro(2) = 1 nonzro(3) = 1 do 310 i = 1, m ui = dble(i) vi = dble(16-i) wi = min( ui, vi) di = vi*x2 + wi*x3 if (di .eq. zero) then write(6,*) '+++ getfun : attempt to divide by zero' stop end if qi = one / (di*di) ti = two * di * qi * qi * ui tw = ti * wi dfj(i,1) = zero dfj(i,2) = tw * vi dfj(i,3) = tw * wi 310 continue return end ************************************************************************ ************************************************************************ subroutine dfkdij ( k, x, n, hess, lhess, linear) implicit double precision (a-h,o-z) logical linear integer k, n, lhess double precision x(n), hess(lhess,n) double precision x1, x2, x3 double precision dk, qk, tk, uk, vk, wk, tw intrinsic dble, min double precision zero, one, two parameter (zero = 0.d0, one = 1.d0, two = 2.d0) *======================================================================= x1 = x(1) x2 = x(2) x3 = x(3) linear = .false. uk = dble(k) vk = dble(16-k) wk = min( uk, vk) dk = vk*x2 + wk*x3 qk = one / (dk*dk*dk) tk = two * qk * uk tw = tk * wk hess( 1, 1) = zero hess( 1, 2) = zero hess( 2, 1) = zero hess( 2, 2) = tk * vk * vk hess( 1, 3) = zero hess( 3, 1) = zero hess( 2, 3) = tw * vk hess( 3, 2) = hess( 2, 3) hess( 3, 3) = tw * wk return end