***************************************************************************** * penalty function ii * 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 j, jm1 double precision a, vj, x1, xj double precision sj, sjm1, tj, tjm1, uj, ujm1 double precision ddot intrinsic sqrt, dble, exp double precision ap, aq, ar, d0, scale common /PARAM1/ ap, aq, ar, d0, scale save /PARAM1/ double precision zero, one, two, point2 parameter (zero = 0.d0, one = 1.d0, two = 2.d0) parameter (point2 = .2d0) *======================================================================= if (mode .eq. 0) goto 20 if (mode .eq. -1) goto 10 if (mode .eq. -2) goto 30 x1 = x(1) 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 = 4 m = 2*n scale = 0.1d0 a = 1.d-5 ar = sqrt(a) ap = ar*scale aq = ap*scale d0 = ar*exp(-scale) if (nout .gt. 0) write( nout, 9999) n, m return *----------------------------------------------------------------------- 20 continue do 21 j = 1, n x(j) = 0.5d0 21 continue return *----------------------------------------------------------------------- 30 continue ftf = 9.37626d-6 return *----------------------------------------------------------------------- 100 continue sum = dble(n)*(x1*x1) f(1) = x1 - point2 sj = ar*exp(scale) tj = ar*exp(x1*scale) jm1 = 1 do 110 j = 2, n sjm1 = sj sj = ar*exp(dble(j)*scale) xj = x(j) tjm1 = tj tj = ar*exp(xj*scale) f(j) = (tj + tjm1) - (sj + sjm1) f(n+jm1) = tj - d0 sum = sum + dble(n-jm1)*(xj*xj) jm1 = j 110 continue f(m) = sum - one if (nb .ne. 0) ftf = ddot( m, f, 1, f, 1) return 200 continue do 210 j = 1, n call dcopy( m, zero, 0, fj( 1, j), 1) 210 continue fj(1,1) = one fj(m,1) = two*dble(n)*x1 uj = ap*exp(x1*scale) jm1 = 1 do 220 j = 2, n xj = x(j) ujm1 = uj uj = ap*exp(xj*scale) fj(j , jm1) = ujm1 fj(j , j ) = uj fj(n+jm1, j ) = uj fj(m , j ) = two*dble(n-jm1)*xj jm1 = j 220 continue return 300 continue do 310 j = 1, n call dcopy( m, zero, 0, fj( 1, j), 1) 310 continue sum = dble(n)*x1*x1 f(1) = x1 - point2 fj(1,1) = one fj(m,1) = two*dble(n)*x1 sj = ar*exp(scale) tj = ar*exp(x1*scale) uj = scale*tj jm1 = 1 do 320 j = 2, n sjm1 = sj sj = ar*exp(dble(j)*scale) xj = x(j) tjm1 = tj ujm1 = uj tj = ar*exp(xj*scale) uj = scale*tj f(j) = (tj + tjm1) - (sj + sjm1) f(n+jm1) = tj - d0 vj = dble(n-jm1)*xj sum = sum + vj*xj fj( j, jm1) = ujm1 fj( j, j) = uj fj(n+jm1, j) = uj fj( m, j) = two*vj jm1 = j 320 continue f(m) = sum - one 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('=')//, *' penalty function ii (more et al.) '//, *' number of variables =', i4, ' (variable)'/, *' number of functions =', i4, ' ( = 2n )'//, * ' ',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) intrinsic dble, exp double precision ap, aq, ar, d0, scale common /PARAM1/ ap, aq, ar, d0, scale save /PARAM1/ double precision zero, two parameter (zero = 0.d0, two = 2.d0) *======================================================================= do 100 j = 1, n nonzro(j) = 1 call dcopy( m, zero, 0, dfj( 1, j), 1) 100 continue t = aq*exp(x(k)*scale) if (k+1 .ge. 2 .and. k+1 .le. n) dfj(k+1 ,k) = t if (k .ge. 2 .and. k .le. n) dfj(k ,k) = t if (k .ge. 2 .and. k .le. n) dfj(k+n-1,k) = t dfj(m,k) = two*dble(n-k+1) 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) intrinsic dble, exp double precision ap, aq, ar, d0, scale common /PARAM1/ ap, aq, ar, d0, scale save /PARAM1/ double precision zero, two parameter (zero = 0.d0, two = 2.d0) *======================================================================= do 100 j = 1, n call dcopy( n, zero, 0, hess( 1, j), 1) 100 continue if (k .eq. 1) linear = .true. if (k .eq. 1) return linear = .false. if ( k .ge. 2 .and. k .le. n) * hess(k ,k ) = aq*exp(x(k)*scale) if ( k .ge. 2 .and. k .le. n) * hess(k-1 ,k-1 ) = aq*exp(x(k-1)*scale) if ( k .gt. n .and. k .lt. 2*n) * hess(k-n+1,k-n+1) = aq*exp(x(k-n+1)*scale) if (k .ne. 2*n) return do 200 i = 1, n hess(i,i) = two*dble(n-i+1) 200 continue return end