website/archive/binaries/mac/src/disembl/Tisean_3.0.1/source_f/slatec/fdjac3.f

   1 *DECK FDJAC3
   2       SUBROUTINE FDJAC3 (FCN, M, N, X, FVEC, FJAC, LDFJAC, IFLAG,
   3      +   EPSFCN, WA)
   4 C***BEGIN PROLOGUE  FDJAC3
   5 C***SUBSIDIARY
   6 C***PURPOSE  Subsidiary to SNLS1 and SNLS1E
   7 C***LIBRARY   SLATEC
   8 C***TYPE      SINGLE PRECISION (FDJAC3-S, DFDJC3-D)
   9 C***AUTHOR  (UNKNOWN)
  10 C***DESCRIPTION
  11 C
  12 C     This subroutine computes a forward-difference approximation
  13 C     to the M by N Jacobian matrix associated with a specified
  14 C     problem of M functions in N variables.
  15 C
  16 C     The subroutine statement is
  17 C
  18 C       SUBROUTINE FDJAC3(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA)
  19 C
  20 C     where
  21 C
  22 C       FCN is the name of the user-supplied subroutine which
  23 C         calculates the functions. FCN must be declared
  24 C         in an external statement in the user calling
  25 C         program, and should be written as follows.
  26 C
  27 C         SUBROUTINE FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC)
  28 C         INTEGER LDFJAC,M,N,IFLAG
  29 C         REAL X(N),FVEC(M),FJAC(LDFJAC,N)
  30 C         ----------
  31 C         When IFLAG.EQ.1 calculate the functions at X and
  32 C         return this vector in FVEC.
  33 C         ----------
  34 C         RETURN
  35 C         END
  36 C
  37 C         The value of IFLAG should not be changed by FCN unless
  38 C         the user wants to terminate execution of FDJAC3.
  39 C         In this case set IFLAG to a negative integer.
  40 C
  41 C       M is a positive integer input variable set to the number
  42 C         of functions.
  43 C
  44 C       N is a positive integer input variable set to the number
  45 C         of variables. N must not exceed M.
  46 C
  47 C       X is an input array of length N.
  48 C
  49 C       FVEC is an input array of length M which must contain the
  50 C         functions evaluated at X.
  51 C
  52 C       FJAC is an output M by N array which contains the
  53 C         approximation to the Jacobian matrix evaluated at X.
  54 C
  55 C       LDFJAC is a positive integer input variable not less than M
  56 C         which specifies the leading dimension of the array FJAC.
  57 C
  58 C       IFLAG is an integer variable which can be used to terminate
  59 C         THE EXECUTION OF FDJAC3. See description of FCN.
  60 C
  61 C       EPSFCN is an input variable used in determining a suitable
  62 C         step length for the forward-difference approximation. This
  63 C         approximation assumes that the relative errors in the
  64 C         functions are of the order of EPSFCN. If EPSFCN is less
  65 C         than the machine precision, it is assumed that the relative
  66 C         errors in the functions are of the order of the machine
  67 C         precision.
  68 C
  69 C       WA is a work array of length M.
  70 C
  71 C***SEE ALSO  SNLS1, SNLS1E
  72 C***ROUTINES CALLED  R1MACH
  73 C***REVISION HISTORY  (YYMMDD)
  74 C   800301  DATE WRITTEN
  75 C   890531  Changed all specific intrinsics to generic.  (WRB)
  76 C   890831  Modified array declarations.  (WRB)
  77 C   891214  Prologue converted to Version 4.0 format.  (BAB)
  78 C   900326  Removed duplicate information from DESCRIPTION section.
  79 C           (WRB)
  80 C   900328  Added TYPE section.  (WRB)
  81 C***END PROLOGUE  FDJAC3
  82       INTEGER M,N,LDFJAC,IFLAG
  83       REAL EPSFCN
  84       REAL X(*),FVEC(*),FJAC(LDFJAC,*),WA(*)
  85       INTEGER I,J
  86       REAL EPS,EPSMCH,H,TEMP,ZERO
  87       REAL R1MACH
  88       SAVE ZERO
  89       DATA ZERO /0.0E0/
  90 C***FIRST EXECUTABLE STATEMENT  FDJAC3
  91       EPSMCH = R1MACH(4)
  92 C
  93       EPS = SQRT(MAX(EPSFCN,EPSMCH))
  94 C      SET IFLAG=1 TO INDICATE THAT FUNCTION VALUES
  95 C           ARE TO BE RETURNED BY FCN.
  96       IFLAG = 1
  97       DO 20 J = 1, N
  98          TEMP = X(J)
  99          H = EPS*ABS(TEMP)
 100          IF (H .EQ. ZERO) H = EPS
 101          X(J) = TEMP + H
 102          CALL FCN(IFLAG,M,N,X,WA,FJAC,LDFJAC)
 103          IF (IFLAG .LT. 0) GO TO 30
 104          X(J) = TEMP
 105          DO 10 I = 1, M
 106             FJAC(I,J) = (WA(I) - FVEC(I))/H
 107    10       CONTINUE
 108    20    CONTINUE
 109    30 CONTINUE
 110       RETURN
 111 C
 112 C     LAST CARD OF SUBROUTINE FDJAC3.
 113 C
 114       END