[u/mrichter/AliRoot.git] / MICROCERN / fint.F

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