Google
 

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