**************************************************************************
*               trigonometric 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   dn, sum, cxi, sxj, xi, xj

      double precision   ddot

      intrinsic          dble, cos, sin

      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

      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      = 10
      m      = n

      dn  = dble(n)

      if (nout .gt. 0)  write( nout, 9999)  n, m

      return

*-----------------------------------------------------------------------

   20 continue

      call dcopy( n, (one/dn), 0, x, 1)

      return

*-----------------------------------------------------------------------

   30 continue

      ftf = zero

      return

*-----------------------------------------------------------------------

 100  continue

      sum = zero
      do 110 i = 1, n
        xi   = x(i)
        cxi  = cos(xi)
        sum  = sum + cxi
        f(i) = dn + dble(i)*(one - cxi) - sin(xi)
 110  continue

      do 120 i = 1, n
        f(i) = f(i) - sum
 120  continue

      if (nb .ne. 0)  ftf = ddot( m, f, 1, f, 1)

      return

 200  continue

      do 220 j = 1, n
        xj  = x(j)
        sxj = sin(xj)
        do 210 i = 1, n
          fj( i, j) = sxj
 210  continue
      fj(j, j) =  dble(j+1)*sxj - cos(xj)
 220  continue

      return

 300  continue

      sum = zero
      do 310 i = 1, n
        xi   = x(i)
        cxi  = cos(xi)
        sum  = sum + cxi
        f(i) = dn + dble(i)*(one - cxi) - sin(xi)
 310  continue

      do 320 i = 1, n
        f(i) = f(i) - sum
 320  continue

      do 340 j = 1, n
        xj  = x(j)
        sxj = sin(xj)
        do 330 i = 1, n
          fj( i, j) = sxj
 330  continue
      fj( j, j) = dble(j+1)*sxj - cos(xj)
 340  continue

      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('=')//,
     *' trigonometric function (more et al.) '//,
     *'        number of variables =', i4, '  (variable)'/,
     *'        number of functions =', i4, '  (   = n  )'//,
     *        ' ',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   cxk, xk

      intrinsic          dble, cos, sin

      double precision   zero
      parameter         (zero = 0.d0)

*=======================================================================

      do 100 j = 1, n
        nonzro(j) = 0
        call dcopy( m, zero, dfj( 1, j), 1)
  100 continue

      nonzro(k) = 1

      xk  = x(k)
      cxk = cos(xk)
      do 200 i = 1, n
        dfj( i, k) = cxk
  200 continue
      dfj(k,k) = dble(k+1)*cxk + sin(xk)

      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            i, j

      double precision   cxi, xi

      intrinsic          dble, cos, sin

      double precision   zero
      parameter         (zero = 0.d0)

*=======================================================================

      do 100 j = 1, n
        call dcopy( n, zero, 0, hess( 1, j), 1)
  100 continue

      linear = .false.

      do 220 i = 1, n
        xi  = x(i)
        cxi = cos(xi)
        if (i .ne. k) hess( i, i) = cxi
        if (i .eq. k) hess( i, i) = dble(i+1)*cxi + sin(xi)
 220  continue

      return
      end