CalorimeterLevel2/src/cluster2.for

C----------------------------------------------------------------------
      SUBROUTINE CLUSTER2
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : IT WORKS AS CLUSTER BUT USING TWO PARTS OF THE
C-   CALORIMETER (LAYERS 1 - 4 AND LAYERS 5 - 8) INSTEAD OF THE 8
C-   LAYERS .
C-
C-   Created   25-FEB-1995   MIRKO BOEZIO
C-   Modified  30-MAR-1995   MIRKO BOEZIO . CORRECTED AN ERROR IN THE
C-             DEFINITION OF THE TWO PARTS , OTHERWISE IT WAS LAYERS 1 - 5 AND
C-             LAYERS 6 - 8 .
C-
C----------------------------------------------------------------------
      INCLUDE 'INTEST.TXT'
      REAL QQQ(NCHA)

C
      DO J = 1,2
        DO N = 1,2
          DO M = 1,NCHA
            CLUS2(N,J,M) = 0.
          ENDDO
          NCL2(N,J) = 0
        ENDDO
      ENDDO
C
      LPIANO = NPLA / 2
C
      DO N = 1,2
        DO J = 1,2
          DO M = 1,NCHA
            QQQ(M) = 0.
            DO L = 1,NPLA
              EN = DEXY(N,L,M)
              IF (EN.GT.EMIN.AND.J.EQ.1.AND.L.LE.LPIANO) THEN
                QQQ(M) = QQQ(M) + EN
              ENDIF
              IF (EN.GT.EMIN.AND.J.EQ.2.AND.L.GT.LPIANO) THEN
                QQQ(M) = QQQ(M) + EN
              ENDIF
            ENDDO
          ENDDO
C
          IGIRO = 0.
C
   50     CONTINUE
          MAX = LVMAX(QQQ,NCHA)
          IF (QQQ(MAX).LT.EMIN) GO TO 100
          MSTR = MAX
   55     CONTINUE
          MSTR = MSTR + 1
          IF (MSTR.GT.NCHA) GO TO 56
          IF (QQQ(MSTR).GT.EMIN) GO TO 55
   56     CONTINUE
          IB = MSTR - 1
C
          MSTR = MAX
   65     CONTINUE
          MSTR = MSTR - 1
          IF (MSTR.LT.1) GO TO 66
          IF (QQQ(MSTR).GT.EMIN) GO TO 65
   66     CONTINUE
          IA = MSTR + 1
C
          CALL BARIC(QQQ,IA,IB,BAR,ENE,IERR1)
          IGIRO = IGIRO + 1
          IGI = IGIRO + NCHA / 2
          CLUS2(N,J,IGIRO) = BAR
          CLUS2(N,J,IGI) = ENE
C
          DO LL = IA,IB
            QQQ(LL) = 0.
          ENDDO
          GO TO 50
C
  100     CONTINUE
          NCL2(N,J) = IGIRO
        ENDDO
      ENDDO
C
      RETURN
      END

1	C----------------------------------------------------------------------
2	SUBROUTINE CLUSTER2
3	C----------------------------------------------------------------------
4	C-
5	C- Purpose and Methods : IT WORKS AS CLUSTER BUT USING TWO PARTS OF THE
6	C- CALORIMETER (LAYERS 1 - 4 AND LAYERS 5 - 8) INSTEAD OF THE 8
7	C- LAYERS .
8	C-
9	C- Created 25-FEB-1995 MIRKO BOEZIO
10	C- Modified 30-MAR-1995 MIRKO BOEZIO . CORRECTED AN ERROR IN THE
11	C- DEFINITION OF THE TWO PARTS , OTHERWISE IT WAS LAYERS 1 - 5 AND
12	C- LAYERS 6 - 8 .
13	C-
14	C----------------------------------------------------------------------
15	INCLUDE 'INTEST.TXT'
16	REAL QQQ(NCHA)
17
18	C
19	DO J = 1,2
20	DO N = 1,2
21	DO M = 1,NCHA
22	CLUS2(N,J,M) = 0.
23	ENDDO
24	NCL2(N,J) = 0
25	ENDDO
26	ENDDO
27	C
28	LPIANO = NPLA / 2
29	C
30	DO N = 1,2
31	DO J = 1,2
32	DO M = 1,NCHA
33	QQQ(M) = 0.
34	DO L = 1,NPLA
35	EN = DEXY(N,L,M)
36	IF (EN.GT.EMIN.AND.J.EQ.1.AND.L.LE.LPIANO) THEN
37	QQQ(M) = QQQ(M) + EN
38	ENDIF
39	IF (EN.GT.EMIN.AND.J.EQ.2.AND.L.GT.LPIANO) THEN
40	QQQ(M) = QQQ(M) + EN
41	ENDIF
42	ENDDO
43	ENDDO
44	C
45	IGIRO = 0.
46	C
47	50 CONTINUE
48	MAX = LVMAX(QQQ,NCHA)
49	IF (QQQ(MAX).LT.EMIN) GO TO 100
50	MSTR = MAX
51	55 CONTINUE
52	MSTR = MSTR + 1
53	IF (MSTR.GT.NCHA) GO TO 56
54	IF (QQQ(MSTR).GT.EMIN) GO TO 55
55	56 CONTINUE
56	IB = MSTR - 1
57	C
58	MSTR = MAX
59	65 CONTINUE
60	MSTR = MSTR - 1
61	IF (MSTR.LT.1) GO TO 66
62	IF (QQQ(MSTR).GT.EMIN) GO TO 65
63	66 CONTINUE
64	IA = MSTR + 1
65	C
66	CALL BARIC(QQQ,IA,IB,BAR,ENE,IERR1)
67	IGIRO = IGIRO + 1
68	IGI = IGIRO + NCHA / 2
69	CLUS2(N,J,IGIRO) = BAR
70	CLUS2(N,J,IGI) = ENE
71	C
72	DO LL = IA,IB
73	QQQ(LL) = 0.
74	ENDDO
75	GO TO 50
76	C
77	100 CONTINUE
78	NCL2(N,J) = IGIRO
79	ENDDO
80	ENDDO
81	C
82	RETURN
83	END
84