← Back to branch summary

~ubuntu-branches/ubuntu/lucid/pdl/lucid

« back to all changes in this revision

Viewing changes to Lib/Slatec/slatec/chfdv.f

  • Committer: Bazaar Package Importer
  • Author(s): Ben Gertzfield
  • Date: 2002-04-08 18:47:16 UTC
  • Revision ID: james.westby@ubuntu.com-20020408184716-0hf64dc96kin3htp
Tags: upstream-2.3.2
Import upstream version 2.3.2

Show diffs side-by-side

added added

removed removed

Lines of Context:
Lib/Slatec/slatec/chfdv.f
 
1
*DECK CHFDV
 
2
      SUBROUTINE CHFDV (X1, X2, F1, F2, D1, D2, NE, XE, FE, DE, NEXT,
 
3
     +   IERR)
 
4
C***BEGIN PROLOGUE  CHFDV
 
5
C***PURPOSE  Evaluate a cubic polynomial given in Hermite form and its
 
6
C            first derivative at an array of points.  While designed for
 
7
C            use by PCHFD, it may be useful directly as an evaluator
 
8
C            for a piecewise cubic Hermite function in applications,
 
9
C            such as graphing, where the interval is known in advance.
 
10
C            If only function values are required, use CHFEV instead.
 
11
C***LIBRARY   SLATEC (PCHIP)
 
12
C***CATEGORY  E3, H1
 
13
C***TYPE      SINGLE PRECISION (CHFDV-S, DCHFDV-D)
 
14
C***KEYWORDS  CUBIC HERMITE DIFFERENTIATION, CUBIC HERMITE EVALUATION,
 
15
C             CUBIC POLYNOMIAL EVALUATION, PCHIP
 
16
C***AUTHOR  Fritsch, F. N., (LLNL)
 
17
C             Lawrence Livermore National Laboratory
 
18
C             P.O. Box 808  (L-316)
 
19
C             Livermore, CA  94550
 
20
C             FTS 532-4275, (510) 422-4275
 
21
C***DESCRIPTION
 
22
C
 
23
C        CHFDV:  Cubic Hermite Function and Derivative Evaluator
 
24
C
 
25
C     Evaluates the cubic polynomial determined by function values
 
26
C     F1,F2 and derivatives D1,D2 on interval (X1,X2), together with
 
27
C     its first derivative, at the points  XE(J), J=1(1)NE.
 
28
C
 
29
C     If only function values are required, use CHFEV, instead.
 
30
C
 
31
C ----------------------------------------------------------------------
 
32
C
 
33
C  Calling sequence:
 
34
C
 
35
C        INTEGER  NE, NEXT(2), IERR
 
36
C        REAL  X1, X2, F1, F2, D1, D2, XE(NE), FE(NE), DE(NE)
 
37
C
 
38
C        CALL  CHFDV (X1,X2, F1,F2, D1,D2, NE, XE, FE, DE, NEXT, IERR)
 
39
C
 
40
C   Parameters:
 
41
C
 
42
C     X1,X2 -- (input) endpoints of interval of definition of cubic.
 
43
C           (Error return if  X1.EQ.X2 .)
 
44
C
 
45
C     F1,F2 -- (input) values of function at X1 and X2, respectively.
 
46
C
 
47
C     D1,D2 -- (input) values of derivative at X1 and X2, respectively.
 
48
C
 
49
C     NE -- (input) number of evaluation points.  (Error return if
 
50
C           NE.LT.1 .)
 
51
C
 
52
C     XE -- (input) real array of points at which the functions are to
 
53
C           be evaluated.  If any of the XE are outside the interval
 
54
C           [X1,X2], a warning error is returned in NEXT.
 
55
C
 
56
C     FE -- (output) real array of values of the cubic function defined
 
57
C           by  X1,X2, F1,F2, D1,D2  at the points  XE.
 
58
C
 
59
C     DE -- (output) real array of values of the first derivative of
 
60
C           the same function at the points  XE.
 
61
C
 
62
C     NEXT -- (output) integer array indicating number of extrapolation
 
63
C           points:
 
64
C            NEXT(1) = number of evaluation points to left of interval.
 
65
C            NEXT(2) = number of evaluation points to right of interval.
 
66
C
 
67
C     IERR -- (output) error flag.
 
68
C           Normal return:
 
69
C              IERR = 0  (no errors).
 
70
C           "Recoverable" errors:
 
71
C              IERR = -1  if NE.LT.1 .
 
72
C              IERR = -2  if X1.EQ.X2 .
 
73
C                (Output arrays have not been changed in either case.)
 
74
C
 
75
C***REFERENCES  (NONE)
 
76
C***ROUTINES CALLED  XERMSG
 
77
C***REVISION HISTORY  (YYMMDD)
 
78
C   811019  DATE WRITTEN
 
79
C   820803  Minor cosmetic changes for release 1.
 
80
C   890411  Added SAVE statements (Vers. 3.2).
 
81
C   890531  Changed all specific intrinsics to generic.  (WRB)
 
82
C   890831  Modified array declarations.  (WRB)
 
83
C   890831  REVISION DATE from Version 3.2
 
84
C   891214  Prologue converted to Version 4.0 format.  (BAB)
 
85
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
 
86
C***END PROLOGUE  CHFDV
 
87
C  Programming notes:
 
88
C
 
89
C     To produce a double precision version, simply:
 
90
C        a. Change CHFDV to DCHFDV wherever it occurs,
 
91
C        b. Change the real declaration to double precision, and
 
92
C        c. Change the constant ZERO to double precision.
 
93
C
 
94
C  DECLARE ARGUMENTS.
 
95
C
 
96
      INTEGER  NE, NEXT(2), IERR
 
97
      REAL  X1, X2, F1, F2, D1, D2, XE(*), FE(*), DE(*)
 
98
C
 
99
C  DECLARE LOCAL VARIABLES.
 
100
C
 
101
      INTEGER  I
 
102
      REAL  C2, C2T2, C3, C3T3, DEL1, DEL2, DELTA, H, X, XMI, XMA, ZERO
 
103
      SAVE ZERO
 
104
      DATA  ZERO /0./
 
105
C
 
106
C  VALIDITY-CHECK ARGUMENTS.
 
107
C
 
108
C***FIRST EXECUTABLE STATEMENT  CHFDV
 
109
      IF (NE .LT. 1)  GO TO 5001
 
110
      H = X2 - X1
 
111
      IF (H .EQ. ZERO)  GO TO 5002
 
112
C
 
113
C  INITIALIZE.
 
114
C
 
115
      IERR = 0
 
116
      NEXT(1) = 0
 
117
      NEXT(2) = 0
 
118
      XMI = MIN(ZERO, H)
 
119
      XMA = MAX(ZERO, H)
 
120
C
 
121
C  COMPUTE CUBIC COEFFICIENTS (EXPANDED ABOUT X1).
 
122
C
 
123
      DELTA = (F2 - F1)/H
 
124
      DEL1 = (D1 - DELTA)/H
 
125
      DEL2 = (D2 - DELTA)/H
 
126
C                                           (DELTA IS NO LONGER NEEDED.)
 
127
      C2 = -(DEL1+DEL1 + DEL2)
 
128
      C2T2 = C2 + C2
 
129
      C3 = (DEL1 + DEL2)/H
 
130
C                               (H, DEL1 AND DEL2 ARE NO LONGER NEEDED.)
 
131
      C3T3 = C3+C3+C3
 
132
C
 
133
C  EVALUATION LOOP.
 
134
C
 
135
      DO 500  I = 1, NE
 
136
         X = XE(I) - X1
 
137
         FE(I) = F1 + X*(D1 + X*(C2 + X*C3))
 
138
         DE(I) = D1 + X*(C2T2 + X*C3T3)
 
139
C          COUNT EXTRAPOLATION POINTS.
 
140
         IF ( X.LT.XMI )  NEXT(1) = NEXT(1) + 1
 
141
         IF ( X.GT.XMA )  NEXT(2) = NEXT(2) + 1
 
142
C        (NOTE REDUNDANCY--IF EITHER CONDITION IS TRUE, OTHER IS FALSE.)
 
143
  500 CONTINUE
 
144
C
 
145
C  NORMAL RETURN.
 
146
C
 
147
      RETURN
 
148
C
 
149
C  ERROR RETURNS.
 
150
C
 
151
 5001 CONTINUE
 
152
C     NE.LT.1 RETURN.
 
153
      IERR = -1
 
154
      CALL XERMSG ('SLATEC', 'CHFDV',
 
155
     +   'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1)
 
156
      RETURN
 
157
C
 
158
 5002 CONTINUE
 
159
C     X1.EQ.X2 RETURN.
 
160
      IERR = -2
 
161
      CALL XERMSG ('SLATEC', 'CHFDV', 'INTERVAL ENDPOINTS EQUAL', IERR,
 
162
     +   1)
 
163
      RETURN
 
164
C------------- LAST LINE OF CHFDV FOLLOWS ------------------------------
 
165
      END