GEANT321/gheisha/cask0b.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1995/10/24 10:21:01  cernlib
   6 * Geant
   7 *
   8 *
   9 #include "geant321/pilot.h"
  10 *CMZ :  3.21/02 29/03/94  15.41.39  by  S.Giani
  11 *-- Author :
  12       SUBROUTINE CASK0B(K,INT,NFL)
  13 C
  14 C *** CASCADE OF ANTI K0 ***
  15 C *** NVE 04-MAY-1988 CERN GENEVA ***
  16 C
  17 C ORIGIN : H.FESEFELDT (13-SEP-1987)
  18 C
  19 C K0B UNDERGOES INTERACTION WITH NUCLEON WITHIN NUCLEUS.
  20 C CHECK IF ENERGETICALLY POSSIBLE TO PRODUCE PIONS/KAONS.
  21 C IF NOT ASSUME NUCLEAR EXCITATION OCCURS AND INPUT PARTICLE
  22 C IS DEGRADED IN ENERGY.    NO OTHER PARTICLES PRODUCED.
  23 C IF REACTION IS POSSIBLE FIND CORRECT NUMBER OF PIONS/PROTONS/
  24 C NEUTRONS PRODUCED USING AN INTERPOLATION TO MULTIPLICITY DATA.
  25 C REPLACE SOME PIONS OR PROTONS/NEUTRONS BY KAONS OR STRANGE BARYONS
  26 C ACCORDING TO AVERAGE MULTIPLICITY PER INELASTIC REACTIONS.
  27 C
  28 #include "geant321/mxgkgh.inc"
  29 #include "geant321/s_consts.inc"
  30 #include "geant321/s_curpar.inc"
  31 #include "geant321/s_result.inc"
  32 #include "geant321/s_prntfl.inc"
  33 #include "geant321/s_kginit.inc"
  34 #include "geant321/limits.inc"
  35 C
  36       REAL N
  37       DIMENSION PMUL(2,1200),ANORM(2,60),CECH(10),CNK0(20),PIY1(4),
  38      $          PIY2(3),IPIY1(2,4),IPIY2(2,3),IPIY3(2,3),B(2)
  39       DIMENSION RNDM(1)
  40       SAVE PMUL,ANORM
  41       DATA CECH/1.,1.,1.,0.70,0.60,0.55,0.35,0.25,0.18,0.15/
  42       DATA CNK0/0.17,0.18,0.17,0.24,0.26,0.20,0.22,0.21,0.34,0.45
  43      $         ,0.58,0.55,0.36,0.29,0.29,0.32,0.32,0.33,0.33,0.33/
  44       DATA PIY1/0.67,0.78,0.89,1.00/,PIY2/0.68,0.84,1.00/
  45       DATA IPIY1/8,18,9,20,8,21,7,22/
  46       DATA IPIY2/9,18,9,21,8,22/,IPIY3/7,18,8,20,7,21/
  47       DATA B/0.7,0.7/,C/1.25/
  48 C
  49 C --- INITIALIZATION INDICATED BY KGINIT(7) ---
  50       IF (KGINIT(7) .NE. 0) GO TO 10
  51       KGINIT(7)=1
  52 C
  53 C --- INITIALIZE PMUL AND ANORM ARRAYS ---
  54       DO 9000 J=1,1200
  55       DO 9001 I=1,2
  56       PMUL(I,J)=0.0
  57       IF (J .LE. 60) ANORM(I,J)=0.0
  58  9001 CONTINUE
  59  9000 CONTINUE
  60 C
  61 C** COMPUTE NORMALIZATION CONSTANTS
  62 C** FOR P AS TARGET
  63 C
  64       L=0
  65       DO 1 NP1=1,20
  66       NP=NP1-1
  67       NMM1=NP1-2
  68       IF(NMM1.LE.1) NMM1=1
  69       DO 1 NM1=NMM1,NP1
  70       NM=NM1-1
  71       DO 1 NZ1=1,20
  72       NZ=NZ1-1
  73       L=L+1
  74       IF(L.GT.1200) GOTO 1
  75       NT=NP+NM+NZ
  76       IF(NT.LE.0.OR.NT.GT.60) GOTO 1
  77       PMUL(1,L)=PMLTPC(NP,NM,NZ,NT,B(1),C)
  78       ANORM(1,NT)=ANORM(1,NT)+PMUL(1,L)
  79     1 CONTINUE
  80 C** FOR N AS TARGET
  81       L=0
  82       DO 2 NP1=1,20
  83       NP=NP1-1
  84       NMM1=NP1-1
  85       IF(NMM1.LT.1) NMM1=1
  86       NPP1=NP1+1
  87       DO 2 NM1=NMM1,NPP1
  88       NM=NM1-1
  89       DO 2 NZ1=1,20
  90       NZ=NZ1-1
  91       L=L+1
  92       IF(L.GT.1200) GOTO 2
  93       NT=NP+NM+NZ
  94       IF(NT.LE.0.OR.NT.GT.60) GOTO 2
  95       PMUL(2,L)=PMLTPC(NP,NM,NZ,NT,B(2),C)
  96       ANORM(2,NT)=ANORM(2,NT)+PMUL(2,L)
  97     2 CONTINUE
  98       DO 3 I=1,60
  99       IF(ANORM(1,I).GT.0.) ANORM(1,I)=1./ANORM(1,I)
 100       IF(ANORM(2,I).GT.0.) ANORM(2,I)=1./ANORM(2,I)
 101     3 CONTINUE
 102       IF(.NOT.NPRT(10)) GOTO 10
 103       WRITE(NEWBCD,2001)
 104       DO 4 NFL=1,2
 105       WRITE(NEWBCD,2002) NFL
 106       WRITE(NEWBCD,2003) (ANORM(NFL,I),I=1,60)
 107       WRITE(NEWBCD,2003) (PMUL(NFL,I),I=1,1200)
 108     4 CONTINUE
 109 C**  CHOOSE PROTON OR NEUTRON AS TARGET
 110    10 NFL=2
 111       CALL GRNDM(RNDM,1)
 112       IF(RNDM(1).LT.ZNO2/ATNO2) NFL=1
 113       TARMAS=RMASS(14)
 114       IF (NFL .EQ. 2) TARMAS=RMASS(16)
 115       S=AMASQ+TARMAS**2+2.0*TARMAS*EN
 116       RS=SQRT(S)
 117       ENP(8)=AMASQ+TARMAS**2+2.0*TARMAS*ENP(6)
 118       ENP(9)=SQRT(ENP(8))
 119       EAB=RS-TARMAS-ABS(RMASS(12))
 120 C
 121 C**  ELASTIC SCATTERING
 122       NP=0
 123       NM=0
 124       NZ=0
 125       N=0.
 126       IPA(1)=12
 127       IPA(2)=14
 128       IF(NFL.EQ.2) IPA(2)=16
 129       IF(INT.EQ.2) GOTO 20
 130       GOTO 100
 131 C**  CHECK IF ENERGETICALLY POSSIBLE TO PRODUCE ONE EXTRA PION IN REACT.
 132    20 IPLAB=IFIX(P*5.)+1
 133       IF(IPLAB.GT.10) GOTO 22
 134       CALL GRNDM(RNDM,1)
 135       IF(RNDM(1).LT.CECH(IPLAB)) GOTO 19
 136       IF (EAB .LT. RMASS(7)) GOTO 55
 137       GOTO 22
 138 C** CHARGE EXCHANGE REACTION (IS INCLUDED IN INELASTIC CROSS SECTION)
 139    19 IPLAB=IFIX(P*10.)+1
 140       IF(IPLAB.GT.20) IPLAB=20
 141       CALL GRNDM(RNDM,1)
 142       IF(RNDM(1).GT.CNK0(IPLAB)) GOTO 24
 143       IF(NFL.EQ.2) GOTO 23
 144 C** FOR K0B P REACTION NO K N STRANGENESS EXCHANGE POSSIBLE
 145       INT=1
 146       IPA(1)=12
 147       IPA(2)=14
 148       GOTO 100
 149    23 INT=1
 150       IPA(1)=13
 151       IPA(2)=14
 152       GOTO 100
 153 C** P L, P S REACTIONS
 154    24 CALL GRNDM(RNDM,1)
 155       RAN=RNDM(1)
 156       IF(RAN.LT.0.25) GOTO 25
 157       IF(RAN.LT.0.50) GOTO 26
 158       IF(RAN.LT.0.75) GOTO 27
 159 C** K0B P --> PI+ L OR K0B N --> PI0 L
 160       IPA(1)=7
 161       IF(NFL.EQ.2) IPA(1)=8
 162       IPA(2)=18
 163       GOTO 100
 164 C** K0B N --> PI- S+
 165    25 IPA(1)=9
 166       IPA(2)=20
 167       IF(NFL.EQ.2) GOTO 100
 168       IPA(1)=12
 169       IPA(2)=14
 170       GOTO 100
 171 C** K0B P --> PI+ S0  OR K0B N --> PI0 S0
 172    26 IPA(1)=7
 173       IF(NFL.EQ.2) IPA(1)=8
 174       IPA(2)=21
 175       GOTO 100
 176 C** K0B N --> PI+ S-
 177    27 IPA(1)=7
 178       IPA(2)=22
 179       IF(NFL.EQ.2) GOTO 100
 180       IPA(1)=12
 181       IPA(2)=14
 182       GOTO 100
 183 C
 184    22 ALEAB=LOG(EAB)
 185 C** NO. OF TOTAL PARTICLES VS SQRT(S)-2*MP
 186       N=3.62567+0.665843*ALEAB+0.336514*ALEAB*ALEAB
 187      * +0.117712*ALEAB*ALEAB*ALEAB+0.0136912*ALEAB*ALEAB*ALEAB*ALEAB
 188       N=N-2.
 189 C** NORMALIZATION CONSTANT FOR  KNO-DISTRIBUTION
 190       ANPN=0.
 191       DO 21 NT=1,60
 192       TEST=-(PI/4.0)*(NT/N)**2
 193       IF (TEST .LT. EXPXL) TEST=EXPXL
 194       IF (TEST .GT. EXPXU) TEST=EXPXU
 195       DUM1=PI*NT/(2.0*N*N)
 196       DUM2=ABS(DUM1)
 197       DUM3=EXP(TEST)
 198       ADDNVE=0.0
 199       IF (DUM2 .GE. 1) ADDNVE=DUM1*DUM3
 200       IF ((DUM2 .LT. 1) .AND. (DUM3 .GE. 1.0E-10)) ADDNVE=DUM1*DUM3
 201       ANPN=ANPN+ADDNVE
 202    21 CONTINUE
 203       ANPN=1./ANPN
 204 C** P OR N AS TARGET
 205       CALL GRNDM(RNDM,1)
 206       RAN=RNDM(1)
 207       EXCS=0.
 208       GOTO (30,40),NFL
 209 C** FOR P AS TARGET
 210    30 L=0
 211       DO 31 NP1=1,20
 212       NP=NP1-1
 213       NMM1=NP1-2
 214       IF(NMM1.LE.1) NMM1=1
 215       DO 31 NM1=NMM1,NP1
 216       NM=NM1-1
 217       DO 31 NZ1=1,20
 218       NZ=NZ1-1
 219       L=L+1
 220       IF(L.GT.1200) GOTO 31
 221       NT=NP+NM+NZ
 222       IF(NT.LE.0.OR.NT.GT.60) GOTO 31
 223       TEST=-(PI/4.0)*(NT/N)**2
 224       IF (TEST .LT. EXPXL) TEST=EXPXL
 225       IF (TEST .GT. EXPXU) TEST=EXPXU
 226       DUM1=ANPN*PI*NT*PMUL(1,L)*ANORM(1,NT)/(2.0*N*N)
 227       DUM2=ABS(DUM1)
 228       DUM3=EXP(TEST)
 229       ADDNVE=0.0
 230       IF (DUM2 .GE. 1) ADDNVE=DUM1*DUM3
 231       IF ((DUM2 .LT. 1) .AND. (DUM3 .GE. 1.0E-10)) ADDNVE=DUM1*DUM3
 232       EXCS=EXCS+ADDNVE
 233       IF(RAN.LT.EXCS) GOTO 50
 234    31 CONTINUE
 235       GOTO 80
 236 C** FOR N AS TARGET
 237    40 L=0
 238       DO 41 NP1=1,20
 239       NP=NP1-1
 240       NMM1=NP1-1
 241       IF(NMM1.LT.1) NMM1=1
 242       NPP1=NP1+1
 243       DO 41 NM1=NMM1,NPP1
 244       NM=NM1-1
 245       DO 41 NZ1=1,20
 246       NZ=NZ1-1
 247       L=L+1
 248       IF(L.GT.1200) GOTO 41
 249       NT=NP+NM+NZ
 250       IF(NT.LE.0.OR.NT.GT.60) GOTO 41
 251       TEST=-(PI/4.0)*(NT/N)**2
 252       IF (TEST .LT. EXPXL) TEST=EXPXL
 253       IF (TEST .GT. EXPXU) TEST=EXPXU
 254       DUM1=ANPN*PI*NT*PMUL(2,L)*ANORM(2,NT)/(2.0*N*N)
 255       DUM2=ABS(DUM1)
 256       DUM3=EXP(TEST)
 257       ADDNVE=0.0
 258       IF (DUM2 .GE. 1) ADDNVE=DUM1*DUM3
 259       IF ((DUM2 .LT. 1) .AND. (DUM3 .GE. 1.0E-10)) ADDNVE=DUM1*DUM3
 260       EXCS=EXCS+ADDNVE
 261       IF(RAN.LT.EXCS) GOTO 50
 262    41 CONTINUE
 263       GOTO 80
 264    50 GOTO (65,60),NFL
 265    60 IF(NP.EQ.NM) GOTO 61
 266       IF(NP.EQ.1+NM) GOTO 63
 267       IPA(1)=12
 268       IPA(2)=14
 269       GOTO 90
 270    61 CALL GRNDM(RNDM,1)
 271       IF(RNDM(1).LT.0.75) GOTO 62
 272       IPA(1)=13
 273       IPA(2)=14
 274       GOTO 90
 275    62 IPA(1)=13
 276       IPA(2)=14
 277       GOTO 90
 278    63 IPA(1)=13
 279       IPA(2)=16
 280       GOTO 90
 281    65 IF(NP.EQ.1+NM) GOTO 66
 282       IF(NP.EQ.NM) GOTO 68
 283       IPA(1)=13
 284       IPA(2)=16
 285       GOTO 90
 286    66 CALL GRNDM(RNDM,1)
 287       IF(RNDM(1).LT.0.50) GOTO 67
 288       IPA(1)=12
 289       IPA(2)=16
 290       GOTO 90
 291    67 IPA(1)=13
 292       IPA(2)=14
 293       GOTO 90
 294    68 IPA(1)=12
 295       IPA(2)=14
 296 C**  PI Y PRODUCTION INSTEAD OF K N
 297    90 CALL GRNDM(RNDM,1)
 298       IF(RNDM(1).LT.0.5) GOTO 100
 299       IF(IPA(1).EQ.13.AND.IPA(2).EQ.16) GOTO 95
 300       IF(IPA(1).EQ.11.AND.IPA(2).EQ.14) GOTO 95
 301       IF(IPA(1).EQ.12.AND.IPA(2).EQ.14) GOTO 95
 302       CALL GRNDM(RNDM,1)
 303       RAN=RNDM(1)
 304       DO 91 I=1,4
 305       IF(RAN.LT.PIY1(I)) GOTO 92
 306    91 CONTINUE
 307       GOTO 100
 308    92 IPA(1)=IPIY1(1,I)
 309       IPA(2)=IPIY1(2,I)
 310       GOTO 100
 311    95 CALL GRNDM(RNDM,1)
 312       RAN=RNDM(1)
 313       DO 96 I=1,3
 314       IF(RAN.LT.PIY2(I)) GOTO 97
 315    96 CONTINUE
 316       GOTO 100
 317    97 IF(IPA(2).EQ.14) GOTO 98
 318       IPA(1)=IPIY2(1,I)
 319       IPA(2)=IPIY2(2,I)
 320       GOTO 100
 321    98 IPA(1)=IPIY3(1,I)
 322       IPA(2)=IPIY3(2,I)
 323       GOTO 100
 324    70 IF(NPRT(4))
 325      *WRITE(NEWBCD,1003) EAB,N,NFL,NP,NM,NZ
 326       CALL STPAIR
 327       IF(INT.EQ.1) CALL TWOB(12,NFL,N)
 328       IF(INT.EQ.2) CALL GENXPT(12,NFL,N)
 329       GO TO 9999
 330 C** NUCLEAR EXCITATION
 331    55 IF(NPRT(4))
 332      *WRITE(NEWBCD,1001)
 333       GOTO 53
 334 C** EXCLUSIVE REACTION NOT FOUND
 335    80 IF(NPRT(4))
 336      *WRITE(NEWBCD,1004) RS,N
 337    53 INT=1
 338       NP=0
 339       NM=0
 340       NZ=0
 341       N=0.
 342       IPA(1)=12
 343       IPA(2)=14
 344       IF(NFL.EQ.2) IPA(2)=16
 345   100 DO 101 I=3,60
 346   101 IPA(I)=0
 347       IF(INT.LE.0) GOTO 131
 348   120 NT=2
 349       IF(NP.EQ.0) GOTO 122
 350       DO 121 I=1,NP
 351       NT=NT+1
 352   121 IPA(NT)=7
 353   122 IF(NM.EQ.0) GOTO 124
 354       DO 123 I=1,NM
 355       NT=NT+1
 356   123 IPA(NT)=9
 357   124 IF(NZ.EQ.0) GOTO 130
 358       DO 125 I=1,NZ
 359       NT=NT+1
 360   125 IPA(NT)=8
 361   130 IF(NPRT(4))
 362      *WRITE(NEWBCD,2004) NT,(IPA(I),I=1,20)
 363       DO 132 I=1,NT
 364       IF(IPA(I).NE.12) GOTO 132
 365       CALL GRNDM(RNDM,1)
 366       IF(RNDM(1).LT.0.5) GOTO 132
 367       IPA(I)=11
 368   132 CONTINUE
 369       GOTO 70
 370   131 IF(NPRT(4))
 371      *WRITE(NEWBCD,2005)
 372 C
 373 1001  FORMAT('0*CASK0B* CASCADE ENERGETICALLY NOT POSSIBLE',
 374      $ ' CONTINUE WITH QUASI-ELASTIC SCATTERING')
 375 1003  FORMAT(' *CASK0B* K0B -INDUCED CASCADE,',
 376      $ ' AVAIL. ENERGY',2X,F8.4,
 377      $ 2X,'<NTOT>',2X,F8.4,2X,'FROM',4(2X,I3),2X,'PARTICLES')
 378 1004  FORMAT(' *CASK0B* K0B -INDUCED CASCADE,',
 379      $ ' EXCLUSIVE REACTION NOT FOUND',
 380      $ ' TRY ELASTIC SCATTERING  AVAIL. ENERGY',2X,F8.4,2X,
 381      $ '<NTOT>',2X,F8.4)
 382 2001  FORMAT('0*CASK0B* TABLES FOR MULT. DATA K0B  INDUCED REACTION',
 383      $ ' FOR DEFINITION OF NUMBERS SEE FORTRAN CODING')
 384 2002  FORMAT(' *CASK0B* TARGET PARTICLE FLAG',2X,I5)
 385 2003  FORMAT(1H ,10E12.4)
 386 2004  FORMAT(' *CASK0B* ',I3,2X,'PARTICLES , MASS INDEX ARRAY',2X,20I4)
 387 2005  FORMAT(' *CASK0B* NO PARTICLES PRODUCED')
 388 C
 389  9999 CONTINUE
 390       END