Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-01 - decus/20-0009/nvhed.for
There is 1 other file named nvhed.for in the archive. Click here to see a list.
      SUBROUTINE HEDING
CHEDING*1  PRINTS OUT HEADING FOR RUN                                   HEDI0010
C     ************************* COMMON COMMON **************************HEDI0030
      COMMON    MAP(2000),PARS(1000),MISC(27),KLIST(500),MTABLE(2)
      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 PARA(1000),NPARA(1000),SNAME(1000),NAME(1000),TABLE(100)
      DIMENSION    HEAD(11), NBRNCH(10),HTABLE(7,100)
      DIMENSION    KTABLE(7,100), TITLE(48),OBANK(90), IBANK(90),       HEDI0100
     1             TBLMS(30), AD(40), HLIST(500)                        HEDI0110
      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  (NCFLAG,MAP(1869)), (WEIGHT,MAP(1978)),
     1             (NTAPE,MAP(1988)), (EINC,MAP(1998)),
     2             (PINC,MAP(1999)), (BINC,MAP(2000))
      EQUIVALENCE  (KTABLE, MAP), (TITLE, MAP(1870)), (OBANK, IBANK,
     1             MAP(1779)), (IPS, MAP(1973)), (GMINP, MAP(1975)),
     2             (GMAXP, MAP(1976)), (LISTW, MAP(1979)), (LISTG,
     3             MAP(1989))
      EQUIVALENCE (MTOT,MAP(1987)), (IRNDM,MAP(1986))                   8/17/68
      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), (TBLMS, PARS), (AD, PARS(40)),
     1             (RSCALE, PARS(98))
C     ************************* END OF C, D, E STATEMENTS **************HEDI0340
      DATA ASTERK/'****'/, BLANKS/' '/, HNON/'NON-'/, AHOL/'A'/,
     1PARENL, PARENR/'(', ')'/, PLUS/' +'/
C                                                                       HEDI0430
      WRITE (NOT,9005)TITLE                                             HEDI0440
 9005     FORMAT ( 1H1 48A1)
      GO TO (3, 4), IPS                                                 INVERTX
 3    TYP =BLANKS
      GO TO 5                                                           HEDI0530
 4    TYP = HNON
 5    WRITE (NOT,9007)MTOT, TYP                                         HEDI0560
 9007    FORMAT ( 35H0THE FOLLOWING HISTOGRAMS REFER TO                 HEDI0570
     1   I6, 36H THROWS OF THE FOLLOWING REACTIONS, A4, 21HINVARIANT PHAHEDI0580
     2SE-SPACE  )                                                       HEDI0590
      TMASS = RTABLE(9,1,1)                                             HEDI0600
      BETA = PINC/(EINC + TMASS)                                        HEDI0610
      BETA= AMIN1(BETA, 1.0)                                            HEDI0620
      GAMMA = 1.0/SQRT(1.0 - BETA**2)                                   HEDI0630
      OMEGA = (EINC + TMASS)/GAMMA                                      HEDI0640
      WRITE (NOT,9012)PINC, EINC, OMEGA, BETA, GAMMA                    HEDI0650
 9012 FORMAT (1H0 43HINITIAL STATE PARAMETERS - BEAM MOMENTUM =  F10.4, HEDI0660
     1   3X14HBEAM ENERGY =  F10.4 / 1H0 27X16HCMS ENERGY  =    F10.4,  HEDI0670
     2   3X9HBETA    = 5XF10.4, 3X10HGAMMA    =  4XF10.4  )             HEDI0680
      IF (BINC)   7, 601, 7
 601  IF (GMINP)    7, 7, 602
 602  WRITE (NOT,9006)GMINP, GMAXP                                      HEDI0710
 9006 FORMAT ( 44H0THIS IS A BREMMSTRAHLUNG SPECTRUM BETWEEN     F10.3, HEDI0720
     1    4H AND   F10.3  )                                             HEDI0730
 7    WRITE (NOT,9008)
 9008 FORMAT  ( 1H0  120(1H*))
      WRITE (NOT,9009)                                                  HEDI0760
 9009 FORMAT (18H VERT   DIS   POL   /18H ----------------- )           HEDI0770
      DO 100   K = 1,20                                                 HEDI0780
      IF ( ITABLE ( 1,K)- 1 )   100, 100, 9                             HEDI0790
 9    DO 10   KK = 1,11
      OBANK(KK) = BLANKS
 10   CONTINUE                                                          HEDI0830
      CALL NTOL ( 1, OBANK(1), K )                                      HEDI0840
      IDUM = ITABLE(5,K)/10
      IF (IDUM .GT. 0)  OBANK(2) = BCDW(IDUM)
 15   IF ( ITABLE (6,K) )    20,20,18
 18   IDUM = ITABLE(6,K)                                                HEDI0940
      CALL NTOL ( 2, OBANK(3), JTABLE(6, IDUM) )
 20   IF (K - 1)   100, 22, 23                                          HEDI0970
 22   OBANK(7) = AHOL
      OBANK(8) = AHOL
      IBANK(5) = BINC*RSCALE + 0.5
      GO TO 24
 23   KK = ITABLE(3,K)
      CALL NTOL(1, OBANK(7), KK)
      CALL NTOL(1, OBANK(8), K)
      IDUM = ITABLE(4,K)
      KDUM = LTABLE(IDUM, KK, 1)                                        HEDI1050
      IBANK(5) = TBLMS(KDUM)*RSCALE + 0.5
      IF (KDUM - 20)   24, 25, 25                                       HEDI1150
 24   OBANK(6) = PARENL
      OBANK(9) = PARENR
      GO TO 26                                                          HEDI1190
 25   OBANK(6) = ASTERK
      OBANK(9) = ASTERK
 26   IF (RTABLE(9, K, 1))   100, 30, 28
 28   OBANK(10) = PLUS
      IDUM = RTABLE(9,K,1)*RSCALE + 0.5                                 HEDI1310
      OBANK(11) = BCDW(IDUM)
 30   IDUM = ITABLE(1,K )                                               HEDI1370
      II = 12
      DO 40   KK = 1, IDUM                                              HEDI1390
      IF ( KK-1)   40, 34, 32                                           HEDI1400
 32   OBANK (II) = PLUS
      II = II +1                                                        HEDI1430
 34   KDUM = LTABLE(KK, K, 1)                                           HEDI1440
      IBANK(II) = TBLMS(KDUM) * RSCALE + 0.5                            HEDI1450
      II = II + 1                                                       HEDI1460
      IF (LTABLE(KK, K, 1) - 20 )  35, 36, 36                           HEDI1470
 35   OBANK(II) = PARENL
      OBANK(II+3) = PARENR
      GO TO 37
 36   OBANK(II) = ASTERK
      OBANK(II+3) = ASTERK
 37   CALL NTOL(1, OBANK(II+1), K)
      CALL NTOL(1, OBANK(II+2), LTABLE(KK, K, 2))
      II = II + 4
 40   CONTINUE                                                          HEDI1640
      II = II - 1                                                       HEDI1650
      WRITE (NOT,9040)( IBANK(KK), KK = 1, II )
 9040 FORMAT (1H0,2X,A3,A4,5X,2A1,5X,I5,4A1,A3,A4,3H  =,8(I5,4A1,A2))
 100  CONTINUE                                                          HEDI1680
      WRITE (NOT,9008)
      NSFL = 0                                                          HEDI1720
      DO 104  K = 1, 20                                                 HEDI1730
      IF(ITABLE(5, K))  104, 104, 102                                   HEDI1740
 102  NSFL = NSFL + 1                                                   HEDI1750
      IBANK(1) = ITABLE(5, K) / 10                                      HEDI1760
      IDUM = ITABLE(5, K) + 1                                           HEDI1770
      IEND = IDUM + 9                                                   HEDI1780
      II = 2                                                            HEDI1790
      DO 103  KK = IDUM, IEND                                           HEDI1800
      IF (AD(KK))  1021, 103, 1021                                      HEDI1810
 1021 OBANK(II) = AD(KK)                                                HEDI1820
      IBANK(II+1) = KK - IDUM
      OBANK(II+2) = PLUS
      II = II + 3
 103  CONTINUE                                                          HEDI1920
      II = II - 2
      IF (II) 104, 1032, 1034
 1032 WRITE (NOT,9103) IBANK(1)
      GO TO 104
 1034 WRITE (NOT,9103)(IBANK(KK),OBANK(KK+1),IBANK(KK+2), KK=1,II,3)
 9103 FORMAT(7H0   DIS I3, 3H  = 7(F7.2, 6H(COS** I1, 1H) A2))
 104  CONTINUE                                                          HEDI1990
C     FERMI ADDITIONS                                                   HEDI2000
      DO 210  K = 1, 20                                                 HEDI2010
      IF (RTABLE(9, K, 2))  201, 210, 201                               HEDI2020
 201  NSFL = NSFL + 1                                                   HEDI2030
      CALL NTOL (1, AA, K)                                              HEDI2040
      WRITE (NOT,9201)AA, RTABLE(9,K,2)                                 HEDI2050
 9201 FORMAT (8H0VERTEX  A2, 25H HAS A FERMI MOMENTUM OF  F9.3, 5H  MAX)HEDI2060
 210  CONTINUE                                                          HEDI2070
      IF (NSFL)  1045, 1045, 1041                                       HEDI2080
 1041 WRITE (NOT,9008)
 1045 CONTINUE                                                          HEDI2120
      NRT = 0                                                           HEDI2130
      IF (LISTW)   112, 112, 105                                        HEDI2140
C        WEIGHT REQUEST PRINT OUT                                       HEDI2150
 105  KK = LISTW  + 1                                                   HEDI2160
      OBANK(1) = HLIST(LISTW)                                           HEDI2180
      CALL GENFUN (LISTW,-1)                                            HEDI2190
      DO 1051 K=1,3
 1051 OBANK(K+1) = VAL(K)
      DO 106 K=5,7
      OBANK(K) = HLIST(KK)                                              HEDI2230
 106  KK = KK + 1                                                       HEDI2240
      MO = KLIST(KK)                                                    HEDI2250
      J = 7
      NRT = 1                                                           HEDI2270
      IF (MO)   110, 110, 1062                                          HEDI2280
 1062 MB = LISTW + 5                                                    HEDI2290
      ME = MB + MO - 1                                                  HEDI2300
 107  CONTINUE                                                          HEDI2310
      DO 108   MM = MB, ME                                              HEDI2320
      J = J + 2
      KC = KLIST(MM)                                                    HEDI2340
      CALL NTOL(2, OBANK(J-1), JTABLE(6,KC))
 108  CONTINUE                                                          HEDI2430
      GO TO (110, 116), NRT                                             HEDI2440
 110  WRITE (NOT,9110)(IBANK(MM), MM=1,5),(OBANK(MM), MM=6,J)
C	CHANGE 3A4 TO 3A5 IN NEXT STATEMENT FOR PDP-10
 9110    FORMAT(20H0WEIGHTING FUNCTION    I2, 1X 3A5, 13H. PARAMETERS   HEDI2460
     1I4, 2(2H,   F9.4), 2X 9HTRACKS    6(2A1,4X)/(61X,10(2A1,4X)))
 112  IF (LISTG)   1161, 1161, 114                                      HEDI2480
C        EXPERIMENTAL FACILITY REQUEST PRINT OUT                        HEDI2490
  114 OBANK(1) = HLIST(LISTG)                                           HEDI2510
      CALL GENFUN (LISTG,-1)                                            HEDI2520
      DO 1141 K=1,3
 1141 OBANK(K+1) = VAL(K)
      IBANK(5) = NTAPE
      OBANK(6) = HLIST(LISTG+1)
      OBANK(7) = HLIST(LISTG+2)
      J = 7
      MO = KLIST(LISTG + 3)                                             HEDI2590
      NRT = 2                                                           HEDI2600
      IF (MO)   116, 116, 115                                           HEDI2610
 115  MB = LISTG + 4                                                    HEDI2620
      ME = MB + MO - 1                                                  HEDI2630
      GO TO 107                                                         HEDI2640
 116  WRITE (NOT,9118)(IBANK(MM), MM=1,5),(OBANK(MM), MM=6,J)
C	CHANGE 3A4 TO 3A5 IN NEXT STATEMENT FOR PDP-10
 9118 FORMAT(23H0EXPERIMENTAL FUNCTION    I2, 2X 3A5,  10H. TAPE NO.    HEDI2660
     1I3, 12H PARAMETERS   2F9.0,2X 9HTRACKS     6(2A1,4X)/
     2(61X,10(2A1,4X)))
 1161 IF (NRT)   118, 118, 1162                                         HEDI2680
 1162 WRITE (NOT,9008)
  118 WRITE (NOT,9100)
 9100 FORMAT ( 47H THE FOLLOWING HISTOGRAMS HAVE BEEN REQUESTED  / 1H   HEDI2760
     1  48(1H-))
      KH = 0                                                            HEDI2780
      DO 150   K = 1, 100                                               HEDI2790
      IF (KTABLE(1,K))   150, 121, 130                                  HEDI2800
 130  IF (KTABLE(1,K) - 1000)   135, 140, 140                           HEDI2810
 135  KH = KH + 1                                                       HEDI2820
      CALL HISCAP (KH,K)                                                HEDI2830
      GO TO 150                                                         HEDI2840
 140  IF (KTABLE(1,K) - 2000)   142, 146, 146                           HEDI2850
 142  KX = K                                                            HEDI2860
      GO TO 150                                                         HEDI2870
 146  KH = KH + 1                                                       HEDI2880
      WRITE (NOT,9146)KH                                                HEDI2890
 9146 FORMAT (3H0NO I4, 25H TWO DIMENSIONAL PLOT OF   )                 HEDI2900
      CALL HISCAP (0,KX)                                                HEDI2910
      CALL HISCAP (0,K)                                                 HEDI2920
 150  CONTINUE                                                          HEDI2930
 121  WRITE (NOT,9008)                                                  8/17/68
      IF (IRNDM) 123, 123, 122                                          8/17/68
 122  WRITE (NOT,9300) IRNDM                                            8/17/68
 9300 FORMAT ('0THE STARTING VALUE OF RANDOM WAS SET = ' I10)           8/17/68
 123  RETURN                                                            8/17/68
      END                                                               HEDI2960
      SUBROUTINE HISCAP (KH, K)
CHISCAP*2  SUBROUTINE FOR HISTOGRAM CAPTION PRINT-OUT -- ALSO LISTS ALL
C       CARD PARAMETERS -- EXTRA CARD PARAMETER VERSION
C     K IS HISTOGRAM NUMBER                                             HISC0030
C	EXTENSIVE CHANGES MADE FOR PDP-10  LDK 12/69
C     ************************ COMMON COMMON ***************************
      COMMON    MAP(2000),PARS(1000),MISC(27),KLIST(500),MTABLE(2)
      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    KTABLE(7,100), OBANK(90)
      DIMENSION PARA(1000),NPARA(1000),SNAME(1000),TABLE(100)
      DIMENSION    HEAD(11), NBRNCH(10),HTABLE(7,100)
      DIMENSION HLIST(500)
      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  (KTABLE,MAP), (OBANK,MAP(1779))                      HISC0360
      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,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  (LTAPE,NBRNCH(9)), (LINK,NBRNCH(10)), (HTABLE,MAP)
      EQUIVALENCE (HLIST,KLIST)
C     ************************* END OF C, D, E STATEMENTS **************HISC0340
      DIMENSION FMT(70), F1(3),F2(3),F3(8),F4(4),F5(5),F6(8)
	DATA F1/'(3H0NOI4,4H OF '/
	DATA F2/'(11X,3A5, 3X   '/
	DATA F3/'3H ( 3H ) 1H,  I6,  F7.3,E13.6,    /26X '/
	DATA F4/'3A5,2A1,2(2A5,2X),  '/
	DATA F5/'(2A1,4X)/(71X10(2A1,4X)))'/
	DATA F6/'(9X12HIF FUNCTION 3A5,1X )    6H OF     '/
	EQUIVALENCE  (BLANKS,F6(8))
      DIMENSION CMS(10), WGHTED(2), TRKLST(2)
	DATA CMS/'IN THE LABORATOR    Y    E CMS OF  IN CMS AT VERT '/
      DATA WGHTED/' ,WEIGHTED'/, TRKLST/'TRACK LIST'/
C                                                                       HISC0370
      NRT = 1
      NBR = 1                                                           HISC0380
      IF (KH .LE. 0) NBR = 2
      KK = MOD(KTABLE(1,K), 1000)                                       HISC0420
      MC = IABS(KTABLE(4,K))                                            HISC0430
      IQFLAG = 1
      IF (KTABLE(4,K)) 31, 32, 32
   31 IDOWN = MOD(MC,1000)
      MC = MC/1000
      IQFLAG = 2
   32 IF (KK - 100)   95, 70, 70
 70   KK = KK - 90                                                      HISC0450
      MC = MC + 1                                                       HISC0460
 95   MO = KLIST(MC)                                                    HISC0470
      ML = MC + 1                                                       HISC0480
      ME = MC + MO                                                      HISC0490
      ICMS = ME
      IF (KK .GT. 10) ME = ME-1
      CALL NAME (K, OBANK(1))                                           HISC0500
      IK = 4
      GO TO (110,96), IQFLAG
C     STORE CARD PARAMETERS IN OBANK
  96  IDOWN = MC + IDOWN
      IUP = ME
      ME = IDOWN - 1                                                    12/28/67
      DO 98  IJ = IDOWN,IUP
      OBANK(IK) = HLIST(IJ)
   98 IK = IK + 1
  110 OBANK(IK) = CMS(1)
      IF (KK - 10)   111, 111, 115                                      HISC0510
C        LABORATORY PLOT                                                HISC0520
  111 DO 112 I=2,5
      IJ = IK+I-1
  112 OBANK(IJ) = CMS(I)
      GO TO 135                                                         HISC0590
 115  IF (KK - 20)   117, 117, 118                                      HISC0600
C        PARTICLE REST FRAME PLOT                                       HISC0610
  117 OBANK(IK+1) = CMS(6)
      OBANK(IK+2) = CMS(7)
C        GET TRACK NAME                                                 HISC0660
      KC = KLIST(ICMS)
      IF (KC)   135, 135, 1173
 1173 CALL NTOL(2, OBANK(IK+3), JTABLE(6,KC))
      GO TO 135                                                         HISC0810
C        NORMAL CMS PLOT                                                HISC0820
  118 OBANK(IK) = CMS(8)
      OBANK(IK+1) = CMS(9)
      OBANK(IK+2) = CMS(10)
      OBANK(IK+3) = BLANKS
C        GET VERTEX NAME                                                HISC0860
 120  KC = KLIST(ICMS)
      IF (KC)   135, 135, 128
  128 CALL NTOL(1, OBANK(IK+4), JTABLE(7,KC))
  135 IK = IK + 5
C        CHECK FOR WEIGHT REQUEST                                       HISC1090
      IF (KTABLE(5,K))   140, 150, 150
140	OBANK(IK) = WGHTED(1)
	IK = IK + 1
	OBANK(IK) = WGHTED(2)
	GO TO 160
150	OBANK(IK) = BLANKS
	IK = IK + 1
	OBANK(IK) = BLANKS
160	IK = IK + 1
      IF (ME - ML)   180, 165, 165                                      HISC1270
165	OBANK(IK) = TRKLST(1)
	IK = IK + 1
	OBANK(IK) = TRKLST(2)
	IK = IK + 1
      DO 170   MM = ML,ME
      KC = KLIST (MM)                                                   HISC1290
      CALL NTOL(2, OBANK(IK), JTABLE(6,KC))
  170 IK = IK+2
  180 JE = IK-1
C     COMPILE FORMAT ARRAY
190	FMT(1) = F2(1)
	IK = 2
	GO TO (200,210),NBR
200	DO 201 I=1,3
201	FMT(I) = F1(I)
	IK = 4
210	FMT(IK) = F2(2)
	IK = IK + 1
	FMT(IK) = F2(3)
      GO TO (270, 240),IQFLAG
  240 NPOS = 104
C     FORMAT CARD PARAMETERS
  250 FMT(IK) = F3(1)
      IK = IK+1
      DO 260 IJ=IDOWN,IUP
  251 IF (KLIST(IJ).GT.999999 .OR. KLIST(IJ).LT.-99999) GO TO 254
  252 NPOS = NPOS -7                                                    12/29/67
      IF (NPOS) 257, 253, 253                                           12/29/67
  253 FMT(IK) = F3(4)
      GO TO 259                                                         12/29/67
  254 IF  (HLIST(IJ).GE.999.9995 .OR.  HLIST(IJ).LE.-99.9995 .OR.
     1     ABS(HLIST(IJ)).LT.0.001)  GO TO 2545
      NPOS = NPOS - 8
      IF (NPOS) 257, 255, 255                                           12/29/67
  255 FMT(IK) = F3(5)
      GO TO 259
 2545 NPOS = NPOS-14
      IF (NPOS) 257,256, 256                                            12/29/67
  256 FMT(IK) = F3(7)
      FMT(IK+1) = F3(8)
      IK = IK+1
      GO TO 259                                                         12/29/67
  257 FMT(IK) = F3(9)
      NPOS = 104
      IK = IK + 1                                                       12/29/67
      GO TO 251                                                         12/29/67
  259 FMT(IK+1) = F3(3)
  260 IK = IK + 2
      FMT(IK - 1) = F3(2)
  269 GO TO (261,430),NRT
  261 IF (NPOS-49) 264, 262, 262
  262 L = (NPOS-43)/6
      GO TO 280
  264 FMT(IK) = F3(8)
  270 IK = IK+1
      L = 10
  280 DO 284 I=1,4
      FMT(IK) = F4(I)
  284 IK = IK+1
      FMT(IK) = BCDW(L)
      IK = IK+1
      DO 286 I=1,5
      FMT(IK) = F5(I)
  286 IK = IK+1
      GO TO (298,292),NBR
  292 WRITE (NOT,FMT) (OBANK(MM), MM =1,JE)
      GO TO 299
  298 WRITE (NOT,FMT) KH, (OBANK(MM),MM = 1,JE)
  299 IF (KTABLE(3,K))   300, 500, 300
C        NOTE CONDITIONAL REQUEST                                       HISC1480
  300 NFK = IABS(KTABLE(3,K))
      NRT = 2
      IQFLAG = 1
      IF (KTABLE(3,K)) 303,304,304
  303 IDOWN = MOD(NFK,1000)
      NFK = NFK/1000
      IQFLAG = 2
  304 NFN = KLIST(NFK)                                                  HISC1500
      CALL GENFUN (NFK, -1)                                             HISC1510
      DO 305 I=1,3
  305 OBANK(I) = VAL(I)
      IK = 4
      MO = KLIST(NFK + 1)                                               HISC1520
      ML = NFK + 2
      ME = NFK + MO + 1
      GO TO (340,320), IQFLAG
C	PICK UP PARAMETERS
  320 IDOWN = NFK + IDOWN + 1
      IUP = ME
      ME = IDOWN -1
      DO 335 IJ = IDOWN, IUP
      OBANK(IK) = HLIST(IJ)
  335 IK = IK + 1
  340 IF (ME-ML) 390, 350, 350
C	PICK UP TRACK LABELS
  350 DO 360 MM = ML,ME
      KC = KLIST(MM)
      CALL NTOL(2, OBANK(IK), JTABLE(6,KC))
  360 IK = IK+2
C	COMPILE FORMAT
  390 JE = IK-1
  420 DO 425 I=1,5
  425 FMT(I) = F6(I)
      IK = 6
      NPOS = 93
      GO TO (430,250), IQFLAG
  430 IF (ME-ML) 435,440,440
  435 FMT(IK) = F6(6)
      GO TO 490
  440 IF (NPOS-12) 450, 445, 445
  445 L = NPOS/6 - 1
      GO TO 460
  450 FMT(IK) = F3(8)
      IK = IK+1
      L=15
  460 FMT(IK) = F6(7)
      FMT(IK+1) = F6(8)
      FMT(IK+2) = BCDW(L)
      IK = IK+3
      DO 470 I=1,5
      FMT(IK) = F5(I)
  470 IK = IK+1
  490 WRITE (NOT,FMT) (OBANK(MM),MM=1,JE)
  500 RETURN
      END
      SUBROUTINE NAME (KK, OBANK)
CNAME    RETURNS NAME OF HISTOGRAM KK IN OBANK(1-3)
C     ************************* COMMON COMMON **************************    0030
      COMMON    MAP(2000),PARS(1000),MISC(27),KLIST(500),MTABLE(2)
      DIMENSION ZMAP(2000)                                              NBOD0110
      DIMENSION REMARK(500)
      DIMENSION PARA(1000),NPARA(1000),SNAME(1000),LNAME(1000)
      DIMENSION    KTABLE(7,100), OBANK(90), VAL(100)                       0060
      EQUIVALENCE (MAP,ZMAP)                                            NBOD0340
      EQUIVALENCE (REMARK,MAP(1001))
      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,MAP), (VAL,MAP(1531))                            0160
      EQUIVALENCE (PARA,NPARA,PARS),(SNAME,LNAME,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 STATEMENTS ****************    0140
      DIMENSION HNAME(3,9)
      DATA HNAME      /'PROD. ANGLE    MOMENTUM       RELATIVE ANGLE INV
     1ARIANT MASS PROD. COSINE   RELATIVE COSINEMASS SQUARED   KINETIC E
     2NERGY TOTAL ENERGY   '/
C                                                                           0170
      KA = MOD(KTABLE(1,KK), 1000)                                          0180
      IF (KA - 100)   80, 50, 50
 50   IND = KTABLE(4,KK)                                                    0200
      IF (IND .LT. 0)  IND = -IND/1000
      CALL GENFUN (IND, -1)                                                 0210
      DO 60 I=1,3
 60   OBANK(I) = VAL(I)
      GO TO 100                                                             0240
 80   KC = MOD(KA, 10)
      DO 90 I=1,3
 90   OBANK(I) = HNAME(I,KC)
 100  RETURN                                                                0700
      END                                                                   0710