MINICERN/packlib/kernlib/kernnum/e104fort/fint.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/02/15 17:48:36  mclareni
   6 * Kernlib
   7 *
   8 *
   9 #include "kernnum/pilot.h"
  10           FUNCTION FINT(NARG,ARG,NENT,ENT,TABLE)
  11 C
  12 C   INTERPOLATION ROUTINE. AUTHOR C. LETERTRE.
  13 C   MODIFIED BY B. SCHORR, 1.07.1982.
  14 C
  15           INTEGER   NENT(9)
  16           REAL      ARG(9),   ENT(9),   TABLE(9)
  17           INTEGER   INDEX(32)
  18           REAL      WEIGHT(32)
  19           LOGICAL   MFLAG,    RFLAG
  20           FINT  =  0.
  21           IF(NARG .LT. 1  .OR.  NARG .GT. 5)  GOTO 300
  22           LMAX      =  0
  23           ISTEP     =  1
  24           KNOTS     =  1
  25           INDEX(1)  =  1
  26           WEIGHT(1) =  1.
  27           DO 100    N  =  1, NARG
  28              X     =  ARG(N)
  29              NDIM  =  NENT(N)
  30              LOCA  =  LMAX
  31              LMIN  =  LMAX + 1
  32              LMAX  =  LMAX + NDIM
  33              IF(NDIM .GT. 2)  GOTO 10
  34              IF(NDIM .EQ. 1)  GOTO 100
  35              H  =  X - ENT(LMIN)
  36              IF(H .EQ. 0.)  GOTO 90
  37              ISHIFT  =  ISTEP
  38              IF(X-ENT(LMIN+1) .EQ. 0.)  GOTO 21
  39              ISHIFT  =  0
  40              ETA     =  H / (ENT(LMIN+1) - ENT(LMIN))
  41              GOTO 30
  42   10         LOCB  =  LMAX + 1
  43   11         LOCC  =  (LOCA+LOCB) / 2
  44              IF(X-ENT(LOCC))  12, 20, 13
  45   12         LOCB  =  LOCC
  46              GOTO 14
  47   13         LOCA  =  LOCC
  48   14         IF(LOCB-LOCA .GT. 1)  GOTO 11
  49              LOCA    =  MIN0( MAX0(LOCA,LMIN), LMAX-1 )
  50              ISHIFT  =  (LOCA - LMIN) * ISTEP
  51              ETA     =  (X - ENT(LOCA)) / (ENT(LOCA+1) - ENT(LOCA))
  52              GOTO 30
  53   20         ISHIFT  =  (LOCC - LMIN) * ISTEP
  54   21         DO 22  K  =  1, KNOTS
  55                 INDEX(K)  =  INDEX(K) + ISHIFT
  56   22            CONTINUE
  57              GOTO 90
  58   30         DO 31  K  =  1, KNOTS
  59                 INDEX(K)         =  INDEX(K) + ISHIFT
  60                 INDEX(K+KNOTS)   =  INDEX(K) + ISTEP
  61                 WEIGHT(K+KNOTS)  =  WEIGHT(K) * ETA
  62                 WEIGHT(K)        =  WEIGHT(K) - WEIGHT(K+KNOTS)
  63   31            CONTINUE
  64              KNOTS  =  2*KNOTS
  65   90         ISTEP  =  ISTEP * NDIM
  66  100         CONTINUE
  67           DO 200    K  =  1, KNOTS
  68              I  =  INDEX(K)
  69              FINT  =  FINT + WEIGHT(K) * TABLE(I)
  70  200         CONTINUE
  71           RETURN
  72  300      CALL KERMTR('E104.1',LGFILE,MFLAG,RFLAG)
  73           IF(MFLAG) THEN
  74              IF(LGFILE .EQ. 0) THEN
  75                 WRITE(*,1000) NARG
  76              ELSE
  77                 WRITE(LGFILE,1000) NARG
  78              ENDIF
  79           ENDIF
  80           IF(.NOT. RFLAG) CALL ABEND
  81           RETURN
  82 1000      FORMAT( 7X, 24HFUNCTION FINT ... NARG =,I6,
  83      +              17H NOT WITHIN RANGE)
  84           END