google以下大部分都能够找到,比如
biggs exp6 function
- *****************************************************************************
- * biggs exp6 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, x4, x5, x6
- double precision e1, e2, e5, ti, ym, yp
- double precision ddot
- intrinsic dble, exp
- double precision zero, one, point1, three, four, five, ten
- parameter (zero = 0.d0, one = 1.d0, point1 = .1d0)
- parameter (three = 3.d0, four = 4.d0, five = 5.d0)
- parameter (ten = 10.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)
- x4 = x(4)
- x5 = x(5)
- x6 = x(6)
- 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 = 6
- m = 13
- if (nout .gt. 0) write( nout, 9999) n, m
- return
- *-----------------------------------------------------------------------
- 20 continue
- x(1) = 1.d0
- x(2) = 2.d0
- x(3) = 1.d0
- x(4) = 1.d0
- x(5) = 1.d0
- x(6) = 1.d0
- return
- *-----------------------------------------------------------------------
- 30 continue
- x(1) = 1.d0
- x(2) = 10.d0
- x(3) = 1.d0
- x(4) = 5.d0
- x(5) = 4.d0
- x(6) = 3.d0
- ftf = zero
- return
- *-----------------------------------------------------------------------
- 100 continue
- do 110 i = 1, m
- ti = point1*dble(i)
- yp = exp(-ti) + three*exp(-four*ti)
- ym = five*exp(-ten*ti)
- e1 = exp(-ti*x1)
- e2 = exp(-ti*x2)
- e5 = exp(-ti*x5)
- f(i) = (x3*e1 + x6*e5 + ym) - (x4*e2 + yp)
- 110 continue
- if (nb .ne. 0) ftf = ddot( m, f, 1, f, 1)
- return
- 200 continue
- do 210 i = 1, m
- ti = point1*dble(i)
- e1 = exp(-ti*x1)
- e2 = exp(-ti*x2)
- e5 = exp(-ti*x5)
- fj( i, 1) = -ti*x3*e1
- fj( i, 2) = ti*x4*e2
- fj( i, 3) = e1
- fj( i, 4) = -e2
- fj( i, 5) = -ti*x6*e5
- fj( i, 6) = e5
- 210 continue
- return
- 300 continue
- do 310 i = 1, m
- ti = point1*dble(i)
- yp = exp(-ti) + three*exp(-four*ti)
- ym = five*exp(-ten*ti)
- e1 = exp(-ti*x1)
- e2 = exp(-ti*x2)
- e5 = exp(-ti*x5)
- f(i) = (x3*e1 + x6*e5 + ym) - (x4*e2 + yp)
- fj( i, 1) = -ti*x3*e1
- fj( i, 2) = ti*x4*e2
- fj( i, 3) = e1
- fj( i, 4) = -e2
- fj( i, 5) = -ti*x6*e5
- fj( i, 6) = e5
- 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('=')//,
- *' biggs exp6 function (more et al.) '//,
- *' number of variables =', i4, ' ( 6 )'/,
- *' number of functions =', i4, ' ( >= 6 )'//,
- * ' ',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, x4, x5, x6
- double precision e1, e2, e5, ti, t1, t2, t5
- intrinsic dble, exp
- double precision zero, point1
- parameter (zero = 0.d0, point1 = .1d0)
- *=======================================================================
- do 100 j = 1, n
- nonzro(j) = 0
- call dcopy( m, zero, 0, dfj( 1, j), 1)
- 100 continue
- goto ( 210, 220, 230, 240, 250, 260 ), k
- 230 continue
- x1 = x(1)
- nonzro(1) = 1
- do 235 i = 1, m
- ti = point1*dble(i)
- dfj( i, 1) = -ti*exp(-ti*x1)
- 235 continue
- return
- 240 continue
- x2 = x(2)
- nonzro(2) = 1
- do 245 i = 1, m
- ti = point1*dble(i)
- dfj( i, 2) = ti*exp(-ti*x2)
- 245 continue
- return
- 260 continue
- x5 = x(5)
- nonzro(5) = 1
- do 265 i = 1, m
- ti = point1*dble(i)
- dfj( i, 5) = -ti*exp(-ti*x5)
- 265 continue
- return
- 210 continue
- x1 = x(1)
- x3 = x(3)
- nonzro(1) = 1
- nonzro(3) = 1
- do 215 i = 1, m
- ti = point1*dble(i)
- e1 = exp(-ti*x1)
- t1 = ti*e1
- dfj( i, 1) = ti*t1*x3
- dfj( i, 3) = -t1
- 215 continue
- return
- 220 continue
- x2 = x(2)
- x4 = x(4)
- nonzro(2) = 1
- nonzro(4) = 1
- do 225 i = 1, m
- ti = point1*dble(i)
- e2 = exp(-ti*x2)
- t2 = ti*e2
- dfj( i, 2) = -ti*t2*x4
- dfj( i, 4) = t2
- 225 continue
- return
- 250 continue
- x5 = x(5)
- x6 = x(6)
- nonzro(5) = 1
- nonzro(6) = 1
- do 255 i = 1, m
- ti = point1*dble(i)
- e5 = exp(-ti*x5)
- t5 = ti*e5
- dfj( i, 5) = ti*t5*x6
- dfj( i, 6) = -t5
- 255 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)
- integer j
- double precision e1, e2, e5, tk, t1, t2, t5
-
- intrinsic dble, exp
- double precision zero, point1
- parameter (zero = 0.d0, point1 = .1d0)
- *=======================================================================
- do 100 j = 1, n
- call dcopy( n, zero, 0, hess( 1, j), 1)
- 100 continue
- linear = .false.
- tk = point1*dble(k)
- e1 = exp(-tk*x(1))
- e2 = exp(-tk*x(2))
- e5 = exp(-tk*x(5))
- t1 = tk * e1
- t2 = tk * e2
- t5 = tk * e5
- hess(1,3) = -t1
- hess(3,1) = hess(3,1)
- hess(2,4) = t2
- hess(4,2) = hess(2,4)
- hess(5,6) = -t5
- hess(6,5) = hess(5,6)
- hess(1,1) = tk * x(3) * t1
- hess(2,2) = -tk * x(4) * t2
- hess(5,5) = tk * x(6) * t5
- return
- end
复制代码
来自于:http://www.netlib.org/uncon/data/biggs.f |