| 1 | *DECK PCHFE |
|---|
| 2 | SUBROUTINE PCHFE (N, X, F, D, INCFD, SKIP, NE, XE, FE, IERR) |
|---|
| 3 | C***BEGIN PROLOGUE PCHFE |
|---|
| 4 | C***PURPOSE Evaluate a piecewise cubic Hermite function at an array of |
|---|
| 5 | C points. May be used by itself for Hermite interpolation, |
|---|
| 6 | C or as an evaluator for PCHIM or PCHIC. |
|---|
| 7 | C***LIBRARY SLATEC (PCHIP) |
|---|
| 8 | C***CATEGORY E3 |
|---|
| 9 | C***TYPE SINGLE PRECISION (PCHFE-S, DPCHFE-D) |
|---|
| 10 | C***KEYWORDS CUBIC HERMITE EVALUATION, HERMITE INTERPOLATION, PCHIP, |
|---|
| 11 | C PIECEWISE CUBIC EVALUATION |
|---|
| 12 | C***AUTHOR Fritsch, F. N., (LLNL) |
|---|
| 13 | C Lawrence Livermore National Laboratory |
|---|
| 14 | C P.O. Box 808 (L-316) |
|---|
| 15 | C Livermore, CA 94550 |
|---|
| 16 | C FTS 532-4275, (510) 422-4275 |
|---|
| 17 | C***DESCRIPTION |
|---|
| 18 | C |
|---|
| 19 | C PCHFE: Piecewise Cubic Hermite Function Evaluator |
|---|
| 20 | C |
|---|
| 21 | C Evaluates the cubic Hermite function defined by N, X, F, D at |
|---|
| 22 | C the points XE(J), J=1(1)NE. |
|---|
| 23 | C |
|---|
| 24 | C To provide compatibility with PCHIM and PCHIC, includes an |
|---|
| 25 | C increment between successive values of the F- and D-arrays. |
|---|
| 26 | C |
|---|
| 27 | C ---------------------------------------------------------------------- |
|---|
| 28 | C |
|---|
| 29 | C Calling sequence: |
|---|
| 30 | C |
|---|
| 31 | C PARAMETER (INCFD = ...) |
|---|
| 32 | C INTEGER N, NE, IERR |
|---|
| 33 | C REAL X(N), F(INCFD,N), D(INCFD,N), XE(NE), FE(NE) |
|---|
| 34 | C LOGICAL SKIP |
|---|
| 35 | C |
|---|
| 36 | C CALL PCHFE (N, X, F, D, INCFD, SKIP, NE, XE, FE, IERR) |
|---|
| 37 | C |
|---|
| 38 | C Parameters: |
|---|
| 39 | C |
|---|
| 40 | C N -- (input) number of data points. (Error return if N.LT.2 .) |
|---|
| 41 | C |
|---|
| 42 | C X -- (input) real array of independent variable values. The |
|---|
| 43 | C elements of X must be strictly increasing: |
|---|
| 44 | C X(I-1) .LT. X(I), I = 2(1)N. |
|---|
| 45 | C (Error return if not.) |
|---|
| 46 | C |
|---|
| 47 | C F -- (input) real array of function values. F(1+(I-1)*INCFD) is |
|---|
| 48 | C the value corresponding to X(I). |
|---|
| 49 | C |
|---|
| 50 | C D -- (input) real array of derivative values. D(1+(I-1)*INCFD) is |
|---|
| 51 | C the value corresponding to X(I). |
|---|
| 52 | C |
|---|
| 53 | C INCFD -- (input) increment between successive values in F and D. |
|---|
| 54 | C (Error return if INCFD.LT.1 .) |
|---|
| 55 | C |
|---|
| 56 | C SKIP -- (input/output) logical variable which should be set to |
|---|
| 57 | C .TRUE. if the user wishes to skip checks for validity of |
|---|
| 58 | C preceding parameters, or to .FALSE. otherwise. |
|---|
| 59 | C This will save time in case these checks have already |
|---|
| 60 | C been performed (say, in PCHIM or PCHIC). |
|---|
| 61 | C SKIP will be set to .TRUE. on normal return. |
|---|
| 62 | C |
|---|
| 63 | C NE -- (input) number of evaluation points. (Error return if |
|---|
| 64 | C NE.LT.1 .) |
|---|
| 65 | C |
|---|
| 66 | C XE -- (input) real array of points at which the function is to be |
|---|
| 67 | C evaluated. |
|---|
| 68 | C |
|---|
| 69 | C NOTES: |
|---|
| 70 | C 1. The evaluation will be most efficient if the elements |
|---|
| 71 | C of XE are increasing relative to X; |
|---|
| 72 | C that is, XE(J) .GE. X(I) |
|---|
| 73 | C implies XE(K) .GE. X(I), all K.GE.J . |
|---|
| 74 | C 2. If any of the XE are outside the interval [X(1),X(N)], |
|---|
| 75 | C values are extrapolated from the nearest extreme cubic, |
|---|
| 76 | C and a warning error is returned. |
|---|
| 77 | C |
|---|
| 78 | C FE -- (output) real array of values of the cubic Hermite function |
|---|
| 79 | C defined by N, X, F, D at the points XE. |
|---|
| 80 | C |
|---|
| 81 | C IERR -- (output) error flag. |
|---|
| 82 | C Normal return: |
|---|
| 83 | C IERR = 0 (no errors). |
|---|
| 84 | C Warning error: |
|---|
| 85 | C IERR.GT.0 means that extrapolation was performed at |
|---|
| 86 | C IERR points. |
|---|
| 87 | C "Recoverable" errors: |
|---|
| 88 | C IERR = -1 if N.LT.2 . |
|---|
| 89 | C IERR = -2 if INCFD.LT.1 . |
|---|
| 90 | C IERR = -3 if the X-array is not strictly increasing. |
|---|
| 91 | C IERR = -4 if NE.LT.1 . |
|---|
| 92 | C (The FE-array has not been changed in any of these cases.) |
|---|
| 93 | C NOTE: The above errors are checked in the order listed, |
|---|
| 94 | C and following arguments have **NOT** been validated. |
|---|
| 95 | C |
|---|
| 96 | C***REFERENCES (NONE) |
|---|
| 97 | C***ROUTINES CALLED CHFEV, XERMSG |
|---|
| 98 | C***REVISION HISTORY (YYMMDD) |
|---|
| 99 | C 811020 DATE WRITTEN |
|---|
| 100 | C 820803 Minor cosmetic changes for release 1. |
|---|
| 101 | C 870707 Minor cosmetic changes to prologue. |
|---|
| 102 | C 890531 Changed all specific intrinsics to generic. (WRB) |
|---|
| 103 | C 890831 Modified array declarations. (WRB) |
|---|
| 104 | C 890831 REVISION DATE from Version 3.2 |
|---|
| 105 | C 891214 Prologue converted to Version 4.0 format. (BAB) |
|---|
| 106 | C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) |
|---|
| 107 | C***END PROLOGUE PCHFE |
|---|
| 108 | C Programming notes: |
|---|
| 109 | C |
|---|
| 110 | C 1. To produce a double precision version, simply: |
|---|
| 111 | C a. Change PCHFE to DPCHFE, and CHFEV to DCHFEV, wherever they |
|---|
| 112 | C occur, |
|---|
| 113 | C b. Change the real declaration to double precision, |
|---|
| 114 | C |
|---|
| 115 | C 2. Most of the coding between the call to CHFEV and the end of |
|---|
| 116 | C the IR-loop could be eliminated if it were permissible to |
|---|
| 117 | C assume that XE is ordered relative to X. |
|---|
| 118 | C |
|---|
| 119 | C 3. CHFEV does not assume that X1 is less than X2. thus, it would |
|---|
| 120 | C be possible to write a version of PCHFE that assumes a strict- |
|---|
| 121 | C ly decreasing X-array by simply running the IR-loop backwards |
|---|
| 122 | C (and reversing the order of appropriate tests). |
|---|
| 123 | C |
|---|
| 124 | C 4. The present code has a minor bug, which I have decided is not |
|---|
| 125 | C worth the effort that would be required to fix it. |
|---|
| 126 | C If XE contains points in [X(N-1),X(N)], followed by points .LT. |
|---|
| 127 | C X(N-1), followed by points .GT.X(N), the extrapolation points |
|---|
| 128 | C will be counted (at least) twice in the total returned in IERR. |
|---|
| 129 | C |
|---|
| 130 | C DECLARE ARGUMENTS. |
|---|
| 131 | C |
|---|
| 132 | INTEGER N, INCFD, NE, IERR |
|---|
| 133 | REAL X(*), F(INCFD,*), D(INCFD,*), XE(*), FE(*) |
|---|
| 134 | LOGICAL SKIP |
|---|
| 135 | C |
|---|
| 136 | C DECLARE LOCAL VARIABLES. |
|---|
| 137 | C |
|---|
| 138 | INTEGER I, IERC, IR, J, JFIRST, NEXT(2), NJ |
|---|
| 139 | C |
|---|
| 140 | C VALIDITY-CHECK ARGUMENTS. |
|---|
| 141 | C |
|---|
| 142 | C***FIRST EXECUTABLE STATEMENT PCHFE |
|---|
| 143 | IF (SKIP) GO TO 5 |
|---|
| 144 | C |
|---|
| 145 | IF ( N.LT.2 ) GO TO 5001 |
|---|
| 146 | IF ( INCFD.LT.1 ) GO TO 5002 |
|---|
| 147 | DO 1 I = 2, N |
|---|
| 148 | IF ( X(I).LE.X(I-1) ) GO TO 5003 |
|---|
| 149 | 1 CONTINUE |
|---|
| 150 | C |
|---|
| 151 | C FUNCTION DEFINITION IS OK, GO ON. |
|---|
| 152 | C |
|---|
| 153 | 5 CONTINUE |
|---|
| 154 | IF ( NE.LT.1 ) GO TO 5004 |
|---|
| 155 | IERR = 0 |
|---|
| 156 | SKIP = .TRUE. |
|---|
| 157 | C |
|---|
| 158 | C LOOP OVER INTERVALS. ( INTERVAL INDEX IS IL = IR-1 . ) |
|---|
| 159 | C ( INTERVAL IS X(IL).LE.X.LT.X(IR) . ) |
|---|
| 160 | JFIRST = 1 |
|---|
| 161 | IR = 2 |
|---|
| 162 | 10 CONTINUE |
|---|
| 163 | C |
|---|
| 164 | C SKIP OUT OF LOOP IF HAVE PROCESSED ALL EVALUATION POINTS. |
|---|
| 165 | C |
|---|
| 166 | IF (JFIRST .GT. NE) GO TO 5000 |
|---|
| 167 | C |
|---|
| 168 | C LOCATE ALL POINTS IN INTERVAL. |
|---|
| 169 | C |
|---|
| 170 | DO 20 J = JFIRST, NE |
|---|
| 171 | IF (XE(J) .GE. X(IR)) GO TO 30 |
|---|
| 172 | 20 CONTINUE |
|---|
| 173 | J = NE + 1 |
|---|
| 174 | GO TO 40 |
|---|
| 175 | C |
|---|
| 176 | C HAVE LOCATED FIRST POINT BEYOND INTERVAL. |
|---|
| 177 | C |
|---|
| 178 | 30 CONTINUE |
|---|
| 179 | IF (IR .EQ. N) J = NE + 1 |
|---|
| 180 | C |
|---|
| 181 | 40 CONTINUE |
|---|
| 182 | NJ = J - JFIRST |
|---|
| 183 | C |
|---|
| 184 | C SKIP EVALUATION IF NO POINTS IN INTERVAL. |
|---|
| 185 | C |
|---|
| 186 | IF (NJ .EQ. 0) GO TO 50 |
|---|
| 187 | C |
|---|
| 188 | C EVALUATE CUBIC AT XE(I), I = JFIRST (1) J-1 . |
|---|
| 189 | C |
|---|
| 190 | C ---------------------------------------------------------------- |
|---|
| 191 | CALL CHFEV (X(IR-1),X(IR), F(1,IR-1),F(1,IR), D(1,IR-1),D(1,IR), |
|---|
| 192 | * NJ, XE(JFIRST), FE(JFIRST), NEXT, IERC) |
|---|
| 193 | C ---------------------------------------------------------------- |
|---|
| 194 | IF (IERC .LT. 0) GO TO 5005 |
|---|
| 195 | C |
|---|
| 196 | IF (NEXT(2) .EQ. 0) GO TO 42 |
|---|
| 197 | C IF (NEXT(2) .GT. 0) THEN |
|---|
| 198 | C IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(2) TO THE |
|---|
| 199 | C RIGHT OF X(IR). |
|---|
| 200 | C |
|---|
| 201 | IF (IR .LT. N) GO TO 41 |
|---|
| 202 | C IF (IR .EQ. N) THEN |
|---|
| 203 | C THESE ARE ACTUALLY EXTRAPOLATION POINTS. |
|---|
| 204 | IERR = IERR + NEXT(2) |
|---|
| 205 | GO TO 42 |
|---|
| 206 | 41 CONTINUE |
|---|
| 207 | C ELSE |
|---|
| 208 | C WE SHOULD NEVER HAVE GOTTEN HERE. |
|---|
| 209 | GO TO 5005 |
|---|
| 210 | C ENDIF |
|---|
| 211 | C ENDIF |
|---|
| 212 | 42 CONTINUE |
|---|
| 213 | C |
|---|
| 214 | IF (NEXT(1) .EQ. 0) GO TO 49 |
|---|
| 215 | C IF (NEXT(1) .GT. 0) THEN |
|---|
| 216 | C IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(1) TO THE |
|---|
| 217 | C LEFT OF X(IR-1). |
|---|
| 218 | C |
|---|
| 219 | IF (IR .GT. 2) GO TO 43 |
|---|
| 220 | C IF (IR .EQ. 2) THEN |
|---|
| 221 | C THESE ARE ACTUALLY EXTRAPOLATION POINTS. |
|---|
| 222 | IERR = IERR + NEXT(1) |
|---|
| 223 | GO TO 49 |
|---|
| 224 | 43 CONTINUE |
|---|
| 225 | C ELSE |
|---|
| 226 | C XE IS NOT ORDERED RELATIVE TO X, SO MUST ADJUST |
|---|
| 227 | C EVALUATION INTERVAL. |
|---|
| 228 | C |
|---|
| 229 | C FIRST, LOCATE FIRST POINT TO LEFT OF X(IR-1). |
|---|
| 230 | DO 44 I = JFIRST, J-1 |
|---|
| 231 | IF (XE(I) .LT. X(IR-1)) GO TO 45 |
|---|
| 232 | 44 CONTINUE |
|---|
| 233 | C NOTE-- CANNOT DROP THROUGH HERE UNLESS THERE IS AN ERROR |
|---|
| 234 | C IN CHFEV. |
|---|
| 235 | GO TO 5005 |
|---|
| 236 | C |
|---|
| 237 | 45 CONTINUE |
|---|
| 238 | C RESET J. (THIS WILL BE THE NEW JFIRST.) |
|---|
| 239 | J = I |
|---|
| 240 | C |
|---|
| 241 | C NOW FIND OUT HOW FAR TO BACK UP IN THE X-ARRAY. |
|---|
| 242 | DO 46 I = 1, IR-1 |
|---|
| 243 | IF (XE(J) .LT. X(I)) GO TO 47 |
|---|
| 244 | 46 CONTINUE |
|---|
| 245 | C NB-- CAN NEVER DROP THROUGH HERE, SINCE XE(J).LT.X(IR-1). |
|---|
| 246 | C |
|---|
| 247 | 47 CONTINUE |
|---|
| 248 | C AT THIS POINT, EITHER XE(J) .LT. X(1) |
|---|
| 249 | C OR X(I-1) .LE. XE(J) .LT. X(I) . |
|---|
| 250 | C RESET IR, RECOGNIZING THAT IT WILL BE INCREMENTED BEFORE |
|---|
| 251 | C CYCLING. |
|---|
| 252 | IR = MAX(1, I-1) |
|---|
| 253 | C ENDIF |
|---|
| 254 | C ENDIF |
|---|
| 255 | 49 CONTINUE |
|---|
| 256 | C |
|---|
| 257 | JFIRST = J |
|---|
| 258 | C |
|---|
| 259 | C END OF IR-LOOP. |
|---|
| 260 | C |
|---|
| 261 | 50 CONTINUE |
|---|
| 262 | IR = IR + 1 |
|---|
| 263 | IF (IR .LE. N) GO TO 10 |
|---|
| 264 | C |
|---|
| 265 | C NORMAL RETURN. |
|---|
| 266 | C |
|---|
| 267 | 5000 CONTINUE |
|---|
| 268 | RETURN |
|---|
| 269 | C |
|---|
| 270 | C ERROR RETURNS. |
|---|
| 271 | C |
|---|
| 272 | 5001 CONTINUE |
|---|
| 273 | C N.LT.2 RETURN. |
|---|
| 274 | IERR = -1 |
|---|
| 275 | CALL XERMSG ('SLATEC', 'PCHFE', |
|---|
| 276 | + 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) |
|---|
| 277 | RETURN |
|---|
| 278 | C |
|---|
| 279 | 5002 CONTINUE |
|---|
| 280 | C INCFD.LT.1 RETURN. |
|---|
| 281 | IERR = -2 |
|---|
| 282 | CALL XERMSG ('SLATEC', 'PCHFE', 'INCREMENT LESS THAN ONE', IERR, |
|---|
| 283 | + 1) |
|---|
| 284 | RETURN |
|---|
| 285 | C |
|---|
| 286 | 5003 CONTINUE |
|---|
| 287 | C X-ARRAY NOT STRICTLY INCREASING. |
|---|
| 288 | IERR = -3 |
|---|
| 289 | CALL XERMSG ('SLATEC', 'PCHFE', 'X-ARRAY NOT STRICTLY INCREASING' |
|---|
| 290 | + , IERR, 1) |
|---|
| 291 | RETURN |
|---|
| 292 | C |
|---|
| 293 | 5004 CONTINUE |
|---|
| 294 | C NE.LT.1 RETURN. |
|---|
| 295 | IERR = -4 |
|---|
| 296 | CALL XERMSG ('SLATEC', 'PCHFE', |
|---|
| 297 | + 'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1) |
|---|
| 298 | RETURN |
|---|
| 299 | C |
|---|
| 300 | 5005 CONTINUE |
|---|
| 301 | C ERROR RETURN FROM CHFEV. |
|---|
| 302 | C *** THIS CASE SHOULD NEVER OCCUR *** |
|---|
| 303 | IERR = -5 |
|---|
| 304 | CALL XERMSG ('SLATEC', 'PCHFE', |
|---|
| 305 | + 'ERROR RETURN FROM CHFEV -- FATAL', IERR, 2) |
|---|
| 306 | RETURN |
|---|
| 307 | C------------- LAST LINE OF PCHFE FOLLOWS ------------------------------ |
|---|
| 308 | END |
|---|
