Google
 

Trailing-Edge - PDP-10 Archives - decus_20tap1_198111 - decus/20-0009/func10.for
There is 1 other file named func10.for in the archive. Click here to see a list.
      SUBROUTINE FUNC10 (KR, KCM)
C     ************************* COMMON COMMON **************************    0020
      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 HLIST(500)
      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 (HLIST,KLIST)
      EQUIVALENCE  (TABLE,PARS(101))
C      ***************    END  COMMON  COMMON  *************************
      DIMENSION LIST(10), HNAME(3)
      DATA HNAME /' RESONANCES '/
C                                                                           0170
      IF (KCM)   5, 10, 10                                                  0180
 5    DO 6 I=1,3
 6    VAL(I) = HNAME(I)
      RETURN                                                                0230
C                                                                           0240
 10   NT = KLIST(KR)                                                        0250
      NRP = HLIST(KR + 1)                                                   0260
      NR = 0                                                                0270
      DO 15   N = 1,6                                                       0280
      LIST(N) = MOD(NRP,10)                                                 0290
      NR = NR + 1                                                           0300
      NRP = NRP / 10                                                        0310
      IF (NRP)   20, 20, 15                                                 0320
 15   CONTINUE                                                              0330
 20   KEND = KR + 3                                                         0340
      Y = 0.0                                                               0350
      Z = 0.0                                                               0360
C                                                                           0370
      DO 50   N = 1,NR                                                      0380
      CVSQ = TABLE(NT)**2                                                   0390
      CVGAM = TABLE(NT) * TABLE(NT + 1)                                     0400
      AMP = TABLE(NT + 2)                                                   0410
      PHASE = TABLE(NT + 3)/RADIAN                                          0420
      COSP = COS(PHASE)                                                     0430
      SINP = SIN(PHASE)                                                     0440
      NT = NT + 4                                                           0450
      NN = NR - N + 1                                                       0460
      KBEG = KEND + 1                                                       0470
      KEND = KEND + LIST(NN)                                                0480
      EFMSQ = SQMASS (KBEG,KEND)                                            0490
      X = (EFMSQ - CVSQ) / CVGAM                                            0500
      B = 1.0 / (1.0 + X*X)                                                 0510
      A = -X*B                                                              0520
      Y = Y + AMP*(A*COSP - B*SINP)                                         0530
      Z = Z + AMP*(B*COSP + A*SINP)                                         0540
 50   CONTINUE                                                              0550
C                                                                           0560
      WEIGHT = Y*Y + Z*Z                                                    0570
      RETURN                                                                0580
      END                                                                   0590