GEANT321/gheisha/caskm.F

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