[u/mrichter/AliRoot.git] / HERWIG / src / hwures.f


CDECK  ID>, HWURES.

*CMZ :-        -26/04/91  11.11.56  by  Bryan Webber

*-- Author :    Ian Knowles & Bryan Webber

C-----------------------------------------------------------------------

      SUBROUTINE HWURES

C-----------------------------------------------------------------------

C     Using properties of particle I supplied in HWUDAT checks particles

C     and antiparticles have compatible properties and sets   SWTEF(I) =

C     ( rep. enhancement factor)^2  - used in cluster decays

C     Finds iso-flavour hadrons and creates pointers for cluster decays.

C     Sets CLDKWT(K) =(2J+1) spin weight normalizing largest value to 1.

C-----------------------------------------------------------------------

      INCLUDE 'HERWIG61.INC'

      INTEGER NMXTMP

      PARAMETER (NMXTMP=20)

      DOUBLE PRECISION EPS,WTMX,REMMN,RWTMX,WTMP,RESTMP(91),WTMX2,

     & REMMN2,WT,CDWTMP(NMXTMP)

      INTEGER HWUANT,MAPF(89),MAPC(12,12),I,IANT,IABPDG,J,L,N,K,LTMP,

     & NCDKS,IMN,ITMP,LOCTMP(91),NTMP,NCDTMP(NMXTMP),IMN2

      EXTERNAL HWUANT

      PARAMETER (EPS=1.D-6)

      DATA MAPF/21,31,41,51,61,12,32,42,52,62,13,23,43,53,63,14,24,34,

     & 44,54,64,15,25,35,45,55,65,16,26,36,46,56,66,111,112,113,122,123,

     & 133,222,223,233,333,-111,-112,-113,-122,-123,-133,-222,-223,-233,

     & -333,114,124,134,224,234,334,-114,-124,-134,-224,-234,-334,115,

     & 125,135,225,235,335,-115,-125,-135,-225,-235,-335,116,126,136,

     & 226,236,336,-116,-126,-136,-226,-236,-336/

      DATA MAPC/90,1,2,47,45,44,48,46,49,3,4,5,6,90,7,50,47,45,51,48,52,

     & 8,9,10,11,12,91,51,48,46,52,49,53,13,14,15,37,40,41,6*0,57,69,81,

     & 35,37,38,6*0,55,67,79,34,35,36,6*0,54,66,78,38,41,42,6*0,58,70,

     & 82,36,38,39,6*0,56,68,80,39,42,43,6*0,59,71,83,16,17,18,63,61,60,

     & 64,62,65,19,20,21,22,23,24,75,73,72,76,74,77,25,26,27,28,29,30,

     & 87,85,84,88,86,89,31,32,33/

C Check particle/anti-particle properties are compatible

      WRITE(6,10)

  10  FORMAT(/10X,'Checking consistency of particle properties'/)

      DO 20 I=10,NRES

      IF (IDPDG(I).GT.0) THEN

        IANT=HWUANT(I)

        IF (IANT.EQ.20) GOTO 20

        IF (MOD(IDPDG(I)/1000,10).EQ.0.AND.

     &      MOD(IDPDG(I)/100 ,10).NE.0) THEN

          IF (MOD(IFLAV(I)/10-IFLAV(IANT),10).NE.0.OR.

     &        MOD(IFLAV(I)-IFLAV(IANT)/10,10).NE.0)

     &     WRITE(6,30) RNAME(I),IFLAV(I),IFLAV(IANT)

        ELSE

          IF (IFLAV(I)+IFLAV(IANT).NE.0)

     &     WRITE(6,30) RNAME(I),IFLAV(I),IFLAV(IANT)

        ENDIF

        IF (ICHRG(I)+ICHRG(IANT).NE.0)

     &   WRITE(6,40) RNAME(I),RNAME(IANT),ICHRG(I),ICHRG(IANT)

        IF (ABS(RMASS(I)-RMASS(IANT)).GT.EPS)

     &   WRITE(6,50) RNAME(I),RMASS(I),RMASS(IANT)

        IF (ABS(RLTIM(I)-RLTIM(IANT)).GT.EPS)

     &   WRITE(6,60) RNAME(I),RLTIM(I),RLTIM(IANT)

        IF (ABS(RSPIN(I)-RSPIN(IANT)).GT.EPS)

     &   WRITE(6,70) RNAME(I),RSPIN(I),RSPIN(IANT)

      ENDIF

  20  CONTINUE

  30  FORMAT(10X,A8,' flavour code=',I4,5X,' antiparticle=',I4)

  40  FORMAT(10X,2A8,' charge      =',I2,7X,' antiparticle=',I2)

  50  FORMAT(10X,A8,' mass        =',F7.3,2X,' antiparticle=',F7.3)

  60  FORMAT(10X,A8,' life time   =',E9.3,' antiparticle=',E9.3)

  70  FORMAT(10X,A8,' spin        =',F3.1,6X,' antiparticle=',F3.1)

C Compute resonance properties

      DO 80 I=21,NRES

C Compute representation weights for hadrons, used in cluster decays

      IABPDG=ABS(IDPDG(I))

      J=MOD(IABPDG,10)

      IF (J.EQ.2.AND.MOD(IABPDG/100,10).LT.MOD(IABPDG/10,10)) THEN

C Singlet (Lambda-like) baryon

        SWTEF(I)=SNGWT**2

      ELSEIF (J.EQ.4) THEN

C Decuplet baryon

        SWTEF(I)=DECWT**2

      ELSEIF(2*(J/2).NE.J) THEN

C Mesons: identify by spin, angular momentum & radial excitation

        J=(J-1)/2

        L= MOD(IABPDG/10000 ,10)

        N= MOD(IABPDG/100000,10)

        IF (L.EQ.0.AND.J.EQ.0.AND.N.EQ.0.OR.

     &      L.GT.3.OR. J.GT.4.OR .N.GT.4) THEN

          SWTEF(I)=1.

        ELSE

          SWTEF(I)=REPWT(L,J,N)**2

        ENDIF

      ELSE

C Not recognized

        SWTEF(I)=1.

      ENDIF

  80  CONTINUE

C Prepare tables for cluster decays, except flavourless light mesons

      LTMP=1

      NCDKS=0

      DO 120 I=1,89

C Store particles, flavour MAPF(I), noting highest spin and lowest mass

      WTMX=0.

      REMMN=1000.

      DO 90 J=21,NRES

      IF (VTOCDK(J).OR.IFLAV(J).NE.MAPF(I)) GOTO 90

      NCDKS=NCDKS+1

      IF (NCDKS.GT.NMXCDK) CALL HWWARN('HWURES',101,*999)

      NCLDK(NCDKS)=J

      CLDKWT(NCDKS)=TWO*RSPIN(J)+ONE

      IF (CLDKWT(NCDKS).GT.WTMX) WTMX=CLDKWT(NCDKS)

      IF (RMASS(J).LT.REMMN) THEN

        REMMN=RMASS(J)

        IMN=NCDKS

      ENDIF

  90  CONTINUE

      IF (NCDKS+1-LTMP.EQ.0) THEN

        WRITE(6,100) MAPF(I)

  100   FORMAT(1X,'No particles exist for a cluster with flavour, ',I4,

     &            ' to decay into')

        CALL HWWARN('HWURES',51,*120)

      ENDIF

C Set scaled spin weights

      RWTMX=1./WTMX

      DO 110 J=LTMP,NCDKS

  110 CLDKWT(J)=CLDKWT(J)*RWTMX

C Swap order if lightest hadron of given flavour not first

      IF (IMN.NE.LTMP) THEN

        ITMP=NCLDK(LTMP)

        WTMP=CLDKWT(LTMP)

        NCLDK(LTMP)=NCLDK(IMN)

        CLDKWT(LTMP)=CLDKWT(IMN)

        NCLDK(IMN)=ITMP

        CLDKWT(IMN)=WTMP

      ENDIF

C Set pointers etc

      LOCTMP(I)=LTMP

      RESTMP(I)=FLOAT(NCDKS+1-LTMP)

      LTMP=NCDKS+1

  120 CONTINUE

C Now do flavourless light mesons, allowing for mixing in weights

      WTMX=0.

      REMMN=1000.

      WTMX2=0.

      REMMN2=1000.

      NTMP=0

      DO 140 J=21,NRES

      IF (VTOCDK(J)) THEN

        GOTO 140

C Calculate mixing weight for (|uubar>+|ddbar>)/sqrt(2) component

      ELSEIF (IFLAV(J).EQ.11) THEN

        WT=1.

      ELSEIF (IFLAV(J).EQ.33) THEN

C eta - eta'

        IF     (J.EQ.22 ) THEN

          WT=COS(ETAMIX*PIFAC/180.+ATAN(SQRT(TWO)))**2

        ELSEIF (J.EQ.25 ) THEN

          WT=SIN(ETAMIX*PIFAC/180.+ATAN(SQRT(TWO)))**2

C phi - omega

        ELSEIF (J.EQ.56 ) THEN

          WT=COS(PHIMIX*PIFAC/180.+ATAN(SQRT(TWO)))**2

        ELSEIF (J.EQ.24 ) THEN

          WT=SIN(PHIMIX*PIFAC/180.+ATAN(SQRT(TWO)))**2

C f'_2 - f_2

        ELSEIF (J.EQ.58 ) THEN

          WT=COS(F2MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2

        ELSEIF (J.EQ.26 ) THEN

          WT=SIN(F2MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2

C f_1(1420) - f_1(1285)

        ELSEIF (J.EQ.57 ) THEN

          WT=COS(F1MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2

        ELSEIF (J.EQ.28 ) THEN

          WT=SIN(F1MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2

C h_1(1380) - h_1(1170)

        ELSEIF (J.EQ.289) THEN

          WT=COS(H1MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2

        ELSEIF (J.EQ.288) THEN

          WT=SIN(H1MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2

C MISSING - f_0(1370)

        ELSEIF (J.EQ.294) THEN

          WT=SIN(F0MIX *PIFAC/180.+ATAN(SQRT(TWO)))**2

C phi_3 - omega_3

        ELSEIF (J.EQ.396) THEN

          WT=COS(PH3MIX*PIFAC/180.+ATAN(SQRT(TWO)))**2

        ELSEIF (J.EQ.395) THEN

          WT=SIN(PH3MIX*PIFAC/180.+ATAN(SQRT(TWO)))**2

C eta_2(1645) - eta_2(1870)

        ELSEIF (J.EQ.397) THEN

          WT=COS(ET2MIX*PIFAC/180.+ATAN(SQRT(TWO)))**2

        ELSEIF (J.EQ.398) THEN

          WT=SIN(ET2MIX*PIFAC/180.+ATAN(SQRT(TWO)))**2

C MISSING - omega(1600)

        ELSEIF (J.EQ.399) THEN

          WT=SIN(OMHMIX*PIFAC/180.+ATAN(SQRT(TWO)))**2

        ELSE

          WT=1./3.

          WRITE(6,130) J

  130   FORMAT(1X,'Isoscalar particle ',I3,' not recognised,',

     &            ' no I=0 mixing assumed')

        ENDIF

      ELSE

        GOTO 140

      ENDIF

      IF (WT.GT.EPS) THEN

        NCDKS=NCDKS+1

        IF (NCDKS.GT.NMXCDK) CALL HWWARN('HWURES',102,*999)

        NCLDK(NCDKS)=J

        CLDKWT(NCDKS)=WT*(TWO*RSPIN(J)+ONE)

        IF (CLDKWT(NCDKS).GT.WTMX) WTMX=CLDKWT(NCDKS)

        IF (RMASS(J).LT.REMMN) THEN

          REMMN=RMASS(J)

          IMN=NCDKS

        ENDIF

      ENDIF

      IF (ONE-WT.GT.EPS) THEN

        NTMP=NTMP+1

        IF (NTMP.GT.NMXTMP) CALL HWWARN('HWURES',103,*999)

        NCDTMP(NTMP)=J

        CDWTMP(NTMP)=(ONE-WT)*(TWO*RSPIN(J)+ONE)

        IF (CDWTMP(NTMP).GT.WTMX2) WTMX2=CDWTMP(NTMP)

        IF (RMASS(J).LT.REMMN2) THEN

          REMMN2=RMASS(J)

          IMN2=NTMP

        ENDIF

      ENDIF

  140 CONTINUE

      IF (NCDKS+1-LTMP.EQ.0) THEN

        WRITE(6,100) 11

        CALL HWWARN('HWURES',52,*160)

      ENDIF

C Normalize scaled spin weights

      RWTMX=1./WTMX

      DO 150 I=LTMP,NCDKS

  150 CLDKWT(I)=CLDKWT(I)*RWTMX

C Swap order if lightest hadron of flavour 11 not first

      IF (IMN.NE.LTMP) THEN

        ITMP=NCLDK(LTMP)

        WTMP=CLDKWT(LTMP)

        NCLDK(LTMP)=NCLDK(IMN)

        CLDKWT(LTMP)=CLDKWT(IMN)

        NCLDK(IMN)=ITMP

        CLDKWT(IMN)=WTMP

      ENDIF

  160 IF (NTMP.EQ.0) THEN

        WRITE(6,100) 33

        CALL HWWARN('HWURES',53,*180)

      ENDIF

      IF (NCDKS+NTMP.GT.NMXCDK) CALL HWWARN('HWURES',104,*999)

C Store hadrons for |ssbar> channel and normalize their weights

      RWTMX=1./WTMX2

      DO 170 I=1,NTMP

      J=NCDKS+I

      NCLDK(J)=NCDTMP(I)

  170 CLDKWT(J)=CDWTMP(I)*RWTMX

C Swap order if lightest hadron of flavour 33 not first

      IF (IMN2.NE.1) THEN

        ITMP=NCLDK(NCDKS+1)

        WTMP=CLDKWT(NCDKS+1)

        NCLDK(NCDKS+1)=NCLDK(NCDKS+IMN2)

        CLDKWT(NCDKS+1)=CLDKWT(NCDKS+IMN2)

        NCLDK(NCDKS+IMN2)=ITMP

        CLDKWT(NCDKS+IMN2)=WTMP

      ENDIF

C Set pointers etc

  180 LOCTMP(90)=LTMP

      RESTMP(90)=FLOAT(NCDKS+1-LTMP)

      LOCTMP(91)=NCDKS+1

      RESTMP(91)=FLOAT(NTMP)

C Set pointers to hadrons of given flavours for cluster decays

      DO 190 I=1,12

      DO 190 J=1,12

      K=MAPC(I,J)

      IF (K.EQ.0) THEN

        RMIN(I,J)=RMASS(NCLDK(LOCN(I,2)))+RMASS(NCLDK(LOCN(I,2)))+1.D-2

      ELSE

        LOCN(I,J)=LOCTMP(K)

        RESN(I,J)=RESTMP(K)

        RMIN(I,J)=RMASS(NCLDK(LOCN(I,J)))

      ENDIF

  190 CONTINUE

  999 END

CDECK  ID>, HWUROB.

*CMZ :-        -26/04/91  11.11.56  by  Bryan Webber

*-- Author :    Bryan Webber

C-----------------------------------------------------------------------

      SUBROUTINE HWUROB(R,P,Q)

C-----------------------------------------------------------------------

C     ROTATES VECTORS BY INVERSE OF ROTATION MATRIX R

C-----------------------------------------------------------------------

      DOUBLE PRECISION S1,S2,S3,R(3,3),P(3),Q(3)

      S1=P(1)*R(1,1)+P(2)*R(2,1)+P(3)*R(3,1)

      S2=P(1)*R(1,2)+P(2)*R(2,2)+P(3)*R(3,2)

      S3=P(1)*R(1,3)+P(2)*R(2,3)+P(3)*R(3,3)

      Q(1)=S1

      Q(2)=S2

      Q(3)=S3

      END
Commit	Line	Data
3820ca8e	1
	2	CDECK ID>, HWURES.
	3
	4	*CMZ :- -26/04/91 11.11.56 by Bryan Webber
	5
	6	*-- Author : Ian Knowles & Bryan Webber
	7
	8	C-----------------------------------------------------------------------
	9
	10	SUBROUTINE HWURES
	11
	12	C-----------------------------------------------------------------------
	13
	14	C Using properties of particle I supplied in HWUDAT checks particles
	15
	16	C and antiparticles have compatible properties and sets SWTEF(I) =
	17
	18	C ( rep. enhancement factor)^2 - used in cluster decays
	19
	20	C Finds iso-flavour hadrons and creates pointers for cluster decays.
	21
	22	C Sets CLDKWT(K) =(2J+1) spin weight normalizing largest value to 1.
	23
	24	C-----------------------------------------------------------------------
	25
	26	INCLUDE 'HERWIG61.INC'
	27
	28	INTEGER NMXTMP
	29
	30	PARAMETER (NMXTMP=20)
	31
	32	DOUBLE PRECISION EPS,WTMX,REMMN,RWTMX,WTMP,RESTMP(91),WTMX2,
	33
	34	& REMMN2,WT,CDWTMP(NMXTMP)
	35
	36	INTEGER HWUANT,MAPF(89),MAPC(12,12),I,IANT,IABPDG,J,L,N,K,LTMP,
	37
	38	& NCDKS,IMN,ITMP,LOCTMP(91),NTMP,NCDTMP(NMXTMP),IMN2
	39
	40	EXTERNAL HWUANT
	41
	42	PARAMETER (EPS=1.D-6)
	43
	44	DATA MAPF/21,31,41,51,61,12,32,42,52,62,13,23,43,53,63,14,24,34,
	45
	46	& 44,54,64,15,25,35,45,55,65,16,26,36,46,56,66,111,112,113,122,123,
	47
	48	& 133,222,223,233,333,-111,-112,-113,-122,-123,-133,-222,-223,-233,
	49
	50	& -333,114,124,134,224,234,334,-114,-124,-134,-224,-234,-334,115,
	51
	52	& 125,135,225,235,335,-115,-125,-135,-225,-235,-335,116,126,136,
	53
	54	& 226,236,336,-116,-126,-136,-226,-236,-336/
	55
	56	DATA MAPC/90,1,2,47,45,44,48,46,49,3,4,5,6,90,7,50,47,45,51,48,52,
	57
	58	& 8,9,10,11,12,91,51,48,46,52,49,53,13,14,15,37,40,41,6*0,57,69,81,
	59
	60	& 35,37,38,60,55,67,79,34,35,36,60,54,66,78,38,41,42,6*0,58,70,
	61
	62	& 82,36,38,39,60,56,68,80,39,42,43,60,59,71,83,16,17,18,63,61,60,
	63
	64	& 64,62,65,19,20,21,22,23,24,75,73,72,76,74,77,25,26,27,28,29,30,
65
66	& 87,85,84,88,86,89,31,32,33/
67
68	C Check particle/anti-particle properties are compatible
69
70	WRITE(6,10)
71
72	10 FORMAT(/10X,'Checking consistency of particle properties'/)
73
74	DO 20 I=10,NRES
75
76	IF (IDPDG(I).GT.0) THEN
77
78	IANT=HWUANT(I)
79
80	IF (IANT.EQ.20) GOTO 20
81
82	IF (MOD(IDPDG(I)/1000,10).EQ.0.AND.
83
84	& MOD(IDPDG(I)/100 ,10).NE.0) THEN
85
86	IF (MOD(IFLAV(I)/10-IFLAV(IANT),10).NE.0.OR.
87
88	& MOD(IFLAV(I)-IFLAV(IANT)/10,10).NE.0)
89
90	& WRITE(6,30) RNAME(I),IFLAV(I),IFLAV(IANT)
91
92	ELSE
93
94	IF (IFLAV(I)+IFLAV(IANT).NE.0)
95
96	& WRITE(6,30) RNAME(I),IFLAV(I),IFLAV(IANT)
97
98	ENDIF
99
100	IF (ICHRG(I)+ICHRG(IANT).NE.0)
101
102	& WRITE(6,40) RNAME(I),RNAME(IANT),ICHRG(I),ICHRG(IANT)
103
104	IF (ABS(RMASS(I)-RMASS(IANT)).GT.EPS)
105
106	& WRITE(6,50) RNAME(I),RMASS(I),RMASS(IANT)
107
108	IF (ABS(RLTIM(I)-RLTIM(IANT)).GT.EPS)
109
110	& WRITE(6,60) RNAME(I),RLTIM(I),RLTIM(IANT)
111
112	IF (ABS(RSPIN(I)-RSPIN(IANT)).GT.EPS)
113
114	& WRITE(6,70) RNAME(I),RSPIN(I),RSPIN(IANT)
115
116	ENDIF
117
118	20 CONTINUE
119
120	30 FORMAT(10X,A8,' flavour code=',I4,5X,' antiparticle=',I4)
121
122	40 FORMAT(10X,2A8,' charge =',I2,7X,' antiparticle=',I2)
123
124	50 FORMAT(10X,A8,' mass =',F7.3,2X,' antiparticle=',F7.3)
125
126	60 FORMAT(10X,A8,' life time =',E9.3,' antiparticle=',E9.3)
127
128	70 FORMAT(10X,A8,' spin =',F3.1,6X,' antiparticle=',F3.1)
129
130	C Compute resonance properties
131
132	DO 80 I=21,NRES
133
134	C Compute representation weights for hadrons, used in cluster decays
135
136	IABPDG=ABS(IDPDG(I))
137
138	J=MOD(IABPDG,10)
139
140	IF (J.EQ.2.AND.MOD(IABPDG/100,10).LT.MOD(IABPDG/10,10)) THEN
141
142	C Singlet (Lambda-like) baryon
143
144	SWTEF(I)=SNGWT**2
145
146	ELSEIF (J.EQ.4) THEN
147
148	C Decuplet baryon
149
150	SWTEF(I)=DECWT**2
151
152	ELSEIF(2*(J/2).NE.J) THEN
153
154	C Mesons: identify by spin, angular momentum & radial excitation
155
156	J=(J-1)/2
157
158	L= MOD(IABPDG/10000 ,10)
159
160	N= MOD(IABPDG/100000,10)
161
162	IF (L.EQ.0.AND.J.EQ.0.AND.N.EQ.0.OR.
163
164	& L.GT.3.OR. J.GT.4.OR .N.GT.4) THEN
165
166	SWTEF(I)=1.
167
168	ELSE
169
170	SWTEF(I)=REPWT(L,J,N)**2
171
172	ENDIF
173
174	ELSE
175
176	C Not recognized
177
178	SWTEF(I)=1.
179
180	ENDIF
181
182	80 CONTINUE
183
184	C Prepare tables for cluster decays, except flavourless light mesons
185
186	LTMP=1
187
188	NCDKS=0
189
190	DO 120 I=1,89
191
192	C Store particles, flavour MAPF(I), noting highest spin and lowest mass
193
194	WTMX=0.
195
196	REMMN=1000.
197
198	DO 90 J=21,NRES
199
200	IF (VTOCDK(J).OR.IFLAV(J).NE.MAPF(I)) GOTO 90
201
202	NCDKS=NCDKS+1
203
204	IF (NCDKS.GT.NMXCDK) CALL HWWARN('HWURES',101,*999)
205
206	NCLDK(NCDKS)=J
207
208	CLDKWT(NCDKS)=TWO*RSPIN(J)+ONE
209
210	IF (CLDKWT(NCDKS).GT.WTMX) WTMX=CLDKWT(NCDKS)
211
212	IF (RMASS(J).LT.REMMN) THEN
213
214	REMMN=RMASS(J)
215
216	IMN=NCDKS
217
218	ENDIF
219
220	90 CONTINUE
221
222	IF (NCDKS+1-LTMP.EQ.0) THEN
223
224	WRITE(6,100) MAPF(I)
225
226	100 FORMAT(1X,'No particles exist for a cluster with flavour, ',I4,
227
228	& ' to decay into')
229
230	CALL HWWARN('HWURES',51,*120)
231
232	ENDIF
233
234	C Set scaled spin weights
235
236	RWTMX=1./WTMX
237
238	DO 110 J=LTMP,NCDKS
239
240	110 CLDKWT(J)=CLDKWT(J)*RWTMX
241
242	C Swap order if lightest hadron of given flavour not first
243
244	IF (IMN.NE.LTMP) THEN
245
246	ITMP=NCLDK(LTMP)
247
248	WTMP=CLDKWT(LTMP)
249
250	NCLDK(LTMP)=NCLDK(IMN)
251
252	CLDKWT(LTMP)=CLDKWT(IMN)
253
254	NCLDK(IMN)=ITMP
255
256	CLDKWT(IMN)=WTMP
257
258	ENDIF
259
260	C Set pointers etc
261
262	LOCTMP(I)=LTMP
263
264	RESTMP(I)=FLOAT(NCDKS+1-LTMP)
265
266	LTMP=NCDKS+1
267
268	120 CONTINUE
269
270	C Now do flavourless light mesons, allowing for mixing in weights
271
272	WTMX=0.
273
274	REMMN=1000.
275
276	WTMX2=0.
277
278	REMMN2=1000.
279
280	NTMP=0
281
282	DO 140 J=21,NRES
283
284	IF (VTOCDK(J)) THEN
285
286	GOTO 140
287
288	C Calculate mixing weight for (\|uubar>+\|ddbar>)/sqrt(2) component
289
290	ELSEIF (IFLAV(J).EQ.11) THEN
291
292	WT=1.
293
294	ELSEIF (IFLAV(J).EQ.33) THEN
295
296	C eta - eta'
297
298	IF (J.EQ.22 ) THEN
299
300	WT=COS(ETAMIXPIFAC/180.+ATAN(SQRT(TWO)))*2
301
302	ELSEIF (J.EQ.25 ) THEN
303
304	WT=SIN(ETAMIXPIFAC/180.+ATAN(SQRT(TWO)))*2
305
306	C phi - omega
307
308	ELSEIF (J.EQ.56 ) THEN
309
310	WT=COS(PHIMIXPIFAC/180.+ATAN(SQRT(TWO)))*2
311
312	ELSEIF (J.EQ.24 ) THEN
313
314	WT=SIN(PHIMIXPIFAC/180.+ATAN(SQRT(TWO)))*2
315
316	C f'_2 - f_2
317
318	ELSEIF (J.EQ.58 ) THEN
319
320	WT=COS(F2MIX PIFAC/180.+ATAN(SQRT(TWO)))*2
321
322	ELSEIF (J.EQ.26 ) THEN
323
324	WT=SIN(F2MIX PIFAC/180.+ATAN(SQRT(TWO)))*2
325
326	C f_1(1420) - f_1(1285)
327
328	ELSEIF (J.EQ.57 ) THEN
329
330	WT=COS(F1MIX PIFAC/180.+ATAN(SQRT(TWO)))*2
331
332	ELSEIF (J.EQ.28 ) THEN
333
334	WT=SIN(F1MIX PIFAC/180.+ATAN(SQRT(TWO)))*2
335
336	C h_1(1380) - h_1(1170)
337
338	ELSEIF (J.EQ.289) THEN
339
340	WT=COS(H1MIX PIFAC/180.+ATAN(SQRT(TWO)))*2
341
342	ELSEIF (J.EQ.288) THEN
343
344	WT=SIN(H1MIX PIFAC/180.+ATAN(SQRT(TWO)))*2
345
346	C MISSING - f_0(1370)
347
348	ELSEIF (J.EQ.294) THEN
349
350	WT=SIN(F0MIX PIFAC/180.+ATAN(SQRT(TWO)))*2
351
352	C phi_3 - omega_3
353
354	ELSEIF (J.EQ.396) THEN
355
356	WT=COS(PH3MIXPIFAC/180.+ATAN(SQRT(TWO)))*2
357
358	ELSEIF (J.EQ.395) THEN
359
360	WT=SIN(PH3MIXPIFAC/180.+ATAN(SQRT(TWO)))*2
361
362	C eta_2(1645) - eta_2(1870)
363
364	ELSEIF (J.EQ.397) THEN
365
366	WT=COS(ET2MIXPIFAC/180.+ATAN(SQRT(TWO)))*2
367
368	ELSEIF (J.EQ.398) THEN
369
370	WT=SIN(ET2MIXPIFAC/180.+ATAN(SQRT(TWO)))*2
371
372	C MISSING - omega(1600)
373
374	ELSEIF (J.EQ.399) THEN
375
376	WT=SIN(OMHMIXPIFAC/180.+ATAN(SQRT(TWO)))*2
377
378	ELSE
379
380	WT=1./3.
381
382	WRITE(6,130) J
383
384	130 FORMAT(1X,'Isoscalar particle ',I3,' not recognised,',
385
386	& ' no I=0 mixing assumed')
387
388	ENDIF
389
390	ELSE
391
392	GOTO 140
393
394	ENDIF
395
396	IF (WT.GT.EPS) THEN
397
398	NCDKS=NCDKS+1
399
400	IF (NCDKS.GT.NMXCDK) CALL HWWARN('HWURES',102,*999)
401
402	NCLDK(NCDKS)=J
403
404	CLDKWT(NCDKS)=WT(TWORSPIN(J)+ONE)
405
406	IF (CLDKWT(NCDKS).GT.WTMX) WTMX=CLDKWT(NCDKS)
407
408	IF (RMASS(J).LT.REMMN) THEN
409
410	REMMN=RMASS(J)
411
412	IMN=NCDKS
413
414	ENDIF
415
416	ENDIF
417
418	IF (ONE-WT.GT.EPS) THEN
419
420	NTMP=NTMP+1
421
422	IF (NTMP.GT.NMXTMP) CALL HWWARN('HWURES',103,*999)
423
424	NCDTMP(NTMP)=J
425
426	CDWTMP(NTMP)=(ONE-WT)(TWORSPIN(J)+ONE)
427
428	IF (CDWTMP(NTMP).GT.WTMX2) WTMX2=CDWTMP(NTMP)
429
430	IF (RMASS(J).LT.REMMN2) THEN
431
432	REMMN2=RMASS(J)
433
434	IMN2=NTMP
435
436	ENDIF
437
438	ENDIF
439
440	140 CONTINUE
441
442	IF (NCDKS+1-LTMP.EQ.0) THEN
443
444	WRITE(6,100) 11
445
446	CALL HWWARN('HWURES',52,*160)
447
448	ENDIF
449
450	C Normalize scaled spin weights
451
452	RWTMX=1./WTMX
453
454	DO 150 I=LTMP,NCDKS
455
456	150 CLDKWT(I)=CLDKWT(I)*RWTMX
457
458	C Swap order if lightest hadron of flavour 11 not first
459
460	IF (IMN.NE.LTMP) THEN
461
462	ITMP=NCLDK(LTMP)
463
464	WTMP=CLDKWT(LTMP)
465
466	NCLDK(LTMP)=NCLDK(IMN)
467
468	CLDKWT(LTMP)=CLDKWT(IMN)
469
470	NCLDK(IMN)=ITMP
471
472	CLDKWT(IMN)=WTMP
473
474	ENDIF
475
476	160 IF (NTMP.EQ.0) THEN
477
478	WRITE(6,100) 33
479
480	CALL HWWARN('HWURES',53,*180)
481
482	ENDIF
483
484	IF (NCDKS+NTMP.GT.NMXCDK) CALL HWWARN('HWURES',104,*999)
485
486	C Store hadrons for \|ssbar> channel and normalize their weights
487
488	RWTMX=1./WTMX2
489
490	DO 170 I=1,NTMP
491
492	J=NCDKS+I
493
494	NCLDK(J)=NCDTMP(I)
495
496	170 CLDKWT(J)=CDWTMP(I)*RWTMX
497
498	C Swap order if lightest hadron of flavour 33 not first
499
500	IF (IMN2.NE.1) THEN
501
502	ITMP=NCLDK(NCDKS+1)
503
504	WTMP=CLDKWT(NCDKS+1)
505
506	NCLDK(NCDKS+1)=NCLDK(NCDKS+IMN2)
507
508	CLDKWT(NCDKS+1)=CLDKWT(NCDKS+IMN2)
509
510	NCLDK(NCDKS+IMN2)=ITMP
511
512	CLDKWT(NCDKS+IMN2)=WTMP
513
514	ENDIF
515
516	C Set pointers etc
517
518	180 LOCTMP(90)=LTMP
519
520	RESTMP(90)=FLOAT(NCDKS+1-LTMP)
521
522	LOCTMP(91)=NCDKS+1
523
524	RESTMP(91)=FLOAT(NTMP)
525
526	C Set pointers to hadrons of given flavours for cluster decays
527
528	DO 190 I=1,12
529
530	DO 190 J=1,12
531
532	K=MAPC(I,J)
533
534	IF (K.EQ.0) THEN
535
536	RMIN(I,J)=RMASS(NCLDK(LOCN(I,2)))+RMASS(NCLDK(LOCN(I,2)))+1.D-2
537
538	ELSE
539
540	LOCN(I,J)=LOCTMP(K)
541
542	RESN(I,J)=RESTMP(K)
543
544	RMIN(I,J)=RMASS(NCLDK(LOCN(I,J)))
545
546	ENDIF
547
548	190 CONTINUE
549
550	999 END
551
552	CDECK ID>, HWUROB.
553
554	*CMZ :- -26/04/91 11.11.56 by Bryan Webber
555
556	*-- Author : Bryan Webber
557
558	C-----------------------------------------------------------------------
559
560	SUBROUTINE HWUROB(R,P,Q)
561
562	C-----------------------------------------------------------------------
563
564	C ROTATES VECTORS BY INVERSE OF ROTATION MATRIX R
565
566	C-----------------------------------------------------------------------
567
568	DOUBLE PRECISION S1,S2,S3,R(3,3),P(3),Q(3)
569
570	S1=P(1)R(1,1)+P(2)R(2,1)+P(3)*R(3,1)
571
572	S2=P(1)R(1,2)+P(2)R(2,2)+P(3)*R(3,2)
573
574	S3=P(1)R(1,3)+P(2)R(2,3)+P(3)*R(3,3)
575
576	Q(1)=S1
577
578	Q(2)=S2
579
580	Q(3)=S3
581
582	END