Trailing-Edge
-
PDP-10 Archives
-
decuslib20-01
-
decus/20-0009/func11.for
There is 1 other file named func11.for in the archive. Click here to see a list.
SUBROUTINE FUNC11 (KR,KCM)
CFUNC11 CALCULATES DEL**2 0100
C DEL**2= (EINC-E(K))**2-(PINC-P(K))**2 0120
C WHERE E(K) IS SUM OVER ALL E(K) IN LIST 0130
C AND P(K) ARE VECTORS 0140
C USES TABLE(1-2) FOR LIMITS 0150
C ************************* COMMON COMMON ************************** 0160
COMMON MAP(2000),PARS(1000),MISC(27),KLIST(500),MTABLE(2)
COMMON /LIMIT/LIMMNO,LIMLNO,LIMKNO,LIMEX
DIMENSION ZMAP(2000)
DIMENSION REMARK(500)
DIMENSION OTABLE(7,50), JTABLE(7,50), RTABLE(9,20,2),
1 LTABLE(9,20,2), ITABLE(6,20), VAL(100), IVAL(100),
2 WGT(100)
DIMENSION PARA(1000),NPARA(1000),SNAME(1000),NAME(1000)
DIMENSION HEAD(11), NBRNCH(10)
DIMENSION HTABLE(7,100)
DIMENSION TABLE(100)
EQUIVALENCE (MAP,ZMAP)
EQUIVALENCE (REMARK,MAP(1001))
EQUIVALENCE (OTABLE,JTABLE,MAP(701)), (RTABLE,LTABLE,MAP(1051)),
1 (ITABLE,MAP(1411)), (VAL,IVAL,MAP(1531)),
2 (WGT,MAP(1631))
EQUIVALENCE (NCFLAG,MAP(1869)), (WEIGHT,MAP(1978)),
1 (NTAPE,MAP(1988)), (EINC,MAP(1998)),
2 (PINC,MAP(1999)), (BINC,MAP(2000))
EQUIVALENCE (PARA,NPARA,PARS),(SNAME,NAME,MAP(1))
EQUIVALENCE (PI, MISC), (RADIAN, MISC(2)), (NIT, MISC(3)),
1 (NOT, MISC(4)), (HEAD, MISC(5)), (NBRNCH, MISC(16)),
2 (NPAGE, MISC(26)), (NORD, MISC(27))
EQUIVALENCE (LTAPE,NBRNCH(9)), (LINK,NBRNCH(10)), (HTABLE,MAP)
EQUIVALENCE (TABLE,PARS(101))
C *************** END COMMON COMMON *************************
DIMENSION HNAME(3)
DATA HNAME /'DEL**2 -LIST'/
C 0260
IF (KCM) 5,10,10 0270
5 DO 6 I=1,3
6 VAL(I) = HNAME(I)
GO TO 100 0320
10 KK=KLIST(KR) 0330
IF (KK) 11,11,15 0340
11 VAL(1)=0 0350
GO TO 100 0360
15 KB=KR+1 0370
KE=KR+KK 0380
KT = 1 0390
IF (KCM - 3) 55, 20, 55 0400
20 KT = KLIST(KE) 0410
KE = KE - 1 0420
55 VAL(1) = DELSQ(KB,KE) 0430
IF (TABLE(KT) - TABLE(KT+1)) 60, 100, 60 0440
60 IF ((VAL(1) - TABLE(KT))*(VAL(1) - TABLE(KT+1))) 100, 100, 90 0450
90 NCFLAG=-1 0460
GO TO 101 0470
100 NCFLAG=1 0480
101 RETURN 0490
END 0500