[u/mrichter/AliRoot.git] / MINICERN / packlib / kernlib / kernnum / e104fort / fint.F

*
* $Id$
*
* $Log$
* Revision 1.1.1.1  1996/02/15 17:48:36  mclareni
* Kernlib
*
*
#include "kernnum/pilot.h"
          FUNCTION FINT(NARG,ARG,NENT,ENT,TABLE)
C
C   INTERPOLATION ROUTINE. AUTHOR C. LETERTRE.
C   MODIFIED BY B. SCHORR, 1.07.1982.
C
          INTEGER   NENT(9)
          REAL      ARG(9),   ENT(9),   TABLE(9)
          INTEGER   INDEX(32)
          REAL      WEIGHT(32)
          LOGICAL   MFLAG,    RFLAG
          FINT  =  0.
          IF(NARG .LT. 1  .OR.  NARG .GT. 5)  GOTO 300
          LMAX      =  0
          ISTEP     =  1
          KNOTS     =  1
          INDEX(1)  =  1
          WEIGHT(1) =  1.
          DO 100    N  =  1, NARG
             X     =  ARG(N)
             NDIM  =  NENT(N)
             LOCA  =  LMAX
             LMIN  =  LMAX + 1
             LMAX  =  LMAX + NDIM
             IF(NDIM .GT. 2)  GOTO 10
             IF(NDIM .EQ. 1)  GOTO 100
             H  =  X - ENT(LMIN)
             IF(H .EQ. 0.)  GOTO 90
             ISHIFT  =  ISTEP
             IF(X-ENT(LMIN+1) .EQ. 0.)  GOTO 21
             ISHIFT  =  0
             ETA     =  H / (ENT(LMIN+1) - ENT(LMIN))
             GOTO 30
  10         LOCB  =  LMAX + 1
  11         LOCC  =  (LOCA+LOCB) / 2
             IF(X-ENT(LOCC))  12, 20, 13
  12         LOCB  =  LOCC
             GOTO 14
  13         LOCA  =  LOCC
  14         IF(LOCB-LOCA .GT. 1)  GOTO 11
             LOCA    =  MIN0( MAX0(LOCA,LMIN), LMAX-1 )
             ISHIFT  =  (LOCA - LMIN) * ISTEP
             ETA     =  (X - ENT(LOCA)) / (ENT(LOCA+1) - ENT(LOCA))
             GOTO 30
  20         ISHIFT  =  (LOCC - LMIN) * ISTEP
  21         DO 22  K  =  1, KNOTS
                INDEX(K)  =  INDEX(K) + ISHIFT
  22            CONTINUE
             GOTO 90
  30         DO 31  K  =  1, KNOTS
                INDEX(K)         =  INDEX(K) + ISHIFT
                INDEX(K+KNOTS)   =  INDEX(K) + ISTEP
                WEIGHT(K+KNOTS)  =  WEIGHT(K) * ETA
                WEIGHT(K)        =  WEIGHT(K) - WEIGHT(K+KNOTS)
  31            CONTINUE
             KNOTS  =  2*KNOTS
  90         ISTEP  =  ISTEP * NDIM
 100         CONTINUE
          DO 200    K  =  1, KNOTS
             I  =  INDEX(K)
             FINT  =  FINT + WEIGHT(K) * TABLE(I)
 200         CONTINUE
          RETURN
 300      CALL KERMTR('E104.1',LGFILE,MFLAG,RFLAG)
          IF(MFLAG) THEN
             IF(LGFILE .EQ. 0) THEN
                WRITE(*,1000) NARG
             ELSE
                WRITE(LGFILE,1000) NARG
             ENDIF
          ENDIF
          IF(.NOT. RFLAG) CALL ABEND
          RETURN
1000      FORMAT( 7X, 24HFUNCTION FINT ... NARG =,I6,
     +              17H NOT WITHIN RANGE)
          END
Commit	Line	Data
fe4da5cc	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