HERWIG/src/hwures.f

   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,6*0,55,67,79,34,35,36,6*0,54,66,78,38,41,42,6*0,58,70,
  61
  62      & 82,36,38,39,6*0,56,68,80,39,42,43,6*0,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(ETAMIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
 301
 302         ELSEIF (J.EQ.25 ) THEN
 303
 304           WT=SIN(ETAMIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
 305
 306 C phi - omega
 307
 308         ELSEIF (J.EQ.56 ) THEN
 309
 310           WT=COS(PHIMIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
 311
 312         ELSEIF (J.EQ.24 ) THEN
 313
 314           WT=SIN(PHIMIX*PIFAC/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(PH3MIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
 357
 358         ELSEIF (J.EQ.395) THEN
 359
 360           WT=SIN(PH3MIX*PIFAC/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(ET2MIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
 367
 368         ELSEIF (J.EQ.398) THEN
 369
 370           WT=SIN(ET2MIX*PIFAC/180.+ATAN(SQRT(TWO)))**2
 371
 372 C MISSING - omega(1600)
 373
 374         ELSEIF (J.EQ.399) THEN
 375
 376           WT=SIN(OMHMIX*PIFAC/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*(TWO*RSPIN(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)*(TWO*RSPIN(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