Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-01 - decus/20-0009/nvhist.for
There is 1 other file named nvhist.for in the archive. Click here to see a list.
      SUBROUTINE EHIST
CEHIST*2   ENTERS EVENT VARIABLES INTO HISTOGRAMS
C     EXTRA CARD PARAMETER VERSION -- INCOMPATIBLE WITH ANY OTHER NVERTX
C     ************************* COMMON COMMON **************************    0030
      COMMON    MAP(2000),PARS(1000),MISC(27),KLIST(500),MTABLE(2)
      DIMENSION ZMAP(2000)                                              NBOD0110
      DIMENSION REMARK(500)
      DIMENSION    OTABLE(7,50), JTABLE(7,50), RTABLE(9,20,2),          NBOD0120
     1             LTABLE(9,20,2), ITABLE(6,20), VAL(100), IVAL(100),   NBOD0130
     2             WGT(100)                                             NBOD0140
      DIMENSION PARA(1000),NPARA(1000),SNAME(1000),NAME(1000)
      DIMENSION    HEAD(11), NBRNCH(10)                                 NBOD0170
      DIMENSION    KTABLE(7,100), HTABLE(7,100), DCTRA(3), DIRINC(3),
     1             VM(3), VN(3), WTABLE(2)
      EQUIVALENCE (MAP,ZMAP)                                            NBOD0340
      EQUIVALENCE (REMARK,MAP(1001))
      EQUIVALENCE  (OTABLE,JTABLE,MAP(701)), (RTABLE,LTABLE,MAP(1051)), NBOD0350
     1             (ITABLE,MAP(1411)), (VAL,IVAL,MAP(1531)),            NBOD0360
     2             (WGT,MAP(1631))                                      NBOD0370
      EQUIVALENCE  (NCFLAG,MAP(1869)), (WEIGHT,MAP(1978)),              NBOD0380
     1             (NTAPE,MAP(1988)), (EINC,MAP(1998)),                 NBOD0390
     2             (PINC,MAP(1999)), (BINC,MAP(2000))                   NBOD0400
      EQUIVALENCE  (KTABLE,HTABLE,MAP), (WTABLE,MTABLE), (RADIAN,           0310
     1             MISC(2)), (DIRINC,PARS(95)), (DCTRA,MAP(1852)),          0320
     2             (VM,MAP(1833)), (VN,MAP(1836)), (LISTW,MAP(1979)),       0330
     3             (LISTG,MAP(1989)), (IPS,MAP(1973)), (WPS,MAP(1974))      0340
      EQUIVALENCE (PARA,NPARA,PARS),(SNAME,NAME,MAP(1))
      EQUIVALENCE  (PI, MISC), (RADIAN, MISC(2)), (NIT, MISC(3)),       NBOD0490
     1             (NOT, MISC(4)), (HEAD, MISC(5)), (NBRNCH, MISC(16)), NBOD0500
     2             (NPAGE, MISC(26)), (NORD, MISC(27))                  NBOD0510
C     ****************** END OF C D E PACKAGE **************************    0280
C                                                                           0350
      IF (LISTW)   3, 3, 1                                                  0360
    1 CALL GENFUN(LISTW, 0)                                                 0370
 3    IF (LISTG)   7, 7, 5                                                  0380
    5 CALL GENFUN(LISTG, 0 )                                                0390
 7    NXC = 0                                                               0400
C                                                                           0410
      DO 200 K = 1,100                                                      0420
      NCFLAG = 0                                                            0430
      IF (KTABLE(1,K))   500, 500, 8                                        0440
C        HISTOGRAM, X PLOT OR Y PLOT                                        0450
 8    NBR = 1                                                               0460
      KT = KTABLE(1,K)                                                      0470
      IF (KT - 1000)   9, 801, 801                                          0480
 801  IF (KT - 2000)  8011, 802, 802                                        0490
 8011 NXC = 0                                                               0500
      NBR = 2                                                               0510
      GO TO 805                                                             0520
 802  IF (NXC)   200, 803, 200                                              0530
 803  NBR = 3                                                               0540
 805  KT= MOD(KT, 1000)                                                     0550
C        SET KT AND KTT, VARIABLE CODES W AND W/O CMS CODE                  0560
 9    KTT = MOD(KT,10)                                                      0570
      IF (KTT)   200, 901, 902                                              0580
 901  KTT = 10                                                              0590
      KT = KT - 90                                                          0600
C        CONDITIONAL TEST                                                   0610
 902  KFLAG = 0                                                             0620
      IF (KTABLE(3,K))   9021, 10, 903                                      0630
 9021 KFLAG = 3                                                             0640
 903  KCON = IABS(KTABLE(3,K))                                              0650
      IF(KFLAG.EQ.3) KCON = KCON/1000
      CALL GENFUN (KCON, KFLAG)                                             0660
      IF (NCFLAG)   905, 10, 10                                             0670
 905  GO TO (200, 907, 200), NBR                                            0680
 907  NXC = 1                                                               0690
      GO TO 200                                                             0700
C        GET HISTOGRAMMING DATA                                             0710
 10   M = KTABLE(2,K)                                                       0720
      N = KTABLE(5,K)                                                       0730
      WGT(1)= WPS                                                           0740
      NRT = 1                                                               0750
      IPS = IPS                                                             0760
      GO TO (1002, 1001), IPS                                               0770
 1001 NRT = 2                                                               0780
      MA = M + N + 2                                                        0790
      MB = 2*MA - M                                                         0800
 1002 IF (N)   1003, 1004, 1004                                             0810
 1003 NRT = 2                                                               0820
      WGT(1)= WGT(1)* WEIGHT                                                0830
      N = -N                                                                0840
      MA = M + N + 2                                                        0850
      MB = MA + N + 2                                                       0860
 1004 XBEG = HTABLE(6,K)                                                    0870
      XEND = HTABLE(7,K)                                                    0880
      ML = IABS(KTABLE(4,K))                                                0890
      IF(KTABLE(4,K).LT.0) ML = ML/1000
      MO = KLIST(ML)                                                        0900
      ML = ML + 1                                                           0910
      IF (KTT - 10)   1008, 1005, 1005                                      0920
 1005 MO = KLIST(ML)                                                        0930
      ML = ML + 1                                                           0940
 1008 ME = ML + MO - 1                                                      0950
      KE = 0                                                                0960
      KBEG = ML                                                             0970
C        SET CMS TRANSFORMATION DATA                                        0980
      KCMS = (KT - 1)/10                                                    0990
      IF (KCMS - 1)   19, 11, 11                                            1000
 11   KE = KLIST(ME)                                                        1010
      ME = ME - 1                                                           1020
      IF (KE)  200, 200, 14
 14   JV = JTABLE ( 7,KE )                                                  1100
      DO 15    KK = 1,3                                                     1110
 15   DCTRA ( KK ) = OTABLE ( KK, KE )                                      1120
      TMASS = RTABLE ( 9, JV, 1 )                                           1130
      BETLAB = OTABLE ( 5, KE )                                             1140
      BPLAB = OTABLE ( 4, KE )                                              1150
 16   IF (KCMS - 1)   19, 17, 18                                            1160
 17   TMASS = 0.0                                                           1170
 18   BETA =  BPLAB/(BETLAB + TMASS)                                        1180
C                                                                           1190
 19   GO TO (20, 40, 60, 80, 20, 60, 80, 40, 40, 100), KTT                  1200
C     ANGLE HISTOGRAM ( A CARD)                                             1210
 20   NENT = 0                                                              1220
      DO 39   ML = KBEG, ME                                                 1230
      Q = 0.0                                                               1240
      KL = KLIST(ML)                                                        1250
      IF (KCMS)   200, 21, 25                                               1260
 21   DO 22   KK = 1,3                                                      1270
 22   VM(KK) = OTABLE ( KK,KL)                                              1280
      GO TO 30                                                              1290
 25   DO 26   KK = 1,3                                                      1300
 26   VN(KK) = OTABLE ( KK,KL )                                             1310
      EIN = OTABLE ( 5,KL )                                                 1320
      PIN = OTABLE ( 4, KL )                                                1330
      CALL LORTRA (BETA, DCTRA(1), EIN, PIN, VN(1), EVAL, PVAL, VM(1))      1340
 30   DO 31   KK = 1,3                                                      1350
 31   Q = Q + DIRINC(KK) * VM(KK)                                           1360
      IF (ABS(Q) - 1.0)   33, 33, 32                                        1370
 32   Q = SIGN(1.0,Q)                                                       1380
 33   IF  (KTT - 5)  34, 35, 34                                             1390
 34   Q =ACOS(Q) * RADIAN                                                  1400
 35   NENT = NENT + 1                                                       1410
      VAL(NENT) = Q                                                         1420
 39   CONTINUE                                                              1430
      GO TO 110                                                             1440
C     MOMENTUM HISTOGRAM (P CARD)                                           1450
 40   NENT = 0                                                              1460
      DO 59   ML = KBEG, ME                                                 1470
      KL = KLIST(ML)                                                        1480
      IF (KCMS)   200, 41, 45                                               1490
 41   PVAL = OTABLE(4,KL)                                                   1500
      EVAL = OTABLE(5,KL)                                                   1510
      GO TO 50                                                              1520
 45   DO 46   KK = 1,3                                                      1530
 46   VN(KK) = OTABLE ( KK,KL )                                             1540
      EIN = OTABLE( 5,KL )                                                  1550
      PIN = OTABLE( 4,KL )                                                  1560
      CALL LORTRA (BETA, DCTRA(1), EIN, PIN, VN(1), EVAL, PVAL, VM(1))      1570
 50   CONTINUE                                                              1580
      IF (KTT - 8)   501, 505, 503                                          1590
 501  Q = PVAL                                                              1600
      GO TO 52                                                              1610
 503  Q = EVAL                                                              1620
      GO TO 52                                                              1630
 505  IV = JTABLE(6,KL)                                                     1640
      IVB = JTABLE(7,KL)                                                    1650
      DO 507   IP = 1, 8                                                    1660
      IF (LTABLE(IP,IV,2) - IVB)   507, 508, 507                            1670
 507  CONTINUE                                                              1680
      GO TO 200                                                             1690
 508  MSNO = LTABLE(IP,IV,1)                                                1700
      CALL GETMS (MSNO,FM)                                                  1710
      Q = EVAL - FM                                                         1720
 52   NENT = NENT + 1                                                       1730
      VAL(NENT) = Q                                                         1740
 59   CONTINUE                                                              1750
      GO TO 110                                                             1760
C     RELATIVE ANGLE HISTOGRAM (R CARD)                                     1770
 60   NENT = 0                                                              1780
      DO 79   ML = KBEG, ME, 2                                              1790
      Q = 0.0                                                               1800
      KL = KLIST(ML)                                                        1810
      MLL = ML +1                                                           1820
      KLL = KLIST (MLL)                                                     1830
      IF (KCMS)   200, 601, 605                                             1840
 601  DO 602   KK = 1,3                                                     1850
      VM(KK) = OTABLE(KK,KL)                                                1860
 602  VN(KK) = OTABLE(KK,KLL)                                               1870
      GO TO 607                                                             1880
 605  EIN = OTABLE(5,KL)                                                    1890
      PIN = OTABLE(4,KL)                                                    1900
      CALL LORTRA (BETA,DCTRA(1), EIN,PIN,OTABLE(1,KL), EVAL,PVAL,VM(1))    1910
      EIN = OTABLE(5,KLL)                                                   1920
      PIN = OTABLE(4,KLL)                                                   1930
      CALL LORTRA (BETA,DCTRA(1), EIN,PIN,OTABLE(1,KLL), EVAL,PVAL,VN(1)    1940
     1)                                                                     1950
 607  DO 61   KK = 1,3                                                      1960
 61   Q = Q + VM(KK) * VN(KK)                                               1970
      IF (ABS(Q) - 1.0)   63, 63, 62                                        1980
 62   Q = SIGN(1.0,Q)                                                       1990
 63   IF (KTT - 6 )  64, 65, 64                                             2000
 64   Q =ACOS(Q) * RADIAN                                                  2010
 65   NENT = NENT + 1                                                       2020
      VAL(NENT) = Q                                                         2030
 79   CONTINUE                                                              2040
      GO TO 110                                                             2050
C     INVARIANT MASS HISTOGRAM ( M CARD)                                    2060
 80   NENT = 1                                                              2070
      VAL(1)= SQMASS (KBEG,ME)                                              2080
      IF (KTT - 4)   200, 92, 110                                           2090
 92   VAL(1)= SQRT(VAL(1))                                                  2100
      GO TO 110                                                             2110
C        FUNCTION HISTOGRAM (F CARD)                                        2120
 100  KLENT = KTABLE(4,K)                                                   2130
      IF (KLENT)   106, 108, 108                                            2140
 106  KCMS = KCMS + 3                                                       2150
      KLENT = -KLENT/1000
 108  CALL GENFUN (KLENT, KCMS)                                             2170
 109  NENT= MAX0(1, IABS(NCFLAG))                                           2180
C        VAL AND NENT ALL READY, LOAD WEIGHT ARRAY                          2190
 110  DO 111   KK = 1, NENT                                                 2200
 111  WGT(KK) = WGT(1)                                                      2210
      GO TO (112, 120, 130), NBR                                            2220
C        ENTER INTO HISTOGRAM                                               2230
 112  GO TO (114, 116), NRT                                                 2240
 114  CALL HISTO (VAL(1), NENT, MTABLE(M), N, XBEG, XEND)                   2250
      GO TO 200                                                             2260
 116  CALL HISTOW (VAL(1), NENT, MTABLE(M), WTABLE(MA), N, XBEG, XEND,      2270
     1      WGT(1), WTABLE(MB))                                             2280
      GO TO 200                                                             2290
C        RECORD X COORDINATE FOR PLOT                                       2300
 120  CONTINUE                                                              2310
      DO 124   KK = 1, NENT                                                 2320
 124  VAL (KK + 50) = VAL(KK)                                               2330
      NA = N                                                                2340
      AMIN = XBEG                                                           2350
      AMAX = XEND                                                           2360
      GO TO 200                                                             2370
C        ENTER EVENTS INTO PLOT                                             2380
 130  CONTINUE                                                              2390
      CALL ENTMAT (NRT, VAL(51), VAL(1), NENT, WGT(1), MTABLE(M), WTABLE    2400
     1(M),     AMIN, AMAX, NA, XBEG, XEND, N)                               2410
 200  CONTINUE                                                              2420
C                                                                           2430
 500  CONTINUE                                                              2440
      RETURN                                                                2450
      END                                                                   2460
      SUBROUTINE OHIST  (NOZ)
COHIST*2   HISTOGRAM OUTPUT ROUTINE
C     EXTRA CARD PARAMETER VERSION -- INCOMPATIBLE WITH ANY OTHER NVERTX
C     ZERO ONLY IF NOZ NEGATIVE                                             0030
C      ******************    COMMON COMMON   ***************************    0040
      COMMON    MAP(2000),PARS(1000),MISC(27),KLIST(500),MTABLE(2)
      COMMON /LIMIT/LIMMNO,LIMLNO,LIMKNO,LIMEX
      DIMENSION ZMAP(2000)
      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 HTABLE(7,100), KTABLE(7,100), TITLE(48)
      DIMENSION PARA(1000),NPARA(1000),SNAME(1000),TABLE(100)
      DIMENSION    HEAD(11), NBRNCH(10)
      DIMENSION WTABLE(2)
      EQUIVALENCE (MAP,ZMAP),(TABLE(1),PARA(101))
      EQUIVALENCE  (OTABLE,JTABLE,MAP(701)), (RTABLE,LTABLE,MAP(1051)),
     1             (ITABLE,MAP(1411)), (VAL,IVAL,MAP(1531)),
     2             (WGT,MAP(1631))
      EQUIVALENCE (HTABLE, KTABLE, MAP)
      EQUIVALENCE  (NCFLAG,MAP(1869)), (WEIGHT,MAP(1978)),
     1             (NTAPE,MAP(1988)), (EINC,MAP(1998)),
     2             (PINC,MAP(1999)), (BINC,MAP(2000))
      EQUIVALENCE  (IPS,MAP(1973)), (WPS,MAP(1974))                         0640
      EQUIVALENCE(NOUTH,MAP(1980)),(NOUTM,MAP(1981)),(NPT,MAP(1982))
      EQUIVALENCE  (TITLE,MAP(1870))
      EQUIVALENCE (PARA,NPARA,PARS),(SNAME,MAP)
      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  (MTABLE, WTABLE)                                         0670
C      ***************    END  COMMON  COMMON  *************************    0320
      DIMENSION AME(3), AMES(6)
      EQUIVALENCE (AME,NAM)
      IF (NOZ) 5001 ,5, 5                                                   0700
 5001 DO 501   KK = 1, LIMMNO                                               0710
 501  MTABLE(KK) = 0                                                        0720
      GO TO 502                                                             0730
    5 CONTINUE                                                              0740
      CALL ITRNDM(0,IOLD)                                               8/17/68
      WRITE (NOT,9200) IOLD                                             8/17/68
 9200 FORMAT('0TO CONTINUE THIS RUN SET THE STARTING VALUE OF RANDOM = '8/17/68
     1        I10)                                                      8/17/68
      NH = 0                                                                0750
      DO 200 K = 1,100                                                      0760
      IF (KTABLE(1,K))500,500,10                                            0770
 10   M = KTABLE(2,K)                                                       0780
      N = KTABLE(5,K)                                                       0790
      NZ = 0                                                                0800
      GO TO (17, 15), IPS                                                   0820
 15   NZ = 2                                                                0830
      I = M + N + 2                                                         0840
      J = 2*I - M                                                           0850
 17   IF (N)   20, 70, 70                                                   0860
 20   NZ = 2                                                                0870
      N = -N                                                                0880
      I = M + N + 2                                                         0890
      J = I + N + 2                                                         0900
 70   XBEG = HTABLE(6, K)                                                   0910
      XEND = HTABLE(7,K)                                                    0920
      CALL NAME(K, AME(1))
 85   CONTINUE                                                              0940
      IF (KTABLE(1,K) - 1000)   150, 90, 90                                 0950
 90   IF (KTABLE(1,K) - 2000)   95, 100, 100                                0960
 95   KX = K                                                                0970
      DO 96 I=1,3
 96   AMES(I) = AME(I)
      NA = N                                                                0990
      AMIN = XBEG                                                           1000
      AMAX = XEND                                                           1010
      GO TO 200                                                             1020
 100  DO 101 I=1,3
 101  AMES(I+3) = AME(I)
      NZ= MAX0(NZ, 1)                                                       1040
      NH = NH + 1                                                           1060
      IF(NOUTM.EQ.0) GO TO 103
      WRITE(NPT,9123)NH,PINC,TITLE
 9123 FORMAT(4H NO.I3,1XF9.4,3X,48A1)
  270 DO 300 I=1,N
      MBEG=M+(I-1)*(NA+1)
      MEND=MBEG+NA-1
      IF (NZ-1) 280, 280, 290
  280 WRITE (NPT,9400) (MTABLE(J),J=MBEG,MEND)
      GO TO 300
  290 WRITE (NPT,9450) (WTABLE(J),J=MBEG,MEND)
  300 CONTINUE
  103 CALL OUTMAT (NOT,AMES(1),NZ,MTABLE(M),AMIN,AMAX,NA,XBEG,XEND,N)
      WRITE (NOT,9100)NH                                                    1070
 9100 FORMAT (3H NO I4, 25H TWO DIMENSIONAL PLOT OF   )                     1080
      CALL HISCAP (0,KX)                                                    1090
      CALL HISCAP (0,K)                                                     1100
      GO TO 200                                                             1110
 150  CALL TRHIST (NOT, NZ,  NAM,   MTABLE(M), WTABLE(I), WTABLE(J), N,
     1      XBEG, XEND)                                                     1130
      NH = NH + 1                                                           1140
      IF(NOUTH.EQ.0) GO TO 105
      WRITE(NPT,9150)NH,PINC,AME,TITLE
 9150 FORMAT(4H NO.I3,1XF9.4,1X3A4,2X48A1)
      IF (NZ) 350, 350, 360
  350 MHI = M+N-1
      WRITE (NPT,9400) (MTABLE(NPM), NPM=M,MHI)
 9400 FORMAT (12I6)
      GO TO 105
  360 MHI = I+N-1
      WRITE (NPT,9450) (WTABLE(NPM), NPM=I,MHI)
 9450 FORMAT (10F8.2)
  105 WRITE (NOT,9000)
 9000 FORMAT (1H0)                                                          1160
      CALL HISCAP (NH,K)                                                    1170
 200   CONTINUE                                                             1180
 500  CONTINUE                                                              1190
 502  CONTINUE                                                              1200
      RETURN                                                                1210
      END                                                                   1220