*CMZ : 05/03/2002 08.29.07 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C====================================================================== PROGRAM AAMAIN C----------------------------------------------------------------------- C MAIN PROGRAM C C SIMULATION OF EXTENSIVE AIR SHOWERS C PREPARES INITIALIZATIONS C GENERATES SHOWERS IN THE SHOWER LOOP C TREATES PARTICLES IN THE PARTICLE LOOP C PERFORMS PRINTING OF TABLES AT END OF SHOWER AND AT END OF RUN C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) c-----changed--add c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> parameter (xct=1) parameter (yct=2) parameter (zct=3) parameter (ctthet=4) parameter (ctphi=5) parameter (ctdiam=6) parameter (ctfoc=7) c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> c-----changed--add *KEEP,ATMOS2. COMMON /ATMOS2/ HLAY,HLAY0,THICKL,LAYNO,LAYNEW DOUBLE PRECISION HLAY(6),HLAY0(5,0:4),THICKL(5) INTEGER LAYNO(0:16) LOGICAL LAYNEW,flag c-----changed--add logical fmfb c-----changed--add *KEEP,BUFFS. COMMON /BUFFS/ RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH INTEGER MAXBUF,MAXLEN PARAMETER (MAXLEN=16) PARAMETER (MAXBUF=39*7) REAL RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF), * RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF) INTEGER LH CHARACTER*4 CRUNH,CRUNE,CEVTH,CEVTE,CLONG EQUIVALENCE (RUNH(1),CRUNH), (RUNE(1),CRUNE) EQUIVALENCE (EVTH(1),CEVTH), (EVTE(1),CEVTE) EQUIVALENCE (ARRAYLONG(1),CLONG) *KEEP,CHISTA. COMMON /CHISTA/ IHYCHI,IKACHI,IMUCHI,INNCHI,INUCHI,IPICHI INTEGER IHYCHI(124),IKACHI(124),IMUCHI(124), * INNCHI(124),INUCHI(124),IPICHI(124) *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,CURVE. COMMON /CURVE/ CHAPAR,DEP,ERR,NSTP DOUBLE PRECISION CHAPAR(1200),DEP(1200),ERR(1200) INTEGER NSTP *KEEP,ELADPM. COMMON /ELADPM/ ELMEAN,ELMEAA,IELDPM,IELDPA DOUBLE PRECISION ELMEAN(40),ELMEAA(40) INTEGER IELDPM(40,13),IELDPA(40,13) *KEEP,ELASTY. COMMON /ELASTY/ ELAST DOUBLE PRECISION ELAST *KEEP,GENER. COMMON /GENER/ GEN,ALEVEL DOUBLE PRECISION GEN,ALEVEL *KEEP,IRET. COMMON /IRET/ IRET1,IRET2,IRETE INTEGER IRET1,IRET2 LOGICAL IRETE *KEEP,ISTA. COMMON /ISTA/ IFINET,IFINNU,IFINKA,IFINPI,IFINHY INTEGER IFINET,IFINNU,IFINKA,IFINPI,IFINHY *KEEP,LONGI. COMMON /LONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG, * SDLONG,SELONG,SPLONG,THSTEP,THSTPI, * LHEIGH,NSTEP,LLONGI,FLGFIT DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9), * APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9), * HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9), * SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI INTEGER LHEIGH,NSTEP LOGICAL LLONGI,FLGFIT *KEEP,MAGNET. COMMON /MAGNET/ BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT DOUBLE PRECISION BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT *KEEP,MPARTI. COMMON /MPARTI/ MPARTO DOUBLE PRECISION MPARTO(10,25),MPHOTO(10),MPOSIT(10),MELECT(10), * MNU(10),MMUP(10),MMUM(10),MPI0(10),MPIP(10), * MPIM(10),MK0L(10),MKPL(10),MKMI(10),MNEUTR(10), * MPROTO(10),MPROTB(10),MK0S(10),MHYP(10), * MNEUTB(10),MDEUT(10),MTRIT(10),MALPHA(10), * MOTHER(10),MMUOND EQUIVALENCE (MPARTO(1, 1),MPHOTO(1)), (MPARTO(1, 2),MPOSIT(1)), * (MPARTO(1, 3),MELECT(1)), (MPARTO(1, 4),MNU(1)) , * (MPARTO(1, 5),MMUP(1)) , (MPARTO(1, 6),MMUM(1)) , * (MPARTO(1, 7),MPI0(1)) , (MPARTO(1, 8),MPIP(1)) , * (MPARTO(1, 9),MPIM(1)) , (MPARTO(1,10),MK0L(1)) , * (MPARTO(1,11),MKPL(1)) , (MPARTO(1,12),MKMI(1)) , * (MPARTO(1,13),MNEUTR(1)), (MPARTO(1,14),MPROTO(1)), * (MPARTO(1,15),MPROTB(1)), (MPARTO(1,16),MK0S(1)) , * (MPARTO(1,18),MHYP(1)) , (MPARTO(1,19),MDEUT(1)) , * (MPARTO(1,20),MTRIT(1)) , (MPARTO(1,21),MALPHA(1)), * (MPARTO(1,22),MOTHER(1)), (MPARTO(1,25),MNEUTB(1)), * (MPARTO(1,23),MMUOND) *KEEP,MULT. COMMON /MULT/ EKINL,MSMM,MULTMA,MULTOT DOUBLE PRECISION EKINL INTEGER MSMM,MULTMA(40,13),MULTOT(40,13) *KEEP,MUMULT. COMMON /MUMULT/ CHC,OMC,PHISCT,STEPL,VSCAT,FMOLI DOUBLE PRECISION CHC,OMC,PHISCT,STEPL,VSCAT LOGICAL FMOLI *KEEP,MUPART. COMMON /MUPART/ AMUPAR,BCUT,CMUON,FMUBRM,FMUORG DOUBLE PRECISION AMUPAR(16),BCUT,CMUON(11) LOGICAL FMUBRM,FMUORG *KEEP,NCOUNT. COMMON /NCOUNT/ NCOUN INTEGER NCOUN(8) *KEEP,NKGI. COMMON /NKGI/ SEL,SELLG,STH,ZEL,ZELLG,ZSL,DIST, * DISX,DISY,DISXY,DISYX,DLAX,DLAY,DLAXY,DLAYX, * OBSATI,RADNKG,RMOL,TLEV,TLEVCM,IALT DOUBLE PRECISION SEL(10),SELLG(10),STH(10),ZEL(10),ZELLG(10), * ZSL(10),DIST(10), * DISX(-10:10),DISY(-10:10), * DISXY(-10:10,2),DISYX(-10:10,2), * DLAX (-10:10,2),DLAY (-10:10,2), * DLAXY(-10:10,2),DLAYX(-10:10,2), * OBSATI(2),RADNKG,RMOL(2),TLEV(10),TLEVCM(10) INTEGER IALT(2) *KEEP,NKGS. COMMON /NKGS/ CZX,CZY,CZXY,CZYX,SAH,SL,ZNE DOUBLE PRECISION CZX(-10:10,2),CZY(-10:10,2),CZXY(-10:10,2), * CZYX(-10:10,2),SAH(10),SL(10),ZNE(10) *KEEP,NPARTI. COMMON /NPARTI/ NPARTO DOUBLE PRECISION NPARTO(10,25),NPHOTO(10),NPOSIT(10),NELECT(10), * NNU(10),NMUP(10),NMUM(10),NPI0(10),NPIP(10), * NPIM(10),NK0L(10),NKPL(10),NKMI(10),NNEUTR(10), * NPROTO(10),NPROTB(10),NK0S(10),NHYP(10), * NNEUTB(10),NDEUT(10),NTRIT(10),NALPHA(10), * NOTHER(10),NMUOND EQUIVALENCE (NPARTO(1, 1),NPHOTO(1)), (NPARTO(1, 2),NPOSIT(1)), * (NPARTO(1, 3),NELECT(1)), (NPARTO(1, 4),NNU(1)) , * (NPARTO(1, 5),NMUP(1)) , (NPARTO(1, 6),NMUM(1)) , * (NPARTO(1, 7),NPI0(1)) , (NPARTO(1, 8),NPIP(1)) , * (NPARTO(1, 9),NPIM(1)) , (NPARTO(1,10),NK0L(1)) , * (NPARTO(1,11),NKPL(1)) , (NPARTO(1,12),NKMI(1)) , * (NPARTO(1,13),NNEUTR(1)), (NPARTO(1,14),NPROTO(1)), * (NPARTO(1,15),NPROTB(1)), (NPARTO(1,16),NK0S(1)) , * (NPARTO(1,18),NHYP(1)) , (NPARTO(1,19),NDEUT(1)) , * (NPARTO(1,20),NTRIT(1)) , (NPARTO(1,21),NALPHA(1)), * (NPARTO(1,22),NOTHER(1)), (NPARTO(1,25),NNEUTB(1)), * (NPARTO(1,23),NMUOND) *KEEP,OBSPAR. COMMON /OBSPAR/ OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP, * THETPR,PHIPR, * VUECON, * NOBSLV DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10), * HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2) DOUBLE PRECISION VUECON(2) INTEGER NOBSLV *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,PRIMSP. COMMON /PRIMSP/ PSLOPE,LLIMIT,ULIMIT,LL,UL,SLEX,ISPEC DOUBLE PRECISION PSLOPE,LLIMIT,ULIMIT,LL,UL,SLEX INTEGER ISPEC *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RECORD. COMMON /RECORD/ IRECOR INTEGER IRECOR *KEEP,REJECT. COMMON /REJECT/ AVNREJ,ALTMIN,ANEXP,THICKA,THICKD,CUTLN,EONCUT, * FNPRIM DOUBLE PRECISION AVNREJ(10),ALTMIN(10),ANEXP(10),THICKA(10), * THICKD(10),CUTLN,EONCUT LOGICAL FNPRIM *KEEP,RESON. COMMON /RESON/ RDRES,RESRAN,IRESPAR REAL RDRES(2),RESRAN(30000) INTEGER IRESPAR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,SIGM. COMMON /SIGM/ SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO DOUBLE PRECISION SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO *KEEP,STACKF. COMMON /STACKF/ STACK,MSTACKP,MEXST,NSHIFT,NOUREC,ICOUNT, * NTO,NFROM INTEGER MAXSTK PARAMETER (MAXSTK = 16*256*2) DOUBLE PRECISION STACK(MAXSTK) INTEGER MSTACKP,MEXST,NSHIFT,NOUREC,ICOUNT,NTO,NFROM *KEEP,STATI. COMMON /STATI/ SABIN,SBBIN,INBIN,IPBIN,IKBIN,IHBIN DOUBLE PRECISION SABIN(40),SBBIN(40) INTEGER INBIN(40),IPBIN(40),IKBIN(40),IHBIN(40) *KEEP,TABLES. INTEGER IEBIN, ITBIN, IDBIN PARAMETER (IEBIN=40,ITBIN=30,IDBIN=20) COMMON /TABLES/ G_ARRAY, E_ARRAY, M_ARRAY, * EBOFF,EBFAC,TBOFF,TBFAC,DBOFF,DBFAC REAL G_ARRAY(IEBIN,ITBIN,IDBIN) REAL E_ARRAY(IEBIN,ITBIN,IDBIN) REAL M_ARRAY(IEBIN,ITBIN,IDBIN) REAL EBOFF,EBFAC,TBOFF,TBFAC,DBOFF,DBFAC REAL EBMIN,EBMAX,TBMIN,TBMAX,DBMIN,DBMAX PARAMETER (EBMIN=1.E-4,EBMAX=1.E4) PARAMETER (TBMIN=10.,TBMAX=1.E4) PARAMETER (DBMIN=5.E3,DBMAX=5.E5) *KEEP,THNVAR. COMMON /THNVAR/ STACKINT, * INT_ICOUNT,MODETHN,THINNING INTEGER MAXICOUNT PARAMETER (MAXICOUNT=40000) DOUBLE PRECISION STACKINT(16,MAXICOUNT) INTEGER INT_ICOUNT,MODETHN LOGICAL THINNING *KEEP,VERS. COMMON /VERS/ VERNUM,MVDATE,VERDAT DOUBLE PRECISION VERNUM INTEGER MVDATE CHARACTER*18 VERDAT *KEEP,CEREN1. COMMON /CEREN1/ CERELE,CERHAD,ETADSN,WAVLGL,WAVLGU,CYIELD, * CERSIZ,CERNOR,LCERFI DOUBLE PRECISION CERELE,CERHAD,ETADSN,WAVLGL,WAVLGU,CYIELD, * CERSIZ,CERNOR LOGICAL LCERFI *KEEP,CEREN2. COMMON /CEREN2/ ACERX,ACERY,CERXOS,CERYOS, * DCERX,DCERXI,DCERY,DCERYI,EPSX,EPSY,FCERX,FCERY, * WL,XCMAX,XCMAXS,XSCATT,YCMAX,YCMAXS,YSCATT, * PHOTCM,XCER,YCER,UEMIS,VEMIS,WEMIS,CARTIM,ZEMIS, * NCERX,NCERY,ICERML DOUBLE PRECISION ACERX,ACERY,CERXOS(20),CERYOS(20), * DCERX,DCERXI,DCERY,DCERYI,EPSX,EPSY,FCERX,FCERY, * WL,XCMAX,XCMAXS,XSCATT,YCMAX,YCMAXS,YSCATT DOUBLE PRECISION PHOTCM,XCER,YCER,UEMIS,VEMIS,WEMIS,CARTIM,ZEMIS INTEGER NCERX,NCERY,ICERML *KEEP,CEREN3. COMMON /CEREN3/ CERCNT,DATAB2,NRECER,LHCER INTEGER MAXBF2 PARAMETER ( MAXBF2 = 39 * 7 ) DOUBLE PRECISION CERCNT REAL DATAB2(MAXBF2) INTEGER NRECER,LHCER *KEND. c----add -changed c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> *keep,certel. common /certel/ cormxd,cord,coralp,ctpars,omega, + photn,photnp,phpt,pht,vphot, + vchi,veta,vzeta,vchim,vetam,vzetam, + lambda,mu,nu,nctels,ncph,phip1,thetap1 double precision cormxd,cord,coralp,ctpars(20,7),omega(20,3,3), + photn(3),photnp(3),phpt(3),pht,vphot(3), + vchi(3),veta(3),vzeta(3),vchim,vetam,vzetam, + lambda,mu,nu integer nctels,ncph(5) double precision xg,yg,zg,xgp,ygp,zgp,up,vp,wp,xpcut,ypcut,zpcut double precision thetap1,phip1 equivalence (photn(1) ,xg) ,(photn(2) ,yg) ,(photn(3) ,zg) , + (photnp(1),xgp) ,(photnp(2),ygp) ,(photnp(3),zgp), + (phpt(1) ,xpcut),(phpt(2) ,ypcut),(phpt(3) ,zpcut), + (vphot(1) ,up) ,(vphot(2) ,vp) ,(vphot(3) ,wp) c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> c Angles for the "spinning" of a particle around the c main axis of the CT common /spinang/ spinxi double precision spinxi C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> c----add -changed DOUBLE PRECISION JNBIN(40),JPBIN(40),JKBIN(40),JHBIN(40) DOUBLE PRECISION CHI2,FPARAM(6) DOUBLE PRECISION MPART2(10,25),MPHOT2(10),MPOSI2(10),MELEC2(10), * MNU2(10),MMUP2(10),MMUM2(10),MPI02(10),MPIP2(10), * MPIM2(10),MK0L2(10),MKPL2(10),MKMI2(10), * MNETR2(10),MPROT2(10),MPRTB2(10),MK0S2(10), * MHYP2(10),MNETB2(10),MDEUT2(10),MTRIT2(10), * MALPH2(10),MOTH2(10) EQUIVALENCE (MPART2(1, 1),MPHOT2(1)), (MPART2(1, 2),MPOSI2(1)), * (MPART2(1, 3),MELEC2(1)), (MPART2(1, 4),MNU2(1)) , * (MPART2(1, 5),MMUP2(1)) , (MPART2(1, 6),MMUM2(1)) , * (MPART2(1, 7),MPI02(1)) , (MPART2(1, 8),MPIP2(1)) , * (MPART2(1, 9),MPIM2(1)) , (MPART2(1,10),MK0L2(1)) , * (MPART2(1,11),MKPL2(1)) , (MPART2(1,12),MKMI2(1)) , * (MPART2(1,13),MNETR2(1)), (MPART2(1,14),MPROT2(1)), * (MPART2(1,15),MPRTB2(1)), (MPART2(1,16),MK0S2(1)) , * (MPART2(1,18),MHYP2(1)) , (MPART2(1,19),MDEUT2(1)), * (MPART2(1,20),MTRIT2(1)), (MPART2(1,21),MALPH2(1)), * (MPART2(1,22),MOTH2 (1)), (MPART2(1,25),MNETB2(1)) DOUBLE PRECISION THICK INTEGER LPCT0,LPCT1 EXTERNAL BLOCK1,EGS4BD,HEIGH,THICK DOUBLE PRECISION DL,DIAG,FIXHAPP,THCKHN,THICKC EXTERNAL THICKC DOUBLE PRECISION XVC1,XVC2,YVC1,YVC2,ZVC1,ZVC2 C VARIABLES BEING USED FOR RUNTIME REAL TDIFF INTEGER ILEFTA,ILEFTB EXTERNAL TIMER c-----changed---add C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> double precision ctdiams(20) C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> double precision theprim, phiprim double precision spinthe, spinphi c double precision thetap1,phip1 C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> c-----changed--add C----------------------------------------------------------------------- CERELE = 0.D0 CERHAD = 0.D0 NRECER = 0 C INITIALIZE AND READ RUN STEERING CARDS CALL START IF ( CERSIZ .LE. 0.D0 ) THEN ICRSIZ = 0 ELSE ICRSIZ = 1 ENDIF C RESET COUNTER FOR WORDS WRITTEN TO TAPE IRECOR = 0 C RESET COUNTER FOR AVERAGE HEIGHT OF 1ST INTERACTION CHISUM = 0.D0 CHISM2 = 0.D0 C SET ARRAYS FOR SCALES OF KINETIC ENERGY-INTERACTION TABLE SABIN(1) = 0.D0 SBBIN(1) = 0.1D0 DO 13 J = 2,40 SABIN(J) = 10.D0**((J-5.D0)/3.D0) SBBIN(J) = 10.D0**((J-4.D0)/3.D0) 13 CONTINUE C CHECK AND SET PRIMARY PARAMETERS CALL INPRM C INITIALIZE NKG ROUTINES CALL ININKG C RESET COUNTERS FOR NUCLEON, PION AND KAON TABLE FOR ALL SHOWERS C RESET ENERGY-MULTIPLICITY & ENERGY-ELASTICITY MATRIX FOR ALL SHOWERS DO 17 J = 1,40 JNBIN(J) = 0.D0 JPBIN(J) = 0.D0 JKBIN(J) = 0.D0 JHBIN(J) = 0.D0 ELMEAA(J) = 0.D0 DO 17 L = 1,13 MULTOT(J,L) = 0 IELDPA(J,L) = 0 17 CONTINUE C RESET ARRAYS FOR INTERACTION LENGTH STATISTICS DO 90 J = 1,124 IHYCHI(J) = 0 IKACHI(J) = 0 IMUCHI(J) = 0 INUCHI(J) = 0 IPICHI(J) = 0 INNCHI(J) = 0 90 CONTINUE C RESET ARRAY FOR MEAN VALUES AND STANDARD DEVIATION DO 477 K = 1,25 DO 477 J = 1,10 MPARTO(J,K) = 0.D0 MPART2(J,K) = 0.D0 477 CONTINUE C RESET ARRAYS FOR AVERAGE LONGITUDINAL DISTRIBUTION IF ( LLONGI ) THEN LPCT0 = NSTEP LPCT1 = 1 DO J = 0,NSTEP DO K = 1,9 AELONG(J,K) = 0.D0 APLONG(J,K) = 0.D0 SELONG(J,K) = 0.D0 SPLONG(J,K) = 0.D0 ENDDO DO K = 1,9 ADLONG(J,K) = 0.D0 SDLONG(J,K) = 0.D0 ENDDO ENDDO ENDIF C STEERING OF PRINTOUT OF RANDOM GENERATOR SEEDS IPROUT = MIN(100,NSHOW/20) IPROUT = MAX(1,IPROUT) C TIME AT BEGINNING CALL TIMER( ILEFTA ) c-----changed--add cxxc>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> cxx ILEFTA = 0 cxxc>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> CBC++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C Modified by C. Bigongiari 2001 Jan 16 C C Cc>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> print *,'JCIO::========================================' print *,'JCIO:: Initializing JCIO system for advanced' print *,'JCIO:: saving of data.' print *,'JCIO::========================================' C Cc- initialize jcio system C call jcinitio(dsn,nrrun) Cc- create file run###### C call jcstartrun(runh) Cc>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> C C- Modified JCSTARTRUN creates cer###### and dat###### files ! C C ###### is the RUN number ! C call jcstartrun(RUNH) C C- write Run Header on cer and dat files C CALL TOBUF(RUNH,0) IF ( LCERFI ) CALL TOBUFC(RUNH,0) C CBC++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c------changed--add C----------------------------------------------------------------------- C----------------------------------------------------------------------- C LOOP OVER SHOWERS DO 2 ISHW = 1,NSHOW ISHOWNO = ISHOWNO + 1 I = ISHW IF ( ISHW .LE. MAXPRT ) THEN FPRINT = .TRUE. ELSE FPRINT = .FALSE. ENDIF C ENTRY POINT IF COLLISION WAS NOT ACCEPTED IN INTTEST 2222 CONTINUE C FIRST INTERACTION DATA FIRSTI = .TRUE. IFINET = 0 IFINNU = 0 IFINKA = 0 IFINPI = 0 IFINHY = 0 ELAST = 0.D0 THICK1 = 0.D0 TARG1I = 0.D0 SIGAIR = 0.D0 SIG1I = 0.D0 C RESET COUNTERS DO 447 K = 1,25 DO 447 J = 1,10 NPARTO(J,K) = 0.D0 447 CONTINUE C RESET ARRAY FOR LONGITUDINAL DISTRIBUTION PER SHOWER IF ( LLONGI ) THEN DO 479 K = 1,9 DO J = 0,NSTEP DLONG(J,K) = 0.D0 ELONG(J,K) = 0.D0 PLONG(J,K) = 0.D0 ENDDO 479 CONTINUE ENDIF NRECS = 0 NBLKS = 0 DO 922 KKK = 1,10 AVNREJ(KKK) = 0.D0 922 CONTINUE IRESPAR = 0 C RESET COUNTERS FOR NUCLEON, PION AND KAON TABLE FOR SHOWER C RESET ENERGY-MULTIPLICITY & ENERGY-ELASTICITY MATRIX FOR SHOWER DO 11 J = 1,40 INBIN(J) = 0 IPBIN(J) = 0 IKBIN(J) = 0 IHBIN(J) = 0 ELMEAN(J) = 0.D0 DO 11 L = 1,13 MULTMA(J,L) = 0 IELDPM(J,L) = 0 11 CONTINUE C RESET PARTICLE TABLES IF ( FTABOUT ) THEN DO IIE = 1,IEBIN DO IIT = 1,ITBIN DO IID = 1,IDBIN G_ARRAY(IIE,IIT,IID) = 0. E_ARRAY(IIE,IIT,IID) = 0. M_ARRAY(IIE,IIT,IID) = 0. ENDDO ENDDO ENDDO ENDIF C INITIALIZE PARTICLE STACK CALL ISTACK C RESET STACKINT DO J = 1,MAXICOUNT DO K = 1,MAXLEN STACKINT(K,J) = 0.D0 ENDDO ENDDO IRET1 = 0 C INITIALIZE EVENT HEADER AND END FOR EACH EVENT DO 2123 L = 2,43 EVTH(L) = 0. 2123 CONTINUE DO 123 L = 2,MAXBUF EVTE(L) = 0. 123 CONTINUE C SHOWER BEGIN PRINTOUT IF ( FPRINT .OR. DEBUG ) WRITE(MONIOU,105) ISHOWNO 105 FORMAT ('1',10('='),' SHOWER NO ',I10,' ',47('=')/) C RANDOM GENERATOR STATUS AT BEGINNING OF SHOWER CALCULATION EVTH(13) = NSEQ DO 45 L = 1,NSEQ CALL RMMAQ( ISEED(1,L), L, 'R' ) C SEED EVTH(11+L*3) = ISEED(1,L) C NUMBER OF CALLS EVTH(12+L*3) = MOD ( ISEED(2,L), 1000000 ) C NUMBER OF MILLIONS EVTH(13+L*3) = ISEED(3,L)*1000 + INT( ISEED(2,L)/1000000 ) 45 CONTINUE IF ( FPRINT .OR. DEBUG .OR. MOD(ISHW-1,IPROUT).EQ.0 ) THEN CALL PRTIME(TTIME) WRITE(MONIOU,158) ISHOWNO,(L,(ISEED(J,L),J=1,3),L=1,NSEQ) 158 FORMAT(' AND RANDOM NUMBER GENERATOR AT BEGIN OF EVENT :',I8, * /,(' SEQUENCE = ',I2,' SEED = ',I9 ,' CALLS = ',I9, * ' BILLIONS = ',I9)) ENDIF C RESET KNOR KNOR = .TRUE. C GET FULL RANDOM GENERATOR STATUS (103 WORDS PER SEQUENCE) CC DO 495 L = 1,NSEQ CC CALL RMMAQ( ISEED(1,L), L, 'RV' ) CC WRITE(MONIOU,658) L,(ISEED(J,L),J=1,103) CC658 FORMAT ( ' FULL RANDOM NUMBER GENERATOR STATUS ', CC * 'FOR SEQUENCE ',I2,/(' ',10I11)) CC495 CONTINUE C GET PRIMARY ENERGY INTO PRMPAR(2) IF ( ISPEC .EQ. 0 ) THEN PRMPAR(2) = LLIMIT ELSE CALL RMMAR( RD,1,1 ) IF ( PSLOPE .NE. -1.D0 ) THEN PRMPAR(2) = ( RD(1)*UL + ( 1.D0-RD(1) )*LL )**SLEX ELSE PRMPAR(2) = LLIMIT * LL**RD(1) ENDIF IF ( FPRINT .OR. DEBUG .OR. MOD(ISHW-1,IPROUT).EQ.0 ) * WRITE(MONIOU,*) 'PRIMARY ENERGY = ',PRMPAR(2),' GEV' ENDIF C IF YOU WANT TO USE KINETIC ENERGY IN PRIMARY SPECTRUM C YOU HAVE TO ADD THE PRIMARY'S REST MASS: cc PRMPAR(2) = PRMPAR(2) + PAMA(NINT(PRMPAR(1))) c-------------changes---add THETAP1 = THETPR(1) PHIP1 = PHIPR(1) c-------------changes---add C GET PRIMARY ANGLES OF INCIDENCE IF ( FIXINC ) THEN THETAP = THETPR(1) PHIP = PHIPR(1) IF ( VUECON(2) .GT. 0.D0 ) THEN C THROW UNIFORMLY DISTRIBUTED DIRECTION IN VIEWING CONE OR CONE RING C FOR NOW 46 CALL RMMAR( RD,3,1 ) CT1 = COS(VUECON(1)) CT2 = COS(VUECON(2)) CTT = RD(2) * ( CT2 - CT1 ) + CT1 THETAP = ACOS(CTT) PHIP = RD(1) * PI2 C TEMPORARY CARTESIAN COORDINATES XVC1 = COS(PHIP)*SIN(THETAP) YVC1 = SIN(PHIP)*SIN(THETAP) ZVC1 = COS(THETAP) C ROTATE AROUND Y AXIS XVC2 = XVC1*COS(THETPR(1)) + ZVC1*SIN(THETPR(1)) YVC2 = YVC1 ZVC2 = ZVC1*COS(THETPR(1)) - XVC1*SIN(THETPR(1)) C FOR A HORIZONTAL TARGET, THE COS(THETA) WEIGHT IS OBTAINED BY C THROWING THE DICE ANOTHER TIME. IF ( RD(3) .GT. ZVC2 ) GOTO 46 THETAP = ACOS(ZVC2) IF ( THETAP .GT. 88.D0*(PI/180.D0) ) GOTO 46 PHIP = ATAN2(YVC2,XVC2) + PHIPR(1) IF ( PHIP .GT. PI2 ) PHIP = PHIP - PI2 IF ( PHIP .LT. 0.D0 ) PHIP = PHIP + PI2 ENDIF C COSINE OF APPARENT ZENIT ANGLE IS PUT IN PRMPAR(15) C (COSINE OF LOCAL ZENIT ANGLE IS IN PRMPAR(3)) PRMPAR(15) = COS(THETAP) ELSE C CHOOSE ANGLES AT RANDOM WITH EQUAL FLUX FOR ALL DIRECTIONS C WITH HORIZONTAL DETECTOR ARRAY (SEE: O.C. ALLKOFER & P.K.F. GRIEDER, C COSMIC RAYS ON EARTH, IN: PHYSICS DATA 25/1, H.BEHRENS & G.EBEL ED., C (FACHINFORMATIONSZENTRUM KARLSRUHE, GERMANY, 1983) CHPT. 1.1.2) CALL RMMAR( RD,3,1 ) CT1 = SIN(THETPR(1))**2 CT2 = SIN(THETPR(2))**2 CTT = SQRT( 1.D0 - RD(2)*(CT2 - CT1) - CT1 ) THETAP = ACOS(CTT) PHIP = RD(1) * ( PHIPR(2) - PHIPR(1) ) + PHIPR(1) C CALCULATION IS THE SAME AS IN THE CASE OF A FLAT ATMOSPHERE BECAUSE C FOR THIS CALCULATION THE APPARENT ANGLES AT DETECTOR ARE NEEDED. C COSINE OF APPARENT ZENITH ANGLE IS PUT IN PRMPAR(15) = COSTAP PRMPAR(15) = CTT ENDIF PRMPAR(4) = PHIP IF ( FPRINT .OR. DEBUG .OR. MOD(ISHW-1,IPROUT).EQ.0 ) THEN IF ( VUECON(2) .GT. 0.D0 ) WRITE(MONIOU,669) THETAP,PHIP 669 FORMAT(' PRIMARY ANGLES ARE: THETA = ',F6.4,' RAD AND ', * ' PHI = ',F6.4,' RAD') ENDIF C DEFINE HEIGHT FOR START AT THICK0 (IN G/CM**2) C WHICH IS 112.8 KM FOR THICK0 = 0 PRMPAR(5) = HEIGH(THICK0) IF ( LLONGI ) LPCT0 = MIN( INT(THICK0*THSTPI), LPCT0 ) C CALCULATE COORDINATE CORRECTION FOR TOP OF ATMOSPHERE C ALL CALCULATIONS FOR CURPAR ARE MADE IN CORINC C (COSTHE, HAPP, COSTEA). (X, Y) FOR SHOWER CORE = (0,0) H = PRMPAR(5) CURPAR(15) = PRMPAR(15) CALL CORINC C COUNTER FOR PARTICLE OUTPUT LH = 0 C COUNTER FOR CHERENKOV OUTPUT IF ( LCERFI ) LHCER = 0 C CALCULATE BUNCH SIZE FOR CHERENKOV PHOTONS IF NOT SET IN DATAC IF ( ICRSIZ .EQ. 0 ) THEN CALL GETBUS( NINT(PRMPAR(1)),PRMPAR(2),PRMPAR(3),CERSIZ ) IF ( FPRINT .OR. DEBUG ) WRITE(MONIOU,*) * 'CHERENKOV BUNCH SIZE IS CALCULATED TO=',CERSIZ ENDIF IF ( ICERML .GE. 1 ) THEN DO 4438 III = 1,ICERML c--changes--add c 5226 CALL SELCOR(CERXOS(III),CERYOS(III)) if(yscatt.eq.xscatt) then cerxos(iii)=yscatt/dcos(thetap1)*dcos(phip1) ceryos(iii)=yscatt/dcos(thetap1)*dsin(phip1) else 5226 CALL RMMAR( RD,2,3 ) CERXOS(III) = 2.0*YSCATT*(RD(1)-0.5)/dcos(thetap1) CERYOS(III) = 2.0*YSCATT*(RD(2)-0.5)/dcos(thetap1) xx=cerxos(iii)*dcos(phip1)-ceryos(iii)*dsin(phip1) yy=cerxos(iii)*dsin(phip1)+ceryos(iii)*dcos(phip1) r=dsqrt((xx*dcos(thetap1))**2+yy**2+1.d-7) c R=SQRT(CERXOS(I)**2+CERYOS(I)**2) IF ((R.LT.XSCATT).OR.(R.GT.YSCATT)) GOTO 5226 endif c--changes--add WRITE(MONIOU,4437) ISHW,III,CERXOS(III),CERYOS(III) 4437 FORMAT(' CORE OF EVENT ',I5,' (SCATT# ',I2, * ') AT ',F12.2,9X,F12.2,' CM') 4438 CONTINUE ENDIF DO 480 III = 1,20 EVTH( 98+III) = CERXOS(III) EVTH(118+III) = CERYOS(III) 480 CONTINUE C GET GAMMA FACTOR FROM ENERGY C FOR MASSLESS PRIMARIES PRMPAR(2) STAYS = ENERGY IF ( PAMA(NINT(PRMPAR(1))) .NE. 0.D0 ) * PRMPAR(2) = PRMPAR(2) / PAMA(NINT(PRMPAR(1))) C SET PRIMARY TO CURRENT PARTICLE DO J = 1,8 CURPAR(J) = PRMPAR(J) NCOUN(J) = 0 ENDDO C CALCULATE FIRST INTERACTION POINT IF HADRONIC GEN = 0.D0 H = HEIGH(THICK0) CALL BOX2 IF ( FIX1I ) THEN C CALCULATE GEOMETRIC PATH LENGHT TO FIXED FIRST INTERACTION POINT IN C DETECTOR FRAME (DUE TO DIFFERENCES IN H AND FIXHEI (POSSIBLY VERY C DIFFERENT COORDINATE FRAMES) AND TAKE NRANGC FOR GETTING CHI IN A C CURVED ATMOSPHERE DIAG = SQRT( (C(1)+FIXHEI)**2 - (C(1)+OBSLEV(1))**2 * * (1.D0-PRMPAR(15)**2) ) - (C(1)+OBSLEV(1))*PRMPAR(15) FIXHAPP = OBSLEV(1) + DIAG * PRMPAR(15) DL = (HAPP - FIXHAPP) / PRMPAR(15) CALL NRANGC(DL) H = FIXHEI FDECAY = .FALSE. ELSE C CHI IS GIVEN BY BOX2 THICKH = THICK0 THCKHN = THICKC(CHI) H = HEIGH(THCKHN) H = MAX( H, HLAY(1) - 100.D0 ) ENDIF HEIGHP = H THICK1 = THICK(H) IF ( CURPAR(1) .GT. 3.D0 .OR. .NOT. FEGS ) THEN CHISUM = CHISUM + CHI CHISM2 = CHISM2 + CHI**2 ENDIF ALEVEL = H C STORE PRIMARY COORDINATES FOR ADDITIONAL MUON INFORMATION IF ( FMUADD ) THEN IF ( CURPAR(1) .EQ. 5 .OR. CURPAR(1) .EQ. 6 ) THEN DO J = 1,MAXLEN AMUPAR(J) = CURPAR(J) ENDDO AMUPAR(5) = PRMPAR(5) IF ( DEBUG ) WRITE(MDEBUG,*) 'AAMAIN: MUON STORED IN AMUPAR' FMUORG = .TRUE. ELSE FMUORG = .FALSE. ENDIF ENDIF C SET TARGET FLAG IF SELECTED FOR FIRST INTERACTION IF ( N1STTR .GT. 0 ) THEN FIXTAR = .TRUE. FDECAY = .FALSE. EVTH(6) = REAL(N1STTR) ELSE FIXTAR = .FALSE. EVTH(6) = 0. ENDIF C INITIALIZE ARRAYS FOR NKG FOR EACH SHOWER IF ( FNKG ) CALL STANKG C STORE FIRST PARTICLE IN HEADER AND PRINT IT OUT EVTH( 2) = REAL(ISHOWNO) EVTH( 3) = CURPAR(1) IF ( PAMA(NINT(CURPAR(1))) .EQ. 0.D0 ) THEN C PRIMARY ENERGY FOR MASSLESS PARTICLES (PHOTONS, NEUTRINOS) E00 = GAMMA E00PN = GAMMA INUCL = 1 ELSE E00 = GAMMA * PAMA(NINT(CURPAR(1))) INUCL = INT(MAX(1.D0,CURPAR(1)/100.D0)) E00PN = E00 / INUCL ENDIF EVTH(148) = 0. EVTH(149) = 0. EVTH(150) = 0. EVTH(151) = 0. EVTH(152) = 0. IF ( FEGS ) THEN C PARAMETER FOR ELECTRON AND PHOTON REJECT (CONVERT ENERGY TO MEV) EONCUT = .5D-9*SQRT(E00*1000.D0) CUTLN = LOG(EONCUT) ENDIF EVTH( 4) = E00 EVTH( 5) = THICK0 EVTH( 7) = HEIGHP PTOT0 = SQRT( E00**2 - PAMA(NINT(CURPAR(1)))**2 ) PTOT0N = PTOT0 / INUCL C PUT APPARENT ANGLES (SEEN FROM DETECTOR) INTO EVENT HEADER ST = SQRT(1.D0-COSTAP**2) EVTH(10) = PTOT0 * COSTAP THETA = ACOS(COSTAP) EVTH( 8) = PTOT0 * ST * COS(PHI) EVTH( 9) = PTOT0 * ST * SIN(PHI) EVTH(11) = THETA EVTH(12) = PHI C WRITE ENERGY AND ANGLES OF PRIMARY TO DBASE FILE FOR THE FIRST SHOWER IF ( FDBASE .AND. ISHW .EQ. 1 ) THEN WRITE(MDBASE,668) E00, THETA*180.D0/PI, PHI*180.D0/PI 668 FORMAT(1P,'#energy_prim#',E14.7,'#theta_prim#',E14.7, * '#phi_prim#',E14.7) CLOSE(UNIT=MDBASE) ENDIF EVTH(85) = CERSIZ IF ( DEBUG .OR. FPRINT ) THEN WRITE(MONIOU,*) ENDIF IF ( CURPAR(1) .GT. 3.D0 ) THEN IF ( DEBUG ) THEN WRITE(MONIOU,102) (CURPAR(J),J = 1,8) 102 FORMAT (' PRIMARY PARAMETERS AT FIRST INTERACTION POINT'/ * 16X,1P,8E10.3) ELSEIF ( FPRINT ) THEN WRITE(MONIOU,1021) (CURPAR(J),J = 1,8) 1021 FORMAT (' PRIMARY PARAMETERS AT FIRST INTERACTION POINT'/ * 1X,1P,8E10.3) ENDIF ELSE IF ( FPRINT .OR. DEBUG ) WRITE(MONIOU,132) 132 FORMAT (/' PRIMARY PARTICLE IS ELECTROMAGNETIC') ENDIF C WRITE EVENT HEADER INTO BUFFER C FOR EM PARTICLES EVTH IS WRITTEN TO BUFFER IN EGS (IF ACTIVE) IF ( EVTH(3) .GT. 3.0 .OR. .NOT. FEGS ) THEN C NEGATIVE FIRST INTERACTIN HEIGHT, IF TRACKING STARTS AT ATMOS. MARGIN CALL TOBUF ( EVTH,0 ) IF ( LCERFI ) CALL TOBUFC( EVTH,0 ) ENDIF C PRINT HEADER FOR HIGH ENERGY PARTICLES IF ( FPRINT .OR. DEBUG ) WRITE(MONIOU,103) 103 FORMAT(/' TYPE GAMMA COSTHETA ', * ' PHI HEIGHT TIME X-CM Y-CM ', * ' GEN ALEVEL E ON STACK'/) NOPART = 0 IF ( CURPAR(1) .LE. 3.D0 .OR. * (CURPAR(1) .EQ. 5.D0 .OR. CURPAR(1) .EQ. 6.D0) ) THEN C GIVE PARTICLE TO EGS OR NKG IF ELECTROMAGNETIC C AND TAKE THEN NEXT PARTICLE FROM STACK C FLAG FOR NO PRIMARY INTERACTION IS SET FOR ALL BUT ELM. PRIMARIES IF ( CURPAR(1) .LE. 3.D0 ) THEN C EM PARTICLES FNPRIM = .FALSE. BNORMC = BNORM*1.D-3 ELSE C MUONS FNPRIM = .TRUE. H = PRMPAR(5) IF ( TMARGIN ) BNORMC = BNORM*1.D-3 ENDIF c-----changed--add fmfb=.true. CALL BOX3(fmfb) fmfb=.false. c-----changed--add BNORMC = BNORM*1.D-3 IF ( FEGS ) THEN CHISUM = CHISUM + THICK(ABS(DBLE(EVTH(7)))) CHISM2 = CHISM2 + THICK(ABS(DBLE(EVTH(7))))**2 ENDIF FIRSTI = .FALSE. GOTO 4 ELSE C HADRONIC PARTICLES FNPRIM = .TRUE. C CHECK OBSERVATION LEVEL PASSAGE AND UPDATE PARTICLE COORDINATES HNEW = H C FOR SUBR. UPDATE WE NEED THE START ALTITUDE H H = HEIGH(THICK0) C TRACK THE PARTICLE WHEN ENTERING THE ATMOSPHERE FLAG = .FALSE. c--changed---add fmfb=.true. CALL UPDATC(IPAS,FLAG,fmfb) fmfb=.false. c--changed---add C ELIMINATE PARTICLE IF BELOW CUTS BY JUMP TO LABEL 4 IF ( IRET2 .NE. 0 ) GOTO 4 IF ( IPAS .EQ. 0 ) THEN C PARTICLE DID NOT REACH OBSERVATION LEVEL C START CLOCK AT FIRST INTERACTION (MAGNETIC FIELD IS SET IN INPRM) CURPAR(6) = 0.D0 C JUMP INTO NORMAL PARTICLE TREATMENT FOR HADRONS GOTO 6 ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) * 'AAMAIN: PRIMARY REACHED LOWEST OBSERVATION LEVEL' GOTO 4 ENDIF C----------------------------------------------------------------------- C NORMAL CYCLE 7 CONTINUE C IF ENERGY IS TOO SMALL, TAKE NEXT PARTICLE BY JUMP TO LABEL 4 IF ( GAMMA .LE. 1.D0 ) THEN IF ( CURPAR(1) .NE. 1.D0 ) THEN IF ( CURPAR(1).EQ.5.D0 .OR. CURPAR(1).EQ.6.D0 ) * FMUORG = .FALSE. IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT LHEIGH = INT(THICK(H)*THSTPI + 1.D0) IF ( ITYPE .EQ. 2 ) THEN DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + (GAMMA+1.D0)*PAMA(2) ELSEIF ( ITYPE .EQ. 3 ) THEN DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + (GAMMA-1.D0)*PAMA(2) ELSEIF ( ITYPE .EQ. 5 .OR. ITYPE .EQ. 6 ) THEN DLONG(LHEIGH,5) = DLONG(LHEIGH,5) + GAMMA * PAMA(5) ELSEIF ( ITYPE .GE. 7 .AND. ITYPE .LE. 74 ) THEN DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + GAMMA * PAMA(ITYPE) * - RESTMS(ITYPE) ENDIF ENDIF GOTO 4 ENDIF C SPECIAL TREATMENT FOR PHOTONS ITYPE = 1 CHI = 0.D0 GOTO 5 ENDIF C DETERMINE PLACE OF NEXT INTERACTION CALL BOX2 C CHECK PASSAGE THROUGH OBSERVATION LEVELS AND TRACK PARTICLES TO THE C PLACE OF INTERACTION 5 CONTINUE IRET1 = 0 CALL BOX3(fmfb) IF ( IRET1 .NE. 0 ) GOTO 4 6 CONTINUE IRET1 = 0 MSMM = 0 C INCREMENT PARTICLE GENERATION AND PROCESS NUCLEAR INTERACTION GEN = GEN + 1.D0 C INITIALIZE INTERMEDIATE STACK FOR ONE REACTION INT_ICOUNT = 0 CALL NUCINT C TRANSFER INTERMEDIATE STACK FOR ONE REACTION CALL TSTEND C ENERGY - MULTIPLICITY STATISTICS IF ( EKINL .LE. 0.1D0 ) THEN MEN = 1 ELSE MEN = 4.D0 + 3.D0 * LOG10(EKINL) MEN = MIN( MEN, 40 ) ENDIF IF ( MSMM .LE. 1 ) THEN MMU = 1 ELSE MMU = 1.D0 + 3.D0 * LOG10(DBLE(MSMM)) MMU = MIN( MMU, 13 ) ENDIF MULTMA(MEN,MMU) = MULTMA(MEN,MMU) + 1 MULTOT(MEN,MMU) = MULTOT(MEN,MMU) + 1 IF ( DEBUG ) WRITE(MDEBUG,*) 'AAMAIN: EKINL,MSMM=', * SNGL(EKINL),MSMM IF ( IRET1 .EQ. 0 ) THEN IF ( DEBUG ) WRITE(MDEBUG,666) (CURPAR(II),II=1,9) 666 FORMAT(' AAMAIN: CURPAR=',1P,9E10.3) GOTO 7 ENDIF C GET NEXT PARTICLE FROM STACK, IF IRET=1 ALL PARTICLES ARE DONE 4 CONTINUE IRET1 = 0 CALL FSTACK IF ( FMUADD ) THEN IF ( (CURPAR(1) .EQ. 5 .OR. CURPAR(1) .EQ. 6) * .AND. IRET1 .EQ. 0 .AND. .NOT. FMUORG ) THEN DO J = 1,MAXLEN AMUPAR(J) = CURPAR(J) ENDDO IF ( DEBUG ) WRITE(MDEBUG,*) 'AAMAIN: MUON STORED IN AMUPAR' FMUORG = .TRUE. ENDIF ENDIF C STACK IS EMPTY, IF IRET1 IS 1 IF ( IRET1 .EQ. 0 ) GOTO 7 C----------------------------------------------------------------------- C FINISH SHOWER AND PRINT INFORMATION CALL OUTEND * IF ( DEBUG ) WRITE(MDEBUG,442) NPARTO *442 FORMAT(' AAMAIN: NPARTO='/(' ',10F10.0)) IF ( FPRINT .OR. DEBUG ) THEN IOBSLV = MIN( 5, NOBSLV ) WRITE(MONIOU,54) (K,K=1,IOBSLV) 54 FORMAT (/' PARTICLES AT DETECTOR LEVEL :'/ * ' FOR LEVEL ', 5I13) WRITE(MONIOU,55) (OBSLEV(K),K=1,IOBSLV) 55 FORMAT ( ' HEIGHT IN CM ',1P, 5E13.3/) WRITE(MONIOU,555) (THCKOB(K),K=1,IOBSLV) 555 FORMAT ( ' HEIGHT IN G/CM**2 ',1P, 5E13.3/) WRITE(MONIOU,776) 'PROTONS ',(NPROTO(K),K=1,IOBSLV) WRITE(MONIOU,776) 'ANTIPROTONS ',(NPROTB(K),K=1,IOBSLV) WRITE(MONIOU,776) 'NEUTRONS ',(NNEUTR(K),K=1,IOBSLV) WRITE(MONIOU,776) 'ANTINEUTRONS ',(NNEUTB(K),K=1,IOBSLV) WRITE(MONIOU,775) 'PHOTONS ',(NPHOTO(K),K=1,IOBSLV) WRITE(MONIOU,775) 'ELECTRONS ',(NELECT(K),K=1,IOBSLV) WRITE(MONIOU,775) 'POSITRONS ',(NPOSIT(K),K=1,IOBSLV) WRITE(MONIOU,776) 'MU - ',(NMUM (K),K=1,IOBSLV) WRITE(MONIOU,776) 'MU + ',(NMUP (K),K=1,IOBSLV) WRITE(MONIOU,776) 'PI 0 ',(NPI0 (K),K=1,IOBSLV) WRITE(MONIOU,776) 'PI - ',(NPIM (K),K=1,IOBSLV) WRITE(MONIOU,776) 'PI + ',(NPIP (K),K=1,IOBSLV) WRITE(MONIOU,776) 'K0L ',(NK0L (K),K=1,IOBSLV) WRITE(MONIOU,776) 'K0S ',(NK0S (K),K=1,IOBSLV) WRITE(MONIOU,776) 'K - ',(NKMI (K),K=1,IOBSLV) WRITE(MONIOU,776) 'K + ',(NKPL (K),K=1,IOBSLV) WRITE(MONIOU,776) 'STR. BARYONS ',(NHYP (K),K=1,IOBSLV) WRITE(MONIOU,776) 'DEUTERONS ',(NDEUT (K),K=1,IOBSLV) WRITE(MONIOU,776) 'TRITONS ',(NTRIT (K),K=1,IOBSLV) WRITE(MONIOU,776) 'ALPHAS ',(NALPHA(K),K=1,IOBSLV) WRITE(MONIOU,776) 'OTHER PARTIC.',(NOTHER(K),K=1,IOBSLV) WRITE(MONIOU,*) WRITE(MONIOU,776) 'DECAYED MUONS',NMUOND 775 FORMAT(' NO OF ',A13, '= ',1P,5E13.6,0P) 776 FORMAT(' NO OF ',A13, '= ',5F13.0) IF ( NOBSLV .GT. 5 ) THEN IOBSLV = NOBSLV WRITE(MONIOU,54) (K,K=6,IOBSLV) WRITE(MONIOU,55) (OBSLEV(K),K=6,IOBSLV) WRITE(MONIOU,555) (THCKOB(K),K=6,IOBSLV) WRITE(MONIOU,776) 'PROTONS ',(NPROTO(K),K=6,IOBSLV) WRITE(MONIOU,776) 'ANTIPROTONS ',(NPROTB(K),K=6,IOBSLV) WRITE(MONIOU,776) 'NEUTRONS ',(NNEUTR(K),K=6,IOBSLV) WRITE(MONIOU,776) 'ANTINEUTRONS ',(NNEUTB(K),K=6,IOBSLV) WRITE(MONIOU,775) 'PHOTONS ',(NPHOTO(K),K=6,IOBSLV) WRITE(MONIOU,775) 'ELECTRONS ',(NELECT(K),K=6,IOBSLV) WRITE(MONIOU,775) 'POSITRONS ',(NPOSIT(K),K=6,IOBSLV) WRITE(MONIOU,776) 'MU - ',(NMUM (K),K=6,IOBSLV) WRITE(MONIOU,776) 'MU + ',(NMUP (K),K=6,IOBSLV) WRITE(MONIOU,776) 'PI 0 ',(NPI0 (K),K=6,IOBSLV) WRITE(MONIOU,776) 'PI - ',(NPIM (K),K=6,IOBSLV) WRITE(MONIOU,776) 'PI + ',(NPIP (K),K=6,IOBSLV) WRITE(MONIOU,776) 'K0L ',(NK0L (K),K=6,IOBSLV) WRITE(MONIOU,776) 'K0S ',(NK0S (K),K=6,IOBSLV) WRITE(MONIOU,776) 'K - ',(NKMI (K),K=6,IOBSLV) WRITE(MONIOU,776) 'K + ',(NKPL (K),K=6,IOBSLV) WRITE(MONIOU,776) 'STR. BARYONS ',(NHYP (K),K=6,IOBSLV) WRITE(MONIOU,776) 'DEUTERONS ',(NDEUT (K),K=6,IOBSLV) WRITE(MONIOU,776) 'TRITONS ',(NTRIT (K),K=6,IOBSLV) WRITE(MONIOU,776) 'ALPHAS ',(NALPHA(K),K=6,IOBSLV) WRITE(MONIOU,776) 'OTHER PARTIC.',(NOTHER(K),K=6,IOBSLV) WRITE(MONIOU,*) ENDIF ENDIF C ADD UP FOR MEAN VALUES DO 779 K = 1,25 DO 779 J = 1,10 MPARTO(J,K) = MPARTO(J,K) + NPARTO(J,K) MPART2(J,K) = MPART2(J,K) + NPARTO(J,K)**2 779 CONTINUE EVTE(2) = ISHOWNO IOBSLV = NOBSLV DO 335 K = 1,IOBSLV EVTE(3) = EVTE(3) + NPHOTO(K) EVTE(4) = EVTE(4) + NELECT(K) + NPOSIT(K) EVTE(5) = EVTE(5) + NPROTO(K) + NPROTB(K) + NNEUTR(K) + * NNEUTB(K) + NPI0(K) + NPIM(K) + NPIP(K) + NK0L(K) + * NK0S(K) + NKMI(K) + NKPL(K) + NHYP(K) + * NDEUT(K) + NTRIT(K) + NALPHA(K) + NOTHER(K) EVTE(6) = EVTE(6) + NMUP(K) + NMUM(K) 335 CONTINUE EVTE(7) = NOPART IF ( FPRINT .OR. DEBUG ) WRITE(MONIOU,110) * IFINNU,IFINPI,IFINET,IFINKA,IFINHY, * IFINNU+IFINPI+IFINET+IFINKA+IFINHY, * ELAST,THICK1,SIG1I,TARG1I 110 FORMAT(/ * ' NO OF NUCLEONS PRODUCED IN FIRST HADR. INTERACTION =',I10/ * ' NO OF PIONS PRODUCED IN FIRST HADR. INTERACTION =',I10/ * ' NO OF ETAS PRODUCED IN FIRST HADR. INTERACTION =',I10/ * ' NO OF KAONS PRODUCED IN FIRST HADR. INTERACTION =',I10/ * ' NO OF S.BARYONS PRODUCED IN FIRST HADR. INTERACTION =',I10/ * ' TOTAL MULTIPLICITY OF FIRST HADR. INTERACTION =',I10/ * ' ELASTICITY OF FIRST HADR. INTERACTION =',F10.4/ * ' VERTICAL DEPTH (G/CM**2) OF FIRST HADR. INTERACTION =',F10.4/ * ' CROSS-SECTION MILLIBARN OF FIRST HADR. INTERACTION =',F10.4/ * ' TARGET MASS NUMBER OF FIRST HADR. INTERACTION =',F10.4/) C PRINT OUT NKG RESULT FOR ONE SHOWER IF SELECTED IF ( FNKG ) CALL AVAGE c--------changed------add c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> c calculated here again, 'cos it's rewrite I dont know where LPCT1 = INT( THICK0 * THSTPI ) LPCT2 = INT( (THICK0 + PRMPAR(3)*CHI) * THSTPI ) LPCT2 = MIN(NSTEP,LPCT2) c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> c-------changed ---add--- IF ( LLONGI ) THEN C TREAT LONGITUDINAL DISTRIBUTIONS DO 980 J = 0,NSTEP C ADD UP ENERGY DEPOSIT AND IONIZATION FOR SUM DLONG(J,9) = DLONG(J,1)+DLONG(J,2)+DLONG(J,3)+DLONG(J,4) * +DLONG(J,5)+DLONG(J,6)+DLONG(J,7)+DLONG(J,8) C ADD ELECTRONS, POSITRONS, MUONS AND NUCLEI TO THE CHARGED PARTICLES ELONG(J,7) = ELONG(J,7) + ELONG(J,2) + ELONG(J,3) * + ELONG(J,4) + ELONG(J,5) + ELONG(J,8) C ADD UP ALL ENERGIES FOR SUM ELONG(J,9) = ELONG(J,1) + ELONG(J,2) + ELONG(J,3) * + ELONG(J,4) + ELONG(J,5) + ELONG(J,6) + ELONG(J,8) C ADD ALL CHARGED PARTICLES TO CHARGED SUM PLONG(J,7) = PLONG(J,7) + PLONG(J,2) + PLONG(J,3) * + PLONG(J,4) + PLONG(J,5) + PLONG(J,8) C ADD UP FOR MEAN VALUES OF LONGITUDINAL DISTRIBUTION DO K = 1,9 AELONG(J,K) = AELONG(J,K) + ELONG(J,K) SELONG(J,K) = SELONG(J,K) + ELONG(J,K)**2 APLONG(J,K) = APLONG(J,K) + PLONG(J,K) SPLONG(J,K) = SPLONG(J,K) + PLONG(J,K)**2 ENDDO DO K = 1,9 ADLONG(J,K) = ADLONG(J,K) + DLONG(J,K) SDLONG(J,K) = SDLONG(J,K) + DLONG(J,K)**2 ENDDO 980 CONTINUE C PRINT LONGITUDINAL DISTRIBUTIONS PER SHOWER IF ( FPRINT .OR. DEBUG ) THEN WRITE(MONIOU,910) THSTEP, * 'GAMMAS','POSITRONS','ELECTRONS','MU+','MU-','HADRONS', * 'CHARGED','NUCLEI','CHERENKOV', * (J*THSTEP,(PLONG(J,K),K=1,9),J=LPCT1,NSTEP) 910 FORMAT(/' ---------- LONGITUDINAL PARTICLE DISTRIBUTION IN ' * ,'STEPS OF ',F5.0,' G/CM**2 ',50(1H-)/ * ' DEPTH ',3A14,3A12,A12,A11,A12/ * (' ',F6.0,F15.0,2F14.0,3F12.0,F14.0,F11.0,1P,E12.5,0P) ) CJOK ADAPTED FOR HEAT CALCULATION C910 FORMAT(/ C * ' LONGITUDINAL DISTRIBUTION IN STEPS OF ',F5.0,' G/CM**2' C * /' ',92('=')/' DEPTH',8A10,A12/1P C * (' ',0P,F6.0,1P,9E11.4)) CJOK C ENERGY DISTRIBUTION WRITE(MONIOU,908) THSTEP, * 'GAMMAS','POSITRONS','ELECTRONS','MU+','MU-','HADRONS', * 'CHARGED','NUCLEI','SUM', * (J*THSTEP,(ELONG(J,K),K=1,9),J=LPCT1,NSTEP) 908 FORMAT(/' ---------- LONGITUDINAL ENERGY DISTRIBUTION ', * '[GEV] IN STEPS OF ',F5.0,' G/CM**2 ',47(1H-)/ * ' DEPTH',9(A12,1X)/ (' ',F6.0,1P,9E13.5,0P) ) C ENERGY DEPOSIT WRITE(MONIOU,909) THSTEP, * ' GAMMA ','EM IONIZ','EM CUT','MU IONIZ','MU CUT', * 'HADR IONIZ','HADR CUT','NEUTRINO ',' SUM', * ((2*J-1)*.5*THSTEP,(DLONG(J,K),K=1,9), * J=MAX(1,LPCT1),NSTEP-1) 909 FORMAT(/' ---------- LONGITUDINAL ENERGY DEPOSIT [GEV] IN ', * 'STEPS OF ',F5.0,' G/CM**2 ',51(1H-)/ * ' DEPTH ',3A14,6A12,/,(' ',F6.1,1X,3F14.1,5F12.1,F13.1)) WRITE(MONIOU,9091) (2*NSTEP-1)*.5*THSTEP, * (DLONG(NSTEP,K),K=1,9) 9091 FORMAT(' ',F6.1,1X,1P,3E14.7,5E12.5,E13.6) DLONGSUM = 0.D0 DO K = 1,9 DO J = 0,NSTEP DLONG(1170,K) = DLONG(1170,K) + DLONG(J,K) ENDDO IF ( K .NE. 9 ) DLONGSUM = DLONGSUM + DLONG(1170,K) ENDDO WRITE(MONIOU,907) (DLONG(1170,K),K=1,8) 907 FORMAT(' ',20X,' LONGITUDINAL ENERGY SUM [GEV] ',/ * ,' ',7X,1P,3E14.7,5E12.5) WRITE(MONIOU,919) DLONGSUM DO K = 1,9 DLONG(1170,K) = 0.D0 ENDDO ENDIF C WRITE OUT LONGITUDINAL DISTRIBUTION IF ( FLONGOUT ) THEN WRITE(MLONGOUT,211) NSTEP,THSTEP,ISHOWNO, * 'GAMMAS','POSITRONS','ELECTRONS','MU+','MU-','HADRONS', * 'CHARGED','NUCLEI','CHERENKOV' C C DO NOT CHANGE THIS FORMAT, AS THE CorsTo Root PROGRAM DEPENDS ON IT C 211 FORMAT(' LONGITUDINAL DISTRIBUTION IN ',I5, * ' VERTICAL STEPS OF ',F5.0,' G/CM**2 FOR SHOWER ', * I7,/,' DEPTH',9(A11,1X) ) DO J = 1, NSTEP WRITE(MLONGOUT,212) J*THSTEP,(PLONG(J,K),K=1,9) C C DO NOT CHANGE THIS FORMAT, AS THE CorsTo Root PROGRAM DEPENDS ON IT C 212 FORMAT(' ',F5.0,1P,9(E12.5),0P) ENDDO WRITE(MLONGOUT,213) NSTEP,THSTEP,ISHOWNO, * 'GAMMA ','EM IONIZ','EM CUT','MU IONIZ','MU CUT', * 'HADR IONIZ','HADR CUT','NEUTRINO ',' SUM ' C C DO NOT CHANGE THIS FORMAT, AS THE CorsTo Root PROGRAM DEPENDS ON IT C 213 FORMAT(' LONGITUDINAL ENERGY DEPOSIT IN ',I5, * ' VERTICAL STEPS OF ',F5.0,' G/CM**2 FOR SHOWER ', * I7,/,' DEPTH ',3A11,6A12) DO J = 1, NSTEP DEPSTEP = (2*J-1)*.5*THSTEP WRITE(MLONGOUT,214) DEPSTEP, * (DLONG(J,K),K=1,9) C C DO NOT CHANGE THIS FORMAT, AS THE CorsTo Root PROGRAM DEPENDS ON IT C 214 FORMAT(' ',F6.1,1P,9(E12.5),0P) ENDDO ELSE C FILL THE PERMANENT VALUES OF LONGITUDINAL FIELDS: ARRAYLONG(2) = EVTH(2) !SHOWER NUMBER ARRAYLONG(3) = EVTH(3) !PRIMARY PARTICLE ARRAYLONG(4) = EVTH(4) !PRIMARY ENERGY ARRAYLONG(7) = THICK(DBLE(EVTH(7))) !THICKNESS FIRST INTERACT ARRAYLONG(8) = EVTH(11) !ZENITH ANGLE ARRAYLONG(9) = EVTH(12) !AZIMUTH ANGLE ARRAYLONG(10) = EVTH(61) !ENERGY CUT HADRONS ARRAYLONG(11) = EVTH(62) !ENERGY CUT MUONS ARRAYLONG(12) = EVTH(63) !ENERGY CUT ELECTRONS ARRAYLONG(13) = EVTH(64) !ENERGY CUT GAMMAS C CALCULATE HOW MANY BLOCKS MUST BE WRITTEN JJEND = INT( (NSTEP-1)/26 ) + 1 ARRAYLONG(5) = JJEND + 100*NSTEP !TOTAL # OF LONGI BLOCKS C ! & NUMBER OF STEPS C WRITE THE BLOCKS DO JJ = 1, JJEND C SET ACTUAL BLOCK NUMBER ARRAYLONG(6) = JJ !CURRENT NUMBER OF BLOCK C FILL THE BLOCK WITH ACTUAL VALUES DO J = 1, 26 JPLUS = 10*(J-1) JJJ = J + 26 * (JJ-1) IF ( JJJ .LE. NSTEP ) THEN C FILL IN THE THICKNESS VALUES ARRAYLONG(14+JPLUS) = JJJ * THSTEP DO K = 1, 9 C FILL IN THE PARTICLE NUMBERS ARRAYLONG(14+JPLUS+K) = PLONG(JJJ,K) ENDDO ELSE C FILL THE END OF LAST BLOCK WITH ZEROS DO K = 1, 10 ARRAYLONG(13+JPLUS+K) = 0. ENDDO ENDIF ENDDO C NOW WRITE OUT THE BLOCK CALL TOBUF(ARRAYLONG,0) * WRITE(MONIOU,3333)JJ,ARRAYLONG *3333 FORMAT( 1X,I5,3(1X,E10.5),/,(10(1X,E10.5)) ) ENDDO ENDIF IF ( FLGFIT ) THEN IF ( FPRINT .OR. DEBUG ) WRITE(MONIOU,*) ' ' C PERFORM FIT TO THE LONGITUDINAL DISTRIBUTION OF ALL CHARGED PARTICLES C IF EGS IS SELECTED THIS IS THE DISTRIBUTION WHICH IS TO BE TAKEN IF ( FEGS ) THEN DO 930 J = 0,NSTEP-LPCT1 DEP(J+1) = (J+LPCT1)*THSTEP CHAPAR(J+1) = MAX( PLONG(J+LPCT1,7), 0.D0 ) 930 CONTINUE NSTP = NSTEP + 1 - LPCT1 IF ( FPRINT .OR. DEBUG ) * WRITE(MONIOU,8229) 'ALL CHARGED PARTICLES' 8229 FORMAT(' FIT OF THE HILLAS CURVE ', * ' N(T) = P1*((T-P2)/(P3-P2))**((P3-P2)/(P4+P5*T+P6*T**2))', * ' * EXP((P3-T)/(P4+P5*T+P6*T**2))'/ * ' TO LONGITUDINAL DISTRIBUTION OF ',A35) IF ( FLONGOUT ) * WRITE(MLONGOUT,8229) 'ALL CHARGED PARTICLES' C IF NKG IS SELECTED ONLY THE ELECTRON DISTRIBUTION IS AVAILABLE ELSEIF ( FNKG ) THEN DEP(1) = 0.D0 CHAPAR(1) = 0.D0 DO 931 J = 1,IALT(1) DEP(J+1) = TLEV(J) CHAPAR(J+1) = MAX( SL(J), 0.D0 ) 931 CONTINUE NSTP = IALT(1) + 1 IF ( FPRINT .OR. DEBUG ) WRITE(MONIOU,8229)'NKG ELECTRONS' IF ( FLONGOUT ) * WRITE(MLONGOUT,8229)'NKG ELECTRONS' C IF NONE IS SELECTED IT DOES NOT REALLY MAKE SENSE TO FIT C BUT LET'S TAKE THEN ALL CHARGED WHICH ARE MUONS AND HADRONS ELSE DO 932 J = 0,NSTEP-LPCT1 DEP(J+1) = (J+LPCT1)*THSTEP CHAPAR(J+1) = MAX( PLONG(J+LPCT1,7), 0.D0 ) 932 CONTINUE NSTP = NSTEP + 1 - LPCT1 IF ( FPRINT .OR. DEBUG ) * WRITE(MONIOU,8229) 'MUONS AND CHARGED HADRONS' IF ( FLONGOUT ) * WRITE(MLONGOUT,8229) 'MUONS AND CHARGED HADRONS' ENDIF IF ( NSTP .GT. 6 ) THEN C THERE ARE MORE THAN 6 STEP VALUES, A FIT SHOULD BE POSSIBLE. C DO THE FIT: NPAR AND FPARAM GIVE THE NUMBER OF PARAMETERS USED C AND THE FINAL VALUES FOR THE PARAMETERS. CHISQ GIVES THE CHI**2/DOF C FOR THE FIT. CALL LONGFT(FPARAM,CHI2) IF ( FPRINT .OR. DEBUG ) THEN IF ( FPARAM(1) .GT. 0.D0 ) THEN WRITE(MONIOU,8230) * FPARAM,CHI2,CHI2/SQRT(FPARAM(1))*100.D0 8230 FORMAT(' PARAMETERS = ',1P,6E12.4/ * ' CHI**2/DOF = ',E11.4/ * ' AV. DEVIATION IN % = ',E11.4,0P/) ELSE WRITE(MONIOU,8231) FPARAM,CHI2 8231 FORMAT(' PARAMETERS = ',1P,6E12.4/ * ' CHI**2/DOF = ',E11.4,0P//) ENDIF ENDIF IF ( FLONGOUT ) THEN IF ( FPARAM(1) .GT. 0.D0 ) THEN WRITE(MLONGOUT,8230) FPARAM,CHI2, * CHI2/SQRT(FPARAM(1))*100.D0 ELSE WRITE(MLONGOUT,8231) FPARAM,CHI2 ENDIF ENDIF C STORE RESULT IN END EVENT BLOCK DO 933 K = 1,6 EVTE(255+K) = FPARAM(K) 933 CONTINUE EVTE(262) = CHI2 ELSE WRITE(MONIOU,*) 'NO LONGI. FIT POSSIBLE, ', * ' NSTP = ',NSTP,' TOO SMALL.' DO 934 K = 1,6 EVTE(255+K) = 0. 934 CONTINUE EVTE(262) = 0. ENDIF ENDIF ENDIF c----changed---add CBC++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C Modified by C. Bigongiari 2001 Jan 16 C C Cc>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> c Saves statistics to sta###### file cxxand many lines with comand - simply keep output like in standart CBC++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c---changed--add C WRITE SHOWER END TO OUTPUT BUFFER CALL TOBUF( EVTE,0 ) IF ( LCERFI ) THEN CALL OUTND2 CALL TOBUFC( EVTE,0 ) ENDIF IF ( FPRINT .OR. DEBUG ) WRITE(MONIOU,*) * 'CHERENKOV PH. FROM ELECTRONS = ',SNGL(CERELE), * ' CHERENKOV PH. FROM HADRONS = ',SNGL(CERHAD) CERELE = 0.D0 CERHAD = 0.D0 NRECER = 0 C STORE TABLES IF ( FTABOUT ) THEN WRITE(MTABOUT) G_ARRAY,E_ARRAY,M_ARRAY C STORE LONG DISTRIBUTION OF CHARGED PARTICLES IF ( LLONGI ) THEN WRITE(MTABOUT) THSTEP,NSTEP,(PLONG(II,7),II=1,NSTEP) ENDIF ENDIF IF ( FPRINT .OR. DEBUG ) WRITE(MONIOU,210) ISHOWNO 210 FORMAT(/' END OF SHOWER NO ',I10) DO 19 J = 1,40 JNBIN(J) = JNBIN(J) + INBIN(J) JPBIN(J) = JPBIN(J) + IPBIN(J) JKBIN(J) = JKBIN(J) + IKBIN(J) JHBIN(J) = JHBIN(J) + IHBIN(J) 19 CONTINUE 2 CONTINUE C END OF SHOWER LOOP C----------------------------------------------------------------------- 992 CONTINUE WRITE(MONIOU,*) ' ' CALL PRTIME(TTIME) DO L = 1,NSEQ CALL RMMAQ( ISEED(1,L), L, 'R' ) ENDDO WRITE(MONIOU,159) ISHOWNO,(L,(ISEED(J,L),J=1,3),L=1,NSEQ) 159 FORMAT(' AND RANDOM NUMBER GENERATOR AT END OF EVENT :',I8, * /,(' SEQUENCE = ',I2,' SEED = ',I9 ,' CALLS = ',I9, * ' BILLIONS = ',I9)) C RESET NUMBER OF SHOWERS TO CORRECT VALUE ISHW = I RUNE(3) = REAL(ISHW) TDIFF = ILEFTB - ILEFTA C WRITE RUN END TO OUTPUT BUFFER AND FINISH OUTPUT c---------changed------add CBC++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C Modified by C. Bigongiari 2001 Jan 16 C Cc>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> Cc CALL TOBUF ( RUNE,1 ) C call jcendrun(rune) Cc IF ( LCERFI ) CALL TOBUFC( RUNE,1 ) Cc>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> C C- write Run End CBC++++++++++++++++++++++++++++++++++++++++++++++++++++++++++C c---------changed------add CALL TOBUF ( RUNE,1 ) IF ( LCERFI ) CALL TOBUFC( RUNE,1 ) C TIME SINCE BEGINNING NO VALID INFORMATION CALL TIMER( ILEFTB ) TDIFF = ILEFTB - ILEFTA C MEAN VALUE FOR FIRST INTERACTION ALTITUDE (G/CM**2) IF ( ISHW .GT. 1 ) THEN CHISM2 = SQRT( ABS(CHISM2-CHISUM**2/ISHW) / (ISHW-1) ) CHISUM = CHISUM / ISHW ELSE CHISM2 = 0.D0 ENDIF C OUTPUTS FOR ALL SHOWERS WRITE(MONIOU,201) ISHW,TDIFF,TDIFF/ISHW,IRECOR,IRECOR/ISHW, * CHISUM,CHISM2 201 FORMAT('1',10('='),' RUN SUMMARY ',56('=')// * ' NUMBER OF GENERATED EVENTS = ',I10,/ * ' TOTAL TIME USED = ',F12.0,' SEC'/ * ' TIME PER EVENT = ',F14.2,' SEC'/ * ' TOTAL SPACE ON MPATAP USED = ',I12,' WORDS'/ * ' SPACE PER EVENT ON MPATAP = ',I12,' WORDS'/ * ' AVERAGE HEIGHT OF 1ST INT. = ',F10.3,' +-',F10.3,' G/CM**2'/) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF ( ISHW .GT. 1 ) THEN C DO PRINTING OF AVERAGES ONLY IF MORE THAN 1 SHOWER IS SIMULATED C ENERGY - MULTIPLICITY MATRIX FOR ALL SHOWERS WRITE(MONIOU,209) (K,K=1,13),(J,(MULTOT(J,K),K=1,13), * 10**((J-4.)/3.),10**((J-3.)/3.),J=1,39), * 1,(INT(10**((K-1.)/3.)+1),K = 2,13), * 2,(INT(10**((K )/3.) ),K = 2,13) 209 FORMAT(//' ENERGY - MULTIPLICITY MATRIX FOR ALL SHOWERS'/ * ' ENERGY RUNS VERTICALLY, MULTIPLICITY HORIZONTALLY'//, * ' ',6X,5I10,3I8,5I6,' ENERGY RANGE (GEV)'/ * 39(/' ',I4,1X,I11,4I10,3I8,5I6,1X,1P,2E10.1,0P)// * ' MULT. ',5I10,3I8,5I6,4X,'LOWER BIN LIMIT'/ * ' RANGE ',5I10,3I8,5I6,4X,'UPPER BIN LIMIT') C GET MEAN OF ELASTICITY FOR ENERGY BINS DO 3377 J = 1,40 NELMEA = 0 DO 3378 K = 1,10 NELMEA = NELMEA + IELDPA(J,K) 3378 CONTINUE IF ( NELMEA .NE. 0 ) ELMEAA(J) = ELMEAA(J) / NELMEA 3377 CONTINUE C PRINT ENERGY - ELASTICITY MATRIX FOR ALL SHOWERS WRITE(MONIOU,408) (K,K=1,10), (J,(IELDPA(J,K),K=1,10), * ELMEAA(J),10**((J-4.D0)/3.D0),10**((J-3.)/3.D0),J=1,39), * ((K-1)*0.1D0,K=1,10),(K*0.1D0,K=1,10) 408 FORMAT (//' ENERGY - ELASTICITY MATRIX FOR ALL SHOWERS'/ * ' ENERGY RUNS VERTICALLY, ELASTICITY HORIZONTALLY'// * ' ',5X,7I9,3I10,' MEAN EL. ENERGY RANGE (GEV)'/ * 39(/' ',I4,1X,7I9,3I10,2X,1P,E10.3,2E10.1,0P)// * ' ELA. ',7F9.2,3F10.2,5X,'LOWER BIN LIMIT'/ * ' RANGE',7F9.2,3F10.2,5X,'UPPER BIN LIMIT') WRITE(MONIOU,204) 204 FORMAT (//' INTERACTIONS PER KINETIC ENERGY INTERVAL FOR ALL', * ' SHOWERS'//' BIN LOWER LIMIT UPPER LIMIT ', * 'NUCLEON PIONS KAONS S.BARYONS ', * ' TOTAL'/ 12X,'IN GEV',9X,'IN GEV',7X, * ' EVENTS EVENTS EVENTS EVENTS '//) WRITE(MONIOU,207) (J,SABIN(J),SBBIN(J),JNBIN(J),JPBIN(J), * JKBIN(J),JHBIN(J),JNBIN(J)+JPBIN(J)+JKBIN(J)+JHBIN(J),J=1,40) 207 FORMAT(' ',I5,1P,2E15.4,0P,F14.0,3F14.0,F15.0) C CALCULATE MEAN VALUES AND STANDARD DEVIATIONS OF PARTICLE NUMBERS IF ( ISHW .GT. 1 ) THEN DO 879 K = 1,25 IOBSLV = NOBSLV DO J = 1,IOBSLV MPART2(J,K) = SQRT( ABS(MPART2(J,K)-MPARTO(J,K)**2/ISHW) * /(ISHW-1) ) MPARTO(J,K) = MPARTO(J,K)/ISHW ENDDO 879 CONTINUE ELSE DO 881 K = 1,25 IOBSLV = NOBSLV DO J = 1,IOBSLV MPART2(J,K) = 0.D0 ENDDO 881 CONTINUE ENDIF C PRINT MEAN VALUES AND STANDARD DEVIATIONS OF PARTICLE NUMBERS IOBSLV = MIN( 3, NOBSLV ) WRITE(MONIOU,854) (K,K=1,IOBSLV) 854 FORMAT (/ ' AVERAGE NUMBER OF PARTICLES PER EVENT :'/ * ' FROM LEVEL NUMBER ', 3(10X,I10,10X) ) WRITE(MONIOU,855) (OBSLEV(K),K=1,IOBSLV) 855 FORMAT ( ' HEIGHT IN CM',1P,3(20X,E10.3)/) WRITE(MONIOU,856) (THCKOB(K),K=1,IOBSLV) 856 FORMAT ( ' HEIGHT IN G/CM**2',1P,3(14X,E10.3,6X)/) WRITE(MONIOU,778)'PROTONS ',(MPROTO(K),MPROT2(K),K=1,IOBSLV) WRITE(MONIOU,778)'ANTIPROTONS ',(MPROTB(K),MPRTB2(K),K=1,IOBSLV) WRITE(MONIOU,778)'NEUTRONS ',(MNEUTR(K),MNETR2(K),K=1,IOBSLV) WRITE(MONIOU,778)'ANTINEUTRONS',(MNEUTB(K),MNETB2(K),K=1,IOBSLV) WRITE(MONIOU,777)'PHOTONS ',(MPHOTO(K),MPHOT2(K),K=1,IOBSLV) WRITE(MONIOU,777)'ELECTRONS ',(MELECT(K),MELEC2(K),K=1,IOBSLV) WRITE(MONIOU,777)'POSITRONS ',(MPOSIT(K),MPOSI2(K),K=1,IOBSLV) WRITE(MONIOU,778)'MU - ',(MMUM (K),MMUM2 (K),K=1,IOBSLV) WRITE(MONIOU,778)'MU + ',(MMUP (K),MMUP2 (K),K=1,IOBSLV) WRITE(MONIOU,778)'PI 0 ',(MPI0 (K),MPI02 (K),K=1,IOBSLV) WRITE(MONIOU,778)'PI - ',(MPIM (K),MPIM2 (K),K=1,IOBSLV) WRITE(MONIOU,778)'PI + ',(MPIP (K),MPIP2 (K),K=1,IOBSLV) WRITE(MONIOU,778)'K0L ',(MK0L (K),MK0L2 (K),K=1,IOBSLV) WRITE(MONIOU,778)'K0S ',(MK0S (K),MK0S2 (K),K=1,IOBSLV) WRITE(MONIOU,778)'K - ',(MKMI (K),MKMI2 (K),K=1,IOBSLV) WRITE(MONIOU,778)'K + ',(MKPL (K),MKPL2 (K),K=1,IOBSLV) WRITE(MONIOU,778)'STR. BARYONS',(MHYP (K),MHYP2 (K),K=1,IOBSLV) WRITE(MONIOU,778)'DEUTERONS ',(MDEUT (K),MDEUT2(K),K=1,IOBSLV) WRITE(MONIOU,778)'TRITONS ',(MTRIT (K),MTRIT2(K),K=1,IOBSLV) WRITE(MONIOU,778)'ALPHAS ',(MALPHA(K),MALPH2(K),K=1,IOBSLV) WRITE(MONIOU,778)'OTHER PART. ',(MOTHER(K),MOTH2 (K),K=1,IOBSLV) WRITE(MONIOU,*) WRITE(MONIOU,778) 'DECAYED MUONS',MMUOND 777 FORMAT(' NO OF ',A12,' = ',1P,3(E13.6,' +-',E13.6,' '),0P) 778 FORMAT(' NO OF ',A12,' = ',3(F13.1,' +-',F13.1,' ')) IF ( NOBSLV .GT. 3 ) THEN IOBSLV = MIN( 6, NOBSLV ) WRITE(MONIOU,854) (K,K=4,IOBSLV) WRITE(MONIOU,855) (OBSLEV(K),K=4,IOBSLV) WRITE(MONIOU,856) (THCKOB(K),K=4,IOBSLV) WRITE(MONIOU,778)'PROTONS ',(MPROTO(K),MPROT2(K),K=4,IOBSLV) WRITE(MONIOU,778)'ANTIPROTONS ',(MPROTB(K),MPRTB2(K),K=4,IOBSLV) WRITE(MONIOU,778)'NEUTRONS ',(MNEUTR(K),MNETR2(K),K=4,IOBSLV) WRITE(MONIOU,778)'ANTINEUTRONS',(MNEUTB(K),MNETB2(K),K=4,IOBSLV) WRITE(MONIOU,777)'PHOTONS ',(MPHOTO(K),MPHOT2(K),K=4,IOBSLV) WRITE(MONIOU,777)'ELECTRONS ',(MELECT(K),MELEC2(K),K=4,IOBSLV) WRITE(MONIOU,777)'POSITRONS ',(MPOSIT(K),MPOSI2(K),K=4,IOBSLV) WRITE(MONIOU,778)'MU - ',(MMUM (K),MMUM2 (K),K=4,IOBSLV) WRITE(MONIOU,778)'MU + ',(MMUP (K),MMUP2 (K),K=4,IOBSLV) WRITE(MONIOU,778)'PI 0 ',(MPI0 (K),MPI02 (K),K=4,IOBSLV) WRITE(MONIOU,778)'PI - ',(MPIM (K),MPIM2 (K),K=4,IOBSLV) WRITE(MONIOU,778)'PI + ',(MPIP (K),MPIP2 (K),K=4,IOBSLV) WRITE(MONIOU,778)'K0L ',(MK0L (K),MK0L2 (K),K=4,IOBSLV) WRITE(MONIOU,778)'K0S ',(MK0S (K),MK0S2 (K),K=4,IOBSLV) WRITE(MONIOU,778)'K - ',(MKMI (K),MKMI2 (K),K=4,IOBSLV) WRITE(MONIOU,778)'K + ',(MKPL (K),MKPL2 (K),K=4,IOBSLV) WRITE(MONIOU,778)'STR. BARYONS',(MHYP (K),MHYP2 (K),K=4,IOBSLV) WRITE(MONIOU,778)'DEUTERONS ',(MDEUT (K),MDEUT2(K),K=4,IOBSLV) WRITE(MONIOU,778)'TRITONS ',(MTRIT (K),MTRIT2(K),K=4,IOBSLV) WRITE(MONIOU,778)'ALPHAS ',(MALPHA(K),MALPH2(K),K=4,IOBSLV) WRITE(MONIOU,778)'OTHER PART. ',(MOTHER(K),MOTH2 (K),K=4,IOBSLV) WRITE(MONIOU,*) IF ( NOBSLV .GT. 6 ) THEN IOBSLV = MIN( 9, NOBSLV ) WRITE(MONIOU,854) (K,K=7,IOBSLV) WRITE(MONIOU,855) (OBSLEV(K),K=7,IOBSLV) WRITE(MONIOU,856) (THCKOB(K),K=7,IOBSLV) WRITE(MONIOU,778)'PROTONS ',(MPROTO(K),MPROT2(K),K=7,IOBSLV) WRITE(MONIOU,778)'ANTIPROTONS ',(MPROTB(K),MPRTB2(K),K=7,IOBSLV) WRITE(MONIOU,778)'NEUTRONS ',(MNEUTR(K),MNETR2(K),K=7,IOBSLV) WRITE(MONIOU,778)'ANTINEUTRONS',(MNEUTB(K),MNETB2(K),K=7,IOBSLV) WRITE(MONIOU,777)'PHOTONS ',(MPHOTO(K),MPHOT2(K),K=7,IOBSLV) WRITE(MONIOU,777)'ELECTRONS ',(MELECT(K),MELEC2(K),K=7,IOBSLV) WRITE(MONIOU,777)'POSITRONS ',(MPOSIT(K),MPOSI2(K),K=7,IOBSLV) WRITE(MONIOU,778)'MU - ',(MMUM (K),MMUM2 (K),K=7,IOBSLV) WRITE(MONIOU,778)'MU + ',(MMUP (K),MMUP2 (K),K=7,IOBSLV) WRITE(MONIOU,778)'PI 0 ',(MPI0 (K),MPI02 (K),K=7,IOBSLV) WRITE(MONIOU,778)'PI - ',(MPIM (K),MPIM2 (K),K=7,IOBSLV) WRITE(MONIOU,778)'PI + ',(MPIP (K),MPIP2 (K),K=7,IOBSLV) WRITE(MONIOU,778)'K0L ',(MK0L (K),MK0L2 (K),K=7,IOBSLV) WRITE(MONIOU,778)'K0S ',(MK0S (K),MK0S2 (K),K=7,IOBSLV) WRITE(MONIOU,778)'K - ',(MKMI (K),MKMI2 (K),K=7,IOBSLV) WRITE(MONIOU,778)'K + ',(MKPL (K),MKPL2 (K),K=7,IOBSLV) WRITE(MONIOU,778)'STR. BARYONS',(MHYP (K),MHYP2 (K),K=7,IOBSLV) WRITE(MONIOU,778)'DEUTERONS ',(MDEUT (K),MDEUT2(K),K=7,IOBSLV) WRITE(MONIOU,778)'TRITONS ',(MTRIT (K),MTRIT2(K),K=7,IOBSLV) WRITE(MONIOU,778)'ALPHAS ',(MALPHA(K),MALPH2(K),K=7,IOBSLV) WRITE(MONIOU,778)'OTHER PART. ',(MOTHER(K),MOTH2 (K),K=7,IOBSLV) WRITE(MONIOU,*) IF ( NOBSLV .GT. 9 ) THEN IOBSLV = MIN( 10, NOBSLV ) WRITE(MONIOU,854) (K,K=9,IOBSLV) WRITE(MONIOU,855) (OBSLEV(K),K=9,IOBSLV) WRITE(MONIOU,856) (THCKOB(K),K=9,IOBSLV) WRITE(MONIOU,778)'PROTONS ',(MPROTO(K),MPROT2(K),K=9,IOBSLV) WRITE(MONIOU,778)'ANTIPROTONS ',(MPROTB(K),MPRTB2(K),K=9,IOBSLV) WRITE(MONIOU,778)'NEUTRONS ',(MNEUTR(K),MNETR2(K),K=9,IOBSLV) WRITE(MONIOU,778)'ANTINEUTRONS',(MNEUTB(K),MNETB2(K),K=9,IOBSLV) WRITE(MONIOU,777)'PHOTONS ',(MPHOTO(K),MPHOT2(K),K=9,IOBSLV) WRITE(MONIOU,777)'ELECTRONS ',(MELECT(K),MELEC2(K),K=9,IOBSLV) WRITE(MONIOU,777)'POSITRONS ',(MPOSIT(K),MPOSI2(K),K=9,IOBSLV) WRITE(MONIOU,778)'MU - ',(MMUM (K),MMUM2 (K),K=9,IOBSLV) WRITE(MONIOU,778)'MU + ',(MMUP (K),MMUP2 (K),K=9,IOBSLV) WRITE(MONIOU,778)'PI 0 ',(MPI0 (K),MPI02 (K),K=9,IOBSLV) WRITE(MONIOU,778)'PI - ',(MPIM (K),MPIM2 (K),K=9,IOBSLV) WRITE(MONIOU,778)'PI + ',(MPIP (K),MPIP2 (K),K=9,IOBSLV) WRITE(MONIOU,778)'K0L ',(MK0L (K),MK0L2 (K),K=9,IOBSLV) WRITE(MONIOU,778)'K0S ',(MK0S (K),MK0S2 (K),K=9,IOBSLV) WRITE(MONIOU,778)'K - ',(MKMI (K),MKMI2 (K),K=9,IOBSLV) WRITE(MONIOU,778)'K + ',(MKPL (K),MKPL2 (K),K=9,IOBSLV) WRITE(MONIOU,778)'STR. BARYONS',(MHYP (K),MHYP2 (K),K=9,IOBSLV) WRITE(MONIOU,778)'DEUTERONS ',(MDEUT (K),MDEUT2(K),K=9,IOBSLV) WRITE(MONIOU,778)'TRITONS ',(MTRIT (K),MTRIT2(K),K=9,IOBSLV) WRITE(MONIOU,778)'ALPHAS ',(MALPHA(K),MALPH2(K),K=9,IOBSLV) WRITE(MONIOU,778)'OTHER PART. ',(MOTHER(K),MOTH2 (K),K=9,IOBSLV) WRITE(MONIOU,*) ENDIF ENDIF ENDIF C PRINT OUT NKG RESULT FOR ALL SHOWERS IF SELECTED IF ( FNKG ) CALL MITAGE C CALCULATE MEAN VALUES AND SIGMAS OF LONGITUDINAL DISTRIBUTION IF ( LLONGI ) THEN IF ( ISHW .GT. 1 ) THEN DO J = 0,NSTEP DO K = 1,9 SDLONG(J,K) = SQRT( MAX( 0.D0, * (SDLONG(J,K)-ADLONG(J,K)**2/ISHW)/(ISHW-1) ) ) ADLONG(J,K) = ADLONG(J,K)/ISHW ENDDO DO K = 1,9 SELONG(J,K) = SQRT( MAX( 0.D0, * (SELONG(J,K)-AELONG(J,K)**2/ISHW)/(ISHW-1) ) ) AELONG(J,K) = AELONG(J,K)/ISHW SPLONG(J,K) = SQRT( MAX( 0.D0, * (SPLONG(J,K)-APLONG(J,K)**2/ISHW)/(ISHW-1) ) ) APLONG(J,K) = APLONG(J,K)/ISHW ENDDO ENDDO ELSE DO J = 0,NSTEP DO K = 1,9 SDLONG(J,K) = 0.D0 ENDDO DO K = 1,9 SELONG(J,K) = 0.D0 SPLONG(J,K) = 0.D0 ENDDO ENDDO ENDIF C PRINT AVERAGE LONGITUDINAL PARTICLE DISTRIBUTIONS WRITE(MONIOU,911) THSTEP, * 'GAMMAS ','POSITRONS','ELECTRONS','MU+ ','MU- ', * (J*THSTEP,(APLONG(J,K),SPLONG(J,K),K=1,5),J=LPCT0,NSTEP) 911 FORMAT(/' AVERAGE LONGITUDINAL PARTICLE DISTRIBUTION IN ', * 'STEPS OF ',F5.0,' G/CM**2 '/' ',132('=')/ * ' DEPTH',6X,A9,16X,2(A10,17X),A9,16X,A9 // * (' ',F5.0,1X,1P,E10.4,'+-',E10.4,0P,1X,F13.0,'+-',F12.0, * 1X,F13.0,'+-',F12.0,1X,F10.0,'+-',F11.0, * 1X,F10.0,'+-',F11.0 )) WRITE(MONIOU,912) THSTEP, * 'HADRONS','CHARGED','NUCLEI','CHERENKOV', * (J*THSTEP,(APLONG(J,K),SPLONG(J,K),K=6,9),J=LPCT0,NSTEP) 912 FORMAT(/' AVERAGE LONGITUDINAL PARTICLE DISTRIBUTION IN ', * 'STEPS OF ',F5.0,' G/CM**2 '/' ',118('=')/ * ' DEPTH',8X,A9,17X,A10,17X,A9,21X,A9 // * (' ',F5.0,1X,F11.1,'+-',F11.1,1X,F13.0,'+-',F13.0, * 2X,F10.1,'+-',F10.1,1X,1P,E16.6,'+-',E16.6,0P)) C PRINT AVERAGE LONGITUDINAL ENERGY DISTRIBUTIONS WRITE(MONIOU,915) THSTEP, * 'GAMMAS ','POSITRONS','ELECTRONS','MU+ ','MU- ', * (J*THSTEP,(AELONG(J,K),SELONG(J,K),K=1,5),J=LPCT0,NSTEP) 915 FORMAT(/' AVERAGE LONGITUDINAL ENERGY DISTRIBUTION [GEV] ', * 'IN STEPS OF ',F5.0,' G/CM**2 '/' ',131('=')/ * ' DEPTH',6X,A9,4(16X,A9),// * (' ',F5.0,1X,1P,5(1X,E11.5,'+-',E11.5),0P)) WRITE(MONIOU,916) THSTEP, * 'HADRONS','CHARGED','NUCLEI','ENERGYSUM', * (J*THSTEP,(AELONG(J,K),SELONG(J,K),K=6,9),J=LPCT0,NSTEP) 916 FORMAT(/' AVERAGE LONGITUDINAL ENERGY DISTRIBUTION [GEV] ', * 'IN STEPS OF ',F5.0,' G/CM**2 '/' ',110('=')/ * ' DEPTH',7X,3(A8,17X),2X,A10, // (' ',F5.0,1X,1P, * 3(1X,E11.5,'+-',E11.5),1X,E13.7,'+-',E13.7,0P)) C PRINT AVERAGE LONGITUDINAL ENERGY DEPOSIT ADLONGSUM = 0.D0 DO K = 1,9 DO J = 0,NSTEP ADLONG(1170,K) = ADLONG(1170,K) + ADLONG(J,K) ENDDO IF ( K .NE. 9 ) ADLONGSUM = ADLONGSUM + ADLONG(1170,K) ENDDO WRITE(MONIOU,913) THSTEP, * 'GAMMA ', 'EM IONIZ','EM CUT','MU IONIZ','MU CUT', * ((2*J-1)*.5*THSTEP,(ADLONG(J,K),SDLONG(J,K),K=1,5), * J=LPCT0+1,NSTEP) 913 FORMAT(/' AVERAGE LONGITUDINAL ENERGY DEPOSIT [GEV] IN ', * 'STEPS OF ', F5.0,' G/CM**2 '/' ',132('=')/ * ' DEPTH',6X,A11,14X,2(A10,17X),A9,16X,A9 // * (' ',F6.1, F10.0,'+-',F10.0,1X,F13.0,'+-',F12.0, * 1X,F13.0,'+-',F12.0,1X,F10.0,'+-',F11.0, * 1X,F10.0,'+-',F11.0 )) WRITE(MONIOU,917) (ADLONG(1170,K),K=1,5) 917 FORMAT(' ',20X,'AVERAGE LONGITUDINAL ENERGY SUM [GEV] '/ * ' ',4X,F13.1,13X,F13.1,14X,F14.1,12X,F13.1,11X,F13.1) WRITE(MONIOU,914) THSTEP, * 'HADR IONIZ','HADR CUT','NEUTRINO',' SUM', * ((2*J-1)*.5*THSTEP,(ADLONG(J,K),SDLONG(J,K),K=6,9), * J=LPCT0+1,NSTEP) 914 FORMAT(/' AVERAGE LONGITUDINAL ENERGY DEPOSIT [GEV] IN ', * 'STEPS OF ',F5.0,' G/CM**2 '/' ',112('=')/ * ' DEPTH',7X,A10,16X,A10,16X,A10,15X,A9 // * (' ',F6.1, F11.1,'+-',F11.1,1X,F13.0,'+-',F13.0, * 2X,F10.1,'+-',F10.1,1X,F13.1,'+-',F13.1)) WRITE(MONIOU,918) (ADLONG(1170,K),K=6,8) 918 FORMAT(' ',20X,'AVERAGE LONGITUDINAL ENERGY SUM [GEV] ', * /,' ',4X,F13.1,14X,F14.1,14X,F12.1) WRITE(MONIOU,919) ADLONGSUM 919 FORMAT(' ',20X,' ENERGY SUM = ',1P,E15.7,0P,' GEV') IF ( FLGFIT ) THEN C PERFORM FIT TO THE LONGITUDINAL DISTRIBUTION OF ALL CHARGED PARTICLES C IF EGS IS SELECTED THIS IS THE DISTRIBUTION WHICH IS TO BE TAKEN IF ( FEGS ) THEN DO 730 J = 0,NSTEP-LPCT0 DEP(J+1) = (J+LPCT0)*THSTEP CHAPAR(J+1) = MAX( APLONG(J+LPCT0,7), 0.D0 ) 730 CONTINUE NSTP = NSTEP + 1 - LPCT0 WRITE(MONIOU,8229) 'AVERAGE ALL CHARGED PARTICLES' C IF NKG IS SELECTED ONLY THE ELECTRON DISTRIBUTION IS AVAILABLE ELSEIF ( FNKG ) THEN DEP(1) = 0.D0 CHAPAR(1) = 0.D0 DO 731 J = 1,IALT(1) DEP(J+1) = TLEV(J) CHAPAR(J+1) = MAX( SEL(J)/ISHW, 0.D0 ) 731 CONTINUE NSTP = IALT(1) + 1 WRITE(MONIOU,8229) 'AVERAGE NKG ELECTRONS' C IF NONE IS SELECTED IT DOES NOT REALLY MAKE SENSE TO FIT C BUT LET'S TAKE THEN ALL CHARGED WHICH ARE MUONS AND HADRONS ELSE DO 732 J = 0,NSTEP-LPCT0 DEP(J+1) = (J+LPCT0)*THSTEP CHAPAR(J+1) = MAX( APLONG(J+LPCT0,7), 0.D0 ) 732 CONTINUE NSTP = NSTEP + 1 - LPCT0 WRITE(MONIOU,8229) 'AVERAGE MUONS AND CHARGED HADRONS' ENDIF IF ( NSTP .GT. 6 ) THEN C THERE ARE MORE THAN 6 STEP VALUES, A FIT SHOULD BE POSSIBLE. C DO THE FIT: NPAR AND FPARAM GIVE THE NUMBER OF PARAMETERS USED C AND THE FINAL VALUES FOR THE PARAMETERS. CHISQ GIVES THE CHI**2/DOF C FOR THE FIT. CALL LONGFT(FPARAM,CHI2) IF ( FPARAM(1) .GT. 0.D0 ) THEN WRITE(MONIOU,8230) FPARAM,CHI2, * CHI2/SQRT(FPARAM(1))*100.D0 ELSE WRITE(MONIOU,8231) FPARAM,CHI2 ENDIF ELSE WRITE(MONIOU,*) 'NO LONGI. FIT POSSIBLE, ', * ' NSTP = ',NSTP,' TOO SMALL.' ENDIF ENDIF ENDIF ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C CONTROL PRINT OUTPUT OF CONSTANTS IF ( DEBUG ) THEN CALL STAEND WRITE(MDEBUG,*) 'AAMAIN: STAEND CALLED' ENDIF c------changed ---add CBC+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C Modified by C. Bigongiari 2001 Jan 16 C Cc>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> C call jcenddata(runh,rune) Cc>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c------changed---add WRITE(MONIOU,*) ' ' CALL PRTIME(TTIME) WRITE(MONIOU,101) 101 FORMAT (/' ',10('='),' END OF RUN ',48('=')) C CLOSE ALL OPEN UNITS IF ( MONIOU .NE. 6 ) CLOSE(MONIOU) IF ( MDEBUG .NE. 6 ) CLOSE(MDEBUG) CLOSE(MEXST) IF ( FPAROUT ) CLOSE(MPATAP) IF ( FTABOUT ) CLOSE(MTABOUT) IF ( FLONGOUT .AND. LLONGI ) CLOSE(MLONGOUT) IF ( LCERFI ) CLOSE(MCETAP) STOP END *CMZ : 06/11/2000 10.53.24 by D. HECK IK3 FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE ADDANG( COST0,PHI0, COST,PHI, COST1,PHI1 ) C----------------------------------------------------------------------- C ADD(ITION OF) ANG(LES) C C ADDITION OF ANGLES IS DONE BY SEQUENTIAL ROTATIONS : C 1. ROTATE VECTOR AROUND Z AXIS BY -PHI0 C 2. ROTATE VECTOR AROUND Y AXIS BY -THETA0 NOW VECTOR IS (0,0,1) C C 3. ROTATE VECTOR AROUND Y AXIS BY THETA ANGLES TO BE ADDED C 4. ROTATE VECTOR AROUND Z AXIS BY PHI C C 5. ROTATE VECTOR AROUND Y AXIS BY THETA0 C 6. ROTATE VECTOR AROUND Z AXIS BY -PHI0 C NOW VECTOR IS (X,Y,Z) WITH COST1 = Z C AND TAN(PHI1) = Y/X C THIS SUBROUTINE IS CALLED FROM MANY ROUTINES. C ARGUMENTS: C COST0 = COSINE THETA OF PARTICLE BEFORE C PHI0 = PHI OF PARTICLE BEFORE C COST = COSINE THETA OF ANGLE TO ADD C PHI = PHI OF ANGLE TO ADD C COST1 = COSINE THETA OF PARTICLE AFTER ADDITION OF ANGLES C PHI1 = PHI THETA OF PARTICLE AFTER ADDITION OF ANGLES C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DOUBLE PRECISION A,COST,COST0,COST1,CPHI,CPHI0,PHI,PHI0,PHI1, * SINT,SINT0,SPHI,SPHI0,XXX,YYY,ZZZ SAVE C----------------------------------------------------------------------- CC IF ( DEBUG ) WRITE(MDEBUG,*) 'ADDANG:' SINT0 = SQRT(1.D0-COST0**2) SINT = SQRT(1.D0-COST **2) SPHI0 = SIN(PHI0) CPHI0 = COS(PHI0) SPHI = SIN(PHI) CPHI = COS(PHI) A = COST0 * CPHI * SINT + COST * SINT0 XXX = A * CPHI0 - SPHI0 * SINT * SPHI YYY = A * SPHI0 + CPHI0 * SINT * SPHI ZZZ = COST * COST0 - SINT0 * SINT * CPHI C GET NEW COSINE(THETA) AND PHI COST1 = MIN(ZZZ, 1.D0) IF ( YYY .EQ. 0.D0 .AND. XXX .EQ. 0.D0 ) THEN PHI1 = 0.D0 ELSE PHI1 = ATAN2( YYY, XXX ) ENDIF RETURN END *CMZ : 18/10/2000 09.15.11 by D. HECK IK3 FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE ADDANI( COST0,PHI0, COST1,PHI1, DCTH,DPHI ) C----------------------------------------------------------------------- C ADD(ITION OF) AN(GLES) I(NVERTED) C C GIVEN TWO DIRECTIONS (0 AND 1) IN A COMMON SYSTEM OF REFERENCE. C FIND DCTH AND DPHI SUCH, THAT THE SUBROUT. ADDANG TRANSFORMS C (COST0,PHI0) BY ADDING (DCTH,DPHI) INTO (COST1,PHI1). C CALCULATION IS DONE BY SEQUENTIAL ROTATIONS : C 1. ROTATE VECTOR AROUND Z AXIS BY -PHI1 C 2. ROTATE VECTOR AROUND Y AXIS BY -THETA1 C NOW VECTOR IS (X,Y,Z) WITH DCTH = Z C AND TAN(DPHI) = Y/X C THIS SUBROUTINE IS CALLED FROM MUDECY. C ARGUMENTS: C COST0 = COSINE THETA OF PARTICLE BEFORE C PHI0 = PHI OF PARTICLE BEFORE C COST1 = COSINE THETA OF PARTICLE C PHI1 = PHI OF PARTICLE C DCTH = COSINE THETA OF ANGLE C DPHI = PHI OF ANGLE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DOUBLE PRECISION COST0,COST1,CP,CP1,CT,CT1,DCTH,DPHI,PHI0,PHI1, * SP,SP1,ST,ST1,X,XX,Y,YY,Z,ZZ SAVE C----------------------------------------------------------------------- CC IF ( DEBUG ) WRITE(MDEBUG,*) 'ADDANI:' CT = COST0 ST = SQRT(1.D0-CT**2) CP = COS(PHI0) SP = SIN(PHI0) CT1 = COST1 ST1 = SQRT(1.D0-CT1**2) CP1 = COS(PHI1) SP1 = SIN(PHI1) X = ST1 * CP1 Y = ST1 * SP1 Z = CT1 XX = CT*CP*X + CT*SP*Y - ST*Z YY = (-SP) *X + CP *Y ZZ = ST*CP*X + ST*SP*Y + CT*Z C GET NEW COSINE(THETA) AND PHI DCTH = ZZ IF ( YY .NE. 0.D0 .OR. XX .NE. 0.D0 ) THEN DPHI = ATAN2( YY, XX ) ELSE DPHI = 0.D0 ENDIF RETURN END *CMZ : 28/02/2002 13.08.19 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 16/05/95 C======================================================================= SUBROUTINE AMOEBA(P,Y,MP,NP,NDIM,FTOL,FUNK,ITER,IFLAG) C----------------------------------------------------------------------- C C FITTING ROUTINE C REFERENCE : NUMERICAL RECIPES, W.H. PRESS ET AL., C CAMBRIDGE UNIVERSITY PRESS, 1992 ISBN 0 521 43064 X C ADAPTED FOR DOUBLE PRECISION C THIS SUBROUTINE IS CALLED FROM LONGFT. C ARGUMENTS: C P = ARRAY (NPAR+1,NPAR) WITH PARAMETERS FOR FIT C Y = ARRAY WITH ERRORS C MP = NUMBER NPAR+1 C NDIM = NUMBER NPAR OF FREE VARIABLES C FTOL = TOLERANCE OF FIT C FUNK = EXTERNAL FUNKTION (GIVING DERIVATIVES) C ITER = ITERATION COUNTER C IFLAG = ERROR FLAG C C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. INTEGER ITMAX,NMAX C MAXIMUM NUMBER OF TRIAL PER CALL PARAMETER (ITMAX=5000) PARAMETER (NMAX=20) INTEGER MP,NP DOUBLE PRECISION FTOL,P(MP,NP),PSUM(NMAX), * RTOL,SUM,SWAP,Y(MP),YSAVE,YTRY INTEGER I,IFLAG,IHI,ILO,INHI,ITER,J,M,N,NDIM DOUBLE PRECISION AMOTRY,FUNK SAVE EXTERNAL AMOTRY,FUNK C USES AMOTRY,FUNK C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'AMOEBA:' IFLAG = 0 ITER = 0 1 DO 12 N = 1,NDIM SUM = 0.D0 DO 11 M = 1,NDIM+1 SUM = SUM + P(M,N) 11 CONTINUE PSUM(N) = SUM 12 CONTINUE 2 ILO = 1 IF ( Y(1) .GT. Y(2) ) THEN IHI = 1 INHI = 2 ELSE IHI = 2 INHI = 1 ENDIF DO 13 I = 1,NDIM+1 IF ( Y(I) .LE. Y(ILO) ) ILO = I IF ( Y(I) .GT. Y(IHI) ) THEN INHI = IHI IHI = I ELSEIF ( Y(I) .GT. Y(INHI) ) THEN IF ( I .NE. IHI ) INHI = I ENDIF 13 CONTINUE RTOL = 2.D0*ABS(Y(IHI)-Y(ILO))/(ABS(Y(IHI))+ABS(Y(ILO))) IF ( RTOL .LT. FTOL ) THEN SWAP = Y(1) Y(1) = Y(ILO) Y(ILO) = SWAP DO 14 N = 1,NDIM SWAP = P(1,N) P(1,N) = P(ILO,N) P(ILO,N) = SWAP 14 CONTINUE RETURN ENDIF IF ( ITER .GE.ITMAX ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) 'AMOEBA: ITMAX EXCEEDED IN AMOEBA' IFLAG = 1 RETURN ENDIF ITER = ITER + 2 YTRY = AMOTRY(P,Y,PSUM,MP,NP,NDIM,FUNK,IHI,-1.0D0) IF ( YTRY .LE. Y(ILO) ) THEN YTRY = AMOTRY(P,Y,PSUM,MP,NP,NDIM,FUNK,IHI,2.0D0) ELSEIF ( YTRY .GE. Y(INHI) ) THEN YSAVE = Y(IHI) YTRY = AMOTRY(P,Y,PSUM,MP,NP,NDIM,FUNK,IHI,0.5D0) IF ( YTRY .GE. YSAVE ) THEN DO 16 I = 1,NDIM+1 IF ( I .NE. ILO ) THEN DO 15 J = 1,NDIM PSUM(J) = 0.5D0 * (P(I,J) + P(ILO,J)) P(I,J) = PSUM(J) 15 CONTINUE Y(I) = FUNK(PSUM) ENDIF 16 CONTINUE ITER = ITER + NDIM GOTO 1 ENDIF ELSE ITER = ITER - 1 ENDIF GOTO 2 END C======================================================================= DOUBLE PRECISION FUNCTION AMOTRY(P,Y,PSUM,MP,NP,NDIM,FUNK,IHI,FAC) C----------------------------------------------------------------------- C C REFERENCE : NUMERICAL RECIPES, W.H. PRESS ET AL., C CAMBRIDGE UNIVERSITY PRESS, 1992 ISBN 0 521 43064 X C ADAPTED FOR DOUBLE PRECISION C USES EXTERNAL FUNCTION FUNK C THIS FUNCTION IS CALLED FROM AMOEBA. C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. INTEGER MP,NP,NMAX PARAMETER (NMAX=20) DOUBLE PRECISION FAC,P(MP,NP),PSUM(NP),Y(MP),FUNK DOUBLE PRECISION FAC1,FAC2,YTRY,PTRY(NMAX) INTEGER IHI,NDIM,J SAVE EXTERNAL FUNK C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'AMOTRY:' FAC1 = (1.D0-FAC)/NDIM FAC2 = FAC1-FAC DO 11 J = 1,NDIM PTRY(J) = PSUM(J) * FAC1 - P(IHI,J) * FAC2 11 CONTINUE YTRY = FUNK(PTRY) IF ( YTRY .LT. Y(IHI) ) THEN Y(IHI) = YTRY DO 12 J = 1,NDIM PSUM(J) = PSUM(J) - P(IHI,J) + PTRY(J) P(IHI,J) = PTRY(J) 12 CONTINUE ENDIF AMOTRY = YTRY RETURN END *CMZ : 05/03/2002 08.29.24 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= BLOCK DATA BLOCK1 C----------------------------------------------------------------------- C C INITIALIZES DATA C THIS ROUTINE IS CALLED FROM AAMAIN. C----------------------------------------------------------------------- *KEEP,AIR. COMMON /AIR/ COMPOS,PROBTA,AVERAW,AVOGAD DOUBLE PRECISION COMPOS(3),PROBTA(3),AVERAW,AVOGAD *KEEP,ATMOS. COMMON /ATMOS/ AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM DOUBLE PRECISION AATM(5),AATM0(5,0:16),BATM(5),BATM0(5,0:16), * CATM(5),CATM0(5,0:16),DATM(5) INTEGER MODATM *KEEP,ATMOS2. COMMON /ATMOS2/ HLAY,HLAY0,THICKL,LAYNO,LAYNEW DOUBLE PRECISION HLAY(6),HLAY0(5,0:4),THICKL(5) INTEGER LAYNO(0:16) LOGICAL LAYNEW *KEEP,BUFFS. COMMON /BUFFS/ RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH INTEGER MAXBUF,MAXLEN PARAMETER (MAXLEN=16) PARAMETER (MAXBUF=39*7) REAL RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF), * RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF) INTEGER LH CHARACTER*4 CRUNH,CRUNE,CEVTH,CEVTE,CLONG EQUIVALENCE (RUNH(1),CRUNH), (RUNE(1),CRUNE) EQUIVALENCE (EVTH(1),CEVTH), (EVTE(1),CEVTE) EQUIVALENCE (ARRAYLONG(1),CLONG) *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,EDECAY. COMMON /EDECAY/ CETA DOUBLE PRECISION CETA(5) *KEEP,GNUPR. COMMON /GNUPR/ SE14,SE16,SE40 DOUBLE PRECISION SE14(3,14),SE16(3,16),SE40(3,40) *KEEP,KAONS. COMMON /KAONS/ CKA DOUBLE PRECISION CKA(80) *KEEP,MUPART. COMMON /MUPART/ AMUPAR,BCUT,CMUON,FMUBRM,FMUORG DOUBLE PRECISION AMUPAR(16),BCUT,CMUON(11) LOGICAL FMUBRM,FMUORG *KEEP,NKGI. COMMON /NKGI/ SEL,SELLG,STH,ZEL,ZELLG,ZSL,DIST, * DISX,DISY,DISXY,DISYX,DLAX,DLAY,DLAXY,DLAYX, * OBSATI,RADNKG,RMOL,TLEV,TLEVCM,IALT DOUBLE PRECISION SEL(10),SELLG(10),STH(10),ZEL(10),ZELLG(10), * ZSL(10),DIST(10), * DISX(-10:10),DISY(-10:10), * DISXY(-10:10,2),DISYX(-10:10,2), * DLAX (-10:10,2),DLAY (-10:10,2), * DLAXY(-10:10,2),DLAYX(-10:10,2), * OBSATI(2),RADNKG,RMOL(2),TLEV(10),TLEVCM(10) INTEGER IALT(2) *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,REST. COMMON /REST/ CONTNE,TAR,LT DOUBLE PRECISION CONTNE(3),TAR INTEGER LT *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,STACKF. COMMON /STACKF/ STACK,MSTACKP,MEXST,NSHIFT,NOUREC,ICOUNT, * NTO,NFROM INTEGER MAXSTK PARAMETER (MAXSTK = 16*256*2) DOUBLE PRECISION STACK(MAXSTK) INTEGER MSTACKP,MEXST,NSHIFT,NOUREC,ICOUNT,NTO,NFROM *KEEP,STRBAR. COMMON /STRBAR/ CSTRBA DOUBLE PRECISION CSTRBA(11) *KEEP,VERS. COMMON /VERS/ VERNUM,MVDATE,VERDAT DOUBLE PRECISION VERNUM INTEGER MVDATE CHARACTER*18 VERDAT *KEEP,CEREN3. COMMON /CEREN3/ CERCNT,DATAB2,NRECER,LHCER INTEGER MAXBF2 PARAMETER ( MAXBF2 = 39 * 7 ) DOUBLE PRECISION CERCNT REAL DATAB2(MAXBF2) INTEGER NRECER,LHCER *KEND. C----------------------------------------------------------------------- C AIR DATA COMPOS / 0.78479D0, 0.21052D0, 0.00469D0 / DATA PROBTA / 0.78479D0, 0.99531D0, 1.00000D0 / DATA AVERAW / 14.543D0 / C VALUE OF AVOGADRO REVISED SEPT. 2000 BY D.H. DATA AVOGAD / 6.02214199D-4 / C ATMOS (U.S.STANDARD IS DEFAULT) DATA AATM / -186.5562D0, -94.919D0, 0.61289D0,0.D0,.01128292D0 / DATA BATM / 1222.6562D0,1144.9069D0,1305.5948D0,540.1778D0,1.D0 / DATA CATM / 994186.38D0,878153.55D0,636143.04D0,772170.16D0,1.D9/ DATA ((AATM0(I,J),I=1,5),J=0,16) * /-186.5562D0, -94.919D0 ,.61289D0 , 0.D0 , .01128292D0 , * -186.5562D0, -94.919D0 ,.61289D0 , 0.D0 , .01128292D0 , * -118.1277D0,-154.258D0 ,.4191499D0, 5.4094056D-4, .01128292D0 , * -195.837264D0,-50.4128778D0,.345594007D0,5.46207D-4,.01128292D0, * -253.95047D0,-128.97714D0,.353207D0 , 5.526876D-4 , .01128292D0 , * -208.12899D0,-120.26179D0,.31167036D0,5.591489D-4 , .01128292D0 , * -77.875723D0,-214.96818D0,.3721868D0, 5.5309816D-4, .01128292D0 , * -242.56651D0,-103.21398D0,.3349752D0, 5.527485D-4 , .01128292D0 , * -195.34842D0,-71.997323D0,.3378142D0, 5.48224D-4 , .01128292D0 , * 0.D0 , 0.D0 , 0.D0, 0.D-4 , .01128292D0 , * 0.D0 , 0.D0 , 0.D0, 0.D-4 , .01128292D0 , * -137.656D0, -37.9610D0, .222659D0,-6.16201D-4 , .00207722D0 , * -163.331D0, -65.3713D0, .402903D0,-4.79198D-4 , .00188667D0 , * -142.801D0, -70.1538D0, 1.14855D0,-9.10269D-4 , .00152236D0 , * -128.601D0, -39.5548D0, 1.13088D0,-26.4960D-4 , .00192534D0 , * -113.139D0, -79.0635D0,-54.3888D0, 0.00000D0 , .4210330D-2 , * - 59.0293D0, -21.5794D0,-7.14839D0, 0.00000D0 , .1901750D-3 / DATA ((BATM0(I,J),I=1,5),J=0,16) * / 1222.6562D0, 1144.9069D0, 1305.5948D0, 540.1778D0, 1.D0 , * 1222.6562D0, 1144.9069D0, 1305.5948D0, 540.1778D0, 1.D0 , * 1173.9861D0, 1205.7625D0, 1386.7807D0, 555.8935D0, 1.D0 , * 1240.48D0 , 1117.85D0 , 1210.9D0 , 608.2128D0, 1.D0 , * 1285.2782D0, 1173.1616D0, 1320.4561D0, 680.6803D0, 1.D0 , * 1251.474D0 , 1173.321D0 , 1307.826D0 , 763.1139D0, 1.D0 , * 1103.3362D0, 1226.5761D0, 1382.6933D0, 685.6073D0, 1.D0 , * 1262.7013D0, 1139.0249D0, 1270.2886D0, 681.4061D0, 1.D0 , * 1210.4D0 , 1103.8629D0, 1215.3545D0, 629.7611D0, 1.D0 , * 0.D0 , 0.D0 , 0.D0 , 0.D0 , 1.D0 , * 0.D0 , 0.D0 , 0.D0 , 0.D0 , 1.D0 , * 1130.74D0, 1052.05D0, 1137.21D0, 442.512D0, 1.D0 , * 1183.70D0, 1108.06D0, 1424.02D0, 207.595D0, 1.D0 , * 1177.19D0, 1125.11D0, 1304.77D0, 433.823D0, 1.D0 , * 1139.99D0, 1073.82D0, 1052.96D0, 492.503D0, 1.D0 , * 1133.10D0, 1101.20D0, 1085.00D0, 1098.00D0, 1.D0 , * 1079.00D0, 1071.90D0, 1182.00D0, 1647.10D0, 1.D0 / DATA ((CATM0(I,J),I=1,5),J=0,16) * / 994186.38D0, 878153.55D0, 636143.04D0, 772170.16D0, 1.D9 , * 994186.38D0, 878153.55D0, 636143.04D0, 772170.16D0, 1.D9 , * 919546.D0 , 963267.92D0, 614315.D0 , 739059.6D0 , 1.D9 , * 933697.D0 , 765229.D0 , 636790.D0 , 733793.8D0 , 1.D9 , * 1088310.D0 , 935485.D0 , 635137.D0 , 727312.6D0 , 1.D9 , * 1032310.D0 , 925528.D0 , 645330.D0 , 720851.4D0 , 1.D9 , * 932077.D0 ,1109960.D0 , 630217.D0 , 726901.3D0 , 1.D9 , * 1059360.D0 , 888814.D0 , 639902.D0 , 727251.8D0 , 1.D9 , * 970276.D0 , 820946.D0 , 639074.D0 , 731776.5D0 , 1.D9 , * 0.D0 , 0.D0 , 0.D0 , 0.D0 , 1.D9 , * 0.D0 , 0.D0 , 0.D0 , 0.D0 , 1.D9 , * 867358.D0 , 741208.D0 , 633846.D0 , 759850.D0,5.4303203D9, * 875221.D0 , 753213.D0 , 545846.D0 , 793043.D0,5.9787908D9, * 861745.D0 , 765925.D0 , 581351.D0 , 775155.D0,7.4095699D9, * 861913.D0 , 744955.D0 , 675928.D0 , 829627.D0,5.8587010D9, * 861730.D0 , 826340.D0 , 790950.D0 , 682800.D0,2.6798156D9, * 764170.D0 , 699910.D0 , 635650.D0 , 551010.D0,59.329575D9/ DATA (LAYNO(J), J=0,16) * / 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 2, 3 / DATA (HLAY(I),I=1,5) * / -5779.5D2 , 4.D5 , 1.D6 , 4.D6, 1.D7 / DATA ((HLAY0(I,J),I=1,5),J=0,3) * / -5779.5D2 , 4.D5 , 1.D6 , 4.D6, 1.D7 , * -5779.5D2 , 4.D5 , 1.D6 , 4.D6, 1.D7 , * 0.D0 , 2.66667D5 , 5.33333D5 , 8.D5, 1.D7 , * 0.D0 , 6.66667D5 ,13.33333D0 , 20.D5, 1.D7 / C CEREN3 DATA CERCNT / 0.D0 / C CONSTA DATA PI / 3.141592653589793D0 / DATA PI2 / 6.283185307179586D0 / DATA OB3 / 0.333333333333333D0 / DATA TB3 / 0.666666666666666D0 / C ENEPER IS CALCULATED IN START: ENEPER = EXP(1.D0) C DATA FOR MUPART: CUTOFF FOR BREMSSTRAHLUNG AT 3 MEV DATA BCUT /0.003D0/ C DATA FOR REST: AVERAGE ATOMIC WEIGHT, NEUTRON CONTENTS OF N,O,AR DATA TAR / 14.6D0 /, CONTNE / 0.5D0, 0.5D0, 0.55D0 /, LT / 1 / C KAON CONSTANTS C REVISED SEPT. 2000 BY D. HECK DATA CKA / 0.0D0, 0.1D0, 1.2386D-8, 1.2386D-8, 0.8935D-10, * 5.17D-8, 0.25D0, 0.5D0, 0.75D0, 1.0D0, * 0.5D0, 0.2D0, 0.0D0, 0.0D0, 149.6D0, * 149.6D0,0.236D0, 0.206D0, 0.135D0, 0.222D0, * 0.5D0, 0.0D0, 0.635D0, 0.686D0, 0.8734D0, * 0.6598D0,.3884D0, 0.0D0, 0.0D0, 0.0D0, * 0.0D0, 0.0D0, 0.0D0, 0.0D0, 1.0D0, * 1.0D5, 0.0D0, 0.0D0, 0.0D0, 0.0D0, * 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, * 0.0D0,0.8468D0, 0.9027D0, 0.9509D0, 0.9827D0, * -0.2154D0, 0.012D0,-0.0101D0, 1.27D0, 0.652D0, * 0.057D0, 0.0D0, 1.84D0, 0.0D0, 1.0D0, * 0.678D0, 0.076D0, 0.0099D0, 2.22D0, 0.0288D0, * 0.0D0,1.288D-2, 0.031D0, 0.006D0, 1.194D-2, * 0.0288D0, 0.0D0, 1.310D-2, 0.034D0, 0.025D0, * 1.241D-2, 0.0D0, 0.0D0, 0.0D0, 0.0D0 / C DATA FOR ETA DECAY DATA CETA / 0.3960D0, 0.7206D0, 0.9522D0, -1.07D0, 2.07D0 / C DATA FOR STRANGE BARYON DECAY DATA CSTRBA / 2.632D-10,0.8018D-10, 7.4D-20, 1.479D-10,0.6409D0, * 0.5163D0, 2.90D-10, 1.639D-10, 0.821D-10, 0.678D0, * 0.914D0 / C PARPAR DATA C /6371315.D2, 6.0D5, 20.0D5, 0.0D0, 0.0D0, * 0.0D0, 0.0D0, 0.0D0, 2.5D0, 2.07D0, * 8.2D0, 0.1D0, 0.0D0, 0.0D0, 0.0D0, * 88.0D0, 110.D0, 2.6033D-8, 2.19703D-6, 0.0D0, * 37.7D0, 1.532873D-4, 9.386417D0, 2.D-3, 29.9792458D9, * 1.0D0, 0.0D0, 1.57D0, 0.0D0, 0.021D0, * 88.0D0, 110.0D0, 0.0D0, 2.0D1, 0.0D0, * 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, * 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, * 0.0D0, 0.0D0, 0.0D0, 0.0D0,137.0359998D0 / C RUNPAR,STACKF DATA MONIIN / 5 /, MONIOU / 6 /, MPATAP / 90 /, MEXST / 96 /, * MDEBUG / 6 /, NUCNUC / 11 /, MDBASE / 45 /, MTABOUT / 46 /, * MLONGOUT / 48 / * ,MCETAP / 91 / C UNRELEASABLE ENERGY (REST MASS) FOR THINNING DATA RESTMS/ 0., -.511D-3, .511D-3, 0., .105658 , * .105658 , 0., 0., 0., 0., * 0., 0., .939566 , .93827 , 0. , * 0., 0., .939 , .939 , .939 , * .939 , .939 , .939 , .939 , 0. , * 0. , 0. , 0. , 0. , 0. , * 0. , 0. , 0., 0., 0., * 0., 0., 0., 0., 0., * 0., 0., 0., 0., 0., * 0., 0., 0., 0., 0., * 0., 0., 0., .939 , .939 , * .939 , .939 , 0. , 0. , 0. , * 0. , 0., 0., 0., 0., * 0., 0., 0., 0., 0., * 0., 0., 0., 0., 0., * 5925*0.D0/ C GNUPR (NEW VERSION OCT 1991) C NITROGEN TARGET 14 DATA ((SE14(I,J),I=1,3),J=1,14) * / 0.472000D+00,-0.426710D-02, 0.726439D-04, * 0.230324D+00,-0.989733D-03,-0.807077D-05, * 0.138623D+00, 0.609624D-03,-0.401675D-04, * 0.827139D-01, 0.135103D-02,-0.360236D-04, * 0.445693D-01, 0.137582D-02,-0.137674D-04, * 0.206106D-01, 0.998620D-03, 0.422867D-05, * 0.792756D-02, 0.559858D-03, 0.957875D-05, * 0.247793D-02, 0.247480D-03, 0.701650D-05, * 0.615535D-03, 0.860096D-04, 0.324410D-05, * 0.118279D-03, 0.230732D-04, 0.104282D-05, * 0.169210D-04, 0.461424D-05, 0.235175D-06, * 0.169481D-05, 0.647634D-06, 0.358189D-07, * 0.105988D-06, 0.568994D-07, 0.332920D-08, * 0.311374D-08, 0.235385D-08, 0.143213D-09/ C OXYGEN TARGET 16 DATA ((SE16(I,J), I=1,3),J=1,16) * /0.475002D+00,-0.434401D-02, 0.734217D-04, * 0.230261D+00,-0.966152D-03,-0.982228D-05, * 0.137372D+00, 0.642454D-03,-0.408490D-04, * 0.813380D-01, 0.135241D-02,-0.354835D-04, * 0.437870D-01, 0.135776D-02,-0.134429D-04, * 0.204919D-01, 0.988538D-03, 0.398723D-05, * 0.812995D-02, 0.567070D-03, 0.942943D-05, * 0.269031D-02, 0.263160D-03, 0.728079D-05, * 0.732711D-03, 0.993722D-04, 0.366933D-05, * 0.161940D-03, 0.303662D-04, 0.134776D-05, * 0.285325D-04, 0.740356D-05, 0.371648D-06, * 0.390910D-05, 0.140655D-05, 0.768260D-07, * 0.401145D-06, 0.200620D-06, 0.116200D-07, * 0.290010D-07, 0.202033D-07, 0.121929D-08, * 0.131709D-08, 0.128046D-08, 0.795482D-10, * 0.282645D-10, 0.384068D-10, 0.243535D-11/ C ARGON TARGET 40 DATA ((SE40(I,J),I=1,3),J=1,18) * / 0.318084D+00,-0.352566D-02, 0.829469D-04, * 0.193581D+00,-0.238538D-02, 0.404919D-04, * 0.148699D+00,-0.118791D-02,-0.130378D-04, * 0.117201D+00, 0.966097D-04,-0.536044D-04, * 0.876737D-01, 0.106482D-02,-0.612882D-04, * 0.600279D-01, 0.150343D-02,-0.412273D-04, * 0.370180D-01, 0.147347D-02,-0.130096D-04, * 0.204422D-01, 0.117625D-02, 0.743960D-05, * 0.101003D-01, 0.807913D-03, 0.155153D-04, * 0.447163D-02, 0.489622D-03, 0.146804D-04, * 0.177806D-02, 0.265260D-03, 0.102802D-04, * 0.636671D-03, 0.129412D-03, 0.591434D-05, * 0.205809D-03, 0.571042D-04, 0.291674D-05, * 0.601981D-04, 0.228546D-04, 0.126074D-05, * 0.159631D-04, 0.831226D-05, 0.484001D-06, * 0.384379D-05, 0.275100D-05, 0.166440D-06, * 0.841490D-06, 0.829259D-06, 0.515615D-07, * 0.167633D-06, 0.227810D-06, 0.144446D-07/ DATA((SE40(I,J),I=1,3),J=19,36) * /0.304029D-07, 0.570494D-07, 0.366843D-08, * 0.502077D-08, 0.130224D-07, 0.845876D-09, * 0.754786D-09, 0.270844D-08, 0.177211D-09, * 0.103229D-09, 0.512862D-09, 0.337323D-10, * 0.128308D-10, 0.883149D-10, 0.583066D-11, * 0.144721D-11, 0.138082D-10, 0.914113D-12, * 0.147837D-12, 0.195621D-11, 0.129757D-12, * 0.136429D-13, 0.250465D-12, 0.166371D-13, * 0.113379D-14, 0.288894D-13, 0.192092D-14, * 0.845213D-16, 0.299003D-14, 0.198959D-15, * 0.562496D-17, 0.276346D-15, 0.183981D-16, * 0.332222D-18, 0.226723D-16, 0.151001D-17, * 0.172872D-19, 0.163915D-17, 0.109200D-18, * 0.785321D-21, 0.103480D-18, 0.689517D-20, * 0.307886D-22, 0.563885D-20, 0.375787D-21, * 0.102630D-23, 0.261299D-21, 0.174154D-22, * 0.285163D-25, 0.100944D-22, 0.672832D-24, * 0.642589D-27, 0.316302D-24, 0.210839D-25/ DATA((SE40(I,J),I=1,3),J=37,40) * /0.112817D-28, 0.772286D-26, 0.514807D-27, * 0.144773D-30, 0.137838D-27, 0.918858D-29, * 0.120779D-32, 0.159956D-29, 0.106632D-30, * 0.491605D-35, 0.905709D-32, 0.603784D-33/ C VERSION NUMBER AND DATE OF RELEASE DATA VERNUM / 6.014 / DATA MVDATE / 20020305 / C -YYYYMMDD- DATA VERDAT / 'MARCH 05, 2002' / C ----+----+----+--- END *CMZ : 28/02/2002 13.08.19 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE BOX2 C----------------------------------------------------------------------- C C DETERMINES POINT OF INTERACTION OR DECAY FOR ANY PARTICLE C HEAVY PRIMARIES AND STRANGE BARYONS INCLUDED C ANNIHILATION CROSS-SECTION INCLUDED C PRECISE MEAN FREE PATH FOR DECAYING PARTICLES C HAS INTERACTION LENGTH STATISTICS INCLUDED C THIS SUBROUTINE IS CALLED FROM AAMAIN. C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,AIR. COMMON /AIR/ COMPOS,PROBTA,AVERAW,AVOGAD DOUBLE PRECISION COMPOS(3),PROBTA(3),AVERAW,AVOGAD *KEEP,ATMOS2. COMMON /ATMOS2/ HLAY,HLAY0,THICKL,LAYNO,LAYNEW DOUBLE PRECISION HLAY(6),HLAY0(5,0:4),THICKL(5) INTEGER LAYNO(0:16) LOGICAL LAYNEW *KEEP,CHISTA. COMMON /CHISTA/ IHYCHI,IKACHI,IMUCHI,INNCHI,INUCHI,IPICHI INTEGER IHYCHI(124),IKACHI(124),IMUCHI(124), * INNCHI(124),INUCHI(124),IPICHI(124) *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,KAONS. COMMON /KAONS/ CKA DOUBLE PRECISION CKA(80) *KEEP,MUPART. COMMON /MUPART/ AMUPAR,BCUT,CMUON,FMUBRM,FMUORG DOUBLE PRECISION AMUPAR(16),BCUT,CMUON(11) LOGICAL FMUBRM,FMUORG *KEEP,NCSNCS. COMMON /NCSNCS/ SIGN30,SIGN45,SIGN60,SIGO30,SIGO45,SIGO60, * SIGA30,SIGA45,SIGA60,PNOA30,PNOA45,PNOA60, * SIG30A,SIG45A,SIG60A DOUBLE PRECISION SIGN30(56),SIGN45(56),SIGN60(56), * SIGO30(56),SIGO45(56),SIGO60(56), * SIGA30(56),SIGA45(56),SIGA60(56), * PNOA30(1540,3),PNOA45(1540,3),PNOA60(1540,3), * SIG30A(56),SIG45A(56),SIG60A(56) *KEEP,OBSPAR. COMMON /OBSPAR/ OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP, * THETPR,PHIPR, * VUECON, * NOBSLV DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10), * HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2) DOUBLE PRECISION VUECON(2) INTEGER NOBSLV *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,REST. COMMON /REST/ CONTNE,TAR,LT DOUBLE PRECISION CONTNE(3),TAR INTEGER LT *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,SIGM. COMMON /SIGM/ SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO DOUBLE PRECISION SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO *KEEP,STRBAR. COMMON /STRBAR/ CSTRBA DOUBLE PRECISION CSTRBA(11) *KEEP,VENUS. COMMON /VENUS/ ISH00,IVERVN,MTAR99,FVENUS,FVENSG INTEGER ISH00,IVERVN,MTAR99 LOGICAL FVENUS,FVENSG *KEND. DOUBLE PRECISION CHIBRM,CHIPRM,CHIINT,CHI1,CHI2,CKA2,COR1,DH, * EKIN,ELAB,ELABLG,ELABT,FRAPTN,FRPTNO, * HEIGH,PLAB,PLABLG,SIGBRM,SIGPRM, * SIG45,S45SQ,S4530,THICK REAL GBRSGM,GPRSGM INTEGER I,IA,IHY,IP,KA,MU,NI,NU DOUBLE PRECISION HNEW SAVE DOUBLE PRECISION CGHSIG EXTERNAL CGHSIG EXTERNAL HEIGH,THICK,GBRSGM,GPRSGM C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=1,9) 444 FORMAT(' BOX2 : CURPAR=',1P,9E10.3) ITYPE = CURPAR(1) C PHOTONS AND ELECTRONS ETA ARE TREATED SEPARATELY (SEE BOX3) IF ( ITYPE .LE. 3 ) THEN CHI = 0.D0 RETURN ENDIF C----------------------------------------------------------------------- C RESONANCES ARE TREATED SEPARATELY (SEE BOX3) IF ( ITYPE .GE. 50 .AND. ITYPE .LE. 65 ) THEN CHI = 0.D0 RETURN ENDIF BETA = SQRT( GAMMA**2 - 1.D0 ) / GAMMA THICKH = THICK(H) ELAB = PAMA(ITYPE) * GAMMA C----------------------------------------------------------------------- C MU + , MU - DECAYS AFTER ITS LIFE TIME C MUON INTERACTS BY BREMSSTRAHLUNG OR PAIR PRODUCTION IF ( ITYPE .EQ. 5 .OR. ITYPE .EQ. 6 ) THEN CALL RMMAR( RD,3,1 ) COR1 = (-LOG(RD(1))) * C(25) * C(19) CALL PRANGC(COR1,.TRUE.,HNEW) DH = MAX( H - HNEW, 0.D0 ) IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,RD(1),CHIDEC=', * ITYPE,RD(1),SNGL(CHI) IF ( GAMMA .LE. 200.D0 ) THEN FDECAY = .TRUE. ELSE C AT HIGHER ENERGIES CHECK FOR MUON BREMSSTRAHLUNG AND PAIR PRODUCTION ELABLG = LOG(ELAB) C CALCULATE MUON BREMSSTRAHLUNG CROSS-SECTION FOR AIR IF ( ELAB .LE. 1.D5 ) THEN FRACTN = COMPOS(1)*GBRSGM( 7.,SNGL(ELAB)) FRCTNO = FRACTN + COMPOS(2)*GBRSGM( 8.,SNGL(ELAB)) SIGBRM = FRCTNO + COMPOS(3)*GBRSGM(18.,SNGL(ELAB)) ELSE C PRELIMINARY PARAMETRIZED FOR ULTRAHIGH ENERGIES (JAN 2000) SIGBRM = EXP( ELABLG*0.046816D0 - 7.80342D0 ) FRACTN = SIGBRM * 0.78D0 FRCTNO = SIGBRM * 0.99D0 ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : SIGBRM=',SNGL(SIGBRM) C CALCULATE CHIBRM = (-LOG(RD(2))) * AVERAW / (AVOGAD * SIGBRM) IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,RD(2),CHIBRM=', * ITYPE,RD(2),SNGL(CHIBRM) CHI1 = MIN( CHIBRM, CHI ) IF ( ELAB .LE. 1.D5 ) THEN C CALCULATE MUON PAIR PRODUCTION CROSS-SECTION FOR AIR FRAPTN = COMPOS(1)*GPRSGM( 7.,SNGL(ELAB)) FRPTNO = FRAPTN + COMPOS(2)*GPRSGM( 8.,SNGL(ELAB)) SIGPRM = FRPTNO + COMPOS(3)*GPRSGM(18.,SNGL(ELAB)) ELSE C PRELIMINARY PARAMETRIZED FOR ULTRAHIGH ENERGIES (JAN 2000) SIGPRM = EXP( ELABLG*0.136048D0 - 3.70468D0 ) FRAPTN = SIGPRM * 0.78D0 FRPTNO = SIGPRM * 0.99D0 ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : SIGPRM=',SNGL(SIGPRM) C CALCULATE MEAN FREE PATH FOR PAIR PRODUCTION CHIPRM = (-LOG(RD(3))) * AVERAW / (AVOGAD * SIGPRM) IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,RD(3),CHIPRM=', * ITYPE,RD(3),SNGL(CHIPRM) CHI2 = MIN( CHIPRM, CHI1 ) IF ( CHI2 .EQ. CHI ) THEN FDECAY = .TRUE. ELSEIF ( CHI2 .EQ. CHIBRM ) THEN FDECAY = .FALSE. FMUBRM = .TRUE. C TARGET IS CHOSEN AT RANDOM FOR MUON BREMSSTRAHLUNG CALL RMMAR( RD,1,1 ) IF ( RD(1)*SIGBRM .LE. FRACTN ) THEN C BREMSSTRAHLUNG WITH NITROGEN LT = 1 TAR = 14.D0 ELSEIF ( RD(1)*SIGBRM .LE. FRCTNO ) THEN C BREMSSTRAHLUNG WITH OXYGEN LT = 2 TAR = 16.D0 ELSE C BREMSSTRAHLUNG WITH ARGON LT = 3 TAR = 40.D0 ENDIF ELSEIF ( CHI2 .EQ. CHIPRM ) THEN FDECAY = .FALSE. FMUBRM = .FALSE. C TARGET IS CHOSEN AT RANDOM FOR MUON PAIR PRODUCTION CALL RMMAR( RD,1,1 ) IF ( RD(1)*SIGPRM .LE. FRAPTN ) THEN C PAIR PRODUCTION WITH NITROGEN LT = 1 TAR = 14.D0 ELSEIF ( RD(1)*SIGPRM .LE. FRPTNO ) THEN C PAIR PRODUCTION WITH OXYGEN LT = 2 TAR = 16.D0 ELSE C PAIR PRODUCTION WITH ARGON LT = 3 TAR = 40.D0 ENDIF ENDIF CHI = CHI2 ENDIF C DECAY LENGTH STATISTICS MU = 1.D0 + DH * 1.D-4 / COSTHE MU = MIN( MU, 123 ) IMUCHI( MU) = IMUCHI( MU) + 1 IMUCHI(124) = IMUCHI(124) + 1 C----------------------------------------------------------------------- C CHARGED PIONS ELSEIF ( ITYPE .EQ. 8 .OR. ITYPE .EQ. 9 ) THEN PLAB = ELAB * BETA C CALCULATION OF CROSS-SECTION IN THE GHEISHA ROUTINES IF ( ELAB .LE. HILOELB ) THEN EKIN = ELAB - PAMA(ITYPE) USELOW = .TRUE. SIGAIR = CGHSIG(SNGL(PLAB),SNGL(EKIN),ITYPE) GHESIG = .TRUE. ELSE USELOW = .FALSE. GHESIG = .FALSE. IF ( FVENSG .AND. (ELAB .GE. HILOELB) ) THEN CALL VENSIG(ELAB,2) ELSE C SIGMA IS ENERGY DEPENDENT INELASTIC PION-NUCLEON CROSS-SECTION IF ( PLAB .LE. 5.D0 ) THEN SIGMA = 20.64D0 ELSEIF ( PLAB .LT. 1.D3 ) THEN PLABLG = LOG(PLAB) C INELASTIC CROSS-SECTIONS FROM PARTICLE DATA GROUP C (A.BALDINI ET AL., LANDOLT-BOERNSTEIN NEW SERIES I/12A (1987) 193) SIGMA = 24.3D0 - 12.3D0 * PLAB**(-1.91D0) * + 0.324D0 * PLABLG**2 - 2.44D0 * PLABLG ELSE C FACTOR 0.6667 GIVES RATIO BETWEEN PION AND NUCLEON CROSS-SECTION SIGMA = 19.87D0 * ELAB**.079D0 * 0.6667D0 ENDIF C AUXIL. QUANTITIES FOR INTERPOLATION SIG45 = SIGMA - 45.D0 S45SQ = SIG45**2 / 450.D0 S4530 = SIG45 / 30.D0 C INELASTIC CROSS-SECTIONS OF AIR FOR PROJECTILE WITH MASS NUMBER 1 SIGAIR = (1.D0 - 2.D0 * S45SQ) * SIG45A(1) * +(S45SQ - S4530) * SIG30A(1) * +(S45SQ + S4530) * SIG60A(1) ENDIF ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : SIGMA,SIGAIR,GHESIG=', * SNGL(SIGMA),SNGL(SIGAIR),GHESIG CALL RMMAR( RD,2,1 ) C MEAN FREE PATH FOR INTERACTION (CHIINT) OR DECAY (CHI) CHIINT = (-LOG(RD(1))) * AVERAW / (AVOGAD * SIGAIR) IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,RD(1),CHIINT=', * ITYPE,RD(1),SNGL(CHIINT) COR1 = (-LOG(RD(2))) * C(25) * C(18) CALL PRANGC(COR1,.FALSE.,HNEW) CHI = MAX( CHI, 0.D0 ) IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,RD(2),CHIDEC=', * ITYPE,RD(2),SNGL(CHI) CHI = MIN( CHIINT, CHI ) IF ( CHI .LT. CHIINT ) THEN FDECAY = .TRUE. ELSE FDECAY = .FALSE. ENDIF C INTERACTION LENGTH STATISTICS IP = 1.D0 + CHI * 0.1D0 IP = MIN( IP, 123 ) IPICHI( IP) = IPICHI( IP) + 1 IPICHI(124) = IPICHI(124) + 1 C----------------------------------------------------------------------- C NEUTRAL PIONS ELSEIF ( ITYPE .EQ. 7 ) THEN C LOW ENERGY PIONS ARE NOT TRACKED AND DECAY IF ( ELAB .LT. 1.D5 ) THEN FDECAY = .TRUE. CHI = 0.D0 IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,CHI,FDECAY=', * ITYPE,SNGL(CHI),FDECAY ELSE C PION IS HIGH ENERGY AND MUST BE TRACKED PLAB = ELAB * BETA GHESIG = .FALSE. IF ( FVENSG ) THEN CALL VENSIG(ELAB,2) ELSE C SIGMA IS ENERGY DEPENDENT INELASTIC PION-NUCLEON CROSS-SECTION C FACTOR 0.6667 GIVES RATIO BETWEEN PION AND NUCLEON CROSS-SECTION SIGMA = 19.87D0 * ELAB**.079D0 * 0.6667D0 C AUXIL. QUANTITIES FOR INTERPOLATION SIG45 = SIGMA - 45.D0 S45SQ = SIG45**2 / 450.D0 S4530 = SIG45 / 30.D0 C INELASTIC CROSS-SECTIONS OF AIR FOR PROJECTILE WITH MASS NUMBER 1 SIGAIR = (1.D0 - 2.D0 * S45SQ) * SIG45A(1) * +(S45SQ - S4530) * SIG30A(1) * +(S45SQ + S4530) * SIG60A(1) ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) * 'BOX2 : SIGMA,SIGAIR=',SNGL(SIGMA),SNGL(SIGAIR) CALL RMMAR( RD,2,1 ) C MEAN FREE PATH FOR INTERACTION (CHIINT) OR DECAY (CHI) CHIINT = (-LOG(RD(1))) * AVERAW / (AVOGAD * SIGAIR) IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,RD(1),CHIINT=', * ITYPE,RD(1),SNGL(CHIINT) COR1 = (-LOG(RD(2))) * C(25) * 8.4D-17 CALL NRANGC(COR1*BETA*GAMMA) IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,RD(2),CHIDEC=', * ITYPE,RD(2),SNGL(CHI) CHI = MIN( CHIINT, CHI ) IF ( CHI .LT. CHIINT ) THEN FDECAY = .TRUE. ELSE FDECAY = .FALSE. ENDIF ENDIF C INTERACTION LENGTH STATISTICS IP = 1.D0 + CHI * 0.1D0 IP = MIN( IP, 123 ) IPICHI( IP) = IPICHI( IP) + 1 IPICHI(124) = IPICHI(124) + 1 C----------------------------------------------------------------------- C NUCLEONS AND ANTINUCLEONS ELSEIF ( ITYPE .EQ. 13 .OR. ITYPE .EQ. 14 .OR. * ITYPE .EQ. 15 .OR. ITYPE .EQ. 25 ) THEN PLAB = ELAB * BETA C CALCULATION OF CROSS-SECTION IN THE GHEISHA ROUTINES IF ( ELAB .LE. HILOELB ) THEN EKIN = ELAB - PAMA(ITYPE) USELOW = .TRUE. SIGAIR = CGHSIG(SNGL(PLAB),SNGL(EKIN),ITYPE) GHESIG = .TRUE. ELSE USELOW = .FALSE. GHESIG = .FALSE. IF ( FVENSG .AND. (ELAB .GE. HILOELB) ) THEN CALL VENSIG(ELAB,1) ELSE C SIGMA IS ENERGY DEPENDENT INELASTIC NUCLEON-NUCLEON CROSS-SECTION IF ( PLAB .LT. 1.D1 ) THEN SIGMA = 29.9D0 ELSEIF ( PLAB .LT. 1.D3 ) THEN PLABLG = LOG(PLAB) C INELASTIC CROSS-SECTIONS FROM PARTICLE DATA GROUP C (A.BALDINI ET AL., LANDOLT-BOERNSTEIN NEW SERIES I/12B (1987) 150) SIGMA = 30.9D0 - 28.9D0 * PLAB**(-2.46D0) * + 0.192D0 * PLABLG**2 - 0.835D0 * PLABLG ELSE SIGMA = 19.87D0 * ELAB**.079D0 ENDIF C ADD ANNIHILATION CROSS-SECTION FOR ANTI-NUCLEONS IF ( ITYPE .EQ. 15 .OR. ITYPE .EQ. 25 ) THEN C ANNIHILATION CROSS-SECTIONS FROM PARTICLE DATA GROUP C (A.BALDINI ET AL., LANDOLT-BOERNSTEIN NEW SERIES I/12B (1987) 286) SIGANN = 0.532D0 + 0.634D2 * PLAB**(-0.71D0) SIGMA = MIN( 120.D0, SIGMA + SIGANN ) ENDIF C AUXIL. QUANTITIES FOR INTERPOLATION SIG45 = SIGMA - 45.D0 S45SQ = SIG45**2 / 450.D0 S4530 = SIG45 / 30.D0 C INELASTIC CROSS-SECTIONS OF AIR FOR PROJECTILE WITH MASS NUMBER 1 SIGAIR = (1.D0 - 2.D0 * S45SQ) * SIG45A(1) * +(S45SQ - S4530) * SIG30A(1) * +(S45SQ + S4530) * SIG60A(1) ENDIF IF ( ITYPE .EQ. 15 .OR. ITYPE .EQ. 25 ) THEN C TAKE ANNIHILATION AS ADDITION TO HADR. INTERACT. CROSS-SECTION SIGANN = 2.25D2 * PLAB**(-0.625D0) SIGAIR = SIGAIR + SIGANN FRACTN = FRACTN + PROBTA(1) * SIGANN FRCTNO = FRCTNO + PROBTA(2) * SIGANN ENDIF ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : SIGMA,SIGAIR,GHESIG=', * SNGL(SIGMA),SNGL(SIGAIR),GHESIG C MEAN FREE PATH FROM MOLECULAR WEIGHT, AVOGADRO'S CONSTANT AND SIGMA CALL RMMAR( RD,1,1 ) CHI = (-LOG(RD(1))) * AVERAW / (AVOGAD * SIGAIR) FDECAY = .FALSE. IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,RD(1),CHI=', * ITYPE,RD(1),SNGL(CHI) C INTERACTION LENGTH STATISTICS NU = 1.D0 + CHI * 0.1D0 NU = MIN( NU, 123 ) INUCHI( NU) = INUCHI( NU) + 1 INUCHI(124) = INUCHI(124) + 1 C----------------------------------------------------------------------- C KAONS (PARTICLE TYPES 10,11,12,16) ELSEIF ( ITYPE .EQ. 10 .OR. ITYPE .EQ. 11 .OR. * ITYPE .EQ. 12 .OR. ITYPE .EQ. 16 ) THEN PLAB = ELAB * BETA C CALCULATION OF CROSS-SECTION IN THE GHEISHA ROUTINES IF ( ELAB .LE. HILOELB ) THEN EKIN = ELAB - PAMA(ITYPE) USELOW = .TRUE. SIGAIR = CGHSIG(SNGL(PLAB),SNGL(EKIN),ITYPE) GHESIG = .TRUE. ELSE USELOW = .FALSE. GHESIG = .FALSE. IF ( FVENSG .AND. (ELAB .GE. HILOELB) ) THEN CALL VENSIG(ELAB,3) ELSE C SIGMA IS ENERGY DEPENDENT INELASTIC KAON-NUCLEON CROSS-SECTION IF ( PLAB .LE. 1.D1 ) THEN SIGMA = 14.11D0 ELSEIF ( PLAB .LT. 1.D3 ) THEN PLABLG = LOG(PLAB) C INELASTIC CROSS-SECTIONS FROM PARTICLE DATA GROUP C (A.BALDINI ET AL., LANDOLT-BOERNSTEIN NEW SERIES I/12B (1987) 56) SIGMA = 12.3D0 - 7.77D0 * PLAB**(-2.12D0) * + 0.0326D0 * PLABLG**2 + 0.738D0 * PLABLG ELSE C FACTOR 0.5541 GIVES RATIO BETWEEN KAON AND NUCLEON CROSS-SECTION SIGMA = 19.87D0 * ELAB**.079D0 * 0.5541D0 ENDIF C AUXIL. QUANTITIES FOR INTERPOLATION SIG45 = SIGMA - 45.D0 S45SQ = SIG45**2 / 450.D0 S4530 = SIG45 / 30.D0 C INELASTIC CROSS-SECTIONS OF AIR FOR PROJECTILE WITH MASS NUMBER 1 SIGAIR = (1.D0 - 2.D0 * S45SQ) * SIG45A(1) * +(S45SQ - S4530) * SIG30A(1) * +(S45SQ + S4530) * SIG60A(1) ENDIF ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : SIGMA,SIGAIR,GHESIG=', * SNGL(SIGMA),SNGL(SIGAIR),GHESIG CALL RMMAR( RD,2,1 ) C MEAN FREE PATH FOR INTERACTION (CHIINT) OR DECAY (CHI) CHIINT = (-LOG(RD(1))) * AVERAW / (AVOGAD * SIGAIR) IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,RD(1),CHIINT=', * ITYPE,RD(1),SNGL(CHIINT) IF ( ITYPE .EQ. 16 ) THEN CKA2 = CKA(5) ELSEIF ( ITYPE .EQ. 10 ) THEN CKA2 = CKA(6) ELSE CKA2 = CKA(3) ENDIF COR1 = (-LOG(RD(2))) * C(25) * CKA2 IF ( SIGNUM(ITYPE) .EQ. 0.D0 ) THEN C NEUTRAL KAONS CALL NRANGC(COR1*BETA*GAMMA) ELSE C CHARGED KAONS CALL PRANGC(COR1,.FALSE.,HNEW) CHI = MAX( CHI, 0.D0 ) ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,RD(2),CHIDEC=', * ITYPE,RD(2),SNGL(CHI) CHI = MIN( CHIINT, CHI ) IF ( CHI .LT. CHIINT ) THEN FDECAY = .TRUE. ELSE FDECAY = .FALSE. ENDIF C INTERACTION LENGTH STATISTICS KA = 1.D0 + CHI * 0.1D0 KA = MIN( KA, 123 ) IKACHI( KA) = IKACHI( KA) + 1 IKACHI(124) = IKACHI(124) + 1 C----------------------------------------------------------------------- C ETA MESONS ELSEIF ( ITYPE .EQ. 17 .OR. * (ITYPE .GE. 71 .AND. ITYPE .LE. 74 ) ) THEN C LOW ENERGY ETA MESONS ARE NOT TRACKED AND DECAY IF ( ELAB .LT. 1.D7 ) THEN FDECAY = .TRUE. CHI = 0.D0 IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,CHI,FDECAY=', * ITYPE,SNGL(CHI),FDECAY ELSE C ETA IS HIGH ENERGY AND MUST BE TRACKED. WE TAKE PION CROSS-SECTIONS PLAB = ELAB * BETA GHESIG = .FALSE. IF ( FVENSG ) THEN CALL VENSIG(ELAB,2) ELSE C SIGMA IS ENERGY DEPENDENT INELASTIC PION-NUCLEON CROSS-SECTION C FACTOR 0.6667 GIVES RATIO BETWEEN PION AND NUCLEON CROSS-SECTION SIGMA = 19.87D0 * ELAB**.079D0 * 0.6667D0 C AUXIL. QUANTITIES FOR INTERPOLATION SIG45 = SIGMA - 45.D0 S45SQ = SIG45**2 / 450.D0 S4530 = SIG45 / 30.D0 C INELASTIC CROSS-SECTIONS OF AIR FOR PROJECTILE WITH MASS NUMBER 1 SIGAIR = (1.D0 - 2.D0 * S45SQ) * SIG45A(1) * +(S45SQ - S4530) * SIG30A(1) * +(S45SQ + S4530) * SIG60A(1) ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) * 'BOX2 : SIGMA,SIGAIR=',SNGL(SIGMA),SNGL(SIGAIR) CALL RMMAR( RD,2,1 ) C MEAN FREE PATH FOR INTERACTION (CHIINT) OR DECAY (CHI) CHIINT = (-LOG(RD(1))) * AVERAW / (AVOGAD * SIGAIR) IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,RD(1),CHIINT=', * ITYPE,RD(1),SNGL(CHIINT) COR1 = (-LOG(RD(2))) * C(25) * 5.531D-19 CALL NRANGC(COR1*BETA*GAMMA) IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,RD(2),CHIDEC=', * ITYPE,RD(2),SNGL(CHI) CHI = MIN( CHIINT, CHI ) IF ( CHI .LT. CHIINT ) THEN FDECAY = .TRUE. ELSE FDECAY = .FALSE. ENDIF ENDIF C INTERACTION LENGTH STATISTICS IP = 1.D0 + CHI * 0.1D0 IP = MIN( IP, 123 ) IPICHI( IP) = IPICHI( IP) + 1 IPICHI(124) = IPICHI(124) + 1 C----------------------------------------------------------------------- C STRANGE BARYONS ( LAMBDA, SIGMA(+,0,-),XI(0,-), OMEGA- ) ELSEIF ( (ITYPE .GE. 18 .AND. ITYPE .LE. 24) .OR. * (ITYPE .GE. 26 .AND. ITYPE .LE. 32) ) THEN PLAB = ELAB * BETA C CALCULATION OF CROSS-SECTION IN THE GHEISHA ROUTINES IF ( ELAB .LE. HILOELB ) THEN EKIN = ELAB - PAMA(ITYPE) USELOW = .TRUE. SIGAIR = CGHSIG(SNGL(PLAB),SNGL(EKIN),ITYPE) C SET CROSS-SECTION VALUE TO A SMALL NUMBER FOR SIGMA0 AND ANTI SIGMA0 IF ( ITYPE .EQ. 20 .OR. ITYPE .EQ. 28 ) THEN SIGAIR = 1.D-3 ENDIF GHESIG = .TRUE. ELSE USELOW = .FALSE. GHESIG = .FALSE. C CROSS-SECTION FOR BARYONS IS ASSUMED TO BE THE SAME AS FOR NUCLEONS IF ( FVENSG .AND. (ELAB .GE. HILOELB) ) THEN CALL VENSIG(ELAB,1) ELSE C SIGMA IS ENERGY DEPENDENT INELASTIC NUCLEON-NUCLEON CROSS-SECTION IF ( PLAB .LT. 1.D1 ) THEN SIGMA = 29.9D0 ELSEIF ( PLAB .LT. 1.D3 ) THEN PLABLG = LOG(PLAB) C INELASTIC CROSS-SECTIONS FROM PARTICLE DATA GROUP C (A.BALDINI ET AL., LANDOLT-BOERNSTEIN NEW SERIES I/12B (1987) 150) SIGMA = 30.9D0 - 28.9D0 * PLAB**(-2.46D0) * + 0.192D0 * PLABLG**2 - 0.835D0 * PLABLG ELSE SIGMA = 19.87D0 * ELAB**.079D0 ENDIF C AUXIL. QUANTITIES FOR INTERPOLATION SIG45 = SIGMA - 45.D0 S45SQ = SIG45**2 / 450.D0 S4530 = SIG45 / 30.D0 C INELASTIC CROSS-SECTIONS OF AIR FOR PROJECTILE WITH MASS NUMBER 1 SIGAIR = (1.D0 - 2.D0 * S45SQ) * SIG45A(1) * +(S45SQ - S4530) * SIG30A(1) * +(S45SQ + S4530) * SIG60A(1) ENDIF ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : SIGMA,SIGAIR,GHESIG=', * SNGL(SIGMA),SNGL(SIGAIR),GHESIG CALL RMMAR( RD,2,1 ) C MEAN FREE PATH FOR INTERACTION (CHIINT) OR DECAY (CHI) IF ( ITYPE .GE. 18 .AND. ITYPE .LE. 21 ) THEN COR1 = (-LOG(RD(2))) * C(25) * CSTRBA(ITYPE-17) ELSEIF ( ITYPE .GE. 22 .AND. ITYPE .LE. 24 ) THEN COR1 = (-LOG(RD(2))) * C(25) * CSTRBA(ITYPE-15) ELSEIF ( ITYPE .GE. 26 .AND. ITYPE .LE. 29 ) THEN COR1 = (-LOG(RD(2))) * C(25) * CSTRBA(ITYPE-25) ELSEIF ( ITYPE .GE. 30 .AND. ITYPE .LE. 32 ) THEN COR1 = (-LOG(RD(2))) * C(25) * CSTRBA(ITYPE-23) ENDIF IF ( SIGNUM(ITYPE) .EQ. 0.D0 ) THEN C NEUTRAL STRANGE BARYONS CALL NRANGC(COR1*BETA*GAMMA) ELSE C CHARGED STRANGE BARYONS CALL PRANGC(COR1,.FALSE.,HNEW) CHI = MAX( CHI, 0.D0 ) ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,RD(2),CHIDEC=', * ITYPE,RD(2),SNGL(CHI) CHIINT = (-LOG(RD(1))) * AVERAW / (AVOGAD * SIGAIR) IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,RD(1),CHIINT=', * ITYPE,RD(1),SNGL(CHIINT) CHI = MIN( CHIINT, CHI ) IF ( CHI .LT. CHIINT ) THEN FDECAY = .TRUE. ELSE FDECAY = .FALSE. ENDIF C GHEISHA CANNOT TREAT SIGMA0 AND ANTI-SIGMA0, LET THEM DECAY IF (GHESIG .AND. (ITYPE.EQ.20 .OR. ITYPE.EQ.28))FDECAY = .TRUE. C INTERACTION LENGTH STATISTICS IHY = 1.D0 + CHI * 0.1D0 IHY = MIN( IHY, 123 ) IHYCHI(IHY) = IHYCHI(IHY) + 1 IHYCHI(124) = IHYCHI(124) + 1 C----------------------------------------------------------------------- C HEAVY PRIMARIES ( ITYPE = 100 * A + Z , FE -> ITYPE = 5626 ) C ( APPEARING AT FIRST INTERACTION AND AS REMANENTS OF THE PRIMARY ) ELSEIF ( ITYPE .GT. 100 ) THEN IA = ITYPE / 100 IF ( IA .GT. 56 ) THEN WRITE(MONIOU,*) 'BOX2 : UNEXPECTED PARTICLE TYPE=',ITYPE WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: PRMPAR' STOP ENDIF C MEAN FREE PATH OF THE HEAVY PRIMARY IS DEDUCED FROM THAT OF A NUCLEON C ONLY INELASTIC SCATTERING AT INTERACTIONS WITH HEAVY PRIMARY/FRAGMENT ELAB = (PAMA(13) + PAMA(14)) * 0.5D0 * GAMMA PLAB = ELAB * BETA C CALCULATION OF CROSS-SECTION IN THE GHEISHA ROUTINES ELABT = ELAB * IA IF ( ELAB .LE. HILOELB ) THEN USELOW = .TRUE. C GHEISHA CANNOT TREAT NUCLEI GHESIG = .FALSE. ELSE USELOW = .FALSE. GHESIG = .FALSE. ENDIF IF ( FVENSG .AND. (ELAB .GE. HILOELB) ) THEN CALL VENSIG(ELAB,ITYPE) ELSE IF ( GHESIG ) GOTO 333 C SIGMA IS ENERGY DEPENDENT INELASTIC NUCLEON-NUCLEON CROSS-SECTION IF ( PLAB .LT. 1.D1 ) THEN SIGMA = 29.9D0 ELSEIF ( PLAB .LT. 1.D3 ) THEN PLABLG = LOG(PLAB) C INELASTIC CROSS-SECTIONS FROM PARTICLE DATA GROUP C (A.BALDINI ET AL., LANDOLT-BOERNSTEIN NEW SERIES I/12B (1987) 150) SIGMA = 30.9D0 - 28.9D0 * PLAB**(-2.46D0) * + 0.192D0 * PLABLG**2 - 0.835D0 * PLABLG ELSE SIGMA = 19.87D0 * ELAB**.079D0 ENDIF ENDIF C AUXIL. QUANTITIES FOR INTERPOLATION SIG45 = SIGMA - 45.D0 S45SQ = SIG45**2 / 450.D0 S4530 = SIG45 / 30.D0 C INELASTIC CROSS-SECTIONS OF AIR FOR PROJECTILE WITH MASS NUMBER IA SIGAIR = (1.D0 - 2.D0 * S45SQ) * SIG45A(IA) * +(S45SQ - S4530) * SIG30A(IA) * +(S45SQ + S4530) * SIG60A(IA) 333 CONTINUE IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : SIGMA,SIGAIR,GHESIG=', * SNGL(SIGMA),SNGL(SIGAIR),GHESIG C CHECK SIGAIR FOR CORRECT CROSS-SECTION IF ( SIGAIR .LE. 0.D0 ) THEN WRITE(MONIOU,*) 'BOX2: SIGAIR=0.D0, PROGRAM STOPPED ', * ' (UNALLOWED COMBINATION OF PRIMARY WITH CROSS-SECTION)' WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: PRMPAR' STOP ENDIF CALL RMMAR( RD,1,1 ) C MEAN FREE PATH FROM MOLECULAR WEIGHT, AVOGADRO'S CONSTANT AND SIGMA CHI = (-LOG(RD(1))) * AVERAW / (AVOGAD * SIGAIR) FDECAY = .FALSE. IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,RD(1),CHI=', * ITYPE,RD(1),SNGL(CHI) C INTERACTION LENGTH STATISTICS NI = 1.D0 + CHI * 0.1D0 NI = MIN( NI, 123 ) INNCHI( NI) = INNCHI( NI) + 1 INNCHI(124) = INNCHI(124) + 1 C----------------------------------------------------------------------- C ERROR IN PARTICLE CODE ELSE WRITE(MONIOU,*) 'BOX2 : UNEXPECTED PARTICLE TYPE=',ITYPE WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: PRMPAR' STOP ENDIF RETURN END *CMZ : 05/03/2002 08.56.36 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE BOX3(fmfb) C----------------------------------------------------------------------- C C CHECKS PASSAGE THROUGH OBSERVATION LEVEL(S) C IRET1=1 KILLS PARTICLE C IRET2=1 PARTICLE HAS BEEN CUTTED IN UPDATE C THIS SUBROUTINE IS CALLED FROM AAMAIN. C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,GENER. COMMON /GENER/ GEN,ALEVEL DOUBLE PRECISION GEN,ALEVEL *KEEP,IRET. COMMON /IRET/ IRET1,IRET2,IRETE INTEGER IRET1,IRET2 LOGICAL IRETE *KEEP,LONGI. COMMON /LONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG, * SDLONG,SELONG,SPLONG,THSTEP,THSTPI, * LHEIGH,NSTEP,LLONGI,FLGFIT DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9), * APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9), * HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9), * SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI INTEGER LHEIGH,NSTEP LOGICAL LLONGI,FLGFIT *KEEP,OBSPAR. COMMON /OBSPAR/ OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP, * THETPR,PHIPR, * VUECON, * NOBSLV DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10), * HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2) DOUBLE PRECISION VUECON(2) INTEGER NOBSLV *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,THNVAR. COMMON /THNVAR/ STACKINT, * INT_ICOUNT,MODETHN,THINNING INTEGER MAXICOUNT PARAMETER (MAXICOUNT=40000) DOUBLE PRECISION STACKINT(16,MAXICOUNT) INTEGER INT_ICOUNT,MODETHN LOGICAL THINNING c-----changed--add logical fmfb c-----changed--add *KEND. DOUBLE PRECISION THICK INTEGER I,IRET3 SAVE LOGICAL FLAG EXTERNAL THICK C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=1,9) 444 FORMAT(' BOX3 : CURPAR=',1P,9E10.3) IF ( ITYPE .EQ. 5 .OR. ITYPE .EQ. 6 ) THEN C MUONS ARE TRACKED WITHIN SUBR. MUTRAC INT_ICOUNT = 0 CALL MUTRAC(fmfb) CALL TSTEND IRET1 = 1 RETURN ELSEIF ( ITYPE .LE. 3 ) THEN C ELECTRONS OR PHOTONS ARE TREATED IN SUBR. EM CALL EM IRET1 = 1 RETURN ELSEIF ( ITYPE .GE. 50 .AND. ITYPE .LE. 65 ) THEN C RESONANCES DECAY WITHIN SUBR. RESDEC IF (LLONGI) LHEIGH = INT(THICK(H)*THSTPI + 1.D0) INT_ICOUNT = 0 CALL RESDEC CALL TSTEND IRET1 = 1 RETURN ENDIF C FOR ALL THE OTHER PARTICLES THE PLACE OF NEXT INTERACTION WAS C DETERMINED IN BOX2 C UPDATE PARTICLE TO INTERACTION POINT OR OBSERVATION LEVEL, C WHICHEVER IS CLOSER FLAG = .FALSE. c-----changed--add CALL UPDATC(IRET3,FLAG,fmfb) c-----changed--add IF (DEBUG) WRITE(MDEBUG,*) 'BOX3 : IRET1,2,3=', * IRET1,IRET2,IRET3 IF ( IRET2 .NE. 0 ) THEN C PARTICLE CUTTED BEFORE INTERACTION POINT C LONGITUDINAL DEPOSIT IS ALREADY DONE IN UPDATC IRET1 = 1 RETURN ELSE C KILL PARTICLE AS IT IS AT DETECTOR LEVEL IF ( IRET3 .NE. 0 ) THEN IRET1 = 1 RETURN ELSE C STORE PARTICLE FOR FURTHER TREATMENT DO I = 1,8 CURPAR(I) = OUTPAR(I) ENDDO ALEVEL = H BETA = SQRT( GAMMA**2 - 1.D0 ) / GAMMA ENDIF ENDIF RETURN END *CMZ : 23/10/2000 14.43.21 by D. HECK IK3 FZK KARLSRUHE *-- Author : The CORSIKA development group 16/05/95 C======================================================================= DOUBLE PRECISION FUNCTION CHISQ(F) C----------------------------------------------------------------------- C CHI SQ(UARE) C C THIS FUNCTION CALCULATES THE CHI**2 OBTAINED WITH THE HILLAS C FUNCTION AND THE FIT SUBROUT. AMOEBA USING THE PARAMETER SET F C SEE: T.K. GAISSER & A.M. HILLAS, PROC. XV ICRC, PLOVDIV, BULGARIA, C VOL. 8 (1977) 353 C THIS FUNCTION IS CALLED FROM LONGFT AND AMOEBA. C ARGUMETS: C F(1) = HEIGHT AT MAXIMUM C F(2) = SHOWER STARTING POINT C F(3) = T AT MAXIMUM C F(4) = WIDTH PARAMETER 1 C F(5) = WIDTH PARAMETER 2 T C F(6) = WIDTH PARAMETER 3 T**2 C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,CURVE. COMMON /CURVE/ CHAPAR,DEP,ERR,NSTP DOUBLE PRECISION CHAPAR(1200),DEP(1200),ERR(1200) INTEGER NSTP *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DOUBLE PRECISION AUXIL,BALL,BASE,EXPO,F(6),T,WIDTH INTEGER I SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'CHISQ : PARAMETERS,NSTP =', * (SNGL(F(I)),I=1,6),NSTP C EXCLUDE PATHOLOGICAL PARAMETER SETTINGS IF ( F(1) .LE. 0.D0 .OR. F(2) .GE. F(3) .OR. * (F(4).LE.0.D0 .AND. F(5).EQ.0.D0 .AND. F(6).EQ.0.D0) ) THEN CHISQ = 1.D16 RETURN ENDIF CHISQ = 0.D0 C LOOP OVER THE LONGITUDINAL DISTRIBUTION DO 1 I = 1,NSTP T = DEP(I) IF ( T .GT. F(2) ) THEN BASE = (T-F(2)) / (F(3)-F(2)) WIDTH = F(4) + T*F(5) + T**2*F(6) IF ( WIDTH .LT. 1.D-20 ) THEN CHISQ = CHISQ + 1.D16 GOTO 1 ENDIF EXPO = (F(3)-F(2)) / WIDTH AUXIL = (F(3)-T) / WIDTH IF ( ABS(AUXIL) .GT. 20.D0 ) THEN CHISQ = CHISQ + 1.D16 GOTO 1 ENDIF BALL = F(1) * BASE ** EXPO * EXP(AUXIL) ELSE BALL = 0.D0 ENDIF CHISQ = CHISQ + ((BALL-CHAPAR(I))/ERR(I))**2 1 CONTINUE CHISQ = CHISQ / (NSTP-6) IF ( DEBUG ) WRITE(MDEBUG,*) 'CHISQ : CHI**2 =',SNGL(CHISQ) RETURN END *CMZ : 23/10/2000 14.43.21 by D. HECK IK3 FZK KARLSRUHE *-- Author : The CORSIKA development group 16/05/95 C======================================================================= DOUBLE PRECISION FUNCTION CHISQ1(F) C----------------------------------------------------------------------- C CHI SQ(UARE FOR THE) 1(ST FIT FUNCTION)) C C THIS FUNCTION CALCULATES THE CHI**2 OBTAINED WITH THE HILLAS C FUNCTION AND THE FIT SUBROUT. AMOEBA USING THE PARAMETER SET F C SEE: T.K. GAISSER & A.M. HILLAS, PROC. XV ICRC, PLOVDIV, BULGARIA, C VOL. 8 (1977) 353 C THIS FUNCTION IS CALLED FROM LONGFT AND AMOEBA. C ARGUMETS: C F(1) = HEIGHT AT MAXIMUM C F(2) = SHOWER STARTING POINT C F(3) = T AT MAXIMUM C F(4) = WIDTH PARAMETER C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,CURVE. COMMON /CURVE/ CHAPAR,DEP,ERR,NSTP DOUBLE PRECISION CHAPAR(1200),DEP(1200),ERR(1200) INTEGER NSTP *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DOUBLE PRECISION AUXIL,BALL,BASE,EXPO,F(6),T INTEGER I SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*)'CHISQ1: PARAMETERS,NSTP =', * (SNGL(F(I)),I=1,4),NSTP C EXCLUDE PATHOLOGICAL PARAMETER SETTINGS IF ( F(1) .LE. 0.D0 .OR. F(2) .GE. F(3) .OR. * F(4) .LE. 0.D0 ) THEN CHISQ1 = 1.D16 RETURN ENDIF CHISQ1 = 0.D0 C LOOP OVER THE LONGITUDINAL DISTRIBUTION DO 1 I = 1,NSTP T = DEP(I) IF ( T .GT. F(2) ) THEN BASE = (T-F(2)) / (F(3)-F(2)) AUXIL = F(4) IF ( AUXIL .LT. 1.D-20 ) THEN CHISQ1 = CHISQ1 + 1.D16 GOTO 1 ENDIF EXPO = (F(3)-F(2)) / AUXIL AUXIL = (F(3)-T) / AUXIL IF ( ABS(AUXIL) .GT. 20.D0 ) THEN CHISQ1 = CHISQ1 + 1.D16 GOTO 1 ENDIF BALL = F(1) * BASE ** EXPO * EXP(AUXIL) ELSE BALL = 0.D0 ENDIF CHISQ1 = CHISQ1 + ((BALL-CHAPAR(I))/ERR(I))**2 1 CONTINUE CHISQ1 = CHISQ1 / (NSTP-4) IF ( DEBUG ) WRITE(MDEBUG,*) 'CHISQ1 : CHI**2 =',SNGL(CHISQ1) RETURN END *CMZ : 18/10/2000 09.15.11 by D. HECK IK3 FZK KARLSRUHE *-- Author : F. SCHROEDER UNI WUPPERTAL 18/11/98 C======================================================================= SUBROUTINE CORINC C----------------------------------------------------------------------- C CO(O)R(DINATE) IN(ITIALIZATION FOR A) C(URVED ATMOSPHERE) C C INITIALIZES ALL IMPORTANT COORDINATES FOR ONE OBSERVATION LEVEL C ROUTINE DETERMINES STARTING PARAMETERS AT HEIGHT GIVEN BY THICK0 FOR C A COORDINATE SYSTEM WHICH IS FIXED IN (X,Y) AT THE ASSUMED DETECTOR C POSITION AND IN Z AT SEA LEVEL. C THIS SUBROUTINE IS CALLED FROM AAMAIN. C C AUTHOR : F. SCHROEDER UNI WUPPERTAL C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,OBSPAR. COMMON /OBSPAR/ OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP, * THETPR,PHIPR, * VUECON, * NOBSLV DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10), * HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2) DOUBLE PRECISION VUECON(2) INTEGER NOBSLV *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DOUBLE PRECISION DIST,DIAG,TEA SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'CORINC: H,COSTAP,PHI =', * SNGL(H),SNGL(COSTAP),SNGL(PHIP) C NOTE : ANGLES THETAP AND PHIP ARE APPARENT ANGLES OF PRIMARY AT C THE EDGE OF THE ATMOSPHERE SEEN FROM THE C DETECTOR POSITION X=Y=0, Z=OBSLEV(1) C FOR CALCULATIONS: COSTAP = COSINE OF APPARENT ZENITH ANGLE THETAP C COSTAP IS SET IN AAMAIN BY EQUIVALENCE WITH CURPAR(15) C DISTANCE DIAG BETWEEN DETECTOR POSITION X=Y=0, Z = OBSLEV(1) AND C STARTING POINT DIAG = SQRT( (C(1)+H)**2 - (C(1)+OBSLEV(1))**2 *(1.D0-COSTAP**2) ) * - (C(1)+OBSLEV(1)) * COSTAP C APPARENT HEIGHT HAPP IS PARTICLE Z-COORDINATE IN DETECTOR SYSTEM HAPP = OBSLEV(1) + DIAG * COSTAP C CALCULATING COSINE OF THETA_EARTH COSTEA, COSINE OF ZENITH ANGLE BY C TAKING A COORDINATE FRAME CENTERED IN THE MIDDLE OF EARTH COSTEA = (C(1)+HAPP) / (C(1)+H) IF ( DEBUG ) WRITE(MDEBUG,*) 'CORINC: HAPP,COSTEA,DIAG =', * SNGL(HAPP),COSTEA,SNGL(DIAG) COSTEA = MIN( 1.D0, COSTEA ) C TRANSFORM THE APPARENT ANGLE SEEN FROM DETECTOR POSITION TO LOCAL C ANGLES RELATIVE TO THE VERTICAL TO THE MIDDLE OF EARTH C NOTE : LOCAL ZENITH ANGLE = DIFFERENCE OF APPARENT ZENITH ANGLE AND C THETA_EARTH COSTHE = (DIAG + (C(1)+OBSLEV(1))*COSTAP)/(C(1)+H) C DISTANCE DIST BETWEEN THE DETECTOR POSITION X=0, Y=0 C AND THE ACTUAL INTERACTION POINT MEASURED ON THE EARTH'S SURFACE TEA = ACOS(COSTEA) DIST = C(1) * TEA C CONCERNING TRANSFORMATION OF AZIMUTH ANGLE PHI C NOTE : THE COORDINATE SYTEMS ONLY DIFFER IN A SHIFT ALONG THE Z-AXIS C OR A ROTATION ALONG THE ZENITH ANGLE. BOTH TRANSFORMATIONS C JUST CHANGE THETA AND NOT PHI (THETA AND PHI ARE ORTHOGONAL C COORDINATES, THUS LINEAR INDEPENDENT). C X,Y-COORDINATES SEEN FROM THE DETECTOR POSITION (X=Y=0) X = -DIST * COS( PHIP ) Y = -DIST * SIN( PHIP ) IF ( DEBUG ) WRITE(MDEBUG,*) 'CORINC: X,Y,COSTHE,DIST =', * SNGL(X),SNGL(Y),SNGL(COSTHE),SNGL(DIST) C FILL PARAMETERS IN PRMPAR PRMPAR(3) = COSTHE PRMPAR(7) = X PRMPAR(8) = Y C WE HAVE EQUIVALENCES FOR HAPP AND COSTEA C CURPAR(14) = HAPP C CURPAR(16) = COSTEA RETURN END *CMZ : 28/02/2002 13.08.19 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE DATAC C----------------------------------------------------------------------- C DATA C(ARDS) C C READS DATA CARDS FROM UNIT 5 TO STEER RUN. C READING IS FREE FORMAT WITH BLANK AS SEPARATOR. C EACH KEYWORD STARTS ON A NEW LINE LEFTSHIFTED. C THIS SUBROUTINE IS CALLED FROM START. C----------------------------------------------------------------------- c------changed-------add and comand c IMPLICIT NONE c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> c All this lines are under test c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - parameter (xct=1) parameter (yct=2) parameter (zct=3) parameter (ctthet=4) parameter (ctphi=5) parameter (ctdiam=6) parameter (ctfoc=7) c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> c------changed-------add and comand c IMPLICIT NONE *KEEP,ATMOS. COMMON /ATMOS/ AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM DOUBLE PRECISION AATM(5),AATM0(5,0:16),BATM(5),BATM0(5,0:16), * CATM(5),CATM0(5,0:16),DATM(5) INTEGER MODATM *KEEP,ATMOS2. COMMON /ATMOS2/ HLAY,HLAY0,THICKL,LAYNO,LAYNEW DOUBLE PRECISION HLAY(6),HLAY0(5,0:4),THICKL(5) INTEGER LAYNO(0:16) LOGICAL LAYNEW *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,DPMFLG. COMMON /DPMFLG/ NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM INTEGER NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM *KEEP,EGSDEB. COMMON /EGSDEB/ JCLOCK,NCLOCK,FEGSDB INTEGER JCLOCK,NCLOCK LOGICAL FEGSDB *KEEP,ELABCT. COMMON /ELABCT/ ELCUT DOUBLE PRECISION ELCUT(4) *KEEP,ETHMAP. COMMON /ETHMAP/ ECTMAP,ELEFT DOUBLE PRECISION ECTMAP,ELEFT *KEEP,LONGI. COMMON /LONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG, * SDLONG,SELONG,SPLONG,THSTEP,THSTPI, * LHEIGH,NSTEP,LLONGI,FLGFIT DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9), * APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9), * HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9), * SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI INTEGER LHEIGH,NSTEP LOGICAL LLONGI,FLGFIT *KEEP,MAGANG. COMMON /MAGANG/ ARRANG,ARRANR,COSANG,SINANG DOUBLE PRECISION ARRANG,ARRANR,COSANG,SINANG *KEEP,MAGNET. COMMON /MAGNET/ BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT DOUBLE PRECISION BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT *KEEP,MUMULT. COMMON /MUMULT/ CHC,OMC,PHISCT,STEPL,VSCAT,FMOLI DOUBLE PRECISION CHC,OMC,PHISCT,STEPL,VSCAT LOGICAL FMOLI *KEEP,NKGI. COMMON /NKGI/ SEL,SELLG,STH,ZEL,ZELLG,ZSL,DIST, * DISX,DISY,DISXY,DISYX,DLAX,DLAY,DLAXY,DLAYX, * OBSATI,RADNKG,RMOL,TLEV,TLEVCM,IALT DOUBLE PRECISION SEL(10),SELLG(10),STH(10),ZEL(10),ZELLG(10), * ZSL(10),DIST(10), * DISX(-10:10),DISY(-10:10), * DISXY(-10:10,2),DISYX(-10:10,2), * DLAX (-10:10,2),DLAY (-10:10,2), * DLAXY(-10:10,2),DLAYX(-10:10,2), * OBSATI(2),RADNKG,RMOL(2),TLEV(10),TLEVCM(10) INTEGER IALT(2) *KEEP,OBSPAR. COMMON /OBSPAR/ OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP, * THETPR,PHIPR, * VUECON, * NOBSLV DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10), * HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2) DOUBLE PRECISION VUECON(2) INTEGER NOBSLV *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PRIMSP. COMMON /PRIMSP/ PSLOPE,LLIMIT,ULIMIT,LL,UL,SLEX,ISPEC DOUBLE PRECISION PSLOPE,LLIMIT,ULIMIT,LL,UL,SLEX INTEGER ISPEC *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,REJECT. COMMON /REJECT/ AVNREJ,ALTMIN,ANEXP,THICKA,THICKD,CUTLN,EONCUT, * FNPRIM DOUBLE PRECISION AVNREJ(10),ALTMIN(10),ANEXP(10),THICKA(10), * THICKD(10),CUTLN,EONCUT LOGICAL FNPRIM *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,VENPAR. COMMON /VENPAR/ PARVAL,NPARAM,PARCHA REAL PARVAL(100) INTEGER NPARAM CHARACTER*6 PARCHA(100) *KEEP,VENUS. COMMON /VENUS/ ISH00,IVERVN,MTAR99,FVENUS,FVENSG INTEGER ISH00,IVERVN,MTAR99 LOGICAL FVENUS,FVENSG *KEEP,CEREN1. COMMON /CEREN1/ CERELE,CERHAD,ETADSN,WAVLGL,WAVLGU,CYIELD, * CERSIZ,CERNOR,LCERFI DOUBLE PRECISION CERELE,CERHAD,ETADSN,WAVLGL,WAVLGU,CYIELD, * CERSIZ,CERNOR LOGICAL LCERFI *KEEP,CEREN2. COMMON /CEREN2/ ACERX,ACERY,CERXOS,CERYOS, * DCERX,DCERXI,DCERY,DCERYI,EPSX,EPSY,FCERX,FCERY, * WL,XCMAX,XCMAXS,XSCATT,YCMAX,YCMAXS,YSCATT, * PHOTCM,XCER,YCER,UEMIS,VEMIS,WEMIS,CARTIM,ZEMIS, * NCERX,NCERY,ICERML DOUBLE PRECISION ACERX,ACERY,CERXOS(20),CERYOS(20), * DCERX,DCERXI,DCERY,DCERYI,EPSX,EPSY,FCERX,FCERY, * WL,XCMAX,XCMAXS,XSCATT,YCMAX,YCMAXS,YSCATT DOUBLE PRECISION PHOTCM,XCER,YCER,UEMIS,VEMIS,WEMIS,CARTIM,ZEMIS INTEGER NCERX,NCERY,ICERML *KEEP,ATMOSX. C EXTERNAL ATMOSPHERIC MODELS COMMON /ATMOSX/ IATMOX,FREFRX INTEGER IATMOX LOGICAL FREFRX *KEND. c------changed-----add c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> c All this lines are under test c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *keep,certel. common /certel/ cormxd,cord,coralp,ctpars,omega, + photn,photnp,phpt,pht,vphot, + vchi,veta,vzeta,vchim,vetam,vzetam, + lambda,mu,nu,nctels,ncph,phip1,thetap1 double precision cormxd,cord,coralp,ctpars(20,7),omega(20,3,3), + photn(3),photnp(3),phpt(3),pht,vphot(3), + vchi(3),veta(3),vzeta(3),vchim,vetam,vzetam, + lambda,mu,nu integer nctels,ncph(5) double precision xg,yg,zg,xgp,ygp,zgp,up,vp,wp,xpcut,ypcut,zpcut double precision thetap1,phip1 equivalence (photn(1) ,xg) ,(photn(2) ,yg) ,(photn(3) ,zg) , + (photnp(1),xgp) ,(photnp(2),ygp) ,(photnp(3),zgp), + (phpt(1) ,xpcut),(phpt(2) ,ypcut),(phpt(3) ,zpcut), + (vphot(1) ,up) ,(vphot(2) ,vp) ,(vphot(3) ,wp) character *72 ctfile character *6 keyw c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> c Angles for the "spinning" of a particle around the c main axis of the CT common /spinang/ spinxi double precision spinxi C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> integer m,nct cxx---------------- c------changed-----add DOUBLE PRECISION R1,R2 INTEGER I,IE,IOBSLV,IS,ISEQ,MMM,MONNEW,NNTYP,NUMERR INTEGER LENVAL INTEGER IPARAM CHARACTER LINE*132,TAB*1 SAVE C----------------------------------------------------------------------- C WRITE TITEL WRITE(MONIOU,999) 999 FORMAT(' ',10('='),' USERS RUN DIRECTIVES FOR THIS SIMULATION ', * 27('=')/) C SET TABULATOR TAB = CHAR(9) C DEFAULT VALUES FOR ALL RUN PARAMETERS ISEQ = 0 NSEQ = 2 ISEED(1,1) = 1 ISEED(2,1) = 0 ISEED(3,1) = 0 ISEED(1,2) = 2 ISEED(2,2) = 0 ISEED(3,2) = 0 ISEED(1,3) = 3 ISEED(2,3) = 0 ISEED(3,3) = 0 NRRUN = 1 ISHOWNO = 0 LLIMIT = 1.D4 ULIMIT = 1.D4 PSLOPE = 0.D0 PRMPAR(1) = 14.D0 THETPR(1) = 0.D0 THETPR(2) = 0.D0 PHIPR(1) = 0.D0 PHIPR(2) = 0.D0 NSHOW = 10 IOBSLV = 0 NOBSLV = 1 OBSLEV(1) = 110.D2 MODATM = 1 LAYNEW = .FALSE. ELCUT(1) = 0.3D0 ELCUT(2) = 0.3D0 ELCUT(3) = 0.003D0 ELCUT(4) = 0.003D0 ECTMAP = 1.D4 NFLAIN = 0 NFLDIF = 0 NFLPI0 = 0 NFLPIF = 0 NFLCHE = 0 NFRAGM = 2 FNKG = .TRUE. FMOLI = .TRUE. FMUADD = .FALSE. FEGS = .FALSE. FPAROUT = .TRUE. FTABOUT = .FALSE. STEPFC = 1.D0 MAXPRT = 10 BX = 20.40D0 BZ = 43.23D0 ARRANG = 0.D0 LLONGI = .FALSE. THSTEP = 20.D0 FLGFIT = .FALSE. FLONGOUT= .FALSE. RADNKG = 200.D2 C BORDER BETWEEN LOW AND HIGH ENERGY INTERACTION MODELS C SET BY DEFAULT TO ELAB = 80 GEV HILOELB = 80.D0 GHEISH = .TRUE. GHEISDB = .FALSE. FDBASE = .FALSE. DEBUG = .FALSE. DEBDEL = .FALSE. NDEBDL = 100000000 THICK0 = 0.D0 FIX1I = .FALSE. FIXHEI = 0.D0 DSN = 'anynameupto64characters ' TMARGIN = .FALSE. HOST = ' ' USER = ' ' STEPFC = 1.D0 WAVLGL = 300.D0 WAVLGU = 450.D0 CERSIZ = 0.D0 NCERX = 27 NCERY = 27 DCERX = 1500.D0 DCERY = 1500.D0 ACERX = 100.D0 ACERY = 100.D0 LCERFI = .TRUE. ICERML = 1 XSCATT = 0.D0 YSCATT = 0.D0 DO 554 I = 1,20 CERXOS(I) = 0.D0 CERYOS(I) = 0.D0 554 CONTINUE IATMOX = 0 FREFRX = .FALSE. FVENUS = .TRUE. ISH00 = 91 IPARAM = 0 NPARAM = 0 DO 555 I = 1,100 PARVAL(I) = 0. 555 CONTINUE FVENSG = .TRUE. VUECON(1) = 0.D0 VUECON(2) = 0.D0 C----------------------------------------------------------------------- C OPEN DATASET FOR COMMANDS IF ( MONIIN .NE. 5 ) THEN OPEN(UNIT=MONIIN,FILE='INPUTS',STATUS='OLD',FORM='FORMATTED') WRITE(MONIOU,*) 'DATA CARDS FOR RUN STEERING ARE ', * 'EXPECTED FROM UNIT',MONIIN ELSE WRITE(MONIOU,*) 'DATA CARDS FOR RUN STEERING ARE ', * 'EXPECTED FROM STANDARD INPUT' ENDIF NUMERR = 0 C----------------------------------------------------------------------- 1 CONTINUE C ERASE 'LINE' BY FILLING WITH BLANKS LINE = ' ' C GET A NEW INPUT LINE AND PRINT IT READ(MONIIN,500,END=1000) LINE 500 FORMAT(A) DO 10 IE = LEN(LINE),1,-1 IF ( LINE(IE:IE).NE.' ' ) GOTO 11 10 CONTINUE 11 CONTINUE C CHECK FOR HORIZONTAL TABS AND ELIMINATE THEM DO I = 1,IE IF ( LINE(I:I) .EQ. TAB ) THEN LINE(I:I) = ' ' ENDIF ENDDO C ECHO WRITE THE INPUT LINE IF ( DEBUG ) THEN WRITE(MDEBUG,501) LINE(1:IE) 501 FORMAT(' DATAC : ',A) ELSE WRITE(MONIOU,502) LINE(1:IE) 502 FORMAT(' ',A) ENDIF C CONVERT LOWER CASE CHARACTERS TO UPPER CASE DO 3 I = 1,5 CALL LOWUP(LINE(I:I)) 3 CONTINUE IF ( LINE(1:4).NE.'HOST' .AND. LINE(1:4).NE.'USER' ) THEN CALL LOWUP(LINE(6:6)) IF ( LINE(1:6).NE.'DIRECT' .AND. LINE(1:6).NE.'HISTDS' * ) THEN DO 4 I = 7,LEN(LINE) CALL LOWUP(LINE(I:I)) 4 CONTINUE ENDIF ENDIF C----------------------------------------------------------------------- C INTERPRET KEYWORD AND READ PARAMETERS IS = 0 C DUMMY LINE (MAY BE USED FOR COMMENTS) NO ACTION IF ( LINE(1:6) .EQ. ' ' ) THEN ELSEIF ( LINE(1:1) .EQ. '*' ) THEN ELSEIF ( LINE(1:2) .EQ. 'C ' ) THEN C GET ANGLE (DEGREES) BETWEEN ARRAY X-DIRCTION AND MAGNETIC NORD ELSEIF ( LINE(1:6) .EQ. 'ARRANG' ) THEN CALL DTCDBL(LINE,IS,ARRANG,'ARRANG',1) C GET INTERNAL ATMOSPHERIC MODEL NUMBER ELSEIF ( LINE(1:5) .EQ. 'ATMOD' ) THEN CALL DTCINT(LINE,IS,MODATM,'ATMOD',1) C READ ATMOSPHERIC PARAMETERS AATM(.,0) ELSEIF ( LINE(1:4) .EQ. 'ATMA' ) THEN CALL DTCDBL(LINE,IS,AATM0(1,0),'ATMA',1) CALL DTCDBL(LINE,IS,AATM0(2,0),'ATMA',2) CALL DTCDBL(LINE,IS,AATM0(3,0),'ATMA',3) CALL DTCDBL(LINE,IS,AATM0(4,0),'ATMA',4) AATM0(5,0) = .01128292D0 IF ( MODATM .EQ. 10 ) THEN AATM0(1,10) = AATM0(1,0) AATM0(2,10) = AATM0(2,0) AATM0(3,10) = AATM0(3,0) AATM0(4,10) = AATM0(4,0) CALL DTCDBL(LINE,IS,AATM0(5,10),'ATMA',5) ENDIF C READ ATMOSPHERIC PARAMETERS BATM(.,0) ELSEIF ( LINE(1:4) .EQ. 'ATMB' ) THEN CALL DTCDBL(LINE,IS,BATM0(1,0),'ATMB',1) CALL DTCDBL(LINE,IS,BATM0(2,0),'ATMB',2) CALL DTCDBL(LINE,IS,BATM0(3,0),'ATMB',3) CALL DTCDBL(LINE,IS,BATM0(4,0),'ATMB',4) BATM0(5,0) = 1.D0 IF ( MODATM .EQ. 10 ) THEN BATM0(1,10) = BATM0(1,0) BATM0(2,10) = BATM0(2,0) BATM0(3,10) = BATM0(3,0) BATM0(4,10) = BATM0(4,0) ENDIF C READ ATMOSPHERIC PARAMETERS CATM(.,0) ELSEIF ( LINE(1:4) .EQ. 'ATMC' ) THEN CALL DTCDBL(LINE,IS,CATM0(1,0),'ATMC',1) CALL DTCDBL(LINE,IS,CATM0(2,0),'ATMC',2) CALL DTCDBL(LINE,IS,CATM0(3,0),'ATMC',3) CALL DTCDBL(LINE,IS,CATM0(4,0),'ATMC',4) CATM0(5,0) = 1.D9 IF ( MODATM .EQ. 10 ) THEN CATM0(1,10) = CATM0(1,0) CATM0(2,10) = CATM0(2,0) CATM0(3,10) = CATM0(3,0) CATM0(4,10) = CATM0(4,0) CALL DTCDBL(LINE,IS,CATM0(5,10),'ATMC',5) ENDIF C READ ATMOSPHERIC LAYER BOUNDARIES HLAY0(.,0) ELSEIF ( LINE(1:6) .EQ. 'ATMLAY' ) THEN CALL DTCDBL(LINE,IS,HLAY0(2,0),'ATMLAY',1) CALL DTCDBL(LINE,IS,HLAY0(3,0),'ATMLAY',2) CALL DTCDBL(LINE,IS,HLAY0(4,0),'ATMLAY',3) CALL DTCDBL(LINE,IS,HLAY0(5,0),'ATMLAY',4) HLAY0(1,0) = 0.D0 LAYNEW = .TRUE. C SET EXTERNAL ATMOSPHERIC MODEL (MOST USEFUL FOR CHERENKOV LIGHT) C AND DETERMINE IF ATMOSPHERIC REFRACTION SHOULD BE ACCOUNTED FOR. ELSEIF ( LINE(1:10) .EQ. 'ATMOSPHERE' ) THEN CALL DTCINT(LINE,IS,IATMOX,'ATMOSPHERE',1) CALL DTCLOG(LINE,IS,FREFRX,'ATMOSPHERE',2) C GET CHERENKOV ARRAY SPECIFICATIONS ELSEIF ( LINE(1:6) .EQ. 'CERARY' ) THEN CALL DTCINT(LINE,IS,NCERX,'CERARY',1) CALL DTCINT(LINE,IS,NCERY,'CERARY',2) CALL DTCDBL(LINE,IS,DCERX,'CERARY',3) CALL DTCDBL(LINE,IS,DCERY,'CERARY',4) CALL DTCDBL(LINE,IS,ACERX,'CERARY',5) CALL DTCDBL(LINE,IS,ACERY,'CERARY',6) C GET CHERENKOV OUTPUT FLAG ELSEIF ( LINE(1:6) .EQ. 'CERFIL' ) THEN CALL DTCLOG(LINE,IS,LCERFI,'CERFIL',1) C GET MAXIMUM BUNCH SIZE FOR CHERENKOV PHOTONS ELSEIF ( LINE(1:6) .EQ. 'CERSIZ' ) THEN CALL DTCDBL(LINE,IS,CERSIZ,'CERSIZ',1) C GET CHERENKOV EVENT SCATTERING INFORMATION ELSEIF ( LINE(1:5) .EQ. 'CSCAT' ) THEN CALL DTCINT(LINE,IS,ICERML,'CSCAT',1) CALL DTCDBL(LINE,IS,XSCATT,'CSCAT',2) CALL DTCDBL(LINE,IS,YSCATT,'CSCAT',3) C GET CHERENKOV WAVELENGTH BAND ELSEIF ( LINE(1:6) .EQ. 'CWAVLG' ) THEN CALL DTCDBL(LINE,IS,R1,'CWAVLG',1) CALL DTCDBL(LINE,IS,R2,'CWAVLG',2) WAVLGL = MIN( R1, R2 ) WAVLGU = MAX( R1, R2 ) C GET DATABASE FLAG ELSEIF ( LINE(1:6) .EQ. 'DATBAS' ) THEN CALL DTCLOG(LINE,IS,FDBASE,'DATBAS',1) C GET DEBUG FLAG AND DELAYED DEBUG PARAMETERS ELSEIF ( LINE(1:5) .EQ. 'DEBUG' ) THEN CALL DTCLOG(LINE,IS,DEBUG,'DEBUG',1) CALL DTCINT(LINE,IS,MMM,'DEBUG',2) CALL DTCLOG(LINE,IS,DEBDEL,'DEBUG',3) CALL DTCINT(LINE,IS,NDEBDL,'DEBUG',4) IF ( MMM .LE. 0 .OR. MMM .GT. 99 ) THEN MDEBUG = 6 ELSE MDEBUG = MMM ENDIF C GET OUTPUT DIRECTORY FOR CALCULATIONS ON UNIX-STATION ELSEIF ( LINE(1:6) .EQ. 'DIRECT' ) THEN CALL DTCCHR(LINE,IS,DSN,'DIRECT',1,LENVAL) C GET ENERGY CUTS FOR PARTICLE PRINTOUT ELSEIF ( LINE(1:6) .EQ. 'ECTMAP' ) THEN CALL DTCDBL(LINE,IS,ECTMAP,'ECTMAP',1) C GET ENERGY CUTS FOR HADRONS, MUONS, ELECTRONS, AND PHOTONS ELSEIF ( LINE(1:5) .EQ. 'ECUTS' ) THEN CALL DTCDBL(LINE,IS,ELCUT(1),'ECUTS',1) CALL DTCDBL(LINE,IS,ELCUT(2),'ECUTS',2) CALL DTCDBL(LINE,IS,ELCUT(3),'ECUTS',3) CALL DTCDBL(LINE,IS,ELCUT(4),'ECUTS',4) C GET COUNTER FOR START OF EGS DEBUGGUNG ELSEIF ( LINE(1:6) .EQ. 'EGSDEB' ) THEN CALL DTCINT(LINE,IS,JCLOCK,'EGSDEB',1) C GET FLAGS FOR ELECTROMAGNETIC OPTIONS (NKG, EGS) ELSEIF ( LINE(1:6) .EQ. 'ELMFLG' ) THEN CALL DTCLOG(LINE,IS,FNKG,'ELMFLG',1) CALL DTCLOG(LINE,IS,FEGS,'ELMFLG',2) C GET ENERGY RANGE OF PRIMARY PARTICLE ELSEIF ( LINE(1:6) .EQ. 'ERANGE' ) THEN CALL DTCDBL(LINE,IS,LLIMIT,'ERANGE',1) CALL DTCDBL(LINE,IS,ULIMIT,'ERANGE',2) C GET SLOPE OF ENERGY SPECTRUM OF PRIMARY PARTICLE ELSEIF ( LINE(1:6) .EQ. 'ESLOPE' ) THEN CALL DTCDBL(LINE,IS,PSLOPE,'ESLOPE',1) C GET FIRST EVENT NUMBER ELSEIF ( LINE(1:5) .EQ. 'EVTNR' ) THEN CALL DTCINT(LINE,IS,ISHOWNO,'EVTNR',1) ISHOWNO = MAX( ISHOWNO-1, 0 ) c------changed-----add----- c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> c get cerenkov file name with cts array specifications elseif ( LINE(1:6) .eq. 'CERTEL' ) then read(line(7:),'(I10)') nctels d2r = 3.1415926535897932385/180.0 do 1967 nct=1,nctels read(moniin,*) (ctpars(nct,m),m=1,7) ct = cos(ctpars(nct,ctthet)*d2r) st = sin(ctpars(nct,ctthet)*d2r) cp = cos(ctpars(nct,ctphi)*d2r) sp = sin(ctpars(nct,ctphi)*d2r) omega(nct,1,1) = cp omega(nct,1,2) = sp omega(nct,1,3) = 0.0 omega(nct,2,1) = -ct*sp omega(nct,2,2) = ct*cp omega(nct,2,3) = st omega(nct,3,1) = st*sp omega(nct,3,2) = -st*cp omega(nct,3,3) = ct c write(moniou,*) nct,(ctpars(nct,m),m=1,7) 1967 continue c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> c---------changed-------add C END OF DATA CARD INPUT ELSEIF ( LINE(1:4) .EQ. 'EXIT' ) THEN IF ( DEBUG ) THEN WRITE(MDEBUG,*) 'DATAC : END OF DATACARD INPUT' ELSE WRITE(MONIOU,*) WRITE(MONIOU,*) 'END OF DATACARD INPUT' ENDIF GOTO 1001 C GET FIXED HEIGHT (G/CM**2) OF PARTICLE START ELSEIF ( LINE(1:6) .EQ. 'FIXCHI' ) THEN CALL DTCDBL(LINE,IS,THICK0,'FIXCHI',1) C GET FIXED HEIGHT OF FIRST INTERACTION AND FIRST TARGET ELSEIF ( LINE(1:6) .EQ. 'FIXHEI' ) THEN CALL DTCDBL(LINE,IS,FIXHEI,'FIXHEI',1) CALL DTCINT(LINE,IS,N1STTR,'FIXHEI',2) IF ( FIXHEI .GT. 0. ) FIX1I = .TRUE. C GET FLAG FOR GHEISHA DEBUG ELSEIF ( LINE(1:6) .EQ. 'GHEIDB' ) THEN CALL DTCLOG(LINE,IS,GHEISDB,'GHEIDB',1) C GET FLAGS FOR HADRON INTERACTION OPTIONS ELSEIF ( LINE(1:6) .EQ. 'HADFLG' ) THEN CALL DTCINT(LINE,IS,NFLAIN,'HADFLG',1) CALL DTCINT(LINE,IS,NFLDIF,'HADFLG',2) CALL DTCINT(LINE,IS,NFLPI0,'HADFLG',3) CALL DTCINT(LINE,IS,NFLPIF,'HADFLG',4) CALL DTCINT(LINE,IS,NFLCHE,'HADFLG',5) CALL DTCINT(LINE,IS,NFRAGM,'HADFLG',6) C GET NAME OF HOST COMPUTER ELSEIF ( LINE(1:4) .EQ. 'HOST' ) THEN CALL DTCCHR(LINE,IS,HOST,'HOST',1,LENVAL) C GET PARAMETER FOR LONGITUDINAL DEVELOPMENT ELSEIF ( LINE(1:5) .EQ. 'LONGI' ) THEN CALL DTCLOG(LINE,IS,LLONGI,'LONGI',1) CALL DTCDBL(LINE,IS,THSTEP,'LONGI',2) CALL DTCLOG(LINE,IS,FLGFIT,'LONGI',3) CALL DTCLOG(LINE,IS,FLONGOUT,'LONGI',4) C GET PARAMETERS OF MAGNETIC FIELD ELSEIF ( LINE(1:6) .EQ. 'MAGNET' ) THEN CALL DTCDBL(LINE,IS,BX,'MAGNET',1) CALL DTCDBL(LINE,IS,BZ,'MAGNET',2) C GET NUMBER OF EVENTS TO BE PRINTED ELSEIF ( LINE(1:6) .EQ. 'MAXPRT' ) THEN CALL DTCINT(LINE,IS,MAXPRT,'MAXPRT',1) IF ( MAXPRT .LT. 0 ) MAXPRT = 10 C GET FLAG FOR ADDITIONAL MUON INFORMATION ON MPATAP ELSEIF ( LINE(1:6) .EQ. 'MUADDI' ) THEN CALL DTCLOG(LINE,IS,FMUADD,'MUADDI',1) C GET FLAG FOR MUON MULTIPLE SCATTERING (T=MOLIERE, F=GAUSS) ELSEIF ( LINE(1:6) .EQ. 'MUMULT' ) THEN CALL DTCLOG(LINE,IS,FMOLI,'MUMULT',1) C GET NUMBER OF SHOWERS TO BE PRODUCED ELSEIF ( LINE(1:5) .EQ. 'NSHOW' ) THEN CALL DTCINT(LINE,IS,NSHOW,'NSHOW',1) IF ( NSHOW .LE. 0 ) NSHOW = 1 C GET HEIGHT OF OBSERVATION LEVELS ELSEIF ( LINE(1:6) .EQ. 'OBSLEV' ) THEN IOBSLV = IOBSLV + 1 IF ( IOBSLV .LE. 1 ) THEN CALL DTCDBL(LINE,IS,OBSLEV(IOBSLV),'OBSLEV',1) NOBSLV = IOBSLV ELSE WRITE(MONIOU,*) 'DATAC : ONLY ONE OBSERVATION LEVEL ,', * 'POSSIBLE IN CURVED VERSION' STOP ENDIF C GET NEW MONITOR OUTPUT UNIT ELSEIF ( LINE(1:6) .EQ. 'OUTPUT' ) THEN CALL DTCINT(LINE,IS,MONNEW,'OUTPUT',1) WRITE(MONIOU,593) MONIOU,MONNEW 593 FORMAT(' ATTENTION'/' ========='/ * ' LOGFILE OUTPUT REDIRECTED FROM UNIT ',I3, * ' TO UNIT ',I3) MONIOU = MONNEW C GET FLAGS FOR PARTICLE AND TABLE OUTPUT ELSEIF ( LINE(1:6) .EQ. 'PAROUT' ) THEN CALL DTCLOG(LINE,IS,FPAROUT,'PAROUT',1) CALL DTCLOG(LINE,IS,FTABOUT,'PAROUT',2) C GET PHI OF PRIMARY PARTICLE ELSEIF ( LINE(1:4) .EQ. 'PHIP' ) THEN CALL DTCDBL(LINE,IS,R1,'PHIP',1) CALL DTCDBL(LINE,IS,R2,'PHIP',2) PHIPR(1) = MIN( R1, R2 ) PHIPR(2) = MAX( R1, R2 ) C GET TYPE OF PRIMARY PARTICLE ELSEIF ( LINE(1:6) .EQ. 'PRMPAR' ) THEN CALL DTCINT(LINE,IS,NNTYP,'PRMPAR',1) PRMPAR(1) = NNTYP C GET WIDTH OF NKG LATERAL DISTRIBUTION ELSEIF ( LINE(1:6) .EQ. 'RADNKG' ) THEN CALL DTCDBL(LINE,IS,RADNKG,'RADNKG',1) C GET RUN NUMBER ELSEIF ( LINE(1:5) .EQ. 'RUNNR' ) THEN CALL DTCINT(LINE,IS,NRRUN,'RUNNR',1) NRRUN = ABS(NRRUN) C GET SEEDS OF RANDOM NUMBER SEQUENCES ELSEIF ( LINE(1:4) .EQ. 'SEED' ) THEN ISEQ = ISEQ + 1 IF ( ISEQ .LE. 10 ) THEN CALL DTCINT(LINE,IS,ISEED(1,ISEQ),'SEED',1) CALL DTCINT(LINE,IS,ISEED(2,ISEQ),'SEED',2) CALL DTCINT(LINE,IS,ISEED(3,ISEQ),'SEED',3) NSEQ = ISEQ ELSE WRITE(MONIOU,*) 'DATAC : TOO MANY RANDOM GENERATOR SEEDS,', * ' IGNORE IT' ENDIF C GET FACTOR FOR ELECTRON'S MULTIPLE SCATTERING LENGTH ELSEIF ( LINE(1:6) .EQ. 'STEPFC' ) THEN CALL DTCDBL(LINE,IS,STEPFC,'STEPFC',1) C GET THETA OF PRIMARY PARTICLE ELSEIF ( LINE(1:6) .EQ. 'THETAP' ) THEN CALL DTCDBL(LINE,IS,R1,'THETAP',1) CALL DTCDBL(LINE,IS,R2,'THETAP',2) THETPR(1) = MIN( R1, R2 ) THETPR(2) = MAX( R1, R2 ) C GET NAME OF USER ELSEIF ( LINE(1:4) .EQ. 'USER' ) THEN CALL DTCCHR(LINE,IS,USER,'USER',1,LENVAL) C GET VENUS PARAMETER WITH CODE WORD AND VALUE ELSEIF ( LINE(1:6) .EQ. 'VENPAR' ) THEN IPARAM = IPARAM + 1 IF ( IPARAM .LE. 100 ) THEN CALL DTCCHR(LINE,IS,PARCHA(IPARAM),'VENPAR',1,LENVAL) CALL DTCRL(LINE,IS,PARVAL(IPARAM),'VENPAR',2) NPARAM = IPARAM ELSE WRITE(MONIOU,*) 'DATAC : TOO MANY VENUS PARAMETERS,', * ' IGNORE IT' ENDIF C GET CROSS-SECTION FLAG FOR VENUS HADRONIC INTERACTION MODEL ELSEIF ( LINE(1:6) .EQ. 'VENSIG' ) THEN CALL DTCLOG(LINE,IS,FVENSG,'VENSIG',1) C GET FLAG FOR VENUS HIGH ENERGY HADRONIC INTERACTION MODEL C GET PARAMETER ISH00 FOR AMOUNT OF VENUS DEBUG ELSEIF ( LINE(1:5) .EQ. 'VENUS' ) THEN CALL DTCLOG(LINE,IS,FVENUS,'VENUS',1) CALL DTCINT(LINE,IS,ISH00,'VENUS',2) C GET CIRCULAR ANGLE RANGE FROM (FIXED) THETA AND PHI DIRECTION C WHERE SIMULATED SHOWER DIRECTION SHOULD BE. ELSEIF (LINE(1:8) .EQ. 'VIEWCONE' ) THEN CALL DTCDBL(LINE,IS,R1,'VIEWCONE',1) CALL DTCDBL(LINE,IS,R2,'VIEWCONE',2) VUECON(1) = MIN(R1,R2) VUECON(2) = MAX(R1,R2) C ILLEGAL KEYWORD ELSE IE = INDEX(LINE,' ') IF ( IE.LE.0 ) IE = LEN(LINE)+1 WRITE(MONIOU,*) 'DATAC : UNKNOWN KEYWORD : ',LINE(1:IE-1) NUMERR = NUMERR + 1 ENDIF IF ( LINE(1:1) .EQ. '!' ) NUMERR = NUMERR + 1 GOTO 1 C----------------------------------------------------------------------- 1000 CONTINUE IF ( DEBUG ) THEN WRITE(MDEBUG,*) 'DATAC : NO MORE DIRECTIVES FOUND' ELSE WRITE(MONIOU,*) '*** NO MORE DIRECTIVES FOUND ***' ENDIF 1001 IF ( NUMERR .GT. 0 ) THEN WRITE(MONIOU,9000) NUMERR 9000 FORMAT(1X,I3,' SYNTAX ERROR(S) IN INPUT DATA CARDS.') STOP 'BAD DATA CARDS' ENDIF RETURN END *CMZ : 27/02/2002 16.27.13 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE DECAY1( M0,M3,M4 ) C----------------------------------------------------------------------- C DECAY (INTO TWO PARTICLES) C C TWO PARTICLE DECAY WITH FULL KINEMATIC; ENERGY AND MOMENTA CONSERVED C THIS SUBROUTINE IS CALLED FROM KDECAY, RESDEC, AND STRDEC. C ARGUMENTS: C M0 = TYPE OF DECAYING PARTICLE C M3 = TYPE OF FIRST PRODUCT PARTICLE (HADRON) C M4 = TYPE OF SECOND PRODUCT PARTICLE (HADRON OR GAMMA) C C DESIGN : D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,LONGI. COMMON /LONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG, * SDLONG,SELONG,SPLONG,THSTEP,THSTPI, * LHEIGH,NSTEP,LLONGI,FLGFIT DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9), * APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9), * HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9), * SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI INTEGER LHEIGH,NSTEP LOGICAL LLONGI,FLGFIT *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DOUBLE PRECISION AUX1,AUX2,AUX2A,AUX3,AUX4,COSTCM,COSTH3,COSTH4, * GAMMA3,GAMMA4,PHI4,WORK1,WORK2 INTEGER I,M0,M3,M4 SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,444) BETA,M0,M3,M4 444 FORMAT(' DECAY1: BETA,M0,M3,M4=',1P,E10.3,3I5) C PARTICLE COORDINATES 5..10 ARE COPIED INTO SECPAR IN CALLING PROGRAM C CALCULATE AUXILIARY QUANTITIES AUX1 = ( ( PAMA(M0)**2 + PAMA(M3)**2 - PAMA(M4)**2 ) * / (2.D0*PAMA(M0)) )**2 - PAMA(M3)**2 AUX2 = 1.D0 + AUX1 / PAMA(M3)**2 AUX2A = SQRT(AUX2) AUX3 = SQRT( 1.D0 - 1.D0 / AUX2 ) WORK1 = GAMMA * AUX2A WORK2 = AUX3 * BETA * WORK1 C DETERMINE POLAR ANGLE IN CM SYSTEM CALL RMMAR( RD,2,1 ) COSTCM = 2.D0 * RD(1) - 1.D0 GAMMA3 = WORK1 + WORK2 * COSTCM C SECOND PRODUCT PARTICLE WITH NONVANISHING REST MASS IF ( PAMA(M4) .NE. 0.D0 ) THEN GAMMA4 = (PAMA(M0)*GAMMA - PAMA(M3)*GAMMA3) / PAMA(M4) AUX4 = (PAMA(M0)**2 + PAMA(M4)**2 - PAMA(M3)**2 ) * / (2.D0*PAMA(M0)*PAMA(M4)) COSTH4 = MIN( 1.D0, (GAMMA*GAMMA4 - AUX4) * / (BETA * GAMMA * SQRT(GAMMA4**2 - 1.D0)) ) ELSE C SECOND PRODUCT PARTICLE IS GAMMA; THEN GAMMA4 IS THE ENERGY GAMMA4 = PAMA(M0)*GAMMA - PAMA(M3)*GAMMA3 COSTH4 = MIN( 1.D0, (BETA - COSTCM)/(1.D0 - BETA*COSTCM) ) ENDIF PHI4 = RD(2)*PI2 CALL ADDANG( COSTHE,PHI, COSTH4,PHI4, SECPAR(3),SECPAR(4) ) IF ( SECPAR(3) .GT. C(29) ) THEN SECPAR(1) = M4 SECPAR(2) = GAMMA4 IF ( DEBUG ) WRITE(MDEBUG,445) (SECPAR(I),I=1,9) 445 FORMAT(' DECAY1: SECPAR=',1P,8E10.3,0P,F10.0) CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( M4 .EQ. 1 ) THEN DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + GAMMA4 ELSE DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + GAMMA4 * PAMA(M4) ENDIF ENDIF ENDIF C FIRST PRODUCT PARTICLE COSTH3 = MIN( 1.D0, (GAMMA * GAMMA3 - AUX2A) * / (BETA * GAMMA * SQRT(GAMMA3**2 - 1.D0)) ) CALL ADDANG( COSTHE,PHI, COSTH3,PHI4+PI, SECPAR(3),SECPAR(4) ) IF ( SECPAR(3) .GT. C(29) ) THEN SECPAR(1) = M3 SECPAR(2) = GAMMA3 IF ( DEBUG ) WRITE(MDEBUG,445) (SECPAR(I),I=1,9) CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( M3 .EQ. 13 .OR. M3 .EQ. 14 ) THEN DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + (GAMMA3-1.D0)*PAMA(M3) ELSEIF ( M3 .EQ. 15 .OR. M3 .EQ. 25 ) THEN DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + (GAMMA3+1.D0)*PAMA(M3) ELSE DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + GAMMA3 * PAMA(M3) ENDIF ENDIF ENDIF RETURN END *CMZ : 13/06/2001 15.08.42 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE DECAY6(AM0,AM3,AM4,AM5,PARAMA,PARAMB,PARAMC,AMPMX,MODE) C----------------------------------------------------------------------- C DECAY (INTO 3 PARTICLES) C C TREATES DECAY INTO 3 PARTICLES; FULLY CONSERVING ENERGY AND MOMENTA C KINEMATIC RANGE PARAMETRISATION SEE PHYS. LETT. 204B (1988) 90-91 C FOR LEPTONIC KAON DACAY: THE POLARIZATION OF THE MUON AND C THE NEUTRINO PRODUCTION IS INCLUDED. C THIS SUBROUTINE IS CALLED FROM ETADEC, KDECAY, PI0DEC, AND RESDEC. C ARGUMENTS: C AM0 = MASS OF DECAYING PARTICLE C AM3, AM4, AM5 = MASSES OF RESULTING PARTICLES C PARAMA = DALITZ AMPLITUDE PARAMETER (SEE BELOW) C PARAMB = DALITZ AMPLITUDE PARAMETER (SEE BELOW) C PARAMC = DALITZ AMPLITUDE PARAMETER (SEE BELOW) C AMPMX = MAXIMUM AMPLITUDE OF DALITZ PLOT C MODE = 1 FOR DECAY KAON ----> 3 PIONS C = 2 FOR DECAY ETA ----> 3 PIONS OR 2 PIONS + GAMMA C FOR DECAY PI(0) ----> ELECTRON + POSITRON + GAMMA C = 3 FOR DECAY KAON ----> PION + MUON + NEUTRINO C = 4 FOR DECAY KAON ----> PION + ELECTRON + NEUTRINO C C AMPLITUDE PARAMETERS PARAMA, PARAMB, PARAMC ARE DEPENDENT ON MODE: C FOR MODE=1: PARAMA = G DALITZ AMPLITUDE PARAMETRISATION SEE C PARAMB = H PHYS. LETT. 204B (1988) 181 - 193 C PARAMC = K C C FOR MODE=2: PARAMA = A DALITZ AMPLITUDE PARAMETRISATION SEE C PARAMB = DUMMY PHYS. LETT. 204B (1988) 173 - 175; C PARAMC = DUMMY J.G. LAYTER ET.AL. PHYS.REV.D7(1973)2565 C C FOR MODE>2: PARAMA = LAMBDA-PLUS DALITZ AMPLITUDE PARAMETRISATION C PARAMB = LAMBDA-ZERO SEE PHYS. LETT. 204B (1988) C PARAMC = DUMMY 182 - 194 C C DESIGN : D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,DECAY. COMMON /DECAY/ GAM345,COS345,PHI345 DOUBLE PRECISION GAM345(3),COS345(3),PHI345(3) *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,POLAR. COMMON /POLAR/ POLART,POLARF DOUBLE PRECISION POLART,POLARF *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DOUBLE PRECISION ABYM,AMPLI,AMPMX,AM0,AM3,AM34I,AM34SQ,AM35SQ, * AM4,AM5,APARAL,APERPN,AUXA,AUXB,AUX1,AUX2,AUX2A, * AUX3,AUX4,AUX4A,AUX5,AUX6,AUX7,AUX8,AUX10,AUX12, * AUX14,BBYM,BOFQ,CM0SQ,CM3SQ,CM3SQI,CM4SQ,CM5SQ, * COSALF,COSBET,COSFI4,COSFI5,COSOME,COSPHI, * COSPSI,COS3CM,COS4CM,COS5CM, * DISCR,EPIPRM,E3CM,E3STAR,E4CM,E5CM,E5STAR,FACT, * GRLAMD,OMEGA,PA,PARAMA,PARAMB,PARAMC,PB,PC,PSI, * P3CM,P3SQ,P4CM,P4SQ,P5CM,P5SQ,ROOT1,ROOT2, * SINALF,SINBET,SINFI4,SINFI5,SINOMG,SINPHI,SINPSI, * SINT4,SINT4I,SINT5I,SIN3CM,S0,TBYMSS,XIT,XI0 INTEGER MODE SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,444) AM0,AM3,AM4,AM5 444 FORMAT(' DECAY6: AM0',1P,E10.3,' AM3',E10.3,' AM4',E10.3, * ' AM5',E10.3) C CALCULATE AUXILIARY QUANTITIES CM0SQ = AM0**2 CM3SQ = AM3**2 CM4SQ = AM4**2 CM5SQ = AM5**2 AUX1 = (AM3 + AM4)**2 AUX2A = (AM0 - AM5)**2 AUX2 = AUX2A - AUX1 AUX3 = (AM3 + AM5)**2 AUX4A = (AM0 - AM4)**2 AUX4 = AUX4A - AUX3 AUX5 = CM3SQ - CM4SQ AUX6 = CM0SQ - CM5SQ AUX7 = 0.5D0 / AM0 IF ( MODE .EQ. 1 ) THEN AUX8 = (AM0 - AM3)**2 S0 = OB3 * ( CM0SQ + CM3SQ + CM4SQ + CM5SQ ) AUX10 = 1.D0 / PAMA(8)**2 ELSEIF ( MODE .EQ. 2 ) THEN AUX14 = 1.D0 / (AM0 - AM3 - AM4 - AM5) ELSEIF ( MODE .EQ. 3 .OR. MODE .EQ. 4 ) THEN CM3SQI = 1.D0 / CM3SQ AUX12 = (CM0SQ + CM3SQ - CM4SQ) * AUX7 C XI0 IS XI(0); GRLAMD IS GREAT LAMBDA XI0 = ( CM0SQ - CM3SQ) * CM3SQI * (PARAMB - PARAMA) GRLAMD = (-XI0) * PARAMA ELSE WRITE(MONIOU,*) 'DECAY6: UNEXPECTED MODE =',MODE RETURN ENDIF 100 CALL RMMAR( RD,3,1 ) C ARE INVARIANT MASS SQUARES INSIDE BOUNDARY OF DALITZ PLOT? AM34SQ = AUX2 * RD(1) + AUX1 AM35SQ = AUX4 * RD(2) + AUX3 AM34I = 0.5D0 / SQRT(AM34SQ) E3STAR = (AUX5 + AM34SQ) * AM34I E5STAR = (AUX6 - AM34SQ) * AM34I ROOT1 = SQRT(E3STAR**2 - CM3SQ ) ROOT2 = SQRT(E5STAR**2 - CM5SQ ) DISCR = AM35SQ - (E3STAR + E5STAR)**2 C REJECT RANDOM NUMBERS, IF OUTSIDE KINEMATIC BOUNDARY OF DALITZ PLOT IF ( DISCR .GT. -((ROOT1 - ROOT2)**2) ) GOTO 100 IF ( DISCR .LT. -((ROOT1 + ROOT2)**2) ) GOTO 100 C E3CM, E4CM, E5CM ARE ENERGIES IN THE C. M. SYSTEM E4CM = (CM0SQ + CM4SQ - AM35SQ) * AUX7 E5CM = (CM0SQ + CM5SQ - AM34SQ) * AUX7 E3CM = AM0 - E4CM - E5CM IF ( MODE .EQ. 1 ) THEN FACT = AUX10 * (AUX2A - 2.D0*AM0*(E5CM-AM5) - S0) C AMPLITUDE OF SQUARED MATRIX ELEMENT (SEE PHYS. LETT. B204 (1988) 181) AMPLI = 1.D0 + PARAMA*FACT + PARAMB*FACT**2 + PARAMC*( AUX10 * * ( AUX4A -AUX8 -2.D0*(E4CM-AM4-E3CM+AM3)*AM0 ) )**2 ELSEIF ( MODE .EQ. 2 ) THEN C AMPLITUDE OF SQUARED MATRIX ELEMENT (SEE PHYS. LETT. B204 (1988) 173) C REF: J. G. LAYTER ET AL., PHYS. REV. D7 (1973) 2565 AMPLI = 1.D0 + PARAMA * ( 3.D0 * (E5CM - AM5) * AUX14 - 1.D0 ) ELSE C EPIPRM IS (ENERGY OF PION)PRIMED EPIPRM = AUX12 - E3CM C PA, PB, AND PC ARE THE A, B, AND C PARAMETERS PA = AM0 * ( 2.D0 * E4CM * E5CM - AM0 * EPIPRM ) * + CM4SQ * ( 0.25D0 * EPIPRM - E5CM ) PB = CM4SQ * ( E5CM - 0.5D0 * EPIPRM ) PC = CM4SQ * EPIPRM * 0.25D0 C TBYMSS IS T DIVIDED BY MASS SQUARE OF PION TBYMSS = (CM0SQ + CM3SQ - 2.D0 * AM0 * E3CM) * CM3SQI C XIT IS XI(T) XIT = XI0 + GRLAMD*TBYMSS C AMPLITUDE OF SQUARED MATRIX ELEMENT (PHYS. LETT. B204 (1988) 183) AMPLI = (1.D0 + PARAMA*TBYMSS)**2 * ( PA + XIT*PB + XIT**2 *PC ) ENDIF C REJECT RANDOM NUMBERS, IF RD(3) IS LARGER THAN DALITZ PLOT AMPLITUDE IF ( RD(3)*AMPMX .GT. AMPLI ) GOTO 100 IF (DEBUG) WRITE(MDEBUG,*) 'DECAY6: E3CM,E4CM,E5CM=', * SNGL(E3CM),SNGL(E4CM),SNGL(E5CM) C P3CM, P4CM, P5CM ARE MOMENTA IN THE C.M. SYSTEM C P3SQ, P4SQ, P5SQ ARE SQUARED MOMENTA IN C.M. SYSTEM P5SQ = E5CM**2 - CM5SQ P5CM = SQRT(P5SQ) P4SQ = E4CM**2 - CM4SQ P4CM = SQRT(P4SQ) P3SQ = E3CM**2 - CM3SQ P3CM = SQRT(P3SQ) C ANGLE ALFA AND BETA ARE BETWEEN PARTICLE 3 AND 4 RSP. 3 AND 5 COSALF = (P5SQ - P3SQ - P4SQ) / (2.D0 * P3CM * P4CM) SINALF = -SQRT( MAX(0.D0, 1.D0 - COSALF**2) ) COSBET = (P4SQ - P3SQ - P5SQ) / (2.D0 * P3CM * P5CM) SINBET = SQRT( MAX(0.D0, 1.D0 - COSBET**2) ) C NOW SELECT RANDOM NUMBERS FOR THREE INDEPENDENT ANGLES IN CM-SYSTEM C COS3CM AND PHI ARE ANGLES OF PARTICLE 3 RELATIVE TO DECAYING PARTICLE CALL RMMAR( RD,3,1 ) COS3CM = 2.D0*RD(1) - 1.D0 SIN3CM = SQRT( MAX(0.D0, 1.D0 - COS3CM**2) ) PHI345(1) = PI2 * RD(2) COSPHI = COS( PHI345(1) ) SINPHI = SIN( PHI345(1) ) C ANGLE PSI GIVES ROTATION OF PLANE (3,4,5) RELATIVE TO PLANE (1,3) PSI = PI2 * RD(3) COSPSI = COS(PSI) SINPSI = SIN(PSI) C CALCULATE ALL NEEDED POLAR AND AZIMUTHAL ANGLES IN THE CM-SYSTEM COS4CM = COS3CM * COSALF - SIN3CM * COSPSI * SINALF IF ( ABS(COS4CM) .LT. 1.D0 ) THEN SINT4 = SQRT(1.D0 - COS4CM**2) SINT4I = 1.D0 / SINT4 AUXA = COS3CM * COSPSI * SINALF + SIN3CM * COSALF COSFI4 = (COSPHI*AUXA-SINPHI*SINPSI*SINALF) * SINT4I PHI345(2) = ACOS( MAX( -1.D0, MIN( 1.D0, COSFI4 ) ) ) SINFI4 = (SINPHI*AUXA+COSPHI*SINPSI*SINALF) * SINT4I IF ( SINFI4 .LE. 0.D0 ) PHI345(2) = PI2 - PHI345(2) ELSE PHI345(2) = 0.D0 ENDIF C CALCULATE GAMMA FACTORS AND POLAR ANGLES IN LABORATORY SYSTEM GAM345(1) = GAMMA * (E3CM + BETA * P3CM * COS3CM) / AM3 COS345(1) = MIN( 1.D0, (BETA * E3CM + P3CM * COS3CM) * GAMMA * / ( AM3 * SQRT(GAM345(1)**2 - 1.D0) ) ) GAM345(2) = GAMMA * (E4CM + BETA * P4CM * COS4CM) / AM4 COS345(2) = MIN( 1.D0, (BETA * E4CM + P4CM * COS4CM) * GAMMA * / ( AM4 * SQRT(GAM345(2)**2 - 1.D0) ) ) C CALCULATE PARAMETERS OF PARTICLE 5, IF NEEDED IF ( MODE .LE. 2 ) THEN COS5CM = COS3CM * COSBET - SIN3CM * COSPSI * SINBET IF ( ABS(COS5CM) .LT. 1.D0 ) THEN SINT5I = 1.D0 / SQRT(1.D0 - COS5CM**2) AUXB = COS3CM * COSPSI * SINBET + SIN3CM * COSBET COSFI5 = (COSPHI*AUXB-SINPHI*SINPSI*SINBET) * SINT5I PHI345(3) = ACOS( MAX( -1.D0, MIN( 1.D0, COSFI5 ) ) ) SINFI5 = (SINPHI*AUXB+COSPHI*SINPSI*SINBET) * SINT5I IF ( SINFI5 .LE. 0.D0 ) PHI345(3) = PI2 - PHI345(3) ELSE PHI345(3) = 0.D0 ENDIF IF ( AM5 .NE. 0.D0 ) THEN GAM345(3) = GAMMA * (E5CM + BETA * P5CM * COS5CM) / AM5 COS345(3) = MIN( 1.D0, (BETA * E5CM + P5CM * COS5CM) * GAMMA * / ( AM5 * SQRT(GAM345(3)**2 - 1.D0) ) ) ELSE C IF PARTICLE 5 IS GAMMA RAY OR NEUTRINO, THEN GAM345(3) IS THE ENERGY GAM345(3) = GAMMA * (E5CM + BETA * P5CM * COS5CM) COS345(3) = MIN( 1.D0, (BETA * E5CM + P5CM * COS5CM) * GAMMA * / GAM345(3) ) ENDIF ENDIF IF ( MODE .EQ. 3 ) THEN C CALCULATION OF MUON POLARIZATION. WE FOLLOW THE DESCRIPTION OF C L. JAUNEAU, IN: METHODS IN SUBNUCLEAR PHYSICS, VOL. 3, M. NIKOLIC ED. C (GORDON + BREACH, NEW YORK, 1969), P. 123 C SEE ALSO: L.M. CHOUNET ET AL., PHYS. REP. 4 (1972) 199, APPENDIX 1. C SEE ALSO: N. CABBIBO, A. MAKSYMOWICZ, PHYS. LETT. 9 (1964) 352 C (CORRECTIONS IN: PHYS. LETT. 11 (1964) 360; 14 (1965) 72) C WE DEFINE BOFQ (READ: B OF Q), WHICH IS -B(Q**2)*4 BOFQ = 1.D0 - XIT C ABYM AND BBYM (READ A BY M; B BY M) ARE THE QUANTITIES A/M AND B/M ABYM = AM0 * ( BOFQ * EPIPRM - 2.D0 * E5CM ) BBYM = CM0SQ + 0.25D0 * CM4SQ * BOFQ**2 - BOFQ * AM0 * E4CM C NOW CALCULATE THE COMPONENTS APARAL (PARALLEL TO MU DIRECTION) AND C APERPN (PERPENDICULAR TO MU DIRECTION) USING QUANTITIES DEFINED IN C KAON REST SYSTEM. NOTE OUR DEFINITION OF SINALF (ALWAYS WITH NEGATIVE C SIGN) OPPOSITE TO CABBIBO'S SIN(PSI) AND JAUNEAU'S SIN(THETA) APARAL = (-P3CM)*AM4*BBYM*COSALF - P4CM * ( AM0*ABYM - BBYM * * ( P3CM*SINALF*(E4CM-AM4)/P4CM + AM0 - E3CM ) ) APERPN = P3CM*AM4*BBYM*SINALF C NOW NORMALIZE THE PARALLEL COMPONENT OF POLARIZATION; POLART IS C COSINE OF THE ANGLE BETWEEN MUON MOMENTUM AND POLARISATION POLART = APARAL / SQRT(APARAL**2 + APERPN**2) C THE POLARIZATION VECTOR LIES IN THE PLANE OF MOMENTA (PION,MUON). C OMEGA IS THE ANGLE BY WHICH THE DECAY PLANE (PION,MUON) IS ROTATET C AROUND THE DIRECTION OF MUON RELATIVE TO THE PLANE (KAON,MUON) IF ( ABS(COS4CM) .LT. 1.D0 .AND. SINALF .NE. 0.D0 ) THEN COSOME = (COS4CM*COSALF - COS3CM)*SINT4I/SINALF OMEGA = ACOS( MAX( -1.D0, MIN( 1.D0, COSOME ) ) ) IF ( SINFI4 .NE. 0.D0 ) THEN SINOMG = ( COSFI4 * ( COSALF - COS3CM*COS4CM ) * SINT4I * - SIN3CM * COSPHI ) / (SINALF*SINFI4) IF ( SINOMG .LT. 0.D0 ) OMEGA = PI2 - OMEGA ENDIF ELSE OMEGA = 0.D0 ENDIF POLARF = OMEGA ENDIF RETURN END *CMZ : 28/02/2002 10.53.59 by D. HECK IK FZK KARLSRUHE *-- Author : K. BERNLOEHR MPIK HEIDELBERG 15/06/98 C======================================================================= SUBROUTINE DTCCHR (LINE,IS,CVAL,KEYWRD,IKEY,LENVAL) C----------------------------------------------------------------------- C D(A)T(A) C(ARD) CH(A)R(ACTER) C C READ CHARACTER PARAMETER FROM DATA CARD CHARACTER STRING C ERRORS ARE INDICATED BY WRITING A '!' IN LINE(1:1) C THIS SUBROUTINE IS CALLED FROM DATAC. C ARGUMETNS: C LINE = CHARACTER STRING OF INPUT LINE C IS = POINTER FOR START OF INTERPRETATION OF 'LINE' C CVAL = CHARACTER STRING TO BE RETURNED C KEYWORD= KEYWORD AT BEGIN OF LINE C IKEY = NUMBER OF ARGUMENT AFTER KEYWORD C LENVAL = LENGTH OF CHARACTER STRING TO BE RETURNED C C AUTHOR: K. BERNLOEHR MPIK HEIDELBERG 1998 C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. INTEGER I,IE,IKEY,IQUOTE,IS,L,LENVAL CHARACTER CVAL*(*),KEYWRD*(*),LINE*(*) SAVE C----------------------------------------------------------------------- IF ( IS.LE.0 ) IS = LEN(KEYWRD) L = LEN(LINE) DO 10 I = IS+1,L IF ( LINE(I:I) .NE. ' ' ) GOTO 11 10 CONTINUE 11 IF ( I.GT.L .OR. LINE(I:I).EQ.'!' .OR. LINE(I:I).EQ.' ') THEN IF ( IKEY .LE. 1 ) THEN WRITE(MONIOU,6000) KEYWRD 6000 FORMAT(1X,'DATACARD ',A,' HAS NO PARAMETER(S)') ELSE WRITE(MONIOU,6001) KEYWRD,IKEY 6001 FORMAT(1X,'DATACARD ',A,' PARAMETER',I2,' IS MISSING') ENDIF CVAL = ' ' LINE(1:1) = '!' LENVAL = 0 RETURN ENDIF IF ( LINE(I:I) .EQ. '''' ) THEN IQUOTE = 1 IS = I+1 ELSEIF ( LINE(I:I) .EQ. '"' ) THEN IQUOTE = 2 IS = I+1 ELSE IQUOTE = 0 IS = I ENDIF DO 20 I = IS,L IF ( IQUOTE .EQ. 1 ) THEN IF ( LINE(I:I) .EQ. '''' ) GOTO 21 ELSEIF ( IQUOTE .EQ. 2 ) THEN IF ( LINE(I:I) .EQ. '"' ) GOTO 21 ELSE IF ( LINE(I:I) .EQ. ' ' .OR. LINE(I:I) .EQ. '!' ) GOTO 21 ENDIF 20 CONTINUE 21 IE = I IF ( IQUOTE .EQ. 1 ) THEN IF ( LINE(I:I) .EQ. '''' ) THEN IE = I-1 LINE(I:I) = ' ' ENDIF ELSEIF ( IQUOTE .EQ. 2 ) THEN IF ( LINE(I:I) .EQ. '"' ) THEN IE = I-1 LINE(I:I) = ' ' ENDIF ELSEIF ( LINE(I:I) .EQ. ' ' .OR. LINE(I:I) .EQ. '!' ) THEN IE = I-1 ENDIF * WRITE(*,6666) KEYWRD,IKEY,IS,IE,LINE(IS:IE) *6666 FORMAT(1X,'DTCCHR : ',A,' #',I3,I4,I4,': ',A) CVAL = LINE(IS:IE) LENVAL = IE-IS+1 IF ( LEN(CVAL) .LT. IE-IS+1 ) THEN WRITE(MONIOU,6002) * KEYWRD,IKEY,IE-IS+1,LEN(CVAL),CVAL 6002 FORMAT(1X,'DATACARD ',A,' PARAMETER',I2,' IS TOO LONG AND HAS', * ' BEEN TRUNCATED FROM',I4,' TO',I4,':'/5X,'''',A,'''') LINE(1:1) = '!' LENVAL = LEN(CVAL) ENDIF IS = IE IF ( DEBUG ) WRITE(MDEBUG,6667) CVAL 6667 FORMAT(1X,'DTCCHR : VALUE = ''',A,'''') RETURN END *CMZ : 27/02/2002 16.27.13 by D. HECK IK FZK KARLSRUHE *-- Author : K. BERNLOEHR MPIK HEIDELBERG 15/06/98 C======================================================================= SUBROUTINE DTCDBL (LINE,IS,DVAL,KEYWRD,IKEY) C----------------------------------------------------------------------- C D(A)T(A) C(ARD) D(OU)BL(E PRECISION) C C READ DOUBLE PRECISION PARAMETER FROM DATA CARD CHARACTER STRING C ERRORS ARE INDICATED BY WRITING A '!' IN LINE(1:1) C THIS SUBROUTINE IS CALLED FROM DATAC. C ARGUMETNS: C LINE = CHARACTER STRING OF INPUT LINE C IS = POINTER FOR START OF INTERPRETATION OF 'LINE' C DVAL = DOUBLE PRECISION VARIABLE TO BE RETURNED C KEYWORD= KEYWORD AT BEGIN OF LINE C IKEY = NUMBER OF ARGUMENT AFTER KEYWORD C C AUTHOR: K. BERNLOEHR MPIK HEIDELBERG 1998 C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DOUBLE PRECISION DVAL INTEGER I,IE,IKEY,IS,L CHARACTER CFMTR*8,KEYWRD*(*),LINE*(*) SAVE C----------------------------------------------------------------------- IF ( IS.LE.0 ) IS = LEN(KEYWRD) L = LEN(LINE) DO 10 I = IS+1,L IF ( LINE(I:I) .NE. ' ' ) GOTO 11 10 CONTINUE 11 IF ( I.GT.L .OR. LINE(I:I).EQ.'!' .OR. LINE(I:I).EQ.' ') THEN IF ( IKEY .LE. 1 ) THEN WRITE(MONIOU,6000) KEYWRD 6000 FORMAT(1X,'DATACARD ',A,' HAS NO PARAMETER(S)') ELSE WRITE(MONIOU,6001) KEYWRD,IKEY 6001 FORMAT(1X,'DATACARD ',A,' PARAMETER',I2,' IS MISSING') ENDIF DVAL = 0.D0 LINE(1:1) = '!' RETURN ENDIF IS = I DO 20 I = IS+1,L IF ( LINE(I:I) .EQ. ' ' .OR. LINE(I:I) .EQ. '!' ) GOTO 21 20 CONTINUE 21 IF ( LINE(I:I) .EQ. ' ' .OR. LINE(I:I) .EQ. '!' ) THEN IE = I-1 ELSE IE = I ENDIF * WRITE(*,*) 'DTCDBL : ',KEYWRD,' #',IKEY,IS,IE,': ',LINE(IS:IE) IF ( IE-IS+1 .LT. 10 ) THEN CFMTR = '(F .0)' WRITE(CFMTR(3:3),'(I1)') IE-IS+1 ELSE CFMTR = '(F .0)' WRITE(CFMTR(3:4),'(I2)') IE-IS+1 ENDIF READ(LINE(IS:IE),CFMTR,ERR=999) DVAL IS = IE IF ( DEBUG ) WRITE(MDEBUG,*) 'DTCDBL : VALUE = ',DVAL RETURN 999 WRITE(MONIOU,6002) KEYWRD,IKEY,LINE(IS:IE) 6002 FORMAT(1X,'DATACARD ',A,' PARAMETER',I2, * ' IS INVALID: ',A) LINE(1:1) = '!' DVAL = 0.D0 IS = IE IF ( DEBUG ) WRITE(MDEBUG,*) 'DTCDBL : VALUE = ',DVAL RETURN END *CMZ : 27/02/2002 16.27.13 by D. HECK IK FZK KARLSRUHE *-- Author : K. BERNLOEHR MPIK HEIDELBERG 15/06/98 C======================================================================= SUBROUTINE DTCINT (LINE,IS,IVAL,KEYWRD,IKEY) C----------------------------------------------------------------------- C D(A)T(A) C(ARD) INT(EGER) C C READ INTEGER PARAMETER FROM DATA CARD CHARACTER STRING C ERRORS ARE INDICATED BY WRITING A '!' IN LINE(1:1) C THIS SUBROUTINE IS CALLED FROM DATAC. C ARGUMETNS: C LINE = CHARACTER STRING OF INPUT LINE C IS = POINTER FOR START OF INTERPRETATION OF 'LINE' C IVAL = INTEGER VARIABLE TO BE RETURNED C KEYWORD= KEYWORD AT BEGIN OF LINE C IKEY = NUMBER OF ARGUMENT AFTER KEYWORD C C AUTHOR: K. BERNLOEHR MPIK HEIDELBERG 1998 C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. INTEGER I,IE,IKEY,IS,IVAL,L CHARACTER CFMTI*8,KEYWRD*(*),LINE*(*) SAVE C----------------------------------------------------------------------- IF ( IS .LE. 0 ) IS = LEN(KEYWRD) L = LEN(LINE) DO 10 I = IS+1,L IF ( LINE(I:I) .NE. ' ' ) GOTO 11 10 CONTINUE 11 IF ( I.GT.L .OR. LINE(I:I).EQ.'!' .OR. LINE(I:I).EQ.' ' ) THEN IF ( IKEY.LE.1 ) THEN WRITE(MONIOU,6000) KEYWRD 6000 FORMAT(1X,'DATACARD ',A,' HAS NO PARAMETER(S)') ELSE WRITE(MONIOU,6001) KEYWRD,IKEY 6001 FORMAT(1X,'DATACARD ',A,' PARAMETER',I2,' IS MISSING') ENDIF IVAL = 0 LINE(1:1) = '!' RETURN ENDIF IS = I DO 20 I = IS+1,L IF ( LINE(I:I) .EQ. ' ' .OR. LINE(I:I) .EQ. '!' ) GOTO 21 20 CONTINUE 21 IF ( LINE(I:I) .EQ. ' ' .OR. LINE(I:I) .EQ. '!' ) THEN IE = I-1 ELSE IE = I ENDIF * WRITE(*,*) 'DTCINT : ',KEYWRD,' #',IKEY,IS,IE,': ',LINE(IS:IE) DO 30 I = IS,IE IF ( (ICHAR(LINE(I:I)) .LT. ICHAR('0') .OR. * ICHAR(LINE(I:I)) .GT. ICHAR('9')) .AND. * (LINE(I:I) .NE. '-' .OR. I .NE. IS) ) THEN WRITE(MONIOU,6002) KEYWRD,IKEY,LINE(IS:IE) 6002 FORMAT(1X,'DATACARD ',A,' PARAMETER',I2, * ' IS NOT INTEGER: ',A) IS = IE IVAL = 0 LINE(1:1) = '!' RETURN ENDIF 30 CONTINUE IF ( IE-IS+1 .LT. 10 ) THEN CFMTI = '(I )' WRITE(CFMTI(3:3),'(I1)') IE-IS+1 ELSE CFMTI = '(I )' WRITE(CFMTI(3:4),'(I2)') IE-IS+1 ENDIF READ(LINE(IS:IE),CFMTI) IVAL IS = IE IF ( DEBUG ) WRITE(MDEBUG,*) 'DTCINT : VALUE = ',IVAL RETURN END *CMZ : 27/02/2002 16.27.13 by D. HECK IK FZK KARLSRUHE *-- Author : K. BERNLOEHR MPIK HEIDELBERG 15/06/98 C======================================================================= SUBROUTINE DTCLOG (LINE,IS,LVAL,KEYWRD,IKEY) C----------------------------------------------------------------------- C D(A)T(A) C(ARD) LOG(ICAL) C C READ LOGICAL PARAMETER FROM DATA CARD CHARACTER STRING. C MAKE USE OF UPPERCASE CONVERSION OF DATA CARDS. C FOR 'T' YOU CAN ALSO USE 'TRUE', '.TRUE.', 'Y', 'YES', 'ON', '1'. C FOR 'F' YOU CAN ALSO USE 'FALSE', '.FALSE.', 'N', 'NO', 'OFF', '0'. C ERRORS ARE INDICATED BY WRITING A '!' IN LINE(1:1) C THIS SUBROUTINE IS CALLED FROM DATAC. C ARGUMETNS: C LINE = CHARACTER STRING OF INPUT LINE C IS = POINTER FOR START OF INTERPRETATION OF 'LINE' C LVAL = LOGICAL TO BE RETURNED C KEYWORD= KEYWORD AT BEGIN OF LINE C IKEY = NUMBER OF ARGUMENT AFTER KEYWORD C C AUTHOR: K. BERNLOEHR MPIK HEIDELBERG 1998 C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. INTEGER I,IE,IKEY,IS,L LOGICAL LVAL CHARACTER KEYWRD*(*),LINE*(*) SAVE C----------------------------------------------------------------------- IF ( IS .LE. 0 ) IS = LEN(KEYWRD) L = LEN(LINE) DO 10 I = IS+1,L IF ( LINE(I:I) .NE. ' ' ) GOTO 11 10 CONTINUE 11 IF ( I.GT.L .OR. LINE(I:I).EQ.'!' .OR. LINE(I:I).EQ.' ' ) THEN IF ( IKEY .LE. 1 ) THEN WRITE(MONIOU,6000) KEYWRD 6000 FORMAT(1X,'DATACARD ',A,' HAS NO PARAMETER(S)') ELSE WRITE(MONIOU,6001) KEYWRD,IKEY 6001 FORMAT(1X,'DATACARD ',A,' PARAMETER',I2,' IS MISSING') ENDIF IS = IE LVAL = .FALSE. LINE(1:1) = '!' RETURN ENDIF IS = I DO 20 I = IS+1,L IF ( LINE(I:I) .EQ. ' ' .OR. LINE(I:I) .EQ. '!' ) GOTO 21 20 CONTINUE 21 IF ( LINE(I:I) .EQ. ' ' .OR. LINE(I:I) .EQ. '!' ) THEN IE = I-1 ELSE IE = I ENDIF * WRITE(*,*) 'DTCLOG : ',KEYWRD,' #',IKEY,IS,IE,': ',LINE(IS:IE) IF ( LINE(IS:IE) .EQ. 'T' .OR. LINE(IS:IE) .EQ. 'TRUE' * .OR. LINE(IS:IE) .EQ. '.TRUE.' * .OR. LINE(IS:IE) .EQ. 'Y' .OR. LINE(IS:IE) .EQ. 'YES' * .OR. LINE(IS:IE) .EQ. 'ON' .OR. LINE(IS:IE) .EQ. '1' ) THEN LVAL = .TRUE. ELSEIF ( LINE(IS:IE) .EQ. 'F' .OR. LINE(IS:IE) .EQ. 'FALSE' * .OR. LINE(IS:IE) .EQ. '.FALSE.' * .OR. LINE(IS:IE) .EQ. 'N' .OR. LINE(IS:IE) .EQ. 'NO' * .OR. LINE(IS:IE) .EQ. 'OFF' .OR. LINE(IS:IE) .EQ. '0' ) THEN LVAL = .FALSE. ELSE WRITE(MONIOU,6002) KEYWRD,IKEY,LINE(IS:IE) 6002 FORMAT(1X,'DATACARD ',A,' PARAMETER',I2, * ' IS INVALID: ',A) LVAL = .FALSE. LINE(1:1) = '!' ENDIF IS = IE IF ( DEBUG ) WRITE(MDEBUG,*) 'DTCLOG : VALUE = ',LVAL RETURN END *CMZ : 27/02/2002 16.27.13 by D. HECK IK FZK KARLSRUHE *-- Author : K. BERNLOEHR MPIK HEIDELBERG 15/06/98 C======================================================================= SUBROUTINE DTCRL (LINE,IS,RVAL,KEYWRD,IKEY) C----------------------------------------------------------------------- C D(A)T(A) C(ARD) R(EA)L C C READ REAL PARAMETER FROM DATA CARD CHARACTER STRING C ERRORS ARE INDICATED BY WRITING A '!' IN LINE(1:1) C THIS SUBROUTINE IS CALLED FROM DATAC. C ARGUMETNS: C LINE = CHARACTER STRING OF INPUT LINE C IS = POINTER FOR START OF INTERPRETATION OF 'LINE' C RVAL = REAL VARIABLE TO BE RETURNED C KEYWORD= KEYWORD AT BEGIN OF LINE C IKEY = NUMBER OF ARGUMENT AFTER KEYWORD C C AUTHOR: K. BERNLOEHR MPIK HEIDELBERG 1998 C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. REAL RVAL INTEGER I,IE,IKEY,IS,L CHARACTER CFMTR*8,LINE*(*),KEYWRD*(*) SAVE C----------------------------------------------------------------------- IF ( IS .LE. 0 ) IS = LEN(KEYWRD) L = LEN(LINE) DO 10 I = IS+1,L IF ( LINE(I:I).NE.' ' ) GOTO 11 10 CONTINUE 11 IF ( I.GT.L .OR. LINE(I:I).EQ.'!' .OR. LINE(I:I).EQ.' ' ) THEN IF ( IKEY.LE.1 ) THEN WRITE(MONIOU,6000) KEYWRD 6000 FORMAT(1X,'DATACARD ',A,' HAS NO PARAMETER(S)') ELSE WRITE(MONIOU,6001) KEYWRD,IKEY 6001 FORMAT(1X,'DATACARD ',A,' PARAMETER',I2,' IS MISSING') ENDIF RVAL = 0. LINE(1:1) = '!' RETURN ENDIF IS = I DO 20 I = IS+1,L IF ( LINE(I:I) .EQ. ' ' .OR. LINE(I:I) .EQ. '!' ) GOTO 21 20 CONTINUE 21 IF ( LINE(I:I) .EQ. ' ' .OR. LINE(I:I) .EQ. '!' ) THEN IE = I-1 ELSE IE = I ENDIF * WRITE(*,*) 'DTCRL : ',KEYWRD,' #',IKEY,IS,IE,': ',LINE(IS:IE) IF ( IE-IS+1 .LT. 10 ) THEN CFMTR = '(F .0)' WRITE(CFMTR(3:3),'(I1)') IE-IS+1 ELSE CFMTR = '(F .0)' WRITE(CFMTR(3:4),'(I2)') IE-IS+1 ENDIF READ(LINE(IS:IE),CFMTR,ERR=999) RVAL IF ( DEBUG ) WRITE(MDEBUG,*) 'DTCRL : VALUE = ',RVAL IS = IE RETURN 999 WRITE(MONIOU,6002) KEYWRD,IKEY,LINE(IS:IE) 6002 FORMAT(1X,'DATACARD ',A,' PARAMETER',I2, * ' IS INVALID: ',A) RVAL = 0. LINE(1:1) = '!' IS = IE IF ( DEBUG ) WRITE(MDEBUG,*) 'DTCRL : VALUE = ',RVAL RETURN END *CMZ : 24/10/2000 15.40.59 by D. HECK IK3 FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE EM C----------------------------------------------------------------------- C E(LECTRO) M(AGNETIC PARTICLES) C C ROUTINE FOR TREATING EM PARTICLES C THIS SUBROUTINE IS CALLED FROM BOX3. C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,GENER. COMMON /GENER/ GEN,ALEVEL DOUBLE PRECISION GEN,ALEVEL *KEEP,LONGI. COMMON /LONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG, * SDLONG,SELONG,SPLONG,THSTEP,THSTPI, * LHEIGH,NSTEP,LLONGI,FLGFIT DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9), * APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9), * HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9), * SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI INTEGER LHEIGH,NSTEP LOGICAL LLONGI,FLGFIT *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DOUBLE PRECISION ENER,THICK INTEGER I SAVE EXTERNAL THICK C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=1,9) 444 FORMAT(' EM : CURPAR=',1P,8E10.3,0P,F6.0) C GET CORRECT PARTICLE ENERGY IF ( ITYPE .EQ. 1 ) THEN ENER = CURPAR(2) ELSEIF ( ITYPE .EQ. 2 .OR. ITYPE .EQ. 3 ) THEN ENER = CURPAR(2) * PAMA(2) ELSE WRITE(MONIOU,*) 'EM : WRONG PARTICLE CODE =',ITYPE RETURN ENDIF C COPY PARTICLE COORDINATES INTO SECPAR DO 101 I = 1,8 SECPAR(I) = CURPAR(I) 101 CONTINUE SECPAR( 9) = GEN SECPAR(10) = ALEVEL SECPAR(14) = CURPAR(14) SECPAR(15) = CURPAR(15) SECPAR(16) = CURPAR(16) C CALL NKG IF SELECTED IF ( FNKG ) THEN CALL NKG( ENER ) ENDIF C CALL EGS4 IF SELECTED ( PARTICLE IS TAKEN IN EGS FROM COMMON ) IF ( FEGS ) THEN CALL EGS4( ENER ) ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT LHEIGH = INT(THICK(H)*THSTPI + 1.D0) IF ( SECPAR(1) .EQ. 1.D0 ) THEN DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + ENER ELSEIF ( SECPAR(2) .EQ. 2.D0 ) THEN DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + (ENER+PAMA(2)) ELSE DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + (ENER-PAMA(2)) ENDIF ENDIF ENDIF RETURN END *CMZ : 14/06/2000 15.06.16 by D. HECK IK3 FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE ETADEC C----------------------------------------------------------------------- C ETA DEC(AY) C C ROUTINE TREATES DECAY OF ETA C DECAY WITH FULL KINEMATIC, ENERGY AND MOMENTA CONSERVED C THIS SUBROUTINE IS CALLED FROM NUCINT. C C DESIGN : D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,DECAY. COMMON /DECAY/ GAM345,COS345,PHI345 DOUBLE PRECISION GAM345(3),COS345(3),PHI345(3) *KEEP,EDECAY. COMMON /EDECAY/ CETA DOUBLE PRECISION CETA(5) *KEEP,GENER. COMMON /GENER/ GEN,ALEVEL DOUBLE PRECISION GEN,ALEVEL *KEEP,LONGI. COMMON /LONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG, * SDLONG,SELONG,SPLONG,THSTEP,THSTPI, * LHEIGH,NSTEP,LLONGI,FLGFIT DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9), * APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9), * HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9), * SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI INTEGER LHEIGH,NSTEP LOGICAL LLONGI,FLGFIT *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DOUBLE PRECISION AUX1,AUX2,COSTH1,COSTH2,EETA2,FI1 INTEGER I SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=1,9) 444 FORMAT(' ETADEC: CURPAR=',1P,9E10.3) C SELECT MODE OF DECAY, IF NOT ALREADY SELECTED BY THE PARTICLE TYPE IF ( ITYPE .EQ. 17 ) THEN CALL RMMAR( RD,1,1 ) IF ( RD(1) .LE. CETA(1) ) THEN ITYPE = 71 ELSEIF ( RD(1) .LE. CETA(2) ) THEN ITYPE = 72 ELSEIF ( RD(1) .LE. CETA(3) ) THEN ITYPE = 73 ELSE ITYPE = 74 ENDIF ENDIF C DECAY OF ETA WITH 4 MODES C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C DECAY ETA ----> GAMMA + GAMMA IF ( ITYPE .EQ. 71 ) THEN EETA2 = 0.5D0 * GAMMA * PAMA(17) CALL RMMAR( RD,2,1 ) AUX1 = 1.D0 + BETA * RD(1) AUX2 = 1.D0 - BETA * RD(1) COSTH1 = (BETA + RD(1)) / AUX1 COSTH2 = (BETA - RD(1)) / AUX2 SECPAR(1) = 1.D0 C FIRST GAMMA (WITH HIGHER ENERGY) FI1 = PI2 * RD(2) SECPAR(2) = AUX1 * EETA2 CALL ADDANG( COSTHE,PHI, COSTH1,FI1, SECPAR(3),SECPAR(4) ) IF ( SECPAR(3) .GT. C(29) ) THEN CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + SECPAR(2) ENDIF ENDIF C SECOND GAMMA (WITH LOWER ENERGY) SECPAR(2) = AUX2 * EETA2 CALL ADDANG( COSTHE,PHI, COSTH2,FI1+PI, SECPAR(3),SECPAR(4) ) IF ( SECPAR(3) .GT. C(29) ) THEN CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + SECPAR(2) ENDIF ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C DECAY ETA ----> PI(0) + PI(0) + PI(0) ELSEIF ( ITYPE .EQ. 72 ) THEN CALL DECAY6( PAMA(17), PAMA(7),PAMA(7),PAMA(7), * 0.D0,0.D0,0.D0, 1.D0, 2 ) SECPAR(1) = 7.D0 DO 340 I = 1,3 CALL ADDANG( COSTHE,PHI, COS345(I),PHI345(I), * SECPAR(3),SECPAR(4) ) IF ( SECPAR(3) .GT. C(29) ) THEN SECPAR(2) = GAM345(I) CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + GAM345(I) * PAMA(7) ENDIF ENDIF 340 CONTINUE C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C DECAY ETA ----> PI(-) + PI(+) + PI(0) ELSEIF ( ITYPE .EQ. 73 ) THEN CALL DECAY6( PAMA(17), PAMA(8),PAMA(8),PAMA(7), * CETA(4),0.D0,0.D0, CETA(5), 2 ) DO 360 I = 1,3 CALL ADDANG( COSTHE,PHI, COS345(I),PHI345(I), * SECPAR(3),SECPAR(4) ) IF ( SECPAR(3) .GT. C(29) ) THEN SECPAR(1) = 10 - I SECPAR(2) = GAM345(I) CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + GAM345(I)*PAMA(10-I) ENDIF ENDIF 360 CONTINUE C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C DECAY ETA ----> PI(+) + PI(-) + GAMMA ELSEIF ( ITYPE .EQ. 74 ) THEN CALL DECAY6( PAMA(17), PAMA(8),PAMA(8),0.D0, * 0.D0,0.D0,0.D0, 1.D0, 2 ) DO 380 I = 1,3 CALL ADDANG( COSTHE,PHI, COS345(I),PHI345(I), * SECPAR(3),SECPAR(4) ) IF ( SECPAR(3) .GT. C(29) ) THEN IF ( I .EQ. 3 ) THEN SECPAR(1) = 1.D0 ELSE SECPAR(1) = 7 + I ENDIF SECPAR(2) = GAM345(I) CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( I .EQ. 3 ) THEN DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + GAM345(I) ELSE DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + GAM345(I)*PAMA(8) ENDIF ENDIF ENDIF 380 CONTINUE ELSE WRITE(MONIOU,*) 'ETADEC: UNEXPECTED PARTICLE CODE ITYPE=',ITYPE ENDIF RETURN END *CMZ : 27/02/2002 16.27.13 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE FSTACK C----------------------------------------------------------------------- C F(ROM) STACK C C GETS PARTICLE FROM STACK AND READS FROM DISK IF NECESSARY C THIS SUBROUTINE IS CALLED FORM AAMAIN C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,BUFFS. COMMON /BUFFS/ RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH INTEGER MAXBUF,MAXLEN PARAMETER (MAXLEN=16) PARAMETER (MAXBUF=39*7) REAL RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF), * RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF) INTEGER LH CHARACTER*4 CRUNH,CRUNE,CEVTH,CEVTE,CLONG EQUIVALENCE (RUNH(1),CRUNH), (RUNE(1),CRUNE) EQUIVALENCE (EVTH(1),CEVTH), (EVTE(1),CEVTE) EQUIVALENCE (ARRAYLONG(1),CLONG) *KEEP,ETHMAP. COMMON /ETHMAP/ ECTMAP,ELEFT DOUBLE PRECISION ECTMAP,ELEFT *KEEP,GENER. COMMON /GENER/ GEN,ALEVEL DOUBLE PRECISION GEN,ALEVEL *KEEP,IRET. COMMON /IRET/ IRET1,IRET2,IRETE INTEGER IRET1,IRET2 LOGICAL IRETE *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,POLAR. COMMON /POLAR/ POLART,POLARF DOUBLE PRECISION POLART,POLARF *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,STACKF. COMMON /STACKF/ STACK,MSTACKP,MEXST,NSHIFT,NOUREC,ICOUNT, * NTO,NFROM INTEGER MAXSTK PARAMETER (MAXSTK = 16*256*2) DOUBLE PRECISION STACK(MAXSTK) INTEGER MSTACKP,MEXST,NSHIFT,NOUREC,ICOUNT,NTO,NFROM *KEND. INTEGER I,ISTK,J SAVE DATA ISTK / MAXSTK / C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,220) ICOUNT-1 220 FORMAT(' FSTACK:',I7) C STACK EMPTY, SOMETHING TO BE READ FROM DISK ? IF ( MSTACKP .EQ. 0 ) THEN IF ( NOUREC .EQ. 0 ) THEN IF ( FPRINT .OR. DEBUG ) WRITE(MONIOU,224) NTO,NFROM 224 FORMAT(/' NO MORE SECONDARIES FOUND ON STACK'/ * ' ',I10,' PARTICLES WRITTEN TO STACK'/ * ' ',I10,' PARTICLES READ FROM STACK' ) CURPAR(1) = 0.D0 IRET1 = 1 RETURN ENDIF C READ LAST BLOCK OF 256 PARTICLES FROM SCRATCH FILE READ(MEXST,REC=NOUREC) (STACK(I),I=1,ISTK/2) NOUREC = NOUREC - 1 MSTACKP = ISTK/2 ENDIF NFROM = NFROM + 1 ICOUNT = ICOUNT - 1 C PUT PARTICLE FROM STACK INTO CURPAR MSTACKP = MSTACKP - MAXLEN DO 5 J = 1,8 CURPAR(J) = STACK(MSTACKP+J) 5 CONTINUE GEN = STACK(MSTACKP+ 9) ALEVEL = STACK(MSTACKP+10) POLART = STACK(MSTACKP+11) POLARF = STACK(MSTACKP+12) CURPAR(14) = STACK(MSTACKP+14) CURPAR(15) = STACK(MSTACKP+15) CURPAR(16) = STACK(MSTACKP+16) IF ( PAMA(NINT(CURPAR(1))) .NE. 0.D0 ) THEN ELEFT = ELEFT - CURPAR(2)*PAMA(NINT(CURPAR(1))) ELSE ELEFT = ELEFT - CURPAR(2) ENDIF IF ( DEBUG ) WRITE(MDEBUG,667) ICOUNT,(CURPAR(J),J=1,8) 667 FORMAT('+ ',I7,1X,1P,8E10.3) RETURN END *CMZ : 11/07/2000 10.08.30 by D. HECK IK3 FZK KARLSRUHE *-- Author : D. HECK IK3 FZK KARLSRUHE 25/09/96 C======================================================================= REAL FUNCTION GBRSGM(Z,E) C----------------------------------------------------------------------- C CALCULATES MUON BREMSSTRAHLUNG CROSS-SECTIONS C C THIS SUBROUTINE IS TAKEN FROM GEANT321 PACKAGE (WITH MODIFICATIONS) C CALCULATES CROSS-SECTION IN CURRENT MATERIAL FOR DISCRETE(HARD) MUON C BREMSSTRAHLUNG. (SIG IN BARN/ATOM) C FOR A DESCRIPTION SEE: CERN PROGRAM LIBRARY LONG WRITEUP W5013 (1993) C THIS FUNCTION IS CALLED FROM BOX2. C ARGUMENTS: C Z (R4) = ATOMIC NUMBER OF PENETRATET MATERIAL C E (R4) = TOTAL ENERGY OF MUON C C AUTHOR : L.URBAN C MODIFIED: D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,MUPART. COMMON /MUPART/ AMUPAR,BCUT,CMUON,FMUBRM,FMUORG DOUBLE PRECISION AMUPAR(16),BCUT,CMUON(11) LOGICAL FMUBRM,FMUORG *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. REAL C(52),AKSI,ALFA,E,ECMAX,FAC,GAM, * S,SS,X,XX,YY,Z INTEGER I,J,K SAVE DATA AKSI/2.30/, ALFA/1.06/, GAM/0.63/ DATA C/ 0.949313E-07,-0.819600E-07, 0.529075E-07,-0.832023E-08 + , 0.539299E-09,-0.127042E-10,-0.165784E-08,-0.307788E-07 + , 0.977905E-08,-0.113658E-08, 0.574481E-10,-0.106221E-11 + , 0.968339E-09,-0.108640E-08,-0.177634E-09, 0.889497E-10 + ,-0.876878E-11, 0.264303E-12, 0.216263E-08,-0.152680E-08 + , 0.380989E-09,-0.455274E-10, 0.264172E-11,-0.596016E-13 + , 0.444927E-09,-0.272978E-09, 0.645634E-10,-0.748783E-11 + , 0.424890E-12,-0.940837E-14, 0.162289E-10,-0.362486E-11 + ,-0.576652E-12, 0.211269E-12,-0.185482E-13, 0.522065E-15 + ,-0.215590E-09, 0.112204E-09,-0.819133E-11, 0.145128E-12 + ,-0.206029E-09, 0.559940E-10,-0.483350E-11, 0.134252E-12 + ,-0.368469E-10, 0.999457E-11,-0.904967E-12, 0.272717E-13 + ,-0.303446E-11, 0.853429E-12,-0.785466E-13, 0.236435E-14/ C----------------------------------------------------------------------- GBRSGM = 0. IF ( E-PAMA(5) .LE. BCUT ) RETURN ECMAX = E - CMUON(10) * Z**0.333333 IF ( ECMAX .LE. BCUT ) RETURN X = LOG(E/PAMA(5)) S = 0. YY = 1. DO 30 I = 1,6 XX = 1. DO 20 J = 1,6 K = 6*I + J - 6 S = S + C(K) * XX * YY XX = XX * X 20 CONTINUE YY = YY * CMUON(11) 30 CONTINUE SS = 0. YY = 1. DO 50 I = 1,4 XX = 1. DO 40 J = 1,4 K = 4*I + J + 32 SS = SS + C(K) * XX * YY XX = XX * X 40 CONTINUE YY = YY * CMUON(11) 50 CONTINUE S = S + Z * SS IF ( S .LE. 0. ) RETURN FAC = LOG(ECMAX/BCUT) IF ( FAC .LE. 0. ) RETURN FAC = Z * ( Z + AKSI * (1.+GAM*LOG(Z)) ) * FAC**ALFA GBRSGM = FAC * S IF ( DEBUG ) WRITE(MDEBUG,444) Z,E,GBRSGM 444 FORMAT(' GBRSGM: Z=',F3.0,' E=',1P,E10.4,' GBRSGM=',E10.4) 99 RETURN END *CMZ : 11/07/2000 10.08.30 by D. HECK IK3 FZK KARLSRUHE *-- Author : D. HECK IK3 FZK KARLSRUHE 02/10/96 C======================================================================= REAL FUNCTION GPRSGM(Z,E) C----------------------------------------------------------------------- C G(EANT) P(AI)R S(I)GM(A) C CALCULATES MUON PAIR PRODUCTION CROSS-SECTIONS C C THIS SUBROUTINE IS TAKEN FROM GEANT321 PACKAGE (WITH MODIFICATIONS) C CALCULATES CROSS-SECTION IN CURRENT MATERIAL FOR DISCRETE(HARD) MUON C PAIR PRODUCTION. (SIG IN BARN/ATOM) C FOR A DESCRIPTION SEE: CERN PROGRAM LIBRARY LONG WRITEUP W5013 (1993) C THIS SUBROUTINE IS CALLED FROM BOX2. C ARGUMENTS: C Z (R4) = ATOMIC NUMBER OF PENETRATET MATERIAL C E (R4) = TOTAL ENERGY OF MUON C C AUTHOR : L.URBAN C MODIFIED: D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,MUPART. COMMON /MUPART/ AMUPAR,BCUT,CMUON,FMUBRM,FMUORG DOUBLE PRECISION AMUPAR(16),BCUT,CMUON(11) LOGICAL FMUBRM,FMUORG *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. REAL C(100),C1(60),C2(40),AKSI,ALFA,E,ECMAX,ECMIN,FAC,GAM, * S,SS,VS,X,XX,Y,YY,Z,CUT INTEGER I,J,K EQUIVALENCE (C(1),C1(1)),(C(61),C2(1)) SAVE DATA AKSI/1.16/,ALFA/3.46/,GAM/0.06/,VS/0.019/ DATA ECMIN/2.044E-3/ DATA C1/0.230181E-08,-0.280842E-08, 0.137525E-08,-0.156503E-09 + , 0.728088E-11,-0.122631E-12, 0.133014E-08,-0.160591E-09 + ,-0.390814E-09, 0.314492E-10, 0.251296E-12,-0.574223E-13 + , 0.604923E-09,-0.560766E-09, 0.660253E-09,-0.103474E-09 + , 0.621338E-11,-0.135273E-12, 0.103739E-09, 0.710290E-09 + ,-0.544755E-10,-0.211241E-11, 0.286443E-12,-0.644602E-14 + , 0.332492E-09,-0.484785E-10, 0.126921E-10,-0.165217E-11 + , 0.845273E-13,-0.143180E-14,-0.112267E-13, 0.113308E-11 + , 0.292577E-12,-0.733441E-13, 0.475747E-14,-0.976279E-16 + ,-0.112856E-07, 0.936398E-08,-0.291882E-08, 0.422266E-09 + ,-0.279042E-10, 0.678485E-12, 0.112383E-07,-0.964400E-08 + , 0.313121E-08,-0.440224E-09, 0.278668E-10,-0.643012E-12 + ,-0.414131E-08, 0.355112E-08,-0.115035E-08, 0.158539E-09 + ,-0.976788E-11, 0.216911E-12, 0.521380E-09,-0.442265E-09 + , 0.141753E-09,-0.190826E-10, 0.114038E-11,-0.242085E-13/ DATA C2/0.572943E-10,-0.296824E-10, 0.630217E-11,-0.623179E-12 + , 0.211467E-13,-0.143579E-10,-0.137247E-11, 0.118670E-11 + ,-0.793091E-13, 0.124745E-14,-0.269884E-10, 0.125314E-10 + ,-0.239259E-11, 0.181151E-12,-0.470277E-14,-0.342454E-11 + , 0.976666E-12,-0.236792E-12, 0.213290E-13,-0.607799E-15 + ,-0.748844E-12, 0.178214E-12,-0.226827E-13, 0.148441E-14 + ,-0.367972E-16, 0.840330E-12, 0.820025E-11,-0.294797E-11 + , 0.294669E-12,-0.970294E-14,-0.830636E-12,-0.309273E-11 + , 0.124169E-11,-0.135879E-12, 0.481683E-14, 0.438223E-12 + , 0.259162E-12,-0.149284E-12, 0.180170E-13,-0.677948E-15/ C----------------------------------------------------------------------- GPRSGM=0. CUT = BCUT IF ( ECMIN .GT. BCUT ) CUT=ECMIN ECMAX = E - CMUON(10) * Z**OB3 IF ( ECMAX .LE. CUT ) RETURN X = LOG(E/PAMA(5)) Y = LOG( CUT/(VS*E) ) S = 0. YY = 1. DO 30 I = 1,2 XX = 1. DO 20 J = 1,6 K = 6*I + J - 6 S = S + C(K) * XX * YY XX = XX * X 20 CONTINUE YY = YY * Y 30 CONTINUE DO 50 I = 3,6 XX = 1. DO 40 J = 1,6 K = 6*I + J - 6 IF ( Y .LE. 0. ) THEN S = S + C(K) * XX * YY ELSE S = S + C(K+24) * XX * YY ENDIF XX = XX * X 40 CONTINUE YY = YY * Y 50 CONTINUE SS = 0. YY = 1. DO 70 I = 1,2 XX = 1. DO 60 J = 1,5 K = 5*I + J + 55 SS = SS + C(K) * XX * YY XX = XX * X 60 CONTINUE YY = YY * Y 70 CONTINUE DO 90 I = 3,5 XX = 1. DO 80 J = 1,5 K = 5*I + J + 55 IF ( Y .LE. 0. ) THEN SS = SS + C(K) * XX * YY ELSE SS = SS + C(K+15) * XX * YY ENDIF XX = XX * X 80 CONTINUE YY = YY * Y 90 CONTINUE S = S + Z * SS IF ( S .LE. 0. ) RETURN C DE/DX SHOULD BE MONOTON INCREASING AS A C FUNCTION OF THE CUT C SOLUTION: LIN. INTERPOLATION FOR 0.2*ECMAX DEBUG INFORMATION WRITTEN TO UNIT ',I3//) C----------------------------------------------------------------------- C CHECK CORRECTNESS OF RUN NUMBER IF ( NRRUN .GT. 999999 ) THEN WRITE(MONIOU,*)'RUN NUMBER = ',NRRUN,' EXCEEDS 999999, STOP' STOP ENDIF c--------changed----command up to line labeld 5791 cxx------------ cxx call tobuf(runh,0) and tobufc(runh,0) are now in main program c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> c Next block of code is obsolete. c Now it's used "jcio" routines (C) C------------------------------------- cxxC OUTPUT FILES SHOULD NORMALLY NOT EXIST BEFORE THE RUN STARTS RQSTAT = 'NEW' cC OPEN OUTPUT DATA SET FOR RUN c IBL = INDEX(DSN,' ') c DSN(IBL:73) = 'DAT000000' c WRITE(DSN(IBL+3:IBL+8),'(I6)') NRRUN c DO 274 L = IBL+3,IBL+8 c IF ( DSN(L:L) .EQ. ' ' ) DSN(L:L) = '0' c 274 CONTINUE c IF ( FTABOUT ) THEN c DSNTAB=DSN c DSNTAB(IBL+9:IBL+12) = '.tab' c ENDIF c IF ( FLONGOUT .AND. LLONGI ) THEN c IF ( DSN(1:9) .EQ. '/dev/null' ) THEN c DSNLONG(1:9) = DSN(10:18) c DSNLONG(10:14) = '.long ' c ELSE c DSNLONG = DSN c DSNLONG(IBL+9:IBL+13) = '.long' c ENDIF c ENDIF c IF ( DSN(1:9) .EQ. '/dev/null' ) THEN c DSN = '/dev/null' c RQSTAT = 'UNKNOWN' c ELSE cC ON LINUX WITH G77 AN EXISTING FILE CAUSES A CORE DUMP -> FIRST INQUIRE c INQUIRE(FILE=DSN,EXIST=FEXIST) c IF ( FEXIST ) THEN c IBL = INDEX(DSN,' ') c IF ( IBL .LE. 1 ) IBL = LEN(DSN)+1 c WRITE(MONIOU,5791) DSN(1:IBL-1) 5791 FORMAT(/' FILE ',A,' ALREADY EXISTS. RENAME OR REMOVE IT', * ' OR CHANGE ''DIRECT'' DATA CARD AND TRY AGAIN.') c STOP 'FATAL PROBLEM' c ENDIF c ENDIF cC OPEN DATASET FOR PARTICLE OUTPUT c IF ( FPAROUT ) THEN c OPEN(UNIT=MPATAP,FILE=DSN,STATUS=RQSTAT, c * FORM='UNFORMATTED',ACCESS='SEQUENTIAL') c WRITE(MONIOU,579) DSN c 579 FORMAT(/' PARTICLE OUTPUT TO FILE : ',A79) c ENDIF cC OPEN DATASET FOR TABLE OUTPUT c IF ( FTABOUT ) THEN c OPEN(UNIT=MTABOUT,FILE=DSNTAB,STATUS=RQSTAT, c * FORM='UNFORMATTED',ACCESS='SEQUENTIAL') c WRITE(MONIOU,578) DSNTAB, c * IEBIN,EBMIN,EBMAX, c * ITBIN,TBMIN,TBMAX, c * IDBIN,DBMIN,DBMAX c 578 FORMAT(/' TABLE OUTPUT TO FILE : ',A79/ c * ' ENERGY : ',I2,' BINS, RANGE :',1P,2E10.2,' GEV'/ c * ' TIME : ',I2,' BINS, RANGE :',1P,2E10.2,' NS'/ c * ' RADIUS : ',I2,' BINS, RANGE :',1P,2E10.2,' CM') c WRITE(MTABOUT) IEBIN,EBMIN,EBMAX c WRITE(MTABOUT) ITBIN,TBMIN,TBMAX c WRITE(MTABOUT) IDBIN,DBMIN,DBMAX c EBOFF = LOG10(EBMIN) c EBFAC = 1./(LOG10(EBMAX/EBMIN)/IEBIN) c TBOFF = LOG10(TBMIN) c TBFAC = 1./(LOG10(TBMAX/TBMIN)/ITBIN) c DBOFF = LOG10(DBMIN) c DBFAC = 1./(LOG10(DBMAX/DBMIN)/IDBIN) c ENDIF c IF ( FLONGOUT .AND. LLONGI ) THEN c OPEN(UNIT=MLONGOUT,FILE=DSNLONG,STATUS=RQSTAT, c * FORM='FORMATTED',ACCESS='SEQUENTIAL') c WRITE(MONIOU,5781) DSNLONG c 5781 FORMAT(' LONGITUDINAL OUTPUT TO FILE: ',A79) c ENDIF c cC WRITE RUNHEADER TO OUTPUT BUFFER c CALL TOBUF( RUNH,0 ) c cC OPEN OUTPUT DATA SET FOR CHERENKOV PHOTONS c IF ( LCERFI ) THEN c DSN(IBL:73) = 'CER000000' c WRITE(DSN(IBL+3:IBL+8),'(I6)') NRRUN c DO 249 L = IBL+3,IBL+8 c IF ( DSN(L:L) .EQ. ' ' ) DSN(L:L) = '0' c 249 CONTINUE c IF ( DSN(1:9) .EQ. '/dev/null' ) THEN c DSN = '/dev/null' c RQSTAT = 'UNKNOWN' c ELSE cC ON LINUX WITH G77 AN EXISTING FILE CAUSES A CORE DUMP -> FIRST INQUIRE c INQUIRE(FILE=DSN,EXIST=FEXIST) c IF ( FEXIST ) THEN c IBL = INDEX(DSN,' ') c IF ( IBL .LE. 1 ) IBL = LEN(DSN)+1 c WRITE(MONIOU,5791) DSN(1:IBL-1) c STOP 'FATAL PROBLEM' c ENDIF c ENDIF c OPEN(UNIT=MCETAP,FILE=DSN,STATUS=RQSTAT, c * FORM='UNFORMATTED',ACCESS='SEQUENTIAL') c WRITE(MONIOU,580) DSN c 580 FORMAT(' CHERENKOV OUTPUT TO FILE : ',A79) c CALL TOBUFC( RUNH,0 ) c ELSE c WRITE(MONIOU,580) DSN c ENDIF cC RESET DSN c DSN(IBL:73) = ' ' c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> c------changed - command above c---------change to alpha - remove c*** and command some lines C OPEN THE EXTERNAL STACK C BLOCKS OF 32448 BYTES = 4056 REAL*8 = 312 PARTICLES FOR THINNING C BLOCKS OF 32640 BYTES = 4080 REAL*8 = 340 PARTICLES FOR STANDARD C FOR MOST FORTRAN COMPILERS ON UNIX-LIKE SYSTEMS (GNU g77, HP, C IBM RS6000) IT IS NECESSARY TO USE THE NUMBER OF BYTES FOR THE RECL C PARAMETER. C FOR DEC UNIX (COMPAQ Tru64) MACHINES WITH f77 COMPILER (UNLESS USING C THE '-assume bytrecl' COMPILER OPTION) AND SOME OTHER MACHINES THE C RECL PARAMETER IS THE NUMBER OF (4-BYTE) WORDS. c*** CALL RCLCHK(MEXST,4,L) CALL RCLCHK(MEXST,1,L) IF ( L .NE. 0 ) THEN WRITE(MONIOU,*) 'FATAL ERROR:',L, * ' RECL HANDLING NOT AS EXPECTED' STOP ENDIF OPEN(UNIT=MEXST,STATUS='SCRATCH', * FORM='UNFORMATTED',ACCESS='DIRECT',RECL=4*MAXSTK) c------changed to alpha c*** * FORM='UNFORMATTED',ACCESS='DIRECT',RECL=MAXSTK) c------changed to alpha C----------------------------------------------------------------------- C----------------------------------------------------------------------- C WRITE DATA SET FOR INFORMATION BANK IF ( FDBASE ) THEN C OPEN OUTPUT DATA SET FOR RUN IBL = INDEX(DSN,' ') C IF NORMAL OUTPUT DISABLED BUT 'DATBAS T', TRY CURRENT DIRECTORY. IF ( DSN(1:9) .EQ. '/dev/null' ) IBL = 1 DSN(IBL:79) = 'DAT000000.dbase' WRITE(DSN(IBL+3:IBL+8),'(I6)') NRRUN DO 275 L = IBL+3,IBL+8 IF ( DSN(L:L) .EQ. ' ' ) DSN(L:L) = '0' 275 CONTINUE IF ( DSN(1:9) .EQ. '/dev/null' ) THEN DSN = '/dev/null' RQSTAT = 'UNKNOWN' ELSE C ON LINUX WITH G77 AN EXISTING FILE CAUSES A CORE DUMP -> FIRST INQUIRE INQUIRE(FILE=DSN,EXIST=FEXIST) IF ( FEXIST ) THEN IBL = INDEX(DSN,' ') IF ( IBL .LE. 1 ) IBL = LEN(DSN)+1 WRITE(MONIOU,5791) DSN(1:IBL-1) STOP 'FATAL PROBLEM' ENDIF ENDIF OPEN(UNIT=MDBASE,FILE=DSN,STATUS=RQSTAT) WRITE(MONIOU,581) DSN 581 FORMAT(/' DBASE OUTPUT TO FILE : ',A79) C RESET DSN DSN(IBL+9:IBL+14) = ' ' LSTDSN(1:3) = 'LST' LSTDSN(4:9) = DSN(IBL+3:IBL+8) C RESET DSN TO '/dev/null' AS IT WAS BEFORE. IF ( IBL .EQ. 1 ) DSN = '/dev/null' VERVEN = FLOAT(IVERVN)/1000.D0 IF ( LLONGI ) THEN ILONG = 1 ELSE ILONG = 0 ENDIF ISO = 0 C SET DPMFLAG (0=HDPM, 1=VENUS, 2=SIBYLL, 3=QGSJET, 4=DPMJET, 5=NEXUS) IF ( EVTH(76) .EQ. 1. ) THEN IDPM = 1 ELSEIF ( EVTH(76) .EQ. 2. ) THEN IDPM = 2 ELSEIF ( EVTH(76) .EQ. 3. ) THEN IDPM = 3 ELSEIF ( EVTH(76) .EQ. 4. ) THEN IDPM = 4 ELSEIF ( EVTH(76) .EQ. 5. ) THEN IDPM = 5 ELSE IDPM = 0 ENDIF C INCREMENT DPMFLAG FOR VARIOUS CROSS-SECTIONS C BY (0=HDPM-SIG, 10=VENUSSIG, 20=SIBYLLSIG, 30=QGSSIG, 40=DPMJETSIG, C 50=NEXUSSIG) IF ( EVTH(145) .EQ. 1. ) THEN IDPM = IDPM + 10 ELSEIF ( EVTH(145) .EQ. 2. ) THEN IDPM = IDPM + 50 ELSEIF ( EVTH(140) .NE. 0. ) THEN IDPM = IDPM + 20 ELSEIF ( EVTH(142) .NE. 0. ) THEN IDPM = IDPM + 30 ELSEIF ( EVTH(144) .NE. 0. ) THEN IDPM = IDPM + 40 ENDIF MARK = '1' ILTHIN = 0 EFRAC = 0.D0 IF ( FREFRX ) THEN IFREFRX = 1 ELSE IFREFRX = 0 ENDIF WRITE(MDBASE,666) VERNUM,MARK,MVDATE,SNGL(VERVEN), $ INT(RUNH(3))+20000000, $ INT(EVTH(80)),INT(EVTH(79)),INT(EVTH(78)), $ MOD(INT(EVTH(77)),10),INT(RUNH(2)), $ INT(PRMPAR(1)),LLIMIT,ULIMIT, $ PSLOPE,INT(RUNH(20)),INT(RUNH(19)),INT(EVTH(76)), $ INT(EVTH(75)),ISO,IDPM, $ NFLAIN,NFLDIF,NFLPI0,NFLPIF,NFLCHE,NFRAGM, $ ILONG,THSTEP,BX, $ BZ,NOBSLV 666 FORMAT('#version#',F6.3,A1,'#versiondate#',I9, $ '#modelversion#',F8.3,'#rundate#',I9,/, $ '#computer#',I2,'#curved#',I2,'#neutrino#',I2, $ '#cerenkov#',I2,'#runnumber#',I7,/, $ '#primary#',I5,'#e_range_l#',1P,E14.7,'#e_range_u#',E14.7,/, $ '#slope#',E15.7,0P,'#nkg#',I2,'#egs#',I2,/, $ '#model#',I2,'#gheisha#',I2,'#isobar#',I2, $ '#model+crossect#',I3,/, $ '#hadflag1#',I2,'#hadflag2#',I2,'#hadflag3#',I2, $ '#hadflag4#',I2,'#hadflag5#',I2,'#hadflag6#',I2,/, $ '#longi#',I2,'#longistep#',1P,E14.7,'#magnetx#',E15.7,/, $ '#magnetz#',E15.7,0P,'#nobslev#',I3) WRITE(MDBASE,669) OBSLEV(1),OBSLEV(2),OBSLEV(3), $ OBSLEV(4),OBSLEV(5),OBSLEV(6), $ OBSLEV(7),OBSLEV(8),OBSLEV(9), $ OBSLEV(10),ELCUT(1),ELCUT(2), $ ELCUT(3), ELCUT(4),EVTH(81), $ EVTH(82),EVTH(83),EVTH(84), $ FIXHEI,N1STTR,THICK0, $ STEPFC,ARRANG,INT(EVTH(94)),NSEQ, $ ISEED(1,1),ISEED(2,1),ISEED(3,1), $ ISEED(1,2),ISEED(2,2),ISEED(3,2), $ ISEED(1,3),ISEED(2,3),ISEED(3,3), $ 0,DSN, $ LSTDSN,' ARC000.01',' ARC000.01', $ NSHOW,HOST,USER $ ,IATMOX,IFREFRX $ ,VUECON(1)*(180.D0/PI),VUECON(2)*(180.D0/PI) 669 FORMAT(1P,'#obslev1#',E15.7,'#obslev2#',E15.7, $ '#obslev3#',E15.7,/, $ '#obslev4#',E15.7,'#obslev5#',E15.7,'#obslev6#',E15.7,/, $ '#obslev7#',E15.7,'#obslev8#',E15.7,'#obslev9#',E15.7,/, $ '#obslev10#',E15.7,'#hcut#',E14.7,'#mcut#',E14.7,/, $ '#ecut#',E14.7,'#gcut#',E14.7,'#theta_l#',E14.7,/, $ '#theta_u#',E14.7,'#phi_l#',E15.7,'#phi_u#',E15.7,/, $ '#fixhei#',E14.7,'#n1sttr#',0P,I3,1P,'#fixchi#',E14.7,/, $ '#stepfc#',E14.7,'#arrang#',E15.7,0P,'#muaddi#',I2, $ '#nseq#',I2,/, $ '#seq1seed1#',I9,'#seq1seed2#',I9,'#seq1seed3#',I9,/, $ '#seq2seed1#',I9,'#seq2seed2#',I9,'#seq2seed3#',I9,/, $ '#seq3seed1#',I9,'#seq3seed2#',I9,'#seq3seed3#',I9,/, $ '#size#',I10,/,'#dsn_events#',A59,/, $ '#dsn_prtout# ',A9,'#tape_name#',A10,'#backup#',A10,/, $ '#howmanyshowers#',I10,'#host#',A20,'#user#',A20 $ ,/,'#atmosphere#',I3,'#refract#',I2 $ ,/,1P,'#viewcon_l#',E14.7,'#viewcon_u#',E14.7,0P $ ) WRITE(MDBASE,670) ILTHIN,EFRAC 670 FORMAT('#thinning#',I2,'#thinnlev_had#',1P,E14.7,0P) C RESET DSN DSN(IBL:IBL+14) = ' ' C THE MDBASE FILE IS CLOSED IN AAMAIN ENDIF WRITE(MONIOU,*) 'NUMBER OF SHOWERS TO GENERATE =',NSHOW WRITE(MONIOU,*) RETURN END *CMZ : 18/10/2000 09.15.11 by D. HECK IK3 FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE ISTACK C----------------------------------------------------------------------- C I(NITIALIZE) STACK C C PREPARES STACK AND EXTERNAL DISK FILE C THIS SUBROUTINE IS CALLED FROM AAMAIN. C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,ETHMAP. COMMON /ETHMAP/ ECTMAP,ELEFT DOUBLE PRECISION ECTMAP,ELEFT *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,STACKF. COMMON /STACKF/ STACK,MSTACKP,MEXST,NSHIFT,NOUREC,ICOUNT, * NTO,NFROM INTEGER MAXSTK PARAMETER (MAXSTK = 16*256*2) DOUBLE PRECISION STACK(MAXSTK) INTEGER MSTACKP,MEXST,NSHIFT,NOUREC,ICOUNT,NTO,NFROM *KEND. SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'ISTACK:' NTO = 0 NFROM = 0 NOUREC = 0 NSHIFT = 0 MSTACKP = 0 ELEFT = 0.D0 ICOUNT = 1 RETURN END *CMZ : 31/01/2001 10.50.55 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE KDECAY( IGO ) C----------------------------------------------------------------------- C K(AON) DECAY C C KAON DECAYS WITH FULL KINEMATIC, ENERGY AND MOMENTA CONSERVED C ALL SECONDARY PARTICLES ARE WRITTEN TO STACK C THIS SUBROUTINE IS CALLED FROM NUCINT. C ARGUMENT: (TO CHARACTERIZE THE DECAYING KAON) C IGO = 1 K+ C = 2 K- C = 3 K0S C = 4 K0L C C DESIGN : D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,DECAY. COMMON /DECAY/ GAM345,COS345,PHI345 DOUBLE PRECISION GAM345(3),COS345(3),PHI345(3) *KEEP,IRET. COMMON /IRET/ IRET1,IRET2,IRETE INTEGER IRET1,IRET2 LOGICAL IRETE *KEEP,KAONS. COMMON /KAONS/ CKA DOUBLE PRECISION CKA(80) *KEEP,LONGI. COMMON /LONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG, * SDLONG,SELONG,SPLONG,THSTEP,THSTPI, * LHEIGH,NSTEP,LLONGI,FLGFIT DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9), * APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9), * HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9), * SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI INTEGER LHEIGH,NSTEP LOGICAL LLONGI,FLGFIT *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,POLAR. COMMON /POLAR/ POLART,POLARF DOUBLE PRECISION POLART,POLARF *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DOUBLE PRECISION BETA3,COSTCM,COSTH3,GAMMA3,GAMMA4,PHI3,RA, * WORK1,WORK2 INTEGER I,ICHARG,IGO,M3 SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=1,9) 444 FORMAT(' KDECAY: CURPAR=',1P,9E10.3) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C DECAY OF K(+,-) (6 MODES) IF ( IGO .LE. 2 ) THEN 21 CALL RMMAR( RD,1,1 ) RA = RD(1) C DECAY K(+,-) ----> MU(+,-) + NEUTRINO IF ( RA .LE. CKA(23) ) THEN C NEUTRINO IS DROPPED WORK1 = CKA(28) * GAMMA WORK2 = CKA(29) * BETA * WORK1 CALL RMMAR( RD,2,1 ) COSTCM = RD(1) * 2.D0 - 1.D0 C MU(+,-) GAMMA3 = WORK1 + COSTCM * WORK2 BETA3 = SQRT( 1.D0 - 1.D0 / GAMMA3**2 ) COSTH3 = MIN( 1.D0, (GAMMA * GAMMA3 - CKA(28)) * / (BETA * GAMMA * BETA3 * GAMMA3) ) PHI3 = RD(2) * PI2 CALL ADDANG( COSTHE,PHI, COSTH3,PHI3, SECPAR(3),SECPAR(4) ) IF ( SECPAR(3) .GT. C(29) ) THEN SECPAR(1) = 4 + IGO SECPAR(2) = GAMMA3 C DIRECTION OF PION IN THE MUON CM SYSTEM (= DIRECTION OF POLARIZATION) C SEE: G. BARR ET AL., PHYS. REV. D39 (1989) 3532, EQ. 5 C POLART IS COS OF ANGLE BETWEEN KAON AND LABORATORY IN THE MU CM C POLARF IS ANGLE PHI AROUND THE LAB DIRECTION IN THE MU CM C POLART, POLARF WITH RESPECT TO THE MU DIRECTION IN THE LAB SYSTEM POLART = ( 2.D0*PAMA(11)*GAMMA*C(6) / (PAMA(5)*GAMMA3) * - C(6) - 1.D0 ) / ( BETA3 * (1.D0-C(6)) ) POLARF = PHI3 - PI C PION DIRECTION IS DIRECTION OF POLARIZATION FOR K+, OPPOSITE FOR K- IF ( ITYPE .EQ. 12 ) THEN POLART = -POLART POLARF = POLARF + PI ENDIF C GET THE POLARIZATION DIRECTION IN THE MU CM RELATIVE TO THE CORSIKA C COORDINATE SYSTEM CALL ADDANG( SECPAR(3),SECPAR(4), POLART,POLARF, * POLART,POLARF ) SECPAR(11) = POLART SECPAR(12) = POLARF CALL TSTACK SECPAR(11) = 0.D0 SECPAR(12) = 0.D0 ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT DLONG(LHEIGH,5) = DLONG(LHEIGH,5) + GAMMA3 * PAMA(5) ENDIF ENDIF IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT GAMMA4 = PAMA(11) * GAMMA - PAMA(5) * GAMMA3 DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + GAMMA4 ENDIF C DECAY K(+,-) ----> PI(+,-) + PI(0) ELSEIF ( RA .LE. CKA(47) ) THEN M3 = ITYPE - 3 CALL DECAY1( ITYPE, M3, 7 ) C DECAY K(+,-) ----> PI(+,-) + PI(+,-) + PI(-,+) ELSEIF ( RA. LE. CKA(48) ) THEN CALL DECAY6( PAMA(11), PAMA(8),PAMA(8),PAMA(8), * CKA(51),CKA(52),CKA(53), CKA(54), 1 ) C PI(+,-) AND PI(+,-) AND THIRD (ODD) PI(-,+) DO 230 I = 1,3 CALL ADDANG( COSTHE,PHI, COS345(I),PHI345(I), * SECPAR(3),SECPAR(4) ) IF ( SECPAR(3) .GT. C(29) ) THEN IF ( I .EQ. 3 ) THEN SECPAR(1) = 10 - IGO ELSE SECPAR(1) = 7 + IGO ENDIF SECPAR(2) = GAM345(I) CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + GAM345(I) * PAMA(8) ENDIF ENDIF 230 CONTINUE C DECAY K(+,-) ----> PI(0) + E(+,-) + NEUTRINO ELSEIF ( RA. LE. CKA(49) ) THEN CALL DECAY6( PAMA(11), PAMA(7),PAMA(2),0.D0, * CKA(65),CKA(66),0.D0, CKA(67), 4 ) C PI(0) AND E(+,-) / NEUTRINO IS DROPPED DO 250 I = 1,2 CALL ADDANG( COSTHE,PHI, COS345(I),PHI345(I), * SECPAR(3),SECPAR(4) ) IF ( SECPAR(3) .GT. C(29) ) THEN IF ( I .EQ. 1 ) THEN SECPAR(1) = 7.D0 ELSE SECPAR(1) = 1 + IGO ENDIF SECPAR(2) = GAM345(I) CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( I .EQ. 1 ) THEN DLONG(LHEIGH,7) = DLONG(LHEIGH,7)+GAM345(1)*PAMA(7) ELSE IF ( IGO .EQ. 1 ) THEN DLONG(LHEIGH,3) = DLONG(LHEIGH,3) * + (GAM345(2)+1.D0) * PAMA(2) ELSE DLONG(LHEIGH,3) = DLONG(LHEIGH,3) * + (GAM345(2)-1.D0) * PAMA(2) ENDIF ENDIF ENDIF ENDIF 250 CONTINUE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT GAM345(3)=GAMMA*PAMA(11)-GAM345(1)*PAMA(7)-GAM345(2)*PAMA(2) DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + GAM345(3) ENDIF C DECAY K(+,-) ----> PI(0) + MU(+,-) + NEUTRINO ELSEIF ( RA. LE. CKA(50) ) THEN CALL DECAY6( PAMA(11), PAMA(7),PAMA(5),0.D0, * CKA(68),CKA(69),0.D0, CKA(70), 3 ) C PI(0) AND MU(+,-) / NEUTRINO IS DROPPED DO 260 I = 1,2 CALL ADDANG( COSTHE,PHI, COS345(I),PHI345(I), * SECPAR(3),SECPAR(4) ) IF ( SECPAR(3) .GT. C(29) ) THEN SECPAR(2) = GAM345(I) IF ( I .EQ. 1 ) THEN SECPAR(1) = 7.D0 ELSE SECPAR(1) = 4 + IGO IF ( SECPAR(1) .EQ. 6.D0 ) THEN C INVERT POLARIZATION DIRECTION FOR MU(-) POLART = -POLART POLARF = POLARF + PI ENDIF C GET THE POLARIZATION DIRECTION IN THE MU CM RELATIVE TO THE CORSIKA C COORDINATE SYSTEM CALL ADDANG( SECPAR(3),SECPAR(4), POLART, POLARF, * POLART,POLARF ) SECPAR(11) = POLART SECPAR(12) = POLARF ENDIF CALL TSTACK SECPAR(11) = 0.D0 SECPAR(12) = 0.D0 ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( I .EQ. 1 ) THEN DLONG(LHEIGH,7) = DLONG(LHEIGH,7)+GAM345(2)*PAMA(7) ELSE DLONG(LHEIGH,5) = DLONG(LHEIGH,5)+GAM345(2)*PAMA(5) ENDIF ENDIF ENDIF 260 CONTINUE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT GAM345(3)=GAMMA*PAMA(11)-GAM345(1)*PAMA(7)-GAM345(2)*PAMA(5) DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + GAM345(3) ENDIF C DECAY K(+,-) ----> PI(0) + PI(0) + PI(+,-) ELSE CALL DECAY6( PAMA(11), PAMA(7),PAMA(7),PAMA(8), * CKA(55),CKA(56),CKA(57), CKA(58), 1 ) C PI(0)'S AND PI(+,-) DO 270 I = 1,3 IF ( I .EQ. 3 ) THEN SECPAR(1) = 7 + IGO ELSE SECPAR(1) = 7.D0 ENDIF CALL ADDANG( COSTHE,PHI, COS345(I),PHI345(I), * SECPAR(3),SECPAR(4) ) IF ( SECPAR(3) .GT. C(29) ) THEN SECPAR(2) = GAM345(I) CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT GAMMA4 = GAM345(I) * PAMA(NINT(SECPAR(1))) DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + GAMMA4 ENDIF ENDIF 270 CONTINUE ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C DECAY OF K0S (2 MODES) ELSEIF ( IGO .EQ. 3 ) THEN CALL RMMAR( RD,1,1 ) C DECAY K0S ----> PI(+) + PI(-) IF ( RD(1) .LE. CKA(24) ) THEN CALL DECAY1( ITYPE, 8, 9 ) C DECAY K0S ----> PI(0) + PI(0) ELSE CALL DECAY1( ITYPE, 7, 7 ) ENDIF C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C DECAY OF K0L (4 MODES) ELSEIF ( IGO .EQ. 4 ) THEN CALL RMMAR( RD,1,1 ) RA = RD(1) C DECAY K0L ----> PI(+,-) + E(-,+) + NEUTRINO IF ( RA .LE. CKA(27) ) THEN CALL DECAY6( PAMA(10), PAMA(8),PAMA(2),0.D0, * CKA(71),CKA(72),0.D0, CKA(73), 4 ) CALL RMMAR( RD,1,1 ) C CHARGE ASYMMETRY PREFERS FORMATION OF PI(-) ICHARG = INT(1.5016 + RD(1)) C PI(+,-) AND E(-,+) / NEUTRINO IS DROPPED DO 420 I = 1,2 SECPAR(1) = 10 - 3*I - (2*I-3)*ICHARG CALL ADDANG( COSTHE,PHI, COS345(I),PHI345(I), * SECPAR(3),SECPAR(4) ) IF ( SECPAR(3) .GT. C(29) ) THEN SECPAR(2) = GAM345(I) CALL TSTACK ELSE C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( LLONGI ) THEN IF ( I .EQ. 1 ) THEN DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + GAM345(1)*PAMA(8) ELSE IF ( SECPAR(1) .EQ. 2.D0 ) THEN DLONG(LHEIGH,3) = DLONG(LHEIGH,3) * + (GAM345(2)+1.D0) * PAMA(2) ELSE DLONG(LHEIGH,3) = DLONG(LHEIGH,3) * + (GAM345(2)-1.D0) * PAMA(2) ENDIF ENDIF ENDIF ENDIF 420 CONTINUE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT GAM345(3)=GAMMA*PAMA(10)-GAM345(1)*PAMA(8)-GAM345(2)*PAMA(2) DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + GAM345(3) ENDIF C DECAY K0L ----> PI(+,-) + MU(-,+) + NEUTRINO ELSEIF ( RA .LE. CKA(26) ) THEN CALL DECAY6( PAMA(10), PAMA(8),PAMA(5),0.D0, * CKA(74),CKA(75),0.D0, CKA(76), 3 ) CALL RMMAR( RD,1,1 ) C CHARGE ASYMMETRY PREFERS FORMATION OF PI(-) ICHARG = INT(1.5016 + RD(1)) C PI(+,-) AND MU(-,+) / NEUTRINO IS DROPPED DO 430 I = 1,2 CALL ADDANG( COSTHE,PHI, COS345(I),PHI345(I), * SECPAR(3),SECPAR(4) ) IF ( SECPAR(3) .GT. C(29) ) THEN SECPAR(2) = GAM345(I) IF ( I .EQ. 1 ) THEN SECPAR(1) = 7 + ICHARG ELSEIF ( I .EQ. 2 ) THEN SECPAR(1) = 7 - ICHARG IF ( SECPAR(1) .EQ. 6.D0 ) THEN C INVERT POLARIZATION DIRECTION FOR MU(-) POLART = -POLART POLARF = POLARF + PI ENDIF C GET THE POLARIZATION DIRECTION IN THE MU CM RELATIVE TO THE CORSIKA C COORDINATE SYSTEM CALL ADDANG( SECPAR(3),SECPAR(4), POLART,POLARF, * POLART,POLARF ) SECPAR(11) = POLART SECPAR(12) = POLARF ENDIF CALL TSTACK SECPAR(11) = 0.D0 SECPAR(12) = 0.D0 ELSE C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( LLONGI ) THEN IF ( I .EQ. 1 ) THEN DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + GAM345(1)*PAMA(8) ELSE DLONG(LHEIGH,5) = DLONG(LHEIGH,5) + GAM345(2)*PAMA(5) ENDIF ENDIF ENDIF 430 CONTINUE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT GAM345(3)=GAMMA*PAMA(10)-GAM345(1)*PAMA(8)-GAM345(2)*PAMA(5) DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + GAM345(3) ENDIF C DECAY K0L ----> PI(0) + PI(0) + PI(0) ELSEIF ( RA .LE. CKA(25) ) THEN C SEE: S.V. SOMALWAR ET AL., PHYS.REV.LET. 68(1992)2580 CALL DECAY6( PAMA(10), PAMA(7),PAMA(7),PAMA(7), * CKA(59),-.0033D0,CKA(59), CKA(60), 1 ) C PI(0)'S SECPAR(1) = 7.D0 DO 440 I = 1,3 CALL ADDANG( COSTHE,PHI, COS345(I),PHI345(I), * SECPAR(3),SECPAR(4) ) IF ( SECPAR(3) .GT. C(29) ) THEN SECPAR(2) = GAM345(I) CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + GAM345(I) * PAMA(7) ENDIF ENDIF 440 CONTINUE C DECAY K0L ----> PI(+) + PI(-) + PI(0) ELSE CALL DECAY6( PAMA(10), PAMA(8),PAMA(8),PAMA(7), * CKA(61),CKA(62),CKA(63), CKA(64), 1 ) C PI(+) AND PI(-) AND PI(0) DO 450 I = 1,3 CALL ADDANG( COSTHE,PHI, COS345(I),PHI345(I), * SECPAR(3),SECPAR(4) ) IF ( SECPAR(3) .GT. C(29) ) THEN IF ( I .EQ. 3 ) THEN SECPAR(1) = 7.D0 ELSE SECPAR(1) = 7 + I ENDIF SECPAR(2) = GAM345(I) CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( I .EQ. 3 ) THEN DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + GAM345(I)*PAMA(7) ELSE DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + GAM345(I)*PAMA(8) ENDIF ENDIF ENDIF 450 CONTINUE ENDIF ENDIF C KILL CURRENT PARTICLE IRET1 = 1 RETURN END *CMZ : 27/02/2002 16.27.13 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 16/05/95 C======================================================================= SUBROUTINE LONGFT(FPARAM,CHI2) C----------------------------------------------------------------------- C LONG(ITUDINAL) F(I)T C C THIS ROUTINE PERFORMS A FIT TO THE LONGITUDINAL DISTRIBUTION OF AN C AIR SHOWER. DUE TO THE LARGE PARTICLE NUMBERS IN AN AIR SHOWER THE C STATISTICAL ERRORS ON THE PARTICLE NUMBER AT A GIVEN LEVEL ARE C MINUTE. THIS LEADS TO RATHER LARGE CHI**2/DOF FOR THE FITS EVEN IF C THE FITTED FUNCTION MATCHES THE POINTS BETTER THAN SAY 1%. C KEEP IN MIND THAT FITTING IS A DIFFICULT TASK AND THE RESULTS DO NOT C NECESSARILY REPRESENT THE ABOLUTE MINIMUM OR EVEN A GOOD C APPROXIMATION. C C IN A FIRST STEP A 4 PARAMETER FIT IS TRIED BASED ON M. HILLAS' CURVE C WITH WIDTH PARAMETER LAMBDA : C N(T) = NMAX * ((T-T0)/(TMAX-T0))**((TMAX-T0)/P) * EXP((TMAX-T)/P) C WITH: C NMAX = PARTICLE NUMBER AT TMAX C T = DEPTH IN G/CM**2 C T0 = STARTING DEPTH OF SHOWER C TMAX = DEPTH OF SHOWER MAXIMUM C P = WIDTH PARAMETER LAMBDA C C IN A SECOND STEP WE REFINE THE FIT WITH THE START VALUES FROM THE 4 C PARAMETER FIT AND USE A 6 PARAMETER FIT BASED ON M. HILLAS' CURVE C REPLACING HIS WIDTH PARAMETER LAMBDA BY A POLYNOMIAL OF 3. DEGREE. C N(T) = NMAX * ((T-T0)/(TMAX-T0))**((TMAX-T0)/(P1+P2*T+P3*T**2)) C * EXP((TMAX-T)/(P1+P2*T+P3*T**2)) C WITH: C NMAX = PARTICLE NUMBER AT TMAX C T = DEPTH IN G/CM**2 C T0 = STARTING DEPTH OF SHOWER C TMAX = DEPTH OF SHOWER MAXIMUM C P1 .. P3 = PARAMETERS OF A POLYNOMIAL DESCRIBING THE WIDTH C C THIS SUBROUTINE IS CALLED FROM AAMAIN. C ARGUMENTS: C FPARAM = ARRAY WITH THE FINAL FITTED PARAMETERSTHE 6 PARAMETER C CHI2 = CHI SQUARED C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,CURVE. COMMON /CURVE/ CHAPAR,DEP,ERR,NSTP DOUBLE PRECISION CHAPAR(1200),DEP(1200),ERR(1200) INTEGER NSTP *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. INTEGER NPAR PARAMETER (NPAR=6) DOUBLE PRECISION F(NPAR),FPARAM(NPAR),CHI2,CHISQ,CHISQ1 DOUBLE PRECISION P(NPAR+1,NPAR),Y(NPAR+1),EPS DOUBLE PRECISION P1(NPAR-1,NPAR-2),FPARAM1(NPAR-2),CHI21 DOUBLE PRECISION HALFW,T0,TMAX,NMAX,FAC INTEGER I,II,ILOWER,IMAX,IUPPER,J,JJ,K,ITER,IFLAG SAVE EXTERNAL CHISQ,CHISQ1 C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'LONGFT:' C FIND GOOD START VALUES FOR XMAX AND FMAX NMAX = 0.D0 TMAX = 400.D0 DO I = 1,NSTP ERR(I) = MAX( 1.D0, SQRT(CHAPAR(I)) ) IF ( CHAPAR(I) .GT. NMAX ) THEN NMAX = CHAPAR(I) TMAX = DEP(I) IMAX = I ENDIF ENDDO C STARTVALUE FOR X0 IS ABOUT WHERE MORE THAN 1 PARTICLE SHOWS UP II = 1 DO I = 1,NSTP IF ( CHAPAR(I) .GT. 1.D0 ) GOTO 1 II = I ENDDO C OBVIOUSLY WE HAVE NO PARTICLES IN THE DISTRIBUTION WRITE(MONIOU,*) * 'LONGFT: NO PARTICLES IN LONGITUDINAL DISTRIBUTION' WRITE (MONIOU,*)' NO FIT POSSIBLE' DO I = 1,NPAR FPARAM(I) = 0.D0 ENDDO CHI2 = 0.D0 RETURN 1 CONTINUE IF ( II .GT. 1 ) THEN T0 = 0.5 * ( DEP(II) + DEP(II-1) ) ELSE T0 = DEP(II) ENDIF C FIND A START VALUE FOR THE WIDTH PARAMETER AT HALF OF MAXIMUM IF ( NSTP .GT. 10 ) THEN DO I = 1,IMAX IF ( CHAPAR(I) .GT. 0.5D0*NMAX ) THEN IUPPER = I GOTO 31 ENDIF ENDDO IUPPER = IMAX - 1 31 CONTINUE DO I = IMAX, NSTP IF ( CHAPAR(I) .LT. 0.5D0*NMAX ) THEN ILOWER = I GOTO 32 ENDIF ENDDO ILOWER = NSTP - 1 32 CONTINUE HALFW = (DEP(ILOWER) - DEP(IUPPER)) /3.9D0 ELSE C IF WE HAVE ONLY A FEW POINTS, TAKE AN AVERAGE VALUE FOR THE WIDTH HALFW = 70.D0 ENDIF C----------------------------------------------------------------------- C FIT IS PERFORMED WITH THE SUBROUT. AMOEBA FROM: C NUMERICAL RECIPES, W.H. PRESS ET AL., C CAMBRIDGE UNIVERSITY PRESS, 1992 ISBN 0 521 43064 X C SEE THERE HOW IT HAS TO BE USED. C WE FIRST FIT THE GAISSER-HILLAS CURVE WITH SIMPLE WIDTH PARAMETER C THERFORE THE NUMBER OF FREE PARAMETERS IS SET TO 4 = NPAR-2 C CREATE A SET OF NPAR-1 STARTING VERTICES C HERE IS THE FIRST ONE P1(1,1) = NMAX P1(1,2) = T0 P1(1,3) = TMAX P1(1,4) = HALFW IF (DEBUG) WRITE(MDEBUG,*) 'LONGFT: START VALS=',(P1(1,I),I=1,4) C LOOP OVER FITTING ROUTINE (2 TIMES 3 FITS WITH VARYING PRECISION) DO J = 1,2 DO JJ = 1,3 C START WITH CRUDE PRECISION AND IMPROVE STEP BY STEP C AFTER THREE STEPS ENLARGE AGAIN EPS = 10.D0**(-3.D0-JJ*0.5D0) FAC = 1.D0 + 2.D0**(2.1D0*(1.D0-JJ)) C GO AS WELL IN DIFFERENT DIRECTIONS IF ( J .EQ. 2 ) FAC = 1.D0/FAC C GET OTHER NPAR-2 STARTING VERTICES FROM THE STARTING POINT BY C VARIATION OF ONLY ONE OF THE COORDINATE VALUES DO I = 2,NPAR-1 DO K = 1,NPAR-2 P1(I,K) = P1(1,K) ENDDO IF ( P1(I,I-1) .EQ. 0.D0 ) THEN P1(I,I-1) = 1.D0 ELSE P1(I,I-1) = P1(I,I-1) * FAC ENDIF ENDDO IF (DEBUG) WRITE(MDEBUG,*) 'LONGFT: TRIAL1,FAC,EPS ', * J,FAC,EPS C CALCULATE FUNCTION VALUES AT THE START VERTICES DO I = 1,NPAR-1 DO K = 1,NPAR-2 F(K) = P1(I,K) ENDDO Y(I) = CHISQ1(F) ENDDO C PERFORM A FIT CALL AMOEBA(P1,Y,NPAR-1,NPAR-2,NPAR-2,EPS,CHISQ1,ITER,IFLAG) IF ( DEBUG ) THEN WRITE(MDEBUG,*) 'LONGFT: ITER1/IFLAG=',ITER,IFLAG WRITE(MDEBUG,*) 'LONGFT: PARAMETERS1=',(SNGL(P1(1,K)),K=1,4) WRITE(MDEBUG,*) 'LONGFT: CHISQ2 =',Y(1) ENDIF C STORE CHI**2 AT FIRST TRIAL OR AT IMPROVED RESULT IF ( J .EQ. 1 .OR. Y(1) .LT. CHI2 ) THEN DO 8 I=1,NPAR-2 FPARAM1(I) = P1(1,I) 8 CONTINUE CHI21 = Y(1) ENDIF C END OF LOOPS OVER THE FITTING ROUTINE ENDDO ENDDO IF (DEBUG) WRITE(MDEBUG,*) 'LONGFIT: INTERMEDIATE PARAMETERS ARE', * (SNGL(FPARAM1(I)),I=1,4),CHI21 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C CREATE A SET OF NPAR+1 STARTING VERTICES C HERE IS THE FIRST ONE (THE FIRST FOUR PARAMETERS REMAIN UNCHANGED) C EXPERIENCE SHOWS, THAT THE FIFTH PARAMETER IS USUALLY NEGATIVE P(1,1) = FPARAM1(1) P(1,2) = FPARAM1(2) P(1,3) = FPARAM1(3) P(1,4) = FPARAM1(4) ** P(1,5) = -0.01D0 ! GIVES SOMETIMES EXTREMELY BAD FITS (OCT. 00 DH) P(1,5) = 0.D0 P(1,6) = 0.D0 C LOOP OVER THE FITTING ROUTINE (2 TIMES 5 FITS WITH VARYING PRECISION) DO J = 1,2 DO JJ = 1,5 C START WITH CRUDE PRECISION AND IMPROVE STEP BY STEP C AFTER FIVE STEPS ENLARGE AGAIN EPS = 10.D0**(-3.D0-JJ*0.5D0) FAC = 1.D0 + 2.D0**(2.1D0*(1.D0-JJ)) C GO AS WELL IN DIFFERENT DIRECTIONS IF ( J .EQ. 2 ) FAC = 1.D0/FAC C GET OTHER NPAR STARTING VERTICES FROM THE STARTING POINT BY VARIATION C OF ONLY ONE OF THE COORDINATE VALUES DO I = 2,NPAR+1 DO K = 1,NPAR P(I,K) = P(1,K) ENDDO IF ( P(I,I-1) .EQ. 0.D0 ) THEN P(I,I-1) = 1.D0 ELSE P(I,I-1) = P(I,I-1) * FAC ENDIF ENDDO IF (DEBUG) WRITE(MDEBUG,*) 'LONGFT: TRIAL,FAC,EPS ',J, * SNGL(FAC),SNGL(EPS) C CALCULATE FUNCTION VALUES AT THE START VERTICES DO I = 1,NPAR+1 DO K = 1,NPAR F(K) = P(I,K) ENDDO Y(I) = CHISQ(F) ENDDO C PERFORM A FIT CALL AMOEBA(P,Y,NPAR+1,NPAR,NPAR,EPS,CHISQ,ITER,IFLAG) IF ( DEBUG ) THEN WRITE(MDEBUG,*) 'LONGFT: ITER/IFLAG=',ITER,IFLAG WRITE(MDEBUG,*) 'LONGFT: PARAMETERS=',(SNGL(P(1,K)),K=1,6) WRITE(MDEBUG,*) 'LONGFT: CHISQ =',SNGL(Y(1)) ENDIF C STORE VALUES AT FIRST TRIAL OR AT IMPROVED RESULT IF ( J .EQ. 1 .OR. Y(1) .LT. CHI2 ) THEN DO I = 1,NPAR FPARAM(I) = P(1,I) ENDDO CHI2 = Y(1) ENDIF C END OF LOOPS OVER THE FITTING ROUTINE ENDDO ENDDO RETURN END *CMZ : 27/02/2002 16.27.13 by D. HECK IK FZK KARLSRUHE *-- Author : K. BERNLOEHR MPIK HEIDELBERG 15/06/98 C======================================================================= SUBROUTINE LOWUP(CHAR) C----------------------------------------------------------------------- C (CONVERTS) LOW(ER CASE CHARACTER TO) UP(PER CASE CHARACTER) C C THIS SUBROUTINE IS CALLED FROM DATAC. C ARGUMENT: C CHAR = CHARACTER TO BE CONVERTED C C REDESIGN : K. BERNLOEHR MPIK HEIDELBERG 1998 C----------------------------------------------------------------------- IMPLICIT NONE INTEGER IDX CHARACTER*1 CHAR CHARACTER LOWCHR*26, UPRCHR*26 SAVE DATA UPRCHR/'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ DATA LOWCHR/'abcdefghijklmnopqrstuvwxyz'/ C----------------------------------------------------------------------- IDX = INDEX(LOWCHR,CHAR) IF ( IDX .NE. 0 ) CHAR = UPRCHR(IDX:IDX) RETURN END *CMZ : 28/02/2002 13.12.11 by D. HECK IK FZK KARLSRUHE *-- Author : D. HECK IK3 FZK KARLSRUHE 15/10/96 C======================================================================= SUBROUTINE MMOL4(Y,X,VAL,ARG,EPS,IER) C----------------------------------------------------------------------- C M(UON) MOL(IERE SCATTERING) 4 (POINT CONTINUED FRACT. INTERPOLATION) C C ROUTINE TAKEN FROM IBM SCIENTIFIC SUBROUT. PACKAGE C ROUTINE TAKEN FROM GEANT321 (CERN) C 4 POINT CONTINUED FRACTION INTERPOLATION C THIS SUBROUTINE IS CALLED FROM MMOLIE. C ARGUMENTS: C Y = INTERPOLATED VALUE FOR THE ARGUMENT X C X = ARGUMENT FOR Y C VAL = VALUE ARRAY C ARG = ARGUMENT ARRAY C EPS = DESIRED ACCURACY C IER = OUTPUT ERROR PARAMETER C 0 ACCURACY O.K. C 1 ACCURACY CAN NOT BE TESTED IN 4TH ORDER INTERPOLATION C 2 TWO IDENTICAL ELEMENTS IN THE ARGUMENT ARRAY C----------------------------------------------------------------------- IMPLICIT NONE REAL ARG(4),AUX,DELT,EPS,H,P1,P2,P3,Q1,Q2,Q3,VAL(4),X,Y,Z INTEGER I,II,III,IER,J,JEND SAVE C----------------------------------------------------------------------- IER = 1 Y = VAL(1) P2 = 1. P3 = Y Q2 = 0. Q3 = 1. DO 16 I = 2,4 II = 0 P1 = P2 P2 = P3 Q1 = Q2 Q2 = Q3 Z = Y JEND = I - 1 3 AUX = VAL(I) DO 10 J = 1,JEND H = VAL(I) - VAL(J) IF ( ABS(H) .GT. 1.E-6*ABS(VAL(I)) ) GOTO 9 IF ( ARG(I) .EQ. ARG(J) ) GOTO 17 IF ( J .LT. JEND ) GOTO 8 II = II + 1 III = I + II IF ( III .GT. 4 ) GOTO 19 VAL(I) = VAL(III) VAL(III) = AUX AUX = ARG(I) ARG(I) = ARG(III) ARG(III) = AUX GOTO 3 8 VAL(I) = 1.E36 GOTO 10 9 VAL(I) = ( ARG(I)-ARG(J) ) / H 10 CONTINUE P3 = VAL(I) * P2 + ( X - ARG(I-1) ) * P1 Q3 = VAL(I) * Q2 + ( X - ARG(I-1) ) * Q1 IF ( Q3. NE. 0. ) THEN Y = P3 / Q3 ELSE Y = 1.E36 ENDIF DELT = ABS(Z-Y) IF ( DELT .LE. EPS ) GOTO 19 16 CONTINUE RETURN 17 IER = 2 RETURN 19 IER = 0 RETURN END *CMZ : 18/10/2000 09.15.11 by D. HECK IK3 FZK KARLSRUHE *-- Author : D. HECK IK3 FZK KARLSRUHE 15/10/96 C======================================================================= SUBROUTINE MMOLIE(OMEGA,DENS) C----------------------------------------------------------------------- C M(UON) MOLIE(RE MULTIPLE SCATTERING) C C TREATES MOLIERE MULTIPLE SCATTERING FOR MUONS C CORRECTED FOR FINITE ANGLE SCATTERING C THIS SUBROUTINE IS IN ANALOGY WITH SUBROUT. GMOLIE C (AUTHOR: M.S.DIXIT, NRCC, OTTAWA) OF GEANT321 C SEE CERN PROGRAM LIBRARY LONG WRITEUP W5013 C THIS SUBROUTINE IS CALLED FROM UPDATE. C ARGUMENTS: C OMEGA = NUMBER OF SCATTERINGS FOR THE STEP C DENS = LOCAL DENSITY C C REDESIGN: D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,MUMULT. COMMON /MUMULT/ CHC,OMC,PHISCT,STEPL,VSCAT,FMOLI DOUBLE PRECISION CHC,OMC,PHISCT,STEPL,VSCAT LOGICAL FMOLI *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DOUBLE PRECISION TINT(40),B,BINV,CHIC,CNST,DB,DENS,OMEGA,SINTH, * TEST,TMP REAL ARG(4),F0I(40),F1I(40),F2I(40), * THRED(40),VAL(4),F,THRI,XINT INTEGER IER,JA,L,M,NA,NA3,NA3M,NMAX SAVE DATA THRED/ 0.00, 0.10, 0.20, 0.30 + , 0.40, 0.50, 0.60, 0.70 + , 0.80, 0.90, 1.00, 1.10 + , 1.20, 1.30, 1.40, 1.50 + , 1.60, 1.70, 1.80, 1.90 + , 2.00, 2.20, 2.40, 2.60 + , 2.80, 3.00, 3.20, 3.40 + , 3.60, 3.80, 4.00, 5.00 + , 6.00, 7.00, 8.00, 9.00 + , 10.00,11.00,12.00,13.00 / DATA F0I/ + 0.000000E+00 ,0.995016E-02 ,0.392106E-01 ,0.860688E-01 + ,0.147856E+00 ,0.221199E+00 ,0.302324E+00 ,0.387374E+00 + ,0.472708E+00 ,0.555142E+00 ,0.632121E+00 ,0.701803E+00 + ,0.763072E+00 ,0.815480E+00 ,0.859142E+00 ,0.894601E+00 + ,0.922695E+00 ,0.944424E+00 ,0.960836E+00 ,0.972948E+00 + ,0.981684E+00 ,0.992093E+00 ,0.996849E+00 ,0.998841E+00 + ,0.999606E+00 ,0.999877E+00 ,0.999964E+00 ,0.999990E+00 + ,0.999998E+00 ,0.999999E+00 ,0.100000E+01 ,0.100000E+01 + ,0.100000E+01 ,0.100000E+01 ,0.100000E+01 ,0.100000E+01 + ,1.000000E+00 ,1.000000E+00 ,1.000000E+00 ,1.000000E+00 / DATA F1I/ + 0.000000E+00, 0.414985E-02, 0.154894E-01, 0.310312E-01 + , 0.464438E-01, 0.569008E-01, 0.580763E-01, 0.468264E-01 + , 0.217924E-01,-0.163419E-01,-0.651205E-01,-0.120503E+00 + ,-0.178272E+00,-0.233580E+00,-0.282442E+00,-0.321901E+00 + ,-0.350115E+00,-0.366534E+00,-0.371831E+00,-0.367378E+00 + ,-0.354994E+00,-0.314803E+00,-0.266539E+00,-0.220551E+00 + ,-0.181546E+00,-0.150427E+00,-0.126404E+00,-0.107830E+00 + ,-0.933106E-01,-0.817375E-01,-0.723389E-01,-0.436650E-01 + ,-0.294700E-01,-0.212940E-01,-0.161406E-01,-0.126604E-01 + ,-0.102042E-01,-0.840465E-02,-0.704261E-02,-0.598886E-02/ DATA F2I/ + 0.000000 , 0.121500E-01, 0.454999E-01, 0.913000E-01 + , 0.137300E+00, 0.171400E+00, 0.183900E+00, 0.170300E+00 + , 0.132200E+00, 0.763000E-01, 0.126500E-01,-0.473500E-01 + ,-0.936000E-01,-0.119750E+00,-0.123450E+00,-0.106300E+00 + ,-0.732800E-01,-0.312400E-01, 0.128450E-01, 0.528800E-01 + , 0.844100E-01, 0.114710E+00, 0.106200E+00, 0.765830E-01 + , 0.435800E-01, 0.173950E-01, 0.695001E-03,-0.809500E-02 + ,-0.117355E-01,-0.125449E-01,-0.120280E-01,-0.686530E-02 + ,-0.385275E-02,-0.231115E-02,-0.147056E-02,-0.982480E-03 + ,-0.682440E-03,-0.489715E-03,-0.361190E-03,-0.272582E-03/ C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'MMOLIE: OMEGA=',SNGL(OMEGA), * ' DENS=',SNGL(DENS) C COMPUTE VSCAT ANGLE FROM MOLIERE DISTRIBUTION VSCAT = 0.D0 IF ( OMEGA .LE. ENEPER ) RETURN CNST = LOG(OMEGA) B = 5.D0 DO 10 L = 1,10 IF ( ABS(B) .LT. 1.D-10 ) THEN B = 1.D-10 ENDIF DB = - ((B - LOG(ABS(B)) - CNST)/(1.D0 - 1.D0/B)) B = B + DB IF ( ABS(DB) .LE. 0.0001D0 ) GOTO 20 10 CONTINUE RETURN 20 CONTINUE IF ( B .LE. 0.D0 ) RETURN C CHC IS DEFINED DIFFERENTLY FROM GEANT CHIC = CHC*SQRT(CHI)/(PAMA(5)*GAMMA*BETA**2) BINV = 1.D0/B TINT(1) = 0.D0 DO 30 JA = 2,4 TINT(JA) = F0I(JA) + ( F1I(JA) + F2I(JA)*BINV ) * BINV 30 CONTINUE NMAX = 4 40 CONTINUE CALL RMMAR(RD,2,1) XINT = RD(2) DO 50 NA = 3,40 IF ( NA .GT. NMAX ) THEN TINT(NA) = F0I(NA) + ( F1I(NA) + F2I(NA)*BINV ) * BINV NMAX = NA ENDIF IF ( XINT .LE. TINT(NA-1) ) GOTO 60 50 CONTINUE IF ( XINT .LE. TINT(40) ) THEN NA = 40 GOTO 60 ELSE TMP = 1.D0 - ( 1.D0 - B*(1.D0-XINT) )**5 IF ( TMP .LE. 0.D0 ) GOTO 40 THRI = 5.D0 / TMP GOTO 80 ENDIF 60 CONTINUE NA = MAX(NA-1,3) NA3 = NA-3 DO 70 M = 1,4 NA3M = NA3 + M ARG(M) = TINT(NA3M) VAL(M) = THRED(NA3M)**2 70 CONTINUE F = THRED(NA) * .02D0 CALL MMOL4(THRI,XINT,VAL,ARG,F,IER) 80 CONTINUE VSCAT = CHIC * SQRT( ABS(B*THRI) ) IF ( VSCAT .GT. PI ) GOTO 40 SINTH = SIN(VSCAT) TEST = VSCAT * (RD(1))**2 IF ( TEST .GT. SINTH ) GOTO 40 RETURN END *CMZ : 18/10/2000 09.15.11 by D. HECK IK3 FZK KARLSRUHE *-- Author : D. HECK IK3 FZK KARLSRUHE 15/10/96 C======================================================================= SUBROUTINE MPOISS(AMEAN,NPRAN) C----------------------------------------------------------------------- C M(UON COULOMB SCATTERING) POISS(ON DISTRIBUTION) C C GENERATES A RANDOM NUMBER POISSON DISTRIBUTED WITH MEAN VALUE AMEAN. C THIS SUBROUTINE IS IN ANALOGY WITH SUBROUT. GPOISS. C (AUTHOR: L. URBAN) OF GEANT321 C SEE CERN PROGRAM LIBRARY LONG WRITEUP W5013. C THIS SUBROUTINE IS CALLED FROM MUCOUL. C ARGUMENTS: C AMEAN = MEAN VALUE OF RANDOM NUMBER C NPRAN = RANDOM NUMBER POISSON DISTRIBUTED C C REDESIGN: D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DOUBLE PRECISION AMEAN,AN,HMXINT,P,PLIM,RR,S,X INTEGER NPRAN SAVE DATA PLIM/16.D0/,HMXINT/2.D9/ C----------------------------------------------------------------------- C PROTECTION AGAINST NEGATIVE MEAN VALUES AN = 0.D0 IF ( AMEAN .GT. 0.D0 ) THEN IF ( AMEAN .LE. PLIM ) THEN CALL RMMAR(RD,1,1) P = EXP(-AMEAN) S = P IF ( RD(1) .LE. S ) GOTO 20 10 AN = AN + 1.D0 P = P * AMEAN / AN S = S + P IF ( S .LT. RD(1) .AND. P .GT. 1.D-30 ) GOTO 10 ELSE CALL RMMAR(RD,2,1) RR = SQRT( (-2.D0)*LOG(RD(1)) ) X = RR * COS( PI2 * RD(2) ) AN = MIN( MAX( AMEAN+X*SQRT(AMEAN), 0.D0 ), HMXINT ) ENDIF ENDIF 20 NPRAN = AN RETURN END *CMZ : 28/02/2002 13.12.11 by D. HECK IK FZK KARLSRUHE *-- Author : D. HECK IK3 FZK KARLSRUHE 25/09/96 C======================================================================= SUBROUTINE MUBREM C----------------------------------------------------------------------- C MU(ON) BREM(SSTRAHLUNG) C C TREATES MUON BREMSSTRAHLUNG (WITHOUT POLARISATION EFFECTS) C IN ANALOGY WITH SUBROUT. GBREMM FROM GEANT WRITTEN BY L. URBAN C EXPLANATIONS SEE CERN PROGRM LIBRARY LONG WRITEUP W5013 C THIS SUBROUTINE IS CALLED FROM MUTRAC. C C DESIGN : D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,ELABCT. COMMON /ELABCT/ ELCUT DOUBLE PRECISION ELCUT(4) *KEEP,GENER. COMMON /GENER/ GEN,ALEVEL DOUBLE PRECISION GEN,ALEVEL *KEEP,LONGI. COMMON /LONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG, * SDLONG,SELONG,SPLONG,THSTEP,THSTPI, * LHEIGH,NSTEP,LLONGI,FLGFIT DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9), * APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9), * HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9), * SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI INTEGER LHEIGH,NSTEP LOGICAL LLONGI,FLGFIT *KEEP,MUPART. COMMON /MUPART/ AMUPAR,BCUT,CMUON,FMUBRM,FMUORG DOUBLE PRECISION AMUPAR(16),BCUT,CMUON(11) LOGICAL FMUBRM,FMUORG *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,POLAR. COMMON /POLAR/ POLART,POLARF DOUBLE PRECISION POLART,POLARF *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,REST. COMMON /REST/ CONTNE,TAR,LT DOUBLE PRECISION CONTNE(3),TAR INTEGER LT *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DOUBLE PRECISION ALFA1,BETA1,COSTH3,CREJ,D,F1, * EKIN,EMUON,PHI3,SCREJ,SINTH3,THETA3,U,UMAX, * V,VC,VM,V1,W1,Z,THICK INTEGER I SAVE EXTERNAL THICK DATA ALFA1/0.625D0/ C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=1,9) 444 FORMAT(' MUBREM: CURPAR=',1P,9E10.3) C COPY VERTEX COORDINATES TO SECPAR DO 11 I = 5,8 SECPAR(I) = CURPAR(I) 11 CONTINUE SECPAR( 9) = GEN SECPAR(14) = CURPAR(14) SECPAR(15) = CURPAR(15) SECPAR(16) = CURPAR(16) IF ( LLONGI ) LHEIGH = INT(THICK(H)*THSTPI + 1.D0) C TOTAL AND KINETIC ENERGY OF MUON EMUON = PAMA(5) * GAMMA EKIN = EMUON - PAMA(5) IF ( EKIN .LE. BCUT ) THEN C MUON ENERGY IS TOO LOW TO PRODUCE BREMSSTRAHLUNG SECPAR(2) = CURPAR(2) GOTO 900 ENDIF VC = BCUT/EMUON VM = 1.D0 - CMUON(6+LT)/EMUON IF ( VM .LE. 0.D0 ) THEN C MAXIMUM OF BREMSSTRAHLUNG SPECTRUM IS NEGATIVE, NO BREMSSTRAHLUNG SECPAR(2) = CURPAR(2) GOTO 900 ENDIF CREJ = CMUON(3+LT)/EMUON 50 CALL RMMAR(RD,2,1) V = VC*(VM/VC)**RD(1) V1 = 1.D0 - V C COMPUTE REJECTION FUNCTION F1 = CMUON(LT) - LOG(1.D0 + CREJ*V/V1) SCREJ = (V1 + 0.75D0*V*V)*F1/CMUON(LT) IF ( RD(2) .GT. SCREJ ) GOTO 50 C PHOTON ENERGY SECPAR(2) = EMUON * V C RADIATED GAMMA BELOW CUT? IF ( SECPAR(2) .LE. ELCUT(4) ) THEN IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + SECPAR(2) ENDIF C REDUCE ENERGY OF MUON GOTO 800 ENDIF C SET MATERIAL CONSTANTS CMUON(.) ACCORDING TO C TARGET INDEX LT (1=N, 2=O, 3=AR) WHICH HAS BEEN SET IN BOX2 IF ( LT .EQ. 1 ) THEN Z = 7.D0 ELSEIF ( LT .EQ. 2 ) THEN Z = 8.D0 ELSE Z = 18.D0 ENDIF C GENERATE EMITTED PHOTON ANGLES WITH RESPECT TO MUON DIRECTION C PHI IS GENERATED ISOTROPICALLY AND THETA IS ASSIGNED A UNIVERSAL C ANGULAR DISTRIBUTION WITH D=D(Z,E,V) C THIS FUNCTION APPROXIMATES THE REAL DISTRIBUTION FUNCTION WHICH CAN C BE FOUND IN: YUNG-SU TSAI, REV. MOD. PHYS. 46(1974)815 C +ERRATUM: REV. MOD. PHYS. 49(1977)421 D = 0.13D0 *(0.8D0 + 1.3D0/Z) * (100.D0 + 1.D0/EMUON) * (1.D0 + V) W1 = 9.D0 / (9.D0 + D) UMAX = EMUON * PI / PAMA(5) 10 CALL RMMAR(RD,3,1) IF ( RD(1) .LE. W1 ) THEN BETA1 = ALFA1 ELSE BETA1 = 3.D0 * ALFA1 ENDIF U = -(( LOG(RD(2) * RD(3)) ) / BETA1) C CUT: THETA SHOULD BE .LE. PI ! C THIS CONDITION DEPENDS ON E IN THE CASE OF D=CONST TOO! IF ( U .GE. UMAX ) GOTO 10 THETA3 = U * PAMA(ITYPE) / EMUON COSTH3 = COS( THETA3 ) SINTH3 = SIN( THETA3 ) CALL RMMAR(RD,1,1) PHI3 = PI2 * RD(1) CALL ADDANG( COSTHE,PHI, COSTH3,PHI3, SECPAR(3),SECPAR(4)) IF ( SECPAR(3) .GT. C(29) ) THEN C WRITE BREMSSTRAHLUNG PHOTON TO STACK SECPAR( 1) = 1.D0 SECPAR(10) = H CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + SECPAR(2) ENDIF ENDIF C REDUCE ENERGY OF MUON 800 CONTINUE EMUON = EMUON * V1 SECPAR(2) = EMUON/PAMA(5) 900 CONTINUE C WRITE MUON TO STACK SECPAR( 1) = CURPAR(1) SECPAR( 3) = CURPAR(3) SECPAR( 4) = CURPAR(4) SECPAR(10) = ALEVEL CALL TSTACK RETURN END *CMZ : 18/10/2000 09.15.11 by D. HECK IK3 FZK KARLSRUHE *-- Author : D. HECK IK3 FZK KARLSRUHE 15/10/96 C======================================================================= SUBROUTINE MUCOUL(OMEGA,DENS) C----------------------------------------------------------------------- C MU(ON) COUL(OMB SCATTERING OF SINGLE SCATTERING EVENTS) C C TREATES SINGLE COULOMB SCATTERING FOR MUONS IN SMALL ANGLE C APPROXIMATION. C THIS SUBROUTINE IS IN ANALOGY WITH SUBROUT. GMCOUL C (AUTHOR: G. LYNCH, LBL) OF GEANT321 C SEE CERN PROGRAM LIBRARY LONG WRITEUP W5013 C THIS SUBROUTINE IS CALLED FROM UPDATE. C ARGUMENTS: C OMEGA = NUMBER OF SCATTERINGS FOR THE STEP C DENS = LOCAL DENSITY C C REDESIGN: D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,MUMULT. COMMON /MUMULT/ CHC,OMC,PHISCT,STEPL,VSCAT,FMOLI DOUBLE PRECISION CHC,OMC,PHISCT,STEPL,VSCAT LOGICAL FMOLI *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DOUBLE PRECISION DENS,OMCF,OMEGA,OMEGA0,PHIS,SUMX,SUMY, * THET,THMIN2 INTEGER I,NSCMX,NSCA SAVE DATA OMCF/1.167D0/,NSCMX/50/ C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'MUCOUL: OMEGA=',SNGL(OMEGA), * ' DENS=',SNGL(DENS) C COMPUTE NUMBER OF SCATTERS (POISSON DISTR. WITH MEAN OMEGA0) OMEGA0 = OMCF*OMEGA CALL MPOISS (OMEGA0,NSCA) IF ( NSCA .LE. 0 ) THEN VSCAT = 0.D0 RETURN ENDIF NSCA = MIN(NSCA,NSCMX) CALL RMMAR(RD,2*NSCA,1) C THMIN2 IS THE SCREENING ANGLE THMIN2 = CHC**2/( OMCF*OMC * (PAMA(5)*BETA*GAMMA)**2 ) SUMX = 0.D0 SUMY = 0.D0 DO 12 I = 1,NSCA THET = SQRT( THMIN2*((1./RD(I)) - 1.) ) PHIS = PI2 * RD(NSCA+I) SUMX = SUMX + THET*COS(PHIS) SUMY = SUMY + THET*SIN(PHIS) 12 CONTINUE VSCAT = SQRT(SUMX**2 + SUMY**2) RETURN END *CMZ : 28/02/2002 13.12.11 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE MUDECY C----------------------------------------------------------------------- C MU(ON) DEC(A)Y C C TREATES DECAY OF MUON INTO ELECTRON (INCLUDING POLARISATION EFFECTS) C INCLUDING NEUTRINOS, IF SELECTED C THIS SUBROUTINE IS CALLED FROM MUTRAC. C C DESIGN : D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,GENER. COMMON /GENER/ GEN,ALEVEL DOUBLE PRECISION GEN,ALEVEL *KEEP,LONGI. COMMON /LONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG, * SDLONG,SELONG,SPLONG,THSTEP,THSTPI, * LHEIGH,NSTEP,LLONGI,FLGFIT DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9), * APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9), * HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9), * SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI INTEGER LHEIGH,NSTEP LOGICAL LLONGI,FLGFIT *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,POLAR. COMMON /POLAR/ POLART,POLARF DOUBLE PRECISION POLART,POLARF *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DOUBLE PRECISION AUX2,COSDE,COSTH3,COS3CM,COS3C1,COS3C2, * E3CM,GAMMA3,GAMMA4,PHI3CM,PHI3C2,PHI31, * P3CM,THICK,XI INTEGER I SAVE EXTERNAL THICK C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=1,9) 444 FORMAT(' MUDECY: CURPAR=',1P,9E10.3) C COPY VERTEX COORDINATES TO SECPAR DO 4 I = 5,8 SECPAR(I) = CURPAR(I) 4 CONTINUE SECPAR( 9) = GEN SECPAR(10) = ALEVEL SECPAR(14) = CURPAR(14) SECPAR(15) = CURPAR(15) SECPAR(16) = CURPAR(16) IF ( LLONGI ) LHEIGH = INT(THICK(H)*THSTPI + 1.D0) C MUON DECAYS INTO ELECTRON AND NEUTRINOS XI = 2*ITYPE - 11 C ELECTRON ENERGY SPECTRUM N(E) * DE = CONST * E**2 * (3/2*E0-E) * DE C IS GAINED BY THE REJECTION/REFLECTION METHOD 6 CALL RMMAR( RD,4,1 ) IF ( RD(1)**2*(3.-RD(1)*2.) .LT. RD(2) ) RD(1) = 1.-RD(1) E3CM = PAMA(2) + RD(1) * ( C(8) - PAMA(2) ) IF ( E3CM .GT. 0.5D0*PAMA(5) ) GOTO 6 P3CM = SQRT( E3CM**2 - PAMA(2)**2 ) C NOW DETERMINE COS3C1 AND PHI31 BY RANDOM SELECTION C WITH RESPECT TO THE POLARIZATION DIRECTION OF THE MUON IN THE MU CM C GIVEN BY POLART, POLARF COSDE = 2.D0 * RD(4) - 1.D0 AUX2 = ( 1. - 2.*RD(1) ) / ( 3. - 2.*RD(1) ) IF ( ABS(AUX2) .GT. 1.D-2 ) THEN COS3C1 = XI*(SQRT(1.D0-(2.D0*COSDE-AUX2)*AUX2) - 1.D0) / AUX2 ELSE COS3C1 = (-XI) * COSDE ENDIF PHI31 = RD(3)*PI2 C NOW ADD ELECTRON EMISSION ANGLE COS3C1 TO THE POLARISATION DIRECTION C TO GET THE DIRECTION (RELATIVE TO THE CORSIKA COORDINATE SYSTEM) CALL ADDANG( POLART,POLARF, COS3C1,PHI31, COS3C2,PHI3C2 ) C GET THE ELECTRON DIRECTION RELATIVE TO THE MUON LAB DIRECTION CALL ADDANI( CURPAR(3),CURPAR(4), COS3C2,PHI3C2, COS3CM,PHI3CM ) C LORENTZ TRANSFORMATION TO THE LAB SYSTEM GAMMA3 = GAMMA * ( E3CM + BETA * P3CM * COS3CM ) / PAMA(2) COSTH3 = MIN( 1.D0, GAMMA * (P3CM * COS3CM + BETA * E3CM) / * (PAMA(2) * SQRT(GAMMA3**2 - 1.D0)) ) CALL ADDANG( CURPAR(3),CURPAR(4), COSTH3,PHI3CM, * SECPAR(3),SECPAR(4) ) IF ( SECPAR(3) .GT. C(29) ) THEN SECPAR(1) = ITYPE - 3 SECPAR(2) = GAMMA3 CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( ITYPE .EQ. 5 ) THEN DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + (GAMMA3+1.D0) * PAMA(2) ELSE DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + (GAMMA3-1.D0) * PAMA(2) ENDIF ENDIF ENDIF POLART = 0.D0 POLARF = 0.D0 IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT GAMMA4 = GAMMA * PAMA(5) - GAMMA3 * PAMA(2) DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + GAMMA4 ENDIF RETURN END *CMZ : 05/07/2001 13.19.11 by D. HECK IK FZK KARLSRUHE *-- Author : D. HECK IK3 FZK KARLSRUHE 04/10/96 C======================================================================= SUBROUTINE MUPRPR C----------------------------------------------------------------------- C MU(ON) P(AI)R PR(ODUCTION) C C TREATES MUON PAIR PRODUCTION (WITHOUT POLARISATION EFFECTS) C IN ANALOGY WITH SUBROUTINE SUBROUT. FROM GEANT WRITTEN BY L. URBAN C EXPLANATIONS SEE CERN PROGRM LIBRARY LONG WRITEUP W5013 C THIS SUBROUTINE IS CALLED FROM MUTRAC. C C DESIGN : D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,ELABCT. COMMON /ELABCT/ ELCUT DOUBLE PRECISION ELCUT(4) *KEEP,GENER. COMMON /GENER/ GEN,ALEVEL DOUBLE PRECISION GEN,ALEVEL *KEEP,LONGI. COMMON /LONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG, * SDLONG,SELONG,SPLONG,THSTEP,THSTPI, * LHEIGH,NSTEP,LLONGI,FLGFIT DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9), * APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9), * HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9), * SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI INTEGER LHEIGH,NSTEP LOGICAL LLONGI,FLGFIT *KEEP,MUPART. COMMON /MUPART/ AMUPAR,BCUT,CMUON,FMUBRM,FMUORG DOUBLE PRECISION AMUPAR(16),BCUT,CMUON(11) LOGICAL FMUBRM,FMUORG *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,POLAR. COMMON /POLAR/ POLART,POLARF DOUBLE PRECISION POLART,POLARF *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,REST. COMMON /REST/ CONTNE,TAR,LT DOUBLE PRECISION CONTNE(3),TAR INTEGER LT *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DOUBLE PRECISION AA,ALE,ALFA,AL10T,A1,A1R,B,BETA1,CC,C1,C2, * COSTH3,EKIN,EMUON,ENEG,EPOS,EPP, * PHI3,R0,R0MAX,SCREJ,THICK, * V,VC,VMAX,VMIN,V0,Z INTEGER I SAVE EXTERNAL THICK DATA AL10T/9.212D0/ C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=1,9) 444 FORMAT(' MUPRPR: CURPAR=',1P,9E10.3) C COPY VERTEX COORDINATES TO SECPAR DO 11 I = 5,8 SECPAR(I) = CURPAR(I) 11 CONTINUE SECPAR( 9) = GEN SECPAR(14) = CURPAR(14) SECPAR(15) = CURPAR(15) SECPAR(16) = CURPAR(16) IF ( LLONGI ) LHEIGH = INT(THICK(H)*THSTPI + 1.D0) C SET MATERIAL CONSTANTS CMUON(.) ACCORDING TO C TARGET INDEX LT (1=N, 2=O, 3=AR) WHICH HAS BEEN SET IN BOX2 IF ( LT .EQ. 1 ) THEN Z = 7.D0 ELSEIF ( LT .EQ. 2 ) THEN Z = 8.D0 ELSE Z = 18.D0 ENDIF C TOTAL AND KINETIC ENERGY OF MUON EMUON = PAMA(5) * GAMMA EKIN = EMUON - PAMA(5) IF ( EKIN .LE. BCUT ) GOTO 900 C VMIN = 4.D0 * PAMA(2) / EMUON VMAX = 1.D0 - CMUON(10) * Z**OB3 / EMUON IF ( VMAX .LE. VMIN ) GOTO 900 VC = BCUT / EMUON ALE = LOG(EMUON) ALFA = 1.D0 + ALE/AL10T V0 = 0.18D0 * (4.D0 + ALE/AL10T) * ALFA * (ALFA*VMIN)**TB3 BETA1 = 0.1D0 * (1.D0 + 3.D0 * ALE/AL10T) B = 0.9D0 / (1.D0 + 0.4D0*ALE + 0.022D0*ALE**2) AA = 1.D0 + 2.D0 * B * LOG(VC/V0) IF ( AA .LE. 1.D0 ) AA = 1.05D0 A1 = 1.D0 - AA CC = EXP((-0.25D0)*A1*A1/B) A1R = 1.D0 / A1 C1 = VMAX**A1 C2 = VC**A1 C SAMPLE ENERGY FRACTION V AND RO 50 CALL RMMAR(RD,2,1) V = ( RD(1)*C1 + (1.-RD(1))*C2 )**A1R IF ( V .LE. VMIN ) GOTO 50 IF ( V .LT. V0 ) THEN SCREJ = CC * ( (V-VMIN)/(V0-VMIN) )**BETA * (V0/V)**A1 ELSE SCREJ = CC * (V0/V)**( A1 + B*LOG(V/V0) ) ENDIF IF ( RD(2) .GT. SCREJ ) GOTO 50 R0MAX = SCREJ * ( 1.D0 - 6.D0 *PAMA(5)/( EMUON**2 * (1.D0-V) ) ) CALL RMMAR(RD,2,1) R0 = R0MAX * (2.*RD(1)-1.) C ENERGIES EPP = V * EMUON EPOS = 0.5D0 * EPP * (1.D0 + R0) ENEG = EPP - EPOS C ANGLES COSTH3 = COS( PAMA(5)/EMUON ) PHI3 = PI2 * RD(2) C POSITRON IF ( EPOS .GT. BCUT+PAMA(2) ) THEN CALL ADDANG( COSTHE,PHI, COSTH3,PHI3, SECPAR(3),SECPAR(4) ) IF ( SECPAR(3) .GT. C(29) ) THEN SECPAR( 1) = 2.D0 SECPAR( 2) = EPOS/PAMA(2) SECPAR(10) = H CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + EPOS + PAMA(2) ENDIF ENDIF ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + EPOS + PAMA(2) ENDIF ENDIF C ELECTRON IF ( ENEG .GT. BCUT+PAMA(2) ) THEN CALL ADDANG( COSTHE,PHI, COSTH3,-PHI3, SECPAR(3),SECPAR(4) ) IF ( SECPAR(3) .GT. C(29) ) THEN SECPAR( 1) = 3.D0 SECPAR( 2) = ENEG/PAMA(2) SECPAR(10) = H CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + ENEG - PAMA(2) ENDIF ENDIF ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + ENEG - PAMA(2) ENDIF ENDIF C REDUCE ENERGY OF MUON 60 CONTINUE GAMMA = (EMUON - EPP)/ PAMA(5) 900 CONTINUE C WRITE MUON TO STACK SECPAR( 1) = CURPAR(1) SECPAR( 2) = GAMMA SECPAR( 3) = CURPAR(3) SECPAR( 4) = CURPAR(4) SECPAR(10) = ALEVEL CALL TSTACK RETURN END *CMZ : 05/03/2002 08.29.07 by D. HECK IK FZK KARLSRUHE *-- Author : D. HECK IK3 FZK KARLSRUHE 25/09/96 C======================================================================= SUBROUTINE MUTRAC(fmfb) C----------------------------------------------------------------------- C MU(ON) TRAC(KING) C C TRACKS THE MUON REGARDING MAX. STEP LENGTH FOR MULTIPLE SCATTERING C CHECKS PASSAGE THROUGH OBSERVATION LEVELS C IRET1=1 KILLS PARTICLE C IRET2=1 PARTICLE HAS BEEN CUTTED IN UPDATE C THIS SUBROUTINE IS CALLED FROM BOX3. C C DESIGN : D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,GENER. COMMON /GENER/ GEN,ALEVEL DOUBLE PRECISION GEN,ALEVEL *KEEP,IRET. COMMON /IRET/ IRET1,IRET2,IRETE INTEGER IRET1,IRET2 LOGICAL IRETE *KEEP,LONGI. COMMON /LONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG, * SDLONG,SELONG,SPLONG,THSTEP,THSTPI, * LHEIGH,NSTEP,LLONGI,FLGFIT DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9), * APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9), * HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9), * SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI INTEGER LHEIGH,NSTEP LOGICAL LLONGI,FLGFIT *KEEP,MUMULT. COMMON /MUMULT/ CHC,OMC,PHISCT,STEPL,VSCAT,FMOLI DOUBLE PRECISION CHC,OMC,PHISCT,STEPL,VSCAT LOGICAL FMOLI *KEEP,MUPART. COMMON /MUPART/ AMUPAR,BCUT,CMUON,FMUBRM,FMUORG DOUBLE PRECISION AMUPAR(16),BCUT,CMUON(11) LOGICAL FMUBRM,FMUORG *KEEP,NPARTI. COMMON /NPARTI/ NPARTO DOUBLE PRECISION NPARTO(10,25),NPHOTO(10),NPOSIT(10),NELECT(10), * NNU(10),NMUP(10),NMUM(10),NPI0(10),NPIP(10), * NPIM(10),NK0L(10),NKPL(10),NKMI(10),NNEUTR(10), * NPROTO(10),NPROTB(10),NK0S(10),NHYP(10), * NNEUTB(10),NDEUT(10),NTRIT(10),NALPHA(10), * NOTHER(10),NMUOND EQUIVALENCE (NPARTO(1, 1),NPHOTO(1)), (NPARTO(1, 2),NPOSIT(1)), * (NPARTO(1, 3),NELECT(1)), (NPARTO(1, 4),NNU(1)) , * (NPARTO(1, 5),NMUP(1)) , (NPARTO(1, 6),NMUM(1)) , * (NPARTO(1, 7),NPI0(1)) , (NPARTO(1, 8),NPIP(1)) , * (NPARTO(1, 9),NPIM(1)) , (NPARTO(1,10),NK0L(1)) , * (NPARTO(1,11),NKPL(1)) , (NPARTO(1,12),NKMI(1)) , * (NPARTO(1,13),NNEUTR(1)), (NPARTO(1,14),NPROTO(1)), * (NPARTO(1,15),NPROTB(1)), (NPARTO(1,16),NK0S(1)) , * (NPARTO(1,18),NHYP(1)) , (NPARTO(1,19),NDEUT(1)) , * (NPARTO(1,20),NTRIT(1)) , (NPARTO(1,21),NALPHA(1)), * (NPARTO(1,22),NOTHER(1)), (NPARTO(1,25),NNEUTB(1)), * (NPARTO(1,23),NMUOND) *KEEP,OBSPAR. COMMON /OBSPAR/ OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP, * THETPR,PHIPR, * VUECON, * NOBSLV DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10), * HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2) DOUBLE PRECISION VUECON(2) INTEGER NOBSLV *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DOUBLE PRECISION AUX,CHITOT,STPTOT INTEGER I,IRET3 LOGICAL FSCAT LOGICAL FLAG c-----changed--add logical fmfb c-----changed--add SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=1,9) 444 FORMAT(' MUTRAC: CURPAR=',1P,9E10.3) C THE PLACE OF NEXT INTERACTION WAS DETERMINED IN BOX2 C KEEP TOTAL STEP LENGTH UNTIL DECAY OR INTERACTION OCCURS CHITOT = CHI IF ( FDECAY ) THEN STPTOT = STEPL ENDIF 10 CONTINUE C CALCULATE MAX STEP SIZE (10 RAD. LENGTH) FOR MULTIPLE SCATTERING C THE MAXIMUM STEP SIZE DEPENDS ON THE ENERGY TO GET ARRIVAL TIMES C WITH UNCERTAINTIES SMALLER THAN 1 NSEC AUX = MIN( 10.D0, 0.015D0*GAMMA ) CHI = MIN( AUX*C(21), CHITOT ) IF ( CHI .GE. CHITOT ) THEN FSCAT = .FALSE. IF (DEBUG) WRITE(MDEBUG,*) 'MUTRAC: CHI=',SNGL(CHI) ELSE FSCAT = .TRUE. IF (DEBUG) WRITE(MDEBUG,*) 'MUTRAC: C(XX)=',SNGL(AUX*C(21)) ENDIF C UPDATE PARTICLE TO INTERACTION POINT OR OBSERVATION LEVEL, C WHICHEVER IS CLOSER FLAG = .TRUE. c-----changed--add CALL UPDATC(IRET3,FLAG,fmfb) c-----changed--add C IRET3 = 1 MEANS PARTCLE HAS PASSED OBSERVATION LEVEL IF ( DEBUG ) WRITE(MDEBUG,*) 'MUTRAC: IRET1,2,3=', * IRET1,IRET2,IRET3 IF ( IRET2 .NE. 0 ) THEN C MUON CUTTED BEFORE INTERACTION POINT C LONGITUDINAL DEPOSIT IS ALREADY DONE IN UPDATC IRET1 = 1 FMUORG = .FALSE. RETURN ELSE IF ( IRET3 .EQ. 0 ) THEN C STORE MUON FOR FURTHER TREATMENT DO I = 1,8 CURPAR(I) = OUTPAR(I) ENDDO BETA = SQRT( GAMMA**2 - 1.D0 ) / GAMMA ELSE C KILL PARTICLE AS IT IS AT DETECTOR LEVEL IRET1 = 1 FMUORG = .FALSE. RETURN ENDIF ENDIF IF ( FDECAY ) THEN C MUON DECAYS AT END OF PATH (MUDECY WRITES EM-PARTICLE TO STACK) IF ( FSCAT ) THEN C CHITOT IS THE MATERIAL STILL TO BE TRACKED C STPTOT IS THE PATHLENGTH STILL TO BE TRACKED STPTOT = STPTOT - STEPL CHITOT = CHITOT - CHI IF ( CHITOT.GT.0.D0 .AND. STPTOT.GT.0.D0 ) GOTO 11 ENDIF ALEVEL = H CALL MUDECY NMUOND = NMUOND + 1.D0 FMUORG = .FALSE. ELSE C MUON UNDERGOES BREMSSTR/PAIRPR AT END OF PATH C (MUBREM/MUPRPR WRITE EM-PARTICLES AND MUON TO STACK) IF ( FSCAT ) THEN C MUON HAS MADE MULTIPLE SCATTERING C CHITOT IS THE MATERIAL STILL TO BE TRACKED CHITOT = CHITOT - CHI IF ( CHITOT .GT. 0.D0 ) GOTO 11 ENDIF IF ( FMUBRM ) THEN CALL MUBREM ELSE CALL MUPRPR ENDIF ENDIF IRET1 = 1 RETURN 11 CONTINUE IF ( DEBUG ) WRITE(MDEBUG,457) (CURPAR(I),I=1,9) 457 FORMAT(' MUTRAC: SCATTER',1P,9E10.3) GOTO 10 END *CMZ : 27/02/2002 16.27.13 by D. HECK IK FZK KARLSRUHE *-- Author : F. SCHROEDER UNI WUPPERTAL 17/09/98 C======================================================================= SUBROUTINE NRANGC(ARG) C----------------------------------------------------------------------- C N(EUTRAL PARTICLE) RANGE C(URVED ATMOSPHERE) C C DETERMINES PENETRATED MATTER CHI FOR NEUTRAL PARTICLES C TAKING INTO ACCOUNT A CURVED ATMOSPHERE C THIS SUBROUTINE IS CALLED FROM AAMAIN AND BOX2. C ARGUMENT: C ARG = GEOMETRIC LENGTH OF PARTICLE TRACK C C DESIGN : F. SCHROEDER UNI WUPPERTAL C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,ATMOS2. COMMON /ATMOS2/ HLAY,HLAY0,THICKL,LAYNO,LAYNEW DOUBLE PRECISION HLAY(6),HLAY0(5,0:4),THICKL(5) INTEGER LAYNO(0:16) LOGICAL LAYNEW *KEEP,OBSPAR. COMMON /OBSPAR/ OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP, * THETPR,PHIPR, * VUECON, * NOBSLV DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10), * HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2) DOUBLE PRECISION VUECON(2) INTEGER NOBSLV *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DOUBLE PRECISION ARG,ARGNEW,COSDIF,COSPHI,COSTAPNEW,COSTHENEW, * DH,DISTN2,DISTO2,HOLD,HNEW,RADIUS,SIGNE, * SINPHI,SINTHENEW,THICK,TRANS,TRANSNEW,XNEW,YNEW SAVE EXTERNAL THICK C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,444) ARG,THICKH 444 FORMAT(' NRANGC: ARG=',1P,E10.3,' THICKH=',E10.3) C START VALUES CHI = 0.D0 HNEW = H XNEW = X YNEW = Y COSPHI = COS( PHI ) SINPHI = SIN( PHI ) DISTN2 = XNEW**2 + YNEW**2 COSTHENEW = COSTHE COSTAPNEW = COSTAP C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C LOOP OVER PIECES OF ARG (EACH IN ITS LOCAL FLAT COORDINATE FRAME) 2 CONTINUE SINTHENEW = SQRT( 1.D0 - COSTHENEW**2 ) TRANS = ARG * SINTHENEW C MAXIMAL HORIZONTAL STEP (DEPENDS ON THICKNESS AT PARTICLE ALTITUDE) TRANSNEW = MIN( TRANS, C(4) * THICKH + C(3) ) IF (DEBUG) WRITE(MDEBUG,*) 'NRANGC: TRANSNEW=',SNGL(TRANSNEW) IF ( SINTHENEW .LE. 0.D0 ) THEN C PARTICLE TRACK IS VERTICAL ARGNEW = ARG ELSE ARGNEW = TRANSNEW / SINTHENEW ENDIF DH = ARGNEW * COSTHENEW IF ( HNEW-DH .LE. HLAY(1) ) THEN CHI = CHI + (THICKL(1) - THICK(HNEW)) / COSTHENEW IF ( DEBUG ) WRITE(MDEBUG,*) * 'NRANGC: HNEW,CHI= ',SNGL(HLAY(1)),SNGL(CHI) RETURN ENDIF CHI = CHI + (THICK(HNEW-DH) - THICK(HNEW)) / COSTHENEW C ACTUAL VALUES ARG = ARG - ARGNEW IF (DEBUG) WRITE(MDEBUG,*) 'NRANGC: ARG,CHI=',SNGL(ARG),SNGL(CHI) C LOOP UNTIL COMPLETE PARTICLE TRACK LENGTHS IS TRANSFORMED INTO CHI IF ( ARG .GT. 0.D0 ) THEN C NEW COORDINATE FRAME HOLD = HNEW C NEW HEIGHT IN OLD COORDINATE FRAME HNEW = HNEW - DH C NEW ACTUAL HEIGHT AT NEW THICKNESS GRADIENT C (CALCULATED WITH PARAMETERS OF OLD COORDINATE FRAME) HNEW = SQRT( TRANSNEW**2 + (C(1)+HNEW)**2 ) - C(1) C TERMINATE PROCESS IF PARTICLE WELL BELOW OBSERVATION LEVEL IF ( HNEW .LT. OBSLEV(1) - 1.D5 ) THEN RETURN ENDIF COSDIF = ( (C(1)+HNEW)**2 + (C(1)+HOLD)**2 - ARGNEW**2 ) / * ( 2.D0 * (C(1)+HNEW) * (C(1)+HOLD) ) IF (DEBUG) WRITE(MDEBUG,*) 'NRANGC: HNEW,COSDIF=', * SNGL(HNEW),SNGL(COSDIF) COSDIF = MIN(1.D0,COSDIF) C DIRECTION OF PARTICLE RELATIVE TO DETECTOR CENTER DISTO2 = DISTN2 IF ( COSDIF .LT. 1.D0 ) THEN RADIUS = ARGNEW * SQRT( (1.D0-COSTAPNEW**2)/(1.D0-COSDIF**2) ) * * C(1) * ACOS(COSDIF)/(C(1)+HNEW) ELSE RADIUS = ARGNEW * SQRT( 1.D0-COSTAPNEW**2 ) ENDIF XNEW = XNEW + RADIUS * COSPHI YNEW = YNEW + RADIUS * SINPHI DISTN2 = XNEW**2 + YNEW**2 IF ( DISTO2 .GT. DISTN2 ) THEN SIGNE = +1.D0 ELSE SIGNE = -1.D0 ENDIF C COSINE OF NEW LOCAL ZENITH ANGLE COSTHENEW = MIN( 1.D0, ( COSTHENEW * COSDIF - SIGNE * * SQRT( (1.D0-COSTHENEW**2) * (1.D0-COSDIF**2) ) ) ) IF (DEBUG) WRITE(MDEBUG,*) 'NRANGC: COSTHENEW=',COSTHENEW C TERMINATE PROCESS IF PARTICLE BECOMES UPWARD GOING IF ( COSTHENEW .LE. C(29) ) RETURN GOTO 2 ENDIF RETURN END *CMZ : 03/09/2001 11.12.38 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE NUCINT C----------------------------------------------------------------------- C NUC(LEAR) INT(ERACTION) C C SELECTS TYPE OF INTERACTION PROCESS ACCORDING TO ECM C HEAVY PRIMARIES AND STRANGE BARYONS INCLUDED C THIS SUBROUTINE IS CALLED FROM AAMAIN. C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,AIR. COMMON /AIR/ COMPOS,PROBTA,AVERAW,AVOGAD DOUBLE PRECISION COMPOS(3),PROBTA(3),AVERAW,AVOGAD *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,GENER. COMMON /GENER/ GEN,ALEVEL DOUBLE PRECISION GEN,ALEVEL *KEEP,IRET. COMMON /IRET/ IRET1,IRET2,IRETE INTEGER IRET1,IRET2 LOGICAL IRETE *KEEP,KAONS. COMMON /KAONS/ CKA DOUBLE PRECISION CKA(80) *KEEP,LONGI. COMMON /LONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG, * SDLONG,SELONG,SPLONG,THSTEP,THSTPI, * LHEIGH,NSTEP,LLONGI,FLGFIT DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9), * APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9), * HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9), * SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI INTEGER LHEIGH,NSTEP LOGICAL LLONGI,FLGFIT *KEEP,MULT. COMMON /MULT/ EKINL,MSMM,MULTMA,MULTOT DOUBLE PRECISION EKINL INTEGER MSMM,MULTMA(40,13),MULTOT(40,13) *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,POLAR. COMMON /POLAR/ POLART,POLARF DOUBLE PRECISION POLART,POLARF *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,SIGM. COMMON /SIGM/ SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO DOUBLE PRECISION SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO *KEEP,STATI. COMMON /STATI/ SABIN,SBBIN,INBIN,IPBIN,IKBIN,IHBIN DOUBLE PRECISION SABIN(40),SBBIN(40) INTEGER INBIN(40),IPBIN(40),IKBIN(40),IHBIN(40) *KEEP,VKIN. COMMON /VKIN/ BETACM DOUBLE PRECISION BETACM *KEND. DOUBLE PRECISION BETA3,COSMU,COSTCM,COSTH3,ETOT,GAMMA3, * PHIMU,PHI3,THICK,WORK1,WORK2 INTEGER I,IGO,KJ SAVE EXTERNAL THICK C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=1,9) 444 FORMAT(' NUCINT: CURPAR=',1P,9E10.3) C COPY VERTEX COORDINATES INTO SECPAR DO 10 I = 5,8 SECPAR(I) = CURPAR(I) 10 CONTINUE C SET GENERATION AND LEVEL OF LAST INTERACTION SECPAR( 9) = GEN SECPAR(10) = ALEVEL C RESET POLARIZATION, NOT USED FOR PARTICLES OTHER THAN MUONS YET SECPAR(11) = 0.D0 SECPAR(12) = 0.D0 SECPAR(14) = CURPAR(14) SECPAR(15) = CURPAR(15) SECPAR(16) = CURPAR(16) THICKH = THICK(H) IF ( LLONGI ) LHEIGH = INT(THICKH * THSTPI + 1.D0) C CALCULATE KIN. ENERGY BIN EKINL = PAMA(ITYPE) * ( GAMMA - 1.D0 ) ETOT = PAMA(ITYPE) * GAMMA IF ( EKINL .GE. .1D0 ) THEN KJ = INT( MIN( 40.D0, 5.D0 + 3.D0*LOG10(EKINL) ) ) ELSE KJ = 1 ENDIF C----------------------------------------------------------------------- C CHARGED PION INCIDENT IF ( ITYPE .EQ. 8 .OR. ITYPE .EQ. 9 ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) 'NUCINT: PION EKINL=',SNGL(EKINL), * ' ETOT=',ETOT IPBIN(KJ) = IPBIN(KJ) + 1 C DECAY OR INTERACTION FOR CHARGED PIONS ? IF ( FDECAY ) THEN C INCREMENT GENERATION COUNTER TO DIFFERENTIATE BETWEEN MUONS FROM C DECAYS (K-DECAY: GEN=NORMAL, PI-DECAY: GEN INCREASED BY 50) SECPAR( 9) = SECPAR( 9) + 50.D0 C DECAY PI(+,-) ----> MU(+,-) + (ANTI)-NEUTRINO(MU) WORK1 = C(48) * GAMMA WORK2 = C(49) * BETA * WORK1 CALL RMMAR( RD,2,1 ) COSTCM = 2.D0 * RD(1) - 1.D0 GAMMA3 = WORK1 + COSTCM * WORK2 BETA3 = SQRT( 1.D0 - 1.D0 / GAMMA3**2 ) COSTH3 = MIN( 1.D0, ( GAMMA * GAMMA3 - C(48) ) * /( BETA * GAMMA * BETA3 * GAMMA3 ) ) PHI3 = PI2 * RD(2) C NEUTRINO IS DROPPED IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT SECPAR(2) = PAMA(8) * GAMMA - PAMA(5) * GAMMA3 DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + SECPAR(2) ENDIF C MUON CALL ADDANG( COSTHE,PHI, COSTH3,PHI3, COSMU,PHIMU ) IF ( COSMU .GT. C(29) ) THEN C DIRECTION OF PION IN THE MUON CM SYSTEM (= DIRECTION OF POLARIZATION) C SEE: G. BARR ET AL., PHYS. REV. D39 (1989) 3532, EQ. 5 C POLART IS COS OF ANGLE BETWEEN PION AND LABORATORY IN THE MU CM C POLARF IS ANGLE PHI AROUND THE LAB DIRECTION IN THE MU CM C POLART, POLARF ARE WITH RESPECT TO THE MU DIRECTION IN THE LAB SYSTEM POLART = ( 2.D0*PAMA(8)*GAMMA*C(7)/(PAMA(5)*GAMMA3) * - C(7) - 1.D0 ) / ( BETA3 * (1.D0 - C(7)) ) POLARF = PHI3 - PI C PION DIRECTION IS DIRECTION OF POLARIZATION FOR PI+, OPPOSITE FOR PI- IF ( ITYPE .EQ. 9 ) THEN POLART = -POLART POLARF = POLARF + PI ENDIF C GET THE POLARIZATION DIRECTION IN THE MU CM RELATIVE TO THE CORSIKA C COORDINATE SYSTEM CALL ADDANG( COSMU,PHIMU, POLART,POLARF, POLART,POLARF ) C MUON IS WRITTEN TO STACK SECPAR( 1) = CURPAR(1) - 3.D0 SECPAR( 2) = GAMMA3 SECPAR( 3) = COSMU SECPAR( 4) = PHIMU SECPAR(11) = POLART SECPAR(12) = POLARF CALL TSTACK SECPAR(11) = 0.D0 SECPAR(12) = 0.D0 ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT DLONG(LHEIGH,5) = DLONG(LHEIGH,5) + GAMMA3 * PAMA(5) ENDIF ENDIF IRET1 = 1 RETURN ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C CHARGED PION INTERACTS C CALCULATE GAMMA, BETA AND ENERGY IN CENTER OF MASS ECM = SQRT( C(45) * GAMMA + C(46) ) GCM = (PAMA(ITYPE) * GAMMA + PAMA(14)) / ECM BETACM = SQRT( 1.D0 - 1.D0 / GCM**2 ) C LOW ENERGY HADRONIC INTERACTIONS C CHECK IF WE USE LOW ENERGY HADRONIC INTERACTION MODEL IF ( USELOW ) THEN C USE GHEISHA IF THE CROSS-SECTION HAS BEEN CALCULATED FOR GHEISHA CALL CGHEI ELSE CALL SDPM ENDIF C----------------------------------------------------------------------- C PI(0) INCIDENT ELSEIF ( ITYPE .EQ. 7 ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) 'NUCINT: PI(0) EKINL=',SNGL(EKINL), * ' ETOT=',ETOT IPBIN(KJ) = IPBIN(KJ) + 1 C DECAY OR INTERACTION FOR PIONS ? IF ( FDECAY ) THEN CALL PI0DEC ELSE C FOR INTERACTION THE ENERGY MUST BE VERY HIGH C CALCULATE GAMMA, BETA AND ENERGY IN CENTER OF MASS ECM = SQRT( 2.D0 * PAMA(14) * PAMA(7) * GAMMA * + PAMA(14)**2 +PAMA(7)**2 ) GCM = (PAMA(7) * GAMMA + PAMA(14)) / ECM BETACM = SQRT( 1.D0 - 1.D0 / GCM**2 ) C HIGH ENERGY INTERACTION MODEL CALL SDPM ENDIF C----------------------------------------------------------------------- C NUCLEON OR ANTINUCLEON INCIDENT ELSEIF ( ITYPE .EQ. 13 .OR. ITYPE .EQ. 14 .OR. * ITYPE .EQ. 15 .OR. ITYPE .EQ. 25 ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) 'NUCINT: NUCL EKINL=',SNGL(EKINL), * ' ETOT=',ETOT C CALCULATE GAMMA, BETA AND ENERGY IN CENTER OF MASS GCM = SQRT( GAMMA * 0.5D0 + 0.5D0 ) ECM = PAMA(ITYPE) * GCM * 2.D0 BETACM = SQRT( 1.D0 - 1.D0 / GCM**2 ) INBIN(KJ) = INBIN(KJ) + 1 C LOW ENERGY HADRONIC INTERACTIONS C CHECK IF WE USE LOW ENERGY HADRONIC INTERACTION MODEL IF ( USELOW ) THEN C USE GHEISHA IF THE CROSS-SECTION HAS BEEN CALCULATED FOR GHEISHA CALL CGHEI ELSE CALL SDPM ENDIF C----------------------------------------------------------------------- C KAON INCIDENT ELSEIF ( ITYPE .EQ. 11 .OR. ITYPE .EQ. 12 .OR. * ITYPE .EQ. 10 .OR. ITYPE .EQ. 16 ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) 'NUCINT: KAON EKINL=',SNGL(EKINL), * ' ETOT=',ETOT IKBIN(KJ) = IKBIN(KJ) + 1 C DECAY OR INTERACTION FOR KAONS ? IF ( FDECAY ) THEN C KAON DECAYS. DETERMINE DECAY MODE FOR KAONS AND SET LIFE TIME IF ( ITYPE .EQ. 10 ) THEN C K(0,L)-MESON IGO = 4 ELSEIF ( ITYPE .EQ. 11 ) THEN C K(+)-MESON IGO = 1 ELSEIF ( ITYPE .EQ. 12 ) THEN C K(-)-MESON IGO = 2 ELSE C K(0,S)-MESON IGO = 3 ENDIF CALL KDECAY( IGO ) RETURN ELSE C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C KAON INTERACTS C CALCULATE GAMMA, BETA AND ENERGY IN CENTER OF MASS ECM = SQRT( CKA(13) * GAMMA + CKA(14) ) GCM = ( PAMA(ITYPE) * GAMMA + PAMA(14) ) / ECM BETACM = SQRT( 1.D0 - 1.D0 / GCM**2 ) C LOW ENERGY HADRONIC INTERACTIONS C CHECK IF WE USE LOW ENERGY HADRONIC INTERACTION MODEL IF ( USELOW ) THEN C USE GHEISHA IF THE CROSS-SECTION HAS BEEN CALCULATED FOR GHEISHA CALL CGHEI ELSE CALL SDPM ENDIF ENDIF C----------------------------------------------------------------------- C ETA INCIDENT ELSEIF ( ITYPE .EQ. 17 .OR. * (ITYPE .GE. 71 .AND. ITYPE .LE. 74) ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) 'NUCINT: ETA EKINL=',SNGL(EKINL), * ' ETOT=',ETOT IPBIN(KJ) = IPBIN(KJ) + 1 C DECAY OR INTERACTION FOR ETAS ? IF ( FDECAY ) THEN CALL ETADEC ELSE CURPAR(1) = 17.D0 ITYPE = 17 C FOR INTERACTION THE ENERGY MUST BE VERY HIGH C CALCULATE GAMMA, BETA AND ENERGY IN CENTER OF MASS ECM = SQRT( 2.D0 * PAMA(14) * PAMA(17) * GAMMA * + PAMA(14)**2 +PAMA(17)**2 ) GCM = (PAMA(17) * GAMMA + PAMA(14)) / ECM BETACM = SQRT( 1.D0 - 1.D0 / GCM**2 ) C HIGH ENERGY INTERACTION MODEL CALL SDPM ENDIF C----------------------------------------------------------------------- C STRANGE BARYON (LAMDA, SIGMA) INCIDENT ELSEIF ( (ITYPE .GE. 18 .AND. ITYPE .LE. 24) .OR. * (ITYPE .GE. 26 .AND. ITYPE .LE. 32) ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) 'NUCINT: SBAR EKINL=',SNGL(EKINL), * ' ETOT=',ETOT IHBIN(KJ) = IHBIN(KJ) + 1 C DECAY OR INTERACTION FOR STRANGE BARYONS? IF ( FDECAY ) THEN CALL STRDEC RETURN ENDIF C CALCULATE GAMMA, BETA AND ENERGY IN CENTER OF MASS ECM = SQRT( 2.D0 * PAMA(ITYPE) * PAMA(14) * GAMMA * + PAMA(ITYPE)**2 + PAMA(14)**2 ) GCM = ( PAMA(ITYPE) * GAMMA + PAMA(14)) / ECM BETACM = SQRT( 1.D0 - 1.D0 / GCM**2 ) C LOW ENERGY HADRONIC INTERACTIONS C CHECK IF WE USE LOW ENERGY HADRONIC INTERACTION MODEL IF ( USELOW ) THEN C USE GHEISHA IF THE CROSS-SECTION HAS BEEN CALCULATED FOR GHEISHA CALL CGHEI ELSE C VENUS TREATS STRANGE BARYONS CALL SDPM ENDIF C----------------------------------------------------------------------- C HEAVY PRIMARY INCIDENT ELSEIF ( ITYPE .GT. 100 ) THEN IF (DEBUG) WRITE(MDEBUG,*) 'NUCINT: HEAVY PRIMARY EKINL=', * SNGL(EKINL),' ETOT=',ETOT C USE GHEISHA IF THE CROSS-SECTION HAS BEEN CALCULATED FOR GHEISHA C CHECK IF WE USE LOW ENERGY HADRONIC INTERACTION MODEL IF ( USELOW ) THEN C USE GHEISHA IF THE CROSS-SECTION HAS BEEN CALCULATED FOR GHEISHA C (THIS MIGHT BE THE CASE FOR DEUTERONS, TRITONS AND ALPHAS) IF ( GHESIG ) THEN CALL CGHEI ELSE CALL SDPM ENDIF ELSE CALL SDPM ENDIF C----------------------------------------------------------------------- C ILLEGAL PARTICLE ELSE WRITE(MONIOU,444) (CURPAR(I),I=1,9) WRITE(MONIOU,*) 'NUCINT: ILLEGAL PARTICLE = ',ITYPE STOP ENDIF C----------------------------------------------------------------------- C KILL PARTICLE IRET1 = 1 RETURN END *CMZ : 27/02/2002 16.27.13 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE OUTEND C----------------------------------------------------------------------- C OUT(PUT AT) END (OF SHOWER) C C WRITE REST OF PARTICLES TO OUTPUT BUFFER C PRINTS INTERACTION LENGTHS STATISTICS C THIS SUBROUTINE IS CALLED FROM AAMAIN. C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,BUFFS. COMMON /BUFFS/ RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH INTEGER MAXBUF,MAXLEN PARAMETER (MAXLEN=16) PARAMETER (MAXBUF=39*7) REAL RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF), * RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF) INTEGER LH CHARACTER*4 CRUNH,CRUNE,CEVTH,CEVTE,CLONG EQUIVALENCE (RUNH(1),CRUNH), (RUNE(1),CRUNE) EQUIVALENCE (EVTH(1),CEVTH), (EVTE(1),CEVTE) EQUIVALENCE (ARRAYLONG(1),CLONG) *KEEP,CHISTA. COMMON /CHISTA/ IHYCHI,IKACHI,IMUCHI,INNCHI,INUCHI,IPICHI INTEGER IHYCHI(124),IKACHI(124),IMUCHI(124), * INNCHI(124),INUCHI(124),IPICHI(124) *KEEP,ELADPM. COMMON /ELADPM/ ELMEAN,ELMEAA,IELDPM,IELDPA DOUBLE PRECISION ELMEAN(40),ELMEAA(40) INTEGER IELDPM(40,13),IELDPA(40,13) *KEEP,MULT. COMMON /MULT/ EKINL,MSMM,MULTMA,MULTOT DOUBLE PRECISION EKINL INTEGER MSMM,MULTMA(40,13),MULTOT(40,13) *KEEP,NCOUNT. COMMON /NCOUNT/ NCOUN INTEGER NCOUN(8) *KEEP,NPARTI. COMMON /NPARTI/ NPARTO DOUBLE PRECISION NPARTO(10,25),NPHOTO(10),NPOSIT(10),NELECT(10), * NNU(10),NMUP(10),NMUM(10),NPI0(10),NPIP(10), * NPIM(10),NK0L(10),NKPL(10),NKMI(10),NNEUTR(10), * NPROTO(10),NPROTB(10),NK0S(10),NHYP(10), * NNEUTB(10),NDEUT(10),NTRIT(10),NALPHA(10), * NOTHER(10),NMUOND EQUIVALENCE (NPARTO(1, 1),NPHOTO(1)), (NPARTO(1, 2),NPOSIT(1)), * (NPARTO(1, 3),NELECT(1)), (NPARTO(1, 4),NNU(1)) , * (NPARTO(1, 5),NMUP(1)) , (NPARTO(1, 6),NMUM(1)) , * (NPARTO(1, 7),NPI0(1)) , (NPARTO(1, 8),NPIP(1)) , * (NPARTO(1, 9),NPIM(1)) , (NPARTO(1,10),NK0L(1)) , * (NPARTO(1,11),NKPL(1)) , (NPARTO(1,12),NKMI(1)) , * (NPARTO(1,13),NNEUTR(1)), (NPARTO(1,14),NPROTO(1)), * (NPARTO(1,15),NPROTB(1)), (NPARTO(1,16),NK0S(1)) , * (NPARTO(1,18),NHYP(1)) , (NPARTO(1,19),NDEUT(1)) , * (NPARTO(1,20),NTRIT(1)) , (NPARTO(1,21),NALPHA(1)), * (NPARTO(1,22),NOTHER(1)), (NPARTO(1,25),NNEUTB(1)), * (NPARTO(1,23),NMUOND) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,RECORD. COMMON /RECORD/ IRECOR INTEGER IRECOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,STACKF. COMMON /STACKF/ STACK,MSTACKP,MEXST,NSHIFT,NOUREC,ICOUNT, * NTO,NFROM INTEGER MAXSTK PARAMETER (MAXSTK = 16*256*2) DOUBLE PRECISION STACK(MAXSTK) INTEGER MSTACKP,MEXST,NSHIFT,NOUREC,ICOUNT,NTO,NFROM *KEEP,STATI. COMMON /STATI/ SABIN,SBBIN,INBIN,IPBIN,IKBIN,IHBIN DOUBLE PRECISION SABIN(40),SBBIN(40) INTEGER INBIN(40),IPBIN(40),IKBIN(40),IHBIN(40) *KEND. INTEGER I INTEGER J,K,NELMEA SAVE C----------------------------------------------------------------------- IF ( LH .GT. 0 ) THEN IF ( FPAROUT ) CALL TOBUF( DATAB,0 ) DO 2 I = 1,MAXBUF DATAB(I) = 0. 2 CONTINUE ENDIF LH = 0 IF ( FPRINT .OR. DEBUG ) THEN WRITE(MONIOU,101) NSHIFT,NOPART 101 FORMAT(' ',I10,' SHIFTS TO EXTERNAL STACK'/ * ' ',I10,' PARTICLES WRITTEN TO MPATAP') ENDIF IF ( FPRINT ) THEN C PRINT ENERGY - MULTIPLICITY MATRIX WRITE(MONIOU,209) ISHOWNO,(K,K=1,13), * (J,(MULTMA(J,K),K=1,13),10**((J-4.)/3.),10**((J-3.)/3.),J=1,39), * 1,(INT(10**((K-1.)/3.)+1 ),K = 2,13), * 2,(INT(10**((K )/3.) ),K = 2,13) 209 FORMAT(//' ENERGY - MULTIPLICITY MATRIX OF SHOWER NO ',I10/ * ' ENERGY RUNS VERTICALLY, MULTIPLICITY HORIZONTALLY'// * ' ',5X,5I10,3I8,5I6,' ENERGY RANGE (GEV)'/ * 39(/' ',I4,1X,5I10,3I8,5I6,2X,1P,2E10.1,0P)// * ' MULT.',5I10,3I8,5I6,5X,'LOWER BIN LIMIT'/ * ' RANGE',5I10,3I8,5I6,5X,'UPPER BIN LIMIT') ENDIF C GET MEAN OF ELASTICITY FOR ENERGY BINS DO 3377 J = 1,40 NELMEA = 0 DO 3378 K = 1,10 NELMEA = NELMEA + IELDPM(J,K) 3378 CONTINUE IF ( NELMEA .NE. 0 ) ELMEAN(J) = ELMEAN(J) / NELMEA 3377 CONTINUE IF ( FPRINT ) THEN C PRINT ENERGY - ELASTICITY MATRIX WRITE(MONIOU,408) ISHOWNO,(K,K=1,10), * (J,(IELDPM(J,K),K=1,10), * ELMEAN(J),10**((J-4.)/3.),10**((J-3.)/3.),J=1,39), * ((K-1)*0.1,K=1,10),(K*0.1,K=1,10) 408 FORMAT (//' ENERGY - ELASTICITY MATRIX OF SHOWER NO ',I10/ * ' ENERGY RUNS VERTICALLY, ELASTICITY HORIZONTALLY'// * ' ',5X,8I9,2I10,' MEAN EL. ENERGY RANGE (GEV)'/ * 39(/' ',I4,1X,8I9,2I10,2X,1P,E10.3,2E10.1,0P)// * ' ELA. ',8F9.2,2F10.2,5X,'LOWER BIN LIMIT'/ * ' RANGE',8F9.2,2F10.2,5X,'UPPER BIN LIMIT') WRITE(MONIOU,204) ISHOWNO 204 FORMAT(//' INTERACTIONS PER KINETIC ENERGY INTERVAL OF SHOWER', * ' NO ',I10//) WRITE(MONIOU,205) 205 FORMAT(' BIN LOWER LIMIT UPPER LIMIT ', * ' NUCLEON PIONS KAONS S.BARYONS TOTAL'/ * ' IN GEV IN GEV ', * ' EVENTS EVENTS EVENTS EVENTS '/) WRITE(MONIOU,207) (I,SABIN(I),SBBIN(I),INBIN(I),IPBIN(I), * IKBIN(I),IHBIN(I),INBIN(I)+IPBIN(I)+IKBIN(I)+IHBIN(I),I=1,40) 207 FORMAT(' ',I5,1P,2E15.4,0P,1X,5I11) WRITE(MONIOU,301) 301 FORMAT (//' INTERACTION LENGTH STATISTICS: ', * ' 1 BIN CORRESPONDS TO 10 G/CM**2 OR 100M FOR MUONS'// * ' BIN LAMBDA NU LAMBDA PI LAMBDA KA ', * 'LAMBDA HY LAMBDA MU LAMBDA NUCLEUS'/) WRITE(MONIOU,303) (I,INUCHI(I),IPICHI(I),IKACHI(I),IHYCHI(I), * IMUCHI(I),INNCHI(I),I=1,124) 303 FORMAT (' ',I4,6I12) WRITE(MONIOU,105) IRECOR 105 FORMAT (/' NO OF WORDS WRITTEN TO PARTICLE TAPE UP TO NOW =', * I10) ENDIF RETURN END *CMZ : 28/02/2002 13.08.19 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE OUTPT1 C----------------------------------------------------------------------- C (WRITE PARTICLE) OUTP(U)T 1 C C WRITES 39 PARTICLE RECORDS PER PHYSICAL RECORD C TABULATES PARAMETERS OF ALL HIGH ENERGY PARTICLES WITH C LORENTZ FACTOR LARGER THAN ECTMAP C THIS SUBROUTINE IS CALLED FROM AAMAIN, BOX3, MUTRAC, UPDATC, C AND AUSGAB. C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,BUFFS. COMMON /BUFFS/ RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH INTEGER MAXBUF,MAXLEN PARAMETER (MAXLEN=16) PARAMETER (MAXBUF=39*7) REAL RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF), * RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF) INTEGER LH CHARACTER*4 CRUNH,CRUNE,CEVTH,CEVTE,CLONG EQUIVALENCE (RUNH(1),CRUNH), (RUNE(1),CRUNE) EQUIVALENCE (EVTH(1),CEVTH), (EVTE(1),CEVTE) EQUIVALENCE (ARRAYLONG(1),CLONG) *KEEP,ETHMAP. COMMON /ETHMAP/ ECTMAP,ELEFT DOUBLE PRECISION ECTMAP,ELEFT *KEEP,LONGI. COMMON /LONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG, * SDLONG,SELONG,SPLONG,THSTEP,THSTPI, * LHEIGH,NSTEP,LLONGI,FLGFIT DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9), * APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9), * HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9), * SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI INTEGER LHEIGH,NSTEP LOGICAL LLONGI,FLGFIT *KEEP,MAGANG. COMMON /MAGANG/ ARRANG,ARRANR,COSANG,SINANG DOUBLE PRECISION ARRANG,ARRANR,COSANG,SINANG *KEEP,MULT. COMMON /MULT/ EKINL,MSMM,MULTMA,MULTOT DOUBLE PRECISION EKINL INTEGER MSMM,MULTMA(40,13),MULTOT(40,13) *KEEP,MUPART. COMMON /MUPART/ AMUPAR,BCUT,CMUON,FMUBRM,FMUORG DOUBLE PRECISION AMUPAR(16),BCUT,CMUON(11) LOGICAL FMUBRM,FMUORG *KEEP,NPARTI. COMMON /NPARTI/ NPARTO DOUBLE PRECISION NPARTO(10,25),NPHOTO(10),NPOSIT(10),NELECT(10), * NNU(10),NMUP(10),NMUM(10),NPI0(10),NPIP(10), * NPIM(10),NK0L(10),NKPL(10),NKMI(10),NNEUTR(10), * NPROTO(10),NPROTB(10),NK0S(10),NHYP(10), * NNEUTB(10),NDEUT(10),NTRIT(10),NALPHA(10), * NOTHER(10),NMUOND EQUIVALENCE (NPARTO(1, 1),NPHOTO(1)), (NPARTO(1, 2),NPOSIT(1)), * (NPARTO(1, 3),NELECT(1)), (NPARTO(1, 4),NNU(1)) , * (NPARTO(1, 5),NMUP(1)) , (NPARTO(1, 6),NMUM(1)) , * (NPARTO(1, 7),NPI0(1)) , (NPARTO(1, 8),NPIP(1)) , * (NPARTO(1, 9),NPIM(1)) , (NPARTO(1,10),NK0L(1)) , * (NPARTO(1,11),NKPL(1)) , (NPARTO(1,12),NKMI(1)) , * (NPARTO(1,13),NNEUTR(1)), (NPARTO(1,14),NPROTO(1)), * (NPARTO(1,15),NPROTB(1)), (NPARTO(1,16),NK0S(1)) , * (NPARTO(1,18),NHYP(1)) , (NPARTO(1,19),NDEUT(1)) , * (NPARTO(1,20),NTRIT(1)) , (NPARTO(1,21),NALPHA(1)), * (NPARTO(1,22),NOTHER(1)), (NPARTO(1,25),NNEUTB(1)), * (NPARTO(1,23),NMUOND) *KEEP,OBSPAR. COMMON /OBSPAR/ OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP, * THETPR,PHIPR, * VUECON, * NOBSLV DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10), * HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2) DOUBLE PRECISION VUECON(2) INTEGER NOBSLV *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,TABLES. INTEGER IEBIN, ITBIN, IDBIN PARAMETER (IEBIN=40,ITBIN=30,IDBIN=20) COMMON /TABLES/ G_ARRAY, E_ARRAY, M_ARRAY, * EBOFF,EBFAC,TBOFF,TBFAC,DBOFF,DBFAC REAL G_ARRAY(IEBIN,ITBIN,IDBIN) REAL E_ARRAY(IEBIN,ITBIN,IDBIN) REAL M_ARRAY(IEBIN,ITBIN,IDBIN) REAL EBOFF,EBFAC,TBOFF,TBFAC,DBOFF,DBFAC REAL EBMIN,EBMAX,TBMIN,TBMAX,DBMIN,DBMAX PARAMETER (EBMIN=1.E-4,EBMAX=1.E4) PARAMETER (TBMIN=10.,TBMAX=1.E4) PARAMETER (DBMIN=5.E3,DBMAX=5.E5) *KEND. DOUBLE PRECISION AUGM,ETOT,PTOT,STT,XADDMU,YADDMU REAL EE,TT,RR,TF INTEGER IIE,IIT,IID INTEGER I,IGG,III,NCOUNT LOGICAL ROUT SAVE DATA NCOUNT /0/,AUGM/1.D0/ C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,444) (OUTPAR(I),I=1,9),LEVL 444 FORMAT(' OUTPT1: OUTPAR=',1P,8E10.3,0P,F10.0,I5) C PRINT OUT PARTICLE IF IT IS ABOVE THE CUT IF ( FPRINT .OR. DEBUG .OR. DEBDEL ) THEN IF ( OUTPAR(2) .GE. ECTMAP ) THEN WRITE(MONIOU,3) (OUTPAR(I),I=1,10),ELEFT 3 FORMAT(' OUTPT1: ',1P,8E10.3,0P,F6.0,1P,2E10.3) IF ( DEBDEL ) THEN NCOUNT = NCOUNT + 1 WRITE(MDEBUG,*) 'OUTPT1: NCOUNT = ',NCOUNT IF ( NCOUNT .GE. NDEBDL ) DEBUG = .TRUE. IF ( NCOUNT .GE. NDEBDL+2 ) DEBUG = .FALSE. ENDIF ENDIF ENDIF C COUNT PARTICLES SPECIFIED BY THEIR PARTICLE CODE < 25 III = NINT(OUTPAR(1)) IF ( III .LT. 18 ) THEN NPARTO(LEVL,III) = NPARTO(LEVL,III) + AUGM ELSEIF ( III .EQ. 25 ) THEN NNEUTB(LEVL) = NNEUTB(LEVL) + AUGM ELSEIF ( (III .GE. 18 .AND. III .LE. 24) .OR. * (III .GE. 26 .AND. III .LE. 32) ) THEN NHYP(LEVL) = NHYP(LEVL) + AUGM ELSEIF ( III .EQ. 201 ) THEN NDEUT(LEVL) = NDEUT(LEVL) + AUGM ELSEIF ( III .EQ. 301 ) THEN NTRIT(LEVL) = NTRIT(LEVL) + AUGM ELSEIF ( III .EQ. 402 ) THEN NALPHA(LEVL) = NALPHA(LEVL) + AUGM ELSE WRITE(MONIOU,*) 'OUTPT1: PARTICLE ON OBSLEV ',LEVL,' ID= ',III NOTHER(LEVL) = NOTHER(LEVL) + AUGM ENDIF IF ( LLONGI .AND. LEVL.EQ.NOBSLV ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IN LAST BIN NSTEP LHEIGH = NSTEP IF ( III .EQ. 1 ) THEN DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + OUTPAR(2) * AUGM ELSEIF ( III .EQ. 2 ) THEN C REMEMBER: FOR EM-PARTICLES OUTPAR(2) CONTAINS ENERGY IN GEV DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + (OUTPAR(2)+PAMA(2))*AUGM ELSEIF ( III .EQ. 3 ) THEN DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + (OUTPAR(2)-PAMA(2))*AUGM ELSEIF ( III .EQ. 5 .OR. III .EQ. 6 ) THEN DLONG(LHEIGH,5) = DLONG(LHEIGH,5) * + OUTPAR(2)*PAMA(5)*AUGM ELSEIF ( III .EQ. 13 .AND. III .EQ. 14 ) THEN DLONG(LHEIGH,7) = DLONG(LHEIGH,7) * + (OUTPAR(2)-1.D0)*PAMA(III)*AUGM ELSEIF ( III .EQ. 15 .AND. III .EQ. 25 ) THEN DLONG(LHEIGH,7) = DLONG(LHEIGH,7) * + (OUTPAR(2)+1.D0)*PAMA(III)*AUGM ELSE DLONG(LHEIGH,7) = DLONG(LHEIGH,7) * + OUTPAR(2)*PAMA(III)*AUGM ENDIF ENDIF ROUT = .TRUE. C TREATE ADDITIONAL INFORMATION OF MUONS C THE COORDINATES OF MUON ORIGIN ARE STORED IN AMUPAR(.) IF ( ROUT ) THEN IF ( FMUADD .AND. (III .EQ. 5 .OR. III .EQ. 6) ) THEN IGG = MIN( OUTPAR(9), 99.D0 ) DATAB(LH+1) = (III + 70) * 1000 + IGG*10 + MOD(LEVL,10) PTOT = PAMA(III) * SQRT( AMUPAR(2)**2 - 1.D0 ) DATAB(LH+4) = PTOT * AMUPAR(15) XADDMU = AMUPAR(7) YADDMU = AMUPAR(8) STT = SQRT( 1.D0 - AMUPAR(15)**2 ) DATAB(LH+2) = PTOT * STT * COS( AMUPAR(4) + ARRANR ) DATAB(LH+3) = PTOT * STT * SIN( AMUPAR(4) + ARRANR ) DATAB(LH+5) = XADDMU * COSANG + YADDMU * SINANG DATAB(LH+6) = YADDMU * COSANG - XADDMU * SINANG DATAB(LH+7) = AMUPAR(5) IF ( DEBUG ) WRITE(MDEBUG,445) (DATAB(LH+I),I=1,7) 445 FORMAT(' OUTPT1: MUADDI=',1P,7E10.3) LH = LH + 7 C WRITE A BLOCK OF 39 PARTICLES TO OUTPUT BUFFER AND CLEAR FIELD IF ( LH .GE. MAXBUF ) THEN IF ( FPAROUT ) CALL TOBUF( DATAB,0 ) DO 1 I = 1,MAXBUF DATAB(I) = 0. 1 CONTINUE LH = 0 ENDIF ENDIF C COPY PARTICLE TO DATAB FIELD IGG = MIN( OUTPAR(9), 99.D0 ) DATAB(LH+1) = III*1000 + IGG*10 + MOD(LEVL,10) IF ( OUTPAR(1) .LE. 3.D0 ) THEN ETOT = OUTPAR(2) ELSE ETOT = PAMA(III) * OUTPAR(2) ENDIF PTOT = SQRT( ETOT**2 - PAMA(III)**2 ) STT = SQRT( 1.D0 - OUTPAR(3)**2 ) DATAB(LH+2) = PTOT * STT * COS( OUTPAR(4) + ARRANR ) DATAB(LH+3) = PTOT * STT * SIN( OUTPAR(4) + ARRANR ) DATAB(LH+4) = PTOT * OUTPAR(3) DATAB(LH+5) = OUTPAR(7) * COSANG + OUTPAR(8) * SINANG DATAB(LH+6) = OUTPAR(8) * COSANG - OUTPAR(7) * SINANG DATAB(LH+7) = OUTPAR(6) * 1.E9 ENDIF IF ( FTABOUT ) THEN C CALCULATE TIME DELAY (IN NS) WITH RESPECT TO SPHERICAL SHOWER C FRONT AT POINT (X,Y) TF = SQRT( (HEIGHP- OBSLEV(LEVL))**2 + * (OUTPAR(7)+XOFF(LEVL))**2 + * (OUTPAR(8)+YOFF(LEVL))**2 ) / (C(25)*1.D-9) TT = OUTPAR(6)*1.D9 - TF IF ( OUTPAR(1) .LE. 3.D0 ) THEN ETOT = OUTPAR(2) ELSE ETOT = PAMA(III) * OUTPAR(2) ENDIF EE = ETOT RR = SQRT(OUTPAR(7)**2 + OUTPAR(8)**2) EE = MAX(EBMIN,EE) TT = MAX(TBMIN,TT) RR = MAX(DBMIN,RR) C GET CORRECT BIN IIE = (LOG10(EE) - EBOFF)*EBFAC + 1. IIT = (LOG10(TT) - TBOFF)*TBFAC + 1. IID = (LOG10(RR) - DBOFF)*DBFAC + 1. IIE = MIN(IIE,IEBIN) IIE = MAX(IIE,1) IIT = MIN(IIT,ITBIN) IIT = MAX(IIT,1) IID = MIN(IID,IDBIN) IID = MAX(IID,1) IF ( III .EQ. 1 ) THEN G_ARRAY(IIE,IIT,IID) = G_ARRAY(IIE,IIT,IID) + AUGM ELSEIF ( III .LE. 3 ) THEN E_ARRAY(IIE,IIT,IID) = E_ARRAY(IIE,IIT,IID) + AUGM ELSEIF ( III .EQ. 5 .OR. III .EQ. 6 ) THEN M_ARRAY(IIE,IIT,IID) = M_ARRAY(IIE,IIT,IID) + AUGM ENDIF ENDIF C WRITE A BLOCK OF 39 PARTICLES TO OUTPUT BUFFER AND CLEAR FIELD IF ( ROUT ) THEN C COUNT PARTICLES, THAT ARE WRITTEN TO TAPE NOPART = NOPART + 1 LH = LH + 7 C WRITE A BLOCK OF 39 PARTICLES TO OUTPUT BUFFER AND CLEAR FIELD IF ( LH .GE. MAXBUF ) THEN IF ( FPAROUT ) CALL TOBUF( DATAB,0 ) DO 2 I = 1,MAXBUF DATAB(I) = 0. 2 CONTINUE LH = 0 ENDIF ENDIF RETURN END *CMZ : 25/02/2002 15.28.14 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE PAMAF C----------------------------------------------------------------------- C PA(RTICLE) MA(SS) F(ILLING) C C FILLS PARTICLE MASS FOR PARTICLE IP IN ARRAY PAMA C RESONANCES AND STRANGE BARYONS INCLUDED C PARTICLE MASSES ACCORDING TO GEANT TABLE, C TAKEN FROM THE PERIODIC TABLE C OR CALCULATED WITH THE MASS FORMULA OF WEIZSAECKER C THIS SUBROUTINE IS CALLED FROM START. C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEND. DOUBLE PRECISION CHARGE(75),MASSES(75) C* DOUBLE PRECISION AMUS(59,14),BIND,B1,B2,B3,B4,B5,SS INTEGER IA,IC,IN,IP C* INTEGER I,L SAVE C----------------------------------------------------------------------- C MASSES REVISED SEPT 2000 BY D. HECK DATA MASSES / * 0.D0 ,.510998902D-3,.510998902D-3, 0.0D0 ,.105658357D0, * .105658357D0, .1349766D0, .13957018D0,.13957018D0 , 0.497672D0 , * 0.493677D0 , 0.493677D0 ,.93956533D0 ,.93827200D0 ,.93827200D0 , * 0.497672D0 , 0.54730D0 , 1.115683D0 , 1.18937D0 , 1.192642D0 , * 1.197449D0 , 1.31483D0 , 1.32131D0 , 1.67245D0 ,.93956533D0 , * 1.115683D0 , 1.18937D0 , 1.192642D0 , 1.197449D0 , 1.31483D0 , * 1.32131D0 , 1.67245D0 , 1.7841D0 , 1.7841D0 , 1.8693D0 , * 1.8693D0 , 1.8645D0 , 1.8645D0 , 1.9693D0 , 1.9693D0 , * 2.2852D0 , 80.6D0 , 80.6D0 , 91.161D0 , 1.877D0 , * 2.817D0 , 3.755D0 , 0.0D0 , 0.0D0 , 0.78257D0 , * 0.7690D0 , 0.7665D0 , 0.7665D0 , 1.2305D0 , 1.2318D0 , * 1.2331D0 , 1.2344D0 , 1.2309D0 , 1.2323D0 , 1.2336D0 , * 1.2349D0 , 0.89610D0 , 0.89166D0 , 0.89166D0 , 0.89610D0 , * 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , 0.0D0 , * 0.54730D0 , 0.54730D0 , 0.54730D0 , 0.54730D0 , 0.0D0 / DATA CHARGE / * 0.D0,+1.D0,-1.D0, 0.D0,+1.D0,-1.D0, 0.D0,+1.D0,-1.D0, 0.D0, * +1.D0,-1.D0, 0.D0,+1.D0,-1.D0, 0.D0, 0.D0, 0.D0,+1.D0, 0.D0, * -1.D0, 0.D0,-1.D0,-1.D0, 0.D0, 0.D0,-1.D0, 0.D0,+1.D0, 0.D0, * +1.D0,+1.D0,+1.D0,-1.D0,+1.D0,-1.D0, 0.D0, 0.D0,+1.D0,-1.D0, * +1.D0,+1.D0,-1.D0, 0.D0,+1.D0,+1.D0,+2.D0, 0.D0, 0.D0, 0.D0, * 0.D0,+1.D0,-1.D0,+2.D0,+1.D0, 0.D0,-1.D0,-2.D0,-1.D0, 0.D0, * +1.D0, 0.D0,+1.D0,-1.D0, 0.D0, 0.D0, 0.D0, 0.D0, 0.D0, 0.D0, * 0.D0, 0.D0, 0.D0, 0.D0, 0.D0 / C ISOTOPE MASSES CALCULATED FROM: ATOMIC DATA AND NUCL.DATA TABLES 39 C (1988) 289, (WAPSTRA'S VALUES, CORRECTED FOR ELECTRON MASSES) C* DATA ((AMUS(I,L),I=1,59),L=1,7) / C* * 1.8756D0, 2.8089D0, 57*0.D0, C* * 2.8083D0, 3.7273D0, 4.6678D0, 5.6054D0, 6.5454D0, 54*0.D0, C* * 2*0.D0 , 5.6014D0, 6.5337D0, 7.4712D0, 8.4067D0, C* * 9.3471D0, 10.2856D0, 51*0.D0, C* * 2*0.D0 , 6.5341D0, 7.4547D0, 8.3926D0, 9.3253D0, C* * 10.2644D0, 11.2008D0, 51*0.D0, C* * 2*0.D0 , 7.4722D0, 8.3932D0, 9.3243D0, 10.2524D0, C* * 11.1886D0, 12.1232D0, 13.0618D0, 13.9986D0, 49*0.D0, C* * 2*0.D0 , 8.4091D0, 9.3274D0, 10.2538D0, 11.1747D0, 12.1093D0, C* * 13.0406D0, 13.9790D0, 14.9143D0, 15.8531D0, 48*0.D0, C* * 4*0.D0 , 11.1915D0, 12.1110D0, 13.0400D0, 13.9687D0, 14.9057D0, C* * 15.8394D0, 16.7761D0, 17.7104D0, 47*0.D0/ C* DATA ((AMUS(I,L),I=1,59),L=8,14) / C* * 4*0.D0, 12.1282D0, 13.0446D0, 13.9709D0, 14.8948D0, 15.8302D0, C* * 16.7617D0, 17.6973D0, 18.6293D0, 19.5650D0, 46*0.D0, C* * 7*0.D0, 15.8325D0, 16.7629D0, 17.6920D0, 18.6429D0, 19.5564D0, C* * 20.4907D0, 21.4227D0, 22.3587D0, 44*0.D0, C* * 6*0.D0, 15.8464D0, 16.7668D0, 17.6947D0, 18.6174D0, 19.5502D0, C* * 20.4794D0, 21.4137D0, 22.3444D0, 23.2839D0, 24.2138D0, 43*0.D0, C* * 8*0.D0, 18.6308D0, 19.5532D0, 20.4817D0, 21.4088D0, 22.3414D0, C* * 23.2720D0, 24.2059D0, 25.1387D0, 26.0746D0, 27.0099D0, C* * 27.9469D0, 28.8820D0, 29.8173D0, 30.7546D0, 31.6913D0, 36*0.D0, C* * 7*0.D0, 18.6410D0, 19.5658D0, 20.4860D0, 21.4124D0, 22.3354D0, C* * 23.2676D0, 24.1961D0, 25.1292D0, 26.0602D0, 26.9961D0, C* * 27.9291D0, 28.8660D0, 29.7994D0, 30.7376D0, 38*0.D0, C* * 9*0.D0, 21.4241D0, 22.3488D0, 23.2714D0, 24.1996D0, 25.1261D0, C* * 26.0579D0, 26.9880D0, 27.9218D0, 28.8541D0, 29.7894D0, C* * 30.7233D0, 31.6599D0, 32.5944D0, 33.5316D0, 36*0.D0, C* * 9*0.D0, 22.3591D0, 23.2836D0, 24.2041D0, 25.1304D0, 26.0527D0, C* * 26.9838D0, 27.9128D0, 28.8457D0, 29.7761D0, 30.7111D0, C* * 31.6431D0, 32.5803D0, 33.5128D0, 34.4505D0, 35.3837D0, 35*0.D0/ C----------------------------------------------------------------------- C GEANT PARTICLES INCLUDING RHO, K*, AND DELTA DO 1 IP = 1,75 PAMA (IP) = MASSES(IP) SIGNUM(IP) = CHARGE(IP) 1 CONTINUE C RESET REST OF THE ARRAY DO 2 IP = 76,6000 PAMA (IP) = 0.D0 SIGNUM(IP) = 0.D0 2 CONTINUE DO 3 IA = 1,59 DO 3 IC = 1,IA IN = IA - IC IP = IA * 100 + IC C* IF ( IC .LE. 14 ) THEN C MASSES FROM MASS TABLE FOR ISOTOPES C* IF ( IN .EQ. 0 ) THEN C* PAMA(IP) = IC * PAMA(14) C* ELSE C* PAMA(IP) = AMUS(IN,IC) C* ENDIF C SIMPLE SUM OF PROTON AND NEUTRON MASSES C* IF ( PAMA(IP) .EQ. 0.D0 ) C* * PAMA(IP) = IC * PAMA(14) + IN * PAMA(13) C* ELSE C WEIZSAECKERS MASS FORMULA GIVES BINDING ENERGY IN MEV C* B1 = 14.1D0 * IA C* B2 = (-13.D0) * IA**TB3 C* B3 = (-0.595D0) * IC**2 / IA**OB3 C* B4 = (-19.D0) * (IC-IN)**2 / IA C* B5 = 33.5D0 / IA**0.75D0 C* IF ( MOD(IC,2) .EQ. 0 .AND. MOD(IN,2) .EQ. 0 ) THEN C* SS = 1.D0 C* ELSEIF ( MOD(IC,2) .EQ. 1 .AND. MOD(IN,2) .EQ. 1 ) THEN C* SS = -1.D0 C* ELSE C* SS = 0.D0 C* ENDIF C* BIND = (B1 + B2 + B3 + B4 + SS*B5)* 1.D-3 C* BIND = MAX( 0.D0, BIND ) C* PAMA(IP) = IN * MASSES(13) + IC * MASSES(14) - BIND C* ENDIF C DO NOT USE BINDING ENERGY EFFECTS PAMA(IP) = IN * MASSES(13) + IC * MASSES(14) C NUCLEI ARE ASSUMED TO BE FULLY IONIZED SIGNUM(IP) = +IC 3 CONTINUE C MASSES OF MULTINEUTRON CLUSTERS DO 4 IN = 1,59 IP = 100 * IN PAMA (IP) = IN * PAMA(13) SIGNUM(IP) = 0.D0 4 CONTINUE C REST MASS OF LIGHT NUCLEI (DEUTERIUM, TRITIUM, ALPHA) RESTMS(201) = RESTMS(13) + RESTMS(14) RESTMS(301) = 2.D0 * RESTMS(13) + RESTMS(14) RESTMS(402) = 2.D0 * RESTMS(13) + 2.D0 * RESTMS(14) RETURN END *CMZ : 25/09/2000 16.46.23 by D. HECK IK3 FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE PI0DEC C----------------------------------------------------------------------- C PI 0 DEC(AY) C C DECAY OF PI0 INTO 2 GAMMAS OR INTO E(+) + E(-) + GAMMA C THIS SUBROUTINE IS CALLED FROM NUCINT. C C DESIGN : D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,DECAY. COMMON /DECAY/ GAM345,COS345,PHI345 DOUBLE PRECISION GAM345(3),COS345(3),PHI345(3) *KEEP,GENER. COMMON /GENER/ GEN,ALEVEL DOUBLE PRECISION GEN,ALEVEL *KEEP,LONGI. COMMON /LONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG, * SDLONG,SELONG,SPLONG,THSTEP,THSTPI, * LHEIGH,NSTEP,LLONGI,FLGFIT DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9), * APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9), * HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9), * SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI INTEGER LHEIGH,NSTEP LOGICAL LLONGI,FLGFIT *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DOUBLE PRECISION AUX1,AUX2,COSTH1,COSTH2,EPITO2,FI1 INTEGER I SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=1,9) 444 FORMAT(' PI0DEC: CURPAR=',1P,9E10.3) C LOOK FOR DECAY MODE CALL RMMAR (RD,3,1) C DECAY PI(0) ----> GAMMA + GAMMA IF ( RD(3) .LT. 0.98798 ) THEN C HALF OF TOTAL ENERGY OF THE PION = EPITO2 EPITO2 = 0.5D0 * GAMMA * PAMA(7) AUX1 = 1.D0 + BETA * RD(1) AUX2 = 1.D0 - BETA * RD(1) COSTH1 = (BETA + RD(1)) / AUX1 COSTH2 = (BETA - RD(1)) / AUX2 C FIRST GAMMA (WITH HIGHER ENERGY) FI1 = PI2 * RD(2) C ENERGY OF GAMMA SECPAR(2) = AUX1 * EPITO2 CALL ADDANG( COSTHE,PHI, COSTH1,FI1, SECPAR(3),SECPAR(4) ) IF ( SECPAR(3) .GT. C(29) ) THEN SECPAR(1) = 1.D0 CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + SECPAR(2) ENDIF ENDIF C SECOND GAMMA (WITH LOWER ENERGY) C ENERGY OF GAMMA SECPAR(2) = AUX2 * EPITO2 CALL ADDANG( COSTHE,PHI, COSTH2,FI1+PI, SECPAR(3),SECPAR(4) ) IF ( SECPAR(3) .GT. C(29) ) THEN SECPAR(1) = 1.D0 CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + SECPAR(2) ENDIF ENDIF C DECAY PI(0) ----> E(-) + E(+) + GAMMA (DALITZ DECAY) C (UNIFORM PHASE SPACE DISTRIBUTION IS ASSUMED FOR THIS DECAY) ELSE CALL DECAY6( PAMA(7), PAMA(2), PAMA(2), 0.D0, * 0.D0,0.D0,0.D0, 1.D0, 2) DO 11 I = 1,3 CALL ADDANG( COSTHE,PHI, COS345(I),PHI345(I), * SECPAR(3),SECPAR(4) ) IF ( SECPAR(3) .GT. C(29) ) THEN SECPAR(1) = FLOAT(4 - I) SECPAR(2) = GAM345(I) CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( I .EQ. 1 ) THEN DLONG(LHEIGH,3)=DLONG(LHEIGH,3)+(GAM345(I)-1.D0)*PAMA(2) ELSEIF ( I .EQ. 2 ) THEN DLONG(LHEIGH,3)=DLONG(LHEIGH,3)+(GAM345(I)+1.D0)*PAMA(2) ELSE DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + GAM345(I) ENDIF ENDIF ENDIF 11 CONTINUE ENDIF RETURN END *CMZ : 01/03/2002 11.13.53 by D. HECK IK FZK KARLSRUHE *-- Author : F. SCHROEDER UNI WUPPERTAL 17/09/98 C======================================================================= SUBROUTINE PRANGC(ARG,FLAGMU,HNEW) C----------------------------------------------------------------------- C (DECAYING) P(ARTICLE'S) RANG(E IN A) C(URVED ATMOSPHERE) C C DETERMINES MEAN FREE PATH FOR DECAYING PARTICLES IN CURVED C ATMOSPHERE INCLUDING IONIZATION ENERGY LOSS PRECISELY. C CALCULATE TOTAL PATH LENGTH FOR MUONS. C THIS SUBROUTINE IS CALLED FROM BOX2. C ARGUMENTS: C ARG = -LOG(RANDOM NUMBER) * SPEED OF LIGHT * LIFETIME C FLAGMU = MUON FLAG (T FOR MUONS, F ELSE) C HNEW = HEIGHT AFTER TOTAL STEP LENGTH C C DESIGN : F. SCHROEDER UNI WUPPERTAL C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,AIR. COMMON /AIR/ COMPOS,PROBTA,AVERAW,AVOGAD DOUBLE PRECISION COMPOS(3),PROBTA(3),AVERAW,AVOGAD *KEEP,ATMOS. COMMON /ATMOS/ AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM DOUBLE PRECISION AATM(5),AATM0(5,0:16),BATM(5),BATM0(5,0:16), * CATM(5),CATM0(5,0:16),DATM(5) INTEGER MODATM *KEEP,ATMOS2. COMMON /ATMOS2/ HLAY,HLAY0,THICKL,LAYNO,LAYNEW DOUBLE PRECISION HLAY(6),HLAY0(5,0:4),THICKL(5) INTEGER LAYNO(0:16) LOGICAL LAYNEW *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,MUMULT. COMMON /MUMULT/ CHC,OMC,PHISCT,STEPL,VSCAT,FMOLI DOUBLE PRECISION CHC,OMC,PHISCT,STEPL,VSCAT LOGICAL FMOLI *KEEP,OBSPAR. COMMON /OBSPAR/ OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP, * THETPR,PHIPR, * VUECON, * NOBSLV DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10), * HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2) DOUBLE PRECISION VUECON(2) INTEGER NOBSLV *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DOUBLE PRECISION AK,ARG,ARG0,ARGNEW,AUXIL,BETANEW,BK,CHIT,CHIT2, * COSDIF,COSPHI,COSTAPNEW,COSTHENEW,DISTN2,DISTO2, * DK,DL,ELOSS,GAMK,GAMNEW,GAMSQ,GAM0,GMSQM1, * HEIGH,HNEW,HOLD,H0,RADIUS,SIGNE,SINPHI,SINTHENEW, * TH0,THICK,THNEW,THOLD,TRANS,TRANSNEW,XNEW,YNEW INTEGER ILAY LOGICAL FLAGMU SAVE EXTERNAL HEIGH,THICK C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,444) ARG,THICKH 444 FORMAT(' PRANGC: -LOG(RD)*C*TAU = ',1P,E10.3,' THICKH=',E10.3) C START VALUES CHI = 0.D0 HNEW = H GAM0 = GAMMA TH0 = THICKH XNEW = X YNEW = Y BETANEW = BETA COSTHENEW = COSTHE COSTAPNEW = COSTAP STEPL = 0.D0 COSPHI = COS(PHI) SINPHI = SIN(PHI) DISTN2 = XNEW**2 + YNEW**2 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C LOOP OVER PIECES OF ARG (EACH IN ITS LOCAL FLAT COORDINATE FRAME) 1 CONTINUE C STORE OLD VALUE OF THICKNESS THOLD = TH0 SINTHENEW = SQRT( MAX( 1.D0-COSTHENEW**2, 0.D0 ) ) C CALCULATE UPPER LIMIT FOR TRANSVERSAL LENGTH (IMPORTANT TO DO A CUT, C 'UPPER LIMIT' BECAUSE GAM0 BECOMES SMALLER DUE TO IONISATION LOSS) AUXIL = GAM0 * BETANEW * SINTHENEW TRANS = ARG * AUXIL C MAXIMAL HORIZONTAL STEP (DEPENDS ON THICKNESS AT PARTICLE ALTITUDE) TRANSNEW = MIN( TRANS, C(4) * THOLD + C(3) ) IF ( SINTHENEW .EQ. 0.D0 ) THEN C STEP IN VERTICAL DIRECTION ARGNEW = ARG ELSE ARGNEW = TRANSNEW / AUXIL ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'PRANGC: TH0,ARGNEW,TRANSNEW=', * SNGL(TH0),SNGL(ARGNEW),SNGL(TRANSNEW) C LOOK WITHIN WHICH LAYER THE PARTICLE STARTS IF ( HNEW .LE. HLAY(2) ) THEN ILAY = 1 ELSEIF ( HNEW .LE. HLAY(3) ) THEN ILAY = 2 ELSEIF ( HNEW .LE. HLAY(4) ) THEN ILAY = 3 ELSE ILAY = 4 TH0 = MAX( TH0, THICKL(5) ) ENDIF C SET START VALUES FOR ITERATION OVER THE AIR LAYERS ARG0 = ARGNEW CHIT = 0.D0 H0 = HNEW C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 2 CONTINUE GAM0 = MAX( GAM0, 1.0001D0 ) GAMSQ = GAM0**2 GMSQM1 = GAMSQ - 1.D0 C ENERGY LOSS BY IONIZATION ELOSS = SIGNUM(ITYPE)**2 * C(22) * * ( GAMSQ * (LOG(GMSQM1) + C(23)) / GMSQM1 - 1.D0 ) ELOSS = ELOSS / (PAMA(ITYPE) * COSTHENEW ) BK = ELOSS * (TH0 - AATM(ILAY)) DK = GAM0 + BK AK = ARG0 * DK * COSTHENEW * DATM(ILAY) IF ( AK .GT. 0.D0 ) THEN IF ( AK .LT. 174.D0 ) THEN C LIMIT FOR EXPONENT (ON IBM COMPUTER) GAMNEW = MAX( GAM0 * DK / ( GAM0 + BK * EXP(AK) ), 1.0001D0 ) ELSE GAMNEW = 1.0001D0 ENDIF GAMK = GAM0 - ELOSS * ( THICKL(ILAY) - TH0) ELSE GAMK = 1.D0 GAMNEW = 1.0001D0 ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'PRANGC: GAMNEW,GAMK=', * SNGL(GAMNEW),SNGL(GAMK) C LOOK WETHER PARTICLE PENETRATES LAYER BOUNDARY OR DECAYS BEFORE IF ( GAMNEW .LT. GAMK .AND. ILAY. GT. 1 ) THEN C CALCULATE PORTION OF RANGE AND NEW START VALUES AT LAYER BOUNDARY ARG0 = ARG0 - ( H0 - HLAY(ILAY) + CATM(ILAY) * LOG(GAM0/GAMK) ) * / (DK * COSTHENEW) CHIT = CHIT + (THICKL(ILAY) - TH0) / COSTHENEW IF ( FLAGMU ) STEPL = STEPL + (H0 - HLAY(ILAY))/COSTHENEW GAM0 = GAMK H0 = HLAY(ILAY) TH0 = THICKL(ILAY) ILAY = ILAY - 1 GOTO 2 ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C PENETRATED MATTER THICKNESS CHIT2 = (GAM0 - GAMNEW) / (ELOSS*COSTHENEW) CHIT = CHIT + CHIT2 IF ( TH0 + CHIT*COSTHENEW .GT. THICKL(1) ) THEN CHI = CHI + (THICKL(1) - TH0)/COSTHENEW HNEW = HLAY(1) IF ( FLAGMU ) STEPL = STEPL + (H0 - HLAY(1))/COSTHENEW IF ( DEBUG ) WRITE(MDEBUG,*) 'PRANGC: CHI = ',SNGL(CHI) GOTO 100 ENDIF IF ( FLAGMU ) STEPL = STEPL + ( H0 - HEIGH(TH0+CHIT2) )/COSTHENEW C ACTUAL VALUES CHI = CHI + CHIT ARG = ARG - ARGNEW C ACTUAL VALUE OF GAM0 IS CALCULATED IN THE LOOP ABOVE GAM0 = GAMNEW IF ( DEBUG ) WRITE(MDEBUG,11) CHI,CHIT,ARG 11 FORMAT(' PRANGC: CHI,CHIT,ARG=',1P,3(E10.3, 1X),0P) C LOOP UNTIL THE COMPLETE PARTICLE TRACK LENGTHS IS TRANSFORMED IN CHI BETANEW = SQRT( GAMNEW**2 - 1.D0 ) / GAMNEW C CALCULATE REAL TRANSNEW AND REAL GEOMETRIC LENGHT DL WHICH CROSSED C THE PARTICLE WITH GIVEN ARGNEW. (GAMMA (= GAM0) HAS CHANGED DUE TO C IONIZATION LOSS). BECAUSE OF CUT ON TRANS AND ON ARG, IT IS POSSIBLE C TO CALCULATE WITHIN A FLAT ATMOSPHERE THNEW = THOLD + COSTHENEW * CHIT HOLD = HNEW C NEW HEIGHT IN OLD COORDINATE FRAME HNEW = HEIGH( THNEW ) DL = ( HOLD - HNEW ) / COSTHENEW TRANSNEW = DL * SINTHENEW C NEW COORDINATE FRAME FOR NEXT STEP IN TRANSNEW C NEW ACTUAL HEIGHT AT NEW THICKNESS GRADIENT C (CALCULATED WITH PARAMETERS OF OLD COORDINATE FRAME) HNEW = SQRT( TRANSNEW**2 + (C(1)+HNEW)**2 ) - C(1) C TERMINATE PROCESS IF WELL BELOW OBSERVATION LEVEL IF ( HNEW .LT. OBSLEV(1) - 1.D5 ) THEN CDH 21.02.2002 * IF ( HNEW .LT. MIN( OBSLEV(1) - 1.D5, * * OBSLEV(1)-2.D0*C(2)*COSTHENEW/SINTHENEW ) ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) 'PRANGC: HNEW,CHI,ARG,STEPL=', * SNGL(HNEW),SNGL(CHI),SNGL(ARG),SNGL(STEPL) GOTO 100 ENDIF C TERMINATE PROCESS IF PARTICLE IS STOPPED IF ( GAM0 .LE. 1.0001D0 ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) 'PRANGC: HNEW,GAM0,CHI,ARG,STEPL=', * SNGL(HNEW),SNGL(GAM0),SNGL(CHI),SNGL(ARG),SNGL(STEPL) GOTO 100 ENDIF COSDIF = ( (C(1)+HNEW)**2 + (C(1)+HOLD)**2 - DL**2 ) / * ( 2.D0 * (C(1)+HNEW) * (C(1)+HOLD) ) IF ( DEBUG ) WRITE(MDEBUG,*) 'PRANGC: HNEW,COSDIF=', * SNGL(HNEW),SNGL(COSDIF) COSDIF = MIN(1.D0,COSDIF) C DIRECTION OF PARTICLE RELATIVE TO DETECTOR CENTER DISTO2 = DISTN2 IF ( COSDIF .LT. 1.D0 ) THEN RADIUS = DL * SQRT( (1.D0-COSTAPNEW**2)/(1.D0-COSDIF**2) ) * * C(1) * ACOS(COSDIF)/(C(1)+HNEW) ELSE RADIUS = DL * SQRT( 1.D0 - COSTAPNEW**2 ) ENDIF XNEW = XNEW + RADIUS * COSPHI YNEW = YNEW + RADIUS * SINPHI DISTN2 = XNEW**2 + YNEW**2 IF ( DISTO2 .GT. DISTN2 ) THEN SIGNE = +1.D0 ELSE SIGNE = -1.D0 ENDIF C COSINE OF ZENITH ANGLE IN THE NEW FRAME COSTHENEW = MIN( 1.D0, ( COSTHENEW * COSDIF - SIGNE * * SQRT( (1.D0-COSTHENEW**2) * (1.D0-COSDIF**2) ) ) ) IF ( DEBUG ) WRITE(MDEBUG,*) 'PRANGC: COSTHENEW =',COSTHENEW C TERMINATE PROCESS IF PARTICLE BECOMES UPWARD GOING IF ( COSTHENEW .LE. C(29) ) GOTO 100 TH0 = THICK(HNEW) C NEXT STEP IF ARG NOT COMPLETELY TRANSFORMED INTO CHI IF ( ARG .GT. 0.D0 ) GOTO 1 100 CONTINUE IF ( DEBUG ) THEN IF ( FLAGMU ) THEN WRITE(MDEBUG,*) 'PRANGC: HNEW,STEPL=',SNGL(HNEW),SNGL(STEPL) ELSE WRITE(MDEBUG,*) 'PRANGC: HNEW=',SNGL(HNEW) ENDIF ENDIF RETURN END *CMZ : 20/06/2000 15.00.27 by D. HECK IK3 FZK KARLSRUHE *-- Author : The CORSIKA development group 14/07/95 C======================================================================= SUBROUTINE PRANGE(ARG) C----------------------------------------------------------------------- C (DECAYING) P(ARTICLE'S) RANGE C C DETERMINES MEAN FREE PATH FOR DECAYING PARTICLES C INCLUDING IONIZATION ENERGY LOSS, C FOR EACH LAYER OF THE ATMOSOHERE SEPARATELY C PRECISELY C THIS SUBROUTINE IS CALLED FROM BOX2. C ARGUMENT: C ARG = -LOG(RANDOM NUMBER) * SPEED OF LIGHT * LIFETIME C C DESIGN : D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,AIR. COMMON /AIR/ COMPOS,PROBTA,AVERAW,AVOGAD DOUBLE PRECISION COMPOS(3),PROBTA(3),AVERAW,AVOGAD *KEEP,ATMOS. COMMON /ATMOS/ AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM DOUBLE PRECISION AATM(5),AATM0(5,0:16),BATM(5),BATM0(5,0:16), * CATM(5),CATM0(5,0:16),DATM(5) INTEGER MODATM *KEEP,ATMOS2. COMMON /ATMOS2/ HLAY,HLAY0,THICKL,LAYNO,LAYNEW DOUBLE PRECISION HLAY(6),HLAY0(5,0:4),THICKL(5) INTEGER LAYNO(0:16) LOGICAL LAYNEW *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,OBSPAR. COMMON /OBSPAR/ OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP, * THETPR,PHIPR, * VUECON, * NOBSLV DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10), * HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2) DOUBLE PRECISION VUECON(2) INTEGER NOBSLV *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DOUBLE PRECISION AK,ARG,ARG0,BK,CHIT,DK,ELOSS, * GAMK,GAMNEW,GAMSQ,GAM0,GMSQM1,H0,TH0 INTEGER ILAY SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,444) ARG,THICKH 444 FORMAT(' PRANGE: -LOG(RD)*C*TAU = ',1P,E10.3,' THICKH=',E10.3) C LOOK WITHIN WHICH LAYER THE PARTICLE STARTS IF ( H .LE. HLAY(2) ) THEN ILAY = 1 TH0 = THICKH ELSEIF ( H .LE. HLAY(3) ) THEN ILAY = 2 TH0 = THICKH ELSEIF ( H .LE. HLAY(4) ) THEN ILAY = 3 TH0 = THICKH ELSE ILAY = 4 TH0 = MAX( THICKH, THICKL(5) ) ENDIF C SET START VALUES FOR ITERATION ARG0 = ARG CHIT = 0.D0 GAM0 = GAMMA H0 = H 2 CONTINUE GAM0 = MAX( GAM0, 1.0001D0 ) GAMSQ = GAM0**2 GMSQM1 = GAMSQ - 1.D0 C ENERGY LOSS BY IONIZATION ELOSS = SIGNUM(ITYPE)**2 * C(22) * * ( GAMSQ * (LOG(GMSQM1) + C(23)) / GMSQM1 - 1.D0 ) ELOSS = ELOSS / (PAMA(ITYPE) * COSTHE ) BK = ELOSS * (TH0 - AATM(ILAY)) DK = GAM0 + BK AK = ARG0 * DK * COSTHE * DATM(ILAY) IF ( AK .GT. 0.D0 ) THEN IF ( AK .LT. 174.D0 ) THEN C LIMIT FOR EXPONENT (ON IBM COMPUTER) GAMNEW = MAX( GAM0 * DK / ( GAM0 + BK * EXP(AK) ), 1.0001D0 ) ELSE GAMNEW = 1.0001D0 ENDIF GAMK = GAM0 - ELOSS * ( THICKL(ILAY) - TH0) ELSE GAMK = 1.D0 GAMNEW = 1.0001D0 ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'PRANGE: GAMNEW,GAMK=', * SNGL(GAMNEW),SNGL(GAMK) C LOOK WETHER PARTICLE PENETRATES LAYER BOUNDARY OR DECAYS BEFORE IF ( GAMNEW .LT. GAMK .AND. ILAY. GT. 1 ) THEN C CALCULATE PORTION OF RANGE AND NEW START VALUES AT LAYER BOUNDARY ARG0 = ARG0 - ( H0 - HLAY(ILAY) + CATM(ILAY) * LOG(GAM0/GAMK) ) * / (DK * COSTHE) CHIT = CHIT + (THICKL(ILAY) - TH0) / COSTHE GAM0 = GAMK H0 = HLAY(ILAY) TH0 = THICKL(ILAY) ILAY = ILAY - 1 GOTO 2 ENDIF C PENETRATED MATTER THICKNESS CHI = CHIT + (GAM0 - GAMNEW) / (ELOSS*COSTHE) IF ( DEBUG ) WRITE(MDEBUG,445) CHI 445 FORMAT(' PRANGE: CHI = ',1P,E10.3) RETURN END *CMZ : 19/10/2001 08.34.39 by D. HECK IK FZK KARLSRUHE *-- Author : D. HECK IK3 FZK KARLSRUHE 26/06/95 C======================================================================= SUBROUTINE PRTIME(TTIME) C----------------------------------------------------------------------- C PR(INT) TIME C C PRINTS PRESENT DATE AND TIME AND GIVES IT IN A FORMAT SUITED FOR THE C RUNHEADER AND EVENTHEADER C THIS SUBROUTINE IS CALLED FROM AAMAIN AND START. C ARGUMENT: C TTIME = TIME (YYMMDD) C C IF OUR DATE ROUTINE DOES NOT FIT TO YOUR COMPUTER, PLEASE REPLACE C IT BY A SUITABLE ROUTINE OF YOUR SYSTEM C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DOUBLE PRECISION TTIME CHARACTER*8 YYYYMMDD CHARACTER*10 HHMMSS INTEGER IYEAR,MONTH,IDAY,IHOUR,IMINU,ISEC SAVE C----------------------------------------------------------------------- C COMPILERS WITH OLD DATE FUNCTIONS ONLY HAVE TO CALL SEKDAT HERE CALL SEKDAT( IYEAR,MONTH,IDAY,IHOUR,IMINU,ISEC ) WRITE(MONIOU,100) IDAY,MONTH,IYEAR,IHOUR,IMINU,ISEC TTIME = MOD(IYEAR,100)*10000 + MONTH*100 + IDAY 100 FORMAT(' PRESENT TIME : ',I2.2,'.',I2.2,'.',I4,I4.2,':',I2.2, * ':',I2.2,' UTC') RETURN END *CMZ : 03/11/2000 16.13.44 by D. HECK IK3 FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= DOUBLE PRECISION FUNCTION PTRANS() C----------------------------------------------------------------------- C TRANS(VERSE MOMENTUM) C C RANDOM SELECTION OF TRANSVERSE MOMENTUM C DISTRIBUTION IS OF FORM X*EXP(-X) C THIS FUNCTION IS CALLED FROM PIGEN1, PIGEN2. C C CHANGES : J. KNAPP IK1 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DOUBLE PRECISION GX(0:50),HX(0:50),DX,SUMI,TT,X,XX,ZZ INTEGER I,IMAX LOGICAL FIRST SAVE C DX IS STEPSIZE FOR APPROXIMATING CURVE DATA FIRST / .TRUE. /, DX / 0.5D0 / C----------------------------------------------------------------------- C IF ( DEBUG ) WRITE(MDEBUG,*) 'PTRANS:' C COMPUTE FUNCTION VALUES AND INTEGRAL OF STEP FUNCTION H(X) C APPROXIMATING Y(X) = X * EXP(1-X) WITH H(X) > Y(X) IF ( FIRST ) THEN FIRST = .FALSE. IMAX = C(34) / DX GX(0) = 0.D0 HX(0) = DX*EXP(1.D0-DX) DO 2 I = 1,IMAX X = I*DX IF ( X .LT. 1.D0 ) X = X + DX HX(I) = X*EXP(1.D0-X) GX(I) = GX(I-1) + HX(I-1) 2 CONTINUE SUMI = 1.D0 / GX(IMAX) DO 3 I = 1,IMAX GX(I) = GX(I) * SUMI 3 CONTINUE ENDIF C----------------------------------------------------------------------- C GET RANDOM VARIABLE DISTRIBUTED AS HX(X) 11 CONTINUE CALL RMMAR( RD,2,1 ) I = 0 1 CONTINUE I = I+1 IF ( GX(I) .LT. RD(1) ) GOTO 1 XX = ( (RD(1)-GX(I-1))/(GX(I)-GX(I-1)) + I-1 ) * DX ZZ = HX(I-1) C GET RANDOM VARIABLE DISTRIBUTED AS Y(X) BY REJECTION METHOD TT = XX * EXP(1.-XX) IF ( RD(2)*ZZ .GT. TT ) GOTO 11 C GET REQUIRED PEAK VALUE PTRANS = XX * C(12) IF ( DEBUG ) WRITE(MDEBUG,*) 'PTRANS: PT = ',SNGL(PTRANS) RETURN END *CMZ : 27/02/2002 16.27.13 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= DOUBLE PRECISION FUNCTION RANNOR( A,B ) C----------------------------------------------------------------------- C RAN(DOM NUMBER) NOR(MALLY DISTRIBUTED) C C GENERATES NORMAL DISTRIBUTED RANDOM NUMBER C DELIVERS 2 UNCORRELATED RANDOM NUMBERS, C THEREFORE RANDOM CALLS ARE ONLY NECESSARY EVERY SECOND TIME. C REFERENCE : NUMERICAL RECIPES, W.H. PRESS ET AL., C CAMBRIDGE UNIVERSITY PRESS, 1992 ISBN 0 521 43064 X C THIS FUNCTION IS CALLED FROM HDPM, LEADDF, PARRAP, QGSTOR, C UPDATE, AND VAPOR. C ARGUMENTS: C A = MEAN VALUE C B = STANDARD DEVIATION C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DOUBLE PRECISION A,B,RR SAVE C----------------------------------------------------------------------- CC IF ( DEBUG ) WRITE(MDEBUG,100) SNGL(A),SNGL(B) CC100 FORMAT(' RANNOR: A,B=',1P,2E10.3) IF ( KNOR ) THEN 1 CONTINUE CALL RMMAR( RD,2,1 ) U1 = 2.D0*RD(1) - 1.D0 U2 = 2.D0*RD(2) - 1.D0 RR = U1**2 + U2**2 IF ( RR .GE. 1.D0 .OR. RR .EQ. 0.D0 ) GOTO 1 FAC = SQRT( (-2.D0) * LOG(RR) / RR ) RANNOR = FAC * U1 * B + A KNOR = .FALSE. ELSE RANNOR = FAC * U2 * B + A KNOR = .TRUE. ENDIF CC IF ( DEBUG ) WRITE(MDEBUG,101) RANNOR CC101 FORMAT('+',34X,' RANNOR =',1P,E12.5) RETURN END *CMZ : 14/06/2000 14.56.21 by D. HECK IK3 FZK KARLSRUHE *-- Author : Konrad Bernloehr, Uni Hamburg 30/08/99 C======================================================================= SUBROUTINE RCLCHK( MUNIT,NLREC,IERR ) C----------------------------------------------------------------------- C R(E)C(ORD)L(ENGTH PARAMETER) CH(EC)K C C CHECK IF THE RECL PARAMETER FOR OPENING UNFORMATTED DIRECT-ACCESS C FILES IS INTERPRETED AS IT SHOULD C THIS SUBROUTINE IS CALLED FROM INPRM. C ARGUMENTS: C MUNIT = UNIT NUMBER FOR TEMPORARY FILE C NLREC = 1 FOR RECL IN BYTES, 4 FOR RECL IN 4-BYTE WORDS C IERR = ERROR INDICATOR C C DESIGN: K. BERNLOEHR UNI HAMBURG 1999 C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. INTEGER IERR,MUNIT,NLREC INTEGER IDAT(5) SAVE C----------------------------------------------------------------------- IERR = 0 OPEN(UNIT=MUNIT,STATUS='SCRATCH', * FORM='UNFORMATTED',ACCESS='DIRECT',RECL=16/NLREC) C IF NLREC=4 BUT RECL COUNTED IN BYTES, THE '990' STATEMENT C WILL TYPICALLY BE JUMPED TO, AS A RESULT OF A WRITE ERROR. WRITE(MUNIT,REC=1,ERR=990) 1,2,3,4 WRITE(MUNIT,REC=3,ERR=990) 9,10,11,12 WRITE(MUNIT,REC=2,ERR=990) 5,6,7,8 C IF NLREC=4 BUT RECL IS COUNTED IN BYTES AND NO WRITE C ERROR WAS REPORTED, RECORDS SHOULD HAVE OVERLAPED AND C THE DATA IS CORRUPTED. READ(MUNIT,REC=1) IDAT(1),IDAT(2),IDAT(3),IDAT(4) IF ( IDAT(1) .NE. 1 .OR. IDAT(2) .NE. 2 .OR. * IDAT(3) .NE. 3 .OR. IDAT(4) .NE. 4 ) IERR = 1 READ(MUNIT,REC=2) IDAT(1),IDAT(2),IDAT(3),IDAT(4) IF ( IDAT(1) .NE. 5 .OR. IDAT(2) .NE. 6 .OR. * IDAT(3) .NE. 7 .OR. IDAT(4) .NE. 8 ) IERR = IERR + 2 READ(MUNIT,REC=3) IDAT(1),IDAT(2),IDAT(3),IDAT(4) IF ( IDAT(1) .NE. 9 .OR. IDAT(2) .NE. 10 .OR. * IDAT(3) .NE. 11 .OR. IDAT(4) .NE. 12 ) IERR = IERR + 4 C IF NLREC=1 BUT RECL COUNTED IN WORDS IS USUALLY NOT CAUGHT BY C THIS ROUTINE, BUT SHOULD BE RATHER HARMLESS. THE ONLY BAD C EFFECT EXPECTED IS THAT THE EXTERNAL STACK FILE WILL BE FOUR C TIMES AS LARGE AS NEEDED. C WELL, LET'S TRY TO CATCH THAT ONE AS WELL (READ ERROR IS O.K.) READ(MUNIT,REC=1,ERR=900) IDAT(1),IDAT(2),IDAT(3),IDAT(4),IDAT(5) WRITE(MONIOU,*) ' ' WRITE(MONIOU,*) 'THE HANDLING OF UNFORMATTED DIRECT-ACCESS FILES', * ' ON YOUR MACHINE SEEMS TO' WRITE(MONIOU,*) 'BE NOT AS EXPECTED. THE TEMPORARY CORSIKA ', * 'EXTERNAL STACK FILE MAY BECOME' WRITE(MONIOU,*) 'LARGER THAN NEEDED BUT NO DATA CORRUPTION IS ', * 'EXPECTED THERE.' WRITE(MONIOU,*) 'PERHAPS YOU USED THE BYTERECL OPTION FOR ', * 'EXTRACTING CORSIKA BUT DO NOT NEED IT.' WRITE(MONIOU,*) ' ' IERR = -1 RETURN 900 CLOSE(MUNIT) IF ( IERR .NE. 0 ) THEN WRITE(MONIOU,*) ' ' WRITE(MONIOU,*) 'THE HANDLING OF UNFORMATTED DIRECT-ACCESS ', * 'FILES ON YOUR MACHINE IS NOT AS' WRITE(MONIOU,*) 'EXPECTED. THIS MAY WELL LEAD TO CORRUPTION ', * 'OF THE CORSIKA EXTERNAL STACK.' WRITE(MONIOU,*) 'PERHAPS THIS PROBLEM IS DUE TO A MISSING ', * 'BYTERECL OPTION FOR EXTRACTING' WRITE(MONIOU,*) 'CORSIKA FROM THE CMZ FILE. IT MAY ALSO BE ', * 'DUE TO USING COMPILER FLAGS' WRITE(MONIOU,*) 'INAPPROPRIATE FOR THE CORSIKA VERSION ', * 'EXTRACTED.' WRITE(MONIOU,*) ' ' ENDIF RETURN 990 IERR = 99 GOTO 900 END *CMZ : 09/11/2000 14.19.13 by D. HECK IK3 FZK KARLSRUHE *-- Author : D. HECK IK3 FZK KARLSRUHE 16/07/99 C======================================================================= SUBROUTINE RHO0DC C----------------------------------------------------------------------- C RHO(0) D(E)C(AY) C C TWO PARTICLE DECAY WITH FULL KINEMATIC; ENERGY AND MOMENTA CONSERVED C RHO(0) DECAYS INTO PI(+) + PI(-) WITH DIPOLE CHARACTERISTIC C THIS SUBROUTINE IS CALLED FROM RHOGEN. C C DESIGN : D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,GENER. COMMON /GENER/ GEN,ALEVEL DOUBLE PRECISION GEN,ALEVEL *KEEP,LONGI. COMMON /LONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG, * SDLONG,SELONG,SPLONG,THSTEP,THSTPI, * LHEIGH,NSTEP,LLONGI,FLGFIT DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9), * APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9), * HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9), * SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI INTEGER LHEIGH,NSTEP LOGICAL LLONGI,FLGFIT *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,STACKE. COMMON /STACKE/ E,TIM,U,V,W,X,Y,Z,DNEAR, * ZAP,WAP,WA, * IQ,IGEN,IR,IOBS,LPCTE,NP DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60), * X(60),Y(60),Z(60),DNEAR(60) * ,ZAP(60),WAP(60),WA(60) INTEGER IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP *KEND. DOUBLE PRECISION AUX2A,BETA,COSTCM,COSTH3,COSTH4, * GAMMA3,GAMMA4,PHI4,WORK1,WORK2 INTEGER I SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=1,9) 444 FORMAT(' RHO0DC: CURPAR=',1P,8E10.3,0P,F10.0) C COPY VERTEX COORDINATES INTO SECPAR DO 10 I = 5,8 SECPAR(I) = CURPAR(I) 10 CONTINUE C SET GENERATION AND LEVEL OF LAST INTERACTION SECPAR( 9) = GEN SECPAR(10) = ALEVEL C RESET POLARIZATION, NOT USED FOR PARTICLES OTHER THAN MUONS YET SECPAR(11) = 0.D0 SECPAR(12) = 0.D0 SECPAR(14) = CURPAR(14) SECPAR(15) = CURPAR(15) SECPAR(16) = CURPAR(16) C CALCULATE AUXILIARY QUANTITIES BETA = SQRT( CURPAR(2)**2 - 1.D0 ) / CURPAR(2) AUX2A = 0.5D0 * PAMA(51) / PAMA(8) WORK1 = CURPAR(2) * AUX2A WORK2 = BETA * CURPAR(2) * SQRT( AUX2A**2 - 1.D0 ) C DETERMINE POLAR ANGLE IN CM SYSTEM WITH DIPOLE CHARACTERISTICS C PURE DIPOLE RADIATION: W(COSTH) = 1-3/5*COSTH**2 210 CONTINUE CALL RMMAR( RD,2,1 ) COSTCM = 2.D0 * RD(1) - 1.D0 C PARAMETRIZATION FROM H1 COLLAB. [NUCL.PYS. B463(1996)3] C THIS PARAMETRIZATION SEEMS UNPHYSICALLY, AS IT RESULTS IN C NEGATIVE RATE IN FORWARD OR BACKWARD DIRECTION C IF ( RD(2) .GT. 1.D0 - 1.1982D0 * COSTCM**2 ) GOTO 210 C PARAMETRIZATION FROM ZEUSS COLLAB. [Z.PHYS. C69(1995)39] IF ( RD(2) .GT. 1.D0 - 0.8836D0 * COSTCM**2 ) GOTO 210 GAMMA3 = WORK1 + WORK2 * COSTCM C SECOND PRODUCT PARTICLE IS PI(-) GAMMA4 = CURPAR(2) * (PAMA(51)/PAMA(8)) - GAMMA3 COSTH4 = MIN( 1.D0, (CURPAR(2)*GAMMA4 - AUX2A) * / (BETA * CURPAR(2) * SQRT(GAMMA4**2 - 1.D0)) ) CALL RMMAR( RD,1,1 ) PHI4 = RD(1)*PI2 CALL ADDANG(CURPAR(3),CURPAR(4), COSTH4,PHI4, SECPAR(3),SECPAR(4)) IF ( SECPAR(3) .GT. C(29) ) THEN SECPAR(1) = 9.D0 SECPAR(2) = GAMMA4 IF ( DEBUG ) WRITE(MDEBUG,445) (SECPAR(I),I=1,9) 445 FORMAT(' RHO0DC: SECPAR=',1P,8E10.3,0P,F10.0) CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT DLONG(LPCTE(NP),7) = DLONG(LPCTE(NP),7) + GAMMA4 * PAMA(8) ENDIF ENDIF C FIRST PRODUCT PARTICLE IS PI(+) COSTH3 = MIN( 1.D0, (CURPAR(2) * GAMMA3 - AUX2A) * / (BETA * CURPAR(2) * SQRT(GAMMA3**2 - 1.D0)) ) CALL ADDANG( CURPAR(3),CURPAR(4), COSTH3,PHI4+PI, * SECPAR(3),SECPAR(4) ) IF ( SECPAR(3) .GT. C(29) ) THEN SECPAR(1) = 8.D0 SECPAR(2) = GAMMA3 IF ( DEBUG ) WRITE(MDEBUG,445) (SECPAR(I),I=1,9) CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT DLONG(LPCTE(NP),7) = DLONG(LPCTE(NP),7) + GAMMA3 * PAMA(8) ENDIF ENDIF RETURN END *CMZ : 20/06/2000 15.00.27 by D. HECK IK3 FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= DOUBLE PRECISION FUNCTION RHOF( ARG ) C----------------------------------------------------------------------- C RHO (DENSITY) F(UNCTION) C C CALCULATES DENSITY (G/CM**3) OF ATMOSPHERE DEPENDING ON HEIGHT (CM) C THIS FUNCTION IS CALLED FROM BOX2, LPMEFFECT, ININKG, CERENK, C AND INRTAB. C ARGUMENT: C ARG = HEIGHT IN CM C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,ATMOS. COMMON /ATMOS/ AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM DOUBLE PRECISION AATM(5),AATM0(5,0:16),BATM(5),BATM0(5,0:16), * CATM(5),CATM0(5,0:16),DATM(5) INTEGER MODATM *KEEP,ATMOS2. COMMON /ATMOS2/ HLAY,HLAY0,THICKL,LAYNO,LAYNEW DOUBLE PRECISION HLAY(6),HLAY0(5,0:4),THICKL(5) INTEGER LAYNO(0:16) LOGICAL LAYNEW *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,ATMOSX. C EXTERNAL ATMOSPHERIC MODELS COMMON /ATMOSX/ IATMOX,FREFRX INTEGER IATMOX LOGICAL FREFRX *KEND. DOUBLE PRECISION ARG DOUBLE PRECISION RHOFX EXTERNAL RHOFX SAVE C----------------------------------------------------------------------- CC IF ( DEBUG ) WRITE(MDEBUG,*) 'RHOF : ARG=',SNGL(ARG) IF ( IATMOX .GE. 1 ) THEN RHOF = RHOFX(ARG) RETURN ENDIF IF ( ARG .LT. HLAY(2) ) THEN RHOF = BATM(1) * DATM(1) * EXP ( (-ARG) * DATM(1) ) ELSEIF ( ARG .LT. HLAY(3) ) THEN RHOF = BATM(2) * DATM(2) * EXP ( (-ARG) * DATM(2) ) ELSEIF ( ARG .LT. HLAY(4) ) THEN RHOF = BATM(3) * DATM(3) * EXP ( (-ARG) * DATM(3) ) ELSEIF ( ARG .LT. HLAY(5) ) THEN RHOF = BATM(4) * DATM(4) * EXP ( (-ARG) * DATM(4) ) ELSE RHOF = DATM(5) ENDIF RETURN END *CMZ : 27/02/2002 16.27.13 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE RMMAQ( ISEED,ISEQ,CHOPT ) C----------------------------------------------------------------------- C R(ANDO)M (NUMBER GENERATOR OF) MA(RSAGLIA TYPE INITIALIZATION) C C ROUTINE FOR INITIALIZATION OF RMMAR C THIS SUBROUTINE IS CALLED FROM AAMAIN AND START. C ARGUMENTS: C ISEED = SEED TO INITIALIZE A SEQUENCE C ISEQ = # OF RANDOM SEQUENCE C CHOPT = CHARACTER TO STEER INITIALIZE OPTIONS C C CERN PROGLIB# V113 RMMAQ .VERSION KERNFOR 1.0 C ORIG. 01/03/89 FCA + FJ C----------------------------------------------------------------------- COMMON /RANMA2/ IU(1030),JSEQ COMMON /RANMA3/ TWOM24,TWOM48,CD,CM,CINT,MODCNS INTEGER I97(0:1030),J97(0:1030),NTOT(0:1030),NTOT2(0:1030), * IJKL(0:1030) REAL U(1030),C(0:1030),UU(1030) EQUIVALENCE (IJKL(0),IU(1)),(NTOT(0),IU(2)),(NTOT2(0),IU(3)) EQUIVALENCE (U(1),IU(4)),(C(0),IU(101)),(I97(0),IU(102)) EQUIVALENCE (J97(0),IU(103)) INTEGER ISEED(*) CHARACTER CHOPT*(*), CCHOPT*12 LOGICAL FIRST SAVE UU,FIRST,CCHOPT DATA FIRST / .TRUE. / C----------------------------------------------------------------------- IF ( FIRST ) THEN TWOM24 = 2.**(-24) TWOM48 = 2.**(-48) CD = 7654321.*TWOM24 CM = 16777213.*TWOM24 CINT = 362436.*TWOM24 MODCNS = 1000000000 FIRST = .FALSE. ENDIF CCHOPT = CHOPT IF ( CCHOPT .EQ. ' ' ) THEN ISEED(1) = 54217137 ISEED(2) = 0 ISEED(3) = 0 CCHOPT = 'S' JSEQ = 1 ENDIF IF ( INDEX(CCHOPT,'S') .NE. 0 ) THEN IF ( ISEQ .GT. 0 ) JSEQ = ISEQ IBASE = (JSEQ-1)*103 IF ( INDEX(CCHOPT,'V') .NE. 0 ) THEN DO 10 JJ = 1,103 IU(IBASE+JJ) = ISEED(JJ) 10 CONTINUE ELSE IJKL(IBASE) = ISEED(1) NTOT(IBASE) = ISEED(2) NTOT2(IBASE) = ISEED(3) IJ = IJKL(IBASE) / 30082 KL = IJKL(IBASE) - 30082*IJ I = MOD(IJ/177, 177) + 2 J = MOD(IJ, 177) + 2 K = MOD(KL/169, 178) + 1 L = MOD(KL, 169) DO 30 II = 1,97 S = 0. T = .5 DO 20 JJ = 1,24 M = MOD(MOD(I*J,179)*K, 179) I = J J = K K = M L = MOD(53*L+1, 169) IF ( MOD(L*M,64) .GE. 32 ) S = S+T T = 0.5*T 20 CONTINUE UU(II) = S 30 CONTINUE CC = CINT II97 = 97 IJ97 = 33 C COMPLETE INITIALIZATION BY SKIPPING (NTOT2*MODCNS+NTOT) RANDOMNUMBERS NITER = MODCNS DO 50 LOOP2 = 1,NTOT2(IBASE)+1 IF ( LOOP2 .GT. NTOT2(IBASE) ) NITER = NTOT(IBASE) DO 40 IDUM = 1,NITER UNI = UU(II97)-UU(IJ97) IF ( UNI .LT. 0. ) UNI = UNI+1. UU(II97) = UNI II97 = II97-1 IF ( II97 .EQ. 0 ) II97 = 97 IJ97 = IJ97-1 IF ( IJ97 .EQ. 0 ) IJ97 = 97 CC = CC - CD IF ( CC .LT. 0. ) CC = CC+CM 40 CONTINUE 50 CONTINUE I97(IBASE) = II97 J97(IBASE) = IJ97 C(IBASE) = CC DO 60 JJ = 1,97 U(IBASE+JJ) = UU(JJ) 60 CONTINUE ENDIF ELSEIF ( INDEX(CCHOPT,'R') .NE. 0 ) THEN IF ( ISEQ .GT. 0 ) THEN JSEQ = ISEQ ELSE ISEQ = JSEQ ENDIF IBASE = (JSEQ-1)*103 IF ( INDEX(CCHOPT,'V') .NE. 0 ) THEN NCOPY = 103 ELSE NCOPY = 3 ENDIF DO 70 JJ = 1,NCOPY ISEED(JJ) = IU(IBASE+JJ) 70 CONTINUE ENDIF RETURN END *CMZ : 28/02/2002 13.08.19 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE RMMAR( RVEC,LENV,ISEQ ) C----------------------------------------------------------------------- C R(ANDO)M (NUMBER GENERATOR OF) MAR(SAGLIA TYPE) C C THESE ROUTINES (RMMAR,RMMAQ) ARE TAKEN FROM THE CERN LIBRARIES C DESCRIPTION OF ALGORITHM SEE THERE C THIS SUBROUTINE IS CALLED FROM MANY ROUTINES. C ARGUMENTS: C RVEC = VECTOR FIELD TO BE FILLED WITH RANDOM NUMBERS C LENV = LENGTH OF VECTOR (# OF RANDNUMBERS TO BE GENERATED) C ISEQ = # OF RANDOM SEQUENCE C C CERN PROGLIB# V113 RMMAR .VERSION KERNFOR 1.0 C ORIG. 01/03/89 FCA + FJ C----------------------------------------------------------------------- REAL RVEC(*) COMMON /RANMA2/ IU(1030),JSEQ COMMON /RANMA3/ TWOM24,TWOM48,CD,CM,CINT,MODCNS INTEGER I97(0:1030),J97(0:1030),NTOT(0:1030),NTOT2(0:1030), * IJKL(0:1030) REAL U(1030),C(0:1030) EQUIVALENCE (IJKL(0),IU(1)),(NTOT(0),IU(2)),(NTOT2(0),IU(3)) EQUIVALENCE (U(1),IU(4)),(C(0),IU(101)),(I97(0),IU(102)) EQUIVALENCE (J97(0),IU(103)) SAVE C----------------------------------------------------------------------- IF ( ISEQ .GT. 0 ) JSEQ = ISEQ IBASE = (JSEQ-1)*103 DO 100 IVEC = 1,LENV UNI = U(IBASE+I97(IBASE))-U(IBASE+J97(IBASE)) IF ( UNI .LT. 0. ) UNI = UNI+1. U(IBASE+I97(IBASE)) = UNI I97(IBASE) = I97(IBASE)-1 IF ( I97(IBASE) .EQ. 0 ) I97(IBASE) = 97 J97(IBASE) = J97(IBASE)-1 IF ( J97(IBASE) .EQ. 0 ) J97(IBASE) = 97 C(IBASE) = C(IBASE) - CD IF ( C(IBASE) .LT. 0. ) C(IBASE) = C(IBASE)+CM UNI = UNI-C(IBASE) IF ( UNI .LT. 0. ) UNI = UNI+1. C REPLACE EXACT ZEROES BY UNIFORM DISTR. *2**-24 IF ( UNI .EQ. 0. ) THEN UNI = TWOM24*U(2) C AN EXACT ZERO HERE IS VERY UNLIKELY, BUT LET'S BE SAFE. IF ( UNI .EQ. 0. ) UNI = TWOM48 ENDIF RVEC(IVEC) = UNI 100 CONTINUE NTOT(IBASE) = NTOT(IBASE) + LENV IF ( NTOT(IBASE) .GE. MODCNS ) THEN NTOT2(IBASE) = NTOT2(IBASE) + 1 NTOT(IBASE) = NTOT(IBASE) - MODCNS ENDIF RETURN END *CMZ : 28/02/2002 13.12.11 by D. HECK IK FZK KARLSRUHE *-- Author : D. HECK IK3 FZK KARLSRUHE 27/04/94 C======================================================================= SUBROUTINE SDPM C----------------------------------------------------------------------- C S(TARTING) D(UAL) P(ARTON) M(ODEL) C C THIS ROUTINE DETERMINES THE TARGET NUCLEUS. C IT CALLS ALSO THE VARIOUS INTERACTION MODELS. C FOR HDPM, THIS ROUTINE LOOKS, HOW MANY NUCLEONS INTERACT AND WHICH C RESIDUAL FRAGMENT OF THE PROJECTILE NUCLEUS REMAINS. C THIS SUBROUTINE IS CALLED FROM NUCINT AND PIGEN. C C REDESIGN: D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,AIR. COMMON /AIR/ COMPOS,PROBTA,AVERAW,AVOGAD DOUBLE PRECISION COMPOS(3),PROBTA(3),AVERAW,AVOGAD *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,DPMFLG. COMMON /DPMFLG/ NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM INTEGER NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM *KEEP,GENER. COMMON /GENER/ GEN,ALEVEL DOUBLE PRECISION GEN,ALEVEL *KEEP,INTER. COMMON /INTER/ AVCH,AVCH3,DC0,DLOG,DMLOG,ECMDIF,ECMDPM,ELAB, * FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3, * RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG, * WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN, * IDIF,ITAR DOUBLE PRECISION AVCH,AVCH3,DC0,DLOG,DMLOG,ECMDIF,ECMDPM,ELAB, * FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3, * RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG, * WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN INTEGER IDIF,ITAR *KEEP,ISTA. COMMON /ISTA/ IFINET,IFINNU,IFINKA,IFINPI,IFINHY INTEGER IFINET,IFINNU,IFINKA,IFINPI,IFINHY *KEEP,LONGI. COMMON /LONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG, * SDLONG,SELONG,SPLONG,THSTEP,THSTPI, * LHEIGH,NSTEP,LLONGI,FLGFIT DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9), * APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9), * HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9), * SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI INTEGER LHEIGH,NSTEP LOGICAL LLONGI,FLGFIT *KEEP,MULT. COMMON /MULT/ EKINL,MSMM,MULTMA,MULTOT DOUBLE PRECISION EKINL INTEGER MSMM,MULTMA(40,13),MULTOT(40,13) *KEEP,NCSNCS. COMMON /NCSNCS/ SIGN30,SIGN45,SIGN60,SIGO30,SIGO45,SIGO60, * SIGA30,SIGA45,SIGA60,PNOA30,PNOA45,PNOA60, * SIG30A,SIG45A,SIG60A DOUBLE PRECISION SIGN30(56),SIGN45(56),SIGN60(56), * SIGO30(56),SIGO45(56),SIGO60(56), * SIGA30(56),SIGA45(56),SIGA60(56), * PNOA30(1540,3),PNOA45(1540,3),PNOA60(1540,3), * SIG30A(56),SIG45A(56),SIG60A(56) *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,REST. COMMON /REST/ CONTNE,TAR,LT DOUBLE PRECISION CONTNE(3),TAR INTEGER LT *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,SIGM. COMMON /SIGM/ SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO DOUBLE PRECISION SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO *KEEP,VKIN. COMMON /VKIN/ BETACM DOUBLE PRECISION BETACM *KEEP,VENUS. COMMON /VENUS/ ISH00,IVERVN,MTAR99,FVENUS,FVENSG INTEGER ISH00,IVERVN,MTAR99 LOGICAL FVENUS,FVENSG *KEND. DOUBLE PRECISION PFRX(60),PFRY(60) DOUBLE PRECISION COSTET,EA,P,PHIV,PTM,PT2, * SIGMAA,SIGMAN,SIGMAO,SIG45,S45SQ,S4530 DOUBLE PRECISION CGHSIG DOUBLE PRECISION EKIN INTEGER ITYP(60),I,IA,IANEW,INACTA,INACTZ,INDEX,INEUTR, * IZ,IZNEW,J,JFIN,KNEW,L,LL,NPRPRO,NNEPRO SAVE EXTERNAL CGHSIG C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=1,9) 444 FORMAT(' SDPM : CURPAR=',1P,9E10.3) C IA IS MASS NUMBER OF PROJECTILE IA = ITYPE / 100 IF ( IA .GT. 56 ) THEN WRITE(MONIOU,444) (CURPAR(I),I=1,9) WRITE(MONIOU,*) 'SDPM : NOT FORESEEN PARTICLE TYPE=',ITYPE STOP ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C TREATMENT OF GAMMAS COMING FROM EGS4 (PIGEN) IF ( ITYPE .EQ. 1 ) THEN C RATIOS OF CROSS-SECTIONS GO LIKE A**0.91 C 14**0.91 = 11.04; 16**0.91 = 12.47; 40**0.91 = 28.70 FRACTN = COMPOS(1) * 11.04019D0 FRCTNO = FRACTN + COMPOS(2) * 12.46663D0 SIGAIR = FRCTNO + COMPOS(3) * 28.69952D0 C TARGET IS CHOSEN AT RANDOM CALL RMMAR( RD,1,1 ) IF ( RD(1)*SIGAIR .LE. FRACTN ) THEN C INTERACTION WITH NITROGEN LT = 1 TAR = 14.D0 ELSEIF ( RD(1)*SIGAIR .LE. FRCTNO ) THEN C INTERACTION WITH OXYGEN LT = 2 TAR = 16.D0 ELSE C INTERACTION WITH ARGON LT = 3 TAR = 40.D0 ENDIF C GAMMAS ARE TREATED BY VENUS, IF SUFFICIENT ENERGY IF ( FVENUS .AND. CURPAR(2) .GT. HILOELB ) THEN CALL VENLNK ELSE CALL HDPM ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C NORMAL HADRON PROJECTILE ELSEIF ( ITYPE .LT. 100 ) THEN C WITH WHAT KIND OF TARGET DOES PROJECTILE INTERACT? IF ( FIXTAR ) THEN C TARGET OF FIRST INTERACTION IS FIXED LT = N1STTR IF ( N1STTR .EQ. 1 ) THEN TAR = 14.D0 ELSEIF ( N1STTR .EQ. 2 ) THEN TAR = 16.D0 ELSE TAR = 40.D0 ENDIF FIXTAR = .FALSE. C AUXIL. QUANTITIES FOR INTERPOLATION SIG45 = SIGMA - 45.D0 S45SQ = SIG45**2 / 450.D0 S4530 = SIG45 / 30.D0 ELSE C TARGET IS CHOSEN AT RANDOM ACCORDING TO CROSS-SECTION C SIGAIR, FRACTN, FRCTNO HAVE BEEN DETERMINED IN BOX2/VENSIG IF ( FVENSG ) GOTO 333 C SIGMA IS ENERGY DEPENDENT INELASTIC NUCLEON-NUCLEON CROSS-SECTION C AND IS SET IN BOX2 C AUXIL. QUANTITIES FOR INTERPOLATION SIG45 = SIGMA - 45.D0 S45SQ = SIG45**2 / 450.D0 S4530 = SIG45 / 30.D0 C INELASTIC CROSS-SECTIONS FOR PROJECTICLE WITH MASS NUMBER 1 SIGMAN = (1.D0 - 2.D0 * S45SQ) * SIGN45(1) * +(S45SQ - S4530) * SIGN30(1) * +(S45SQ + S4530) * SIGN60(1) FRACTN = COMPOS(1) * SIGMAN SIGMAO = (1.D0 - 2.D0 * S45SQ) * SIGO45(1) * +(S45SQ - S4530) * SIGO30(1) * +(S45SQ + S4530) * SIGO60(1) FRCTNO = FRACTN + COMPOS(2) * SIGMAO SIGMAA = (1.D0 - 2.D0 * S45SQ) * SIGA45(1) * +(S45SQ - S4530) * SIGA30(1) * +(S45SQ + S4530) * SIGA60(1) C INELASTIC CROSS-SECTIONS OF AIR FOR PROJECTILE WITH MASS NUMBER 1 SIGAIR = FRCTNO + COMPOS(3)*SIGMAA 333 CONTINUE CALL RMMAR( RD,1,1 ) IF ( DEBUG ) WRITE(MDEBUG,*) 'SDPM : FRACTN=',SNGL(FRACTN), * ' FRCTNO=',SNGL(FRCTNO),' RD=',RD(1) IF ( RD(1)*SIGAIR .LE. FRACTN ) THEN C INTERACTION WITH NITROGEN LT = 1 TAR = 14.D0 ELSEIF ( RD(1)*SIGAIR .LE. FRCTNO ) THEN C INTERACTION WITH OXYGEN LT = 2 TAR = 16.D0 ELSE C INTERACTION WITH ARGON LT = 3 TAR = 40.D0 ENDIF ENDIF IF ( FVENUS ) THEN C MESONS, NUCLEONS AND STRANGE BARYONS ARE TREATED BY VENUS (JAN 95) IF ( ITYPE .GE. 7 .AND. ITYPE .LE. 32 ) THEN CALL VENLNK ELSE CALL HDPM ENDIF ELSE CALL HDPM ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C HEAVY PRIMARY INCIDENT WITH IA NUCLEONS ELSEIF ( IA .LE. 56 ) THEN IZ = MOD(ITYPE,100) C WITH WHAT KIND OF TARGET DOES PROJECTILE INTERACT? IF ( FIXTAR ) THEN C TARGET OF FIRST INTERACTION IS FIXED LT = N1STTR IF ( N1STTR .EQ. 1 ) THEN TAR = 14.D0 ELSEIF ( N1STTR .EQ. 2 ) THEN TAR = 16.D0 ELSE TAR = 40.D0 ENDIF FIXTAR = .FALSE. CALL RMMAR( RD,2,1 ) C AUXIL. QUANTITIES FOR INTERPOLATION SIG45 = SIGMA - 45.D0 S45SQ = SIG45**2 / 450.D0 S4530 = SIG45 / 30.D0 ELSE C ONLY INELASTIC INTERACTIONS WITH HEAVY PRIMARY/FRAGMENT C SIGMA IS ENERGY DEPENDENT INELASTIC NUCLEON-NUCLEON CROSS-SECTION C AND IS SET IN BOX2/VENSIG C AUXIL. QUANTITIES FOR INTERPOLATION SIG45 = SIGMA - 45.D0 S45SQ = SIG45**2 / 450.D0 S4530 = SIG45 / 30.D0 C INELASTIC CROSS-SECTIONS FOR PROJECTICLE WITH MASS NUMBER IA SIGMAN = (1.D0 - 2.D0 * S45SQ) * SIGN45(IA) * +(S45SQ - S4530) * SIGN30(IA) * +(S45SQ + S4530) * SIGN60(IA) FRACTN = COMPOS(1) * SIGMAN SIGMAO = (1.D0 - 2.D0 * S45SQ) * SIGO45(IA) * +(S45SQ - S4530) * SIGO30(IA) * +(S45SQ + S4530) * SIGO60(IA) FRCTNO = FRACTN + COMPOS(2) * SIGMAO SIGMAA = (1.D0 - 2.D0 * S45SQ) * SIGA45(IA) * +(S45SQ - S4530) * SIGA30(IA) * +(S45SQ + S4530) * SIGA60(IA) C INELASTIC CROSS-SECTIONS OF AIR FOR PROJECTILE WITH MASS NUMBER IA SIGAIR = FRCTNO +COMPOS(3)*SIGMAA 334 CONTINUE C TARGET IS CHOSEN AT RANDOM CALL RMMAR( RD,2,1 ) IF ( DEBUG ) WRITE(MDEBUG,*) 'SDPM : FRACTN=',SNGL(FRACTN), * ' FRCTNO=',SNGL(FRCTNO),' RD=',RD(1) IF ( RD(1)*SIGAIR .LE. FRACTN ) THEN C INTERACTION WITH NITROGEN LT = 1 TAR = 14.D0 ELSEIF ( RD(1)*SIGAIR .LE. FRCTNO ) THEN C INTERACTION WITH OXYGEN LT = 2 TAR = 16.D0 ELSE C INTERACTION WITH ARGON LT = 3 TAR = 40.D0 ENDIF ENDIF C TREAT NUCLEUS BY VENUS, IF SELECTED AND ENERGY/NUCLEON HIGH ENOUGH IF ( FVENUS .AND. PAMA(ITYPE)*GAMMA .GT. HILOELB*IA ) THEN CALL VENLNK RETURN ENDIF C TREATMENT OF NUCLEUS-NUCLEUS INTERACTION IN HDPM BY SUPERPOSITION C C INDEX CALCULATION 1 P( I*(I-3)*0.5+J+1 ) C IZ IS NUMBER OF PROTONS IN PROJECTILE C LT IS INDEX FOR TARGET 1 = N, 2 = O, 3 = AR C INACTA IS NUMBER OF INTERACTING NUCLEONS C INACTZ IS NUMBER OF INTERACTING PROTONS C LOOK, HOW MANY NUCLEONS INTERACT DO 100 J = 1,IA-1 INACTA = J INDEX = IA * (IA-3) * 0.5 + 1 + J P = ( 1.D0 - S45SQ *2.D0 ) * PNOA45(INDEX,LT) * +( S45SQ - S4530 ) * PNOA30(INDEX,LT) * +( S45SQ + S4530 ) * PNOA60(INDEX,LT) IF ( RD(2) .LT. P ) GOTO 110 100 CONTINUE C ALL NUCLEONS INTERACT (INACTA EQUAL IA) INACTA = INACTA + 1 110 CONTINUE IANEW = IA - INACTA C REMAINING PROJECTILE WITH IANEW NUCLEONS DO 120 L = 2,4 SECPAR(L) = CURPAR(L) 120 CONTINUE C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C PROJECTILE NUCLEUS FRAGMENTS COMPLETELY, WRITE SPECTATOR NUCLEONS C ONTO STACK IF ( NFRAGM .EQ. 0 ) THEN C LOOK, HOW MANY PROTONS AND NEUTRONS ARE FORMED IZNEW = IANEW / 2.15D0 + 0.7D0 INEUTR = IANEW - IZNEW INACTZ = MAX( IZ-IZNEW, 0 ) IF ( IZNEW .GT. 0 ) THEN C PROTONS SECPAR(1) = 14.D0 DO 300 L = 1,IZNEW CALL TSTACK 300 CONTINUE ENDIF IF ( INEUTR .GT. 0 ) THEN C NEUTRONS SECPAR(1) = 13.D0 DO 310 L = 1,INEUTR CALL TSTACK 310 CONTINUE ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C NO FRAGMENTATION, BUT SUCCESSIVE ABRASION OF PROJECTILE NUCLEUS ELSE IF ( DEBUG ) WRITE( MDEBUG,111 ) TAR,INACTA,IANEW 111 FORMAT(' SDPM : TARGET=',F4.0,' INACTA=',I4,' IANEW=',I4) C ALL NUCLEONS INTERACT, NO RESIDUAL NUCLEUS IF ( IANEW .EQ. 0 ) THEN INACTZ = IZ IF ( DEBUG ) WRITE(MDEBUG,554) (CURPAR(I),I=1,9) 554 FORMAT(' SDPM : CURPAR=',1P,9E10.3) KNEW = 0 C REMAINING NUCLEUS IS A NUCLEON ELSEIF ( IANEW .EQ. 1 ) THEN CALL RMMAR( RD,1,1 ) IZNEW = NINT(RD(1)) INACTZ = IZ - IZNEW KNEW = 13 + IZNEW C REMAINING NUCLEUS GETS A CHARGE WHICH IS ABOUT HALF THE MASS NUMBER ELSEIF ( IANEW .GT. 1 ) THEN IZNEW = FLOAT(IANEW) / 2.15D0 + 0.7D0 INACTZ = MAX( IZ - IZNEW, 0 ) KNEW = IANEW*100 + IZNEW C REMAINING NUCLEUS DEEXCITES BY EVAPORATION OF NUCLEONS/ALPHA PARTCLS. IF ( NFRAGM .GE. 2 ) THEN JFIN=0 CALL VAPOR(IA,KNEW,JFIN,ITYP,PFRX,PFRY) IF ( JFIN .LE. 0 ) GOTO 190 KNEW = 0 DO 135 J = 1,JFIN EA = GAMMA * PAMA(ITYP(J)) IF (DEBUG) WRITE(MDEBUG,*) 'SDPM : J,ITYP,EA=', * J,ITYP,SNGL(EA) PTM = EA**2 - PAMA(ITYP(J))**2 PT2 = PFRX(J)**2 + PFRY(J)**2 IF ( PT2 .GE. PTM ) THEN IF (DEBUG) WRITE(MDEBUG,*) 'SDPM : PT REJECT ',J GOTO 135 ENDIF IF ( PTM .GT. 0.D0 ) THEN COSTET = SQRT( 1.D0 - PT2/PTM ) ELSE COSTET = 1.D0 ENDIF IF ( PFRX(J) .NE. 0.D0 .OR. PFRY(J) .NE. 0.D0 ) THEN PHIV = ATAN2( PFRY(J), PFRX(J) ) ELSE PHIV = 0.D0 ENDIF CALL ADDANG( COSTHE,PHI, COSTET,PHIV, * SECPAR(3),SECPAR(4) ) IF ( SECPAR(3) .GT. C(29) ) THEN IF ( J .LT. JFIN ) THEN SECPAR(1) = ITYP(J) CALL TSTACK ELSE KNEW = ITYP(JFIN) IANEW = KNEW/100 ENDIF ELSE IF (DEBUG) WRITE(MDEBUG,*) 'SDPM : ANGLE REJECT ',J IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + EA ENDIF ENDIF 135 CONTINUE ENDIF ENDIF C REMAINING NUCLEUS: MASS 5 CANNOT BE TREATED IN BOX2 IF ( KNEW/100 .EQ. 5 ) THEN IF ( MOD(KNEW,100) .GE. 3 ) THEN C MASS 5: SPLIT OFF ONE PROTON SECPAR(1) = 14.D0 CALL TSTACK KNEW = KNEW - 101 ELSE C MASS 5: SPLIT OFF ONE NEUTRON SECPAR(1) = 13.D0 CALL TSTACK KNEW = KNEW - 100 ENDIF C REMAINING NUCLEUS: MASS 8 CANNOT BE TREATED IN BOX2 ELSEIF ( KNEW/100 .EQ. 8 ) THEN IF ( MOD(KNEW,100) .GE. 5 ) THEN C MASS 8: SPLIT OFF ONE PROTON SECPAR(1) = 14.D0 CALL TSTACK KNEW = KNEW - 101 ELSEIF ( MOD(KNEW,100) .LE. 3 ) THEN C MASS 8: SPLIT OFF ONE NEUTRON SECPAR(1) = 13.D0 CALL TSTACK KNEW = KNEW - 100 ELSE C MASS 8: SPLIT OFF ONE ALPHA PARTICLE SECPAR(1) = 402.D0 CALL TSTACK KNEW = KNEW - 402 ENDIF ENDIF IF ( KNEW .GT. 0 ) THEN SECPAR(1) = KNEW CALL TSTACK IF ( DEBUG ) WRITE(MDEBUG,555) (SECPAR(I),I=1,9) 555 FORMAT (' SDPM : SECPAR=',1P,8E10.3,0P,F10.0) ENDIF ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C HERE THE REACTING NUCLEONS ARE TREATED 190 NPRPRO = INACTZ NNEPRO = INACTA - INACTZ IF ( DEBUG ) WRITE(MDEBUG,*) 'SDPM : REACTING PROTONS=', * NPRPRO,' NEUTRONS=',NNEPRO C TREAT INTERACTING NEUTRONS FROM PROJECTILE IF ( NNEPRO .GE. 1 ) THEN CURPAR(1) = 13.D0 ITYPE = 13 C CALCULATE GAMMA, BETA AND ENERGY IN CENTER OF MASS GCM = SQRT( GAMMA * 0.5D0 + 0.5D0 ) ECM = PAMA(ITYPE) * GCM * 2.D0 BETACM = SQRT( 1.D0 - 1.D0 / GCM**2 ) DO 200 LL = 1,NNEPRO IF ( ECM .LE. HILOECM ) THEN C USE GHEISHA AND CALCULATE THE CROSS-SECTION FOR GHEISHA ELAB = PAMA(ITYPE) * GAMMA PLAB = ELAB * BETA EKIN = ELAB - PAMA(ITYPE) SIGAIR = CGHSIG(SNGL(PLAB),SNGL(EKIN),ITYPE) IF ( DEBUG ) WRITE(MDEBUG,*) * 'SDPM : SIGAIR=',SNGL(SIGAIR) CALL CGHEI ELSE C DUAL PARTON MODEL CALL HDPM ENDIF 200 CONTINUE ENDIF C TREAT INTERACTING PROTONS FROM PROJECTILE IN SUBROUT. HDPM IF ( NPRPRO .GE. 1 ) THEN CURPAR(1) = 14.D0 ITYPE = 14 C CALCULATE GAMMA, BETA AND ENERGY IN CENTER OF MASS GCM = SQRT( GAMMA * 0.5D0 + 0.5D0 ) ECM = PAMA(ITYPE) * GCM * 2.D0 BETACM = SQRT( 1.D0 - 1.D0 / GCM**2 ) DO 210 LL = 1,NPRPRO IF ( ECM .LE. HILOECM ) THEN C USE GHEISHA AND CALCULATE THE CROSS-SECTION FOR GHEISHA ELAB = PAMA(ITYPE) * GAMMA PLAB = ELAB * BETA EKIN = ELAB - PAMA(ITYPE) SIGAIR = CGHSIG(SNGL(PLAB),SNGL(EKIN),ITYPE) IF ( DEBUG ) WRITE(MDEBUG,*) * 'SDPM : SIGAIR=',SNGL(SIGAIR) CALL CGHEI ELSE C DUAL PARTON MODEL CALL HDPM ENDIF 210 CONTINUE ENDIF C ALL PARTICLES, INCLUDING THE LEADING ONE, ARE NOW WRITTEN TO STACK ELSE WRITE(MONIOU,444) (CURPAR(I),I=1,9) WRITE(MONIOU,*) 'SDPM : NOT FORESEEN PARTICLE TYPE=',ITYPE STOP ENDIF RETURN END *CMZ : 15/06/2000 16.19.29 by D. HECK IK3 FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE SEKDAT( IJAHR,IMONA,ITAGE,ISTUN,IMINU,ISEKU ) C----------------------------------------------------------------------- C SEK(UNDEN) DAT(UM) C C GIVES TIME AND DATE ON UNIX IN UNIVERSAL TIME (UT) ON C UNIX(-LIKE) SYSTEMS. C LINKING WITH EXTRA TIMER FUNCTION MAY BE REQUIRED. C THIS SUBROUTINE IS CALLED FROM PRTIME. C ARGUMENTS: C IJAHR = YEAR C IMONA = MONTH C ITAGE = DAY C ISTUN = HOUR C IMINU = MINUTE C ISEKU = SECOND C C DESIGN : J. OEHLSCHLAEGER IK3 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE REAL RJAHR INTEGER I,IJAHR,ILANG,ILEAP,IMINU,IMONA,ISECO,ISEKU, * ISTUN,ITAGE INTEGER IMONS(13,4) SAVE DATA IMONS/ 0,31,59,90,120,151,181,212,243,273,304,334,365, + 0,31,60,91,121,152,182,213,244,274,305,335,366, + 0,31,28,31, 30, 31, 30, 31, 31, 30, 31, 30, 31, + 0,31,29,31, 30, 31, 30, 31, 31, 30, 31, 30, 31 / C----------------------------------------------------------------------- CALL TIMER( ISECO ) C SECONDS, MINUTS, HOURS, YEAR ISEKU = MOD(ISECO,60) ISECO = ISECO/60 IMINU = MOD(ISECO,60) ISECO = ISECO/60 ISTUN = MOD(ISECO,24) ISECO = ISECO/24 ITAGE = ISECO RJAHR = 2.73785E-3*ITAGE+1.4E-3 IJAHR = 1970 + INT(RJAHR) C LEAP DAYS ILEAP = 0 ILANG = 1 DO 1 I = 1970,IJAHR IF ( (MOD(I,4) .EQ. 0 .AND. MOD(I,100) .NE. 0 ) + .OR. MOD(I,400) .EQ. 0 ) THEN ILEAP = ILEAP + 1 IF ( I .EQ. IJAHR ) THEN ILANG = 2 ILEAP = ILEAP - 1 ENDIF ENDIF 1 CONTINUE ITAGE = ITAGE - INT(RJAHR)*365 - ILEAP + 1 IF ( I .EQ. IJAHR+4 .AND. ITAGE .LT. IMONS(3,2) ) ITAGE=ITAGE+1 C MONTH AND DAY DO 2 I = 2,13 IF ( IMONS(I,ILANG) .GT. ITAGE ) GOTO 3 2 CONTINUE 3 CONTINUE IMONA = I-1 ITAGE = ITAGE-IMONS(IMONA,ILANG) IF ( ITAGE .EQ. 0 ) THEN ITAGE = IMONS(IMONA,2+ILANG) IMONA = IMONA - 1 ENDIF RETURN END *CMZ : 01/03/2002 14.34.22 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE STAEND C----------------------------------------------------------------------- C STA(RT) END C C SUBROUTINE FOR GETTING THE CONTROL PRINTOUT OF THE CONSTANT ARRAYS C PRINT CONTROL OUTPUT C THIS SUBROUTINE IS CALLED FROM AAMAIN AND START. C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,ATMOS. COMMON /ATMOS/ AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM DOUBLE PRECISION AATM(5),AATM0(5,0:16),BATM(5),BATM0(5,0:16), * CATM(5),CATM0(5,0:16),DATM(5) INTEGER MODATM *KEEP,ATMOS2. COMMON /ATMOS2/ HLAY,HLAY0,THICKL,LAYNO,LAYNEW DOUBLE PRECISION HLAY(6),HLAY0(5,0:4),THICKL(5) INTEGER LAYNO(0:16) LOGICAL LAYNEW *KEEP,EDECAY. COMMON /EDECAY/ CETA DOUBLE PRECISION CETA(5) *KEEP,KAONS. COMMON /KAONS/ CKA DOUBLE PRECISION CKA(80) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,STRBAR. COMMON /STRBAR/ CSTRBA DOUBLE PRECISION CSTRBA(11) *KEEP,ATMOSX. C EXTERNAL ATMOSPHERIC MODELS COMMON /ATMOSX/ IATMOX,FREFRX INTEGER IATMOX LOGICAL FREFRX *KEND. DOUBLE PRECISION HEIGH INTEGER I SAVE EXTERNAL HEIGH C----------------------------------------------------------------------- C PRINT CONTROL OUTPUT WRITE(MONIOU,103) (C(I),I=1,50) 103 FORMAT (//' ',10('='),' CONSTANTS AND PARAMETERS ',43('=') * //' PHYSICAL CONSTANTS C(1) TO C(50)', * / (1P,4(E15.8,1X),E15.8) ) WRITE(MONIOU,110) (CKA(I),I=1,80) 110 FORMAT (//' CONSTANTS FOR KAONS CKA(1) TO CKA(80)' * / (1P,4(E15.8,1X),E15.8) ) WRITE(MONIOU,114) (CETA(I),I=1,5) 114 FORMAT (//' CONSTANTS FOR ETAS CETA(1) TO CETA(5)' * / (1P,4(E15.8,1X),E15.8) ) WRITE(MONIOU,115) (CSTRBA(I),I=1,11) 115 FORMAT (//' CONSTANTS FOR STRANGE BARYONS CSTRBA(1) TO ', * 'CSTRBA(11)'/ (1P,4(E15.8,1X),E15.8) ) WRITE(MONIOU,200) 200 FORMAT(//' ',10('='),' ATMOSPHERE ', 57('=')/ ) IF ( IATMOX .GE. 1 ) THEN WRITE(MONIOU,299) IATMOX 299 FORMAT(' ( EXTERNAL ATMOSPHERE FROM TABLE',I3,' AS FITTED )'/) ELSEIF ( MODATM .EQ. 0 ) THEN WRITE(MONIOU,300) 300 FORMAT(' ( ATMOSPHERE GIVEN BY INPUT (LAYER 5 UNCHANGED)') ELSEIF ( MODATM .EQ. 1 ) THEN WRITE(MONIOU,301) 301 FORMAT(' ( US STANDARD ATMOSPHERE PARAMETRIZED BY LINSLEY )') ELSEIF ( MODATM .EQ. 2 ) THEN WRITE(MONIOU,302) 302 FORMAT(' ( ATMOSPHERE AT115 PARAMETRIZED BY H. ULRICH )') ELSEIF ( MODATM .EQ. 3 ) THEN WRITE(MONIOU,303) 303 FORMAT(' ( ATMOSPHERE AT223 PARAMETRIZED BY H. ULRICH )') ELSEIF ( MODATM .EQ. 4 ) THEN WRITE(MONIOU,304) 304 FORMAT(' ( ATMOSPHERE AT511 PARAMETRIZED BY H. ULRICH )') ELSEIF ( MODATM .EQ. 5 ) THEN WRITE(MONIOU,305) 305 FORMAT(' ( ATMOSPHERE AT616 PARAMETRIZED BY H. ULRICH )') ELSEIF ( MODATM .EQ. 6 ) THEN WRITE(MONIOU,306) 306 FORMAT(' ( ATMOSPHERE AT822 PARAMETRIZED BY H. ULRICH )') ELSEIF ( MODATM .EQ. 7 ) THEN WRITE(MONIOU,307) 307 FORMAT(' ( ATMOSPHERE AT1014 PARAMETRIZED BY H. ULRICH )') ELSEIF ( MODATM .EQ. 8 ) THEN WRITE(MONIOU,308) 308 FORMAT(' ( ATMOSPHERE AT1224 PARAMETRIZED BY H. ULRICH )') ELSEIF ( MODATM .EQ. 9 ) THEN WRITE(MONIOU,309) 309 FORMAT(' ( ATMOSPHERE GIVEN BY INPUT (LAYER 5 UNCHANGED)') ELSEIF ( MODATM .EQ. 10 ) THEN WRITE(MONIOU,310) 310 FORMAT(' ( ATMOSPHERE GIVEN BY INPUT (LAYER 5 CHANGED) )') ELSEIF ( MODATM .EQ. 11 ) THEN WRITE(MONIOU,311) 311 FORMAT(' ( SOUTH POLE ATMOSPHERE FOR 97MAR31 (MSIS-90-E) )') ELSEIF ( MODATM .EQ. 12 ) THEN WRITE(MONIOU,312) 312 FORMAT(' ( SOUTH POLE ATMOSPHERE FOR 97JUL01 (MSIS-90-E) )') ELSEIF ( MODATM .EQ. 13 ) THEN WRITE(MONIOU,313) 313 FORMAT(' ( SOUTH POLE ATMOSPHERE FOR 97OCT01 (MSIS-90-E) )') ELSEIF ( MODATM .EQ. 14 ) THEN WRITE(MONIOU,314) 314 FORMAT(' ( SOUTH POLE ATMOSPHERE FOR 97DEC31 (MSIS-90-E) )') ELSEIF ( MODATM .EQ. 15 ) THEN WRITE(MONIOU,315) 315 FORMAT(' ( SOUTH POLE ATMOSPHERE FOR JANUARY, LIPARI(GS) )') ELSEIF ( MODATM .EQ. 16 ) THEN WRITE(MONIOU,316) 316 FORMAT(' ( SOUTH POLE ATMOSPHERE FOR AUGUST, LIPARI(GS) )') ENDIF WRITE(MONIOU,400) (HLAY(I)*1.D-6,HLAY(I+1)*1.D-6, * AATM(I),BATM(I),CATM(I)*1.E-5,I=1,4), * HLAY(5)*1.D-6,HLAY(6)*1.D-6, AATM(5),CATM(5)*1.E-5 400 FORMAT(' HEIGHT H IN KM GIVES THICKNESS OF ATMOSPHERE T IN ', * 'G/CM**2'/1P,' H = ',F5.1,'...',F5.1,' KM ---> T = ', * E12.5,' +',E11.4,' * EXP( -H /',E11.4,')'/ * ' H = ',F5.1,'...',F5.1,' KM ---> T = ', * E12.5,' +',E11.4,' * EXP( -H /',E11.4,')'/ * ' H = ',F5.1,'...',F5.1,' KM ---> T = ', * E12.5,' +',E11.4,' * EXP( -H /',E11.4,')'/ * ' H = ',F5.1,'...',F5.1,' KM ---> T = ', * E12.5,' +',E11.4,' * EXP( -H /',E11.4,')'/ * ' H = ',F5.1,'...',F5.1,' KM ---> T = ', * E12.5,' - H /',E11.4 ) RETURN END *CMZ : 01/03/2002 14.34.22 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE START C----------------------------------------------------------------------- C START C C PRINTS HEADER AND ALL SELECTED OPTIONS C PERFORMS INITIALIZATIONS AND CHECKS AT THE BEGINNING OF RUN. C CALLS DATAC TO READ IN DATA CARDS. C INITIALIZES ATMOSPHERIC MODELS C CHECKS AND INITIALIZES SELECTED HADRONIC INTERACTION MODEL. C THIS SUBROUTINE IS CALLED FROM AAMAIN. C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,AIR. COMMON /AIR/ COMPOS,PROBTA,AVERAW,AVOGAD DOUBLE PRECISION COMPOS(3),PROBTA(3),AVERAW,AVOGAD *KEEP,ATMOS. COMMON /ATMOS/ AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM DOUBLE PRECISION AATM(5),AATM0(5,0:16),BATM(5),BATM0(5,0:16), * CATM(5),CATM0(5,0:16),DATM(5) INTEGER MODATM *KEEP,ATMOS2. COMMON /ATMOS2/ HLAY,HLAY0,THICKL,LAYNO,LAYNEW DOUBLE PRECISION HLAY(6),HLAY0(5,0:4),THICKL(5) INTEGER LAYNO(0:16) LOGICAL LAYNEW *KEEP,BUFFS. COMMON /BUFFS/ RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH INTEGER MAXBUF,MAXLEN PARAMETER (MAXLEN=16) PARAMETER (MAXBUF=39*7) REAL RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF), * RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF) INTEGER LH CHARACTER*4 CRUNH,CRUNE,CEVTH,CEVTE,CLONG EQUIVALENCE (RUNH(1),CRUNH), (RUNE(1),CRUNE) EQUIVALENCE (EVTH(1),CEVTH), (EVTE(1),CEVTE) EQUIVALENCE (ARRAYLONG(1),CLONG) *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,DPMFLG. COMMON /DPMFLG/ NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM INTEGER NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM *KEEP,EDECAY. COMMON /EDECAY/ CETA DOUBLE PRECISION CETA(5) *KEEP,ELABCT. COMMON /ELABCT/ ELCUT DOUBLE PRECISION ELCUT(4) *KEEP,ETHMAP. COMMON /ETHMAP/ ECTMAP,ELEFT DOUBLE PRECISION ECTMAP,ELEFT *KEEP,KAONS. COMMON /KAONS/ CKA DOUBLE PRECISION CKA(80) *KEEP,MAGNET. COMMON /MAGNET/ BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT DOUBLE PRECISION BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT *KEEP,MUMULT. COMMON /MUMULT/ CHC,OMC,PHISCT,STEPL,VSCAT,FMOLI DOUBLE PRECISION CHC,OMC,PHISCT,STEPL,VSCAT LOGICAL FMOLI *KEEP,MUPART. COMMON /MUPART/ AMUPAR,BCUT,CMUON,FMUBRM,FMUORG DOUBLE PRECISION AMUPAR(16),BCUT,CMUON(11) LOGICAL FMUBRM,FMUORG *KEEP,NCSNCS. COMMON /NCSNCS/ SIGN30,SIGN45,SIGN60,SIGO30,SIGO45,SIGO60, * SIGA30,SIGA45,SIGA60,PNOA30,PNOA45,PNOA60, * SIG30A,SIG45A,SIG60A DOUBLE PRECISION SIGN30(56),SIGN45(56),SIGN60(56), * SIGO30(56),SIGO45(56),SIGO60(56), * SIGA30(56),SIGA45(56),SIGA60(56), * PNOA30(1540,3),PNOA45(1540,3),PNOA60(1540,3), * SIG30A(56),SIG45A(56),SIG60A(56) *KEEP,NKGI. COMMON /NKGI/ SEL,SELLG,STH,ZEL,ZELLG,ZSL,DIST, * DISX,DISY,DISXY,DISYX,DLAX,DLAY,DLAXY,DLAYX, * OBSATI,RADNKG,RMOL,TLEV,TLEVCM,IALT DOUBLE PRECISION SEL(10),SELLG(10),STH(10),ZEL(10),ZELLG(10), * ZSL(10),DIST(10), * DISX(-10:10),DISY(-10:10), * DISXY(-10:10,2),DISYX(-10:10,2), * DLAX (-10:10,2),DLAY (-10:10,2), * DLAXY(-10:10,2),DLAYX(-10:10,2), * OBSATI(2),RADNKG,RMOL(2),TLEV(10),TLEVCM(10) INTEGER IALT(2) *KEEP,OBSPAR. COMMON /OBSPAR/ OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP, * THETPR,PHIPR, * VUECON, * NOBSLV DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10), * HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2) DOUBLE PRECISION VUECON(2) INTEGER NOBSLV *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,PRIMSP. COMMON /PRIMSP/ PSLOPE,LLIMIT,ULIMIT,LL,UL,SLEX,ISPEC DOUBLE PRECISION PSLOPE,LLIMIT,ULIMIT,LL,UL,SLEX INTEGER ISPEC *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,STACKF. COMMON /STACKF/ STACK,MSTACKP,MEXST,NSHIFT,NOUREC,ICOUNT, * NTO,NFROM INTEGER MAXSTK PARAMETER (MAXSTK = 16*256*2) DOUBLE PRECISION STACK(MAXSTK) INTEGER MSTACKP,MEXST,NSHIFT,NOUREC,ICOUNT,NTO,NFROM *KEEP,STRBAR. COMMON /STRBAR/ CSTRBA DOUBLE PRECISION CSTRBA(11) *KEEP,VERS. COMMON /VERS/ VERNUM,MVDATE,VERDAT DOUBLE PRECISION VERNUM INTEGER MVDATE CHARACTER*18 VERDAT *KEEP,VENUS. COMMON /VENUS/ ISH00,IVERVN,MTAR99,FVENUS,FVENSG INTEGER ISH00,IVERVN,MTAR99 LOGICAL FVENUS,FVENSG *KEEP,CEREN3. COMMON /CEREN3/ CERCNT,DATAB2,NRECER,LHCER INTEGER MAXBF2 PARAMETER ( MAXBF2 = 39 * 7 ) DOUBLE PRECISION CERCNT REAL DATAB2(MAXBF2) INTEGER NRECER,LHCER *KEEP,ATMOSX. C EXTERNAL ATMOSPHERIC MODELS COMMON /ATMOSX/ IATMOX,FREFRX INTEGER IATMOX LOGICAL FREFRX *KEND. DOUBLE PRECISION HEIGH,OOO,SE,TEMP1,TEMP2,TEMP3,THICK, * TTIME,ZE,ZS,ZX INTEGER I,IA,J,L SAVE EXTERNAL HEIGH,THICK CHARACTER*1 MARK C----------------------------------------------------------------------- C SAY HELLO WRITE(MONIOU,112) 112 FORMAT(/' ',80('A')// *' OOO OOO OOOO OOOO OO O O O '/ *' O O O O O O O O OO O O O O '/ *' O O O O O O OO O O O O '/ *' O O O O O OOOO OO OO O O'/ *' O O O OOOO O OO O O OOOOOOO'/ *' O O O O O O O O OO O O O O'/ *' OOO OOO O O OOOO OO O O O O'// *' COSMIC RAY SIMULATION FOR KASCADE'// *' A PROGRAM TO SIMULATE EXTENSIVE AIR SHOWERS IN ATMOSPHERE'// *' BASED ON A PROGRAM OF P.K.F. GRIEDER, UNIVERSITY BERN,', *' SWITZERLAND'/ *' VENUS MODEL ACCORDING TO K. WERNER, UNIVERSITY NANTES, FRANCE'/ *' HDPM MODEL ACCORDING TO J.N. CAPDEVIELLE, COLLEGE DE FRANCE,', *' PARIS, FRANCE'/ *' GHEISHA ROUTINES ACCORDING TO H. FESEFELDT, RWTH AACHEN,', *' GERMANY'/ *' EGS4 ACCORDING TO W.R. NELSON, H. HIRAYAMA, D.W.O. ROGERS,', *' SLAC, STANFORD, USA'/ *' NKG FORMULAS FOR FAST SIMULATION OF EL.MAG. PARTICLES'// *' REFERENCES: D. HECK, J.KNAPP, J.N. CAPDEVIELLE, G. SCHATZ,', * ' T. THOUW,'/' REPORT FZKA 6019 (1998)'/ *' J. KNAPP, D. HECK, G. SCHATZ, REPORT FZKA', * ' 5828 (1996)'/ *' SEE ALSO WEB PAGE http://www-ik3.fzk.de/', * '~heck/corsika'//) MARK = '1' WRITE(MONIOU,912) VERNUM,MARK,VERDAT 912 FORMAT(' INSTITUT FUER KERNPHYSIK '/ * ' FORSCHUNGSZENTRUM KARLSRUHE'/ * ' POSTFACH 3640'/ * ' D-76021 KARLSRUHE'/ * ' GERMANY'// * ' IN CASE OF PROBLEMS CONTACT: DIETER HECK '/ * ' E-MAIL: DIETER.HECK@IK.FZK.DE'/ * ' FAX: (49) 7247-82-4075 '/ * ' PHONE: (49) 7247-82-3777 '// * ' NUMBER OF VERSION : ',F6.3,A1/ * ' DATE OF VERSION : ',A18 /) WRITE(MONIOU,*) 'VERSION GENERATED FOR UNIX OR COMPATIBLE SYSTEMS' WRITE(MONIOU,*) '^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^' WRITE(MONIOU,*) ' (RECL IS DEFINED IN BYTES)' WRITE(MONIOU,*) ' WITH TIMERC DATE ROUTINE' WRITE(MONIOU,*) ' ' WRITE(MONIOU,1413) 1413 FORMAT(/' INTERFACE FOR EXTERNAL ATMOSPHERIC PROFILES ENABLED'/ * ' ==================================================='/) WRITE(MONIOU,*) ' ' WRITE(MONIOU,141) 141 FORMAT(/' CHERENKOV RADIATION IS GENERATED'/ * ' ================================'/) WRITE(MONIOU,*) ' ' WRITE(MONIOU,119) 119 FORMAT(/' CURVED VERSION WITH SLIDING PLANAR ATMOSPHERE'/ * ' ============================================='/) WRITE(MONIOU,1432) 1432 FORMAT(/' PRIMARY DIRECTION IS SELECTED FROM VIEWING CONE'/ * ' ==============================================='/) WRITE(MONIOU,*) 'ZENITH ANGLE DEPENDENCE FOR FLAT DETECTOR ARRAY' WRITE(MONIOU,*) ' ' WRITE(MONIOU,*) ' ' C C INITIALIZE ARRAY WITH PARTICLE MASSES CALL PAMAF C READ RUN STEERING DATA CARDS CALL DATAC IF ( FREFRX ) WRITE(MONIOU,144) 144 FORMAT(/' ATMOSPHERIC REFRACTION IS TAKEN INTO ACCOUNT'/ * ' ============================================'/) WRITE(MONIOU,1441) 1441 FORMAT(/) C ORDERING OF OBSERVATION LEVELS FROM TOP TO BOTTOM IF ( NOBSLV .GT. 1 ) THEN 215 CONTINUE DO 11 I = 2,NOBSLV IF ( OBSLEV(I) .GT. OBSLEV(I-1) ) THEN OOO = OBSLEV(I) OBSLEV(I) = OBSLEV(I-1) OBSLEV(I-1) = OOO GOTO 215 ENDIF 11 CONTINUE ENDIF C PREPARE ATMOSPHERIC MODEL IF ( MODATM .LT. 0 .OR. MODATM .GT. 16 ) THEN WRITE(MONIOU,*) 'START: MODATM < 0 OR > 16 NOT POSSIBLE! STOP' WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: ATMOD' STOP ENDIF C SET LOWER BOUNDARIES OF THE AIR LAYERS IF ( LAYNEW ) THEN C TAKE THE BOUNDARIES READ IN I = 0 ELSE C TAKE THE DEFAULT BOUNDARIES I = LAYNO(MODATM) ENDIF C SET THE SELECTED ATMOSPHERE AND LAYERS DO L = 1,5 HLAY(L) = HLAY0(L,I) AATM(L) = AATM0(L,MODATM) BATM(L) = BATM0(L,MODATM) CATM(L) = CATM0(L,MODATM) DATM(L) = 1.D0 / CATM(L) ENDDO C SET THE ATMOSPHERIC MODEL NUMBER, READING AN EXTERNAL FILE IF NEEDED. C PARAMETERS FOR TAKING REFRACTION INTO ACCOUNT ARE CALCULATED EVEN C FOR CORSIKA BUILT-IN MODELS. IF ( IATMOX .GE. 1 .OR. FREFRX ) THEN CALL ATMSET(IATMOX,OBSLEV(NOBSLV)) ENDIF C FOR AN EXTERNAL ATMOSPHERE, FIT PARAMETERS USED IN CORSIKA-EGS PART. IF ( IATMOX .GE. 1 ) THEN IF ( LAYNEW ) THEN CALL ATMFIT(-5,HLAY,AATM,BATM,CATM) ELSE CALL ATMFIT(5,HLAY,AATM,BATM,CATM) ENDIF DO L = 1,5 DATM(L) = 1.D0 / CATM(L) ENDDO ENDIF C CALCULATE THICKNESS AT LOWER BOUNDARIES OF AIR LAYERS DO 100 L = 1,5 THICKL(L) = THICK(HLAY(L)) 100 CONTINUE HLAY(6) = HEIGH(0.D0) IF ( DEBUG ) WRITE(MDEBUG,99) $ (L,HLAY(L),THICKL(L),L=1,5),HLAY(6) 99 FORMAT(' START : ATMOSPHERIC LAYERS',/, $ ' NR. HLAY (CM) THICKL (G/CM**2)',/, $ 5(8X,I3,' ',F11.2,' ',F12.5,/), $ 8X,' 6 ',F11.2,' 0.00000') C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C CLEARS BUFFERS FOR HEADER AND FILLS IN PERMANENT INFORMATION DO 889 L = 1,MAXBUF EVTH(L) = 0. EVTE(L) = 0. RUNH(L) = 0. RUNE(L) = 0. DATAB(L) = 0. ARRAYLONG(L) = 0. DATAB2(L) = 0. 889 CONTINUE C PERMANENT INFORMATION C CHARACTER STRINGS CRUNH = 'RUNH' CRUNE = 'RUNE' CEVTH = 'EVTH' CEVTE = 'EVTE' CLONG = 'LONG' RUNH(2) = NRRUN RUNE(2) = NRRUN EVTH(44) = NRRUN C DATE OF RUN WRITE(MONIOU,101) 101 FORMAT(/' ',10('='),' START OF RUN ',55('=')/) CALL PRTIME(TTIME) RUNH(3) = TTIME EVTH(45) = TTIME C VERSION OF PROGRAM RUNH(4) = VERNUM EVTH(46) = VERNUM C----------------------------------------------------------------------- C INITIALIZATION FOR RANDOM NUMBER GENERATOR IF ( FEGS .AND. NSEQ .LT. 2 ) NSEQ = 2 C CHERENKOV SELECTION DEMANDS ALWAYS EGS CALCULATION FEGS = .TRUE. C IN CASE OF CHERENKOV CALCULATIONS THE 3. RANDOM SEQUENCE IS NEEDED IF ( NSEQ .LT. 3 ) NSEQ = 3 DO 281 I = 1,NSEQ IF ( .NOT. DEBUG .AND. .NOT. DEBDEL .AND. * (ISEED(2,I) .GT. 1000 .OR. ISEED(3,I) .GT. 0) ) THEN WRITE(MONIOU,2811) I 2811 FORMAT(/' #########################################'/ * ' ## IMPROPER INITIALIZATION OF RANDOM ##'/ * ' ## NUMBER GENERATOR SEQUENCE',I6,' ##'/ * ' ## IS EXTREMELY TIME CONSUMING ##'/ * ' ## PLEASE READ THE USERS GUIDE ##'/ * ' ## SEE KEYWORD: SEED ##'/ * ' #########################################'/) ELSE ENDIF CALL RMMAQ( ISEED(1,I), I, 'S' ) 281 CONTINUE KNOR = .TRUE. WRITE(MONIOU,158) (L,(ISEED(J,L),J=1,3),L=1,NSEQ) 158 FORMAT (' RANDOM NUMBER GENERATOR AT BEGIN OF RUN :'/ * (' SEQUENCE = ',I2,' SEED = ',I9,' CALLS = ',I9, * ' BILLIONS = ',I9)) C----------------------------------------------------------------------- C READ CROSS-SECTIONS AND PROBABILITIES FOR NUCLEUS-NUCLEUS COLLISIONS OPEN(UNIT=NUCNUC,FILE='NUCNUCCS',STATUS='OLD') READ(NUCNUC,500) SIGN30,SIGN45,SIGN60,SIGO30,SIGO45,SIGO60, * SIGA30,SIGA45,SIGA60 READ(NUCNUC,500) (PNOA30(I,1),I=1,1540),(PNOA45(I,1),I=1,1540), * (PNOA60(I,1),I=1,1540),(PNOA30(I,2),I=1,1540), * (PNOA45(I,2),I=1,1540),(PNOA60(I,2),I=1,1540), * (PNOA30(I,3),I=1,1540),(PNOA45(I,3),I=1,1540), * (PNOA60(I,3),I=1,1540) 500 FORMAT( 5E16.10 ) CLOSE(UNIT=NUCNUC) C INELASTIC CROSS-SECTIONS FOR PROJECTICLE WITH MASS NUMBER IA DO 501 IA = 1,56 SIG30A(IA) = COMPOS(1)*SIGN30(IA) + COMPOS(2)*SIGO30(IA) * + COMPOS(3)*SIGA30(IA) SIG45A(IA) = COMPOS(1)*SIGN45(IA) + COMPOS(2)*SIGO45(IA) * + COMPOS(3)*SIGA45(IA) SIG60A(IA) = COMPOS(1)*SIGN60(IA) + COMPOS(2)*SIGO60(IA) * + COMPOS(3)*SIGA60(IA) IF (DEBUG) WRITE(MDEBUG,544) IA,SIG30A(IA),SIG45A(IA),SIG60A(IA) 544 FORMAT(' START : CROSS-SECTIONS A-AIR : A=',I2,1P,3E14.6) 501 CONTINUE WRITE(MONIOU,503) 503 FORMAT (//' ',10('='),' INTERACTION MODELS ',49('=')) C HIGH ENERGY HADRONIC INTERACTION MODEL IF ( FVENUS ) THEN WRITE(MONIOU,*) 'VENUS TREATS HIGH ENERGY HADRONIC INTERACTIONS' CALL VENINI IF ( FVENSG ) THEN WRITE(MONIOU,*) WRITE(MONIOU,*) 'VENUS CROSS-SECTIONS ARE TAKEN' CALL VENSIGINI ENDIF ELSE IF ( FVENSG ) THEN WRITE(MONIOU,*) WRITE(MONIOU,*) 'VENUS CROSS-SECTIONS ARE TAKEN' CALL VENSIGINI ENDIF WRITE(MONIOU,1506) ENDIF 1506 FORMAT(' HDPM ROUTINES TREAT HIGH ENERGY HADRONIC INTERACTIONS') IF ( .NOT. FVENUS ) THEN C INPUT FLAGS FOR HDPM OPTIONS WRITE(MONIOU,*) 'HDPM GENERATOR SPECIFICATIONS ARE:' IF ( NFLAIN .EQ. 0 ) THEN WRITE(MONIOU,*) ' RANDOM NUMBER OF INTERACTIONS IN AIR TARGET' IF ( NFLDIF .EQ. 0 ) THEN WRITE(MONIOU,*) ' NO DIFFRACTIVE SECOND INTERACTIONS' ELSE WRITE(MONIOU,*) ' DIFFRACTIVE SECOND INTERACTIONS' ENDIF ELSE WRITE(MONIOU,*) ' FIXED NUMBER OF INTERACTIONS IN AIR TARGET' ENDIF IF ( NFLPI0 .EQ. 0 ) THEN WRITE(MONIOU,*) ' RAPIDITY OF PI0 ACCORDING TO COLLIDER DATA' ELSE WRITE(MONIOU,*) ' RAPIDITY OF PI0 SAME AS THAT OF CHARGED' ENDIF IF ( NFLPIF .EQ. 0 ) THEN WRITE(MONIOU,*) ' NO FLUCTUATIONS OF NUMBER OF PI0' ELSE WRITE(MONIOU,*) ' FLUCTUATIONS OF NUMBER OF PI0 AS MEASURED ', * 'AT THE COLLIDER' ENDIF IF ( NFLCHE .EQ. 0 ) THEN WRITE(MONIOU,*) ' CHARGE EXCHANGE INTERACTION POSSIBLE ' ELSE WRITE(MONIOU,*) ' NO CHARGE EXCHANGE INTERACTION POSSIBLE ' ENDIF ENDIF IF ( NFRAGM .EQ. 0 ) THEN WRITE(MONIOU,*) ' TOTAL FRAGMENTION OF PRIMARY NUCLEUS IN ', * 'FIRST INTERACTION' ELSEIF ( NFRAGM .EQ. 1 ) THEN WRITE(MONIOU,*) ' NO FRAGMENTATION, NO EVAPORATION OF REMAINDER' ELSEIF ( NFRAGM .EQ. 2 ) THEN WRITE(MONIOU,1504) 1504 FORMAT(' NO FRAGMENTATION, EVAPORATION OF REMAINDER ', * ' (PT AFTER JACEE)') ELSEIF ( NFRAGM .EQ. 3 ) THEN WRITE(MONIOU,1505) 1505 FORMAT(' NO FRAGMENTATION, EVAPORATION OF REMAINDER ', * ' (PT AFTER GOLDHABER)') ELSEIF ( NFRAGM .EQ. 4 ) THEN WRITE(MONIOU,1507) 1507 FORMAT(' NO FRAGMENTATION, EVAPORATION OF REMAINDER ', * ' (WITH PT = 0.)') ELSE NFRAGM = 4 WRITE(MONIOU,1507) ENDIF WRITE(MONIOU,*) C LOW ENERGY HADRONIC INTERACTION MODEL WRITE(MONIOU,*) 'GHEISHA TREATS LOW ENERGY HADRONIC ', * 'INTERACTIONS' CALL CGHINI C WRITE HADRONIC STEERING FLAGS TO RUNHEADER RUNH(270) = NFLAIN RUNH(271) = NFLDIF RUNH(272) = NFLPI0 + 100. * NFLPIF RUNH(273) = NFLCHE + 100. * NFRAGM EVTH(65) = NFLAIN EVTH(66) = NFLDIF EVTH(67) = NFLPI0 EVTH(68) = NFLPIF EVTH(69) = NFLCHE EVTH(70) = NFRAGM HILOECM = SQRT(2.D0*PAMA(14)*(PAMA(14) + HILOELB)) IF ( DEBUG ) THEN WRITE(MDEBUG,1509) HILOELB,HILOECM 1509 FORMAT(' START: HIGH ENERGY INTERACTION MODEL USED ABOVE ', * F8.3,' GEV LAB ENERGY OR',/ * 50X,F8.3,' GEV CM ENERGY') ELSE WRITE(MONIOU,1510) HILOELB,HILOECM 1510 FORMAT(' HIGH ENERGY INTERACTION MODEL USED ABOVE ', * F8.3,' GEV LAB ENERGY OR',/ * 43X,F8.3,' GEV CM ENERGY') ENDIF C----------------------------------------------------------------------- C INITIALIZE CONSTANTS FOR MUON MULTIPLE SCATTERING (MOLIERE) C SEE SUBROUT. GMOLI OF GEANT321 (CERN) IF ( FMOLI ) THEN TEMP1 = COMPOS(1) * 7.D0 * 8.D0 TEMP2 = COMPOS(2) * 8.D0 * 9.D0 TEMP3 = COMPOS(3) * 18.D0 * 19.D0 ZS = TEMP1 + TEMP2 + TEMP3 ZE = (-TB3)*(TEMP1*LOG(7.D0)+TEMP2*LOG(8.D0)+TEMP3*LOG(18.D0)) ZX = TEMP1*LOG(1.D0 + 3.34D0 * ( 7.D0/C(50))**2) * +TEMP2*LOG(1.D0 + 3.34D0 * ( 8.D0/C(50))**2) * +TEMP3*LOG(1.D0 + 3.34D0 * (18.D0/C(50))**2) C NOTE: CHC IS DEFINED DIFFERENT FROM GEANT WITHOUT DENSITY CHC = 0.39612D-3 * SQRT(ZS/AVERAW) C NOTE: OMC IS DEFINED DIFFERENT FROM GEANT WITHOUT DENSITY OMC = 6702.33D0 * (ZS/AVERAW) * EXP( (ZE-ZX)/ZS ) EVTH(146) = 1. WRITE(MONIOU,*) 'MUON MULTIPLE SCATTERING AFTER MOLIERE' ELSE EVTH(146) = 0. WRITE(MONIOU,*)'MUON MULTIPLE SCATTERING IN GAUSS APPROXIMATION' ENDIF C----------------------------------------------------------------------- C INPUT STEERING FLAGS FOR ELECTROMAGNETIC PART WRITE(MONIOU,*) IF ( FNKG ) THEN WRITE(MONIOU,121) 121 FORMAT(' ######################################################' * ,/, ' # SIMULATION WITH NKG NOT POSSIBLE IN CURVED VERSION #' * ,/, ' ######################################################' * ,/ ) FNKG = .FALSE. ENDIF IF ( FEGS ) THEN WRITE(MONIOU,*) 'ELECTROMAGNETIC COMPONENT SIMULATED WITH EGS4' WRITE(MONIOU,*) ENDIF IF ( .NOT. (FNKG .OR. FEGS) ) WRITE(MONIOU,*) * 'ELECTROMAGNETIC COMPONENT IS NOT SIMULATED' IF ( FEGS ) THEN IF ( STEPFC .GT. 10.D0 .OR. STEPFC .LE. 0.D0 ) THEN WRITE(MONIOU,*) 'STEP LENGTH FACTOR FOR ELECTRON MULTIPLE ', * 'SCATTERING =',SNGL(STEPFC),' NOT CORRECT' WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: STEPFC' STOP ENDIF IF ( STEPFC .LT. 10.D0 ) WRITE(MONIOU,*)'STEP LENGTH ', * 'FACTOR FOR ELECTRON MULTIPLE SCATTERING =',SNGL(STEPFC) C INITIALIZE EGS4 PACKAGE CALL EGSINI ENDIF C WRITE STEERING FLAGS FOR ELECTROMAGNETIC PART AS REAL TO HEADER IF ( FNKG ) THEN RUNH(20) = 1. EVTH(74) = 1. ELSE RUNH(20) = 0. EVTH(74) = 0. ENDIF IF ( FEGS ) THEN RUNH(19) = 1. EVTH(73) = 1. ELSE RUNH(19) = 0. EVTH(73) = 0. ENDIF EVTH(95) = STEPFC C PROGRAM CONFIGURATIONS FOR EVENT HEADER EVTH(75) = 1. IF ( FVENUS ) THEN EVTH(76) = 1. ELSE EVTH(76) = 0. ENDIF EVTH(139) = 0. EVTH(140) = 0. EVTH(141) = 0. EVTH(142) = 0. EVTH(143) = 0. EVTH(144) = 0. IF ( FVENSG ) THEN EVTH(145) = 1. ELSE EVTH(145) = 0. ENDIF EVTH(153) = VUECON(1) EVTH(154) = VUECON(2) C --------------------------------------------------------- C ELEMENT 77 OF EVENT HEADER HAS THE FOLLOWING CONTENTS IF C CONVERTED TO AN INTEGER WITH SUITABLE ROUNDING APPLIED: C BIT 1: CERENKOV OPTION COMPILED IN C 2: IACT OPTION COMPILED IN C 3: CEFFIC OPTION COMPILED IN C 4: ATMEXT OPTION COMPILED IN C 5: ATMEXT OPTION USED WITH REFRACTION ENABLED C 6: VOLUMEDET OPTION COMPILED IN C 7: CURVED OPTION COMPILED IN (SEE ALSO EVTH(79)) C 11-21: TABLE NUMBER FOR EXTERNAL ATMOSPHERE TABLE C (BUT LIMITED TO 1023 IF THE NUMBER IS LARGER) C -------------------------------------------------------- EVTH(77) = 1. EVTH(77) = EVTH(77) + 8. IF ( FREFRX ) EVTH(77) = EVTH(77) + 16. EVTH(77) = EVTH(77) + 1024. * MIN(IATMOX,1023) EVTH(77) = EVTH(77) + 64. EVTH(78) = 0. EVTH(79) = 2. EVTH(80) = 3. C----------------------------------------------------------------------- C PHYSICAL CONSTANTS PI = 2.D0 * ACOS(0.D0) PI2 = 4.D0 * ACOS(0.D0) OB3 = 1.D0/3.D0 TB3 = 2.D0/3.D0 ENEPER = EXP(1.D0) C(6) = ( PAMA(5) / PAMA(11) )**2 C(7) = ( PAMA(5) / PAMA(8) )**2 C(8) = ( PAMA(5)**2 + PAMA(2)**2 ) * 0.5D0 / PAMA(5) C(20) = 10.D0 * C(21) C(27) = COS( C(26) ) C(29) = COS( C(28) ) C CALCULATE CONSTANT FOR MAXIMAL HORIZONTAL RANGE WITHIN LOCAL SYSTEM C(4) = (C(2)-C(3)) / THICK(0.D0) C EXTEND ANGULAR CUT UP TO HORIZONTAL FOR CURVED VERSION C(29) = 1.D-15 C(45) = PAMA(8) * PAMA(14) * 2.D0 C(46) = PAMA(8)**2 + PAMA(14)**2 C(48) = (PAMA(8)**2 + PAMA(5)**2) / (2.D0*PAMA(8)*PAMA(5)) C(49) = SQRT(C(48)**2 - 1.D0) / C(48) CKA(13) = 2.D0 * PAMA(11) * PAMA(14) CKA(14) = PAMA(11)**2 + PAMA(14)**2 CKA(17) = SQRT( ( (PAMA(11)**2 + PAMA(5)**2) * / (2.D0*PAMA(11)) )**2 - PAMA(5)**2 ) CKA(18) = SQRT( ( (PAMA(11)**2 + PAMA(8)**2 - PAMA(7)**2) * / (2.D0*PAMA(11)) )**2 - PAMA(8)**2 ) CKA(28) = SQRT(1.D0 + CKA(17)**2/PAMA(5)**2) CKA(29) = SQRT(1.D0 - 1.D0/CKA(28)**2) CKA(30) = SQRT(1.D0 + CKA(18)**2/PAMA(8)**2) CKA(31) = SQRT(1.D0 - 1.D0/CKA(30)**2) CKA(41) = PAMA(16) CKA(42) = (PAMA(11)**2 + PAMA(7)**2 - PAMA(8)**2) / * (2.D0*PAMA(11)*PAMA(7)) CKA(43) = CKA(41) / (2.D0*PAMA(7)) CKA(44) = SQRT(1.D0 - 1.D0/CKA(43)**2) CKA(45) = CKA(41) / (2.D0*PAMA(8)) CKA(46) = SQRT(1.D0 - 1.D0/CKA(45)**2) C SET CONSTANTS FOR MUON BREMSSTRAHLUNG C SET BCUT WELL BELOW 21 MEV * BCUT = MIN( ELCUT(3), 100.D0*PAMA(5) ) C BCUT IS FIXED, AS PARAMETRIZATION IN BOX2 IS INDEPENDENT OF BCUT. BCUT = 0.002044D0 CMUON(7) = 7.D0**OB3 CMUON(8) = 8.D0**OB3 CMUON(9) = 18.D0**OB3 CMUON(1) = LOG( 189.D0 * PAMA(5) / (CMUON(7)*PAMA(2)) ) CMUON(2) = LOG( 189.D0 * PAMA(5) / (CMUON(8)*PAMA(2)) ) CMUON(3) = LOG( 189.D0 * PAMA(5) / (CMUON(9)*PAMA(2)) ) * + LOG( TB3/CMUON(9) ) SE = SQRT(EXP(1.D0)) CMUON(4) = 189.D0 * SE*PAMA(5)**2/(2.D0*PAMA(2)*CMUON(7)) CMUON(5) = 189.D0 * SE*PAMA(5)**2/(2.D0*PAMA(2)*CMUON(8)) CMUON(6) = 189.D0 * SE*PAMA(5)**2/(2.D0*PAMA(2)*CMUON(9)) CMUON(10) = 0.75D0 * PAMA(5) * SE CMUON(7) = CMUON(7) * CMUON(10) CMUON(8) = CMUON(8) * CMUON(10) CMUON(9) = CMUON(9) * CMUON(10) CMUON(11) = LOG( BCUT/PAMA(5) ) C----------------------------------------------------------------------- C FILL CONSTANTS IN RUN HEADER DO 3001 L = 1,50 RUNH(24+L) = C(L) RUNH(154+L) = 0. RUNH(204+L) = 0. 3001 CONTINUE DO 3002 L = 1,20 RUNH(74+L) = 0. 3002 CONTINUE DO 3003 L = 1,40 RUNH(94+L) = CKA(L) 3003 CONTINUE DO 3004 L = 1,5 RUNH(134+L) = CETA(L) 3004 CONTINUE DO 3005 L = 1,11 RUNH(139+L) = CSTRBA(L) 3005 CONTINUE DO 3007 L = 1,5 RUNH(254+L) = AATM(L) RUNH(259+L) = BATM(L) RUNH(264+L) = CATM(L) 3007 CONTINUE CALL STAEND RETURN END *CMZ : 14/06/2000 14.56.21 by D. HECK IK3 FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE STRDEC C----------------------------------------------------------------------- C STR(ANGE BARYON) DEC(AY) C C ROUTINE TREATES DECAY OF STRANGE BARYONS (LAMBDA, SIGMA, XI, OMEGA) C DECAY WITH FULL KINEMATIC, ENERGY AND MOMENTA CONSERVED C THIS SUBROUTINE IS CALLED FORM NUCINT C C DESIGN : D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,IRET. COMMON /IRET/ IRET1,IRET2,IRETE INTEGER IRET1,IRET2 LOGICAL IRETE *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,STRBAR. COMMON /STRBAR/ CSTRBA DOUBLE PRECISION CSTRBA(11) *KEND. INTEGER I SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=1,9) 444 FORMAT(' STRDEC: CURPAR=',1P,9E10.3) IF ( ITYPE .EQ. 18 ) THEN CALL RMMAR( RD,1,1 ) IF ( RD(1) .LT. CSTRBA(5) ) THEN C DECAY LAMBDA ---> P + PI(-) CALL DECAY1( ITYPE, 14, 9 ) ELSE C DECAY LAMBDA ---> N + PI(0) CALL DECAY1( ITYPE, 13, 7 ) ENDIF ELSEIF ( ITYPE .EQ. 19 ) THEN CALL RMMAR( RD,1,1 ) IF ( RD(1) .LT. CSTRBA(6) ) THEN C DECAY SIGMA(+) ---> P + PI(0) CALL DECAY1( ITYPE, 14, 7 ) ELSE C DECAY SIGMA(+) ---> N + PI(+) CALL DECAY1( ITYPE, 13, 8 ) ENDIF ELSEIF ( ITYPE .EQ. 20 .OR. ITYPE .EQ. 28 ) THEN C DECAY SIGMA(0) ---> LAMBDA + GAMMA C DECAY ANTI-SIGMA(0) ---> ANTI-LAMBDA + GAMMA CALL DECAY1( ITYPE, ITYPE-2, 1 ) ELSEIF ( ITYPE .EQ. 21 ) THEN C DECAY SIGMA(-) ---> N + PI(-) CALL DECAY1( ITYPE, 13, 9 ) ELSEIF ( ITYPE .EQ. 22 .OR. ITYPE .EQ. 30 ) THEN C DECAY XI(0) ---> LAMBDA + PI(0) C DECAY ANTI-XI(0) ---> ANTI-LAMBDA + PI(0) CALL DECAY1( ITYPE, ITYPE-4, 7 ) ELSEIF ( ITYPE .EQ. 23 ) THEN C DECAY XI(-) ---> LAMBDA + PI(-) CALL DECAY1( ITYPE, 18, 9 ) ELSEIF ( ITYPE .EQ. 24 .OR. ITYPE .EQ. 32 ) THEN CALL RMMAR( RD,1,1 ) IF ( RD(1) .LT. CSTRBA(10) ) THEN C DECAY OMEGA(-) ---> LAMBDA + K(-) C DECAY ANTI-OMEGA(+) ---> ANTI-LAMBDA + K(+) CALL DECAY1( ITYPE, ITYPE-6, 15-ITYPE/8 ) ELSEIF ( RD(1) .LT. CSTRBA(11) ) THEN C DECAY OMEGA(-) ---> XI(0) + PI(-) C DECAY ANTI-OMEGA(+) ---> ANTI-XI(0) + PI(+) CALL DECAY1( ITYPE, ITYPE-2, 12-ITYPE/8 ) ELSE C DECAY OMEGA(-) ---> XI(-) + PI(0) C DECAY ANTI-OMEGA(+) ---> ANTI-XI(+) + PI(0) CALL DECAY1( ITYPE, ITYPE-1, 7 ) ENDIF ELSEIF ( ITYPE .EQ. 26 ) THEN CALL RMMAR( RD,1,1 ) IF ( RD(1) .LT. CSTRBA(5) ) THEN C DECAY ANTI-LAMBDA ---> ANTI-P + PI(+) CALL DECAY1( ITYPE, 15, 8 ) ELSE C DECAY ANTI-LAMBDA ---> ANTI-N + PI(0) CALL DECAY1( ITYPE, 25, 7 ) ENDIF ELSEIF ( ITYPE .EQ. 27 ) THEN CALL RMMAR( RD,1,1 ) IF ( RD(1) .LT. CSTRBA(6) ) THEN C DECAY ANTI-SIGMA(-) ---> ANTI-P + PI(0) CALL DECAY1( ITYPE, 15, 7 ) ELSE C DECAY ANTI-SIGMA(-) ---> ANTI-N + PI(-) CALL DECAY1( ITYPE, 25, 9 ) ENDIF ELSEIF ( ITYPE .EQ. 29 ) THEN C DECAY ANTI-SIGMA(+) ---> ANTI-N + PI(+) CALL DECAY1( ITYPE, 25, 8 ) ELSEIF ( ITYPE .EQ. 31 ) THEN C DECAY ANTI-XI(+) ---> ANTI-LAMBDA + PI(+) CALL DECAY1( ITYPE, 26, 8 ) ELSE WRITE(MONIOU,444) (CURPAR(I),I=1,9) WRITE(MONIOU,*) 'STRDEC: UNFORESEEN PARTICLE CODE =',ITYPE ENDIF IRET1 = 1 RETURN END *CMZ : 18/10/2000 09.15.11 by D. HECK IK3 FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= DOUBLE PRECISION FUNCTION THICK( ARG ) C----------------------------------------------------------------------- C THICK(NESS OF ATMOSPHERE) C C CALCULATES THICKNESS (G/CM**2) OF ATMOSPHERE DEPENDING ON HEIGHT (CM) C THIS FUNCTION IS CALLED FROM AAMAIN, BOX2, BOX3, EM, INPRM, MUBREM, C MUDECY, MUPRPR, MUTRAC, NRANGC, NUCINT, PRANGC, START, UPDATC, C UPDATE, EGS4, ELECTR, HOWFAR, PHOTON, ININKG, NKG, AND CERENK. C ARGUMENT: C ARG = HEIGHT IN CM C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,ATMOS. COMMON /ATMOS/ AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM DOUBLE PRECISION AATM(5),AATM0(5,0:16),BATM(5),BATM0(5,0:16), * CATM(5),CATM0(5,0:16),DATM(5) INTEGER MODATM *KEEP,ATMOS2. COMMON /ATMOS2/ HLAY,HLAY0,THICKL,LAYNO,LAYNEW DOUBLE PRECISION HLAY(6),HLAY0(5,0:4),THICKL(5) INTEGER LAYNO(0:16) LOGICAL LAYNEW *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,ATMOSX. C EXTERNAL ATMOSPHERIC MODELS COMMON /ATMOSX/ IATMOX,FREFRX INTEGER IATMOX LOGICAL FREFRX *KEND. DOUBLE PRECISION ARG SAVE DOUBLE PRECISION THICKX EXTERNAL THICKX C----------------------------------------------------------------------- CC IF ( DEBUG ) WRITE(MDEBUG,*) 'THICK : ARG=',SNGL(ARG) IF ( IATMOX .GE. 1 ) THEN THICK = THICKX(ARG) RETURN ENDIF IF ( ARG .LT. HLAY(2) ) THEN THICK = AATM(1) + BATM(1) * EXP ( (-ARG) * DATM(1) ) ELSEIF ( ARG .LT. HLAY(3) ) THEN THICK = AATM(2) + BATM(2) * EXP ( (-ARG) * DATM(2) ) ELSEIF ( ARG .LT. HLAY(4) ) THEN THICK = AATM(3) + BATM(3) * EXP ( (-ARG) * DATM(3) ) ELSEIF ( ARG .LT. HLAY(5) ) THEN THICK = AATM(4) + BATM(4) * EXP ( (-ARG) * DATM(4) ) ELSE THICK = AATM(5) - ARG * DATM(5) ENDIF RETURN END *CMZ : 18/10/2000 09.15.11 by D. HECK IK3 FZK KARLSRUHE *-- Author : F. SCHROEDER UNI WUPPERTAL 17/09/98 C======================================================================= DOUBLE PRECISION FUNCTION THICKC(ARG) C----------------------------------------------------------------------- C THICK(NESS IN CASE OF) C(URVED ATMOSPHERE) C C CALCULATES OF ATMOSPHERIC THICKNESS AT INTERACTION POINT IN CURVED C COORDINATE SYSTEM AFTER TRANSPORTING THE PARTICLE CHI G/CM**2 C THIS FUNCTION IS CALLED FROM AAMAIN. C ARGUMENT: C ARG = PENETRATED MATTER THICKNESS IN CURVED ATMOSPHERE (G/CM**2) C C DESIGN : F. SCHROEDER UNI WUPPERTAL C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,ATMOS. COMMON /ATMOS/ AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM DOUBLE PRECISION AATM(5),AATM0(5,0:16),BATM(5),BATM0(5,0:16), * CATM(5),CATM0(5,0:16),DATM(5) INTEGER MODATM *KEEP,ATMOS2. COMMON /ATMOS2/ HLAY,HLAY0,THICKL,LAYNO,LAYNEW DOUBLE PRECISION HLAY(6),HLAY0(5,0:4),THICKL(5) INTEGER LAYNO(0:16) LOGICAL LAYNEW *KEEP,OBSPAR. COMMON /OBSPAR/ OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP, * THETPR,PHIPR, * VUECON, * NOBSLV DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10), * HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2) DOUBLE PRECISION VUECON(2) INTEGER NOBSLV *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DOUBLE PRECISION ARG,CHIC,CHIMAX,CHICNEW,COSDIF,COSPHI,COSTAPNEW, * COSTHENEW,DISTN2,DISTO2,DL,HEIGH,HNEW,HOLD, * RADIUS,SIGNE,SINI,SINPHI, * TRANSNEW,WORK,XNEW,YNEW INTEGER IL SAVE EXTERNAL HEIGH C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'THICKC: ARG=',SNGL(ARG),'H=',SNGL(H) C START VALUES CHIC = ARG HNEW = H XNEW = X YNEW = Y THICKC = THICKH DISTN2 = XNEW**2 + YNEW**2 COSPHI = COS(PHI) SINPHI = SIN(PHI) COSTHENEW = COSTHE COSTAPNEW = COSTAP C CHOPPING OF TOTAL PATH LENGTH CHITOT INTO SMALLER PIECES AND C TRANSPORT IN LOCAL PLANE SYSTEM. STEP LENGTH LIMITATION DEPENDS ON C THICKNESS OF STARTING POINT. THIS NEEDS A LOOP OVER ALL SMALL PIECES C OF STEP WHICH ENDS AT MAXIMAL HORIZONTAL STEP 2 CONTINUE C LOOK WITHIN WHICH LAYER THE PARTICLE STARTS IF ( HNEW .LE. HLAY(2) ) THEN IL = 1 ELSEIF ( HNEW .LE. HLAY(3) ) THEN IL = 2 ELSEIF ( HNEW .LE. HLAY(4) ) THEN IL = 3 ELSE IL = 4 ENDIF C LOOK FOR MAXIMAL STEP OF CHICNEW, ONLY IF NOT CLOSE TO VERTICAL IF ( COSTHENEW .LT. 0.98D0 ) THEN SINI = DATM(IL) / SQRT(1.D0 - COSTHENEW**2) WORK = C(4) * THICKC + C(3) IF ( HNEW .LT. HLAY(5) ) THEN CHIMAX = ( THICKC - AATM(IL) ) * SINI * * ( WORK + 0.5D0*COSTHENEW*SINI * WORK**2 ) ELSE CHIMAX = WORK * SINI * DATM(5)/DATM(IL) ENDIF IF ( CHIC .GE. CHIMAX ) THEN CHICNEW = CHIMAX ELSE CHICNEW = CHIC ENDIF ELSE CHICNEW = CHIC ENDIF C ACTUAL VALUES THICKC = THICKC + COSTHENEW * CHICNEW CHIC = CHIC - CHICNEW IF ( DEBUG ) WRITE(MDEBUG,*) 'THICKC: CHIC,THICKC=', * SNGL(CHIC),SNGL(THICKC) C IN CASE COMPLETE PARTICLE TRACK LENGTH IS CHIC, STOP THE LOOP IF ( CHIC .GT. 0.D0 ) THEN C NEW COORDINATE FRAME HOLD = HNEW C NEW HEIGHT IN OLD COORDINATE FRAME HNEW = HEIGH(THICKC) DL = (HOLD - HNEW) * COSTHENEW TRANSNEW = DL * SQRT( 1.D0 - COSTHENEW**2 ) C NEW ACTUAL HEIGHT AT NEW THICKNESS GRADIENT C (CALCULATED WITH PARAMETERS OF OLD COORDINATE FRAME) HNEW = SQRT( TRANSNEW**2 + (C(1)+HNEW)**2 ) - C(1) IF ( HNEW .LT. OBSLEV(1) -1.D5 ) RETURN COSDIF = ( (C(1)+HNEW)**2 + (C(1)+HOLD)**2 - DL**2 ) / * ( 2.D0 * (C(1)+HNEW) * (C(1)+HOLD) ) IF ( DEBUG ) WRITE(MDEBUG,*) 'THICKC: HNEW,COSDIF=', * SNGL(HNEW),SNGL(COSDIF) COSDIF = MIN (1.D0, COSDIF) C DIRECTION OF PARTICLE RELATIV TO SHOWER CORE DISTO2 = DISTN2 IF ( COSDIF .LT. 1.D0 ) THEN RADIUS = DL * SQRT( (1.D0-COSTAPNEW**2)/(1.D0-COSDIF**2) ) * * C(1) * ACOS(COSDIF)/(C(1)+HNEW) ELSE RADIUS = DL * SQRT( 1.D0 - COSTAPNEW**2 ) ENDIF XNEW = XNEW + RADIUS * COSPHI YNEW = YNEW + RADIUS * SINPHI DISTN2 = XNEW**2 + YNEW**2 IF ( DISTO2 .GT. DISTN2 ) THEN SIGNE = +1.D0 ELSE SIGNE = -1.D0 ENDIF C COSINE OF THE ZENITH ANGLE IN THE NEW FRAME COSTHENEW = MIN( 1.D0, ( COSTHENEW * COSDIF - SIGNE * * SQRT( (1.D0-COSTHENEW**2) * (1.D0-COSDIF**2) ) ) ) IF (DEBUG) WRITE(MDEBUG,*) 'THICKC: COSTHENEW=',SNGL(COSTHENEW) IF ( COSTHENEW .GT. C(29) ) GOTO 2 ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'THICKC: THICKC=',SNGL(THICKC) RETURN END *CMZ : 23/11/2000 09.03.51 by D. HECK IK3 FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE TOBUF( A,IFL ) C----------------------------------------------------------------------- C (WRITE) TO BUF(FER) C C WRITES UP TO NSUBBL DATA BLOCKS TO OUTPUT BUFFER AND PUTS THE FULL C BUFFER TO TAPE C THIS SUBROUTINE IS CALLED FROM AAMAIN, ELECTR, PHOTON, INPRM, OUTEND, C OUTPT1, OUTPT2, AND PHOTON. C ARGUMENTS: C A = ARRAY TO BE WRITTEN TO TAPE C IFL = STARTING OF FINAL OUTPUT C = 0 NORMAL BLOCK C = 1 NORMAL BLOCK WITH END OF OUTPUT C = 2 ONLY END OF OUTPUT C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,BUFFS. COMMON /BUFFS/ RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH INTEGER MAXBUF,MAXLEN PARAMETER (MAXLEN=16) PARAMETER (MAXBUF=39*7) REAL RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF), * RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF) INTEGER LH CHARACTER*4 CRUNH,CRUNE,CEVTH,CEVTE,CLONG EQUIVALENCE (RUNH(1),CRUNH), (RUNE(1),CRUNE) EQUIVALENCE (EVTH(1),CEVTH), (EVTE(1),CEVTE) EQUIVALENCE (ARRAYLONG(1),CLONG) *KEEP,RECORD. COMMON /RECORD/ IRECOR INTEGER IRECOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. C NSUBBL IS NUMBER OF SUBBLOCKS IN ONE OUTPUT RECORD INTEGER NSUBBL PARAMETER (NSUBBL=21) REAL A(*) C (OUTPUT RECORD LENGTH = NSUBBL * 39 * 7 * 4 BYTES <= 22932 ) C OUTPUT BUFFER FOR PARTICLE OUTPUT REAL OUTBUF(MAXBUF,NSUBBL) C IBLK IS COUNTER FOR SUBBLOCKS INTEGER I,IBLK,IFL,K SAVE DATA IBLK / 0 / C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'TOBUF : IFL =',IFL C COPY TO BUFFER IF ( IFL .LE. 1 ) THEN IBLK = IBLK + 1 DO 1 I = 1,MAXBUF OUTBUF(I,IBLK) = A(I) 1 CONTINUE ENDIF C WRITE TO TAPE IF BLOCK IS FULL OR IF IFL IS 1 IF ( IFL .GE. 1 .OR. IBLK .EQ. NSUBBL ) THEN NRECS = NRECS + 1 NBLKS = NBLKS + IBLK IF ( FPAROUT ) THEN c------changed--add-and-comand cxx WRITE(MPATAP) ((OUTBUF(I,K),I=1,MAXBUF),K=1,NSUBBL) c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> c WRITE(PATAPE) ((OUTBUF(I,K),I=1,MAXBUF),K=1,NSUBBL) call jcdatsave(outbuf) c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> c------changed--add-and-comand ENDIF IRECOR = IRECOR + MAXBUF * NSUBBL IBLK = 0 DO 2 K = 1,NSUBBL DO 2 I = 1,MAXBUF OUTBUF(I,K) = 0.0 2 CONTINUE ENDIF RETURN END *CMZ : 25/02/2002 15.28.14 by D. HECK IK FZK KARLSRUHE *-- Author : Johannes Knapp, IEKP U Karlsruhe 26/01/97 C======================================================================= SUBROUTINE TSTACK C----------------------------------------------------------------------- C T(O) STACK C C ADDS PARTICLE TO INTERMEDIATE STACK UNTIL REACTION IS FINISHED C ONLY PARTICLES ABOVE ENERGY CUT ARE TAKEN TO STACK C THIS SUBROUTINE IS CALLED FROM MANY ROUTINES ALL OVER THE PROGRAM. C C DESIGN : J. KNAPP, IEKP U KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,BUFFS. COMMON /BUFFS/ RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH INTEGER MAXBUF,MAXLEN PARAMETER (MAXLEN=16) PARAMETER (MAXBUF=39*7) REAL RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF), * RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF) INTEGER LH CHARACTER*4 CRUNH,CRUNE,CEVTH,CEVTE,CLONG EQUIVALENCE (RUNH(1),CRUNH), (RUNE(1),CRUNE) EQUIVALENCE (EVTH(1),CEVTH), (EVTE(1),CEVTE) EQUIVALENCE (ARRAYLONG(1),CLONG) *KEEP,ELABCT. COMMON /ELABCT/ ELCUT DOUBLE PRECISION ELCUT(4) *KEEP,LONGI. COMMON /LONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG, * SDLONG,SELONG,SPLONG,THSTEP,THSTPI, * LHEIGH,NSTEP,LLONGI,FLGFIT DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9), * APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9), * HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9), * SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI INTEGER LHEIGH,NSTEP LOGICAL LLONGI,FLGFIT *KEEP,MUPART. COMMON /MUPART/ AMUPAR,BCUT,CMUON,FMUBRM,FMUORG DOUBLE PRECISION AMUPAR(16),BCUT,CMUON(11) LOGICAL FMUBRM,FMUORG *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,THNVAR. COMMON /THNVAR/ STACKINT, * INT_ICOUNT,MODETHN,THINNING INTEGER MAXICOUNT PARAMETER (MAXICOUNT=40000) DOUBLE PRECISION STACKINT(16,MAXICOUNT) INTEGER INT_ICOUNT,MODETHN LOGICAL THINNING *KEND. INTEGER I,J SAVE C----------------------------------------------------------------------- INT_ICOUNT = INT_ICOUNT + 1 IF ( DEBUG ) WRITE(MDEBUG,1) INT_ICOUNT,(SECPAR(J),J=1,9) 1 FORMAT(' TSTACK:',I7,1X,1P,8E10.3,0P,F10.0) IF ( INT_ICOUNT .GT. MAXICOUNT ) THEN WRITE(MONIOU,10) MAXICOUNT 10 FORMAT(' TSTACK: TOO MANY SECONDARIES FOR THIS REACTION', * ' EXCEEDED ',I7,' A T T E N T I O N PARTICLE IS LOST') INT_ICOUNT = INT_ICOUNT - 1 RETURN ENDIF C CALCULATE APPROPRIATE KINETIC ENERGY CUT AND APPLY IT IF ( SECPAR(1) .EQ. 5.D0 .OR. SECPAR(1) .EQ. 6.D0 ) THEN C ---MUONS--- IF ( (SECPAR(2) - 1.D0)*PAMA(5) .LT. ELCUT(2) ) THEN FMUORG = .FALSE. IF (DEBUG) WRITE(MDEBUG,*) 'TSTACK: PARTICLE BELOW ', * 'ENERGY CUT' INT_ICOUNT = INT_ICOUNT - 1 IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT DLONG(LHEIGH,5) = DLONG(LHEIGH,5) + SECPAR(2) * PAMA(5) ENDIF RETURN ENDIF ELSEIF ( SECPAR(1) .EQ. 2.D0 .OR. SECPAR(1) .EQ. 3.D0 ) THEN C ---ELECTRONS--- IF ( (SECPAR(2) - 1.D0)*PAMA(2) .LT. ELCUT(3) ) THEN IF (DEBUG) WRITE(MDEBUG,*) 'TSTACK: PARTICLE BELOW ', * 'ENERGY CUT' INT_ICOUNT = INT_ICOUNT - 1 IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( SECPAR(1) .EQ. 2.D0 ) THEN DLONG(LHEIGH,3) = DLONG(LHEIGH,3) * + (SECPAR(2)+1.D0) * PAMA(2) ELSE DLONG(LHEIGH,3) = DLONG(LHEIGH,3) * + (SECPAR(2)-1.D0) * PAMA(2) ENDIF ENDIF RETURN ENDIF ELSEIF ( SECPAR(1) .EQ. 1.D0 ) THEN C ---GAMMAS--- IF ( SECPAR(2) .LT. ELCUT(4) ) THEN IF (DEBUG) WRITE(MDEBUG,*) 'TSTACK: PARTICLE BELOW ', * 'ENERGY CUT' INT_ICOUNT = INT_ICOUNT - 1 IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + SECPAR(2) ENDIF RETURN ENDIF ELSEIF (SECPAR(1) .GE. 100.D0 ) THEN C ---NUCLEI---, CUTTED IF ENERGY/NUCLEON BELOW CUT IF ( (SECPAR(2)-1.D0)*PAMA(NINT(SECPAR(1))) * .LT. ELCUT(1)*NINT(SECPAR(1)/100.D0) ) THEN IF (DEBUG) WRITE(MDEBUG,*) 'TSTACK: PARTICLE BELOW ', * 'ENERGY CUT' INT_ICOUNT = INT_ICOUNT - 1 IF ( LLONGI ) THEN C ADD KINETIC ENERGY TO LONGITUDINAL ENERGY DEPOSIT DLONG(LHEIGH,7) = DLONG(LHEIGH,7) * + ( SECPAR(2)*PAMA(NINT(SECPAR(1))) * - RESTMS(NINT(SECPAR(1))) ) ENDIF RETURN ENDIF ELSE C ---HADRONS--- IF ( (SECPAR(2)-1.D0)*PAMA(NINT(SECPAR(1))) .LT. ELCUT(1) ) THEN IF (DEBUG) WRITE(MDEBUG,*) 'TSTACK: PARTICLE BELOW ', * 'ENERGY CUT' INT_ICOUNT = INT_ICOUNT - 1 IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT C IN CASE OF NUCLEONS TAKE ONLY KINETIC ENERGY C IN CASE OF ANTINUCLEONS TAKE RELEASABLE ENERGY DLONG(LHEIGH,7) = DLONG(LHEIGH,7) * + ( SECPAR(2) * PAMA(NINT(SECPAR(1))) * - RESTMS(NINT(SECPAR(1))) ) ENDIF RETURN ENDIF ENDIF C WRITE PARTICLE ABOVE CUT TO INTERMEDIATE STACK DO I = 1,MAXLEN STACKINT(I,INT_ICOUNT) = SECPAR(I) ENDDO RETURN END *CMZ : 27/02/2002 16.27.13 by D. HECK IK FZK KARLSRUHE *-- Author : Johannes Knapp, IEKP U Karlsruhe 26/01/97 C======================================================================= SUBROUTINE TSTEND C----------------------------------------------------------------------- C T(O) ST(ACK) END (OF REACTION) C C MOVE INTERMEDIATE REACTION STACK TO THE REAL STACK C AND PERFORM THINNING, IF SELECTED C THIS SUBROUTINE IS CALLED FROM AAMAIN, BOX3, AND PIGEN. C C DESIGN : J. KNAPP, IEKP U KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,BUFFS. COMMON /BUFFS/ RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH INTEGER MAXBUF,MAXLEN PARAMETER (MAXLEN=16) PARAMETER (MAXBUF=39*7) REAL RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF), * RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF) INTEGER LH CHARACTER*4 CRUNH,CRUNE,CEVTH,CEVTE,CLONG EQUIVALENCE (RUNH(1),CRUNH), (RUNE(1),CRUNE) EQUIVALENCE (EVTH(1),CEVTH), (EVTE(1),CEVTE) EQUIVALENCE (ARRAYLONG(1),CLONG) *KEEP,MUPART. COMMON /MUPART/ AMUPAR,BCUT,CMUON,FMUBRM,FMUORG DOUBLE PRECISION AMUPAR(16),BCUT,CMUON(11) LOGICAL FMUBRM,FMUORG *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,REJECT. COMMON /REJECT/ AVNREJ,ALTMIN,ANEXP,THICKA,THICKD,CUTLN,EONCUT, * FNPRIM DOUBLE PRECISION AVNREJ(10),ALTMIN(10),ANEXP(10),THICKA(10), * THICKD(10),CUTLN,EONCUT LOGICAL FNPRIM *KEEP,RESON. COMMON /RESON/ RDRES,RESRAN,IRESPAR REAL RDRES(2),RESRAN(30000) INTEGER IRESPAR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,THNVAR. COMMON /THNVAR/ STACKINT, * INT_ICOUNT,MODETHN,THINNING INTEGER MAXICOUNT PARAMETER (MAXICOUNT=40000) DOUBLE PRECISION STACKINT(16,MAXICOUNT) INTEGER INT_ICOUNT,MODETHN LOGICAL THINNING *KEND. INTEGER I,K SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,1) INT_ICOUNT 1 FORMAT(' TSTEND: TRANSFER INTERNAL REACTION STACK', * ' WITH ',I6,' PARTICLES ') IF ( INT_ICOUNT .LE. 0 ) RETURN C PUT ALL PARTICLES FROM INTERMEDIATE STACK TO REAL STACK DO K = 1,INT_ICOUNT DO I = 1,MAXLEN SECPAR(I) = STACKINT(I,K) STACKINT(I,K) = 0.D0 ENDDO CALL TSTOUT ENDDO RETURN END *CMZ : 27/02/2002 16.27.13 by D. HECK IK FZK KARLSRUHE *-- Author : Johannes Knapp, IEKP U Karlsruhe 26/01/97 C======================================================================= SUBROUTINE TSTOUT C----------------------------------------------------------------------- C T(O) ST(ACK) OUT C C MAKE OUTPUT AFTER ONE INTERACTION HAS FINISHED C ADDS PARTICLE TO STACK AND WRITES IT TO DISK IF NECESSARY C THIS SUBROUTINE IS CALLED FORM MPPROP, PIGEN1, PIGEN2, RHOGEN, C AND TSTEND C C DESIGN : J. KNAPP, IEKP U KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,BUFFS. COMMON /BUFFS/ RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH INTEGER MAXBUF,MAXLEN PARAMETER (MAXLEN=16) PARAMETER (MAXBUF=39*7) REAL RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF), * RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF) INTEGER LH CHARACTER*4 CRUNH,CRUNE,CEVTH,CEVTE,CLONG EQUIVALENCE (RUNH(1),CRUNH), (RUNE(1),CRUNE) EQUIVALENCE (EVTH(1),CEVTH), (EVTE(1),CEVTE) EQUIVALENCE (ARRAYLONG(1),CLONG) *KEEP,ETHMAP. COMMON /ETHMAP/ ECTMAP,ELEFT DOUBLE PRECISION ECTMAP,ELEFT *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,STACKF. COMMON /STACKF/ STACK,MSTACKP,MEXST,NSHIFT,NOUREC,ICOUNT, * NTO,NFROM INTEGER MAXSTK PARAMETER (MAXSTK = 16*256*2) DOUBLE PRECISION STACK(MAXSTK) INTEGER MSTACKP,MEXST,NSHIFT,NOUREC,ICOUNT,NTO,NFROM *KEND. INTEGER I,ISTK,J SAVE DATA ISTK / MAXSTK / C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,666) ICOUNT,(SECPAR(J),J=1,9) 666 FORMAT(' TSTOUT:',I7,1X,1P,8E10.3,0P,F10.0) IF ( MSTACKP .GE. ISTK ) THEN WRITE(MEXST,REC=NOUREC+1) (STACK(I),I= 1,ISTK/2) WRITE(MEXST,REC=NOUREC+2) (STACK(I),I=ISTK/2+1,ISTK ) NOUREC = NOUREC + 2 NSHIFT = NSHIFT + 2 MSTACKP = 0 ENDIF NTO = NTO + 1 ICOUNT = ICOUNT + 1 DO 2 J = 1,MAXLEN STACK(MSTACKP+J) = SECPAR(J) 2 CONTINUE MSTACKP = MSTACKP + MAXLEN IF ( SECPAR(1) .LE. 1.D0 ) THEN ELEFT = ELEFT + SECPAR(2) ELSE ELEFT = ELEFT + SECPAR(2) * PAMA(NINT(SECPAR(1))) ENDIF RETURN END *CMZ : 05/03/2002 08.55.01 by D. HECK IK FZK KARLSRUHE *-- Author : F. SCHROEDER UNI WUPPERTAL 17/11/98 C======================================================================= SUBROUTINE UPDATC(IPASC,FLAGMU,fmfb) C----------------------------------------------------------------------- C UPDAT(ES PARTICLE PARAMETERS IN A) C(URVED ATMOSPHERE) C C IN THE CASE THE HORIZONTAL COMPONENT OF THE TRACK IS TO LONG (> 20KM) C THE PARTICLE TRACK IS CHOPPED IN SEVERAL SHORTER TRACKS. C FOR EACH OF THESE CHOPPED TRACKS SUBR. UPDATE IS CALLED. C THIS SUBROUTINE IS CALLED FROM AAMAIN, BOX3, AND MUTRAC. C ARGUMENTS: C IPASC = 0 TRANSPORT LEADS TO END OF RANGE OF PARTICLE C 1 TRANSPORT LEADS TO OBSERVATION LEVEL C FLAGMU FLAG INDICATING THE TRACKING OF MUONS C C DESIGN : F. SCHROEDER UNI WUPPERTAL C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,ATMOS. COMMON /ATMOS/ AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM DOUBLE PRECISION AATM(5),AATM0(5,0:16),BATM(5),BATM0(5,0:16), * CATM(5),CATM0(5,0:16),DATM(5) INTEGER MODATM *KEEP,ATMOS2. COMMON /ATMOS2/ HLAY,HLAY0,THICKL,LAYNO,LAYNEW DOUBLE PRECISION HLAY(6),HLAY0(5,0:4),THICKL(5) INTEGER LAYNO(0:16) LOGICAL LAYNEW *KEEP,GENER. COMMON /GENER/ GEN,ALEVEL DOUBLE PRECISION GEN,ALEVEL *KEEP,IRET. COMMON /IRET/ IRET1,IRET2,IRETE INTEGER IRET1,IRET2 LOGICAL IRETE *KEEP,LONGI. COMMON /LONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG, * SDLONG,SELONG,SPLONG,THSTEP,THSTPI, * LHEIGH,NSTEP,LLONGI,FLGFIT DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9), * APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9), * HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9), * SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI INTEGER LHEIGH,NSTEP LOGICAL LLONGI,FLGFIT *KEEP,MAGNET. COMMON /MAGNET/ BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT DOUBLE PRECISION BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT *KEEP,MUMULT. COMMON /MUMULT/ CHC,OMC,PHISCT,STEPL,VSCAT,FMOLI DOUBLE PRECISION CHC,OMC,PHISCT,STEPL,VSCAT LOGICAL FMOLI *KEEP,OBSPAR. COMMON /OBSPAR/ OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP, * THETPR,PHIPR, * VUECON, * NOBSLV DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10), * HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2) DOUBLE PRECISION VUECON(2) INTEGER NOBSLV *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,CORFRAM, IF=CURVED. COMMON /CORFRAM/ DETSYS LOGICAL DETSYS *KEND. DOUBLE PRECISION ARG,AUXIL,AUXILSQ,AUX2SQ,CHIC,CHIMAX,CHIN,CORR, * COSDIF,COSTHENEW,DISTN2,DISTO2,DSTEFF, * EDEPB,EDEPN,EDEP1,EFRST,GAMMAOLD,GAMMAN, * HEIGH,HNEW,HOLD,SIGNE,SINDIF,SINI,SINTEA,STEPLC, * STEPLO,STEPT,THCKHN,THCKHO,THICK,THICKHOLD, * TRANS2,WORK,XNEW,XOLD,YNEW,YOLD INTEGER I,IL,IPASC,LPCT1,LPCT2 LOGICAL FLAGMU c-----changed--add logical fmfb c-----changed--add DOUBLE PRECISION HNEWO SAVE EXTERNAL HEIGH,THICK C----------------------------------------------------------------------- IF (DEBUG) WRITE(MDEBUG,457) (CURPAR(I),I=1,9),FLAGMU 457 FORMAT(' UPDATC: CURPAR=',1P,9E10.3,0P/ * ' FLAGMU=',L2) C NOTE: ARG = PENETRATED MATTER THICKNESS HAS TO BE A CONSTANT C FOR THE WHOLE PARTICLE UPDATING C => LOOP OVER PIECES OF ARG (ALSO CONSTANTS FOR UPDATE) C START VALUES FOR LOOP OVER PENETRATED MATTER THICKNESS IRET2 = 0 C STORE THE THICKNES CHI TO BE TRANSPORTED CHIC = CHI ARG = CHI C STORE THE PATH LENGTH STEPL DO BE TRANSPORTED IF ( FLAGMU ) THEN STEPLC = STEPL ELSE STEPLC = 0.D0 ENDIF STEPLO = 0.D0 HNEW = H THCKHN = THICKH XNEW = X YNEW = Y SINTEA = SQRT(1.D0 - COSTEA**2) IF ( LLONGI ) THEN GAMMAOLD = GAMMA THICKHOLD = THICKH LPCT1 = INT(THICKHOLD*THSTPI + 1.D0) ENDIF C CHOPPING OF TOTAL PATH LENGTH CHIC INTO SMALLER PIECES AND C TRANSPORT IN LOCAL PLANE SYSTEMS. STEP LENGTH LIMITATION DEPENDS ON C THICKNESS OF STARTING POINT. LOOP OVER ALL SMALL PIECES OF STEP 2 CONTINUE C SAVE OLD LOCAL HEIGHT FOR TRANSFORMATION AFTER UPDATE HOLD = HNEW XOLD = XNEW YOLD = YNEW DISTO2 = XNEW**2 + YNEW**2 IF (DEBUG) WRITE(MDEBUG,*) 'UPDATC: CHIC,HOLD,THCKHN=', * SNGL(CHIC),SNGL(HOLD),SNGL(THCKHN) C LOOK WITHIN WHICH LAYER THE PARTICLE STARTS IF ( HOLD .LE. HLAY(2) ) THEN IL = 1 ELSEIF ( HOLD .LE. HLAY(3) ) THEN IL = 2 ELSEIF ( HOLD .LE. HLAY(4) ) THEN IL = 3 ELSE IL = 4 ENDIF C LOOK FOR MAXIMAL STEP OF CHICNEW, ONLY IF NOT CLOSE TO VERTICAL C BEFORE ENTERING NEW ATMOSPHERIC LAYER IF ( COSTHE .LT. 0.98D0 ) THEN SINI = DATM(IL) / SQRT(1.D0 - COSTHE**2) * IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATC: SINI=',SINI WORK = C(4) * THCKHN + C(3) IF ( HOLD .LT. HLAY(5) ) THEN CHIMAX = ( THCKHN - AATM(IL) ) * SINI * * ( WORK + 0.5D0*COSTHE*SINI * WORK**2 ) ELSE CHIMAX = WORK * SINI * DATM(5)/DATM(IL) ENDIF IF (DEBUG) WRITE(MDEBUG,301) CHIMAX 301 FORMAT(' UPDATC: CHIMAX=',F10.5,' TO NEXT ATMOSPHERIC BOUNDARY') IF ( CHIC .GE. CHIMAX ) THEN CHIN = CHIMAX ELSE CHIN = CHIC ENDIF ELSE CHIN = CHIC ENDIF C CALCULATE VALUES FOR UPDATE THCKHO = THCKHN THCKHN = THCKHO + CHIN * COSTHE HNEW = HEIGH(THCKHN) IF ( HNEW .GT. HOLD ) THEN C MAKE A SMALL STEP OF 0.1 CM DEEPER INTO THE ATMOSPHERE HNEW = HOLD - 0.1D0 THCKHN = THICK(HNEW) ENDIF C CHECK WETHER PARTICLE PASSES OBSERVATION LEVEL IF ( HNEW .LE. OBSLEV(1) ) THEN IF ( DEBUG ) WRITE(MDEBUG,558) COSTHE,H,X,Y 558 FORMAT(' UPDATC: UNCORR COSTHE,H,X,Y=',1P,4E17.10,0P) C CORRECT PARTICLE COORDINATES FOR DETECTOR SYSTEM C FIRST CALCULATE COSTAP AND HAPP IN OLD SYSTEM AUXILSQ = SQRT(X**2 + Y**2) COSTEA = COS(AUXILSQ/C(1)) COSTEA = MIN( 1.D0, COSTEA ) HAPP = (C(1)+HOLD) * COSTEA - C(1) C REJECT PARTICLE WHICH TRAVERSES BELOW OBSERVATION LEVEL MEASURED C IN THE DETECTOR FRAME IF ( HAPP .LT. OBSLEV(1) ) GOTO 200 C REGARD WHETHER PARTICLE IS MOVING TOWARDS DETECTOR C EFFECTIVE DISTANCE TO DETECTOR CENTER IS DISTANCE TO POINT C OF FLIGHT PATH PROJECTION WHICH COMES CLOSEST TO DETECTOR CENTER DSTEFF = -( COS(PHI)*X + SIN(PHI)*Y ) C CALCULATE CORRECTION ANGLE DIF FROM EFFECTIVE DISTANCE SINDIF = SIN(DSTEFF/C(1)) COSDIF = SQRT( 1.D0 - SINDIF**2 ) COSTHENEW = COSTHE*COSDIF - SQRT(1.D0-COSTHE**2)*SINDIF IF (DEBUG) WRITE(MDEBUG,*) 'UPDATC: COSDIF,COSTHENEW=', * COSDIF,COSTHENEW COSTHE = MIN( 1.D0, COSTHENEW ) C KILL HORIZONTAL OR UPWARD GOING PARTICLES IF ( COSTHE .LE. C(29) ) THEN IF ( DEBUG ) WRITE(MDEBUG,556) (CURPAR(I),I=1,9) 556 FORMAT(' UPDATC: KILL 1=',1P,10E10.3) GOTO 200 ENDIF C ANGLE DIF MIGHT BE LARGE (DUE TO CUT ON HAPP) X = (HAPP+C(1))*TAN(X/C(1)) Y = (HAPP+C(1))*TAN(Y/C(1)) H = HAPP IF ( DEBUG ) WRITE(MDEBUG,559) COSTHE,H,X,Y 559 FORMAT(' UPDATC: CORREC COSTHE,H,X,Y=',1P,4E17.10,0P) HNEW = OBSLEV(1) THCKHN = THCKOB(1) IPASC = 1 DETSYS = .TRUE. ELSE IPASC = 0 DETSYS = .FALSE. ENDIF HNEWO = HNEW C CALL UPDATE WITH NEW INPUT PARAMETERS ( HNEW,THCKHN,CURPAR(..) ) CHI = CHIN c-----changed--add CALL UPDATE( HNEW,THCKHN,0,fmfb ) c-----changed--add CHIN = CHI C DECREMENT THE THICKNESS STILL TO BE TRAVERSED CHIC = CHIC - CHI C INCREMENT STEPLO BY THE LENGTH PERFORMED IN UPDATE IF ( FLAGMU ) STEPLO = STEPLO + STEPL IF (DEBUG) WRITE(MDEBUG,*) 'UPDATC: CHIC,CHIN=',CHIC,CHIN IF ( IRET2 .NE. 0 ) THEN IF ( IRETE ) THEN C PARTICLE SUFFERED FROM ENERGY CUT GOTO 150 ELSE C PARTICLE SUFFERED FROM ANGULAR CUT GOTO 200 ENDIF ENDIF C KILL PARTICLE AS IT HAS BEEN STOPPED (MODIFIED HNEW IN UPDATE) C (NORMALLY BEDCAUSE OF ENERGY CUT) C IF ( HNEW .NE. HNEWO ) THEN C IRET2 = 1 C IRETE = .TRUE. C GOTO 150 C ENDIF C FOR CHARGED PARTICLES COSINE OF ZENITH ANGLE IS CALCULATED IN UPDATE. C KILL HORIZONTAL OR UPWARD GOING PARTICLES IF ( OUTPAR(3) .LE. C(29) ) GOTO 200 C FILL CURPAR WITH ACTUAL VALUES OF PARTICLE AFTER TRANSPORT IN UPDATE C OUTPAR(13-16) IS NOT MODIFIED IN UPDATE DO I = 2,8 CURPAR(I) = OUTPAR(I) ENDDO THICKH = THCKHN IF ( IPASC .EQ. 0 ) THEN C TRACK ENDS NOT AT OBSERVATION LEVEL C HORIZONTAL COMPONENT OF TRACK LENGTH SQUARED TRANS2 = (X-XOLD)**2 + (Y-YOLD)**2 C TRANSPORT AT MINIMUM 1 MM TRANS2 = MAX(TRANS2,0.01D0) C NEW COORDINATE FRAME, NEW ACTUAL HEIGHT AT NEW THICKNESS GRADIENT C (CALCULATED WITH PARAMETERS OF OLD COORDINATE FRAME) AUXIL = SQRT( TRANS2 + (C(1)+H)**2 ) HNEW = AUXIL - C(1) IF ( HNEW .GE. HLAY(6) ) THEN C KILL PARTICLE WHICH LEAVES ATMOSPHERE IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATC: HNEW=',HNEW,' KILL' GOTO 200 ENDIF THCKHN = THICK(HNEW) C CALCULATE ANGLE DIFFERENCE BETWEEN OLD AND NEW FRAME SINDIF = SQRT(TRANS2) / AUXIL COSDIF = (C(1)+H) / AUXIL IF ( DEBUG ) WRITE(MDEBUG,560) COSDIF,SINDIF,H,HNEW 560 FORMAT(' UPDATC: COSDIF,SINDIF,H,HNEW=',2F18.15,1P,2E17.9) COSDIF = MIN(1.D0,COSDIF) C X AND Y HAVWE TO BE TRANSFORMED INTO 'EARTH'-COORDINATES (SPHERE) C BEFORE THE COMPARISON WITH DISTO2 IS DONE. C TRANSPORT DISTANCE IS CORRECTED TO GET DISTANCE AT EARTHS SURFACE CORR = C(1)*ASIN(SINDIF)/( (C(1)+HNEW)*SINDIF ) XNEW = XOLD + (X-XOLD)*CORR X = XNEW YNEW = YOLD + (Y-YOLD)*CORR Y = YNEW H = HNEW C NEW DISTANCE FROM PARTICLE TO DETECTOR CENTER DISTN2 = X**2 + Y**2 C COMPARE NEW AND OLD DISTANCE TO DETECTOR CENTER IF ( DISTN2 .LT. DISTO2 ) THEN C PARTICLE MOVES TOWARDS DETECTOR CENTER SIGNE = +1.D0 ELSE SIGNE = -1.D0 IF (DEBUG) WRITE(MDEBUG,*) 'UPDATC: SIGNE=',SIGNE ENDIF C IN FIRST ORDER APPROXIMATION COSTHE AND COSDIF ARE IN THE SAME PLANE C OF PARTICLE MOVEMENT, THEREFORE THE ANGLES MAY BE ADDED DIRECTLY COSTHENEW = COSTHE*COSDIF - SIGNE*SINDIF*SQRT(1.D0-COSTHE**2) COSTHE = MIN( 1.D0, COSTHENEW ) C KILL HORIZONTAL OR UPWARD GOING PARTICLES IF ( COSTHE .LE. C(29) ) THEN IF ( DEBUG ) WRITE(MDEBUG,555) (CURPAR(I),I=1,9) 555 FORMAT(' UPDATC: KILL 0=',1P,10E10.3) GOTO 200 ENDIF IF ( DEBUG ) WRITE(MDEBUG,562) COSTEA,HAPP 562 FORMAT(' UPDATC: COSTEA,HAPP=',F18.15,1P,E17.9) IF ( DEBUG ) WRITE(MDEBUG,557) (CURPAR(I),I=1,9) 557 FORMAT(' UPDATC: STPEND=',1P,9E10.3,0P/) C WE ARE NOT YET AT DETECTOR. IF ( FDECAY ) THEN C IS WHOLE CHIC OR STEPLC TRAVERSED ? IF ( CHIC .GT. 1.D-10 .AND. STEPLO .LT. STEPLC ) GOTO 2 ELSE C IS WHOLE CHIC TRAVERSED ? IF ( CHIC .GT. 1.D-10 ) GOTO 2 ENDIF C RESTORE CHI IN COMMON CUPPAR FOR CORRECT USE IN MUTRAC CHI = ARG - CHIC C RESTORE STEPL IN COMMON MUMULT FOR CORRECT USE IN MUTRAC IF ( FLAGMU ) STEPL = STEPLO IF ( DEBUG ) WRITE(MDEBUG,*) 'MUTRAC: CHI,STEPL=', * SNGL(CHI),SNGL(STEPL) C CALCULATE ANGLES IN THE NEW FRAME AUXILSQ = SQRT(X**2 + Y**2) COSTEA = COS(AUXILSQ/C(1)) COSTEA = MIN( 1.D0, COSTEA ) HAPP = (C(1)+HNEW) * COSTEA - C(1) C REJECT PARTICLE WHICH TRAVERSES BELOW OBSERVATION LEVEL MEASURED C IN THE DETECTOR FRAME IF ( HAPP .LT. OBSLEV(1) ) GOTO 200 AUX2SQ = SQRT( (C(1)+HNEW)**2*(1.D0 - COSTEA**2) * + (HAPP-OBSLEV(1))**2 ) COSTAP = (HAPP-OBSLEV(1)) / AUX2SQ IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATC: COSTAP=',COSTAP COSTAP = MIN( 1.D0, COSTAP ) OUTPAR(3) = COSTHE OUTPAR(5) = H OUTPAR(7) = X OUTPAR(8) = Y ENDIF 150 IF ( LLONGI ) THEN C THE PARTICLE IS TRACKED FROM THICKHOLD DOWN TO THCKHN LPCT2 = INT(THCKHN*THSTPI) IF ( SIGNUM(ITYPE) .NE. 0.D0 ) THEN GAMMAN = OUTPAR(2) C TOTAL PATH LENGTH IN UNITS OF LONGI BINS STEPT = (THCKHN - THICKHOLD)*THSTPI C CHARGED PARTICLES SUFFER IONIZATION LOSS. C WE ASSUME HOMOGENEOUS ENERGY DEPOSIT ALONG PATH IF ( STEPT .GT. 0.D0 ) THEN C IONIZATION ENERGY DEPOSED IN EACH BIN EDEPB = PAMA(ITYPE) * (GAMMAOLD - GAMMAN) / STEPT ELSE EDEPB = 0.D0 ENDIF C ENERGY DEPOSIT IN FIRST BIN EDEP1 = EDEPB * (DBLE(LPCT1) - THICKHOLD*THSTPI) C ENERGY AT FIRST BIN BOUNDARY EFRST = PAMA(ITYPE) * GAMMAOLD - EDEP1 IF ( LPCT2. LT. LPCT1 ) THEN EDEPN = EDEPB * (THCKHN*THSTPI - DBLE(LPCT1)) ELSE IF ( IPASC .EQ. 0 ) THEN EDEPN = MAX( 0.D0, EDEPB * (THCKHN*THSTPI - DBLE(LPCT2)) ) ELSE C PARTICLE ARRIVED AT DETECTOR LPCT2 = NSTEP EDEPN = 0.D0 ENDIF ENDIF C NOW FILL FIRST AND LAST+1 BIN, THEN LOOP OVER THE BINS BETWEEN IF ( ITYPE .EQ. 5 ) THEN C MUON(+) LONGITUDIAL DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(LPCT1 ,4) = DLONG(LPCT1 ,4) + EDEP1 DLONG(LPCT2+1,4) = DLONG(LPCT2+1,4) + EDEPN IF ( LPCT2 .GE. LPCT1 ) THEN ELONG(LPCT2,4) = ELONG(LPCT2,4) * + (EFRST-(LPCT2-LPCT1)*EDEPB) PLONG(LPCT2,4) = PLONG(LPCT2,4) + 1.D0 ENDIF ELSEIF ( ITYPE .EQ. 6 ) THEN C MUON(-) LONGITUDIAL DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(LPCT1 ,4) = DLONG(LPCT1 ,4) + EDEP1 DLONG(LPCT2+1,4) = DLONG(LPCT2+1,4) + EDEPN IF ( LPCT2 .GE. LPCT1 ) THEN ELONG(LPCT2,5) = ELONG(LPCT2,5) * + (EFRST-(LPCT2-LPCT1)*EDEPB) PLONG(LPCT2,5) = PLONG(LPCT2,5) + 1.D0 ENDIF ELSEIF ( ITYPE .LT. 100 ) THEN C CHARGED HADRON LONGITUDIAL DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(LPCT1 ,6) = DLONG(LPCT1 ,6) + EDEP1 DLONG(LPCT2+1,6) = DLONG(LPCT2+1,6) + EDEPN IF ( LPCT2 .GE. LPCT1 ) THEN ELONG(LPCT2,6)=ELONG(LPCT2,6)+(EFRST-(LPCT2-LPCT1)*EDEPB) ELONG(LPCT2,7)=ELONG(LPCT2,7)+(EFRST-(LPCT2-LPCT1)*EDEPB) PLONG(LPCT2,6) = PLONG(LPCT2,6) + 1.D0 PLONG(LPCT2,7) = PLONG(LPCT2,7) + 1.D0 ENDIF ELSE C NUCLEI LONGITUDIAL DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(LPCT1 ,6) = DLONG(LPCT1 ,6) + EDEP1 DLONG(LPCT2+1,6) = DLONG(LPCT2+1,6) + EDEPN IF ( LPCT2 .GE. LPCT1 ) THEN ELONG(LPCT2,8)=ELONG(LPCT2,8)+(EFRST-(LPCT2-LPCT1)*EDEPB) PLONG(LPCT2,8) = PLONG(LPCT2,8) + 1.D0 ENDIF ENDIF C LOOP OVER ALL LONGITUDINAL BINS IF ( LPCT2 .GT. LPCT1 ) THEN DO IL = LPCT1,LPCT2-1 IF ( ITYPE .EQ. 5 ) THEN C MUON(+) LONGITUDIAL DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(IL+1,4) = DLONG(IL+1,4) + EDEPB ELONG(IL,4) = ELONG(IL,4) + (EFRST-(IL-LPCT1)*EDEPB) PLONG(IL,4) = PLONG(IL,4) + 1.D0 ELSEIF ( ITYPE .EQ. 6 ) THEN C MUON(-) LONGITUDIAL DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(IL+1,4) = DLONG(IL+1,4) + EDEPB ELONG(IL,5) = ELONG(IL,5) + (EFRST-(IL-LPCT1)*EDEPB) PLONG(IL,5) = PLONG(IL,5) + 1.D0 ELSEIF ( ITYPE .LT. 100 ) THEN C CHARGED HADRON LONGITUDIAL DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(IL+1,6) = DLONG(IL+1,6) + EDEPB ELONG(IL,6) = ELONG(IL,6) + (EFRST-(IL-LPCT1)*EDEPB) ELONG(IL,7) = ELONG(IL,7) + (EFRST-(IL-LPCT1)*EDEPB) PLONG(IL,6) = PLONG(IL,6) + 1.D0 PLONG(IL,7) = PLONG(IL,7) + 1.D0 ELSE C NUCLEI LONGITUDIAL DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(IL+1,6) = DLONG(IL+1,6) + EDEPB ELONG(IL,8) = ELONG(IL,8) + (EFRST-(IL-LPCT1)*EDEPB) PLONG(IL,8) = PLONG(IL,8) + 1.D0 ENDIF ENDDO ENDIF ELSE C NEUTRAL PARTICLES C LONGITUDINAL DISTRIBUTIONS FOR NEUTRAL HADRONS WITHOUT NEUTRINOS C THE PARTICLE IS TRACKED FROM THICKH DOWN TO THCKHN C COUNT THE PARTICLES FOR THE LONGITUDINAL DEVELOPMENT IF ( (ITYPE.GE. 7 .AND. ITYPE.LE.32) .OR. * (ITYPE.GE.71 .AND. ITYPE.LE.74) ) THEN IF ( IPASC .NE. 0 ) THEN C PARTICLE ARRIVES AT DETECTOR LPCT2 = NSTEP ENDIF DO IL = LPCT1,LPCT2 ELONG(IL,6) = ELONG(IL,6) + GAMMA * PAMA(ITYPE) PLONG(IL,6) = PLONG(IL,6) + 1.D0 ENDDO ENDIF ENDIF IF ( IRET2 .NE. 0 .AND. IRETE ) THEN C FILL REMAINING CUTTED ENERGY INTO LONGI BIN AT CUTTING POINT LHEIGH = LPCT2 IF ( ITYPE .EQ. 5 .OR. ITYPE .EQ. 6 ) THEN DLONG(LHEIGH,5) = DLONG(LHEIGH,5) + GAMMAN*PAMA(5) ELSE DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + GAMMAN*PAMA(ITYPE) * - RESTMS(ITYPE) ENDIF C ELIMINATE PARTICLE FALLING BELOW ENERGY CUT RETURN ENDIF ENDIF C ELIMINATE PARTICLE FALLING BELOW ENERGY CUT IF ( IRET2 .NE. 0 .AND. IRETE ) RETURN C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C TRANSPORT TO END OF TRACK IF ( IPASC .EQ. 0 ) THEN ALEVEL = H BETA = SQRT( GAMMA**2 - 1.D0 ) / GAMMA THICKH = THCKHN ELSE C TRANSPORT TO OBSERVATION LEVEL AND BRING TO OUTPUT C COORDINATE SYSTEM AT END OF TRACK HAS TO BE DETECTOR FRAME LEVL = 1 CALL OUTPT1 ENDIF RETURN 200 CONTINUE C TREATMENT OF KILLED PARTICLES C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT, IF PARTICLE IS CUTTED IF ( LLONGI ) THEN C PARTICLE SUFFERED FROM ANGULAR CUT IF ( ITYPE .EQ. 5 .OR. ITYPE .EQ. 6 ) THEN DLONG(LPCT1,5) = DLONG(LPCT1,5) + GAMMAOLD * PAMA(5) ELSE DLONG(LPCT1,7) = DLONG(LPCT1,7) + GAMMAOLD * PAMA(ITYPE) * - RESTMS(ITYPE) ENDIF ENDIF 201 IRET2 = 1 RETURN END *CMZ : 28/02/2002 13.08.20 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE UPDATE( HNEW,THCKHN,IPAS,fmfb ) C----------------------------------------------------------------------- C UPDATE(S PARTICLE PARAMETERS) C C UPDATES PARTICLE PARAMETERS TO OBSERVATION LEVEL WITH NUMBER IPAS C OR TO POINT OF INTERACTION OR DECAY (IPAS=0) C FOR CHARGED PARTICLES THE ENERGY LOSS IS COMPUTED FOR THE WHOLE STEP, C SUBDIVIDED BY THE BOUNDARIES OF THE ATMOSPHERIC LAYERS. CCCTHE PARTICLE IS FLYING THE 1ST HALF (DH/2) WITH INITIAL ENERGY C THE PARTICLE IS FLYING THE 1ST HALF (CHI/2) WITH INITIAL ENERGY C AND ANGLE AND THE 2ND HALF WITH FINAL ENERGY AND ANGLE. C THE TIME CALCULATION FOLLOWS THIS SIMPLIFICATION. C CHARGED PARTICLES ARE DEFLECTED IN THE EARTH MAGNETIC FIELD. C THE ANGLE OF DEFLECTION BY MULTIPLE SCATTERING IS COMPUTED ONLY C FOR MUONS AND ONLY ONCE FOR THE WHOLE STEP AT HALF THICKNESS. C IF PARTICLES COME TO REST BY STOPPING, THEIR PATH TO THE STOPPING C POINT IS CALCULATED. C CHERENKOV RADIATION IS CALCULATED ONLY FOR LOWEST OBSERVATION LEVEL C THIS SUBROUTINE IS CALLED FROM AAMAIN, BOX3, MUTRAC C AND UPDATC. C ARGUMENTS: C HNEW = ALTITUDE OF PARTICLE AFTER UPDATE C THCKHN = THICKNESS OF HNEW C IPAS = 0 TRANSPORT TO END OF RANGE OF PARTICLE C .NE. 0 TRANSPORT TO PASSAGE OF OBSERVATION LEVEL IPAS C C REDESIGN: D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,ATMOS2. COMMON /ATMOS2/ HLAY,HLAY0,THICKL,LAYNO,LAYNEW DOUBLE PRECISION HLAY(6),HLAY0(5,0:4),THICKL(5) INTEGER LAYNO(0:16) LOGICAL LAYNEW *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,ELABCT. COMMON /ELABCT/ ELCUT DOUBLE PRECISION ELCUT(4) *KEEP,GENER. COMMON /GENER/ GEN,ALEVEL DOUBLE PRECISION GEN,ALEVEL *KEEP,IRET. COMMON /IRET/ IRET1,IRET2,IRETE INTEGER IRET1,IRET2 LOGICAL IRETE *KEEP,LONGI. COMMON /LONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG, * SDLONG,SELONG,SPLONG,THSTEP,THSTPI, * LHEIGH,NSTEP,LLONGI,FLGFIT DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9), * APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9), * HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9), * SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI INTEGER LHEIGH,NSTEP LOGICAL LLONGI,FLGFIT *KEEP,MAGNET. COMMON /MAGNET/ BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT DOUBLE PRECISION BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT *KEEP,MUMULT. COMMON /MUMULT/ CHC,OMC,PHISCT,STEPL,VSCAT,FMOLI DOUBLE PRECISION CHC,OMC,PHISCT,STEPL,VSCAT LOGICAL FMOLI *KEEP,OBSPAR. COMMON /OBSPAR/ OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP, * THETPR,PHIPR, * VUECON, * NOBSLV DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10), * HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2) DOUBLE PRECISION VUECON(2) INTEGER NOBSLV *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,CORFRAM, IF=CURVED. COMMON /CORFRAM/ DETSYS LOGICAL DETSYS *KEND. DOUBLE PRECISION ALPHA1,ALPHA2,BETAN,DENS,DH,DR,DTHICK,ELOSS, * FNORM1,FNORM2,F1COS1,F1COS2,F1SIN1,F1SIN2, * GAMMAN,GAMSQ,GLCUT,GMSQM1,HEIGH,HMIDDL, * HNEW,OMEGA,PHI1,RADINV,RANNOR, * SINTH1,SINTH2,SN,SN1,SN2,SN3,SN4, * SNMIDDL1,SNMIDDL2,THICK, * THCKHN,THICKMDL,USW,U10,U12,U20,U22,V,VVV, * V10,V12,V20,V22,W10,W12,W20,W22 INTEGER I,IL,IPAS LOGICAL CFLAG,MUS DOUBLE PRECISION GAM0,TH0 DOUBLE PRECISION CHIT,DT,GAMK,HNEWC,RATIO,THCKHC INTEGER ILAY LOGICAL TCRNKV,TFLAG c-----changed--add logical fmfb c-----changed--add DOUBLE PRECISION AUXIL,CORR,DX,DY,SINDIF,TRANS2 SAVE EXTERNAL HEIGH,RANNOR,THICK DOUBLE PRECISION XBEG,YBEG,ZBEG,TBEG,EBEG,XEND,YEND,ZEND,TEND, * EEND,TPART,XPART,YPART,ZPART,WTPART,CTEA DATA CFLAG /.TRUE./ C----------------------------------------------------------------------- IF (DEBUG) WRITE(MDEBUG,457) (CURPAR(I),I=1,9),HNEW 457 FORMAT(' UPDATE: CURPAR=',1P,9E10.3/ * ' TO HEIGHT ',0P,F13.1) IRET2 = 1 IRETE = .FALSE. C TOTAL HEIGHT DIFFERENCE DH = MAX( H - HNEW, 1.D-10 ) C ATMOSPHERE THICKNESS TRAVERSED DTHICK = MAX( 0.D0, (THCKHN - THICKH) / COSTHE ) C TOTAL PATH FOR UNDEFLECTED PARTICLE SN = DH / COSTHE C GEOMETRICAL MIDDLE CDH HMIDDL = H - 0.5D0*DH C MIDDLE OF THICKNESS THICKMDL = THICKH + 0.5D0*DTHICK*COSTHE HMIDDL = HEIGH(THICKMDL) SNMIDDL1 = ((H-HMIDDL))/COSTHE SNMIDDL2 = SN - SNMIDDL1 SN1 = 0.5D0 * SNMIDDL1 C CALCULATE KINETIC ENERGY CUT IF ( ITYPE .EQ. 5 .OR. ITYPE .EQ. 6 ) THEN MUS = .TRUE. GLCUT = ELCUT(2) / PAMA(ITYPE) + 1.D0 ELSE MUS = .FALSE. GLCUT = ELCUT(1) / PAMA(ITYPE) + 1.D0 ENDIF C CALCULATE THE ENERGY LOSS FOR CHARGED PARTICLES IF ( SIGNUM(ITYPE) .NE. 0.D0 ) THEN C LOOK WITHIN WHICH LAYER THE PARTICLE STARTS IF ( H .LE. HLAY(2) ) THEN ILAY = 1 TH0 = THICKH ELSEIF ( H .LE. HLAY(3) ) THEN ILAY = 2 TH0 = THICKH ELSEIF ( H .LE. HLAY(4) ) THEN ILAY = 3 TH0 = THICKH ELSE ILAY = 4 TH0 = MAX( THICKH, THICKL(5) ) ENDIF C SET START VALUES FOR ITERATION GAM0 = GAMMA IL = ILAY 1 CONTINUE GAM0 = MAX( GAM0, 1.0001D0 ) GAMSQ = GAM0**2 GMSQM1 = GAMSQ - 1.D0 C ENERGY LOSS BY IONIZATION ELOSS = SIGNUM(ITYPE)**2 * C(22) * * ( GAMSQ * (LOG(GMSQM1) + C(23)) / GMSQM1 - 1.D0 ) C LOOK WETHER PARTICLE PENETRATES LAYER BOUNDARY IF ( THICKL(IL) .LT. THCKHN .AND. IL .GT. 1 ) THEN C CALCULATE NEW START VALUES AT LAYER BOUNDARY GAM0 = GAM0 - ELOSS * (THICKL(IL) - TH0) * / (PAMA(ITYPE)*COSTHE) IF ( GAM0 .LE. 1.D0 ) THEN GAMMAN = 1.0001D0 GOTO 3 ENDIF TH0 = THICKL(IL) IL = IL - 1 GOTO 1 ENDIF C GAMMA VALUE FOR CHARGED PARTICLES AT END OF STEP GAMMAN = GAM0 - ELOSS * (THCKHN-TH0) / (PAMA(ITYPE)*COSTHE) 3 CONTINUE ELSE C NO LOSS FOR NEUTRAL PARTICLES GAMMAN = GAMMA ENDIF IF ( LLONGI .OR. CFLAG ) THEN C PARTICLE HAS TO BE TRACKED TO THE CUTOFF ENERGY FOR CHERENKOV PHOTONS C OR FOR LONGITUDINAL DISTRIBUTIONS (AS NEUTRAL DO NOT LOOSE ENERGY IN C UPDATE, THIS CONDITION IS FULFILLED BY CHARGED PARTICLES ONLY) IF ( SIGNUM(ITYPE) .NE. 0.D0 .AND. GAMMAN .LT. GLCUT ) THEN GAMMAN = 0.9D0 + GLCUT * 0.1D0 C SET START VALUES FOR ITERATION IL = ILAY CHIT = 0.D0 GAM0 = GAMMA TH0 = MAX( THICKH, THICKL(5) ) 2 CONTINUE GAM0 = MAX( GAM0, 1.0001D0 ) GAMSQ = GAM0**2 GMSQM1 = GAMSQ - 1.D0 C ENERGY LOSS BY IONIZATION ELOSS = SIGNUM(ITYPE)**2 * C(22) * * ( GAMSQ * (LOG(GMSQM1) + C(23)) / GMSQM1 -1.D0 ) ELOSS = ELOSS / (PAMA(ITYPE) * COSTHE) GAMK = GAM0 - ELOSS * (THICKL(IL) - TH0) C LOOK WETHER PARTICLE PENETRATES LAYER BOUNDARY IF ( GAMMAN .LT. GAMK .AND. IL. GT. 1 ) THEN C CALCULATE PORTION OF RANGE AND NEW START VALUES AT LAYER BOUNDARY CHIT = CHIT + (THICKL(IL) - TH0) / COSTHE GAM0 = GAMK TH0 = THICKL(IL) IL = IL - 1 GOTO 2 ENDIF C PENETRATED MATTER THICKNESS CHI = CHIT + (GAM0 - GAMMAN) / (ELOSS*COSTHE) IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATE: GAMMAN,CHI=', * SNGL(GAMMAN),SNGL(CHI) C CALCULATE CORRECTED PATH PARAMETERS THCKHC = THICKH + COSTHE * CHI HNEWC = HEIGH(THCKHC) DT = SN / (C(25) * BETA * GAMMA) RATIO = .5D0 * (H-HNEWC) / DH DH = MAX( H - HNEWC, 1.D-10 ) SN = DH / COSTHE C GEOMETRICAL MIDDLE CDH HMIDDL = H - 0.5D0*DH C MIDDLE OF THICKNESS THICKMDL = THICKH + 0.5D0*CHI*COSTHE HMIDDL = HEIGH(THICKMDL) SNMIDDL1 = ((H-HMIDDL))/COSTHE SNMIDDL2 = SN - SNMIDDL1 SN1 = 0.5D0 * SNMIDDL1 TFLAG = .TRUE. ELSE TFLAG = .FALSE. ENDIF ELSE IF ( GAMMAN .LT. GLCUT ) THEN C REJECT ALL PARTICLES IF BELOW KINETIC ENERGY CUT IF ( DEBUG ) WRITE(MDEBUG,*) * 'UPDATE: PARTICLE ',ITYPE,' BELOW ENERGY CUT' IRETE = .TRUE. RETURN ENDIF ENDIF C----------------------------------------------------------------------- IF ( IPAS .EQ. 0 ) THEN C UPDATE TO THE END POINT OF THE TRACK IF ( MUS ) THEN C COULOMB SCATTERING ANGLE (FOR MUONS ONLY) IF ( FMOLI ) THEN C TREAT MUON MULTIPLE SCATTERING BY MOLIERE THEORY (SEE GEANT) C CALCULATE AVERAGE DENSITY AND NUMBER OF SCATTERING (OMEGA) DENS = COSTHE * CHI/DH OMEGA = OMC * CHI / BETA**2 IF ( OMEGA .LE. 20.D0 ) THEN C FEW SCATTERING EVENTS, APPLY PLURAL COULOMB SCATTERING CALL MUCOUL(OMEGA,DENS) ELSE C ENOUGH SCATTERING EVENTS, APPLY MOLIERE'S THEORY CALL MMOLIE(OMEGA,DENS) ENDIF ELSE C TREAT MUON MULTIPLE SCATTERING BY GAUSS DISTRIBUTION VSCAT = RANNOR( 0.D0, C(30) * SQRT( CHI/C(21) ) * / (PAMA(5) * GAMMA * BETA**2) ) ENDIF CALL RMMAR( RD,1,1 ) PHISCT = RD(1) * PI2 V = VSCAT IF (DEBUG) WRITE(MDEBUG,*) 'UPDATE: VSCAT=',SNGL(VSCAT), * ' PHISCT=',SNGL(PHISCT) ENDIF IF ( LLONGI .OR. CFLAG ) THEN IF ( TFLAG ) THEN HNEW = HNEWC THCKHN = THCKHC IF ( DEBUG ) WRITE(MDEBUG,*) * 'UPDATE: CHANGED HNEW =',SNGL(HNEW) ENDIF C CHERENKOV RADIATION: LOOK, WHETHER PATH ENDS ABOVE LOWEST OBSERV.LEVEL TCRNKV = .TRUE. ENDIF C UPDATE TO THE OBSERVATION LEVELS ELSE IF ( MUS ) THEN C COULOMB SCATTERING ANGLE (FOR MUONS ONLY) V = VSCAT * SQRT( DTHICK / CHI ) ENDIF IF ( LLONGI .OR. CFLAG ) THEN C CHERENKOV RADIATION: LOOK, WHETHER LOWEST OBSERVATION LEVEL IF ( IPAS .EQ. NOBSLV ) THEN TCRNKV = .TRUE. ELSE TCRNKV = .FALSE. ENDIF ENDIF ENDIF IF ( LLONGI .OR. CFLAG ) THEN C REJECT ALL PARTICLES IF BELOW KINETIC ENERGY CUT IF ( GAMMAN .LT. GLCUT .AND. .NOT.TCRNKV ) THEN IF (DEBUG) WRITE(MDEBUG,*) 'UPDATE: PARTICLE ',ITYPE, * ' BELOW ENERGY CUT, CHERENKOV LIGHT NOT CALCULATED' OUTPAR(2) = GAMMAN IRETE = .TRUE. RETURN ENDIF ENDIF C----------------------------------------------------------------------- C TRANSPORT CHARGED PARTICLES THE FIRST PORTION OF STEP IF ( SIGNUM(ITYPE) .NE. 0.D0 ) THEN C CHARGED PARTICLES SUFFER IONIZATION LOSS, DEFLECTION IN MAGNETIC C FIELD AND MUONS IN ADDITION DO MULTIPLE COULOMB SCATTERING. C DEFLECTION IN EARTH MAGNETIC FIELD ON FIRST HALF OF STEP c--------changed---add if(fmfb) then cc ALPHA1 = SIGNUM(ITYPE) * cc * MIN( 1.D0, 2.D0*SN1*BNORMC /(PAMA(ITYPE)*BETA*GAMMA) ) SINTH1 = SQRT( 1.D0 - COSTHE**2 ) U10 = SINTH1 * COS(-PHI) V10 = SINTH1 * SIN(-PHI) W10 = COSTHE cc FNORM1 = 1.D0 - 0.5D0*ALPHA1**2 * (1.D0 - 0.75D0*ALPHA1**2) cc F1COS1 = ( 1.D0 - FNORM1 ) * COSB cc F1SIN1 = ( 1.D0 - FNORM1 ) * SINB cc VVV = V10 * ALPHA1 * FNORM1 cc USW = U10 * SINB - W10 * COSB cc U12 = U10 - F1SIN1 * USW + VVV * SINB cc V12 = FNORM1 * ( V10 - ALPHA1 * USW ) cc W12 = W10 + F1COS1 * USW - VVV * COSB U12 = U10 V12 = V10 W12 = W10 RADINV = 1.5D0 - 0.5D0 * ( U12**2 + V12**2 + W12**2 ) W12 = MIN( 1.D0, RADINV * W12 ) IF ( W12 .LE. C(29) ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) * 'UPDATE: PARTICLE ',ITYPE,' BELOW ANGLE CUT 1' IRETE = .FALSE. RETURN ENDIF SN2 = SN1 * COSTHE / W12 U12 = RADINV * U12 V12 = RADINV * V12 IF ( U12 .NE. 0.D0 .OR. V12 .NE. 0.D0 ) THEN PHI1 = -ATAN2( V12, U12 ) ELSE PHI1 = 0.D0 ENDIF else c--------changed---add ALPHA1 = SIGNUM(ITYPE) * * MIN( 1.D0, 2.D0*SN1*BNORMC /(PAMA(ITYPE)*BETA*GAMMA) ) SINTH1 = SQRT( 1.D0 - COSTHE**2 ) U10 = SINTH1 * COS(-PHI) V10 = SINTH1 * SIN(-PHI) W10 = COSTHE FNORM1 = 1.D0 - 0.5D0*ALPHA1**2 * (1.D0 - 0.75D0*ALPHA1**2) F1COS1 = ( 1.D0 - FNORM1 ) * COSB F1SIN1 = ( 1.D0 - FNORM1 ) * SINB VVV = V10 * ALPHA1 * FNORM1 USW = U10 * SINB - W10 * COSB U12 = U10 - F1SIN1 * USW + VVV * SINB V12 = FNORM1 * ( V10 - ALPHA1 * USW ) W12 = W10 + F1COS1 * USW - VVV * COSB RADINV = 1.5D0 - 0.5D0 * ( U12**2 + V12**2 + W12**2 ) W12 = MIN( 1.D0, RADINV * W12 ) IF ( W12 .LE. C(29) ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) * 'UPDATE: PARTICLE ',ITYPE,' BELOW ANGLE CUT 1' IRETE = .FALSE. RETURN ENDIF SN2 = SN1 * COSTHE / W12 U12 = RADINV * U12 V12 = RADINV * V12 IF ( U12 .NE. 0.D0 .OR. V12 .NE. 0.D0 ) THEN PHI1 = -ATAN2( V12, U12 ) ELSE PHI1 = 0.D0 ENDIF c--------changed---add endif c--------changed---add C CHERENKOV RADIATION: FILL PARTICLE COORDINATES IF ( TCRNKV ) THEN C ..BEG ARE THE COORDINATES AT BEGIN OF THIS STEP C ..PART ARE THE COORDINATES AT END OF THIS STEP IF ( .NOT. DETSYS ) THEN C TRANSFORM INTO DETECTOR FRAME C FIRST CALCULATE STEP TO X AND Y ALONG EARTH SURFACE DX = +SN1 * U10 + SN2 * U12 DY = -SN1 * V10 - SN2 * V12 TRANS2 = DX**2 + DY**2 AUXIL = SQRT( TRANS2 + (C(1)+HMIDDL)**2 ) SINDIF = SQRT(TRANS2) / AUXIL IF ( SINDIF .GT. 0.D0 ) THEN CORR = C(1) * ASIN(SINDIF) / (AUXIL*SINDIF) ELSE CORR = 1.D0 ENDIF XPART = X + DX*CORR YPART = Y + DY*CORR C CALCULATE ANGLE BETWEEN THE ACTUAL LOCAL AND THE APPARENT COORDINATE C SYSTEM (IMPORTANT FOR DECIDING IN CERENK IF FIRST OR SECOND CALL C AND TO CALCULATE THE INTERMEDIATE DIF ANGLE) AUXIL = SQRT( X**2 + Y**2 ) CTEA = COS( AUXIL/C(1) ) C NOW TRANSFORM THEM IN DETECTOR FRAME. ATTENTION: ANGLE MIGHT BE C VERY LARGE, THEREFORE APPROXIMATION TAN(X) EQUAL X IS NOT ALLOWED! C SINCE X = X(HAPP), DON'T TRANSFORM X AND Y HERE BUT IN CERENK XBEG = X YBEG = Y ELSE CTEA = 1.D0 XBEG = X YBEG = Y XPART = X + SN1 * U10 + SN2 * U12 YPART = Y - SN1 * V10 - SN2 * V12 ENDIF TPART = T + ( SN1 + SN2 ) / ( C(25) * BETA ) CDH ZPART = H - DH * 0.5D0 ZPART = HMIDDL C SET OTHER FUNCTION ARGUMENTS TBEG = T ZBEG = H EBEG = PAMA(ITYPE)*GAMMA TEND = TPART XEND = XPART YEND = YPART ZEND = ZPART EEND = PAMA(ITYPE)*GAMMAN WTPART = 1.D0 CALL CERENK(SN1+SN2,U12,-V12,W12,EBEG,EEND-0.5D0*(EEND-EBEG), * XBEG,YBEG,ZBEG,XEND,YEND,ZEND,TBEG,TEND, * PAMA(ITYPE),SIGNUM(ITYPE),WTPART,CTEA) ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C CHANGE DIRECTION BY COULOMB SCATTERING (FOR MUONS ONLY) IF ( MUS ) THEN C BEFORE SCATTERING : DIRECTION COSINES ARE U12,V12,W12 CALL ADDANG( W12,PHI1, COS(V),PHISCT, W20,PHI1 ) IF ( W20 .LE. C(29) ) THEN IF (DEBUG) WRITE(MDEBUG,*) 'UPDATE: MUON BELOW ANGLE CUT' IRETE = .FALSE. RETURN ENDIF SINTH2 = SQRT( 1.D0 - W20**2 ) U20 = SINTH2 * COS( -PHI1 ) V20 = SINTH2 * SIN( -PHI1 ) C AFTER SCATTERING : DIRECTION COSINES ARE U20,V20,W20 IF ( HNEW .GT. OBSLEV(1) ) THEN C CORRECT ARRIVAL HEIGHT ACCORDING TO INTERACTION OR DECAY IF ( FDECAY ) THEN C IN CASE OF DECAY THE PATH LENGTH SNMIDDL2 IS KEPT CONSTANT HNEW = HMIDDL - SNMIDDL2 * W20 THCKHN = THICK(HNEW) CHI = 0.5D0 * CHI + (THCKHN - THICKMDL)/W20 IF ( DEBUG ) WRITE(MDEBUG,*) * 'UPDATE: DECAY HNEW=',SNGL(HNEW),' CH=',SNGL(CHI) CHI = MAX( CHI, 1.D-20) ELSE C IN CASE OF INTERACTION THE PENETRATED MATTER IS KEPT CONSTANT THCKHN = THICKMDL + 0.5D0*CHI*W20 HNEW = HEIGH(THCKHN) SNMIDDL2 = (HMIDDL - HNEW)/W20 IF ( DEBUG ) WRITE(MDEBUG,*) * 'UPDATE: INTERACT HNEW=',SNGL(HNEW),' SNMIDDL2=',SNMIDDL2 ENDIF STEPL = SNMIDDL1 + SNMIDDL2 SN3 = 0.5D0 * SNMIDDL2 ELSE C KEEP ARRIVAL HEIGHT AND SNMIDDL2, PARTICLE ARRIVES AT OBSERV. LEVEL SN3 = 0.5D0 * SNMIDDL2 * COSTHE / W20 ENDIF ELSE U20 = U12 V20 = V12 W20 = W12 SN3 = 0.5D0 * SNMIDDL2 * COSTHE / W20 ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C TRANSPORT CHARGED PARTICLES THE SECOND PORTION OF STEP C NEW PATH LENGTH, NEW BETA VALUE BECAUSE OF IONIZATION ENERGY LOSS BETAN = SQRT( GAMMAN**2 - 1.D0 ) / GAMMAN C DEFLECTION IN EARTH MAGNETIC FIELD ON SECOND HALF OF STEP c--------changed---add if(fmfb) then cc ALPHA2 = SIGNUM(ITYPE) * cc * MIN(1.D0,2.D0*SN3*BNORMC / (PAMA(ITYPE)*BETAN*GAMMAN)) cc FNORM2 = 1.D0 - 0.5D0*ALPHA2**2 * (1.D0 - 0.75D0*ALPHA2**2) cc F1SIN2 = ( 1.D0 - FNORM2 ) * SINB cc F1COS2 = ( 1.D0 - FNORM2 ) * COSB cc VVV = V20 * ALPHA2 * FNORM2 cc USW = U20 * SINB - W20 * COSB cc U22 = U20 - F1SIN2 * USW + VVV * SINB cc V22 = FNORM2 * ( V20 - ALPHA2 * USW ) cc W22 = W20 + F1COS2 * USW - VVV * COSB U22 = U20 V22 = V20 W22 = W20 RADINV = 1.5D0 - 0.5D0 * ( U22**2 + V22**2 + W22**2 ) W22 = MIN( 1.D0, RADINV * W22 ) IF ( W22 .LE. C(29) ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) * 'UPDATE: PARTICLE ',ITYPE,' BELOW ANGLE CUT 2' IRETE = .FALSE. RETURN ENDIF SN4 = SN3 * W20 / W22 U22 = RADINV * U22 V22 = RADINV * V22 else c--changed---add ALPHA2 = SIGNUM(ITYPE) * * MIN(1.D0,2.D0*SN3*BNORMC / (PAMA(ITYPE)*BETAN*GAMMAN)) FNORM2 = 1.D0 - 0.5D0*ALPHA2**2 * (1.D0 - 0.75D0*ALPHA2**2) F1SIN2 = ( 1.D0 - FNORM2 ) * SINB F1COS2 = ( 1.D0 - FNORM2 ) * COSB VVV = V20 * ALPHA2 * FNORM2 USW = U20 * SINB - W20 * COSB U22 = U20 - F1SIN2 * USW + VVV * SINB V22 = FNORM2 * ( V20 - ALPHA2 * USW ) W22 = W20 + F1COS2 * USW - VVV * COSB RADINV = 1.5D0 - 0.5D0 * ( U22**2 + V22**2 + W22**2 ) W22 = MIN( 1.D0, RADINV * W22 ) IF ( W22 .LE. C(29) ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) * 'UPDATE: PARTICLE ',ITYPE,' BELOW ANGLE CUT 2' IRETE = .FALSE. RETURN ENDIF SN4 = SN3 * W20 / W22 U22 = RADINV * U22 V22 = RADINV * V22 c--changed---add endif c--changed---add OUTPAR(3) = W22 IF ( U22 .NE. 0.D0 .OR. V22 .NE. 0.D0 ) THEN OUTPAR(4) = -ATAN2( V22, U22 ) ELSE OUTPAR(4) = 0.D0 ENDIF C UPDATE COORDINATES AND TIME TO THE END OF DISTANCE IF ( (LLONGI .OR. CFLAG) .AND. TFLAG ) THEN OUTPAR(6) = T + DT* ( RATIO*GAMMA + (1.D0-RATIO)*GAMMAN) ELSE OUTPAR(6) = T + (SN1 + SN2)/(BETA *C(25)) + * (SN3 + SN4)/(BETAN*C(25)) ENDIF OUTPAR(7) = X + SN1*U10 + SN2*U12 + SN3*U20 + SN4*U22 OUTPAR(8) = Y - SN1*V10 - SN2*V12 - SN3*V20 - SN4*V22 C CHERENKOV RADIATION: FILL PARTICLE COORDINATES IF ( TCRNKV ) THEN IF ( .NOT. DETSYS ) THEN C RESAVE OLD COORDINATES DUE TO DIFFERENT DEFINITION IN CERENK C (COORDINATES WERE TRANSFORMED IN CERENK) XEND = XPART YEND = YPART ZEND = ZPART C TRANSFORM INTO DETECTOR FRAME C FIRST CALCULATE STEP TO X AND Y ALONG EARTH SURFACE DX = +SN1*U10 + SN2*U12 + SN3*U20 + SN4*U22 DY = -SN1*V10 - SN2*V12 - SN3*V20 - SN4*V22 TRANS2 = DX**2 + DY**2 AUXIL = SQRT( TRANS2 + (C(1)+HNEW)**2 ) SINDIF = SQRT(TRANS2) / AUXIL IF ( SINDIF .GT. 0.D0 ) THEN CORR = C(1)*ASIN(SINDIF)/(AUXIL*SINDIF) ELSE CORR = 1.D0 ENDIF XPART = X + DX*CORR YPART = Y + DY*CORR C CALCULATE EARTH ANGLE BETWEEN THE ACTUAL LOCAL AND THE C APPARENT COORDINATE SYSTEM (SEE ABOVE) AUXIL = SQRT( X**2 + Y**2 ) CTEA = COS( AUXIL/C(1) ) C NOW TRANSFORM THEM IN DETECTOR FRAME. ATTENTION: ANGLE MIGHT BE C VERY LARGE, THEREFORE APPROXIMATION TAN(X) EQUAL X IS NOT ALLOWED! C DON'T TRANSFORM X AND Y HERE BUT IN CERENK (SEE ABOVE) C XBEG=XEND(LAST PART) AND YBEG=YEND(LAST PART) ARE SET ABOVE ELSE CTEA = 1.D0 XPART = OUTPAR(7) YPART = OUTPAR(8) ENDIF ZPART = HNEW TPART = OUTPAR(6) C SET OTHER FUNCTION ARGUMENTS (FORMER END IS NOW THE BEGIN) TBEG = TEND XBEG = XEND YBEG = YEND ZBEG = ZEND TEND = TPART XEND = XPART YEND = YPART ZEND = ZPART WTPART = 1.D0 CALL CERENK(SN3+SN4,U22,-V22,W22,EBEG+0.5*(EEND-EBEG),EEND, * XBEG,YBEG,ZBEG,XEND,YEND,ZEND,TBEG,TEND, * PAMA(ITYPE),SIGNUM(ITYPE),WTPART,CTEA) ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C REJECT PARTICLES AFTER PRODUCTION OF CHERENKOV LIGHT C AND LONGITUDINAL DEVELOPMENT IF ( (LLONGI .OR. CFLAG) .AND. TCRNKV ) THEN IF ( GAMMAN .LT. GLCUT ) THEN IF (DEBUG) WRITE(MDEBUG,*) 'UPDATE: PARTICLE ',ITYPE, * ' BELOW ENERGY CUT AFTER CREATION OF CHERENKOV LIGHT' OUTPAR(2) = GAMMAN IRETE = .TRUE. RETURN ENDIF ENDIF C----------------------------------------------------------------------- ELSE C NEUTRAL PARTICLES C NO COULOMB SCATTERING, NO DEFLECTION IN MAGNETIC FIELD C HORIZONTAL PATH LENGTH DR = SN * SQRT( 1.D0 - COSTHE**2 ) C UPDATE COORDINATES AND TIME OUTPAR(3) = COSTHE OUTPAR(4) = PHI OUTPAR(6) = T + SN / ( C(25) * BETA ) OUTPAR(7) = X + DR * COS(PHI) OUTPAR(8) = Y + DR * SIN(PHI) ENDIF C----------------------------------------------------------------------- OUTPAR( 1) = CURPAR(1) OUTPAR( 2) = GAMMAN OUTPAR( 5) = HNEW OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL IF (DEBUG) WRITE(MDEBUG,458) (OUTPAR(I),I=1,9) 458 FORMAT(' UPDATE: OUTPAR=',1P,8E10.3,0P,F10.0) C REGULAR END OF UPDATE IRET2 = 0 RETURN END *CMZ : 27/02/2002 16.27.14 by D. HECK IK FZK KARLSRUHE *-- Author : D. HECK IK3 FZK KARLSRUHE 27/04/94 C======================================================================= SUBROUTINE VAPOR(MAPROJ,INEW,JFIN,ITYP,PFRX,PFRY) C----------------------------------------------------------------------- C (E)VAPOR(ATION OF NUCLEONS AND ALPHA PARTICLES FROM FRAGMENT) C C TREATES THE REMAINING UNFRAGMENTED NUCLEUS C EVAPORATION FOLLOWING CAMPI APPROXIMATION C SEE: X. CAMPI AND J. HUEFNER, PHYS.REV. C24 (1981) 2199 C AND J.J. GAIMARD, THESE UNIVERSITE PARIS 7, (1990) C THIS SUBROUTINE IS CALLED FROM SDPM AND VSTORE. C ARGUMENTS INPUT: C MAPROJ = NUMBER OF NUCLEONS OF PROJECTILE C INEW = PARTICLE TYPE OF SPECTATOR FRAGMENT C ARGUMENTS OUTPUT: C JFIN = NUMBER OF FRAGMENTS C ITYP(1:JFIN) = NATURE (PARTICLE CODE) OF FRAGMENTS (GEANT) C PFRX(1:JFIN) = TRANSVERSE MOMENTUM OF FRAGMENTS IN X-DIRECTION C PFRY(1:JFIN) = TRANSVERSE MOMENTUM OF FRAGMENTS IN Y-DIRECTION C C DESIGN : D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,DPMFLG. COMMON /DPMFLG/ NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM INTEGER NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DOUBLE PRECISION PFR(60),PFRX(60),PFRY(60) DOUBLE PRECISION AFIN,AGLH,APRF,BGLH,EEX,PHIFR,RANNOR,SPFRX,SPFRY INTEGER ITYP(60),IARM,INEW,ITYPRM,INRM,IS,IZRM,JC,JFIN, * K,L,LS,MAPROJ,MF,NFIN,NINTA,NNUC,NPRF,NNSTEP SAVE EXTERNAL RANNOR C----------------------------------------------------------------------- IF (DEBUG) WRITE(MDEBUG,*) 'VAPOR : MAPROJ,INEW = ',MAPROJ,INEW ITYPRM = INEW NPRF = INEW/100 NINTA = MAPROJ - NPRF IF ( NINTA .EQ. 0 ) THEN C NO NUCLEON HAS INTERACTED JFIN = 1 PFR(1) = 0.D0 ITYP(1) = INEW IF (DEBUG) WRITE(MDEBUG,*) 'VAPOR : JFIN,NINTA= ',JFIN,NINTA RETURN ENDIF C EXCITATION ENERGY EEX OF PREFRAGMENT C SEE: J.J. GAIMARD, THESE UNIVERSITE PARIS 7, (1990), CHPT. 4.2 EEX = 0.D0 CALL RMMAR(RD,2*NINTA,1) DO 22 L = 1,NINTA IF ( RD(NINTA+L) .LT. RD(L) ) RD(L) = 1. - RD(L) EEX = EEX + RD(L) 22 CONTINUE C DEPTH OF WOODS-SAXON POTENTIAL TO FERMI SURFACE IS 0.040 GEV IF (DEBUG) WRITE(MDEBUG,*)'VAPOR : EEX = ',SNGL(EEX*0.04D0),' GEV' C EVAPORATION: EACH EVAPORATION STEP NEEDS ABOUT 0.020 GEV, THEREFORE C NNSTEP IS EEX * 0.04/0.02 = EEX * 2. NNSTEP = INT(EEX*2.D0) IF ( NNSTEP .LE. 0 ) THEN C EXCITATION ENERGY TOO SMALL, NO EVAPORATION JFIN = 1 PFR(1) = 0.D0 ITYP(1) = INEW IF (DEBUG) WRITE(MDEBUG,*) 'VAPOR : JFIN,EEX = ',JFIN,SNGL(EEX) RETURN ENDIF C AFIN IS ATOMIC NUMBER OF FINAL NUCLEUS APRF = FLOAT(NPRF) AFIN = APRF - 1.6D0 * FLOAT(NNSTEP) NFIN = MAX( INT(AFIN+0.5D0), 0 ) C CORRESPONDS TO DEFINITION; FRAGMENTATION-EVAPORATION C CONVOLUTION EMU07 /MODEL ABRASION EVAPORATION (JNC FZK APRIL 94) C NNUC IS NUMBER OF EVAPORATING NUCLEONS NNUC = NPRF - NFIN IF ( DEBUG ) WRITE(MDEBUG,*) 'VAPOR : NFIN,NNUC = ',NFIN,NNUC JC = 0 IF ( NNUC .LE. 0 ) THEN C NO EVAPORATION JFIN = 1 PFR(1) = 0.D0 ITYP(1) = INEW RETURN ELSEIF ( NNUC .GE. 4 ) THEN C EVAPORATION WITH FORMATION OF ALPHA PARTICLES POSSIBLE C IARM, IZRM, INRM ARE NUMBER OF NUCLEONS, PROTONS, NEUTRONS OF C REMAINDER DO 31 LS = 1,NNSTEP IARM = ITYPRM/100 IF ( IARM .LE. 0 ) GOTO 100 IZRM = MOD(ITYPRM,100) INRM = IARM - IZRM JC = JC + 1 CALL RMMAR(RD,2,1) IF ( RD(1).LT.0.2 .AND. IZRM.GE.2 .AND. INRM.GE.2 ) THEN ITYP(JC) = 402 NNUC = NNUC - 4 ITYPRM = ITYPRM - 402 ELSE IF ( RD(2)*(IZRM+INRM) .LT. IZRM ) THEN ITYP(JC) = 14 ITYPRM = ITYPRM - 101 ELSE ITYP(JC) = 13 ITYPRM = ITYPRM - 100 ENDIF NNUC = NNUC - 1 ENDIF IF ( NNUC .LE. 0 ) GOTO 50 31 CONTINUE ENDIF IF ( NNUC .LT. 4 ) THEN C EVAPORATION WITHOUT FORMATION OF ALPHA PARTICLES CALL RMMAR(RD,NNUC,1) DO 32 IS = 1,NNUC IARM = ITYPRM/100 IF ( IARM .LE. 0 ) GOTO 100 IZRM = MOD(ITYPRM,100) JC = JC + 1 IF ( RD(IS)*IARM .LT. IZRM ) THEN ITYP(JC) = 14 ITYPRM = ITYPRM - 101 ELSE ITYP(JC) = 13 ITYPRM = ITYPRM - 100 ENDIF 32 CONTINUE ENDIF 50 CONTINUE JC = JC + 1 IF ( ITYPRM .GT. 101 ) THEN ITYP(JC) = ITYPRM ELSEIF ( ITYPRM .EQ. 101 ) THEN ITYP(JC) = 14 ELSEIF ( ITYPRM .EQ. 100 ) THEN ITYP(JC) = 13 ELSE JC = JC - 1 IF ( ITYPRM .NE. 0 ) WRITE(MONIOU,*) * 'VAPOR : ILLEGAL PARTICLE ITYPRM =',ITYPRM ENDIF 100 JFIN = JC IF (DEBUG) WRITE(MDEBUG,*) 'VAPOR : NO ITYP PFR' IF ( NFRAGM .EQ. 2 ) THEN C EVAPORATION WITH PT AFTER PARAMETRIZED JACEE DATA DO 150 MF = 1,JFIN PFR(MF) = RANNOR(0.088D0,0.044D0) IF ( DEBUG ) WRITE(MDEBUG,*) MF,ITYP(MF),SNGL(PFR(MF)) 150 CONTINUE ELSEIF ( NFRAGM .EQ. 3 ) THEN C EVAPORATION WITH PT AFTER GOLDHABER'S MODEL (PHYS.LETT.53B(1974)306) DO 160 MF = 1,JFIN K = MAX( 1, ITYP(MF)/100 ) BGLH = K * (MAPROJ - K) / FLOAT(MAPROJ-1) C THE VALUE 0.103 [GEV] IS SIGMA(0)=P(FERMI)/SQRT(5.) * AGLH = 0.103D0 * SQRT( BGLH ) C THE VALUE 0.090 [GEV] IS EXPERIMENTALLY DETERMINED SIGMA(0) AGLH = 0.090D0 * SQRT( BGLH ) PFR(MF) = RANNOR(0.D0,AGLH) IF ( DEBUG ) WRITE(MDEBUG,*) MF,ITYP(MF),SNGL(PFR(MF)) 160 CONTINUE ELSE C EVAPORATION WITHOUT TRANSVERSE MOMENTUM DO 165 MF = 1,JFIN PFR(MF) = 0.D0 IF ( DEBUG ) WRITE(MDEBUG,*) MF,ITYP(MF),SNGL(PFR(MF)) 165 CONTINUE ENDIF C CALCULATE RESIDUAL TRANSVERSE MOMENTUM SPFRX = 0.D0 SPFRY = 0.D0 CALL RMMAR(RD,JFIN,1) DO 170 MF = 1,JFIN PHIFR = PI * RD(MF) PFRX(MF) = PFR(MF) * COS(PHIFR) PFRY(MF) = PFR(MF) * SIN(PHIFR) SPFRY = SPFRY + PFRY(MF) SPFRX = SPFRX + PFRX(MF) 170 CONTINUE C CORRECT ALL TRANSVERSE MOMENTA FOR MOMENTUM CONSERVATION SPFRX = SPFRX / JFIN SPFRY = SPFRY / JFIN DO 180 MF = 1,JFIN PFRX(MF) = PFRX(MF) - SPFRX PFRY(MF) = PFRY(MF) - SPFRY 180 CONTINUE IF (DEBUG) WRITE(MDEBUG,*) 'VAPOR : NINTA,JFIN= ',NINTA,JFIN RETURN END *CMZ : 11/01/2002 09.25.08 by D. HECK IK FZK KARLSRUHE *-- Author : STANFORD LINEAR ACCELERATOR CENTER C======================================================================= C STANFORD LINEAR ACCELERATOR CENTER SUBROUTINE ANNIH C VERSION 4.00 -- 26 JAN 1986/1900 C----------------------------------------------------------------------- C ANNIH(ILATION OF E+) C C GAMMA SPECTRUM FOR TWO GAMMA IN-FLIGHT POSITRON ANNIHILATION. C USING SCHEME BASED ON HEITLER'S P269-270 FORMULAE C THIS ROUTINE SHOULD GIVE THE CORRECT DISTRIBUTION, BUT MORE C THOUGHT COULD BE PUT INTO DEVISING A FASTER SCHEME. HOWEVER, C SINCE POSITRON ANNIHILATION IN FLIGHT IS RELATIVELY INFREQUENT C THIS MAY NOT BE WORTHWHILE. C THIS SUBROUTINE IS CALLED FROM ELECTR. C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,EGSDEB. COMMON /EGSDEB/ JCLOCK,NCLOCK,FEGSDB INTEGER JCLOCK,NCLOCK LOGICAL FEGSDB *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,STACKE. COMMON /STACKE/ E,TIM,U,V,W,X,Y,Z,DNEAR, * ZAP,WAP,WA, * IQ,IGEN,IR,IOBS,LPCTE,NP DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60), * X(60),Y(60),Z(60),DNEAR(60) * ,ZAP(60),WAP(60),WA(60) INTEGER IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP *KEND. COMMON /UPHIOT/ THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI COMMON /USEFUL/ PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE DOUBLE PRECISION PRM,PRMT2,RMI,VCI INTEGER MEDIUM,MEDOLD,IBLOBE DOUBLE PRECISION A,AI,EP,EP0I,G,P,PESG1,PESG2,PAVIP,POT,REJF,T SAVE C----------------------------------------------------------------------- IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP) 1 FORMAT(' ANNIH : NP=',I3,' IR=',I3,' IOBS=',I3) CALL AUSGB2 ENDIF PAVIP = E(NP)+PRM A = PAVIP*RMI AI = 1.D0/A G = A - 1.D0 T = G - 1.D0 P = SQRT(A*T) POT = P/T EP0I = (A+P) 331 CONTINUE C SAMPLE 1/EP FROM EP=1./EP0I TO 1.0-1./EP0I CALL RMMAR(RD,2,2) EP = EXP(DBLE(RD(1))*LOG(EP0I-1.D0))/EP0I C NOW DECIDE WHETHER TO ACCEPT REJF = 1.D0 - EP + AI*AI*(2.D0*G-1.D0/EP) IF ( RD(2) .GT. REJF ) GOTO 331 C THIS COMPLETES SAMPLING OF A DISTRIBUTION WHICH IS ASYMMETRIC C ABOUT EP=1/2, BUT WHICH WHEN SYMMETRIZED IS THE SYMMETRIC C ANNIHILATION DISTRIBUTION. PICK EP IN (1/2,1-EP0). PESG1 = PAVIP*MAX(EP,1.D0-EP) E(NP) = PESG1 E(NP+1) = PAVIP-E(NP) PESG2 = E(NP+1) C SET UP ANGLES OF HIGHER ENERGY GAMMA IQ(NP) = 1 COSTHE = (PESG1-PRM)*POT/PESG1 SINTHE = SQRT(MAX( 0.D0, 1.D0-COSTHE**2 )) CALL UPHI(2,1) NP = NP+1 C SET UP ANGLES OF LOWER ENERGY GAMMA IQ(NP) = 1 COSTHE = (PESG2-PRM)*POT/PESG2 SINTHE = SQRT(MAX( 0.D0, 1.D0-COSTHE**2 )) CALL UPHI(3,2) RETURN END *CMZ : 11/01/2002 09.25.08 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE AUSGAB C----------------------------------------------------------------------- C WE USE AUSGAB TO FILL OUTPAR WITH PARTICLE COORDINATES. C THIS SUBROUTINE IS CALLED FROM ELECTR AND PHOTON. C C DESIGN : D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,EGSDEB. COMMON /EGSDEB/ JCLOCK,NCLOCK,FEGSDB INTEGER JCLOCK,NCLOCK LOGICAL FEGSDB *KEEP,GENER. COMMON /GENER/ GEN,ALEVEL DOUBLE PRECISION GEN,ALEVEL *KEND. COMMON /MISC/ DUNIT,RHOR,KMPI,KMPO,NOSCAT,MED,IRAYLR DOUBLE PRECISION DUNIT,RHOR(6) INTEGER KMPI,KMPO,NOSCAT,MED(6),IRAYLR(6) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,STACKE. COMMON /STACKE/ E,TIM,U,V,W,X,Y,Z,DNEAR, * ZAP,WAP,WA, * IQ,IGEN,IR,IOBS,LPCTE,NP DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60), * X(60),Y(60),Z(60),DNEAR(60) * ,ZAP(60),WAP(60),WA(60) INTEGER IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP *KEND. COMMON /UPHIOT/ THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI COMMON /USEFUL/ PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE DOUBLE PRECISION PRM,PRMT2,RMI,VCI INTEGER MEDIUM,MEDOLD,IBLOBE DOUBLE PRECISION ANGLEX,ANGLEZ,XX,YY,ZZ SAVE C----------------------------------------------------------------------- C ANGLE WITH RESPECT TO X AXIS IF ( U(NP) .NE. 0.D0 .OR. V(NP) .NE. 0.D0 ) THEN ANGLEX = -ATAN2(V(NP),U(NP)) ELSE ANGLEX = 0.D0 ENDIF C PARTICLE IS WRITTEN IN OUTPUT BUFFER ARRAY OUTPAR(1) = IQ(NP) OUTPAR(2) = E(NP)*0.001D0 OUTPAR(3) = MIN( 1.D0, W(NP) ) OUTPAR(4) = ANGLEX OUTPAR(5) =-Z(NP) OUTPAR(6) = TIM(NP) OUTPAR(7) = X(NP) OUTPAR(8) =-Y(NP) OUTPAR(9) = IGEN(NP) OUTPAR(10) = ALEVEL LEVL = IOBS(NP) CALL OUTPT1 IF ( FEGSDB ) THEN WRITE(MDEBUG,*) 'AUSGAB: NP=',NP,' IR=',IR(NP),' IOBS=',IOBS(NP) XX = X(NP) YY =-Y(NP) ZZ =-Z(NP) ANGLEZ = W(NP) WRITE(MDEBUG,170) IQ(NP),E(NP)*.001D0,ANGLEZ,ANGLEX,ZZ, * TIM(NP)*1.D3,XX,YY,IGEN(NP) 170 FORMAT(' AUSGAB:',13X,I4,1P,E11.3,0P,1X,F7.4,1X,F7.4,1X,F9.0, * F9.6,1X,1P,E11.4,1X,E11.4,1X,I3 * ) ENDIF RETURN END *CMZ : 18/02/2002 16.47.35 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE AUSGB2 C----------------------------------------------------------------------- C IN CASE OF DEBUGGING WE PRINT THE PARTICLE COORDINATES. C THIS SUBROUTINE IS CALLED FROM MANY EGS-ROUTINES. C C DESIGN : D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,EGSDEB. COMMON /EGSDEB/ JCLOCK,NCLOCK,FEGSDB INTEGER JCLOCK,NCLOCK LOGICAL FEGSDB *KEND. COMMON /MISC/ DUNIT,RHOR,KMPI,KMPO,NOSCAT,MED,IRAYLR DOUBLE PRECISION DUNIT,RHOR(6) INTEGER KMPI,KMPO,NOSCAT,MED(6),IRAYLR(6) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,STACKE. COMMON /STACKE/ E,TIM,U,V,W,X,Y,Z,DNEAR, * ZAP,WAP,WA, * IQ,IGEN,IR,IOBS,LPCTE,NP DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60), * X(60),Y(60),Z(60),DNEAR(60) * ,ZAP(60),WAP(60),WA(60) INTEGER IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP *KEND. COMMON /UPHIOT/ THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI COMMON /USEFUL/ PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE DOUBLE PRECISION PRM,PRMT2,RMI,VCI INTEGER MEDIUM,MEDOLD,IBLOBE DOUBLE PRECISION ANGLEX,ANGLEZ,XX,YY,ZZ SAVE C----------------------------------------------------------------------- C ANGLE WITH RESPECT TO X AXIS IF ( U(NP) .NE. 0.D0 .OR. V(NP) .NE. 0.D0 ) THEN ANGLEX = -ATAN2(V(NP),U(NP)) ELSE ANGLEX = 0.D0 ENDIF XX = X(NP) YY =-Y(NP) ZZ =-Z(NP) ANGLEZ = W(NP) WRITE(MDEBUG,170) IQ(NP),E(NP)*.001D0,ANGLEZ,ANGLEX,ZZ, * TIM(NP)*1.0D3,XX,YY,IGEN(NP) 170 FORMAT(' AUSGB2:',13X,I4,1P,E11.3,0P,1X,F8.5,1X,F7.4,1X,F9.0, * 1X,F9.6,1X,1P,E11.4,1X,E11.4,0P,1X,I3 * ) RETURN END *CMZ : 11/01/2002 09.25.08 by D. HECK IK FZK KARLSRUHE *-- Author : STANFORD LINEAR ACCELERATOR CENTER C======================================================================= C STANFORD LINEAR ACCELERATOR CENTER SUBROUTINE BHABHA C VERSION 4.00 -- 26 JAN 1986/1900 C----------------------------------------------------------------------- C BHABHA (SCATTERING) C C DISCRETE BHABHA SCATTERING (A CALL TO THIS ROUTINE) HAS BEEN C ARBITRARILY DEFINED AND CALCULATED TO MEAN BHABHA SCATTERINGS C WHICH IMPART TO THE SECONDARY ELECTRON SUFFICIENT ENERGY THAT C IT BE TRANSPORTED DISCRETELY, I.E. E=AE OR T=TE. IT IS NOT C GUARANTEED THAT THE FINAL POSITRON WILL HAVE THIS MUCH ENERGY C HOWEVER. THE EXACT BHABHA DIFFERENTIAL CROSS-SECTION IS USED. C THIS SUBROUTINE IS CALLED FROM ELECTR. C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,EGSDEB. COMMON /EGSDEB/ JCLOCK,NCLOCK,FEGSDB INTEGER JCLOCK,NCLOCK LOGICAL FEGSDB *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,STACKE. COMMON /STACKE/ E,TIM,U,V,W,X,Y,Z,DNEAR, * ZAP,WAP,WA, * IQ,IGEN,IR,IOBS,LPCTE,NP DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60), * X(60),Y(60),Z(60),DNEAR(60) * ,ZAP(60),WAP(60),WA(60) INTEGER IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP *KEND. COMMON /THRESH/ RMSQ,API,TE,THMOLL,AP,AE,UP,UE DOUBLE PRECISION RMSQ,API,TE,THMOLL REAL AP,AE,UP,UE COMMON /UPHIOT/ THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI COMMON /USEFUL/ PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE DOUBLE PRECISION PRM,PRMT2,RMI,VCI INTEGER MEDIUM,MEDOLD,IBLOBE * DOUBLE PRECISION BETAI2,BR,B1,B2,B3,B4,DCOSTH,EP0,EP0C,E0,E02,H1, DOUBLE PRECISION BETA2,BR,B1,B2,B3,B4,DCOSTH,EP0,EP0C,E0,E02,H1, * PEIP,PEKIN,PEKINI,PEKSE2,PESE1,PESE2,REJF2, * T0,YY,Y2,YP,YP2 SAVE C----------------------------------------------------------------------- IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP) 1 FORMAT(' BHABHA: NP=',I3,' IR=',I3,' IOBS=',I3) CALL AUSGB2 ENDIF PEIP = E(NP) C KINETIC ENERGY OF INCIDENT POSITRON PEKIN = PEIP-PRM PEKINI= 1.D0/PEKIN T0 = PEKIN*RMI E0 = T0+1.D0 YY = 1.D0/(T0+2.D0) E02 = E0**2 C CORRECTED 18.12.98 * BETAI2= E02/(E02-1.D0) BETA2 = (E02-1.D0)/E02 EP0 = TE*PEKINI EP0C = 1.D0-EP0 Y2 = YY*YY YP = 1.D0-2.D0*YY YP2 = YP**2 B4 = YP2*YP B3 = B4+YP2 B2 = YP*(3.D0+Y2) B1 = 2.D0-Y2 341 CONTINUE C SAMPLE BR FROM MINIMUM(EP0) TO 1 CALL RMMAR(RD,2,2) BR = EP0/(1.D0-EP0C*RD(1)) C CORRECTED 18.12.98 * REJF2 = EP0C*(BETAI2-BR*(B1-BR*(B2-BR*(B3-BR*B4)))) REJF2 = (1.D0-BETA2*BR*(B1-BR*(B2-BR*(B3-BR*B4)))) IF ( RD(2) .GT. REJF2 ) GOTO 341 IF ( BR .LT. 0.5D0 ) THEN IQ(NP+1) = 3 ELSE C IF E- GOT MORE THAN E+, MOVE THE E+ POINTER AND REFLECT B IQ(NP) = 3 IQ(NP+1) = 2 BR = 1.D0-BR ENDIF BR = MAX( 0.D0, BR ) C DIVIDE UP THE ENERGY PEKSE2 = BR*PEKIN PESE1 = PEIP-PEKSE2 PESE2 = PEKSE2+PRM E(NP) = PESE1 E(NP+1)= PESE2 C DETERMINE ANGLES FROM KINEMATICS H1 = (PEIP+PRM)*PEKINI C DIRECTION COSINE CHANGE FOR 'OLD' ELECTRON DCOSTH = MIN( 1.D0, H1*(PESE1-PRM)/(PESE1+PRM) ) SINTHE = SQRT(1.D0-DCOSTH) COSTHE = SQRT(DCOSTH) CALL UPHI(2,1) NP = NP+1 DCOSTH = MIN( 1.D0, H1*(PESE2-PRM)/(PESE2+PRM) ) SINTHE =-SQRT(1.D0-DCOSTH) COSTHE = SQRT(DCOSTH) CALL UPHI(3,2) RETURN END *CMZ : 11/01/2002 09.25.08 by D. HECK IK FZK KARLSRUHE *-- Author : STANFORD LINEAR ACCELERATOR CENTER C======================================================================= C STANFORD LINEAR ACCELERATOR CENTER SUBROUTINE BREMS C VERSION 4.00 -- 26 JAN 1986/1900 C----------------------------------------------------------------------- C BREMS(STRAHLUNG GENERATION) C C FOR ELECTRON ENERGY GREATER THAN 5.0 MEV, THE BETHE-HEITLER C CROSS-SECTION IS EMPLOYED. C THIS SUBROUTINE IS CALLED FROM ELECTR. C----------------------------------------------------------------------- IMPLICIT NONE COMMON /BREMPR/ PWR2I,DL1,DL2,DL3,DL4,DL5,DL6,DELCM,ALPHI,BPAR, * DELPOS DOUBLE PRECISION PWR2I(60) REAL DL1(6),DL2(6),DL3(6),DL4(6),DL5(6),DL6(6), * DELCM,ALPHI(2),BPAR(2),DELPOS(2) *KEEP,EGSDEB. COMMON /EGSDEB/ JCLOCK,NCLOCK,FEGSDB INTEGER JCLOCK,NCLOCK LOGICAL FEGSDB *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,STACKE. COMMON /STACKE/ E,TIM,U,V,W,X,Y,Z,DNEAR, * ZAP,WAP,WA, * IQ,IGEN,IR,IOBS,LPCTE,NP DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60), * X(60),Y(60),Z(60),DNEAR(60) * ,ZAP(60),WAP(60),WA(60) INTEGER IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP *KEND. COMMON /THRESH/ RMSQ,API,TE,THMOLL,AP,AE,UP,UE DOUBLE PRECISION RMSQ,API,TE,THMOLL REAL AP,AE,UP,UE COMMON /UPHIOT/ THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI COMMON /USEFUL/ PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE DOUBLE PRECISION PRM,PRMT2,RMI,VCI INTEGER MEDIUM,MEDOLD,IBLOBE DOUBLE PRECISION ABREMS,AI2LN2,BR,DEL,DELTA,P,PEIE,PESG,PESE, * REJF,T INTEGER IDISTR,LVL,LVL0,LVX SAVE DATA AI2LN2/0.721347521D0/ C----------------------------------------------------------------------- IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP) 1 FORMAT(' BREMS : NP=',I3,' IR=',I3,' IOBS=',I3) CALL AUSGB2 ENDIF PEIE = E(NP) NP = NP+1 C DECIDE WHICH DISTRIBUTION TO USE IF ( PEIE .LT. 50.D0 ) THEN C (B-H IS USED 1.5 TO 50 MEV) LVX = 1 LVL0 = 0 ELSE C (B-H COULOMB CORRECTED IS USED ABOVE 50 MEV) LVX = 2 LVL0 = 3 ENDIF C TWO TIMES AI2LN2 = 1.442695041 ABREMS = DBLE(INT(1.442695041D0*LOG(PEIE*API))) C THE METHOD OF BUTCHER AND MESSEL FOR SAMPLING A CLASS OF FACTORIZABLE C FREQUENCY DISTRIBUTIONS IS USED. OUR 'BR' VARIABLE IS THE SAME AS C THEIR 'EPSILON' VARIABLE. (SEE BUTCHER AND MESSEL,NUCL.PHYS.,VOL.20, C PP23,24. COMPUTE NUMBER OF SUBDISTRIBUTIONS NEEDED TO PRODUCE PHOTONS C OF MINIMUM DISCRETE TRANSPORT ENRGY AP, IN CASE THE (1-BR)/BR C PART OF THE DISTRIBUTION IS USED. 351 CONTINUE CALL RMMAR(RD,3,2) C DECIDE WHETHER TO SAMPLE FROM (1-BR)/BR OR 2*BR PART OF DISTRIBUTION IF ( (ABREMS*ALPHI(LVX)+0.5D0)*RD(1) .GE. 0.5D0 ) THEN C USE THE (1-BR)/BR PART. WHICH SUBDISTRIBUTION? IDISTR = ABREMS*RD(2) C THIS CHOOSES IDISTR AT RANDOM FROM SET (0,1,2, ..., NBREMS-1) P = PWR2I(IDISTR+1) C SELECT SCREENING REJECTION FUNCTION C LVL=1 UNCOULOMB CORRECTED A(DELTA) C LVL=2 UNCOULOMB CORRECTED B(DELTA) C LVL=3 UNCOULOMB CORRECTED C(DELTA) C LVL=4 COULOMB CORRECTED A(DELTA) C LVL=5 COULOMB CORRECTED B(DELTA) C LVL=6 COULOMB CORRECTED C(DELTA) LVL = LVL0+1 C USE A(DELTA), EITHER BORN OR COULOMB CORRECTED, DEPENDING ON C WHETHER LVL HAS BEEN PREVIOUSLY SET TO 0 OR 3. C ALL SUBDISTRIBUTIONS ARE SAMPLED BY FIRST SAMPLING FROM C (1./LOG(2.))*(1.-BR)/BR IF 0.5 .LE. BR .LE. 1. C 1./LOG(2.) IF BR.LT. 0.5 C AND THEN TAKING BR = BR*P C AI2LN2 IS ACTUALLY 1./(2.*LOG(2.)), WHICH IS THE PROBABILITY C THAT BR IS LESS THAN 0.5 IN THE ELEMENTARY DISTRIBUTION ABOVE. IF ( RD(3) .GE. AI2LN2 ) THEN 361 CONTINUE CALL RMMAR(RD,3,2) BR = 1.D0-0.5D0*MAX(RD(2),RD(3)) IF ( BR*RD(1) .GT. 0.5D0 ) GOTO 361 ELSE CALL RMMAR(RD,1,2) BR = RD(1)*0.5D0 ENDIF BR = BR*P ELSE BR = MAX(RD(2),RD(3)) C USE B(DELTA) FOR SCREENING FUNCTION LVL = LVL0+2 ENDIF C NOW ATTRIBUTE ENERGIES TO THE PARTICLES PESG = PEIE*BR C AP IS SELECTED IN PROGRAM PEGS (ESTABLISHING CROSS-SECTION FILE) C MINIMUM HARDNESS REQUIREMENT, CORRESPONDING TO LOWER BOUND C CHOICE FOR TOTAL CROSS-SECTION INTEGRAL IF ( PESG .LT. AP ) GOTO 351 PESE = PEIE-PESG C THE ELECTRON MUST HAVE A MINIMUM ENERGY EQUAL TO 0.511 MEV IF ( PESE .LT. PRM ) GOTO 351 C DEFINITION OF DELTA IS DELTA=136.0*EXP(ZG)*RM*EE/(E*(1.0-EE)) C =DELCM*EE/(E*(1.0-EE))=DELCM*DEL C WHERE E=ELECTRON INCIDENT ENERGY(MEV), AND EE=(PHOTON ENERGY)/E C ZG IS DEFINED IN THE PROGRAM SHINP, AND IS A WEIGHTED AVERAGE C OF LOG(Z**(-1./3.)) OVER THE VARIOUS TYPES OF ATOMS IN THE C MOLECULE (BUTCHER AND MESSEL, OP.CIT., P.17-19,22-24). DEL = BR/PESE C A(DELTA) AND B(DELTA) MUST ALWAYS BE POSITIVE IF ( DEL .GE. DELPOS(LVX) ) GOTO 351 DELTA = DELCM*DEL IF ( DELTA .LT. 1.D0 ) THEN REJF = DL1(LVL)+DELTA*(DL2(LVL)+DELTA*DL3(LVL)) ELSE REJF = DL4(LVL)+DL5(LVL)*LOG(DELTA+DL6(LVL)) ENDIF CALL RMMAR(RD,1,2) C SCREENING REJECTION IF ( RD(1) .GT. REJF ) GOTO 351 THETA = PRM/PEIE CALL UPHI(1,3) C ATTRIBUTE PARTICLE ENERGIES AND PROPERTIES IF ( PESG .LE. PESE ) THEN IQ(NP ) = 1 E(NP) = PESG E(NP-1) = PESE ELSE IQ(NP) = IQ(NP-1) IQ(NP-1)= 1 E(NP) = PESE E(NP-1) = PESG C INTERCHANGE STACK POSITION OF ELECTRON AND PHOTON T = U(NP) U(NP) = U(NP-1) U(NP-1) = T T = V(NP) V(NP) = V(NP-1) V(NP-1) = T T = W(NP) W(NP) = W(NP-1) W(NP-1) = T ENDIF RETURN END *CMZ : 11/01/2002 09.25.08 by D. HECK IK FZK KARLSRUHE *-- Author : STANFORD LINEAR ACCELERATOR CENTER C======================================================================= C STANFORD LINEAR ACCELERATOR CENTER SUBROUTINE COMPT C VERSION 4.00 -- 26 JAN 1986/1900 C----------------------------------------------------------------------- C COMPT(ON SCATTERING) C C BUTCHER AND MESSEL'S CROSS-SECTION EXPRESSION IS USED C (BUTCHER AND MESSEL, OP.CIT., P. 17-19,25), BUT THE C 1/EPSILON PART IS NOT SAMPLED IN THE WAY THAT THEY DO. C THIS ROUTINE CALLS THEIR 'EPSILON' VARIABLE BY THE NAME 'BR'. C BR=FINAL PHOTON ENERGY /INITIAL PHOTON ENERGY. C BR0 = MINIMUM BR = 1./(1.+2.*(E(NP)/PRM)) C MAXIMUM BR IS 1. C BUTCHER AND MESSEL'S EXPRESSION FOR THE DIFFERENTIAL CROSS- C SECTION IS PROPORTIONAL TO C (1./BR+BR)*(1.-BR*SINTHE**2/(1.+BR*BR)) C WE SHALL SAMPLE FROM THE FIRST FACTOR FROM THE INTERVAL (BR0,1) C AND USE THE SECOND FACTOR AS A REJECTION FUNCTION. C THIS SUBROUTINE IS CALLED FROM PHOTON. C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,EGSDEB. COMMON /EGSDEB/ JCLOCK,NCLOCK,FEGSDB INTEGER JCLOCK,NCLOCK LOGICAL FEGSDB *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,STACKE. COMMON /STACKE/ E,TIM,U,V,W,X,Y,Z,DNEAR, * ZAP,WAP,WA, * IQ,IGEN,IR,IOBS,LPCTE,NP DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60), * X(60),Y(60),Z(60),DNEAR(60) * ,ZAP(60),WAP(60),WA(60) INTEGER IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP *KEND. COMMON /THRESH/ RMSQ,API,TE,THMOLL,AP,AE,UP,UE DOUBLE PRECISION RMSQ,API,TE,THMOLL REAL AP,AE,UP,UE COMMON /UPHIOT/ THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI COMMON /USEFUL/ PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE DOUBLE PRECISION PRM,PRMT2,RMI,VCI INTEGER MEDIUM,MEDOLD,IBLOBE DOUBLE PRECISION ALPH1,ALPH2,A1MIBR,BR,BRP,BR0,BR0I,EGP, * PEIG,PESG,PESE,PSQ,SUMALP,T,TEMP SAVE C----------------------------------------------------------------------- IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP) 1 FORMAT(' COMPT : NP=',I3,' IR=',I3,' IOBS=',I3) CALL AUSGB2 ENDIF PEIG = E(NP) EGP = PEIG*RMI BR0I = 1.D0+2.D0*EGP BR0 = 1.D0/BR0I ALPH1 = LOG(BR0I) ALPH2 = EGP*(BR0I+1.D0)*BR0**2 SUMALP = ALPH1+ALPH2 371 CONTINUE CALL RMMAR(RD,3,2) C WHICH PART OF 1./BR + BR TO SAMPLE FROM ? IF ( ALPH1 .GE. SUMALP*RD(1) ) THEN C USE 1/BR PART OF DISTRIBUTION BR = EXP(ALPH1*RD(2))*BR0 ELSE C USE LINEAR ( BR ) PART OF DISTRIBUTION BRP = RD(2) IF ( EGP .GE. (EGP+1.D0)*RD(3) ) THEN CALL RMMAR(RD(4),1,2) BRP = MAX(RD(2),RD(4)) ENDIF BR = ((BR0I-1.D0)*BRP+1.D0)*BR0 ENDIF C BR=FINAL PHOTON ENERGY FRACTION PESG = BR*PEIG C THE COMPTON ANGLES FOR PHOTON AND RECOIL ELECTRON ARE UNIQUELY C DETERMINED BY THE CONSERVATION LAWS A1MIBR = 1.D0-BR TEMP = PRM*A1MIBR/PESG SINTHE = MAX( 0.D0, TEMP*(2.D0-TEMP) ) CALL RMMAR(RD,1,2) IF ( (1.D0-RD(1))*(1.D0+BR**2) .LT. BR*SINTHE ) GOTO 371 SINTHE = SQRT(SINTHE) COSTHE = 1.D0-TEMP C NOW FILL IN THE PARTICLE PROPERTIES PESE = PEIG-PESG+PRM CALL UPHI(2,1) NP = NP+1 C MOMENTUM SQUARED OF ELECTRON PSQ = PESE*PESE-RMSQ IF ( PSQ .LE. 0.D0 ) THEN COSTHE = 0.D0 SINTHE = -1.D0 ELSE COSTHE = (PESE+PESG)*A1MIBR/SQRT(PSQ) SINTHE = -SQRT(MAX( 0.D0, 1.0-COSTHE**2 )) ENDIF CALL UPHI(3,2) IF ( PESE .LE. PESG ) THEN IQ(NP) = 3 E(NP) = PESE E(NP-1) = PESG ELSE C SORT PARTICLES ON STACK WITH DESCENDING ENERGY IQ(NP) = 1 IQ(NP-1)= 3 E(NP) = PESG E(NP-1) = PESE T = U(NP) U(NP) = U(NP-1) U(NP-1) = T T = V(NP) V(NP) = V(NP-1) V(NP-1) = T T = W(NP) W(NP) = W(NP-1) W(NP-1) = T ENDIF RETURN END *CMZ : 11/01/2002 09.25.08 by D. HECK IK FZK KARLSRUHE *-- Author : D. HECK IK3 FZK KARLSRUHE 18/06/99 C======================================================================= SUBROUTINE CORNEC C----------------------------------------------------------------------- C CO(O)R(DINATE) (I)N(ITIALIZATION FOR) E(M IN A) C(URVED ATMOSPHERE) C C INITIALIZES ALL IMPORTANT COORDINATES FOR ONE OBSERVATION LEVEL C ROUTINE DETERMINES STARTING PARAMETERS AT HEIGHT GIVEN BY THICK0 FOR C A COORDINATE SYSTEM WHICH IS FIXED IN (X,Y) AT THE ASSUMED DETECTOR C POSITION AND IN Z AT SEA LEVEL. C THIS SUBROUTINE IS CALLED FROM ELECTR AND PHOTON. C C DESIGN : D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,OBSPAR. COMMON /OBSPAR/ OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP, * THETPR,PHIPR, * VUECON, * NOBSLV DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10), * HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2) DOUBLE PRECISION VUECON(2) INTEGER NOBSLV *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,STACKE. COMMON /STACKE/ E,TIM,U,V,W,X,Y,Z,DNEAR, * ZAP,WAP,WA, * IQ,IGEN,IR,IOBS,LPCTE,NP DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60), * X(60),Y(60),Z(60),DNEAR(60) * ,ZAP(60),WAP(60),WA(60) INTEGER IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP *KEND. DOUBLE PRECISION DIST,DIAG,TANPHI,TEA SAVE C----------------------------------------------------------------------- IF (DEBUG) WRITE(MDEBUG,*) 'CORNEC: -Z(NP),WAP(NP),U(NP),V(NP)=', * SNGL(-Z(NP)),SNGL(WAP(NP)),SNGL(U(NP)),SNGL(V(NP)) C NOTE : ANGLES WAP, U, AND V ARE APPARENT ANGLES OF PRIMARY AT C THE EDGE OF THE ATMOSPHERE SEEN FROM THE C DETECTOR POSITION X=Y=0, Z=-OBSLEV(1) C FOR CALCULATIONS: WAP = COSINE OF APPARENT ZENITH ANGLE THETAP C WAP IS SET IN SUBR. EGS4 C DISTANCE DIAG BETWEEN DETECTOR POSITION X=Y=0, Z =-OBSLEV(1) AND C STARTING POINT DIAG = SQRT( (C(1)-Z(NP))**2 * -(C(1)+OBSLEV(1))**2 *(1.D0-WAP(NP)**2) ) * - (C(1)+OBSLEV(1)) * WAP(NP) C APPARENT HEIGHT ZAP IS PARTICLE Z-COORDINATE IN DETECTOR SYSTEM ZAP(NP) = -OBSLEV(1) - DIAG * WAP(NP) C CALCULATING COSINE OF THETA_EARTH COSTEA, COSINE OF ZENITH ANGLE BY C TAKING A COORDINATE FRAME CENTERED IN THE MIDDLE OF EARTH WA(NP) = (C(1)-ZAP(NP)) / (C(1)-Z(NP)) IF ( DEBUG ) WRITE(MDEBUG,*) 'CORNEC:-ZAP(NP),WA(NP),DIAG =', * SNGL(-ZAP(NP)),WA(NP),SNGL(DIAG) WA(NP) = MIN( 1.D0, WA(NP) ) C TRANSFORM THE APPARENT ANGLE SEEN FROM DETECTOR POSITION TO LOCAL C ANGLES RELATIVE TO THE VERTICAL TO THE MIDDLE OF EARTH C NOTE : LOCAL ZENITH ANGLE = DIFFERENCE OF APPARENT ZENITH ANGLE AND C THETA_EARTH W(NP) = (DIAG + (C(1)+OBSLEV(1))*WAP(NP))/(C(1)-Z(NP)) W(NP) = MIN( 1.D0, W(NP) ) IF ( U(NP) .NE. 0.D0 ) THEN TANPHI= V(NP) / U(NP) U(NP) = SIGN(1.D0,U(NP))*SQRT((1.D0-W(NP)**2)/(1.D0+TANPHI**2)) V(NP) = TANPHI * U(NP) ELSE IF ( V(NP) .NE. 0.D0 ) * V(NP) = SIGN(1.D0,V(NP)) * SQRT( 1.D0 - W(NP)**2 ) ENDIF C DISTANCE DIST BETWEEN THE DETECTOR POSITION X=0, Y=0 C AND THE ACTUAL INTERACTION POINT MEASURED ON THE EARTH'S SURFACE TEA = ACOS(WA(NP)) DIST = C(1) * TEA C CONCERNING TRANSFORMATION OF AZIMUTH ANGLE PHI C NOTE : THE COORDINATE SYTEMS ONLY DIFFER IN A SHIFT ALONG THE Z-AXIS C OR A ROTATION ALONG THE ZENITH ANGLE. BOTH TRANSFORMATIONS C JUST CHANGE THETA AND NOT PHI (THETA AND PHI ARE ORTHOGONAL C COORDINATES, THUS LINEAR INDEPENDENT). C X,Y-COORDINATES SEEN FROM THE DETECTOR POSITION (X=Y=0) C PHIP IS DEFINED HERE IN OBSPAR, BUT IS NOT SENSIBEL TO USE IN THIS C ROUTINE; WE HAVE TO TAKE NOT PHI OF PRIMARY, BUT FROM CURRENT C PARTICLE. TAKE NEW LOCAL DIRECTION COSINES (SEE ABOVE) IF ( W(NP) .LT. 1.D0 ) THEN X(NP) = -DIST * U(NP) / SQRT( 1.D0 - W(NP)**2 ) Y(NP) = -DIST * V(NP) / SQRT( 1.D0 - W(NP)**2 ) ELSE X(NP) = -DIST * U(NP) Y(NP) = -DIST * V(NP) ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'CORNEC: X(NP),Y(NP),W(NP),DIST =', * SNGL(X(NP)),SNGL(Y(NP)),SNGL(W(NP)),SNGL(DIST) C NOW ALL PARAMETERS ARE FILLED INTO STACKE RETURN END *CMZ : 20/02/2002 09.17.35 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE EGS4( EEIN ) C----------------------------------------------------------------------- C E(LECTRON) G(AMMA) S(HOWER) C C TREATS ELECTROMAGNETIC SUBSHOWER C THIS SUBROUTINE IS CALLED FROM EM. C ARGUMENT: C EEIN = (R8) INCOMING PARTICLE ENERGY (GEV) C C DESIGN : D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,EGSDEB. COMMON /EGSDEB/ JCLOCK,NCLOCK,FEGSDB INTEGER JCLOCK,NCLOCK LOGICAL FEGSDB *KEEP,GENER. COMMON /GENER/ GEN,ALEVEL DOUBLE PRECISION GEN,ALEVEL *KEND. COMMON /GEOMEGS/ ZALTIT,BOUND,OBSLVL,NEWOBS DOUBLE PRECISION ZALTIT,BOUND(6),OBSLVL(10) INTEGER NEWOBS *KEEP,LONGI. COMMON /LONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG, * SDLONG,SELONG,SPLONG,THSTEP,THSTPI, * LHEIGH,NSTEP,LLONGI,FLGFIT DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9), * APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9), * HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9), * SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI INTEGER LHEIGH,NSTEP LOGICAL LLONGI,FLGFIT *KEND. COMMON /MISC/ DUNIT,RHOR,KMPI,KMPO,NOSCAT,MED,IRAYLR DOUBLE PRECISION DUNIT,RHOR(6) INTEGER KMPI,KMPO,NOSCAT,MED(6),IRAYLR(6) *KEEP,OBSPAR. COMMON /OBSPAR/ OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP, * THETPR,PHIPR, * VUECON, * NOBSLV DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10), * HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2) DOUBLE PRECISION VUECON(2) INTEGER NOBSLV *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEND. COMMON /PION/ PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR, * AMASNT DOUBLE PRECISION PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR, * AMASNT *KEEP,REJECT. COMMON /REJECT/ AVNREJ,ALTMIN,ANEXP,THICKA,THICKD,CUTLN,EONCUT, * FNPRIM DOUBLE PRECISION AVNREJ(10),ALTMIN(10),ANEXP(10),THICKA(10), * THICKD(10),CUTLN,EONCUT LOGICAL FNPRIM *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,STACKE. COMMON /STACKE/ E,TIM,U,V,W,X,Y,Z,DNEAR, * ZAP,WAP,WA, * IQ,IGEN,IR,IOBS,LPCTE,NP DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60), * X(60),Y(60),Z(60),DNEAR(60) * ,ZAP(60),WAP(60),WA(60) INTEGER IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP *KEND. COMMON /THRESH/ RMSQ,API,TE,THMOLL,AP,AE,UP,UE DOUBLE PRECISION RMSQ,API,TE,THMOLL REAL AP,AE,UP,UE COMMON /USEFUL/ PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE DOUBLE PRECISION PRM,PRMT2,RMI,VCI INTEGER MEDIUM,MEDOLD,IBLOBE DOUBLE PRECISION EEIN,SITHET,THICK INTEGER IDET,K SAVE EXTERNAL THICK C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'EGS4 :' C FILL IN STARTING COORDINATES NP = 1 TIM(1) = SECPAR(6) X(1) = SECPAR(7) Y(1) =-SECPAR(8) C STARTS IN HEIGHT 'Z' DOWNWARDS Z(1) =-SECPAR(5) IF ( LLONGI ) LPCTE(1)=MIN(NSTEP,INT(THICK(SECPAR(5))*THSTPI)+1) SITHET = SQRT(1.D0-SECPAR(3)**2) C START DIRECTION COSINES U(NP) = SITHET*COS(-SECPAR(4)) V(NP) = SITHET*SIN(-SECPAR(4)) W(NP) = SECPAR(3) ZAP(NP) =-SECPAR(14) WAP(NP) = SECPAR(15) WA(NP) = SECPAR(16) IGEN(1) = GEN C CONVERSION GEV --> MEV E(1) = EEIN*1000.D0 C CHECK ENERGY RANGE IQ(1) = NINT(SECPAR(1)) IF ( IQ(1) .EQ. 1 ) THEN IF ( E(1) .GT. UP ) THEN CALL AUSGB2 WRITE(KMPO,91) EEIN 91 FORMAT(' EGS4 : ENERGY OF GAMMA =',1P,E10.3,' GEV TOO HIGH') STOP ENDIF ELSE IF ( E(1) .GT. UE ) THEN CALL AUSGB2 WRITE(KMPO,92) EEIN 92 FORMAT(' EGS4 : ENERGY OF ELECTRON/POSITRON =',1P,E10.3, * ' GEV TOO HIGH') STOP ENDIF ENDIF DNEAR(1) = 0.D0 DO 101 K = 1,5 C DETERMINE START REGION IF ( -BOUND(K).LE.Z(1) .AND. -BOUND(K+1).GT.Z(1) ) THEN IR(1) = K+1 GOTO 110 ENDIF 101 CONTINUE CALL AUSGB2 WRITE(KMPO,120) (-0.01)*Z(1) 120 FORMAT (' EGS4 : START VALUE OF Z=',1P,E11.4,' M NOT IN ', * 'ATMOSPHERE') RETURN 110 CONTINUE DO 111 IDET = 1,NOBSLV C DETERMINE NEXT OBSERVATION LEVEL IF ( -Z(1) .GE. OBSLVL(IDET) ) THEN IOBS(1) = IDET GOTO 130 ENDIF 111 CONTINUE CALL AUSGB2 WRITE(KMPO,140) (-0.01)*Z(1),OBSLVL(NOBSLV)*0.01 140 FORMAT(' EGS4 : START VALUE OF Z= ',E11.4, ' M BELOW LOWEST ', * 'DETECTOR AT',E11.4,' M') RETURN 130 CONTINUE C NEWOBS IS THE NEXT OBSERVATION LEVEL NEWOBS = IOBS(NP) CALL SHOWER IF ( DEBUG ) WRITE(MDEBUG,*) 'EGS4 : EGS-STACK EMPTY, EXIT' RETURN END *CMZ : 12/10/2001 14.53.55 by D. HECK IK FZK KARLSRUHE *-- Author : STANFORD LINEAR ACCELERATOR CENTER C======================================================================= C STANFORD LINEAR ACCELERATOR CENTER BLOCK DATA EGS4BD C VERSION 4.00 -- 26 JAN 1986/1900 C----------------------------------------------------------------------- C INITIALIZES GENERAL DATA OF EGS4 C----------------------------------------------------------------------- IMPLICIT NONE COMMON /BOUNDS/ ECUT,PCUT,VACDST DOUBLE PRECISION ECUT(6),PCUT(6),VACDST COMMON /ELECIN/ EKE0,EKE1,XR0,TEFF0,BLCC,XCC,ESIG0,ESIG1,PSIG0, * PSIG1,EDEDX0,EDEDX1,PDEDX0,PDEDX1,EBR10,EBR11, * PBR10,PBR11,PBR20,PBR21,TMXS0,TMXS1,ERANG0, * ERANG1,PRANG0,PRANG1,STERNCOR REAL EKE0,EKE1,XR0,TEFF0,BLCC,XCC, * ESIG0(500),ESIG1(500),PSIG0(500),PSIG1(500), * EDEDX0(500),EDEDX1(500),PDEDX0(500),PDEDX1(500), * EBR10(500),EBR11(500),PBR10(500),PBR11(500), * PBR20(500),PBR21(500),TMXS0(500),TMXS1(500), * ERANG0(1),ERANG1(1),PRANG0(1),PRANG1(1),STERNCOR *KEEP,EGSDEB. COMMON /EGSDEB/ JCLOCK,NCLOCK,FEGSDB INTEGER JCLOCK,NCLOCK LOGICAL FEGSDB *KEEP,EPCONT. COMMON /EPCONT/ EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP, * RHOFAC,EOLD,ENEW,EKE,ELKE,BETA2,GLE,TSCAT, * IDISC,IROLD,IRNEW DOUBLE PRECISION EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP, * RHOFAC,EOLD,ENEW, EKE,ELKE,BETA2,GLE,TSCAT INTEGER IDISC,IROLD,IRNEW *KEND. COMMON /MEDIA/ RLDU,RLDUI,RHO,RLC,NMED,MSGE,MGE,MSEKE,MEKE, * MLEKE,MCMFP,MRANGE,IRAYLM DOUBLE PRECISION RLDU,RLDUI REAL RHO,RLC INTEGER NMED,MSGE,MGE,MSEKE,MEKE,MLEKE,MCMFP,MRANGE, * IRAYLM COMMON /MEDIAC/ MEDIA CHARACTER MEDIA*24 COMMON /MISC/ DUNIT,RHOR,KMPI,KMPO,NOSCAT,MED,IRAYLR DOUBLE PRECISION DUNIT,RHOR(6) INTEGER KMPI,KMPO,NOSCAT,MED(6),IRAYLR(6) COMMON /MULTS/ B0G21,B1G21,G210,G211,G212, * B0G22,B1G22,G220,G221,G222, * B0G31,B1G31,G310,G311,G312, * B0G32,B1G32,G320,G321,G322, * B0BGB,B1BGB,BGB0,BGB1,BGB2,NBGB DOUBLE PRECISION B0G21,B1G21,G210(7),G211(7),G212(7), * B0G22,B1G22,G220(8),G221(8),G222(8), * B0G31,B1G31,G310(11),G311(11),G312(11), * B0G32,B1G32,G320(25),G321(25),G322(25), * B0BGB,B1BGB,BGB0(8),BGB1(8),BGB2(8) INTEGER NBGB COMMON /PATHCM/ B0PTH,B1PTH,PTH0,PTH1,PTH2,NPTH DOUBLE PRECISION B0PTH,B1PTH,PTH0(6),PTH1(6),PTH2(6) INTEGER NPTH COMMON /THRESH/ RMSQ,API,TE,THMOLL,AP,AE,UP,UE DOUBLE PRECISION RMSQ,API,TE,THMOLL REAL AP,AE,UP,UE COMMON /UPHIOT/ THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI COMMON /USEFUL/ PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE DOUBLE PRECISION PRM,PRMT2,RMI,VCI INTEGER MEDIUM,MEDOLD,IBLOBE CHARACTER MEDIA1*24 EQUIVALENCE (MEDIA1,MEDIA) C----------------------------------------------------------------------- DATA NCLOCK/0/,JCLOCK/2147483647/ DATA ECUT/6*0.D0/,PCUT/6*0.D0/,VACDST/1.D9/ DATA RHOFAC/1.D0/ DATA NMED/1/,MEDIA1/'NAI '/ DATA IRAYLM/1*0/ DATA KMPI/12/,KMPO/8/,DUNIT/1.D0/,NOSCAT/0/ DATA MED/6*1/,RHOR/6*0.D0/,IRAYLR/6*0/ DATA B0G21/ 2.0000D0/,B1G21/ 5.0000D0/ DATA G210(1),G211(1),G212(1)/-9.9140D-04, 2.7672D+00,-1.1544D+00/ DATA G210(2),G211(2),G212(2)/-9.9140D-04, 2.7672D+00,-1.1544D+00/ DATA G210(3),G211(3),G212(3)/-7.1017D-02, 3.4941D+00,-3.0773D+00/ DATA G210(4),G211(4),G212(4)/-7.3556D-02, 3.5487D+00,-3.1989D+00/ DATA G210(5),G211(5),G212(5)/ 3.6658D-01, 2.1162D+00,-2.0311D+00/ DATA G210(6),G211(6),G212(6)/ 1.4498D+00,-5.9717D-01,-3.2951D-01/ DATA G210(7),G211(7),G212(7)/ 1.4498D+00,-5.9717D-01,-3.2951D-01/ DATA B0G22/ 2.0000D0/,B1G22/ 6.0000D0/ DATA G220(1),G221(1),G222(1)/-5.2593D-04, 1.4285D+00,-1.2670D+00/ DATA G220(2),G221(2),G222(2)/-5.2593D-04, 1.4285D+00,-1.2670D+00/ DATA G220(3),G221(3),G222(3)/-6.4819D-02, 2.2033D+00,-3.6399D+00/ DATA G220(4),G221(4),G222(4)/ 3.7427D-02, 1.6630D+00,-2.9362D+00/ DATA G220(5),G221(5),G222(5)/ 6.1955D-01,-6.2713D-01,-6.7859D-01/ DATA G220(6),G221(6),G222(6)/ 1.7584D+00,-4.0390D+00, 1.8810D+00/ DATA G220(7),G221(7),G222(7)/ 2.5694D+00,-6.0484D+00, 3.1256D+00/ DATA G220(8),G221(8),G222(8)/ 2.5694D+00,-6.0484D+00, 3.1256D+00/ DATA B0G31/ 2.0000D0/,B1G31/ 9.0000D0/ DATA G310(1),G311(1),G312(1)/ 4.9437D-01, 1.9124D-02, 1.8375D+00/ DATA G310(2),G311(2),G312(2)/ 4.9437D-01, 1.9124D-02, 1.8375D+00/ DATA G310(3),G311(3),G312(3)/ 5.3251D-01,-6.1555D-01, 4.5595D+00/ DATA G310(4),G311(4),G312(4)/ 6.6810D-01,-2.2056D+00, 8.9293D+00/ DATA G310(5),G311(5),G312(5)/-3.8262D+00, 2.5528D+01,-3.3862D+01/ DATA G310(6),G311(6),G312(6)/ 4.2335D+00,-1.0604D+01, 6.6702D+00/ DATA G310(7),G311(7),G312(7)/ 5.0694D+00,-1.4208D+01, 1.0456D+01/ DATA G310(8),G311(8),G312(8)/ 1.4563D+00,-3.3275D+00, 2.2601D+00/ DATA G310(9),G311(9),G312(9)/-3.2852D-01, 1.2938D+00,-7.3254D-01/ DATA G310(10),G311(10),G312(10)/-2.2489D-1, 1.0713D+0,-6.1358D-1/ DATA G310(11),G311(11),G312(11)/-2.2489D-1, 1.0713D+0,-6.1358D-1/ DATA B0G32/ 2.0000D0/,B1G32/ 2.3000D1/ DATA G320(1),G321(1),G322(1)/ 2.9907D-05, 4.7318D-01, 6.5921D-01/ DATA G320(2),G321(2),G322(2)/ 2.9907D-05, 4.7318D-01, 6.5921D-01/ DATA G320(3),G321(3),G322(3)/ 2.5820D-03, 3.5853D-01, 1.9776D+00/ DATA G320(4),G321(4),G322(4)/-5.3270D-03, 4.9418D-01, 1.4528D+00/ DATA G320(5),G321(5),G322(5)/-6.6341D-02, 1.4422D+00,-2.2407D+00/ DATA G320(6),G321(6),G322(6)/-3.6027D-01, 4.7190D+00,-1.1380D+01/ DATA G320(7),G321(7),G322(7)/-2.7953D+00, 2.6694D+01,-6.0986D+01/ DATA G320(8),G321(8),G322(8)/-3.6091D+00, 3.4125D+01,-7.7512D+01/ DATA G320(9),G321(9),G322(9)/ 1.2491D+01,-7.1103D+01, 9.4496D+01/ DATA G320(10),G321(10),G322(10)/ 1.9637D+1,-1.1371D+2, 1.5794D+2/ DATA G320(11),G321(11),G322(11)/ 2.1692D+0,-2.5019D+1, 4.5340D+1/ DATA G320(12),G321(12),G322(12)/-1.6682D+1, 6.2067D+1,-5.5257D+1/ DATA G320(13),G321(13),G322(13)/-2.1539D+1, 8.2651D+1,-7.7065D+1/ DATA G320(14),G321(14),G322(14)/-1.4344D+1, 5.5193D+1,-5.0867D+1/ DATA G320(15),G321(15),G322(15)/-5.4990D+0, 2.3874D+1,-2.3140D+1/ DATA G320(16),G321(16),G322(16)/ 3.1029D+0,-4.4708D+0, 2.1318D-1/ DATA G320(17),G321(17),G322(17)/ 6.0961D+0,-1.3670D+1, 7.2823D+0/ DATA G320(18),G321(18),G322(18)/ 8.6179D+0,-2.0950D+1, 1.2536D+1/ DATA G320(19),G321(19),G322(19)/ 7.5064D+0,-1.7956D+1, 1.0520D+1/ DATA G320(20),G321(20),G322(20)/ 5.9838D+0,-1.4065D+1, 8.0342D+0/ DATA G320(21),G321(21),G322(21)/ 4.4959D+0,-1.0456D+1, 5.8462D+0/ DATA G320(22),G321(22),G322(22)/ 3.2847D+0,-7.6709D+0, 4.2445D+0/ DATA G320(23),G321(23),G322(23)/ 1.9514D+0,-4.7505D+0, 2.6452D+0/ DATA G320(24),G321(24),G322(24)/ 4.8808D-1,-1.6910D+0, 1.0459D+0/ DATA G320(25),G321(25),G322(25)/ 4.8808D-1,-1.6910D+0, 1.0459D+0/ DATA NBGB/ 8/,B0BGB/ 1.5714D0/,B1BGB/ 2.1429D-1/ DATA BGB0(1),BGB1(1),BGB2(1)/-1.0724D+00, 2.8203D+00,-3.5669D-01/ DATA BGB0(2),BGB1(2),BGB2(2)/ 3.7136D-01, 1.4560D+00,-2.8072D-02/ DATA BGB0(3),BGB1(3),BGB2(3)/ 1.1396D+00, 1.1910D+00,-5.2070D-03/ DATA BGB0(4),BGB1(4),BGB2(4)/ 1.4908D+00, 1.1267D+00,-2.2565D-03/ DATA BGB0(5),BGB1(5),BGB2(5)/ 1.7342D+00, 1.0958D+00,-1.2705D-03/ DATA BGB0(6),BGB1(6),BGB2(6)/ 1.9233D+00, 1.0773D+00,-8.1806D-04/ DATA BGB0(7),BGB1(7),BGB2(7)/ 2.0791D+00, 1.0649D+00,-5.7197D-04/ DATA BGB0(8),BGB1(8),BGB2(8)/ 2.0791D+00, 1.0649D+00,-5.7197D-04/ DATA NPTH/ 6/,B0PTH/ 2.0000D0/,B1PTH/ 1.8182D1/ DATA PTH0(1),PTH1(1),PTH2(1)/ 1.0000D+00, 9.8875D-01, 2.5026D+00/ DATA PTH0(2),PTH1(2),PTH2(2)/ 1.0000D+00, 9.8875D-01, 2.5026D+00/ DATA PTH0(3),PTH1(3),PTH2(3)/ 1.0060D+00, 7.8657D-01, 4.2387D+00/ DATA PTH0(4),PTH1(4),PTH2(4)/ 1.0657D+00,-2.5051D-01, 8.7681D+00/ DATA PTH0(5),PTH1(5),PTH2(5)/ 1.6971D+00,-7.5600D+00, 2.9946D+01/ DATA PTH0(6),PTH1(6),PTH2(6)/ 1.6971D+00,-7.5600D+00, 2.9946D+01/ END *CMZ : 12/12/2001 11.52.56 by D. HECK IK FZK KARLSRUHE *-- Author : D. HECK IK3 FZK KARLSRUHE 03/02/97 C======================================================================= SUBROUTINE EGSINI C----------------------------------------------------------------------- C E(LECTRON) G(AMMA) S(HOWER) INI(TIALIZATION) C C INITIALIZES EGS4 PACKAGE C THIS SUBROUTINE IS CALLED FROM START. C C DESIGN : D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,ATMOS. COMMON /ATMOS/ AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM DOUBLE PRECISION AATM(5),AATM0(5,0:16),BATM(5),BATM0(5,0:16), * CATM(5),CATM0(5,0:16),DATM(5) INTEGER MODATM *KEEP,ATMOS2. COMMON /ATMOS2/ HLAY,HLAY0,THICKL,LAYNO,LAYNEW DOUBLE PRECISION HLAY(6),HLAY0(5,0:4),THICKL(5) INTEGER LAYNO(0:16) LOGICAL LAYNEW *KEND. COMMON /BOUNDS/ ECUT,PCUT,VACDST DOUBLE PRECISION ECUT(6),PCUT(6),VACDST *KEEP,ELABCT. COMMON /ELABCT/ ELCUT DOUBLE PRECISION ELCUT(4) *KEND. COMMON /ELECIN/ EKE0,EKE1,XR0,TEFF0,BLCC,XCC,ESIG0,ESIG1,PSIG0, * PSIG1,EDEDX0,EDEDX1,PDEDX0,PDEDX1,EBR10,EBR11, * PBR10,PBR11,PBR20,PBR21,TMXS0,TMXS1,ERANG0, * ERANG1,PRANG0,PRANG1,STERNCOR REAL EKE0,EKE1,XR0,TEFF0,BLCC,XCC, * ESIG0(500),ESIG1(500),PSIG0(500),PSIG1(500), * EDEDX0(500),EDEDX1(500),PDEDX0(500),PDEDX1(500), * EBR10(500),EBR11(500),PBR10(500),PBR11(500), * PBR20(500),PBR21(500),TMXS0(500),TMXS1(500), * ERANG0(1),ERANG1(1),PRANG0(1),PRANG1(1),STERNCOR COMMON /GEOMEGS/ ZALTIT,BOUND,OBSLVL,NEWOBS DOUBLE PRECISION ZALTIT,BOUND(6),OBSLVL(10) INTEGER NEWOBS COMMON /LAYER/ HBARO,HBAROI DOUBLE PRECISION HBARO(6),HBAROI(6) COMMON /MEDIA/ RLDU,RLDUI,RHO,RLC,NMED,MSGE,MGE,MSEKE,MEKE, * MLEKE,MCMFP,MRANGE,IRAYLM DOUBLE PRECISION RLDU,RLDUI REAL RHO,RLC INTEGER NMED,MSGE,MGE,MSEKE,MEKE,MLEKE,MCMFP,MRANGE, * IRAYLM COMMON /MEDIAC/ MEDIA CHARACTER MEDIA*24 COMMON /MISC/ DUNIT,RHOR,KMPI,KMPO,NOSCAT,MED,IRAYLR DOUBLE PRECISION DUNIT,RHOR(6) INTEGER KMPI,KMPO,NOSCAT,MED(6),IRAYLR(6) COMMON /MUON/ PRRMMU,RMMUT2 DOUBLE PRECISION PRRMMU,RMMUT2 *KEEP,OBSPAR. COMMON /OBSPAR/ OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP, * THETPR,PHIPR, * VUECON, * NOBSLV DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10), * HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2) DOUBLE PRECISION VUECON(2) INTEGER NOBSLV *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEND. COMMON /PION/ PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR, * AMASNT DOUBLE PRECISION PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR, * AMASNT *KEEP,REJECT. COMMON /REJECT/ AVNREJ,ALTMIN,ANEXP,THICKA,THICKD,CUTLN,EONCUT, * FNPRIM DOUBLE PRECISION AVNREJ(10),ALTMIN(10),ANEXP(10),THICKA(10), * THICKD(10),CUTLN,EONCUT LOGICAL FNPRIM *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. COMMON /THRESH/ RMSQ,API,TE,THMOLL,AP,AE,UP,UE DOUBLE PRECISION RMSQ,API,TE,THMOLL REAL AP,AE,UP,UE COMMON /UPHIOT/ THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI COMMON /USEFUL/ PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE DOUBLE PRECISION PRM,PRMT2,RMI,VCI INTEGER MEDIUM,MEDOLD,IBLOBE DOUBLE PRECISION ECUTMIN,HEIGH INTEGER I,IDET,IRL,JREG,KREG CHARACTER MEDARR*24 LOGICAL LAVAIL SAVE EXTERNAL HEIGH DATA MEDARR/'AIR-NTP '/ C----------------------------------------------------------------------- C INITIALIZATION BEFORE THE FIRST CALL OF EGS4 IF ( DEBUG ) THEN WRITE(MDEBUG,*) 'EGSINI:' KMPO = MDEBUG ELSE KMPO = MONIOU ENDIF WRITE(KMPO,10) 10 FORMAT (/' START EGS4 AIR SHOWER SUBROUTINE VERSION (JUN 99)'/) C SET PARTICLE MASSES AND PHYSICAL CONSTANTS PRM = PAMA(2)*1.D3 RMSQ = PRM**2 RMI = 1.D0/PRM PRMT2 = 2.D0*PRM PRRMMU = PAMA(5)*1.D3 RMMUT2 = 2.D0*PRRMMU PICMAS = PAMA(8)*1.D3 PI0MAS = PAMA(7)*1.D3 PI0MSQ = PI0MAS**2 AMASKC = PAMA(11)*1.D3 AMASK0 = PAMA(10)*1.D3 AMASPR = PAMA(14)*1.D3 AMASNT = PAMA(13)*1.D3 C INVERSE OF VELOCITY OF LIGHT VCI = 1.D0/C(25) PI = 2.D0 * ACOS(0.D0) TWOPI = 2.D0 * PI C PION-PRODUCTION THRESHOLD (MEV) PITHR = 152.D0 C NMED AND DUNIT DEFAULT TO 1,I.E. ONE MEDIUM AND WE WORK IN CM MEDIUM=1 DO I = 1,24 MEDIA(I:I)=MEDARR(I:I) ENDDO C BOUNDARY 1: TOP OF ATMOSPHERE (SEE SUBR. HOWFAR) BOUND(1) = HEIGH(0.D0) C BOUNDARY 6: 1CM BELOW LOWEST AIR LAYER BOUND(6) = HLAY(1) - 1.D0 MED(1) = 0 MED(6) = 0 C VACUUM IN REGIONS 1 AND 6, AIR IN REGION 2 TO 5 DO IRL = 2,5 MED(IRL) = 1 C PARAMETERS OF ATMOSPHERE ARE TAKEN FROM CORSIKAPROGRAM BOUND(IRL) = HLAY(6-IRL) HBARO(IRL) = CATM(6-IRL) HBAROI(IRL) = 1.D0/HBARO(IRL) RHOR(IRL) = BATM(6-IRL)*HBAROI(IRL) C NEEDED FOR REGION 2 TO 5 SINCE NO TRANSPORT ELSEWHERE C ECUT IS TOTAL ENERGY C TERMINATE ELECTRON HISTORIES AT ECUT (GEV TO MEV CONVERTED) ECUT(IRL) = 1000.D0*ELCUT(3)+PRM C TERMINATE PHOTON HISTORIES AT PCUT (GEV TO MEV CONVERTED) PCUT(IRL) = 1000.D0*ELCUT(4) ENDDO C LOOK FOR MINIMUM ENERGY CUT TO SELECT OPTIMAL EGSDATA SET ECUTMIN = MIN(1000.D0*ELCUT(3), 1000.D0*ELCUT(3)) 33 CONTINUE IF ( ECUTMIN .GE. 3.D0 ) THEN INQUIRE(FILE='EGSDAT3_3.',EXIST=LAVAIL) IF ( LAVAIL ) THEN OPEN(UNIT=KMPI,FILE='EGSDAT3_3.',STATUS='OLD') WRITE(KMPO,*) 'DATASET EGSDAT3_3. AVAILABLE' STERNCOR = 0.0 ELSE ECUTMIN = 1.1D0 WRITE(KMPO,*) * 'DATASET EGSDAT3_3. BEST SUITED BUT NOT AVAILABLE' GOTO 33 ENDIF ELSEIF ( ECUTMIN .GE. 1.D0 ) THEN INQUIRE(FILE='EGSDAT3_1.',EXIST=LAVAIL) IF ( LAVAIL ) THEN OPEN(UNIT=KMPI,FILE='EGSDAT3_1.',STATUS='OLD') WRITE(KMPO,*) 'DATASET EGSDAT3_1. AVAILABLE' STERNCOR = 6.0 ELSE ECUTMIN = 0.5D0 WRITE(KMPO,*) * 'DATASET EGSDAT3_1. BEST SUITED BUT NOT AVAILABLE' GOTO 33 ENDIF ELSEIF ( ECUTMIN .GE. 0.4D0 ) THEN INQUIRE(FILE='EGSDAT3_.4',EXIST=LAVAIL) IF ( LAVAIL ) THEN OPEN(UNIT=KMPI,FILE='EGSDAT3_.4',STATUS='OLD') WRITE(KMPO,*) 'DATASET EGSDAT3_.4 AVAILABLE' STERNCOR = 10.0 ELSE ECUTMIN = 0.26D0 WRITE(KMPO,*) * 'DATASET EGSDAT3_.4 BEST SUITED BUT NOT AVAILABLE' GOTO 33 ENDIF ELSEIF ( ECUTMIN .GE. 0.25D0 ) THEN INQUIRE(FILE='EGSDAT3_.25',EXIST=LAVAIL) IF ( LAVAIL ) THEN OPEN(UNIT=KMPI,FILE='EGSDAT3_.25',STATUS='OLD') WRITE(KMPO,*) 'DATASET EGSDAT3_.25 AVAILABLE' STERNCOR = 11.0 ELSE ECUTMIN = 0.16D0 WRITE(KMPO,*) * 'DATASET EGSDAT3_.25 BEST SUITED BUT NOT AVAILABLE' GOTO 33 ENDIF ELSEIF ( ECUTMIN .GE. 0.15D0 ) THEN INQUIRE(FILE='EGSDAT3_.15',EXIST=LAVAIL) IF ( LAVAIL ) THEN OPEN(UNIT=KMPI,FILE='EGSDAT3_.15',STATUS='OLD') WRITE(KMPO,*) 'DATASET EGSDAT3_.15 AVAILABLE' STERNCOR = 12.5 ELSE ECUTMIN = 0.06D0 WRITE(KMPO,*) * 'DATASET EGSDAT3_.15 BEST SUITED BUT NOT AVAILABLE' GOTO 33 ENDIF ELSEIF ( ECUTMIN .GE. 0.05D0 ) THEN INQUIRE(FILE='EGSDAT3_.05',EXIST=LAVAIL) IF ( LAVAIL ) THEN OPEN(UNIT=KMPI,FILE='EGSDAT3_.05',STATUS='OLD') WRITE(KMPO,*) 'DATASET EGSDAT3_.05 AVAILABLE' STERNCOR = 15.0 ELSE ECUTMIN = 0.04D0 WRITE(KMPO,*) * 'DATASET EGSDAT3_.05 BEST SUITED BUT NOT AVAILABLE' GOTO 33 ENDIF ELSE INQUIRE(FILE='EGSDAT3_.05',EXIST=LAVAIL) IF ( LAVAIL ) THEN OPEN(UNIT=KMPI,FILE='EGSDAT3_.05',STATUS='OLD') WRITE(KMPO,*) 'ONLY DATASET EGSDAT3_.05 AVAILABLE' STERNCOR = 15.0 ELSE WRITE(KMPO,*) 'NO DATASET EGSDAT3_???? AVAILABLE' STOP ENDIF ENDIF C PICK UP CROSS-SECTION DATA FOR AIR-NTP FROM UNIT KMPI=12 CALL HATCH CLOSE(UNIT=KMPI) C INVERTED PHOTON THRESHOLD API = 1.D0/AP WRITE(KMPO,40) (AE-PRM)*.001,AP*.001,ECUT(2)*.001,PCUT(2)*.001 40 FORMAT (' ELECTRONS CAN BE CREATED AND ANY ELECTRON FOLLOWED DO', * 'WN TO'/T38,F15.5,' GEV KINETIC ENERGY'/' GAMMAS CAN BE CREATED', * ' AND ANY GAMMA FOLLOWED DOWN TO'/T38,F15.5,' GEV ENERGY'/' ELE', * 'CTRON HISTORIES ARE TERMINATED AT',F15.5,' GEV'/' GAMMA HISTO', * 'RIES ARE TERMINATED AT ',F15.5,' GEV'/) ** IF ( DEBUG ) WRITE(KMPO,50) **50 FORMAT (10X,' PART|TOT.ENERGY|ANGLE Z|ANGLE X|ALTITUDE|', ** * ' TIME | POS. X | POS. Y |GENER|',/,11X,'ICLE|', ** * ' (GEV) |COSTHET| (RAD) | (CM) | (MSEC) | (CM) |', ** * ' (CM) |ATION|') C CALCULATE THE LAYER THICKNESS BELOW EACH DETECTOR DO 61 IDET = 1,NOBSLV C NECESSARY BECAUSE OF DOUBLE PRECIS. OBSLVL(IDET) = OBSLEV(IDET) DO 71 JREG = 2,5 IF ( OBSLVL(IDET) .GE. BOUND(JREG) ) THEN KREG = JREG GOTO 80 ENDIF 71 CONTINUE WRITE(KMPO,90) IDET,OBSLVL(IDET)*0.01 90 FORMAT (' EGSINI:', ' DETECTOR ',I2,' AT ',E10.3,' M IS OUT ', * 'OF ATMOSPHERE') STOP 80 CONTINUE 61 CONTINUE RETURN END *CMZ : 28/02/2002 13.08.20 by D. HECK IK FZK KARLSRUHE *-- Author : STANFORD LINEAR ACCELERATOR CENTER C======================================================================= C STANFORD LINEAR ACCELERATOR CENTER SUBROUTINE ELECTR(IRCODE) C VERSION 4.00 -- 26 JAN 1986/1900 C----------------------------------------------------------------------- C ELECTR(ONS NAD POSITRONS ARE TREATED) C C TREATS THE ELECTRON/POSITRON TRANSPORT C FOR PATH LENGTH CORRECTION BECAUSE OF BAROMETRIC ATMOSPHERE SEE C INTERNAL REPORT OF D.HECK,(1989) C THIS SUBROUTINE IS CALLED FROM SHOWER. C ARGUMENT: C IRCODE = RETURN CODE : 1 NORMAL RETURN C 2 IF POSSIBLY STACK IS EMPTY C----------------------------------------------------------------------- IMPLICIT NONE COMMON /BOUNDS/ ECUT,PCUT,VACDST DOUBLE PRECISION ECUT(6),PCUT(6),VACDST *KEEP,BUFFS. COMMON /BUFFS/ RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH INTEGER MAXBUF,MAXLEN PARAMETER (MAXLEN=16) PARAMETER (MAXBUF=39*7) REAL RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF), * RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF) INTEGER LH CHARACTER*4 CRUNH,CRUNE,CEVTH,CEVTE,CLONG EQUIVALENCE (RUNH(1),CRUNH), (RUNE(1),CRUNE) EQUIVALENCE (EVTH(1),CEVTH), (EVTE(1),CEVTE) EQUIVALENCE (ARRAYLONG(1),CLONG) *KEEP,CEREN1. COMMON /CEREN1/ CERELE,CERHAD,ETADSN,WAVLGL,WAVLGU,CYIELD, * CERSIZ,CERNOR,LCERFI DOUBLE PRECISION CERELE,CERHAD,ETADSN,WAVLGL,WAVLGU,CYIELD, * CERSIZ,CERNOR LOGICAL LCERFI *KEEP,CORFRAM, IF=CURVED. COMMON /CORFRAM/ DETSYS LOGICAL DETSYS *KEND. COMMON /ELECIN/ EKE0,EKE1,XR0,TEFF0,BLCC,XCC,ESIG0,ESIG1,PSIG0, * PSIG1,EDEDX0,EDEDX1,PDEDX0,PDEDX1,EBR10,EBR11, * PBR10,PBR11,PBR20,PBR21,TMXS0,TMXS1,ERANG0, * ERANG1,PRANG0,PRANG1,STERNCOR REAL EKE0,EKE1,XR0,TEFF0,BLCC,XCC, * ESIG0(500),ESIG1(500),PSIG0(500),PSIG1(500), * EDEDX0(500),EDEDX1(500),PDEDX0(500),PDEDX1(500), * EBR10(500),EBR11(500),PBR10(500),PBR11(500), * PBR20(500),PBR21(500),TMXS0(500),TMXS1(500), * ERANG0(1),ERANG1(1),PRANG0(1),PRANG1(1),STERNCOR *KEEP,EGSDEB. COMMON /EGSDEB/ JCLOCK,NCLOCK,FEGSDB INTEGER JCLOCK,NCLOCK LOGICAL FEGSDB *KEEP,EPCONT. COMMON /EPCONT/ EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP, * RHOFAC,EOLD,ENEW,EKE,ELKE,BETA2,GLE,TSCAT, * IDISC,IROLD,IRNEW DOUBLE PRECISION EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP, * RHOFAC,EOLD,ENEW, EKE,ELKE,BETA2,GLE,TSCAT INTEGER IDISC,IROLD,IRNEW *KEND. COMMON /GEOMEGS/ ZALTIT,BOUND,OBSLVL,NEWOBS DOUBLE PRECISION ZALTIT,BOUND(6),OBSLVL(10) INTEGER NEWOBS COMMON /LAYER/ HBARO,HBAROI DOUBLE PRECISION HBARO(6),HBAROI(6) *KEEP,LONGI. COMMON /LONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG, * SDLONG,SELONG,SPLONG,THSTEP,THSTPI, * LHEIGH,NSTEP,LLONGI,FLGFIT DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9), * APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9), * HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9), * SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI INTEGER LHEIGH,NSTEP LOGICAL LLONGI,FLGFIT *KEEP,MAGNET. COMMON /MAGNET/ BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT DOUBLE PRECISION BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT *KEND. COMMON /MEDIA/ RLDU,RLDUI,RHO,RLC,NMED,MSGE,MGE,MSEKE,MEKE, * MLEKE,MCMFP,MRANGE,IRAYLM DOUBLE PRECISION RLDU,RLDUI REAL RHO,RLC INTEGER NMED,MSGE,MGE,MSEKE,MEKE,MLEKE,MCMFP,MRANGE, * IRAYLM COMMON /MEDIAC/ MEDIA CHARACTER MEDIA*24 COMMON /MISC/ DUNIT,RHOR,KMPI,KMPO,NOSCAT,MED,IRAYLR DOUBLE PRECISION DUNIT,RHOR(6) INTEGER KMPI,KMPO,NOSCAT,MED(6),IRAYLR(6) COMMON /MUON/ PRRMMU,RMMUT2 DOUBLE PRECISION PRRMMU,RMMUT2 *KEEP,OBSPAR. COMMON /OBSPAR/ OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP, * THETPR,PHIPR, * VUECON, * NOBSLV DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10), * HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2) DOUBLE PRECISION VUECON(2) INTEGER NOBSLV *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEND. COMMON /PATHCM/ B0PTH,B1PTH,PTH0,PTH1,PTH2,NPTH DOUBLE PRECISION B0PTH,B1PTH,PTH0(6),PTH1(6),PTH2(6) INTEGER NPTH *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,REJECT. COMMON /REJECT/ AVNREJ,ALTMIN,ANEXP,THICKA,THICKD,CUTLN,EONCUT, * FNPRIM DOUBLE PRECISION AVNREJ(10),ALTMIN(10),ANEXP(10),THICKA(10), * THICKD(10),CUTLN,EONCUT LOGICAL FNPRIM *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,STACKE. COMMON /STACKE/ E,TIM,U,V,W,X,Y,Z,DNEAR, * ZAP,WAP,WA, * IQ,IGEN,IR,IOBS,LPCTE,NP DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60), * X(60),Y(60),Z(60),DNEAR(60) * ,ZAP(60),WAP(60),WA(60) INTEGER IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP *KEND. COMMON /THRESH/ RMSQ,API,TE,THMOLL,AP,AE,UP,UE DOUBLE PRECISION RMSQ,API,TE,THMOLL REAL AP,AE,UP,UE COMMON /UPHIOT/ THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI COMMON /USEFUL/ PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE DOUBLE PRECISION PRM,PRMT2,RMI,VCI INTEGER MEDIUM,MEDOLD,IBLOBE DOUBLE PRECISION A,ALPHA,ALTEXP,B,BETA3,CC, * COSDEL,DE,DEDX,DEDX0,DEMFP,DISC,EBR1,EDEPB, * EDEPN,EDEP1,EFRST,EKEF,EKEOLD,ERELS,FLIP,FNORM, * F1SIN,F1COS,PBR1,PBR2,PEIE,PHI,PTH,RADINV,RANGE, * RHOFI,SIG,SIGF,SIG0,SINDEL,SINPSI,SINPS2,SITHET, * STEPT,THCKHN,THCKHO,THICK,TMXS,TUSTPC, * TVSTPC,UMEAN,US,USTEPU,USTEP0,USW,U0, * VMEAN,VS,VSTP,VSTEPU,V0,V1,WMEAN,W0,ZOLD INTEGER IDR,IRCODE,IRL,I,IPTH,I1, * LELEC,LELKE,LPCT1,LPCT2,NSTPCN DOUBLE PRECISION CTEA,EBEG,EEND,TBEG,TEND, * XBEG,XEND,YBEG,YEND,ZBEG,ZEND DOUBLE PRECISION AUXIL,AUXILSQ,AUX2SQ,CORR,COSDIF,COSTHENEW, * DISTN2,DISTO2,DSTEFF,PHIC,SIGNE,SINDIF, * TANPHI,TRANS2,XOLD,YOLD,ZNEW INTEGER IPASC SAVE EXTERNAL THICK DATA NSTPCN/0/ C----------------------------------------------------------------------- IF ( DEBUG ) THEN NCLOCK = NCLOCK+1 IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP),NCLOCK 1 FORMAT(' ELECTR: NP=',I3,' IR=',I3,' IOBS=',I3,' NCLOCK=',I12) CALL AUSGB2 ELSE IF ( NCLOCK .GE. JCLOCK ) THEN FEGSDB = .TRUE. WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP),NCLOCK CALL AUSGB2 ENDIF IF ( MOD(NCLOCK,1000) .EQ. 0 ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP),NCLOCK ENDIF ENDIF ENDIF NEWOBS = IOBS(NP) IRCODE = 1 IROLD = IR(NP) IRL = IR(NP) MEDIUM = MED(IRL) C START WITH A NEW ELECTRON: LELEC = -1 FOR E-, LELEC =+1 FOR E+ 380 CONTINUE LELEC = 5-2*IQ(NP) PEIE = E(NP) IF ( PEIE .LE. ECUT(IRL) ) GOTO 390 MEDIUM = MED(IRL) 401 CONTINUE IF ( MEDIUM .NE. 0 ) THEN C WE USE EKE = KIN. ENERGY OF ELECTRON, ELKE = LOGARITHM OF EKE EKE = PEIE-PRM ELKE = LOG(EKE) CALL RMMAR(RD,1,2) DEMFP = MAX( -LOG(DBLE(RD(1))), 1.D-6 ) C LOOK FOR CROSS-SECTION TO DETERMINE RANGE LELKE = EKE1*ELKE+EKE0 IF ( LELEC .LT. 0 ) THEN SIG0 = ESIG1(LELKE)*ELKE+ESIG0(LELKE) ELSE SIG0 = PSIG1(LELKE)*ELKE+PSIG0(LELKE) ENDIF ENDIF 451 CONTINUE IF ( MEDIUM .EQ. 0 ) THEN C WE ARE IN VACUUM TSTEP = VACDST USTEP = TSTEP TUSTEP = USTEP ALTEXP = 1.D0 ELSE C WE ARE IN AIR C COMPUTE SIZE OF MAXIMUM ACCEPTABLE STEP, WHICH IS LIMITED BY C MULTIPLE SCATTERING OR OTHER APPROXIMATIONS. RHOFAC = RHOR(IRL)/RHO RHOFI = 1.D0/RHOFAC SIG = SIG0*RHOFAC IF ( SIG .LE. 0.D0 ) THEN C THIS CAN HAPPEN IF THE THRESHOLD FOR BREMS, (AP+RM), IS GREATER C THAN AE. MOLLER THRESHOLD IS 2*AE-RM. IF SIG IS ZERO, WE ARE BELOW C THE THRESHOLDS FOR BOTH BREMSSTRAHLUNG AND MOLLER. IN THIS CASE WE C WILL JUST LOSE ENERGY BY IONIZATION LOSS UNTIL WE GO BELOW CUT-OFF. C DO NOT ASSUME RANGE IS AVAILABLE, SO JUST ASK FOR STEP SAME AS C VACUUM. ELECTRON TRANSPORT WILL REDUCE INTO LITTLE STEPS TSTEP = VACDST ELSE TSTEP = DEMFP/SIG ENDIF TMXS = TMXS1(LELKE)*ELKE+TMXS0(LELKE) TMXS = MIN( TMXS, STEPFC*200.D0*DBLE(TEFF0) ) TMXS = TMXS*RHOFI TUSTEP = MIN( TSTEP, TMXS ) C EVALUATE IONIZATION ENERGY LOSS IF ( LELEC .LT. 0 ) THEN DEDX0 = EDEDX1(LELKE)*ELKE+EDEDX0(LELKE) ELSE DEDX0 = PDEDX1(LELKE)*ELKE+PDEDX0(LELKE) ENDIF C STERNHEIMER CORRECTION OF DENSITY DEPENDENT IONISATION ENERGY LOSS C DEDX. SATURATION VALUE OF DEDX AT HIGH ENERGIES IS PRESSURE DEPENDENT C AND SATURATES AT LOWER VALUES FOR HIGHER PRESSURE. THEREFORE THE C CROSS-SECTION FILE IS ESTABLISHED WITH GAS PRESSURE OF 1.E-6 ATM C (CORRESPONDING TO ABOUT 100 KM HIGHT IN ATMOSPHERE). THE CORRECTION C INTRODUCED GIVES VALUES ABOUT 3% TO HIGH IN TRANSITION REGION TO C SATURATION. THE PARAMETRISATION IS ONLY VALID FOR U.S. STANDARD ATMOS. DEDX = RHOFAC*MIN( DEDX0, * (86.65D0-STERNCOR-Z(NP)*8.D-6)*RLDUI ) RANGE = (PEIE-ECUT(IRL)+0.001D0)/DEDX BETA2 = MAX( 1.D-8, 1.D0-RMSQ/(PEIE*PEIE) ) C THE FACTOR 0.094315=2./E_S WITH E_S = 21.2MEV BETA3 = PEIE*BETA2*0.094315D0 TSCAT = RLDU*BETA3**2 TSCAT = TSCAT*RHOFI TUSTEP = MIN( TUSTEP, 0.3D0*TSCAT, RANGE ) C RATIO GIVES TEH NUMBER OF SCATTERS ALONG STEP RATIO = TUSTEP/TSCAT USTEP = TUSTEP*(1.D0-RATIO) C USTEPU IS STEP LENGTH WITHOUT CORRECTION FOR DENSITY GRADIENT USTEPU = USTEP ALTEXP = EXP((-Z(NP))*HBAROI(IRL)) USTEP = USTEP*ALTEXP DISC = W(NP)*USTEP*HBAROI(IRL) IF ( ABS(DISC) .LT. .0000007D0 ) THEN USTEP = USTEP*(1.D0-.5D0*DISC*(1.D0-.666666666666667D0*DISC* * (1.D0-.75D0*DISC*(1.D0-.8D0*DISC)))) ELSEIF ( DISC .GT. -1.D0 ) THEN USTEP = USTEP*LOG(DISC+1.D0)/DISC ELSE USTEP = VACDST ENDIF C USTEP IS STEP LENGTH WITH CORRECTION FOR DENSITY GRADIENT TUSTPC = USTEP/(1.D0-RATIO) ENDIF IRNEW = IR(NP) IDISC = 0 USTEP0 = USTEP C REDUCE STEPSIZE, IF PARTICLE COILS WITH ANGLES >0.2 RAD (=11.4 DEG.) C IN MAGNETIC FIELD USTEP = MIN( USTEP, BLIMIT*PEIE ) C LOOK HOW FAR WE CAN GO IF ( USTEP .GT. DNEAR(NP) ) CALL HOWFAR IF ( IDISC .GT. 0 ) GOTO 420 IF ( USTEP .LE. 0.D0 ) THEN IF ( USTEP .LT. -1.D-4 ) THEN C NEGATIVE USTEP---PROBABLE TRUNCATION PROBLEM AT A BOUNDARY, WHICH C MEANS WE ARE NOT IN THE REGION WE THINK WE ARE IN. THE DEFAULT MACRO C ASSUMES THAT USER HAS SET IRNEW TO THE REGION WE ARE REALLY MOST C LIKELY TO BE IN. A MESSAGE IS WRITTEN OUT WHENEVER USTEP IS LESS C THAN -1.E-4 WRITE(KMPO,460) USTEP 460 FORMAT(' ELECTR: NEGATIVE USTEP=',G20.10,' CM') WRITE(KMPO,470) Z(NP),DNEAR(NP),IR(NP),IRNEW,W(NP) 470 FORMAT (' Z=',G15.7, ' DNEAR=',G15.7,' IR=',I5, ' IRNEW=',I5, * ' W=',G15.7) NSTPCN = NSTPCN+1 IF ( NSTPCN .GE. 20 ) THEN CALL AUSGB2 WRITE(KMPO,480) NSTPCN 480 FORMAT (' ELECTR: PROGRAM STOPPED BECAUSE OF FREQUENT NEGA', * 'TIVE USTEP, COUNTER = ',I5) STOP ENDIF ENDIF USTEP = 0.D0 ENDIF IF ( IDISC .LT. 0 ) THEN C PARTICLE WILL CROSS THE DETECTOR LEVEL ZOLD = Z(NP) XOLD = X(NP) YOLD = Y(NP) DISTO2 = X(NP)**2 + Y(NP)**2 IF ( FEGSDB ) THEN WRITE(MDEBUG,*) 'ELECTR: WE APPROACH DETECTOR' CALL AUSGB2 ENDIF AUXILSQ = SQRT(DISTO2) WA(NP) = COS(AUXILSQ/C(1)) WA(NP) = MIN( 1.D0, WA(NP) ) ZAP(NP) = - (C(1)-Z(NP)) * WA(NP) + C(1) C REGARD WHETHER PARTICLE IS MOVING TOWARDS DETECTOR C EFFECTIVE DISTANCE TO DETECTOR CENTER IS DISTANCE TO POINT C OF FLIGHT PATH PROJECTION WHICH COMES CLOSEST TO DETECTOR CENTER IF ( U(NP) .NE. 0.D0 .OR. V(NP) .NE. 0.D0 ) THEN PHIC = -ATAN2(V(NP),U(NP)) ELSE PHIC = 0.D0 ENDIF DSTEFF = -( COS(PHIC)*X(NP) + SIN(PHIC)*Y(NP) ) C CALCULATE CORRECTION ANGLE DIF FROM EFFECTIVE DISTANCE DSTEFF SINDIF = SIN(DSTEFF/C(1)) COSDIF = SQRT( 1.D0 - SINDIF**2) COSTHENEW = W(NP)*COSDIF - SQRT(1.D0-W(NP)**2)*SINDIF IF ( FEGSDB ) WRITE(MDEBUG,*) 'ELECTR: COSDIF,COSTHENEW=', * SNGL(COSDIF),SNGL(COSTHENEW) W(NP) = MIN( 1.D0, COSTHENEW ) C KILL HORIZONTAL OR UPWARD GOING PARTICLES IF ( W(NP) .LE. C(29) ) GOTO 420 C ANGLE DIF (= DSTEFF/C(1)) MIGHT BE LARGE DUE TO CUT ON HAPP X(NP) = (-ZAP(NP) + C(1)) * TAN(X(NP)/C(1)) Y(NP) = (-ZAP(NP) + C(1)) * TAN(Y(NP)/C(1)) Z(NP) = ZAP(NP) IF ( U(NP) .NE. 0.D0 ) THEN TANPHI= V(NP)/U(NP) U(NP) = SIGN(1.D0,U(NP)) * * SQRT((1.D0-W(NP)**2)/(1.D0+TANPHI**2)) V(NP) = TANPHI * U(NP) ELSE IF ( V(NP) .NE. 0.D0 ) * V(NP) = SIGN(1.D0,V(NP)) * SQRT( 1.D0 - W(NP)**2 ) ENDIF USTEP = -(Z(NP)+OBSLEV(1))/W(NP) IF ( FEGSDB ) THEN WRITE(MDEBUG,*) 'ELECTR: CORR. FOR DET. ARRIVAL:USTEP=',USTEP CALL AUSGB2 ENDIF IPASC = 1 DETSYS = .TRUE. ELSE DETSYS = .FALSE. C PARTICLE MOVES TO END OF ITS RANGE, WE DO NOT YET APPROACH DETECTOR IPASC = 0 ZOLD = Z(NP) XOLD = X(NP) YOLD = Y(NP) DISTO2= X(NP)**2 + Y(NP)**2 ENDIF C FILL IN CHERENKOV COORDINATES AT BEGIN OF STEP EBEG = PEIE*1.D-3 EEND = PEIE*1.D-3 XBEG = X(NP) YBEG = -Y(NP) ZBEG = -Z(NP) TBEG = TIM(NP) C WE ARE IN VACUUM OR MAKE A ZERO STEP IF ( USTEP .EQ. 0.D0 .OR. MEDIUM .EQ. 0 ) THEN IF ( USTEP .NE. 0.D0 ) THEN VSTEP = USTEP TVSTEP = VSTEP C WE ARE IN VACUUM, NO ENERGY LOSS EDEP = 0.D0 TVSTPC = TVSTEP C CHARGED PARTICLE TRANSPORT IN EARTH MAGNETIC FIELD C SEE ALSO SLAC-265, P. 127 FF ALPHA = VSTEP*LELEC*BNORM/PEIE TVSTPC = TVSTPC*(1.D0+0.04166667D0*ALPHA**2) U0 = U(NP) V0 = V(NP) W0 = W(NP) FNORM = 1.D0-0.5D0*ALPHA**2*(1.D0-0.75D0*ALPHA**2) F1SIN = (1.D0-FNORM)*SINB F1COS = (1.D0-FNORM)*COSB V1 = V0*ALPHA*FNORM USW = U0*SINB-W0*COSB U(NP) = U0-F1SIN*USW+V1*SINB V(NP) = FNORM*(V0-ALPHA*USW) W(NP) = W0+F1COS*USW-V1*COSB RADINV= 1.5D0-0.5D0*(U(NP)**2+V(NP)**2+W(NP)**2) U(NP) = U(NP)*RADINV V(NP) = V(NP)*RADINV W(NP) = W(NP)*RADINV UMEAN = 0.5D0*(U0+U(NP)) VMEAN = 0.5D0*(V0+V(NP)) WMEAN = 0.5D0*(W0+W(NP)) X(NP) = X(NP) + VSTEP*UMEAN Y(NP) = Y(NP) + VSTEP*VMEAN Z(NP) = Z(NP) + VSTEP*WMEAN IF ( IPASC .EQ. 0 ) THEN C NORMAL STEP TO END OF PARTICLE RANGE, WE DO NOT YET APPROACH DETECTOR W(NP) = MIN( 1.D0, W(NP) ) C HORIZONTAL COMPONENT OF TRACK LENGTH SQUARED TRANS2 = (X(NP)-XOLD)**2 + (Y(NP)-YOLD)**2 C TRANSPORT AT MINIMUM .001 MM TRANS2 = MAX( TRANS2, 0.00001D0 ) C NEW COORDINATE FRAME, NEW ACTUAL HEIGHT AT NEW THICKNESS GRADIENT C (CALCULATED WITH PARAMETERS OF OLD COORDINATE FRAME) AUXIL = SQRT( TRANS2 + (C(1)-Z(NP))**2 ) ZNEW = C(1) - AUXIL C CALCULATE ANGLE DIFFERENCE BETWEEN OLD AND NEW FRAME SINDIF = SQRT(TRANS2) / AUXIL COSDIF = (C(1)-Z(NP)) / AUXIL IF ( FEGSDB ) WRITE(MDEBUG,560) COSDIF,SINDIF,-Z(NP),-ZNEW 560 FORMAT(/' ELECTR: COSDIF,SINDIF,Z,ZNEW=',2F18.15,1P,2E17.9) COSDIF = MIN( 1.D0, COSDIF ) C CORRECTED X AND Y HAVE TO BE CALCULATED BEFORE DISTN2 C TRANSPORT DISTANCE IS CORRECTED TO GET DISTANCE AT EARTH' SURFACE CORR = C(1)*ASIN(SINDIF)/( (C(1)-ZNEW)*SINDIF ) X(NP) = XOLD + (X(NP)-XOLD)*CORR Y(NP) = YOLD + (Y(NP)-YOLD)*CORR Z(NP) = ZNEW C NEW DISTANCE FROM PARTICLE TO DETECTOR CENTER DISTN2 = X(NP)**2 + Y(NP)**2 C COMPARE NEW AND OLD DISTANCE TO DETECTOR CENTER IF ( DISTN2 .LT. DISTO2 ) THEN C PARTICLE MOVES TOWARDS DETECTOR CENTER SIGNE = +1.D0 ELSE SIGNE = -1.D0 IF ( FEGSDB ) WRITE(MDEBUG,*) 'ELECTR: SIGNE=',SIGNE ENDIF C IN FIRST ORDER APPROXIMATION W(NP) AND COSDIF ARE IN THE SAME PLANE C OF PARTICLE MOVEMENT, THEREFORE THE ANGLES MAY BE ADDED DIRECTLY COSTHENEW = W(NP)*COSDIF - SIGNE*SINDIF*SQRT(1.D0-W(NP)**2) W(NP) = MIN( 1.D0, COSTHENEW ) C KILL HORIZONTAL OR UPWARD GOING PARTICLES IF ( W(NP) .LE. C(29) ) GOTO 420 IF ( FEGSDB ) THEN WRITE(MDEBUG,562) WA(NP),-ZAP(NP) 562 FORMAT(' ELECTR: WA,-ZAP=',F18.15,1P,E17.9) WRITE(MDEBUG,557) U(NP),V(NP),W(NP),X(NP),-Y(NP),-Z(NP) 557 FORMAT(' ELECTR: STEPEND=',1P,6E10.3,0P) ENDIF C CALCULATE ANGLES IN THE NEW FRAME AUXILSQ = SQRT(X(NP)**2 + Y(NP)**2) WA(NP) = COS(AUXILSQ/C(1)) WA(NP) = MIN( 1.D0, WA(NP) ) ZAP(NP) = -(C(1)-ZNEW) * WA(NP) + C(1) AUX2SQ = SQRT( (C(1)-ZNEW)**2*(1.D0 - WA(NP)**2) * + (-ZAP(NP)-OBSLEV(1))**2 ) WAP(NP) = -(OBSLEV(1)+ZAP(NP)) / AUX2SQ IF ( FEGSDB ) WRITE(MDEBUG,*) 'ELECTR: WAP=',WAP(NP) C KILL PARTICLES, WHICH ARE BELOW DETECTOR SURFACE C CUT ON APPARENT HEIGHT IF ( -ZAP(NP) .LE. OBSLEV(1) ) GOTO 420 WAP(NP) = MIN( 1.D0, WAP(NP) ) IF ( U(NP) .NE. 0.D0 ) THEN TANPHI= V(NP) / U(NP) U(NP) = SIGN(1.D0,U(NP)) * * SQRT( (1.D0-W(NP)**2)/(1.D0+TANPHI**2) ) V(NP) = TANPHI * U(NP) ELSE IF ( V(NP) .NE. 0.D0 ) * V(NP) = SIGN(1.D0,V(NP)) * SQRT( 1.D0 - W(NP)**2 ) ENDIF ENDIF TIM(NP) = TIM(NP) + TVSTPC*VCI/SQRT(1.D0-(PRM/E(NP))**2) C NO CHERENKOV PHOTONS, WE ARE IN VACUUM C ADD ELECTRONS TO THE LONGITUDINAL DEVELOPMENT C FIND FIRST THE EQUIVALENT LEVELS IF ( LLONGI ) THEN C IF STARTING POINT BELOW LOWEST LEVEL THEN DON'T CHECK IF ( HLONG(NSTEP) .LE. -ZOLD ) THEN LPCT1 = LPCTE(NP) C Z NEW IS PROBABLY ONLY LITTLE BELOW Z OLD, THEREFORE INCREMENTAL SEARCH DO I1 = LPCT1,NSTEP IF ( HLONG(I1) .LT. -Z(NP) ) GOTO 6003 ENDDO I1 = NSTEP + 1 6003 CONTINUE LPCT2 = I1 - 1 C STORE END POINT AS POSSIBLE STARTPOINT OF NEXT TRACK LPCTE(NP) = LPCT2 + 1 DO I = LPCT1,LPCT2 PLONG(I,IQ(NP)) = PLONG(I,IQ(NP)) + 1.D0 ENDDO IF ( IDISC .LT. 0 ) * PLONG(LPCT2+1,IQ(NP)) = PLONG(LPCT2+1,IQ(NP)) + 1.D0 C WE ARE IN VACUUM NO ENERGY LOSS. RELEASABLE ENERGY ERELS [GEV] ERELS = 1.D-3*( E(NP) - DBLE(2*IQ(NP)-5) * PRM ) C NOW FILL FIRST AND LAST BINS, THEN LOOP OVER THE BINS BETWEEN IF ( LPCT2 .LT. NSTEP ) THEN IF ( IDISC .LT. 0 ) THEN ELONG(LPCT2+1,IQ(NP)) = ELONG(LPCT2+1,IQ(NP)) + ERELS ENDIF ENDIF IF ( LPCT2 .GE. LPCT1 ) THEN ELONG(LPCT2,IQ(NP)) = ELONG(LPCT2,IQ(NP)) + ERELS ENDIF C LOOP OVER ALL LONGITUDINAL BINS IF ( LPCT2 .GT. LPCT1 ) THEN DO I = LPCT1,LPCT2-1 ELONG(I,IQ(NP)) = ELONG(I,IQ(NP)) + ERELS ENDDO ENDIF ENDIF C END LONGITUDINAL DISTRIBUTION FILLING ENDIF DNEAR(NP) = DNEAR(NP)-VSTEP IROLD = IR(NP) C END OF STEP IN VACUUM ENDIF IR(NP) = IRNEW IRL = IRNEW MEDIUM = MED(IRL) IF ( PEIE .LE. ECUT(IRL) ) GOTO 390 C KILL UPWARD GOING PARTICLES IF ( W(NP) .LE. C(29) ) GOTO 420 IF ( USTEP .NE. 0.D0 ) THEN IF ( NEWOBS .GT. IOBS(NP) ) THEN CALL AUSGAB IOBS(NP) = NEWOBS ENDIF ENDIF GOTO 401 ENDIF C WE ARE IN NORMAL MEDIUM WITH NORMAL STEP VSTEP = USTEP IF ( USTEP .EQ. USTEP0 ) THEN TVSTEP = TUSTEP TVSTPC = TUSTPC ELSE C KILL HORIZONTAL OR UPWARD GOING PARTICLES IF ( W(NP) .LE. C(29) ) GOTO 420 C PATH LENGTH CORRECTION FOR BAROMETRIC AIR VSTEPU = VSTEP DISC = W(NP)*VSTEPU*HBAROI(IRL) IF ( DISC .NE. 0.D0 ) THEN VSTEPU = VSTEPU*(EXP(DISC)-1.D0)/(DISC*ALTEXP) ENDIF C PATH LENGTH CORRECTION FOR MULTIPLE SCATTERING VSTP = VSTEPU/TSCAT IPTH = B0PTH+B1PTH*VSTP IPTH = MAX( IPTH, 1 ) IF ( IPTH .GT. NPTH ) THEN CALL AUSGB2 WRITE(KMPO,490) VSTP,IPTH,NPTH 490 FORMAT (' ELECTR: OUT OF BOUNDS IPTH: VSTP,IPTH,NPTH=' , 1P , * G15.6,2I10) STOP ENDIF PTH = PTH0(IPTH)+VSTP*(PTH1(IPTH)+VSTP*PTH2(IPTH)) TVSTEP = PTH*VSTEPU TVSTPC = PTH*VSTEP ENDIF C DEFLECTION IN MAGNETIC FIELD ALPHA = VSTEP*LELEC*BNORM/PEIE TVSTPC = TVSTPC*(1.D0+0.04166667D0*ALPHA**2) C NOW TAKE IONIZATION LOSSES INTO ACCOUNT DE = DEDX*TVSTEP EDEP = DE EKEF = EKE-DE EOLD = PEIE ENEW = EOLD-DE C NOW CHANGE ANGLE BECAUSE OF MULTIPLE SCATTERING CALL MSCAT C WE NOW KNOW DISTANCE AND AMOUNT OF ENERGY LOSS FOR THIS STEP, C AND THE ANGLE BY WHICH THE ELECTRON WILL BE SCATTERED. U0 = U(NP) V0 = V(NP) W0 = W(NP) C NOW TRANSPORT, DEDUCT ENERGY LOSS, DO MULTIPLE SCATTER AND C DEFLECT IN MAGNETIC FIELD FNORM = 1.D0-0.5D0*ALPHA**2*(1.D0-0.75D0*ALPHA**2) F1SIN = (1.D0-FNORM)*SINB F1COS = (1.D0-FNORM)*COSB V1 = V0*ALPHA*FNORM USW = U0*SINB-W0*COSB U(NP) = U0-F1SIN*USW+V1*SINB V(NP) = FNORM*(V0-ALPHA*USW) W(NP) = W0+F1COS*USW-V1*COSB C MAGNETIC DEFLECTION IS APPROXIMATION, THEREFORE RENORMALIZE U, V, W RADINV= 1.5D0-0.5D0*(U(NP)**2+V(NP)**2+W(NP)**2) U(NP) = U(NP)*RADINV V(NP) = V(NP)*RADINV W(NP) = W(NP)*RADINV UMEAN = 0.5D0*(U0+U(NP)) VMEAN = 0.5D0*(V0+V(NP)) WMEAN = 0.5D0*(W0+W(NP)) X(NP) = X(NP) + VSTEP*UMEAN Y(NP) = Y(NP) + VSTEP*VMEAN Z(NP) = Z(NP) + VSTEP*WMEAN IF ( IPASC .EQ. 0 ) THEN C WE TRANSPORT THE PARTICLE TO END OF IT'S RANGE, NORMAL STEP W(NP) = MIN( 1.D0, W(NP) ) C HORIZONTAL COMPONENT OF TRACK LENGTH SQUARED TRANS2 = (X(NP)-XOLD)**2 + (Y(NP)-YOLD)**2 C TRANSPORT AT MINIMUM .001 MM TRANS2 = MAX( TRANS2, 0.00001D0 ) C NEW COORDINATE FRAME, NEW ACTUAL HEIGHT AT NEW THICKNESS GRADIENT C (CALCULATED WITH PARAMETERS OF OLD COORDINATE FRAME) AUXIL = SQRT( TRANS2 + (C(1)-Z(NP))**2 ) ZNEW = C(1) - AUXIL C CALCULATE ANGLE DIFFERENCE BETWEEN OLD AND NEW FRAME SINDIF = SQRT(TRANS2) / AUXIL COSDIF = (C(1)-Z(NP)) / AUXIL IF ( FEGSDB ) WRITE(MDEBUG,560) COSDIF,SINDIF,-Z(NP),-ZNEW COSDIF = MIN( 1.D0, COSDIF ) C CORRECTED X AND Y HAVE TO BE CALCULATED BEFORE DISTN2 C TRANSPORT DISTANCE IS CORRECTED TO GET DISTANCE AT EARTH' SURFACE CORR = C(1)*ASIN(SINDIF)/( (C(1)-ZNEW)*SINDIF ) X(NP) = XOLD + (X(NP)-XOLD)*CORR Y(NP) = YOLD + (Y(NP)-YOLD)*CORR Z(NP) = ZNEW C NEW DISTANCE FROM PARTICLE TO DETECTOR CENTER DISTN2 = X(NP)**2 + Y(NP)**2 C COMPARE NEW AND OLD DISTANCE TO DETECTOR CENTER IF ( DISTN2 .LT. DISTO2 ) THEN C PARTICLE MOVES TOWARDS DETECTOR CENTER SIGNE = +1.D0 ELSE SIGNE = -1.D0 IF ( FEGSDB ) WRITE(MDEBUG,*) 'ELECTR: SIGNE=',SIGNE ENDIF C IN FIRST ORDER APPROXIMATION W(NP) AND COSDIF ARE IN THE SAME PLANE C OF PARTICLE MOVEMENT, THEREFORE THE ANGLES MAY BE ADDED DIRECTLY COSTHENEW = W(NP)*COSDIF - SIGNE*SINDIF*SQRT(1.D0-W(NP)**2) W(NP) = MIN( 1.D0, COSTHENEW ) C KILL HORIZONTAL OR UPWARD GOING PARTICLES IF ( W(NP) .LE. C(29) ) GOTO 420 IF ( FEGSDB ) THEN WRITE(MDEBUG,562) WA(NP),-ZAP(NP) WRITE(MDEBUG,557) U(NP),V(NP),W(NP),X(NP),-Y(NP),-Z(NP) ENDIF C CALCULATE ANGLES IN THE NEW FRAME AUXILSQ = SQRT(X(NP)**2 + Y(NP)**2) WA(NP) = COS(AUXILSQ/C(1)) WA(NP) = MIN( 1.D0, WA(NP) ) ZAP(NP) = -(C(1)-ZNEW) * WA(NP) + C(1) AUX2SQ = SQRT( (C(1)-ZNEW)**2*(1.D0 - WA(NP)**2) * + (-ZAP(NP)-OBSLEV(1))**2 ) WAP(NP) = -(OBSLEV(1)+ZAP(NP)) / AUX2SQ IF ( FEGSDB ) WRITE(MDEBUG,*) 'ELECTR: WAP=',WAP(NP) C LOOK WETHER PARTICLE IS ALREADY ON DETECTOR SURFACE C CUT ON APPARENT HEIGHT IF ( -ZAP(NP) .LE. OBSLEV(1) ) GOTO 420 WAP(NP) = MIN( 1.D0, WAP(NP) ) IF ( U(NP) .NE. 0.D0 ) THEN TANPHI= V(NP) / U(NP) U(NP) = SIGN(1.D0,U(NP)) * * SQRT((1.D0-W(NP)**2)/(1.D0+TANPHI**2)) V(NP) = TANPHI * U(NP) ELSE IF ( V(NP) .NE. 0.D0 ) * V(NP) = SIGN(1.D0,V(NP)) * SQRT( 1.D0 - W(NP)**2 ) ENDIF ENDIF TIM(NP) = TIM(NP) + TVSTPC*VCI/SQRT(1.D0-(PRM/E(NP))**2) C FILL IN CHERENKOV COORDINATES AT END OF STEP IF ( .NOT. DETSYS ) THEN C WE ARE NOT IN LOCAL SYSTEM OF DETECTOR TRANS2 = VSTEP**2 * (UMEAN**2 + VMEAN**2) C TAKE HEIGHT AT END POINT OF TRACK AUXIL = SQRT( TRANS2 + (C(1)+(-Z(NP)))**2 ) SINDIF = SQRT( TRANS2 )/AUXIL IF ( SINDIF .GT. 0.D0 ) THEN CORR = C(1) * ASIN(SINDIF) / (AUXIL*SINDIF) ELSE CORR = 1.D0 ENDIF XEND = XBEG + UMEAN * VSTEP * CORR YEND = YBEG - VMEAN * VSTEP * CORR C CALCULATE EARTH ANGLE BETWEEN THE ACTUAL LOCAL AND THE C APPARENT COORDINATE SYSTEM AUXIL = SQRT( XBEG**2 + YBEG**2 ) CTEA = COS( AUXIL/C(1) ) ELSE C HERE WE ARE IN LOCAL DETECTOR SYSTEM XEND = X(NP) YEND = -Y(NP) ENDIF ZEND = -Z(NP) TEND = TIM(NP) EEND = (PEIE - EDEP)*1.D-3 C GENERATE CHERENKOV PHOTONS IF ( FNPRIM ) CALL CERENK(TVSTPC,UMEAN,-VMEAN,WMEAN,EBEG,EEND, * XBEG,YBEG,ZBEG,XEND,YEND,ZEND,TBEG,TEND,PRM*1.D-3,1.D0, * 1.D0,CTEA) C ADD ELECTRONS TO THE LONGITUDINAL DEVELOPMENT C FIND FIRST THE EQUIVALENT LEVELS IF ( LLONGI ) THEN C IF STARTING POINT BELOW LOWEST LEVEL THEN DON'T CHECK IF ( HLONG(NSTEP) .LE. -ZOLD ) THEN LPCT1 = LPCTE(NP) C Z NEW IS PROBABLY ONLY LITTLE BELOW Z OLD, THEREFORE INCREMENTAL SEARCH DO I1 = LPCT1,NSTEP IF ( HLONG(I1) .LT. -Z(NP) ) GOTO 6103 ENDDO I1 = NSTEP + 1 6103 CONTINUE LPCT2 = I1 - 1 C STORE END POINT AS POSSIBLE STARTPOINT OF NEXT TRACK LPCTE(NP) = LPCT2 + 1 DO I = LPCT1,LPCT2 PLONG(I,IQ(NP)) = PLONG(I,IQ(NP)) + 1.D0 ENDDO IF ( IDISC .LT. 0 ) * PLONG(LPCT2+1,IQ(NP)) = PLONG(LPCT2+1,IQ(NP)) + 1.D0 C TOTAL PATH LENGTH STEPT IN UNITS OF LONGI BINS THCKHO = THICK(-ZOLD) THCKHN = THICK(-Z(NP)) STEPT = (THCKHN - THCKHO)*THSTPI C RELEASABLE ENERGY [IN GEV] ERELS = 1.D-3*( E(NP) - DBLE(2*IQ(NP)-5) * PRM ) C WE ASSUME HOMOGENEOUS ENERGY DEPOSIT ALONG PATH C IONIZATION E(NERGY) DEP(OSED IN EACH) B(IN) [IN GEV] IF ( STEPT .GT. 0.D0 ) THEN EDEPB = EDEP*1.D-3/STEPT ELSE EDEPB = 0.D0 ENDIF C ENERGY DEPOSIT IN FIRST BIN EDEP1 = EDEPB * (DBLE(LPCT1) - THCKHO*THSTPI) C ENERGY AT FIRST BIN BOUNDARY EFRST = ERELS - EDEP1 IF ( LPCT2. LT. LPCT1 ) THEN EDEPN = EDEPB * (THCKHN*THSTPI - DBLE(LPCT1)) ELSE EDEPN = MAX( 0.D0, EDEPB*(THCKHN*THSTPI - DBLE(LPCT2)) ) ENDIF C NOW FILL FIRST AND LAST+1 BIN, THEN LOOP OVER THE BINS BETWEEN DLONG(LPCT1 ,2) = DLONG(LPCT1 ,2) + EDEP1 IF ( LPCT2 .LT. NSTEP ) THEN DLONG(LPCT2+1,2) = DLONG(LPCT2+1,2) + EDEPN IF ( IDISC .LT. 0 ) THEN ELONG(LPCT2+1,IQ(NP)) = ELONG(LPCT2+1,IQ(NP)) * + MAX( 0.D0, (EFRST-(LPCT2+1-LPCT1)*EDEPB) ) ENDIF ENDIF IF ( LPCT2 .GE. LPCT1 ) THEN ELONG(LPCT2,IQ(NP)) = ELONG(LPCT2,IQ(NP)) * + MAX( 0.D0, (EFRST-(LPCT2-LPCT1)*EDEPB) ) ENDIF C LOOP OVER ALL LONGITUDINAL BINS IF ( LPCT2 .GT. LPCT1 ) THEN DO I = LPCT1,LPCT2-1 DLONG(I+1,2) = DLONG(I+1,2) + EDEPB ELONG(I,IQ(NP)) = ELONG(I,IQ(NP)) * + MAX( 0.D0, (EFRST-(I-LPCT1)*EDEPB) ) ENDDO ENDIF C END LONGITUDINAL DISTRIBUTION FILLING ENDIF ENDIF DNEAR(NP) = DNEAR(NP)-VSTEP IROLD = IR(NP) C NOW ADD ANGLE OF MULTIPLE SCATTERING (SEE ALSO SUBR. UPHI) CALL RMMAR(RD,1,2) PHI = RD(1)*TWOPI SINPHI = SIN(PHI) COSPHI = COS(PHI) A = U(NP) B = V(NP) CC = W(NP) SINPS2 = A**2+B**2 IF ( SINPS2 .LT. 1.D-20 ) THEN U(NP) = SINTHE*COSPHI V(NP) = SINTHE*SINPHI W(NP) = CC*COSTHE ELSE SINPSI = SQRT(SINPS2) US = SINTHE*COSPHI VS = SINTHE*SINPHI SINDEL = B*(1.D0/SINPSI) COSDEL = A*(1.D0/SINPSI) U(NP) = CC*COSDEL*US-SINDEL*VS+A*COSTHE V(NP) = CC*SINDEL*US+COSDEL*VS+B*COSTHE W(NP) = (-SINPSI)*US+CC*COSTHE ENDIF C UPDATE ENERGY PEIE = PEIE-EDEP E(NP) = PEIE IF ( PEIE .LE. ECUT(IRL) ) GOTO 390 MEDOLD = MEDIUM IF ( MEDIUM .NE. 0 ) THEN C UPDATE KINETIC ENERGY EKEOLD = EKE EKE = PEIE-PRM ELKE = LOG(EKE) LELKE = EKE1*ELKE+EKE0 ENDIF IF ( IRNEW .NE. IROLD ) THEN C LAYER HAS CHANGED IR(NP) = IRNEW IRL = IRNEW MEDIUM = MED(IRL) ENDIF IF ( PEIE .LE. ECUT(IRL) ) GOTO 390 C KILL UPWARD GOING PARTICLES IF ( W(NP) .LE. C(29) ) GOTO 420 C LOOK FOR OBSERVATION LEVEL AND GIVE TO OUTPUT IF ( NEWOBS .GT. IOBS(NP) ) THEN CALL AUSGAB IOBS(NP) = NEWOBS ENDIF IF ( IDISC .LT. 0 ) GOTO 420 IF ( MEDIUM .NE. MEDOLD ) GOTO 401 DEMFP = MAX( 0.D0, DEMFP-TVSTEP*SIG ) C SKIP BACK IF STEP LENGTH NOT YET TOTALLY EXHAUSTED IF ( DEMFP .GE. 1.D-6 ) GOTO 451 C COMPUTE FINAL SIGMA TO SEE IF RESAMPLE IS NEEDED. C THIS WILL TAKE THE ENERGY VARIATION OF THE SIGMA INTO C ACCOUNT USING THE FICTITIOUS SIGMA METHOD. IF ( LELEC .LT. 0 ) THEN SIGF = ESIG1(LELKE)*ELKE+ESIG0(LELKE) ELSE SIGF = PSIG1(LELKE)*ELKE+PSIG0(LELKE) ENDIF CALL RMMAR(RD,1,2) IF ( RD(1) .GT. SIGF/SIG0 ) GOTO 401 IF ( .NOT. FNPRIM ) THEN C DETERMINE THE ALTITUDE OF THE FIRST INTERACTION IF ( .NOT. TMARGIN ) THEN X(1) = 0.D0 Y(1) = 0.D0 ENDIF IF ( FIX1I ) THEN C IF HEIGHT OF FIRST INTERACTION IS FIXED, TAKE STARTING ANGLES OF C PRIMARY PARTICLE Z(1) = -FIXHEI NP = 1 LPCTE(1) = MIN(NSTEP,INT(THICK(FIXHEI)*THSTPI)+1) SITHET = SQRT(1.D0-SECPAR(3)**2) U(1) = SITHET*COS(-SECPAR(4)) V(1) = SITHET*SIN(-SECPAR(4)) W(1) = SECPAR(3) ENDIF EVTH(6) = 0. IF ( TMARGIN ) THEN C NEGATIVE FIRST INTERACTION HEIGHT,IF TRACKING STARTS AT ATMOS. MARGIN EVTH(7) = Z(1) ELSE EVTH(7) = -Z(1) ENDIF CALL TOBUF(EVTH,0) C OUTPUT OF EVENTHEADER TO THE CHERENKOV FILE IF ( LCERFI ) CALL TOBUFC( EVTH,0 ) CALL CORNEC TIM(1) = 0.D0 FNPRIM = .TRUE. IF ( FPRINT ) THEN WRITE(KMPO,*) ' FIRST INTERACTION AT ',ABS(EVTH(7)*0.01),' M' ENDIF ENDIF C NOW SAMPLE ELECTRON INTERACTION, LOOK FOR BRANCHING RATIOS IF ( LELEC .LT. 0 ) THEN EBR1 = EBR11(LELKE)*ELKE+EBR10(LELKE) CALL RMMAR(RD,1,2) IF ( RD(1) .LE. EBR1 ) THEN C MAKE BREMSSTRAHLUNG GOTO 500 ELSE IF ( E(NP) .LE. THMOLL ) THEN IF ( EBR1 .LE. 0.D0 ) GOTO 380 GOTO 500 ENDIF C MOLLER SCATTERING CALL MOLLER ENDIF C ELECTRON IS LOWEST ENERGY - FOLLOW IT GOTO 380 ENDIF PBR1 = PBR11(LELKE)*ELKE+PBR10(LELKE) CALL RMMAR(RD,1,2) IF ( RD(1) .LT. PBR1 ) THEN C BREMSSTRAHLUNG GOTO 500 ENDIF PBR2 = PBR21(LELKE)*ELKE+PBR20(LELKE) IF ( RD(1) .LT. PBR2 ) THEN C BHABHA SCATTERING CALL BHABHA ELSE C ANNIHILATION CALL ANNIH RETURN ENDIF GOTO 380 500 CONTINUE C BREMSSTRAHLUNG CALL BREMS IF ( IQ(NP) .EQ. 1 ) THEN C PHOTON ON TOP OF STACK RETURN ELSE C ELECTRON ON TOP OF STACK GOTO 380 ENDIF C ENERGY DEPOSIT FOR ELECTRON BELOW CUT 390 IF ( PEIE .GT. AE ) THEN IDR = 1 IF ( LELEC .LT. 0 ) THEN EDEP = PEIE-PRM ELSE EDEP = PEIE-PRM ENDIF ELSE IDR = 2 EDEP = PEIE-PRM ENDIF IF ( LLONGI ) THEN C CUTTED ENERGY TO LONGITUDINAL ENERGY SUMS DLONG(LPCTE(NP),3) = DLONG(LPCTE(NP),3) + EDEP*1.D-3 ENDIF IF ( LELEC .GT. 0 ) THEN C IT'S A POSITRON. PRODUCE ANNIHILATION GAMMAS IF EDEP < PEI IF ( EDEP .LT. PEIE ) THEN CALL RMMAR(RD,2,2) COSTHE = RD(1) FLIP = RD(2) IF ( FLIP .LE. 0.5D0 ) COSTHE = -COSTHE SINTHE = SQRT( MAX( 0.D0, 1.0-COSTHE**2 ) ) E(NP) = PRM IQ(NP) = 1 U(NP) = 0.D0 V(NP) = 0.D0 W(NP) = 1.D0 C UPHI WILL PICK RANDOM AZIMUTHAL ANGLE CALL UPHI(2,1) NP = NP+1 E(NP) = PRM IQ(NP) = 1 X(NP) = X(NP-1) Y(NP) = Y(NP-1) Z(NP) = Z(NP-1) LPCTE(NP) = LPCTE(NP-1) IR(NP) = IR(NP-1) DNEAR(NP) = DNEAR(NP-1) TIM(NP) = TIM(NP-1) IGEN(NP) = IGEN(NP-1) IOBS(NP) = IOBS(NP-1) C SECOND GAMMA IN OPPOSITE DIRECTION U(NP) = -U(NP-1) V(NP) = -V(NP-1) W(NP) = -W(NP-1) ZAP(NP)= ZAP(NP-1) WAP(NP)= WAP(NP-1) WA(NP) = WA(NP-1) RETURN ENDIF ENDIF NP = NP-1 IRCODE = 2 RETURN C ELECTRON IS ELEMINATED BECAUSE OF CUT 420 IF ( LELEC .LT. 0 ) THEN EDEP = PEIE-PRM ELSE EDEP = PEIE+PRM ENDIF IF ( LLONGI ) THEN C CUTTED ENERGY TO LONGITUDINAL ENERGY SUMS DLONG(LPCTE(NP),3) = DLONG(LPCTE(NP),3) + EDEP*1.D-3 ENDIF IRCODE = 2 NP = NP-1 RETURN END *CMZ : 12/10/2001 14.53.55 by D. HECK IK FZK KARLSRUHE *-- Author : STANFORD LINEAR ACCELERATOR CENTER C======================================================================= C STANFORD LINEAR ACCELERATOR CENTER SUBROUTINE HATCH C VERSION 4.00 -- 26 JAN 1986/1900 C----------------------------------------------------------------------- C HATCH (THE CROSS-SECTION FILE) C C SETUP WHICH THE USER IS EXPECTED TO DO BEFORE CALLING HATCH IS: C 1. SET 'NMED' TO THE NUMBER OF MEDIA TO BE USED. C 2. SET THE ARRAY 'MEDIA', WHICH CONTAINS THE NAMES OF THE C MEDIA THAT ARE DESIRED. THE CHARACTER FORMAT IS A1, SO C THAT MEDIA(IB,IM) CONTAINS THE IB'TH BYTE OF THE NAME OF C THE IM'TH MEDIUM IN A1 FORMAT. C 3. SET 'DUNIT', THE DISTANCE UNIT TO BE USED. C DUNIT.GT.0 MEANS VALUE OF DUNIT IS LENGTH OF DISTANCE UNIT C CENTIMETERS. DUNIT.LT.0 MEANS USE THE RADIATION LENGTH OF C THE ABS(DUNIT)'TH MEDIUM FOR THE DISTANCE UNIT. C 4. FILL THE ARRAY 'MED' WITH THE MEDIUM INDICES FOR THE C REGIONS. C 5. FILL ARRAYS 'ECUT' AND 'PCUT' WITH THE ELECTRON AND PHOTON C CUT-OFF ENERGIES FOR EACH REGION RESPECTIVELY. SETUP WILL C RAISE THESE IF NECESSARY TO MAKE THEM AT LEAST AS LARGE AS C THE REGION'S MEDIUM'S AE AND AP RESPECTIVELY. C 6. FILL 'MED' ARRAY. MED(IR) IS THE MEDIUM INDEX FOR REGION C IR. A ZERO MEDIUM INDEX MEANS THE REGION IS IN A VACUUM. C 7. FILL THE ARRAY 'IRAYLR' WITH 1 FOR EACH REGION IN WHICH C RAYLEIGH (COHERENT) SCATTERING IS TO BE INCLUDED. C THIS SUBROUTINE IS CALLED FROM EGSINI. C----------------------------------------------------------------------- IMPLICIT NONE COMMON /BOUNDS/ ECUT,PCUT,VACDST DOUBLE PRECISION ECUT(6),PCUT(6),VACDST COMMON /BREMPR/ PWR2I,DL1,DL2,DL3,DL4,DL5,DL6,DELCM,ALPHI,BPAR, * DELPOS DOUBLE PRECISION PWR2I(60) REAL DL1(6),DL2(6),DL3(6),DL4(6),DL5(6),DL6(6), * DELCM,ALPHI(2),BPAR(2),DELPOS(2) COMMON /ELECIN/ EKE0,EKE1,XR0,TEFF0,BLCC,XCC,ESIG0,ESIG1,PSIG0, * PSIG1,EDEDX0,EDEDX1,PDEDX0,PDEDX1,EBR10,EBR11, * PBR10,PBR11,PBR20,PBR21,TMXS0,TMXS1,ERANG0, * ERANG1,PRANG0,PRANG1,STERNCOR REAL EKE0,EKE1,XR0,TEFF0,BLCC,XCC, * ESIG0(500),ESIG1(500),PSIG0(500),PSIG1(500), * EDEDX0(500),EDEDX1(500),PDEDX0(500),PDEDX1(500), * EBR10(500),EBR11(500),PBR10(500),PBR11(500), * PBR20(500),PBR21(500),TMXS0(500),TMXS1(500), * ERANG0(1),ERANG1(1),PRANG0(1),PRANG1(1),STERNCOR COMMON /MEDIA/ RLDU,RLDUI,RHO,RLC,NMED,MSGE,MGE,MSEKE,MEKE, * MLEKE,MCMFP,MRANGE,IRAYLM DOUBLE PRECISION RLDU,RLDUI REAL RHO,RLC INTEGER NMED,MSGE,MGE,MSEKE,MEKE,MLEKE,MCMFP,MRANGE, * IRAYLM COMMON /MEDIAC/ MEDIA CHARACTER MEDIA*24 COMMON /MISC/ DUNIT,RHOR,KMPI,KMPO,NOSCAT,MED,IRAYLR DOUBLE PRECISION DUNIT,RHOR(6) INTEGER KMPI,KMPO,NOSCAT,MED(6),IRAYLR(6) COMMON /PHOTIN/ EBINDA,GE0,GE1,GMFP0,GMFP1,GBR10,GBR11, * GBR20,GBR21,GBR30,GBR31,GBR40,GBR41, * RCO0,RCO1,RSCT0,RSCT1,COHE0,COHE1,MPGEM,NGR REAL EBINDA,GE0,GE1,GMFP0(500),GMFP1(500), * GBR10(500),GBR11(500),GBR20(500),GBR21(500), * GBR30(500),GBR31(500),GBR40(500),GBR41(500), * RCO0,RCO1,RSCT0(100),RSCT1(100),COHE0(500), * COHE1(500) INTEGER MPGEM(1),NGR *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,STACKE. COMMON /STACKE/ E,TIM,U,V,W,X,Y,Z,DNEAR, * ZAP,WAP,WA, * IQ,IGEN,IR,IOBS,LPCTE,NP DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60), * X(60),Y(60),Z(60),DNEAR(60) * ,ZAP(60),WAP(60),WA(60) INTEGER IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP *KEND. COMMON /THRESH/ RMSQ,API,TE,THMOLL,AP,AE,UP,UE DOUBLE PRECISION RMSQ,API,TE,THMOLL REAL AP,AE,UP,UE COMMON /UPHIOT/ THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI COMMON /USEFUL/ PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE DOUBLE PRECISION PRM,PRMT2,RMI,VCI INTEGER MEDIUM,MEDOLD,IBLOBE DOUBLE PRECISION DFACT,DFACTI,DUNITR,DUNITO,P INTEGER I,IB,IE,IL,IM,IRAYL,I1ST,JR,LMDL,LMDN,LOK,MD, * NCMFP,NE,NEKE,NGE,NGRIM,NLEKE,NM,NRANGE, * NSEKE,NSGE CHARACTER MBUF*72,MDLABL*8 SAVE DATA MDLABL/' MEDIUM='/,LMDL/8/,LMDN/24/,DUNITO/1.D0/ DATA I1ST/1/ C----------------------------------------------------------------------- 510 FORMAT(1X,14I5) 520 FORMAT(1X,1P,5E14.5) 530 FORMAT(A72) IF ( I1ST .NE. 0 ) THEN I1ST = 0 C NOW FILL IN POWER OF TWO TABLE. PWR2I(I)=1/2**(I-1) P = 1.D0 DO 651 I = 1,60 PWR2I(I) = P P = P*.5D0 651 CONTINUE ENDIF C FILL IRAYLM ARRAY BASED ON IRAYLR INPUTS DO 661 IM = 1,NMED 670 CONTINUE DO 671 I = 1,6 IF ( IRAYLR(I).EQ.1 .AND. MED(I).EQ.IM ) THEN C REGION I = MEDIUM IM AND WE WANT RAYLEIGH SCATTERING, SO C SET FLAG TO PICK UP DATA FOR MEDIUM IM AND TRY NEXT MEDIUM. IRAYLM = 1 GOTO 672 ENDIF 671 CONTINUE 672 CONTINUE 661 CONTINUE C NOW SEARCH FILE FOR DATA FOR REQUESTED MATERIALS REWIND KMPI NM = 0 DO 681 IM = 1,NMED LOK = 0 IF ( IRAYLM .EQ. 1 ) THEN WRITE(KMPO,690) IM 690 FORMAT(' RAYLEIGH OPTION REQUESTED FOR MEDIUM NUMBER',I3,/) ENDIF 681 CONTINUE 701 CONTINUE C MEDIUM HEADER SEARCH LOOP, FIRST LOOK FOR MEDIUM HEADER READ(KMPI,530,END=720) MBUF DO 731 IB = 1,LMDL IF ( MBUF(IB:IB) .NE. MDLABL(IB:IB) ) GOTO 701 731 CONTINUE C HEADER MATCHES. NOW SEE IF IT IS ONE OF REQUESTED MEDIA DO 741 IM = 1,NMED DO 751 IB = 1,LMDN IL = LMDL+IB IF ( MBUF(IL:IL) .NE. MEDIA(IB:IB) ) GOTO 741 IF ( IB .EQ. LMDN ) GOTO 712 751 CONTINUE 741 CONTINUE GOTO 701 712 CONTINUE C 'IM' IS THE INDEX OF THE MEDIUM READY TO BE READ IF ( LOK .NE. 0 ) GOTO 701 LOK = 1 NM = NM+1 C NOW READY TO READ IN DATA FOR THIS MEDIUM WRITE(KMPO,760) IM,MBUF 760 FORMAT(' DATA FOR MEDIUM #',I3,', WHICH IS:',A72) READ(KMPI,770) (MBUF(I:I),I=1,5),RHO,NE 770 FORMAT(5A1,5X,F11.0,4X,I2) WRITE(KMPO,780) (MBUF(I:I),I=1,5),RHO,NE 780 FORMAT(5A1,',RHO=',1P,G11.4, ',NE=',I2,',COMPOSITION IS :') DO 791 IE = 1,NE READ(KMPI,530) MBUF WRITE(KMPO,530) MBUF 791 CONTINUE C MEDIA AND THRESH READ(KMPI,520)RLC,AE,AP,UE,UP TE = AE-PRM THMOLL = TE*2.D0 + PRM C ACTUAL ARRAY SIZES FROM PEGS READ(KMPI,510)MSGE,MGE,MSEKE,MEKE,MLEKE,MCMFP,MRANGE,IRAYL NSGE = MSGE NGE = MGE NSEKE = MSEKE NEKE = MEKE NLEKE = MLEKE NCMFP = MCMFP NRANGE = MRANGE C BREMPR READ(KMPI,520) (DL1(I),DL2(I),DL3(I),DL4(I),DL5(I),DL6(I),I=1,6) READ(KMPI,520) DELCM,(ALPHI(I),BPAR(I),DELPOS(I),I=1,2) C ELECIN READ(KMPI,520) XR0,TEFF0,BLCC,XCC READ(KMPI,520) EKE0,EKE1 READ(KMPI,520) (ESIG0(I),ESIG1(I),PSIG0(I),PSIG1(I),EDEDX0(I), * EDEDX1(I),PDEDX0(I),PDEDX1(I),EBR10(I),EBR11(I),PBR10(I), * PBR11(I),PBR20(I),PBR21(I),TMXS0(I),TMXS1(I),I=1,NEKE) C PHOTIN READ(KMPI,520) EBINDA,GE0,GE1 READ(KMPI,520) (GMFP0(I),GMFP1(I),GBR10(I),GBR11(I),GBR20(I), * GBR21(I),GBR30(I),GBR31(I),GBR40(I),GBR41(I),I=1,NGE) IF ( IRAYLM.EQ.1 .AND. IRAYL.NE.1 ) THEN WRITE(KMPO,800) IM 800 FORMAT(' STOPPED IN HATCH: REQUESTED RAYLEIGH OPTION FOR MEDIUM' * ,I3/ ' BUT RAYLEIGH DATA NOT INCLUDED IN DATA CREATED BY PEGS.') STOP ENDIF IF ( IRAYL .EQ. 1 ) THEN READ(KMPI,510) NGR NGRIM = NGR READ(KMPI,520) RCO0,RCO1 READ(KMPI,520) (RSCT0(I),RSCT1(I),I=1,NGRIM) READ(KMPI,520) (COHE0(I),COHE1(I),I=1,NGE) IF ( IRAYLM .NE. 1 ) THEN WRITE(KMPO,810) IM 810 FORMAT(' RAYLEIGH DATA AVAILABLE FOR MEDIUM',I3,' BUT OPTION', * ' NOT REQUESTED.',/) ENDIF ENDIF C THAT'S ALL FOR THIS MEDIUM IF ( NM .LT. NMED ) GOTO 701 C WE NOW HAVE DATA FOR ALL MEDIA REQUESTED. NOW DO DISTANCE UNIT C CHANGE. DATA FROM PEGS IS IN UNITS OF RADIATION LENGTHS. EGS IS C RUN IN UNITS OF 'DUNIT' CENTIMETERS, IF DUNIT.GT.0 OR IN UNITS OF C RLC(-DUNIT) CENTIMETERS IF DUNIT.LT.0. THAT IS, A NEGATIVE DUNIT C MEANS UNIT IS TO BE THE RADIATION LENGTH OF THE MEDIUM WHOSE INDEX C IS -DUNIT DUNITR = DUNIT IF ( DUNIT .LT. 0.D0 ) THEN MD = MAX(1,MIN(1,INT(-DUNIT))) DUNIT = RLC ENDIF IF ( DUNIT .NE. 1.D0 ) THEN WRITE(KMPO,820) DUNITR,DUNIT 820 FORMAT(' DUNIT REQUESTED&USED ARE:',1P,2E14.5,'(CM.)') ENDIF DO 831 IM = 1,NMED C CONVERTS RADIATION LENGTH TO DUNITS DFACT = RLC/DUNIT C CONVERTS (RADIATION LENGTH)**-1 TO DUNITS**-1 DFACTI = 1.D0/DFACT I = 1 GOTO 843 841 I = I+1 843 IF ( I-(MEKE) .GT. 0 ) GOTO 842 ESIG0(I) = ESIG0(I)*DFACTI ESIG1(I) = ESIG1(I)*DFACTI PSIG0(I) = PSIG0(I)*DFACTI PSIG1(I) = PSIG1(I)*DFACTI EDEDX0(I) = EDEDX0(I)*DFACTI EDEDX1(I) = EDEDX1(I)*DFACTI PDEDX0(I) = PDEDX0(I)*DFACTI PDEDX1(I) = PDEDX1(I)*DFACTI TMXS0(I) = TMXS0(I)*DFACT TMXS1(I) = TMXS1(I)*DFACT GOTO 841 842 CONTINUE I = 1 GOTO 853 851 I = I+1 853 IF ( I-(MLEKE) .GT. 0 ) GOTO 852 ERANG0(I) = ERANG0(I)*DFACT ERANG1(I) = ERANG1(I)*DFACT PRANG0(I) = PRANG0(I)*DFACT PRANG1(I) = PRANG1(I)*DFACT GOTO 851 852 CONTINUE TEFF0 = TEFF0*DFACT BLCC = BLCC*DFACTI XCC = XCC*SQRT(DFACTI) RLDU = RLC/DUNIT RLDUI = 1.D0/RLDU I = 1 GOTO 863 861 I = I+1 863 IF ( I-(MGE) .GT. 0 ) GOTO 862 GMFP0(I) = GMFP0(I)*DFACT GMFP1(I) = GMFP1(I)*DFACT GOTO 861 862 CONTINUE 831 CONTINUE C SCALE VACDST. UNDO PREVIOUS SCALE, THEN DO NEW. VACDST = VACDST*DUNITO/DUNIT C SAVE OLD DUNIT DUNITO = DUNIT C NOW MAKE SURE ECUT AND PCUT ARE NOT LOWER THAN ANY AE OR AP C ALSO SET DEFAULT DENSITIES DO 871 JR = 1,6 MD = MED(JR) IF ( (MD .GE. 1) .AND. (MD .LE. NMED) ) THEN ECUT(JR) = MAX(ECUT(JR),DBLE(AE),DBLE(AP+1.1D0*PRM)) PCUT(JR) = MAX(PCUT(JR),DBLE(AP)) C USE STANDARD DENSITY FOR REGIONS NOT SPECIALLY SET UP IF ( RHOR(JR) .EQ. 0.D0 ) RHOR(JR)=RHO ENDIF 871 CONTINUE C SETUP IS NOW COMPLETE IF ( NMED .EQ. 1 ) THEN WRITE(KMPO,880) 880 FORMAT(' EGS SUCCESSFULLY ''HATCHED'' FOR ONE MEDIUM.') ELSE WRITE(KMPO,890) NMED 890 FORMAT(' EGS SUCCESSFULLY ''HATCHED'' FOR ',I5,' MEDIA.') ENDIF RETURN 720 WRITE(KMPO,900) KMPI 900 FORMAT(' END OF FILE ON UNIT ',I2,//,' PROGRAM STOPPED IN HATCH', * ' BECAUSE THE'/ ' FOLLOWING NAMES WERE NOT RECOGNIZED:',/) DO 911 IM = 1,NMED IF ( LOK .NE. 1 ) THEN WRITE(KMPO,920) (MEDIA(I:I),I=1,LMDN) 920 FORMAT(40X,'''',24A1,'''') ENDIF 911 CONTINUE STOP END *CMZ : 18/09/2001 09.00.42 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE HOWFAR C----------------------------------------------------------------------- C HOW FAR (COMES THE PARTICLE) C THE FOLLOWING IS A GENERAL SPECIFICATION OF HOWFAR: C GIVEN A PARTICLE AT (X,Y,Z) IN REGION IR AND GOING IN DIRECTION C (U,V,W), THIS ROUTINE ANSWERS THE QUESTION, CAN THE PARTICLE GO C A DISTANCE USTEP WITHOUT CROSSING A BOUNDARY OR OBSERVATION LEVEL? C IF YES, IT CALCULATES DNEAR AND RETURNS. C IF NO, IT SETS USTEP=DISTANCE TO BOUNDARY OR DETECTOR IN C IN THE CURRENT DIRECTION. C IT SETS IRNEW TO THE REGION NUMBER ON THE FAR SIDE C OF THE BOUNDARY (THIS CAN BE MESSY IN GENERAL!); C IT SETS NEWOBS TO THE DETECTOR NUMBER NEXT AFTER THE C DETECTOR JUST PASSING. C THE USER CAN TERMINATE A HISTORY BY SETTING IDISC>0. C HERE WE TERMINATE ALL PARTICLES GOING UPWARD OR HORIZONTALLY. C THE USER CAN TRANSPORT AND TERMINATE THE LAST PARTICLE BY SETTING C IDISC<0. HERE WE TRANSPORT AND TERMINATE ALL PARTICLES WHICH ENTER C REGION 6 OR HAVE PASSED THE LAST OBSERVATION LEVEL. C********************************************************************* C ELECTRON OR PHOTON POSITIVE Z-DIRECTION (W>0) IS DOWNWARDS C | C | REGION 1 (VACUUM) C V C--------------------------- STARTING PLANE AT -BOUND(1) = -ZALTIT C C REGION 2 (AIR WITH EXPONENTIALLY C INCREASING DENSITY) C C--------------------------- BOUNDARY AT -BOUND(2) C C REGION 3 (AIR WITH EXPONENTIALLY C INCREASING DENSITY) C C--------------------------- BOUNDARY AT -BOUND(3) C C REGION 4 (AIR WITH EXPONENTIALLY C INCREASING DENSITY) C C--------------------------- BOUNDARY AT -BOUND(4) C C REGION 5 (AIR WITH EXPONENTIALLY C INCREASING DENSITY) C C--------------------------- BOUNDARY AT -BOUND(5) (SEA LEVEL) C////////////|///////// C////////////|///////// REGION 6 (VACUUM) C////////////V///////// C ELECTRON OR PHOTON C--------------------------- BOUNDARY AT -BOUND(6) C C********************************************************************* C THIS SUBROUTINE IS CALLED FROM ELECTR AND PHOTON. C C DESIGN : D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,EGSDEB. COMMON /EGSDEB/ JCLOCK,NCLOCK,FEGSDB INTEGER JCLOCK,NCLOCK LOGICAL FEGSDB *KEEP,EPCONT. COMMON /EPCONT/ EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP, * RHOFAC,EOLD,ENEW,EKE,ELKE,BETA2,GLE,TSCAT, * IDISC,IROLD,IRNEW DOUBLE PRECISION EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP, * RHOFAC,EOLD,ENEW, EKE,ELKE,BETA2,GLE,TSCAT INTEGER IDISC,IROLD,IRNEW *KEND. COMMON /GEOMEGS/ ZALTIT,BOUND,OBSLVL,NEWOBS DOUBLE PRECISION ZALTIT,BOUND(6),OBSLVL(10) INTEGER NEWOBS *KEEP,OBSPAR. COMMON /OBSPAR/ OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP, * THETPR,PHIPR, * VUECON, * NOBSLV DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10), * HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2) DOUBLE PRECISION VUECON(2) INTEGER NOBSLV *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,STACKE. COMMON /STACKE/ E,TIM,U,V,W,X,Y,Z,DNEAR, * ZAP,WAP,WA, * IQ,IGEN,IR,IOBS,LPCTE,NP DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60), * X(60),Y(60),Z(60),DNEAR(60) * ,ZAP(60),WAP(60),WA(60) INTEGER IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP *KEND. DOUBLE PRECISION TVAL INTEGER IRL,NOBS DOUBLE PRECISION AUXIL,BOUNDC,CAP,CEARTH,OBSGLOB, * RADHOR,STEPMX,S2B,THICK INTEGER IBFLAG EXTERNAL THICK SAVE C----------------------------------------------------------------------- IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP) 1 FORMAT(' HOWFAR: NP=',I3,' IR=',I3,' IOBS=',I3) CALL AUSGB2 ENDIF IF ( IR(NP).GT.1 .AND. IR(NP).LT.6 ) THEN C WE ARE IN THE ATMOSPHERE - CHECK THE GEOMETRY IRL = IR(NP) C GOING FORWARD - CONSIDER FIRST SINCE MOST FREQUENT NOBS = IOBS(NP) IF ( W(NP) .GT. C(29) ) THEN C WE ARE GOING DOWNWARD C STEPMX IS MAX HORIZONTAL STEP, BEFORE TRANSITION TO NEXT LOCAL C COORDINATE FRAME MUST BE PERFORMED RADHOR = MAX( U(NP)**2 + V(NP)**2, 0.001D0 ) AUXIL = C(4) * THICK(-Z(NP)) + C(3) STEPMX = AUXIL / SQRT(RADHOR) C JUST SHORTEN USTEP IF ( STEPMX .LT. USTEP ) USTEP = STEPMX C TVAL IS DISTANCE TO NEXT BOUNDARY OR OBSERVATION LEVEL IN THIS C DIRECTION. INTRODUCE 'GLOBAL OBSERVATION LEVEL' C (IN CURVED VERSION JUST ONE OBSERVATION LEVEL) CEARTH = COS( SQRT( X(NP)**2 + Y(NP)**2 )/C(1) ) OBSGLOB = ( C(1) + OBSLEV(1) ) / CEARTH - C(1) CAP = W(NP)*CEARTH-SQRT((1.D0-W(NP))*(1.D0-CEARTH)) C CALCULATE REAL STEP LENGHT TO NEXT BOUNDARY S2B C (DUE TO TRANSFORMING INTO NEW LOCAL FRAME AT THIS POINT) IF ( (BOUND(IRL)+C(1))**2 .GE. * (C(1)-Z(NP))**2*(1.D0-W(NP)**2) ) THEN S2B = (C(1)-Z(NP))*W(NP) - SQRT( (BOUND(IRL)+C(1))**2 * - (C(1)-Z(NP))**2 * (1.D0-W(NP)**2) ) TVAL = MIN( S2B, (-Z(NP)-OBSGLOB)/W(NP) ) IBFLAG = 0 ELSE C PARTICLE WITH THIS ZENITH ANGLE AND HEIGHT WILL NEVER REACH THE C BOUNDARY (SPHERE AROUND EARTH), BUT IT MAY REACH THE GLOBAL OBSLEV C (LINE IN DETECTOR SYSTEM). DON'T CUT AT THIS STAGE. IBFLAG = 1 IF ( CAP .GT. 0.D0 ) THEN TVAL = (-Z(NP)-OBSGLOB)/W(NP) ELSE TVAL = USTEP + 1.D0 ENDIF ENDIF IF ( TVAL .GT. USTEP ) THEN C CAN TAKE CURRENTLY REQUESTED STEP. DNEAR HAS TO BE DISTANCE TO NEXT C BOUNDARY OR OBSLEV. KEEP DNEAR SMALL => CHECK CROSSING OF LAYER C BOUNDARY MORE OFTEN IF ( IBFLAG .NE. 0 ) THEN DNEAR(NP) = USTEP*W(NP) ELSE DNEAR(NP) = TVAL*W(NP) ENDIF ELSE C GO TO DETECTOR OR BOUNDARY, WHICH IS CLOSER USTEP = MAX(TVAL,0.0001D0) C CALCULATE THE RIGHT BOUND BOUNDC CONSIDERING THE TRANSFORMATION IN C A NEW LOCAL FRAME IF ( IBFLAG .NE. 0 ) THEN C IF S2B IS NOT DEFINED , BOUNDC IS NOT REACHED. IN THIS CASE BOUNDC C WILL NEVER BEEN REACHED BOUNDC = -9999999.9999D0 ELSE BOUNDC = -Z(NP) - S2B*W(NP) ENDIF IF ( BOUNDC .GE. OBSGLOB ) THEN C PARTICLE CROSSES BOUNDARY IRNEW = IRL+1 C PARTICLE LEAVES AIR IF ( IRNEW .GE. 6 ) IDISC = -1 ENDIF IF ( BOUNDC .LE. OBSGLOB ) THEN C PARTICLE CROSSES DETECTOR NEWOBS = NOBS + 1 C MAKE A VERY SMALL STEP TO AVOID HANGUP OF PROGRAM IF ( USTEP .LE. 0.D0 ) USTEP = 0.0001D0 C TRANSPORT PARTICLE TO FINAL DETECTOR LEVEL AND DISCARD IT IF ( NEWOBS .GT. NOBSLV ) IDISC = -1 ENDIF ENDIF C END OF 'PARTICLE GOING DOWNWARD' ELSE C GOING UPWARD IN ATMOSPHERE OR MOVING HORIZONTALLY C DISCARD PARTICLE IDISC = 1 RETURN ENDIF C END OF ATMOSPHERE REGION CASE ELSEIF ( IR(NP) .EQ. 6 ) THEN C TERMINATE THIS HISTORY, IT IS PAST THE ATMOSPHERE IDISC = 1 C WE ARE IN THE REGION WITH SOURCE ABOVE AIR ELSEIF ( IR(NP) .EQ. 1 ) THEN IF ( W(NP) .GT. C(29) ) THEN C IT MUST BE A SOURCE PARTICLE ON BOUNDARY 1 USTEP = 0.0001D0 IRNEW = 2 ELSE C IT IS A REFLECTED PARTICLE, DISCARD IT IDISC = 1 ENDIF C END REGION 1 CASE ENDIF RETURN END *CMZ : 11/01/2002 09.25.08 by D. HECK IK FZK KARLSRUHE *-- Author : STANFORD LINEAR ACCELERATOR CENTER C======================================================================= C STANFORD LINEAR ACCELERATOR CENTER SUBROUTINE MOLLER C VERSION 4.00 -- 26 JAN 1986/1900 C----------------------------------------------------------------------- C MOLLER (SCATTERING) C C DISCRETE MOLLER SCATTERING (A CALL TO THIS ROUTINE) HAS BEEN C ARBITRARILY DEFINED AND CALCULATED TO MEAN MOLLER SCATTERINGS C WHICH IMPART TO THE SECONDARY ELECTRON SUFFICIENT ENERGY THAT C IT BE TRANSPORTED DISCRETELY. THE THRESHOLD TO TRANSPORT AN C ELECTRON DISCRETELY IS A TOTAL ENERGY OF AE OR A KINETIC ENERGY C OF TE=AE-PRM. SINCE THE KINETIC ENERGY TRANSFER IS ALWAYS, BY C DEFINITION, LESS THAN HALF OF THE INCIDENT KINETIC ENERGY, THIS C IMPLIES THAT THE INCIDENT ENERGY, EIE, MUST BE LARGER THAN C THMOLL=TE*2+PRM. THE REST OF THE COLLISION CONTRIBUTION IS C SUBTRACTED CONTINUOUSLY FROM THE ELECTRON AS IONIZATION C LOSS DURING TRANSPORT. C THIS SUBROUTINE IS CALLED FROM ELECTR. C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,EGSDEB. COMMON /EGSDEB/ JCLOCK,NCLOCK,FEGSDB INTEGER JCLOCK,NCLOCK LOGICAL FEGSDB *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,STACKE. COMMON /STACKE/ E,TIM,U,V,W,X,Y,Z,DNEAR, * ZAP,WAP,WA, * IQ,IGEN,IR,IOBS,LPCTE,NP DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60), * X(60),Y(60),Z(60),DNEAR(60) * ,ZAP(60),WAP(60),WA(60) INTEGER IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP *KEND. COMMON /THRESH/ RMSQ,API,TE,THMOLL,AP,AE,UP,UE DOUBLE PRECISION RMSQ,API,TE,THMOLL REAL AP,AE,UP,UE COMMON /UPHIOT/ THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI COMMON /USEFUL/ PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE DOUBLE PRECISION PRM,PRMT2,RMI,VCI INTEGER MEDIUM,MEDOLD,IBLOBE * DOUBLE PRECISION AUXIL,BETAI2,BR,EP0,E0,E02,EXTRAE,DCOSTH,G1,G2, DOUBLE PRECISION AUXIL,BR,EP0,E0,E02,EXTRAE,DCOSTH,GMAX,G2, * G3,H1,PEIE,PEKIN,PEKINI,PEKSE2,PESE1,PESE2, * R,REJF4,T0 SAVE C----------------------------------------------------------------------- IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP) 1 FORMAT(' MOLLER: NP=',I3,' IR=',I3,' IOBS=',I3) CALL AUSGB2 ENDIF PEIE = E(NP) PEKIN = PEIE-PRM PEKINI = 1.D0/PEKIN T0 = PEKIN*RMI E0 = T0+1.D0 EXTRAE = PEIE - THMOLL E02 = E0**2 * BETAI2 = E02/(E02-1.0) C CORRECTED 18.12.98 EP0 = TE*PEKINI * G1 = (1.D0-2.D0*EP0)*BETAI2 G2 = T0**2*(1.D0/E02) G3 = (2.D0*T0+1.D0)*(1.D0/E02) GMAX = (1.D0+1.25D0*G2) C H.H.NAGEL HAS CONSTRUCTED A FACTORIZATION OF THE FREQUENCY DISTRI- C BUTION FUNCTION FOR THE MOLLER DIFFERENTIAL CROSS-SECTION USED AS C SUGGESTED BY BUTCHER AND MESSEL. (H.H.NAGEL, OP.CIT., P. 53-55) C HOWEVER, A MUCH SIMPLER SAMPLING METHOD WHICH DOES NOT BECOME VERY C INEFFICIENT NEAR THMOLL IS THE FOLLOWING: LET BR=EKS/EKIN, WHERE C EKS IS KINETIC ENERGY TRANSFERED TO THE SECONDARY ELECTRON AND EKIN C IS THE INCIDENT KINETIC ENERGY. C MODIFIED (7 FEB 1974) TO USE THE TRUE MOLLER CROSS-SECTION. THAT IS, C INSTEAD OF THE E+ E- AVERAGE GIVEN IN ROSSI FORMULA USED BY NAGEL. C THE SAMPLING SCHEME IS THAT USED BY MESSEL AND CRAWFORD C (EPSDF 1970 P.13) FIRST SAMPLE (1/BR**2) OVER (TE/EKIN,1/2) . 931 CONTINUE CALL RMMAR(RD,2,2) AUXIL = (PEKIN-EXTRAE*RD(1)) IF ( AUXIL .EQ. 0.D0 ) GOTO 931 BR = TE/AUXIL C USE MESSEL AND CRAWFORDS REJECTION FUNCTION. R = BR/(1.D0-BR) * REJF4 = G1*(1.D0+G2*BR*BR+R*(R-G3)) * IF ( RD(2) .GT. REJF4 ) GOTO 931 C CORRECTED 18.12.98 REJF4 = (1.D0+G2*BR**2+R*(R-G3)) IF ( RD(2)*GMAX .GT. REJF4 ) GOTO 931 PEKSE2 = BR*PEKIN PESE1 = PEIE-PEKSE2 PESE2 = PEKSE2+PRM E(NP) = PESE1 C SINCE BR.LE.0.5, E(NP+1) MUST BE .LE. E(NP) E(NP+1)= PESE2 H1 = (PEIE+PRM)*PEKINI C MOLLER ANGLES ARE UNIQUELY DETERMINED BY KINEMATICS DCOSTH = MIN( 1.D0, H1*(PESE1-PRM)/(PESE1+PRM) ) C DIRECTION COSINE CHANGE FOR 'OLD' ELECTRON SINTHE = SQRT(1.D0-DCOSTH) COSTHE = SQRT(DCOSTH) CALL UPHI(2,1) C RELATED CHANGE AND (X,Y,Z) SETUP FOR 'NEW' ELECTRON NP = NP+1 IQ(NP) = 3 DCOSTH = MIN( 1.D0, H1*(PESE2-PRM)/(PESE2+PRM) ) SINTHE =-SQRT(1.D0-DCOSTH) COSTHE = SQRT(DCOSTH) CALL UPHI(3,2) RETURN END *CMZ : 11/01/2002 09.25.08 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE MPPROP C----------------------------------------------------------------------- C M(UON) P(ION) PROP(AGATION) C C MOVES MUONS AND PIONS FROM EGS-STACK TO CORSIKA-STACK. C THIS SUBROUTINE IS CALLED FROM SHOWER. C C DESIGN : D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,EGSDEB. COMMON /EGSDEB/ JCLOCK,NCLOCK,FEGSDB INTEGER JCLOCK,NCLOCK LOGICAL FEGSDB *KEEP,ELABCT. COMMON /ELABCT/ ELCUT DOUBLE PRECISION ELCUT(4) *KEEP,LONGI. COMMON /LONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG, * SDLONG,SELONG,SPLONG,THSTEP,THSTPI, * LHEIGH,NSTEP,LLONGI,FLGFIT DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9), * APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9), * HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9), * SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI INTEGER LHEIGH,NSTEP LOGICAL LLONGI,FLGFIT *KEND. COMMON /MUON/ PRRMMU,RMMUT2 DOUBLE PRECISION PRRMMU,RMMUT2 *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEND. COMMON /PION/ PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR, * AMASNT DOUBLE PRECISION PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR, * AMASNT *KEEP,POLAR. COMMON /POLAR/ POLART,POLARF DOUBLE PRECISION POLART,POLARF *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,STACKE. COMMON /STACKE/ E,TIM,U,V,W,X,Y,Z,DNEAR, * ZAP,WAP,WA, * IQ,IGEN,IR,IOBS,LPCTE,NP DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60), * X(60),Y(60),Z(60),DNEAR(60) * ,ZAP(60),WAP(60),WA(60) INTEGER IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP *KEND. COMMON /UPHIOT/ THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI DOUBLE PRECISION AMASS,ANGLEX,CUT SAVE C----------------------------------------------------------------------- IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP) 1 FORMAT(' MPPROP: NP=',I3,' IR=',I3,' IOBS=',I3) CALL AUSGB2 ENDIF C SET MASS AND CUT PARAMETER OF PARTICLE UNDER CONSIDERATION IF ( IQ(NP) .LT. 7 ) THEN AMASS = PRRMMU CUT = ELCUT(2)*1000.D0 ELSEIF ( IQ(NP) .EQ. 7 ) THEN AMASS = PI0MAS CUT = ELCUT(1)*1000.D0 POLART = 1.D0 POLARF = 0.D0 ELSE AMASS = PICMAS CUT = ELCUT(1)*1000.D0 POLART = 1.D0 POLARF = 0.D0 ENDIF C USE PARTICLE ONLY IF ABOVE CUT AND INSIDE ACCEPTANCE CONE IF ( E(NP)-AMASS.GT.CUT .AND. W(NP).GT.C(29) ) THEN * IF ( W(NP) .GT. C(29) ) THEN C ANGLE WITH RESPECT TO X AXIS IF ( U(NP) .NE. 0.D0 .OR. V(NP) .NE. 0.D0 ) THEN ANGLEX = -ATAN2(V(NP),U(NP)) ELSE ANGLEX = 0.D0 ENDIF C FILL MUON/PION COORDINATES INTO CORSIKA-STACK SECPAR(1) = IQ(NP) SECPAR(2) = E(NP)/AMASS SECPAR(3) = MIN( 1.D0, W(NP) ) SECPAR(4) = ANGLEX SECPAR(5) = -Z(NP) SECPAR(6) = TIM(NP) SECPAR(7) = X(NP) SECPAR(8) = -Y(NP) SECPAR(9) = IGEN(NP) SECPAR(10) = -Z(NP) SECPAR(11) = POLART SECPAR(12) = POLARF SECPAR(14) = -ZAP(NP) SECPAR(15) = WAP(NP) SECPAR(16) = WA(NP) C ADD MUON/PION TO CORSIKA-STACK CALL TSTOUT ELSE IF ( LLONGI ) THEN C CUTTED ENERGY TO LONGITUDINAL ENERGY SUMS OF MUONS/HADRONS IF ( IQ(NP) .LE. 6 ) THEN DLONG(LPCTE(NP),5) = DLONG(LPCTE(NP),5)+E(NP)*1.D-3 ELSE DLONG(LPCTE(NP),7) = DLONG(LPCTE(NP),7)+E(NP)*1.D-3 ENDIF ENDIF ENDIF C ELIMINATE MUON/PION FROM EGS-STACK POLART = -POLART POLARF = POLARF+PI NP = NP-1 RETURN END *CMZ : 28/02/2002 13.08.20 by D. HECK IK FZK KARLSRUHE *-- Author : STANFORD LINEAR ACCELERATOR CENTER C======================================================================= C STANFORD LINEAR ACCELERATOR CENTER SUBROUTINE MSCAT C VERSION 4.00 -- 26 JAN 1986/1900 C----------------------------------------------------------------------- C M(ULTIPLE) SCAT(TERING) C C DETERMINES ANGLE OF MULTPLIE SCATTERING C THIS SUBROUTINE IS CALLED FROM ELECTR. C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,EGSDEB. COMMON /EGSDEB/ JCLOCK,NCLOCK,FEGSDB INTEGER JCLOCK,NCLOCK LOGICAL FEGSDB *KEND. COMMON /ELECIN/ EKE0,EKE1,XR0,TEFF0,BLCC,XCC,ESIG0,ESIG1,PSIG0, * PSIG1,EDEDX0,EDEDX1,PDEDX0,PDEDX1,EBR10,EBR11, * PBR10,PBR11,PBR20,PBR21,TMXS0,TMXS1,ERANG0, * ERANG1,PRANG0,PRANG1,STERNCOR REAL EKE0,EKE1,XR0,TEFF0,BLCC,XCC, * ESIG0(500),ESIG1(500),PSIG0(500),PSIG1(500), * EDEDX0(500),EDEDX1(500),PDEDX0(500),PDEDX1(500), * EBR10(500),EBR11(500),PBR10(500),PBR11(500), * PBR20(500),PBR21(500),TMXS0(500),TMXS1(500), * ERANG0(1),ERANG1(1),PRANG0(1),PRANG1(1),STERNCOR *KEEP,EPCONT. COMMON /EPCONT/ EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP, * RHOFAC,EOLD,ENEW,EKE,ELKE,BETA2,GLE,TSCAT, * IDISC,IROLD,IRNEW DOUBLE PRECISION EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP, * RHOFAC,EOLD,ENEW, EKE,ELKE,BETA2,GLE,TSCAT INTEGER IDISC,IROLD,IRNEW *KEND. COMMON /MISC/ DUNIT,RHOR,KMPI,KMPO,NOSCAT,MED,IRAYLR DOUBLE PRECISION DUNIT,RHOR(6) INTEGER KMPI,KMPO,NOSCAT,MED(6),IRAYLR(6) COMMON /MULTS/ B0G21,B1G21,G210,G211,G212, * B0G22,B1G22,G220,G221,G222, * B0G31,B1G31,G310,G311,G312, * B0G32,B1G32,G320,G321,G322, * B0BGB,B1BGB,BGB0,BGB1,BGB2,NBGB DOUBLE PRECISION B0G21,B1G21,G210(7),G211(7),G212(7), * B0G22,B1G22,G220(8),G221(8),G222(8), * B0G31,B1G31,G310(11),G311(11),G312(11), * B0G32,B1G32,G320(25),G321(25),G322(25), * B0BGB,B1BGB,BGB0(8),BGB1(8),BGB2(8) INTEGER NBGB *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,STACKE. COMMON /STACKE/ E,TIM,U,V,W,X,Y,Z,DNEAR, * ZAP,WAP,WA, * IQ,IGEN,IR,IOBS,LPCTE,NP DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60), * X(60),Y(60),Z(60),DNEAR(60) * ,ZAP(60),WAP(60),WA(60) INTEGER IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP *KEND. COMMON /THRESH/ RMSQ,API,TE,THMOLL,AP,AE,UP,UE DOUBLE PRECISION RMSQ,API,TE,THMOLL REAL AP,AE,UP,UE COMMON /UPHIOT/ THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI COMMON /USEFUL/ PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE DOUBLE PRECISION PRM,PRMT2,RMI,VCI INTEGER MEDIUM,MEDOLD,IBLOBE DOUBLE PRECISION B,BI,BLC,BMD,BM1,BM2,ETA,G21,G22,G2,G31,G32,G3, * OMEGA0,VSTEFF,THR,XR INTEGER IB,I21,I22,I31,I32 SAVE C----------------------------------------------------------------------- IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP) 1 FORMAT(' MSCAT : NP=',I3,' IR=',I3,' IOBS=',I3) CALL AUSGB2 ENDIF C ACCOUNT FOR ALTERED DENSITY VSTEFF = TVSTEP*RHOFAC C GET MOLIERE'S LOWER CASE B PARAMETER, BLC OMEGA0 = BLCC*VSTEFF/BETA2 IF ( OMEGA0 .LE. 1.D0 ) THEN SINTHE = 0.D0 COSTHE = 1.D0 THETA = 0.D0 NOSCAT = NOSCAT+1 RETURN ENDIF BLC = LOG(OMEGA0) C NOW CONVERT TO MOLIERE'S BIG B; 1.30685=2-LN 2, 1.530394=2/(2-LN 2) IF ( BLC .LE. 1.306852820D0 ) THEN C BELOW TRANSCENDENTAL LIMIT B = 1.530394218D0*BLC ELSE IB = B0BGB+BLC*B1BGB IF ( IB .GT. NBGB ) THEN WRITE(KMPO,940) IB 940 FORMAT('MSCAT: NBGB*SQRT(B); C BUT <*CHI-SUB-C*>=XCC(MEDIUM)*SQRT(VSTEFF)/(E*BETA2) XR = XCC*SQRT(MAX( 0.D0, VSTEFF*B ))/(EOLD*BETA2) C NOW SET B-INVERSE, BI THAT WILL BE USED IN SAMPLING C BI MUST NOT BE LARGER THAN 1./LAMBDA=1/2 IF ( B .GT. 2.D0 ) THEN BI = 1.D0/B BMD = 1.D0/(1.D0+1.75D0*BI) BM1 = (1.D0-2.D0*BI)*BMD BM2 = (1.0+0.025*BI)*BMD ELSE BI = 0.5D0 BM1 = (1.D0-2.D0/B)*0.533333333333D0 BM2 = 0.54D0 ENDIF C THIS LOOP IS FOR BETHE CORRECTION FACTOR REJECTION OR OTHER REJECTION 951 CONTINUE CALL RMMAR(RD,1,2) IF ( RD(1) .LE. BM1 ) THEN C GAUSSIAN, F0 CALL RMMAR(RD(2),1,2) * IF ( RD(2) .EQ. 0.D0 ) RD(2) = 1.E-30 THR = SQRT(MAX( 0.D0, -LOG(DBLE(RD(2))) )) ELSEIF ( RD(1) .LE. BM2 ) THEN C TAIL, F3 CALL RMMAR(RD(2),3,2) ETA = MAX(RD(2),RD(3)) C NOW EVALUATE REJECTION FUNCTION, G3(ETA) I31 = B0G31+ETA*B1G31 G31 = G310(I31)+ETA*(G311(I31)+ETA*G312(I31)) I32 = B0G32+ETA*B1G32 G32 = G320(I32)+ETA*(G321(I32)+ETA*G322(I32)) G3 = G31+G32*BI IF ( RD(4) .GT. G3 ) GOTO 951 THR = 1.D0/ETA ELSE C CENTRAL CORRECTION, F2 CALL RMMAR(RD(2),2,2) THR = RD(2) C COMPUTE REJECTION FUNCTION, G2 I21 = B0G21+THR*B1G21 G21 = G210(I21)+THR*(G211(I21)+THR*G212(I21)) I22 = B0G22+THR*B1G22 G22 = G220(I22)+THR*(G221(I22)+THR*G222(I22)) G2 = G21+G22*BI IF ( RD(3) .GT. G2 ) GOTO 951 ENDIF C THR IS NOW THE REDUCED ANGLE. NOW GET THE REAL ANGLE THETA = THR*XR IF ( THETA .GE. PI ) GOTO 951 SINTHE = SIN(THETA) CALL RMMAR(RD,1,2) C BETHE CORRECTION FACTOR IF ( RD(1)**2*THETA .GT. SINTHE ) GOTO 951 COSTHE = COS(THETA) RETURN END *CMZ : 11/01/2002 09.25.08 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE MUPAIR C----------------------------------------------------------------------- C MU(ON) PAIR (FORMATION) C C IN ANALOGY WITH THE SUBR. PAIR. C FOR A PHOTON ENERGY LESS THAN 434 MEV, THE APPROXIMATION IS C MADE THAT THE ENERGY OF ONE POSITIVE OR NEGATIVE MUON IS C UNIFORMLY DISTRIBUTED IN THE INTERVAL (PRRMMU, PEIG/2) = C (MUON REST MASS, PHOTON ENERGY/2). C FOR PHOTON ENERGY ABOVE 434 MEV THE C COULOMB CORRECTED BETHE-HEITLER CROSS-SECTION IS USED. C (BUTCHER AND MESSEL, OP. CIT., P. 17-19, 22). C THIS MAY BE INCORRECT C THIS SUBROUTINE IS CALLED FROM PHOTON. C C DESIGN : D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE COMMON /BREMPR/ PWR2I,DL1,DL2,DL3,DL4,DL5,DL6,DELCM,ALPHI,BPAR, * DELPOS DOUBLE PRECISION PWR2I(60) REAL DL1(6),DL2(6),DL3(6),DL4(6),DL5(6),DL6(6), * DELCM,ALPHI(2),BPAR(2),DELPOS(2) *KEEP,EGSDEB. COMMON /EGSDEB/ JCLOCK,NCLOCK,FEGSDB INTEGER JCLOCK,NCLOCK LOGICAL FEGSDB *KEND. COMMON /MUON/ PRRMMU,RMMUT2 DOUBLE PRECISION PRRMMU,RMMUT2 COMMON /NKGSUB/ XXOLD,YYOLD,ZZOLD DOUBLE PRECISION XXOLD,YYOLD,ZZOLD *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,POLAR. COMMON /POLAR/ POLART,POLARF DOUBLE PRECISION POLART,POLARF *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,STACKE. COMMON /STACKE/ E,TIM,U,V,W,X,Y,Z,DNEAR, * ZAP,WAP,WA, * IQ,IGEN,IR,IOBS,LPCTE,NP DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60), * X(60),Y(60),Z(60),DNEAR(60) * ,ZAP(60),WAP(60),WA(60) INTEGER IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP *KEND. COMMON /THRESH/ RMSQ,API,TE,THMOLL,AP,AE,UP,UE DOUBLE PRECISION RMSQ,API,TE,THMOLL REAL AP,AE,UP,UE COMMON /UPHIOT/ THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI COMMON /USEFUL/ PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE DOUBLE PRECISION PRM,PRMT2,RMI,VCI INTEGER MEDIUM,MEDOLD,IBLOBE DOUBLE PRECISION ANGLEX,BR,DEL,DELTA,ENERN,PEIG,PESE1,PESE2,REJF INTEGER LVL,LVL0,LVX SAVE C----------------------------------------------------------------------- IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP) 1 FORMAT(' MUPAIR: NP=',I3,' IR=',I3,' IOBS=',I3) CALL AUSGB2 ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'MUPAIR: E=',E(NP)*.001D0 IGEN(NP) = IGEN(NP) + 1 C PRECISE ENERGY OF INCIDENT GAMMA PEIG = E(NP) C SUBTRACT EM SUBSHOWER FROM NKG CALCULATION IF ( FNKG ) THEN SECPAR(1) = 1.D0 SECPAR(3) = MIN( 1.D0, W(NP) ) IF ( U(NP) .NE. 0.D0 .OR. V(NP) .NE. 0.D0 ) THEN ANGLEX = -ATAN2(V(NP),U(NP)) ELSE ANGLEX = 0.D0 ENDIF SECPAR(4) = ANGLEX SECPAR(5) = -ZZOLD SECPAR(7) = XXOLD SECPAR(8) = -YYOLD ENERN = (-1.D-3)*PEIG CALL NKG(ENERN) ENDIF C ENERGY OF INCIDENT GAMMA IF ( PEIG .LE. 434.D0 ) THEN C BELOW 434.MEV, WE ASSUME UNIFORM ENERGY C DISTRIBUTION OF THE MUON #2 IN THE INTERVAL (PRRMMU, PEIG/2). C SEE ALSO SLAC-265, P.49 FOR FURTHER DISCUSSION. CALL RMMAR(RD,1,2) PESE2 = (PEIG*0.5D0-PRRMMU)*RD(1)+PRRMMU ELSE C ABOVE 434.MEV, MUST SAMPLE C COULOMB CORRECTED(LVX=2,LVL=4,6) CROSS-SECTIONS. C SEE RELATED COMMENTS IN BREMS. LVX = 2 LVL0 = 3 181 CONTINUE C RETRY IF REJECTED BECAUSE DEL OUT OF RANGE, OR BY SCREENING C WE'LL NEED AT LEAST ONE RANDOM NUMBER CALL RMMAR(RD,2,2) C NOW DECIDE WHICH OF THE TWO SUBDISTRIBUTIONS TO USE. IF ( RD(2) .GE. BPAR(LVX) ) THEN C USE THE SUBDISTRIBUTION THAT IS PROPORTIONAL TO C 12*(BR-0.5)**2. IT USES A(DELTA) FOR SCREENING FUNCTION LVL = LVL0+1 CALL RMMAR(RD(3),2,2) C FROM SYMMETRY, ONLY NEED TO SAMPLE BR IN INTERVAL (0,.5) * BR = 0.5D0*(1.D0-MAX(RD(3),RD(4),RD(1))) C MODIFIED BY D. HECK (JAN 10, 2002) TO GIVE BETTER CONTINUITY FOR C SMALL BR VALUES IN CONNECTION WITH RMMAR RANDOM GENERATOR BR = 0.5D0 * MIN( RD(3), RD(4), RD(1) ) ELSE C USE THE SUBDISTRIBUTION THAT IS PROPORTIONAL TO 1,I.E. C UNIFORM.IT USES C(DELTA) FOR A SCREENING REJECT FUNCTION LVL = LVL0+3 BR = RD(1)*0.5D0 ENDIF C THE SCREENING FUNCTIONS ARE FUNCTIONS OF DELTA=DELCM*DEL, C WHERE DELCM= 136.D0*EXP(ZG)*PRM (SAME AS FOR BREMS) C AND WHERE DEL=1./(EG0*BR*(1.0-BR)) C WITH EG0 = INCIDENT PHOTON ENERGY AND BR=ENERGY FRACTION. C TO AVOID DIVISION BY ZERO * IF ( BR .EQ. 0.D0 ) GOTO 181 C CORRECTED JAN. 11, 1999 IF ( BR*PEIG .LT. PRRMMU ) GOTO 181 DEL = 1.D0/(PEIG*BR*(1.D0-BR)) IF ( DEL .GE. (PRM/PRRMMU)*DELPOS(LVX) ) GOTO 181 C NEXT TRY C THE PRECEDING CONDITION ENSURES THAT A(DELTA) AND C(DELTA) C WILL BE POSITIVE. IF IT IS NOT SATISFIED,LOOP BACK AND TRY C ANOTHER SAMPLE. DELTA = (PRRMMU*RMI)*DELCM*DEL IF ( DELTA .LT. 1.D0 ) THEN REJF = DL1(LVL)+DELTA*(DL2(LVL)+DELTA*DL3(LVL)) ELSE REJF = DL4(LVL)+DL5(LVL)*LOG(DELTA+DL6(LVL)) ENDIF C RANDOM NUMBER FOR SCREENING REJECTION CALL RMMAR(RD,1,2) C RETRY UNTIL ACCEPTED IF ( RD(1) .GT. REJF ) GOTO 181 C BR=PRODUCT ENERGY FRACTION C ENERGY OF SECONDARY 'MUON' #2 PESE2 = BR*PEIG C END OF PEIG.GT.434 ELSE ENDIF C ENERGY GOING TO LOWER SECONDARY HAS NOW BEEN DETERMINED C PRECISE ENERGY OF SECONDARY 'MUON' 2 C PRECISE ENERGY OF SECONDARY 'MUON' 1 PESE1 = PEIG-PESE2 E(NP) = PESE1 E(NP+1) = PESE2 C THIS AVERAGE ANGLE OF EMISSION FOR BOTH PAIR PRODUCTION AND C BREMSSTRAHLUNG IS MUCH SMALLER THAN THE AVERAGE ANGLE OF C MULTIPLE SCATTERING FOR DELTA T TRANSPORT=0.01 R.L. C THE INITIAL AND FINAL MOMENTA ARE COPLANAR C SET UP A NEW 'MUON' THETA = PRRMMU/PEIG CALL UPHI(1,1) C SET UP A NEW 'MUON' NP = NP+1 SINTHE = -SINTHE CALL UPHI(3,2) C NOW RANDOMLY DECIDED WHICH IS POSITIVE MUON, AND SET C CHARGES ACCORDINGLY CALL RMMAR(RD,3,2) IF ( RD(1) .LE. 0.5 ) THEN C POSITIVE MUON ON TOP IQ(NP) = 5 IQ(NP-1) = 6 ELSE C NEGATIVE MUON ON TOP IQ(NP) = 6 IQ(NP-1) = 5 ENDIF POLART = 2.D0*RD(2) -1.D0 POLARF = TWOPI*RD(3) RETURN END *CMZ : 10/01/2002 17.03.41 by D. HECK IK FZK KARLSRUHE *-- Author : STANFORD LINEAR ACCELERATOR CENTER C======================================================================= C STANFORD LINEAR ACCELERATOR CENTER SUBROUTINE PAIR C VERSION 4.00 -- 26 JAN 1986/1900 C----------------------------------------------------------------------- C PAIR (FORMATION) C C FOR A PHOTON ENERGY LESS THAN 2.1 MEV, THE APPROXIMATION IS C MADE THAT ONE PAIR ELECTRON (OR POSITRON) HAS ONLY ITS REST C MASS ENERGY. FOR PHOTON ENERGY BETWEEN 2.1 MEV AND 50 MEV THE C BETHE-HEITLER CROSS-SECTION IS EMPLOYED. ABOVE 50 MEV THE C COULOMB CORRECTED BETHE-HEITLER CROSS-SECTION IS USED. C (BUTCHER AND MESSEL, OP. CIT., P. 17-19, 22). C THIS SUBROUTINE IS CALLED FROM PHOTON. C----------------------------------------------------------------------- IMPLICIT NONE COMMON /BREMPR/ PWR2I,DL1,DL2,DL3,DL4,DL5,DL6,DELCM,ALPHI,BPAR, * DELPOS DOUBLE PRECISION PWR2I(60) REAL DL1(6),DL2(6),DL3(6),DL4(6),DL5(6),DL6(6), * DELCM,ALPHI(2),BPAR(2),DELPOS(2) *KEEP,EGSDEB. COMMON /EGSDEB/ JCLOCK,NCLOCK,FEGSDB INTEGER JCLOCK,NCLOCK LOGICAL FEGSDB *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,STACKE. COMMON /STACKE/ E,TIM,U,V,W,X,Y,Z,DNEAR, * ZAP,WAP,WA, * IQ,IGEN,IR,IOBS,LPCTE,NP DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60), * X(60),Y(60),Z(60),DNEAR(60) * ,ZAP(60),WAP(60),WA(60) INTEGER IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP *KEND. COMMON /THRESH/ RMSQ,API,TE,THMOLL,AP,AE,UP,UE DOUBLE PRECISION RMSQ,API,TE,THMOLL REAL AP,AE,UP,UE COMMON /UPHIOT/ THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI COMMON /USEFUL/ PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE DOUBLE PRECISION PRM,PRMT2,RMI,VCI INTEGER MEDIUM,MEDOLD,IBLOBE DOUBLE PRECISION BR,DEL,DELTA,PEIG,PESE1,PESE2,REJF INTEGER LVL,LVL0,LVX SAVE C----------------------------------------------------------------------- IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP) 1 FORMAT(' PAIR : NP=',I3,' IR=',I3,' IOBS=',I3) CALL AUSGB2 ENDIF PEIG = E(NP) IF ( PEIG .LE. 2.1D0 ) THEN C BELOW 2.1 MEV, USE APPROXIMATION PESE2 = PRM ELSE C ABOVE 2.1 MEV, MUST SAMPLE. DECIDE WHETHER TO USE C BETHE-HEITLER (LVX=1,LVL=1,3) OR COULOMB CORRECTED (LVX=2,LVL=4,6) C CROSS-SECTIONS. SEE RELATED COMMENTS IN BREMS. IF ( PEIG .LT. 50.D0 ) THEN LVX = 1 LVL0 = 0 ELSE LVX = 2 LVL0 = 3 ENDIF 961 CONTINUE C RETRY IF REJECTED BECAUSE DEL OUT OF RANGE, OR BY SCREENING C WE'LL NEED AT LEAST ONE RANDOM NUMBER C NOW DECIDE WHICH OF THE TWO SUBDISTRIBUTIONS TO USE CALL RMMAR(RD,2,2) IF ( RD(2) .GE. BPAR(LVX) ) THEN C USE THE SUBDISTRIBUTION THAT IS PROPORTIONAL TO 12*(BR-0.5)**2. C IT USES A(DELTA) FOR SCREENING FUNCTION. LVL = LVL0+1 CALL RMMAR(RD(3),2,2) C FROM SYMMETRY, ONLY NEED TO SAMPLE BR IN INTERVAL (0,.5) * BR = 0.5D0*(1.D0-MAX(RD(3),RD(4),RD(1))) C MODIFIED BY D. HECK (JAN 10, 2002) TO GIVE BETTER CONTINUITY FOR C SMALL BR VALUES IN CONNECTION WITH RMMAR RANDOM GENERATOR BR = 0.5D0 * MIN( RD(3), RD(4), RD(1) ) ELSE C USE THE SUBDISTRIBUTION THAT IS PROPORTIONAL TO 1, I.E. UNIFORM. C IT USES C(DELTA) FOR A SCREENING REJECTION FUNCTION. LVL = LVL0+3 BR = RD(1)*0.5D0 ENDIF C THE SCREENING FUNCTIONS ARE FUNCTIONS OF DELTA=DELCM*DEL, C WHERE DELCM= 136.0*EXP(ZG)*RM (SAME AS FOR BREMS) C AND WHERE DEL=1./(EG0*BR*(1.0-BR)) C WITH EG0 = INCIDENT PHOTON ENERGY AND BR=ENERGY FRACTION. C AVOID DIVISION BY ZERO: * IF ( BR .EQ. 0.D0 ) GOTO 961 C CORRECTED 18.12.98 IF ( BR*PEIG .LT. PRM ) GOTO 961 DEL = 1.D0/(PEIG*BR*(1.D0-BR)) IF ( DEL .GE. DELPOS(LVX) ) GOTO 961 C THE PRECEDING CONDITION ENSURES THAT A(DELTA) AND C(DELTA) WILL BE C POSITIVE. IF IT IS NOT SATISFIED, LOOP BACK AND TRY ANOTHER SAMPLE. DELTA = DELCM*DEL IF ( DELTA .LT. 1.D0 ) THEN REJF = DL1(LVL)+DELTA*(DL2(LVL)+DELTA*DL3(LVL)) ELSE REJF = DL4(LVL)+DL5(LVL)*LOG(DELTA+DL6(LVL)) ENDIF CALL RMMAR(RD,1,2) IF ( RD(1) .GT. REJF ) GOTO 961 C BR=PRODUCT ENERGY FRACTION PESE2 = BR*PEIG ENDIF PESE1 = PEIG-PESE2 E(NP) = PESE1 E(NP+1)= PESE2 C THIS AVERAGE ANGLE OF EMISSION FOR BOTH PAIR PRODUCTION AND C BREMSSTRAHLUNG IS MUCH SMALLER THAN THE AVERAGE ANGLE OF C MULTIPLE SCATTERING FOR DELTA T TRANSPORT=0.01 R.L.. THE INITIAL AND C FINAL MOMENTA ARE COPLANAR. SET UP A NEW 'ELECTRON' THETA = PRM/PEIG CALL UPHI(1,1) NP = NP+1 SINTHE =-SINTHE CALL UPHI(3,2) C NOW RANDOMLY DECIDED WHICH IS POSITRON, AND SET CHARGES ACCORDINGLY CALL RMMAR(RD,1,2) IF ( RD(1) .LE. 0.5 ) THEN IQ(NP) = 2 IQ(NP-1) = 3 ELSE IQ(NP) = 3 IQ(NP-1) = 2 ENDIF RETURN END *CMZ : 18/09/2001 13.38.55 by D. HECK IK FZK KARLSRUHE *-- Author : STANFORD LINEAR ACCELERATOR CENTER C======================================================================= C STANFORD LINEAR ACCELERATOR CENTER SUBROUTINE PHOTO C VERSION 4.00 -- 26 JAN 1986/1900 C----------------------------------------------------------------------- C PHOTO (EFFECT) C C TREATS PHOTO EFFECT C THIS SUBROUTINE IS CALLED FORM PHOTON C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,EGSDEB. COMMON /EGSDEB/ JCLOCK,NCLOCK,FEGSDB INTEGER JCLOCK,NCLOCK LOGICAL FEGSDB *KEEP,EPCONT. COMMON /EPCONT/ EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP, * RHOFAC,EOLD,ENEW,EKE,ELKE,BETA2,GLE,TSCAT, * IDISC,IROLD,IRNEW DOUBLE PRECISION EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP, * RHOFAC,EOLD,ENEW, EKE,ELKE,BETA2,GLE,TSCAT INTEGER IDISC,IROLD,IRNEW *KEEP,LONGI. COMMON /LONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG, * SDLONG,SELONG,SPLONG,THSTEP,THSTPI, * LHEIGH,NSTEP,LLONGI,FLGFIT DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9), * APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9), * HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9), * SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI INTEGER LHEIGH,NSTEP LOGICAL LLONGI,FLGFIT *KEND. COMMON /PHOTIN/ EBINDA,GE0,GE1,GMFP0,GMFP1,GBR10,GBR11, * GBR20,GBR21,GBR30,GBR31,GBR40,GBR41, * RCO0,RCO1,RSCT0,RSCT1,COHE0,COHE1,MPGEM,NGR REAL EBINDA,GE0,GE1,GMFP0(500),GMFP1(500), * GBR10(500),GBR11(500),GBR20(500),GBR21(500), * GBR30(500),GBR31(500),GBR40(500),GBR41(500), * RCO0,RCO1,RSCT0(100),RSCT1(100),COHE0(500), * COHE1(500) INTEGER MPGEM(1),NGR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,STACKE. COMMON /STACKE/ E,TIM,U,V,W,X,Y,Z,DNEAR, * ZAP,WAP,WA, * IQ,IGEN,IR,IOBS,LPCTE,NP DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60), * X(60),Y(60),Z(60),DNEAR(60) * ,ZAP(60),WAP(60),WA(60) INTEGER IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP *KEND. COMMON /USEFUL/ PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE DOUBLE PRECISION PRM,PRMT2,RMI,VCI INTEGER MEDIUM,MEDOLD,IBLOBE DOUBLE PRECISION PEIG SAVE C----------------------------------------------------------------------- IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP) 1 FORMAT(' PHOTO : NP=',I3,' IR=',I3,' IOBS=',I3) CALL AUSGB2 ENDIF PEIG = E(NP) IF ( E(NP) .LE. EBINDA ) THEN C PHOTON IS COMPLETELY ABSORBED EDEP = PEIG IBLOBE = 1 ELSE C ASSUME ELECTRON WENT IN DIRECTION OF THE PHOTON WITH ITS ENERGY, LESS C THE BINDING ENERGY. EDEP = EBINDA C BINDING ENERGY WILL BE DEPOSITED LOCALLY E(NP) = EDEP IBLOBE = 0 C FLAG INDICATING WHETHER ENERGY BELOW BINDING ENERGY ENDIF IF ( LLONGI ) THEN C CUTTED ENERGY TO LONGITUDINAL ENERGY SUMS DLONG(LPCTE(NP),1) = DLONG(LPCTE(NP),1) + EDEP*1.D-3 ENDIF IF ( IBLOBE .EQ. 1 ) THEN E(NP) = 0.D0 RETURN ENDIF IQ(NP) = 3 C SET ELECTRON ENERGY E(NP) = PEIG-EDEP+PRM RETURN END *CMZ : 28/01/2002 09.50.31 by D. HECK IK FZK KARLSRUHE *-- Author : STANFORD LINEAR ACCELERATOR CENTER C======================================================================= C STANFORD LINEAR ACCELERATOR CENTER SUBROUTINE PHOTON(IRCODE) C VERSION 4.00 -- 26 JAN 1986/1900 C----------------------------------------------------------------------- C PHOTON (IS TREATED) C C TREATS THE PHOTON TRANSPORT C FOR PATH LENGTH CORRECTION BECAUSE OF BAROMETRIC ATMOSPHERE SEE C INTERNAL REPORT OF D.HECK,(1989) C THIS SUBROUTINE IS CALLED FROM SHOWER. C ARGUMENT: C IRCODE = RETURN CODE : 1 NORMAL RETURN C 2 IF POSSIBLY STACK IS EMPTY C----------------------------------------------------------------------- IMPLICIT NONE COMMON /BOUNDS/ ECUT,PCUT,VACDST DOUBLE PRECISION ECUT(6),PCUT(6),VACDST *KEEP,BUFFS. COMMON /BUFFS/ RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH INTEGER MAXBUF,MAXLEN PARAMETER (MAXLEN=16) PARAMETER (MAXBUF=39*7) REAL RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF), * RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF) INTEGER LH CHARACTER*4 CRUNH,CRUNE,CEVTH,CEVTE,CLONG EQUIVALENCE (RUNH(1),CRUNH), (RUNE(1),CRUNE) EQUIVALENCE (EVTH(1),CEVTH), (EVTE(1),CEVTE) EQUIVALENCE (ARRAYLONG(1),CLONG) *KEEP,CEREN1. COMMON /CEREN1/ CERELE,CERHAD,ETADSN,WAVLGL,WAVLGU,CYIELD, * CERSIZ,CERNOR,LCERFI DOUBLE PRECISION CERELE,CERHAD,ETADSN,WAVLGL,WAVLGU,CYIELD, * CERSIZ,CERNOR LOGICAL LCERFI *KEEP,EGSDEB. COMMON /EGSDEB/ JCLOCK,NCLOCK,FEGSDB INTEGER JCLOCK,NCLOCK LOGICAL FEGSDB *KEEP,EPCONT. COMMON /EPCONT/ EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP, * RHOFAC,EOLD,ENEW,EKE,ELKE,BETA2,GLE,TSCAT, * IDISC,IROLD,IRNEW DOUBLE PRECISION EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP, * RHOFAC,EOLD,ENEW, EKE,ELKE,BETA2,GLE,TSCAT INTEGER IDISC,IROLD,IRNEW *KEND. COMMON /GEOMEGS/ ZALTIT,BOUND,OBSLVL,NEWOBS DOUBLE PRECISION ZALTIT,BOUND(6),OBSLVL(10) INTEGER NEWOBS COMMON /LAYER/ HBARO,HBAROI DOUBLE PRECISION HBARO(6),HBAROI(6) *KEEP,LONGI. COMMON /LONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG, * SDLONG,SELONG,SPLONG,THSTEP,THSTPI, * LHEIGH,NSTEP,LLONGI,FLGFIT DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9), * APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9), * HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9), * SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI INTEGER LHEIGH,NSTEP LOGICAL LLONGI,FLGFIT *KEND. COMMON /MEDIA/ RLDU,RLDUI,RHO,RLC,NMED,MSGE,MGE,MSEKE,MEKE, * MLEKE,MCMFP,MRANGE,IRAYLM DOUBLE PRECISION RLDU,RLDUI REAL RHO,RLC INTEGER NMED,MSGE,MGE,MSEKE,MEKE,MLEKE,MCMFP,MRANGE, * IRAYLM COMMON /MEDIAC/ MEDIA CHARACTER MEDIA*24 COMMON /MISC/ DUNIT,RHOR,KMPI,KMPO,NOSCAT,MED,IRAYLR DOUBLE PRECISION DUNIT,RHOR(6) INTEGER KMPI,KMPO,NOSCAT,MED(6),IRAYLR(6) COMMON /MUON/ PRRMMU,RMMUT2 DOUBLE PRECISION PRRMMU,RMMUT2 COMMON /NKGSUB/ XXOLD,YYOLD,ZZOLD DOUBLE PRECISION XXOLD,YYOLD,ZZOLD *KEEP,OBSPAR. COMMON /OBSPAR/ OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP, * THETPR,PHIPR, * VUECON, * NOBSLV DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10), * HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2) DOUBLE PRECISION VUECON(2) INTEGER NOBSLV *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEND. COMMON /PHOTIN/ EBINDA,GE0,GE1,GMFP0,GMFP1,GBR10,GBR11, * GBR20,GBR21,GBR30,GBR31,GBR40,GBR41, * RCO0,RCO1,RSCT0,RSCT1,COHE0,COHE1,MPGEM,NGR REAL EBINDA,GE0,GE1,GMFP0(500),GMFP1(500), * GBR10(500),GBR11(500),GBR20(500),GBR21(500), * GBR30(500),GBR31(500),GBR40(500),GBR41(500), * RCO0,RCO1,RSCT0(100),RSCT1(100),COHE0(500), * COHE1(500) INTEGER MPGEM(1),NGR COMMON /PION/ PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR, * AMASNT DOUBLE PRECISION PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR, * AMASNT *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,REJECT. COMMON /REJECT/ AVNREJ,ALTMIN,ANEXP,THICKA,THICKD,CUTLN,EONCUT, * FNPRIM DOUBLE PRECISION AVNREJ(10),ALTMIN(10),ANEXP(10),THICKA(10), * THICKD(10),CUTLN,EONCUT LOGICAL FNPRIM *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,STACKE. COMMON /STACKE/ E,TIM,U,V,W,X,Y,Z,DNEAR, * ZAP,WAP,WA, * IQ,IGEN,IR,IOBS,LPCTE,NP DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60), * X(60),Y(60),Z(60),DNEAR(60) * ,ZAP(60),WAP(60),WA(60) INTEGER IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP *KEND. COMMON /THRESH/ RMSQ,API,TE,THMOLL,AP,AE,UP,UE DOUBLE PRECISION RMSQ,API,TE,THMOLL REAL AP,AE,UP,UE COMMON /UPHIOT/ THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI COMMON /USEFUL/ PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE DOUBLE PRECISION PRM,PRMT2,RMI,VCI INTEGER MEDIUM,MEDOLD,IBLOBE DOUBLE PRECISION ALTEXP,COHFAC,CSQTHE,DISC,DPMFP, * GBR1,GBR2,GBR3,GBR4,GMFP,GMFPR0,PEIG,Q2, * REJF,RHOFI,SITHET,THICK,USTEPU,X2,ZOLD INTEGER IRCODE,IRL,I,IDR,I1, * LGLE,LPCT1,LPCT2,LXXX DOUBLE PRECISION AUXIL,AUXILSQ,AUX2SQ,CORR,COSDIF,COSTHENEW, * DISTN2,DISTO2,DSTEFF,PHI,SIGNE,SINDIF, * TANPHI,TRANS2,XOLD,YOLD,ZNEW INTEGER IPASC SAVE EXTERNAL THICK C----------------------------------------------------------------------- IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP) 1 FORMAT(' PHOTON: NP=',I3,' IR=',I3,' IOBS=',I3) CALL AUSGB2 ENDIF NEWOBS = IOBS(NP) IRCODE = 1 PEIG = E(NP) IRL = IR(NP) MEDIUM = MED(IRL) IF ( PEIG .LE. PCUT(IRL) ) GOTO 970 980 CONTINUE XXOLD = X(NP) YYOLD = Y(NP) ZZOLD = Z(NP) 981 CONTINUE C KILL HORIZONTAL OR UPWARD GOING PARTICLES IF ( W(NP) .LE. C(29) ) THEN IDISC = 1 GOTO 1000 ENDIF GLE = LOG(PEIG) C HERE SAMPLE MEAN FREE PATH TO TRANSPORT BEFORE INTERACTING CALL RMMAR(RD,1,2) DPMFP = -LOG(DBLE(RD(1))) IROLD = IR(NP) 1031 CONTINUE IF ( MEDIUM .NE. 0 ) THEN LGLE = GE1*GLE+GE0 GMFPR0 = GMFP1(LGLE)*GLE+GMFP0(LGLE) ENDIF 1041 CONTINUE IF ( MEDIUM .EQ. 0 ) THEN C WE ARE IN VACUUM TSTEP = VACDST ALTEXP = 1.D0 ELSE C WE ARE IN AIR LAYER RHOFAC = RHOR(IRL)/RHO RHOFI = 1.D0/RHOFAC GMFP = GMFPR0*RHOFI C DENSITY CORRECTION OF MEAN FREE PATH IF ( IRAYLR(IRL) .EQ. 1 ) THEN COHFAC = COHE1(LGLE)*GLE+COHE0(LGLE) GMFP = GMFP*COHFAC ENDIF TSTEP = GMFP*DPMFP ALTEXP = EXP((-Z(NP))*HBAROI(IRL)) TSTEP = TSTEP*ALTEXP DISC = W(NP)*TSTEP*HBAROI(IRL) IF ( ABS(DISC) .LT. .0000007D0 ) THEN TSTEP = TSTEP*(1.D0-.5D0*DISC*(1.D0-.666666666666667D0*DISC* * (1.D0-.75D0*DISC*(1.D0-.8D0*DISC)))) ELSEIF ( DISC .GT. -1.D0 ) THEN TSTEP = TSTEP*LOG(DISC+1.D0)/DISC ELSE TSTEP = VACDST ENDIF ENDIF IRNEW = IR(NP) IDISC = 0 USTEP = TSTEP TUSTEP = USTEP C LOOK HOW FAR WE CAN GO IF ( USTEP .GT. DNEAR(NP) ) CALL HOWFAR IF ( IDISC .GT. 0 ) GOTO 1000 IF ( IDISC .LT. 0 ) THEN C PARTICLE WILL CROSS THE DETECTOR LEVEL ZOLD = Z(NP) XOLD = X(NP) YOLD = Y(NP) DISTO2 = X(NP)**2 + Y(NP)**2 IF ( FEGSDB ) THEN WRITE(MDEBUG,*) 'PHOTON: WE APPROACH DETECTOR' CALL AUSGB2 ENDIF AUXILSQ = SQRT(DISTO2) WA(NP) = COS(AUXILSQ/C(1)) WA(NP) = MIN( 1.D0, WA(NP) ) ZAP(NP) = - (C(1)-Z(NP)) * WA(NP) + C(1) C REGARD WHETHER PARTICLE IS MOVING TOWARDS DETECTOR C EFFECTIVE DISTANCE TO DETECTOR CENTER IS DISTANCE TO POINT C OF FLIGHT PATH PROJECTION WHICH COMES CLOSEST TO DETECTOR CENTER IF ( U(NP) .NE. 0.D0 .OR. V(NP) .NE. 0.D0 ) THEN PHI = -ATAN2(V(NP),U(NP)) ELSE PHI = 0.D0 ENDIF DSTEFF = -( COS(PHI)*X(NP) + SIN(PHI)*Y(NP) ) C ANGLE DIF MIGHT BE LARGE (DUE TO CUT ON APPARTENT HEIGHT) C CALCULATE CORRECTION ANGLE DIF FROM EFFECTIVE DISTANCE SINDIF = SIN( DSTEFF/C(1) ) COSDIF = SQRT( 1.D0 - SINDIF**2 ) COSTHENEW = W(NP)*COSDIF - SQRT(1.D0-W(NP)**2)*SINDIF IF ( FEGSDB ) WRITE(MDEBUG,*) 'PHOTON: COSDIF,COSTHENEW=', * SNGL(COSDIF),SNGL(COSTHENEW) W(NP) = MIN( 1.D0, COSTHENEW ) C KILL HORIZONTAL OR UPWARD GOING PARTICLES IF ( W(NP) .LE. C(29) ) THEN IDISC = 1 GOTO 1000 ENDIF C ANGLE DIF MIGHT BE LARGE (DUE TO CUT ON APPARENT HEIGHT) X(NP) = ((-ZAP(NP))+C(1)) * TAN(X(NP)/C(1)) Y(NP) = ((-ZAP(NP))+C(1)) * TAN(Y(NP)/C(1)) Z(NP) = ZAP(NP) IF ( U(NP) .NE. 0.D0 ) THEN TANPHI= V(NP)/U(NP) U(NP) = SIGN(1.D0,U(NP)) * * SQRT((1.D0-W(NP)**2)/(1.D0+TANPHI**2)) V(NP) = TANPHI * U(NP) ELSE IF ( V(NP) .NE. 0.D0 ) * V(NP) = SIGN(1.D0,V(NP)) * SQRT( 1.D0 - W(NP)**2 ) ENDIF USTEP = -(Z(NP)+OBSLEV(1))/W(NP) IF ( FEGSDB ) THEN WRITE(MDEBUG,*) 'PHOTON: CORR. FOR DET. ARRIVAL:USTEP=',USTEP CALL AUSGB2 ENDIF IPASC = 1 ELSE C NORMAL TRANSPORT STEP FAR AWAY FROM DETECTOR IPASC = 0 ZOLD = Z(NP) XOLD = X(NP) YOLD = Y(NP) DISTO2 = X(NP)**2 + Y(NP)**2 ENDIF VSTEP = USTEP TVSTEP = VSTEP C NO ENERGY DEPOSITION ON PHOTON TRANSPORT EDEP = 0.D0 USTEPU = USTEP DISC = W(NP)*USTEPU*HBAROI(IRL) IF ( DISC .NE. 0.D0 ) THEN USTEPU = USTEPU*(EXP(DISC)-1.D0)/(DISC*ALTEXP) ENDIF X(NP) = X(NP)+U(NP)*USTEP Y(NP) = Y(NP)+V(NP)*USTEP Z(NP) = Z(NP)+W(NP)*USTEP TIM(NP) = TIM(NP)+TVSTEP*VCI IF ( IPASC .EQ. 0 ) THEN C NORMAL TRANSPORT STEP FAR AWAY FROM DETECTOR C HORIZONTAL COMPONENT OF TRACK LENGTH SQUARED TRANS2 = (X(NP)-XOLD)**2 + (Y(NP)-YOLD)**2 C TRANSPORT AT MINIMUM .001 MM TRANS2 = MAX( TRANS2, 0.00001D0 ) C NEW COORDINATE FRAME, NEW ACTUAL HEIGHT AT NEW THICKNESS GRADIENT C (CALCULATED WITH PARAMETERS OF OLD COORDINATE FRAME) AUXIL = SQRT( TRANS2 + (C(1)-Z(NP))**2 ) ZNEW = C(1) - AUXIL C CALCULATE ANGLE DIFFERENCE BETWEEN OLD AND NEW FRAME SINDIF = SQRT(TRANS2) / AUXIL COSDIF = (C(1)-Z(NP)) / AUXIL IF ( FEGSDB ) WRITE(MDEBUG,560) COSDIF,SINDIF,-Z(NP),-ZNEW 560 FORMAT(/' PHOTON: COSDIF,SINDIF,-Z,-ZNEW=',2F18.15,1P,2E17.9) COSDIF = MIN( 1.D0, COSDIF ) C CORRECTED X AND Y HAVE TO BE CALCULATED BEFORE DISTN2 C TRANSPORT DISTANCE IS CORRECTED TO GET DISTANCE AT EARTH' SURFACE CORR = C(1) * ASIN(SINDIF) / ( (C(1)-ZNEW)*SINDIF ) X(NP) = XOLD + (X(NP)-XOLD) * CORR Y(NP) = YOLD + (Y(NP)-YOLD) * CORR Z(NP) = ZNEW C NEW DISTANCE FROM PARTICLE TO DETECTOR CENTER DISTN2 = X(NP)**2 + Y(NP)**2 C COMPARE NEW AND OLD DISTANCE TO DETECTOR CENTER IF ( DISTN2 .LT. DISTO2 ) THEN C PARTICLE MOVES TOWARDS DETECTOR CENTER SIGNE = +1.D0 ELSE SIGNE = -1.D0 IF ( FEGSDB ) WRITE(MDEBUG,*) 'PHOTON: SIGNE=',SIGNE ENDIF C IN FIRST ORDER APPROXIMATION W(NP) AND COSDIF ARE IN THE SAME PLANE C OF PARTICLE MOVEMENT, THEREFORE THE ANGLES MAY BE ADDED DIRECTLY COSTHENEW = W(NP)*COSDIF - SIGNE*SINDIF*SQRT(1.D0-W(NP)**2) W(NP) = MIN( 1.D0, COSTHENEW ) C KILL HORIZONTAL OR UPWARD GOING PARTICLES IF ( W(NP) .LE. C(29) ) THEN IDISC = 1 GOTO 1000 ENDIF IF ( FEGSDB ) THEN WRITE(MDEBUG,562) WA(NP),-ZAP(NP) 562 FORMAT(' PHOTON: WA,-ZAP=',F18.15,1P,E17.9) WRITE(MDEBUG,557) U(NP),V(NP),W(NP),X(NP),Y(NP),Z(NP) 557 FORMAT(' PHOTON: STEPEND=',1P,6E10.3,0P) ENDIF C CALCULATE ANGLES IN THE NEW FRAME AUXILSQ = SQRT(X(NP)**2 + Y(NP)**2) WA(NP) = COS( AUXILSQ/C(1) ) WA(NP) = MIN( 1.D0, WA(NP) ) ZAP(NP) = -(C(1)-ZNEW) * WA(NP) + C(1) AUX2SQ = SQRT( (C(1)-ZNEW)**2*(1.D0 - WA(NP)**2) * + (-ZAP(NP)-OBSLEV(1))**2 ) WAP(NP) = -(OBSLEV(1)+ZAP(NP)) / AUX2SQ IF ( FEGSDB ) WRITE(MDEBUG,*) 'PHOTON: WAP=',WAP(NP) WAP(NP) = MIN( 1.D0, WAP(NP) ) IF ( U(NP) .NE. 0.D0 ) THEN TANPHI= V(NP)/U(NP) U(NP) = SIGN(1.D0,U(NP)) * * SQRT((1.D0-W(NP)**2)/(1.D0+TANPHI**2)) V(NP) = TANPHI * U(NP) ELSE IF ( V(NP) .NE. 0.D0 ) * V(NP) = SIGN(1.D0,V(NP)) * SQRT( 1.D0 - W(NP)**2 ) ENDIF ENDIF C ADD PHOTONS TO THE LONGITUDINAL DEVELOPMENT IF ( LLONGI ) THEN C FIND FIRST THE EQUIVALENT LEVELS C IF STARTING POINT BELOW LOWEST LEVEL THEN DON'T CHECK IF ( HLONG(NSTEP) .LE. -ZOLD ) THEN LPCT1 = LPCTE(NP) C Z NEW IS PROBABLY ONLY LITTLE BELOW Z OLD, THEREFORE INCREMENTAL SEARCH DO I1 = LPCT1,NSTEP IF ( HLONG(I1) .LT. -Z(NP) ) GOTO 6003 ENDDO I1 = NSTEP + 1 6003 CONTINUE LPCT2 = I1 - 1 C STORE END POINT AS POSSIBLE STARTPOINT OF NEXT TRACK LPCTE(NP) = LPCT2 + 1 IF ( IDISC .LT. 0 ) LPCT2 = LPCT2+1 DO I = LPCT1,LPCT2 PLONG(I,1) = PLONG(I,1) + 1.D0 ELONG(I,1) = ELONG(I,1) + E(NP)*1.D-3 ENDDO ENDIF ENDIF C DEDUCT FROM DISTANCE TO NEAREST BOUNDARY DNEAR(NP) = DNEAR(NP)-USTEP IF ( MEDIUM .NE. 0 ) THEN DPMFP = MAX( 0.D0, DPMFP-USTEPU/GMFP ) ENDIF IROLD = IR(NP) MEDOLD = MEDIUM IF ( IRNEW .NE. IROLD ) THEN C CHANGE OF LAYER IR(NP) = IRNEW IRL = IRNEW MEDIUM = MED(IRL) IF ( PEIG .LE. PCUT(IRL) ) GOTO 970 ENDIF C KILL UPWARD GOING PARTICLES IF ( W(NP) .LE. C(29) ) THEN IDISC = 1 GOTO 1000 ENDIF C LOOK FOR OBSERVATION LEVEL AND GIVE TO OUTPUT IF ( NEWOBS .GT. IOBS(NP) ) THEN CALL AUSGAB IOBS(NP) = NEWOBS ENDIF IF ( IDISC .LT. 0 ) GOTO 1000 IF ( MEDIUM .NE. MEDOLD ) GOTO 1031 C SKIP BACK IF STEP LENGTH NOT YET TOTALLY EXHAUSTED IF ( MEDIUM .NE. 0 .AND. DPMFP .LE. 1.D-6 ) GOTO 1032 GOTO 1041 1032 CONTINUE C RAYLEIGH SCATTERING IF ( IRAYLR(IRL) .EQ. 1 ) THEN CALL RMMAR(RD,1,2) IF ( RD(1) .LE. 1.D0-COHFAC ) THEN 1050 CONTINUE CALL RMMAR(RD,1,2) LXXX = RCO1*RD(1)+RCO0 X2 = RSCT1(LXXX)*RD(1)+RSCT0(LXXX) Q2 = X2*RMSQ*.23547885D-02 COSTHE = 1.D0-Q2/(2.D0*E(NP)**2) IF ( ABS(COSTHE) .GT. 1.D0 ) GOTO 1050 CSQTHE = COSTHE**2 REJF = (1.D0+CSQTHE)*.5D0 CALL RMMAR(RD,1,2) IF ( RD(1) .GT. REJF ) GOTO 1050 SINTHE = SQRT( MAX( 0.D0, 1.D0-CSQTHE ) ) CALL UPHI(2,1) GOTO 981 ENDIF ENDIF IF ( .NOT. FNPRIM ) THEN C DETERMINE THE ALTITUDE OF THE FIRST INTERACTION IF ( .NOT. TMARGIN ) THEN X(1) = 0.D0 Y(1) = 0.D0 ENDIF IF ( FIX1I ) THEN C IF HEIGHT OF FIRST INTERACTION IS FIXED, TAKE STARTING ANGLES OF C PRIMARY PARTICLE Z(1) = -FIXHEI NP = 1 LPCTE(1) = MIN(NSTEP,INT(THICK(FIXHEI)*THSTPI)+1) SITHET = SQRT(1.D0-SECPAR(3)**2) U(1) = SITHET*COS(-SECPAR(4)) V(1) = SITHET*SIN(-SECPAR(4)) W(1) = SECPAR(3) ENDIF EVTH(6) = 0. IF ( TMARGIN ) THEN C NEGATIVE FIRST INTERACTION HEIGHT,IF TRACKING STARTS AT ATMOS. MARGIN EVTH(7) = Z(1) ELSE EVTH(7) = -Z(1) ENDIF CALL TOBUF(EVTH,0) C OUTPUT OF EVENTHEADER TO THE CHERENKOV FILE IF ( LCERFI ) CALL TOBUFC( EVTH,0 ) CALL CORNEC TIM(1) = 0.D0 FNPRIM = .TRUE. IF ( FPRINT ) THEN WRITE(KMPO,*) ' FIRST INTERACTION AT ',ABS(EVTH(7)*0.01),' M' ENDIF ENDIF C THIS RANDOM NUMBER DETERMINES WHICH INTERACTION CALL RMMAR(RD,1,2) GBR4 = GBR41(LGLE)*GLE+GBR40(LGLE) IF ( RD(1) .GE. GBR4 .AND. E(NP) .GT. PRMT2 ) THEN C E+E- PAIR FORMATION CALL PAIR RETURN ENDIF GBR3 = GBR31(LGLE)*GLE+GBR30(LGLE) IF ( RD(1) .GE. GBR3 ) THEN C COMPTON SCATTERING CALL COMPT IF ( IQ(NP) .NE. 1 ) RETURN GOTO 1060 ENDIF GBR1 = GBR11(LGLE)*GLE+GBR10(LGLE) IF ( RD(1) .LE. GBR1 .AND. E(NP) .GT. RMMUT2 ) THEN C MU+MU- PAIR FORMATION CALL MUPAIR RETURN ENDIF GBR2 = GBR21(LGLE)*GLE+GBR20(LGLE) IF ( RD(1) .LE. GBR2 .AND. E(NP) .GT. PITHR ) THEN C PHOTONUCLEAR REACTION CALL PIGEN IF ( NP .EQ. 0 ) THEN IRCODE = 2 RETURN ENDIF RETURN ELSE C PHOTO EFFECT CALL PHOTO IF ( NP .EQ. 0 ) THEN IRCODE = 2 RETURN ENDIF IF ( IQ(NP) .EQ. 3 ) RETURN ENDIF 1060 PEIG = E(NP) C KILL HORIZONTAL OR UPWARD GOING PARTICLES IF ( W(NP) .LE. C(29) ) THEN IDISC = 1 GOTO 1000 ENDIF IF ( PEIG .GE. PCUT(IRL) ) GOTO 980 970 IF ( PEIG .GT. AP ) THEN IDR = 1 ELSE IDR = 2 ENDIF EDEP = PEIG IF ( LLONGI ) THEN C CUTTED ENERGY TO LONGITUDINAL ENERGY SUMS DLONG(LPCTE(NP),1) = DLONG(LPCTE(NP),1) + EDEP*1.D-3 ENDIF IRCODE = 2 NP = NP-1 RETURN 1000 EDEP = PEIG IF ( LLONGI .AND. IDISC .GT. 0 ) THEN C CUTTED ENERGY TO LONGITUDINAL ENERGY SUMS DLONG(LPCTE(NP),1) = DLONG(LPCTE(NP),1) + EDEP*1.D-3 ENDIF IRCODE = 2 NP = NP-1 RETURN END *CMZ : 11/01/2002 09.25.09 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE PIGEN C----------------------------------------------------------------------- C PI(ON) GEN(ERATION) C C THIS SUBROUTINE STEERS THE PHOTONUCLEAR REACTION: C FOR PRODUCTION OF 1 PION, PIGEN1 IS CALLED. C FOR PRODUCTION OF 2 PIONS, PIGEN2 IS CALLED. C AT HIGHER ENERGIES SDPM IS CALLED FOR PRODUCTION OF MORE PARTICLES C OR RHOGEN IS CALLED FOR PRODUCTION OF RHO OR OMEGA MESON C THIS SUBROUTINE IS CALLED FROM PHOTON. C C DESIGN : D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,BUFFS. COMMON /BUFFS/ RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH INTEGER MAXBUF,MAXLEN PARAMETER (MAXLEN=16) PARAMETER (MAXBUF=39*7) REAL RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF), * RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF) INTEGER LH CHARACTER*4 CRUNH,CRUNE,CEVTH,CEVTE,CLONG EQUIVALENCE (RUNH(1),CRUNH), (RUNE(1),CRUNE) EQUIVALENCE (EVTH(1),CEVTH), (EVTE(1),CEVTE) EQUIVALENCE (ARRAYLONG(1),CLONG) *KEEP,EGSDEB. COMMON /EGSDEB/ JCLOCK,NCLOCK,FEGSDB INTEGER JCLOCK,NCLOCK LOGICAL FEGSDB *KEEP,GENER. COMMON /GENER/ GEN,ALEVEL DOUBLE PRECISION GEN,ALEVEL *KEEP,MULT. COMMON /MULT/ EKINL,MSMM,MULTMA,MULTOT DOUBLE PRECISION EKINL INTEGER MSMM,MULTMA(40,13),MULTOT(40,13) *KEND. COMMON /NKGSUB/ XXOLD,YYOLD,ZZOLD DOUBLE PRECISION XXOLD,YYOLD,ZZOLD *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,STACKE. COMMON /STACKE/ E,TIM,U,V,W,X,Y,Z,DNEAR, * ZAP,WAP,WA, * IQ,IGEN,IR,IOBS,LPCTE,NP DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60), * X(60),Y(60),Z(60),DNEAR(60) * ,ZAP(60),WAP(60),WA(60) INTEGER IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP *KEEP,THNVAR. COMMON /THNVAR/ STACKINT, * INT_ICOUNT,MODETHN,THINNING INTEGER MAXICOUNT PARAMETER (MAXICOUNT=40000) DOUBLE PRECISION STACKINT(16,MAXICOUNT) INTEGER INT_ICOUNT,MODETHN LOGICAL THINNING *KEND. DOUBLE PRECISION ANGLEX,ENERN,PEIG,REGPAR(MAXLEN),REGGEN,REGLVL DOUBLE PRECISION AUXIL,ECMVM,VMFRAC INTEGER K SAVE C----------------------------------------------------------------------- IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP) 1 FORMAT(' PIGEN : NP=',I3,' IR=',I3,' IOBS=',I3) CALL AUSGB2 ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'PIGEN : E=',E(NP)*.001D0 C INCREASE AGE, WE HAVE HADRONIC INTERACTION IGEN(NP) = IGEN(NP)+1 SECPAR(9) = IGEN(NP) SECPAR(10) =-Z(NP) SECPAR(14) = -ZAP(NP) SECPAR(15) = WAP(NP) SECPAR(16) = WA(NP) PEIG = E(NP) IF ( U(NP) .NE. 0.D0 .OR. V(NP) .NE. 0.D0 ) THEN ANGLEX = -ATAN2(V(NP),U(NP)) ELSE ANGLEX = 0.D0 ENDIF C SUBTRACT EM SUBSHOWER FROM NKG CALCULATION C WITH CORRECTION FOR ORIGIN OF GAMMA (MARCH 10, 1998) IF ( FNKG ) THEN SECPAR(1) = 1.D0 SECPAR(3) = MIN( 1.D0, W(NP) ) SECPAR(4) = ANGLEX SECPAR(5) = -ZZOLD SECPAR(7) = XXOLD SECPAR(8) = -YYOLD ENERN = (-1.D-3)*PEIG CALL NKG(ENERN) IF ( DEBUG ) WRITE(MDEBUG,*) 'PIGEN : NKG SUBTRACTED' ENDIF CALL RMMAR(RD,1,2) IF ( RD(1) .GT. (PEIG-400.D0)*0.001D0 ) THEN C FOR ENERGIES BETWEEN 400 MEV AND 1400 MEV (=1000+400) DECIDE C BY CHANCE WHETHER ONE OR TWO PIONS ARE GENERATED C PIGEN1 TREATS THE PRODUCTION OF 1 PION INT_ICOUNT = 0 CALL PIGEN1 CALL TSTEND ELSEIF ( RD(1) .GT. (PEIG-2000.D0)*0.001D0 ) THEN C FOR ENERGIES BETWEEN 2000MEV AND 3000MEV (=1000+2000) DECIDE C BY CHANCE WHETHER 2 (PIGEN2) OR MORE PIONS (SDPM) ARE GENERATED C PIGEN2 TREATS THE PRODUCTION OF 2 PIONS INT_ICOUNT = 0 CALL PIGEN2 CALL TSTEND ELSE C SAVE CURPAR PARTICLE INTO REGISTER REGPAR DO K = 1,MAXLEN REGPAR(K) = CURPAR(K) ENDDO REGGEN = GEN REGLVL = ALEVEL C FOR ENERGIES ABOVE 2 GEV TAKE BY CHANCE DIFFRACTIVE INTERACTION C LEADING TO A RHO (90%) OR OMEGA (10%) BY CALLING RHOGEN C FIRST CALCULATE REST MASS OF AVERAGE AIR TARGET (MASS # 14.6) AUXIL = 7.3D0 * (PAMA(13)+PAMA(14)) C ENERGY IN CM SYSTEM (GEV) ECMVM = SQRT( AUXIL*(AUXIL + 2.D0*PEIG*0.001D0) ) C THE FRACTION IS THE RATIO OF VECTOR MESON PRODUCTION CROSS-SECTION C (TO BE CALCULATED ACCORDING R. ENGEL ET AL., PHYS. REV. D55 C (1997) 6957) TO TOTAL PHOTONUCLEAR CROSS-SECTION C (SEE T. STANEV ET AL., PHYS. REV. D32 (1985) 1244) C THE FRACTION LEADING TO A RHO (90%) OR OMEGA (10%) IS FITTED BY VMFRAC = .11195D0 * ECMVM**0.0870D0 + .51892D0/(ECMVM**1.2891D0) CALL RMMAR(RD,1,2) IF ( FEGSDB ) WRITE(MDEBUG,*) 'PIGEN : VMFRAC,RD=', * SNGL(VMFRAC),RD(1) IF ( RD(1) .LT. VMFRAC ) THEN INT_ICOUNT = 0 CALL RHOGEN CALL TSTEND ELSE C AT HIGHER ENERGIES MORE THAN 2 PIONS ARE GENERATED BY HIGH ENERGY C HADRONIC INTERACTION MODEL C FILL CURRENT EGS4-PARTICLE INTO CURPAR ITYPE = 1 CURPAR(1) = 1.D0 CURPAR(2) = PEIG*1.D-3 CURPAR(3) = MIN( 1.D0, W(NP) ) CURPAR(4) = ANGLEX CURPAR(5) =-Z(NP) CURPAR(6) = TIM(NP) CURPAR(7) = X(NP) CURPAR(8) =-Y(NP) CURPAR(9) = 0.D0 CURPAR(10) = 1.D0 CURPAR(12) = SQRT(PAMA(14)*(PAMA(14)+PEIG*2.D-3)) CURPAR(11) = (PEIG*1.D-3+PAMA(14))/CURPAR(12) GEN = IGEN(NP) ALEVEL =-Z(NP) EKINL = CURPAR(2) CURPAR(14) = -ZAP(NP) SECPAR(14) = -ZAP(NP) CURPAR(15) = WAP(NP) SECPAR(15) = WAP(NP) CURPAR(16) = WA(NP) SECPAR(16) = WA(NP) C ELIMINATE GAMMA FROM EGS-STACK NP = NP-1 C HDPM, VENUS, NEXUS, SIBYLL, QGSJET, DPMJET GIVE ALL PARTICLES TO C SECPAR. COPY VERTEX COORDINATES INTO SECPAR FOR SECONDARIES DO K = 5,8 SECPAR(K) = CURPAR(K) ENDDO INT_ICOUNT = 0 CALL SDPM CALL TSTEND C END OF MANY PION GENERATION ENDIF C RESTORE CURPAR PARTICLE FROM REGPAR DO K = 1,MAXLEN CURPAR(K) = REGPAR(K) ENDDO GEN = REGGEN ALEVEL = REGLVL ENDIF RETURN END *CMZ : 28/02/2002 13.12.11 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE PIGEN1 C----------------------------------------------------------------------- C PI(ON) GEN(ERATION) 1 (PION) C C THIS SUBROUT. DESCRIBES THE PHOTONUCLEAR REACTION C GAMMA + NUCLEON -----> PION + NUCLEON C THIS SUBROUTINE IS CALLED FROM PIGEN. C C DESIGN : D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,EGSDEB. COMMON /EGSDEB/ JCLOCK,NCLOCK,FEGSDB INTEGER JCLOCK,NCLOCK LOGICAL FEGSDB *KEEP,ELABCT. COMMON /ELABCT/ ELCUT DOUBLE PRECISION ELCUT(4) *KEEP,LONGI. COMMON /LONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG, * SDLONG,SELONG,SPLONG,THSTEP,THSTPI, * LHEIGH,NSTEP,LLONGI,FLGFIT DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9), * APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9), * HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9), * SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI INTEGER LHEIGH,NSTEP LOGICAL LLONGI,FLGFIT *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEND. COMMON /PION/ PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR, * AMASNT DOUBLE PRECISION PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR, * AMASNT *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,REJECT. COMMON /REJECT/ AVNREJ,ALTMIN,ANEXP,THICKA,THICKD,CUTLN,EONCUT, * FNPRIM DOUBLE PRECISION AVNREJ(10),ALTMIN(10),ANEXP(10),THICKA(10), * THICKD(10),CUTLN,EONCUT LOGICAL FNPRIM *KEEP,STACKE. COMMON /STACKE/ E,TIM,U,V,W,X,Y,Z,DNEAR, * ZAP,WAP,WA, * IQ,IGEN,IR,IOBS,LPCTE,NP DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60), * X(60),Y(60),Z(60),DNEAR(60) * ,ZAP(60),WAP(60),WA(60) INTEGER IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP *KEND. COMMON /UPHIOT/ THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI DOUBLE PRECISION AMASS2,AMAS2I,AMASS3,AMASS4,AMOM3,AMOM4,ANGLEX, * BETA,BRATIO,B3CM,B3CM2,COSTE3,ED,ENUCL, * ESQ,ETH,E3CM,GAMMA,G3, * PEIG,PEOP,PT,PTRANS,P3CM,W0,W0I,W0S,W0SI SAVE EXTERNAL PTRANS C----------------------------------------------------------------------- IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP) 1 FORMAT(' PIGEN1: NP=',I3,' IR=',I3,' IOBS=',I3) CALL AUSGB2 ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'PIGEN1: E=',E(NP)*.001D0 PEIG = E(NP) C NUMBERS AT THE VARIABLES MEAN : C 1 INCOMING GAMMA RAY C 2 HIT NUCLEON C 3 PRODUCED PION C 4 RECOILING NUCLEON C LOOK WHICH TYPE OF REACTION CALL RMMAR(RD,2,2) C 0.49923 IS THE FRACTION OF PROTONS IN AIR IF ( RD(1) .LE. 0.49923 ) THEN C HIT NUCLEON IS PROTON AMASS2 = AMASPR C 33% CHANCE FOR CHARGE EXCHANGE IF ( RD(2) .LE. 0.3333333 ) THEN C PI(+) + NEUTRON PRODUCED IQ(NP) = 8 IQ(NP+1) = 13 ELSE C PI(0) + PROTON PRODUCED IQ(NP) = 7 IQ(NP+1) = 14 ENDIF ELSE C HIT NUCLEON IS NEUTRON AMASS2 = AMASNT C 33% CHANCE FOR CHARGE EXCHANGE IF ( RD(2) .LE. 0.3333333 ) THEN C PI(-) + PROTON PRODUCED IQ(NP) = 9 IQ(NP+1) = 14 ELSE C PI(0) + NEUTRON PRODUCED IQ(NP) = 7 IQ(NP+1) = 13 ENDIF ENDIF AMAS2I = 1.D0/AMASS2 C NOTE: THE ENERGIES IN EGS ARE IN MEV, IN CORSIKA IN GEV AMASS3 = PAMA(IQ(NP))*1.D3 AMASS4 = PAMA(IQ(NP+1))*1.D3 C TOTAL LABORATORY ENERGY AND ITS INVERSE W0 = PEIG+AMASS2 W0I = 1.D0/W0 C TOTAL.C.M. ENERGY AND INVERSE OF TOTAL C.M.ENERGY W0S = SQRT(AMASS2*(AMASS2+2.D0*PEIG)) W0SI = 1.D0/W0S C THRESHOLD ENERGY ETH = 0.5D0*((AMASS3+AMASS4)**2-AMASS2**2)*AMAS2I C BETA,GAMMA, ESQ, BRATIO, G3 ARE AUXILIARY QUANTITIES BETA = PEIG*W0I GAMMA = W0*W0SI ED = 0.5D0*((AMASS3-AMASS4)**2-AMASS2**2)*AMAS2I ESQ = SQRT((PEIG-ETH)*(PEIG-ED)) BRATIO = PEIG/ESQ G3 = W0I*BRATIO*(PEIG-ETH+AMASS3*AMAS2I*(AMASS3+AMASS4)) C C.M. ENERGY OF PION E3CM = G3*AMASS2*GAMMA/BRATIO C C.M. PION MOMENTUM P3CM = AMASS2*W0SI*ESQ B3CM2 = P3CM**2/(P3CM**2+AMASS3**2) B3CM = SQRT(B3CM2) C DETERMINE THETA IN C.M. SYSTEM BY CHANCE. IF ( PEIG .LE. 900.D0 ) THEN C PHOTON ENERGY IS BELOW 900 MEV 210 CONTINUE CALL RMMAR(RD,2,2) IF ( IQ(NP) .EQ. 7 ) THEN C NEUTRAL PION EMITTED, TAKE PURE C DIPOLE RADIATION: W(COSTH) = 1-3/5*COSTH**2 COSTE3 = 2.D0*RD(1)-1.D0 IF ( RD(2) .GT. 1.D0-0.6D0*COSTE3**2 ) GOTO 210 ELSE C CHARGED PION EMITTED, TAKE MODIFIED DIPOLE RADIATION C WITH ASYMMETRY TERM 1/(1-BETACM*COSTE3)**2 COSTE3 = 1.D0/B3CM - 1.D0/(RD(1)*2.D0*B3CM2/(1.D0-B3CM2) * + B3CM/(1.D0+B3CM)) IF ( RD(2)*2.5D0 .GT. 1.D0+COSTE3*(-1.8D0 + COSTE3* * (.65D0 + COSTE3*(.34D0 -.18D0*COSTE3 ))) ) GOTO 210 ENDIF ELSEIF ( PEIG .LE. 1300.D0 ) THEN C PHOTON ENERGY BETWEEN 900 AND 1300 MEV 220 CONTINUE CALL RMMAR(RD,2,2) IF ( IQ(NP) .EQ. 7 ) THEN C NEUTRAL PION EMITTED, TAKE PURE QUADRUPOLE C RADIATION: W(COSTH) = 1+6*COSTH**2-5*COSTH**4 COSTE3 = 2.D0*RD(1)-1.D0 IF ( 2.8D0*RD(2) .GT. * 1.D0+6.D0*COSTE3**2-5.D0*COSTE3**4 ) GOTO 220 ELSE C CHARGED PION EMITTED, TAKE MODIFIED QUADRUPOLE C RADIATION WITH ASYMMETRY TERM: 1/(1-BETACM*COSTE3)**2 COSTE3 = 1.D0/B3CM - 1.D0/(RD(1)*2.D0*B3CM2/(1.D0-B3CM2) * + B3CM/(1.D0+B3CM)) IF ( 13.2D0*RD(2) .GT. 1.D0 + COSTE3*(-2.18D0 + COSTE3*(7.20D0 * + COSTE3*(-2.55D0 + COSTE3*(-15.39D0 + COSTE3*(6.36D0 * + COSTE3*(13.80D0 - COSTE3*8.235D0)))))) ) GOTO 220 ENDIF ELSE C ABOVE 1300 MEV THE ANGULAR DISTRIBUTION IS DETERMINED C BY THE TRANSVERSE MOMENTUM OF THE PION PT = 1.D3*PTRANS() COSTE3 = SQRT(MAX( 0.D0, P3CM**2-PT**2 ))/P3CM ENDIF C PRECISE ENERGY OUTGOING PION = PEOP PEOP = GAMMA*(E3CM+BETA*P3CM*COSTE3) C ENERGY OF OUTGOING PION IN STACK POSITION NP E(NP) = PEOP C MOMENTUM OF OUTGOING PION = AMOM3 C COSTHE AND SINTHE ARE ANGLES IN LAB SYSTEM FOR PARTICLE 3 (PION) C SEE SLAC-265, P. 52 AMOM3 = SQRT(MAX( 0.D0, PEOP**2-AMASS3**2 )) IF ( AMOM3 .GT. 0.D0 ) THEN COSTHE = (AMASS4**2 - AMASS2**2 - AMASS3**2 + 2.D0*PEOP*W0 * - 2.D0*PEIG*AMASS2)/(2.D0*PEIG*AMOM3) ELSE COSTHE = 1.D0 ENDIF SINTHE = SQRT(MAX( 0.0D0, 1.D0-COSTHE**2 )) CALL UPHI(2,1) C TOTAL ENERGY OF RECOILING NUCLEON = ENUCL ENUCL = W0-PEOP IF ( ENUCL-AMASS4 .GT. ELCUT(1)*1000.D0 ) THEN C RECOIL ENERGY IS TOO LARGE, MUST TREAT THE NUCLEON NP = NP+1 E(NP) = ENUCL C MOMENTUM OF RECOIL NUCLEON AMOM4 = SQRT(ENUCL**2-AMASS4**2) C COSTHE AND SINTHE ARE ANGLES IN LAB SYSTEM FOR RECOIL NUCLEON C SEE SLAC-265, P. 52 COSTHE = (AMASS3**2 - AMASS2**2 - AMASS4**2 + 2.D0*ENUCL*W0 * - 2.D0*PEIG*AMASS2)/(2.D0*PEIG*AMOM4) SINTHE = -SQRT(MAX( 0.0D0, 1.D0-COSTHE**2 )) CALL UPHI(3,2) IF ( E(NP)-AMASS4 .GT. ELCUT(1)*1000.D0 ) THEN IF ( W(NP) .GT. C(29) ) THEN C ANGLE WITH RESPECT TO X AXIS IF ( U(NP) .NE. 0.D0 .OR. V(NP) .NE. 0.D0 ) THEN ANGLEX = -ATAN2(V(NP),U(NP)) ELSE ANGLEX = 0.D0 ENDIF C ADD NUCLEON TO CORSIKA STACK SECPAR(1) = IQ(NP) SECPAR(2) = E(NP)/AMASS4 SECPAR(3) = MIN( 1.D0, W(NP) ) SECPAR(4) = ANGLEX SECPAR(5) = -Z(NP) SECPAR(6) = TIM(NP) SECPAR(7) = X(NP) SECPAR(8) = -Y(NP) SECPAR(11) = 1.D0 SECPAR(12) = 0.D0 CALL TSTACK ELSE IF ( LLONGI ) THEN C CUTTED ENERGY TO LONGITUDINAL ENERGY SUMS OF NUCLEON DLONG(LPCTE(NP),7) = DLONG(LPCTE(NP),7) * + (E(NP)-AMASS4) * 1.D-3 ENDIF ENDIF ELSE IF ( LLONGI ) THEN C CUTTED ENERGY TO LONGITUDINAL ENERGY SUMS OF NUCLEON DLONG(LPCTE(NP),7) = DLONG(LPCTE(NP),7) * + (E(NP)-AMASS4) * 1.D-3 ENDIF ENDIF C ELIMINATE NUCLEON FROM EGS-STACK NP = NP-1 ENDIF C END OF RECOIL NUCLEON TREATMENT CASE RETURN END *CMZ : 11/01/2002 09.25.09 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE PIGEN2 C----------------------------------------------------------------------- C PI(ON) GEN(ERATION) 2 (PIONS) C C THIS SUBROUT. DESCRIBES THE PHOTONUCLEAR REACTION C GAMMA + NUCLEON -----> PION + PION + NUCLEON C THIS SUBROUTINE IS CALLED FROM PIGEN. C C DESIGN : D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,EGSDEB. COMMON /EGSDEB/ JCLOCK,NCLOCK,FEGSDB INTEGER JCLOCK,NCLOCK LOGICAL FEGSDB *KEEP,ELABCT. COMMON /ELABCT/ ELCUT DOUBLE PRECISION ELCUT(4) *KEEP,LONGI. COMMON /LONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG, * SDLONG,SELONG,SPLONG,THSTEP,THSTPI, * LHEIGH,NSTEP,LLONGI,FLGFIT DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9), * APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9), * HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9), * SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI INTEGER LHEIGH,NSTEP LOGICAL LLONGI,FLGFIT *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEND. COMMON /PION/ PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR, * AMASNT DOUBLE PRECISION PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR, * AMASNT *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,REJECT. COMMON /REJECT/ AVNREJ,ALTMIN,ANEXP,THICKA,THICKD,CUTLN,EONCUT, * FNPRIM DOUBLE PRECISION AVNREJ(10),ALTMIN(10),ANEXP(10),THICKA(10), * THICKD(10),CUTLN,EONCUT LOGICAL FNPRIM *KEEP,STACKE. COMMON /STACKE/ E,TIM,U,V,W,X,Y,Z,DNEAR, * ZAP,WAP,WA, * IQ,IGEN,IR,IOBS,LPCTE,NP DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60), * X(60),Y(60),Z(60),DNEAR(60) * ,ZAP(60),WAP(60),WA(60) INTEGER IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP *KEND. COMMON /UPHIOT/ THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI DOUBLE PRECISION AMASS2,AMASS3,AMASS4,AMASS5,AM34SQ,AM35SQ,AM34I, * ANGLEX,AUXA,AUXB,AUX1,AUX2,AUX2A,AUX3,AUX4, * AUX4A,AUX5,AUX6,AUX7,AUX8,BETA,COSA,COSB, * COSFI3,COSPSI,COS3CM,COS4CM,COS5CM,DISCR, * ECM,ENUCL,E3CM,E4CM,E5CM,E3STAR,E5STAR, * GAMMA,HELP,PEIG,P3CM,P4CM,P5CM, * P3SQ,P4SQ,P5SQ,ROOT1,ROOT2,SINA,SINB, * SINFI3,SINPSI,SINT4,SINT4I,SINT5,SINT5I,SIN3CM, * PSI,PTRANS,PT3 INTEGER IHELP SAVE EXTERNAL PTRANS C----------------------------------------------------------------------- IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP) 1 FORMAT(' PIGEN2: NP=',I3,' IR=',I3,' IOBS=',I3) CALL AUSGB2 ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'PIGEN2: E=',E(NP)*.001D0 PEIG = E(NP) C NUMBERS AT THE VARIABLES MEAN : C 1 INCOMING GAMMA RAY C 2 HIT NUCLEON C 3 FIRST PRODUCED PION C 4 SECOND PRODUCED PION C 5 RECOILING NUCLEON CALL RMMAR(RD,2,2) C LOOK WHICH TYPE OF REACTION C 0.49923 IS THE FRACTION OF PROTONS IN AIR IF ( RD(1) .LE. 0.49923 ) THEN C HIT NUCLEON IS PROTON AMASS2 = AMASPR C BRANCHING FOR COLLISION WITH PROTON IF ( RD(2) .LE. 0.3 ) THEN C PI(0) + PI(0) + PROTON IQ(NP) = 7 IQ(NP+1) = 7 IQ(NP+2) = 14 ELSEIF ( RD(2) .LE. 0.6 ) THEN C PI(+) + PI(-) + PROTON IQ(NP) = 8 IQ(NP+1) = 9 IQ(NP+2) = 14 ELSE C PI(+) + PI(0) + NEUTRON IQ(NP) = 8 IQ(NP+1) = 7 IQ(NP+2) = 13 ENDIF ELSE C HIT NUCLEON IS NEUTRON C BRANCHING FOR COLLISION WITH NEUTRON AMASS2 = AMASNT IF ( RD(2) .LE. 0.3 ) THEN C PI(0) + PI(0) + NEUTRON IQ(NP) = 7 IQ(NP+1) = 7 IQ(NP+2) = 13 ELSEIF ( RD(2) .LE. 0.6 ) THEN C PI(+) + PI(-) + NEUTRON IQ(NP) = 8 IQ(NP+1) = 9 IQ(NP+2) = 13 ELSE C PI(-) + PI(0) + PROTON IQ(NP) = 9 IQ(NP+1) = 7 IQ(NP+2) = 14 ENDIF ENDIF C CALCULATE AUXILIARY PARAMETERS ECM = SQRT(AMASS2*(AMASS2+2.D0*PEIG)) C NOTE: THE ENERGIES IN EGS ARE IN MEV, IN CORSIKA IN GEV C HERE ALL ENERGIES ARE USED IN MEV AMASS3 = PAMA(IQ(NP))*1.D3 AMASS4 = PAMA(IQ(NP+1))*1.D3 AMASS5 = PAMA(IQ(NP+2))*1.D3 AUX1 = (AMASS3+AMASS4)**2 AUX2A = (ECM - AMASS5)**2 AUX2 = AUX2A-AUX1 AUX3 = (AMASS3+AMASS5)**2 AUX4A = (ECM - AMASS4)**2 AUX4 = AUX4A-AUX3 AUX5 = AMASS3**2-AMASS4**2 AUX6 = ECM**2-AMASS5**2 AUX7 = 0.5D0/ECM AUX8 = (ECM - AMASS3)**2 BETA = PEIG/(AMASS2+PEIG) GAMMA = 2.D0*(PEIG+AMASS2)*AUX7 230 CONTINUE CALL RMMAR(RD,2,2) C ARE INVARIANT MASS SQUARES INSIDE BOUNDARY OF DALITZ PLOT? AM34SQ = AUX2*RD(1)+AUX1 AM35SQ = AUX4*RD(2)+AUX3 AM34I = 0.5D0/SQRT(AM34SQ) E3STAR = (AUX5+AM34SQ)*AM34I E5STAR = (AUX6-AM34SQ)*AM34I ROOT1 = SQRT(MAX( 0.D0, E3STAR**2-AMASS3**2 )) ROOT2 = SQRT(MAX( 0.D0, E5STAR**2-AMASS5**2 )) C REJECT RANDOM NUMBERS, IF NOT INSIDE KINEMATIC BOUNDARY DISCR = AM35SQ-(E3STAR+E5STAR)**2 IF ( DISCR .GT. -((ROOT1-ROOT2)**2) ) GOTO 230 IF ( DISCR .LT. -((ROOT1+ROOT2)**2) ) GOTO 230 C E3CM,E4CM,E5CM ARE ENERGIES IN C.M. SYSTEM E4CM = (ECM**2+AMASS4**2-AM35SQ)*AUX7 E5CM = (ECM**2+AMASS5**2-AM34SQ)*AUX7 C NOW TAKE PION WITH HIGHEST ENERGY AS PARTICLE 3 E3CM = ECM-E4CM-E5CM IF ( E4CM .GT. E3CM ) THEN C INTERCHANGE PARTICLE 3 AND 4 HELP = E3CM E3CM = E4CM E4CM = HELP HELP = AMASS3 AMASS3 = AMASS4 AMASS4 = HELP IHELP = IQ(NP) IQ(NP) = IQ(NP+1) IQ(NP+1) = IHELP ENDIF C P3CM,P4CM,P5CM ARE MOMENTA IN C.M. SYSTEM C P3SQ,P4SQ,P5SQ ARE SQUARED MOMENTA IN C.M. SYSTEM P3SQ = E3CM**2-AMASS3**2 P3CM = SQRT(MAX( 0.D0, P3SQ )) P4SQ = E4CM**2-AMASS4**2 P4CM = SQRT(MAX( 0.D0, P4SQ )) P5SQ = E5CM**2-AMASS5**2 P5CM = SQRT(MAX( 0.D0, P5SQ )) COSA = (P5SQ-P3SQ-P4SQ)/(2.D0*P3CM*P4CM) SINA =-SQRT(MAX( 0.D0, 1.D0-COSA**2 )) COSB = (P4SQ-P3SQ-P5SQ)/(2.D0*P3CM*P5CM) SINB = SQRT(MAX( 0.D0, 1.D0-COSB**2 )) C NOW SELECT THE THREE INDEPENDENT ANGLES IN C.M. SYSTEM PT3 = 1.D3*PTRANS() SIN3CM = MIN( 1.D0, PT3/P3CM ) COS3CM = SQRT(1.D0-SIN3CM**2) CALL RMMAR(RD,1,2) PSI = TWOPI*RD(1) SINPSI = SIN(PSI) COSPSI = COS(PSI) C THIRD INDEPENDENT ANGLE PHI IS CHOOSEN LATER IN SUBR. UPHI C NOW MAKE LORENTZ TRANSFORMATION FOR PARTICLE 3 (PION) E(NP) = GAMMA*(E3CM+BETA*P3CM*COS3CM) C COSTHE AND SINTHE ARE ANGLES IN LAB SYSTEM FOR PARTICLE 3 (PION) COSTHE = MIN((BETA*E3CM+P3CM*COS3CM)*GAMMA/SQRT(MAX(0.D0,E(NP)**2 * -AMASS3**2)),1.D0) SINTHE = SQRT(MAX( 0.D0, 1.D0-COSTHE**2 )) C SINPHI AND COSPHI ARE NOW SET IN SUBR. UPHI CALL UPHI(2,1) SINFI3 = SINPHI COSFI3 = COSPHI C NOW MAKE LORENTZ TRANSFORMATION FOR PARTICLE 4 = PION COS4CM = COS3CM*COSA-SIN3CM*COSPSI*SINA NP = NP+1 E(NP) = GAMMA*(E4CM+BETA*P4CM*COS4CM) SINT4 = SQRT(MAX( 0.D0, 1.D0-COS4CM**2 )) IF ( SINT4 .NE. 0.D0 ) THEN SINT4I = 1.D0/SINT4 AUXA = COS3CM*COSPSI*SINA+SIN3CM*COSA C COSPHI AND SINPHI ARE IN LAB SYSTEM FOR PARTICLE 4 (PION) COSPHI = (COSFI3*AUXA-SINFI3*SINPSI*SINA)*SINT4I SINPHI = (SINFI3*AUXA+COSFI3*SINPSI*SINA)*SINT4I ELSE COSPHI = 0.D0 SINPHI = 1.D0 ENDIF C COSTHE AND SINTHE ARE IN LAB SYSTEM FOR PARTICLE 4 (PION) COSTHE = MIN((BETA*E4CM+P4CM*COS4CM)*GAMMA/SQRT(MAX(0.D0,E(NP)**2 * -AMASS4**2)),1.D0) SINTHE = SQRT(MAX( 0.0D0, 1.D0-COSTHE**2 )) CALL UPHI(3,2) C NOW MAKE LORENTZ TRANSFORMATION FOR PARTICLE 5 = RECOIL NUCLEON COS5CM = COS3CM*COSB-SIN3CM*COSPSI*SINB ENUCL = GAMMA*(E5CM+BETA*P5CM*COS5CM) NP = NP+1 E(NP) = ENUCL SINT5 = SQRT(MAX( 0.D0, 1.D0-COS5CM**2 )) IF ( SINT5 .NE. 0.D0 ) THEN SINT5I = 1.D0/SINT5 AUXB = COS3CM*COSPSI*SINB+SIN3CM*COSB C COSPHI AND SINPHI ARE IN LAB SYSTEM FOR PART. 5 (NUCLEON) COSPHI = (COSFI3*AUXB-SINFI3*SINPSI*SINB)*SINT5I SINPHI = (SINFI3*AUXB+COSFI3*SINPSI*SINB)*SINT5I ELSE COSPHI = 0.D0 SINPHI = 1.D0 ENDIF C COSTHE AND SINTHE ARE IN LAB SYSTEM FOR PARTICLE 5 (NUCLEON) COSTHE=MIN((BETA*E5CM+P5CM*COS5CM)*GAMMA/SQRT(ENUCL**2-AMASS5**2) * , 1.D0) SINTHE = SQRT(MAX( 0.0D0, 1.D0-COSTHE**2 )) CALL UPHI(3,2) IF ( E(NP)-AMASS5 .GT. ELCUT(1)*1000.D0 ) THEN IF ( W(NP) .GT. C(29) ) THEN C ANGLE WITH RESPECT TO X AXIS IF ( U(NP) .NE. 0.D0 .OR. V(NP) .NE. 0.D0 ) THEN ANGLEX = -ATAN2(V(NP),U(NP)) ELSE ANGLEX = 0.D0 ENDIF C ADD NUCLEON TO CORSIKA STACK SECPAR(1) = IQ(NP) SECPAR(2) = E(NP)/AMASS5 SECPAR(3) = MIN( 1.D0, W(NP) ) SECPAR(4) = ANGLEX SECPAR(5) =-Z(NP) SECPAR(6) = TIM(NP) SECPAR(7) = X(NP) SECPAR(8) =-Y(NP) SECPAR(11) = 1.D0 SECPAR(12) = 0.D0 CALL TSTACK ELSE IF ( LLONGI ) THEN C CUTTED ENERGY TO LONGITUDINAL ENERGY DLONG(LPCTE(NP),7) = DLONG(LPCTE(NP),7) * + (E(NP)-AMASS5) * 1.D-3 ENDIF ENDIF ELSE IF ( LLONGI ) THEN C CUTTED ENERGY TO LONGITUDINAL ENERGY DLONG(LPCTE(NP),7) = DLONG(LPCTE(NP),7) * + (E(NP)-AMASS5) * 1.D-3 ENDIF ENDIF C ELIMINATE NUCLEON FROM EGS-STACK NP = NP-1 C END OF RECOIL NUCLEON TREATMENT CASE C STORE SECOND PION TO CORSIKA STACK CALL PIPROP C STORE FIRST PION TO CORSIKA STACK CALL PIPROP RETURN END *CMZ : 11/01/2002 09.25.09 by D. HECK IK FZK KARLSRUHE *-- Author : D. HECK IK FZK KARLSRUHE 01/09/2001 C======================================================================= SUBROUTINE PIPROP C----------------------------------------------------------------------- C PI(ON) PROP(AGATION) C C MOVES PIONS FROM EGS-STACK TO CORSIKA-STACK. C THIS SUBROUTINE IS CALLED FROM PIGEN2. C C DESIGN : D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,EGSDEB. COMMON /EGSDEB/ JCLOCK,NCLOCK,FEGSDB INTEGER JCLOCK,NCLOCK LOGICAL FEGSDB *KEEP,ELABCT. COMMON /ELABCT/ ELCUT DOUBLE PRECISION ELCUT(4) *KEEP,LONGI. COMMON /LONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG, * SDLONG,SELONG,SPLONG,THSTEP,THSTPI, * LHEIGH,NSTEP,LLONGI,FLGFIT DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9), * APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9), * HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9), * SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI INTEGER LHEIGH,NSTEP LOGICAL LLONGI,FLGFIT *KEND. COMMON /MUON/ PRRMMU,RMMUT2 DOUBLE PRECISION PRRMMU,RMMUT2 *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEND. COMMON /PION/ PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR, * AMASNT DOUBLE PRECISION PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR, * AMASNT *KEEP,POLAR. COMMON /POLAR/ POLART,POLARF DOUBLE PRECISION POLART,POLARF *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,STACKE. COMMON /STACKE/ E,TIM,U,V,W,X,Y,Z,DNEAR, * ZAP,WAP,WA, * IQ,IGEN,IR,IOBS,LPCTE,NP DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60), * X(60),Y(60),Z(60),DNEAR(60) * ,ZAP(60),WAP(60),WA(60) INTEGER IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP *KEND. COMMON /UPHIOT/ THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI DOUBLE PRECISION AMASS,ANGLEX,CUT SAVE C----------------------------------------------------------------------- IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP) 1 FORMAT(' PIPROP: NP=',I3,' IR=',I3,' IOBS=',I3) CALL AUSGB2 ENDIF C SET MASS AND CUT PARAMETER OF PARTICLE UNDER CONSIDERATION IF ( IQ(NP) .EQ. 7 ) THEN AMASS = PI0MAS CUT = ELCUT(1)*1000.D0 POLART = 1.D0 POLARF = 0.D0 ELSE AMASS = PICMAS CUT = ELCUT(1)*1000.D0 POLART = 1.D0 POLARF = 0.D0 ENDIF C USE PARTICLE ONLY IF INSIDE ACCEPTANCE CONE IF ( W(NP) .GT. C(29) ) THEN C ANGLE WITH RESPECT TO X AXIS IF ( U(NP) .NE. 0.D0 .OR. V(NP) .NE. 0.D0 ) THEN ANGLEX = -ATAN2(V(NP),U(NP)) ELSE ANGLEX = 0.D0 ENDIF C FILL PION COORDINATES INTO CORSIKA-STACK SECPAR(1) = IQ(NP) SECPAR(2) = E(NP)/AMASS SECPAR(3) = MIN( 1.D0, W(NP) ) SECPAR(4) = ANGLEX SECPAR(5) = -Z(NP) SECPAR(6) = TIM(NP) SECPAR(7) = X(NP) SECPAR(8) = -Y(NP) SECPAR(9) = IGEN(NP) SECPAR(10) = -Z(NP) SECPAR(11) = POLART SECPAR(12) = POLARF SECPAR(14) = -ZAP(NP) SECPAR(15) = WAP(NP) SECPAR(16) = WA(NP) C ADD PION TO CORSIKA-STACK CALL TSTACK ELSE IF ( LLONGI ) THEN C CUTTED ENERGY TO LONGITUDINAL ENERGY SUMS OF HADRONS DLONG(LPCTE(NP),7) = DLONG(LPCTE(NP),7)+E(NP)*1.D-3 ENDIF ENDIF C ELIMINATE PION FROM EGS-STACK NP = NP-1 RETURN END *CMZ : 11/01/2002 09.25.09 by D. HECK IK FZK KARLSRUHE *-- Author : D. HECK IK3 FZK KARLSRUHE 28/06/99 C======================================================================= SUBROUTINE RHOGEN C----------------------------------------------------------------------- C RHO GEN(ERATION BY PHOTONUCLEAR REACTION) C C THIS SUBROUT. DESCRIBES THE PHOTONUCLEAR REACTION C GAMMA + NUCLEON -----> RHO + NUCLEON (90%) C GAMMA + NUCLEON -----> OMEGA + NUCLEON (10%) C HIGHER MASS VECTOR MESONS ARE OMITTED. THE RATIO FOR PRODUCTION C OF RHO AND OMEGA IS ASSUMED TO BE 9:1 C LITERATURE: A. DONNACHIE & G. SHAW, ELECTROMAGNETIC INTERACTIONS OF C HADRONS (PLENUM PRESS, NEW YORK, 1978) C A. MUECKE ET AL., SOPHIA: MONTE CARLO SIMULATIONS OF C PHOTOHADRONIC PROCESSES IN ASTROPHYSICS, C COMPUT. PHYS. COMMUN. (1999) IN PRESS C THIS SUBROUTINE IS CALLED FROM PIGEN. C C DESIGN : D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,EGSDEB. COMMON /EGSDEB/ JCLOCK,NCLOCK,FEGSDB INTEGER JCLOCK,NCLOCK LOGICAL FEGSDB *KEEP,ELABCT. COMMON /ELABCT/ ELCUT DOUBLE PRECISION ELCUT(4) *KEEP,LONGI. COMMON /LONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG, * SDLONG,SELONG,SPLONG,THSTEP,THSTPI, * LHEIGH,NSTEP,LLONGI,FLGFIT DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9), * APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9), * HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9), * SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI INTEGER LHEIGH,NSTEP LOGICAL LLONGI,FLGFIT *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEND. COMMON /PION/ PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR, * AMASNT DOUBLE PRECISION PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR, * AMASNT *KEEP,POLAR. COMMON /POLAR/ POLART,POLARF DOUBLE PRECISION POLART,POLARF *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RESON. COMMON /RESON/ RDRES,RESRAN,IRESPAR REAL RDRES(2),RESRAN(30000) INTEGER IRESPAR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,REJECT. COMMON /REJECT/ AVNREJ,ALTMIN,ANEXP,THICKA,THICKD,CUTLN,EONCUT, * FNPRIM DOUBLE PRECISION AVNREJ(10),ALTMIN(10),ANEXP(10),THICKA(10), * THICKD(10),CUTLN,EONCUT LOGICAL FNPRIM *KEEP,STACKE. COMMON /STACKE/ E,TIM,U,V,W,X,Y,Z,DNEAR, * ZAP,WAP,WA, * IQ,IGEN,IR,IOBS,LPCTE,NP DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60), * X(60),Y(60),Z(60),DNEAR(60) * ,ZAP(60),WAP(60),WA(60) INTEGER IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP *KEND. COMMON /UPHIOT/ THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI DOUBLE PRECISION AMASS2,AMAS2I,AMAS2S,AMASS3,AMASS4,AMOM3,AMOM4, * ANGLEX,AUX3,BDIFF,BETA,BRATIO, * ED,ENUCL,ESQ,ETH,E3CM,E2,E4, * GAMMA,G3,PCM2,PCM4,PEIG,PEOM,PLNG3,P3CM, * T,TMAX,TMIN,W0,W0I,W0S,W0SI SAVE C----------------------------------------------------------------------- IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP) 1 FORMAT(' RHOGEN: NP=',I3,' IR=',I3,' IOBS=',I3) CALL AUSGB2 ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'RHOGEN: E=',E(NP)*.001D0 PEIG = E(NP) C NUMBERS AT THE VARIABLES MEAN : C 1 INCOMING GAMMA RAY C 2 HIT NUCLEON C 3 PRODUCED MESON C 4 RECOILING NUCLEON C LOOK WHICH TYPE OF REACTION CALL RMMAR(RD,3,2) C 0.49923 IS THE FRACTION OF PROTONS IN AIR IF ( RD(1) .LE. 0.49923 ) THEN C HIT NUCLEON IS PROTON IQ(NP+1) = 14 AMASS2 = AMASPR ELSE C HIT NUCLEON IS NEUTRON IQ(NP+1) = 13 AMASS2 = AMASNT ENDIF AMAS2I = 1.D0/AMASS2 AMAS2S = AMASS2**2 IF ( RD(2) .LT. 0.1 ) THEN C PRESENTLY WE ARE ONLY TAKING INTO ACCOUNT RHO AND OMEGA MESON. C PHI MESON IS NEGLECTED C 10% CHANCE FOR OMEGA MESON IQ(NP) = 50 ELSE C GENERATED MESON IS RHO(0) IQ(NP) = 51 ENDIF C NOTE: THE ENERGIES IN EGS ARE IN MEV, IN CORSIKA IN GEV AMASS3 = PAMA(IQ(NP))*1.D3 AMASS4 = PAMA(IQ(NP+1))*1.D3 C TOTAL LABORATORY ENERGY AND ITS INVERSE W0 = PEIG+AMASS2 W0I = 1.D0/W0 C TOTAL.C.M. ENERGY AND INVERSE OF TOTAL C.M.ENERGY W0S = SQRT(AMASS2*(AMASS2+2.D0*PEIG)) W0SI = 1.D0/W0S C THRESHOLD ENERGY ETH = 0.5D0*((AMASS3+AMASS4)**2-AMAS2S)*AMAS2I C BETA, GAMMA, ESQ, BRATIO, G3 ARE AUXILIARY QUANTITIES BETA = PEIG*W0I GAMMA = W0*W0SI ED = 0.5D0*((AMASS3-AMASS4)**2-AMAS2S)*AMAS2I ESQ = SQRT((PEIG-ETH)*(PEIG-ED)) BRATIO = PEIG/ESQ G3 = W0I*(PEIG-ETH+AMASS3*AMAS2I*(AMASS3+AMASS4)) C C.M. ENERGY OF MESON E3CM = G3*AMASS2*GAMMA C C.M. MESON MOMENTUM P3CM = AMASS2*W0SI*ESQ C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C THE FOLLOWING SELECTION OF TRANSFERRED MOMENTUM IS IN ANALOGY WITH C PROGRAM SOPHIA (SUBROUT. GAMMA_H OF R. ENGEL). ANGULAR DISTRIBUTION C IS ACCORDING D(SIGMA)/DT = EXP( B_DIFFRACTIVE * T) C WITH B_DIFFRACTIVE = 8 GEV^-2 = 8*10-6 [MEV^-2] BDIFF = 8.D-6 C AUXILIAR QUANTITIES AUX3, E2, E4, PCM2, PCM4 AUX3 = 0.5D0 * AMASS3**2 * W0SI E2 = 0.5D0 * (W0S + AMAS2S * W0SI) E4 = E2 - AUX3 PCM2 = SQRT(E2**2 - AMAS2S) PCM4 = SQRT(E4**2 - AMAS2S) C BOUNDARIES FOR MOMENTUM TRANSFER TMIN AND TMAX TMIN = AUX3**2 - (PCM2 + PCM4)**2 TMAX = AUX3**2 - (PCM2 - PCM4)**2 IF (FEGSDB) WRITE(MDEBUG,*) 'RHOGEN: E2,E4,PCM2,PCM4,TMIN,TMAX=', * SNGL(E2*0.001),SNGL(E4*0.001),SNGL(PCM2*0.001), * SNGL(PCM4*0.001),SNGL(TMIN*0.001),SNGL(TMAX*0.001) C SELECT THE MOMENTUM TRANSFER T BY CHANCE T = RD(3)*(EXP(BDIFF*TMAX)-EXP(BDIFF*TMIN))+EXP(BDIFF*TMIN) T = LOG(T) / BDIFF C KINEMATIC CALCULATION OF LONGITUDINAL MOMENTUM PLNG3 = (E2*E4 + 0.5D0*T - AMAS2S) / PCM2 PLNG3 = ABS(PLNG3) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C PRECISE ENERGY OUTGOING MESON = PEOM PEOM = GAMMA*(E3CM+BETA*PLNG3) IF ( FEGSDB ) WRITE(MDEBUG,*) 'RHOGEN: RD,T,PLNG3,PEOM=', * RD(3),SNGL(T*0.001),SNGL(PLNG3*0.001),SNGL(PEOM*0.001) C ENERGY OF OUTGOING MESON IN STACK POSITION NP E(NP) = PEOM C MOMENTUM OF OUTGOING MESON = AMOM3 C COSTHE AND SINTHE ARE ANGLES IN LAB SYSTEM FOR PARTICLE 3 (MESON) C SEE SLAC-265, P. 52 AMOM3 = SQRT(MAX( 0.D0, PEOM**2-AMASS3**2 )) IF ( AMOM3 .GT. 0.D0 ) THEN COSTHE = (AMASS4**2 - AMAS2S - AMASS3**2 + 2.D0*PEOM*W0 * - 2.D0*PEIG*AMASS2)/(2.D0*PEIG*AMOM3) ELSE COSTHE = 1.D0 ENDIF SINTHE = SQRT(MAX( 0.0D0, 1.D0-COSTHE**2 )) CALL UPHI(2,1) C TOTAL ENERGY OF RECOILING NUCLEON ( = ENUCL) ENUCL = W0-PEOM NP = NP+1 E(NP) = ENUCL IF ( ENUCL-AMASS4 .GT. ELCUT(1)*1000.D0 ) THEN C RECOIL ENERGY IS TOO LARGE, MUST TREAT THE NUCLEON C MOMENTUM OF RECOIL NUCLEON AMOM4 = SQRT(ENUCL**2-AMASS4**2) C COSTHE AND SINTHE ARE ANGLES IN LAB SYSTEM FOR RECOIL NUCLEON C SEE SLAC-265, P. 52 COSTHE = (AMASS3**2 - AMAS2S - AMASS4**2 + 2.D0*ENUCL*W0 * - 2.D0*PEIG*AMASS2)/(2.D0*PEIG*AMOM4) SINTHE = -SQRT(MAX( 0.0D0, 1.D0-COSTHE**2 )) CALL UPHI(3,2) IF ( W(NP) .GT. C(29) ) THEN C ANGLE WITH RESPECT TO X AXIS IF ( U(NP) .NE. 0.D0 .OR. V(NP) .NE. 0.D0 ) THEN ANGLEX = -ATAN2(V(NP),U(NP)) ELSE ANGLEX = 0.D0 ENDIF C ADD NUCLEON TO CORSIKA STACK SECPAR(1) = IQ(NP) SECPAR(2) = E(NP)/AMASS4 SECPAR(3) = MIN( 1.D0, W(NP) ) SECPAR(4) = ANGLEX SECPAR(5) = -Z(NP) SECPAR(6) = TIM(NP) SECPAR(7) = X(NP) SECPAR(8) = -Y(NP) SECPAR(11) = 1.D0 SECPAR(12) = 0.D0 CALL TSTACK ELSE IF ( LLONGI ) THEN C CUTTED ENERGY TO LONGITUDINAL ENERGY SUMS TO NUCLEON DLONG(LPCTE(NP),7) = DLONG(LPCTE(NP),7) * + (E(NP)-AMASS4) * 1.D-3 ENDIF ENDIF C ELIMINATE NUCLEON FROM EGS-STACK NP = NP-1 IF ( NP .LE. 0 ) RETURN ELSE IF ( LLONGI ) THEN C CUTTED ENERGY TO LONGITUDINAL ENERGY SUMS TO NUCLEON DLONG(LPCTE(NP),7) = DLONG(LPCTE(NP),7) * + (E(NP)-AMASS4) * 1.D-3 ENDIF C ELIMINATE NUCLEON FROM EGS-STACK NP = NP-1 C END OF RECOIL NUCLEON TREATMENT CASE ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF ( IQ(NP) .GE. 50 ) THEN C NOW TREAT THE VECTOR MESON IF ( W(NP) .GT. C(29) ) THEN C ANGLE WITH RESPECT TO X AXIS IF ( U(NP) .NE. 0.D0 .OR. V(NP) .NE. 0.D0 ) THEN ANGLEX = -ATAN2(V(NP),U(NP)) ELSE ANGLEX = 0.D0 ENDIF IF ( IQ(NP) .EQ. 50 ) THEN C ADD OMEGA MESON TO CORSIKA-STACK (TO BE TREATED IN RESDEC) SECPAR(1) = IQ(NP) SECPAR(2) = E(NP)/AMASS3 SECPAR(3) = MIN( 1.D0, W(NP) ) SECPAR(4) = ANGLEX SECPAR(5) = -Z(NP) SECPAR(6) = TIM(NP) SECPAR(7) = X(NP) SECPAR(8) = -Y(NP) SECPAR(9) = IGEN(NP) SECPAR(10) = -Z(NP) SECPAR(11) = POLART SECPAR(12) = POLARF SECPAR(14) = -ZAP(NP) SECPAR(15) = WAP(NP) SECPAR(16) = WA(NP) IRESPAR = IRESPAR + 1 IF ( IRESPAR .GE. 30000 ) THEN WRITE(MONIOU,*) * 'RHOGEN: STACK OF RESDEC RANDOM NUMBERS FULL' IRESPAR = 29999 ENDIF C STORE DUMMY RANDOM NUMBER FOR TREATMENT OF OMEGA0 IN RESDEC RESRAN(IRESPAR) = 0.5 CALL TSTACK C FINALLY OMEGA WILL BE TREATED IN OMEGDC (OMEGA DECAY ROUTINE) C WITH CORRECT ANGULAR DISTRIBUTION * CALL OMEGDC ELSEIF ( IQ(NP) .EQ. 51 ) THEN C FILL VECTOR MESON COORDINATES INTO CORSIKA-STACK C (CURPAR HAS BEEN SAVED IN PIGEN) ITYPE = IQ(NP) CURPAR(1) = IQ(NP) CURPAR(2) = E(NP)/AMASS3 CURPAR(3) = MIN( 1.D0, W(NP) ) CURPAR(4) = ANGLEX CURPAR(5) = -Z(NP) CURPAR(6) = TIM(NP) CURPAR(7) = X(NP) CURPAR(8) = -Y(NP) CURPAR(9) = IGEN(NP) CURPAR(10) = -Z(NP) CURPAR(11) = POLART CURPAR(12) = POLARF CURPAR(14) = -ZAP(NP) CURPAR(15) = WAP(NP) CURPAR(16) = WA(NP) C RHO(0) DECAYS WITH DIPOLE CHARACTERISTIC IN RHO0DC CALL RHO0DC ELSE WRITE(MONIOU,*) 'RHOGEN: WRONG PARTICLE CODE=',IQ(NP) STOP ENDIF ELSE IF ( LLONGI ) THEN C CUTTED ENERGY TO LONGITUDINAL ENERGY SUMS OF HADRONS DLONG(LPCTE(NP),7) = DLONG(LPCTE(NP),7)+E(NP)*1.D-3 ENDIF ENDIF C ELIMINATE VECTOR MESON FROM EGS-STACK NP = NP-1 ENDIF RETURN END *CMZ : 18/09/2001 13.38.55 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE SHOWER C----------------------------------------------------------------------- C SHOWER (STEERING) C C THIS ROUTINE LOOKS, WHAT IS ON TOP OF EGS-STACK, AND CALLS THE C APPROPRIATE ROUTINE TO TREAT THIS PARTICLE. C THIS SUBROUTINE IS CALLED FROM EGS4. C C DESIGN : D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,EGSDEB. COMMON /EGSDEB/ JCLOCK,NCLOCK,FEGSDB INTEGER JCLOCK,NCLOCK LOGICAL FEGSDB *KEND. COMMON /MISC/ DUNIT,RHOR,KMPI,KMPO,NOSCAT,MED,IRAYLR DOUBLE PRECISION DUNIT,RHOR(6) INTEGER KMPI,KMPO,NOSCAT,MED(6),IRAYLR(6) *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,STACKE. COMMON /STACKE/ E,TIM,U,V,W,X,Y,Z,DNEAR, * ZAP,WAP,WA, * IQ,IGEN,IR,IOBS,LPCTE,NP DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60), * X(60),Y(60),Z(60),DNEAR(60) * ,ZAP(60),WAP(60),WA(60) INTEGER IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP *KEND. INTEGER IRCODE SAVE C----------------------------------------------------------------------- C TAKE FIRST PARTICLE IN STACK NP = 1 C DECIDE WHAT IS ON TOP OF STACK 261 CONTINUE IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP),IQ(NP) 1 FORMAT(' SHOWER: NP=',I3,' IR=',I3,' IOBS=',I3,' IQ=',I3) CALL AUSGB2 ENDIF C JUMP TO PARTICLE IN QUESTION. THE FOLLOWING PARTICLE IDENTIFICATION C IS MADE BY THE VALUE OF IQ(NP) (ACCORDING TO CORSIKA) C IQ = 1 PHOTON C = 2 POSITRON E (+) C = 3 ELECTRON E (-) C = 5 POSITIVE MUON (+) C = 6 NEGATIVE MUON (-) C = 7 NEUTRAL PION (0) C = 8 POSITIVE PION (+) C = 9 NEGATIVE PION (-) C = OTHER VALUE, JUMP TO ERROR MESSAGE GOTO (270,280,280,290, 300,300,300,300,300) (IQ(NP)) C IQ OUT OF RANGE? 290 WRITE(KMPO,320) IQ(NP) 320 FORMAT(' SHOWER: PARTICLE TYPE ',I5,' NOT IDENTIFIED') CALL AUSGB2 NP = NP-1 GOTO 262 C PARTICLE IS MUON OR PION 300 CALL MPPROP GOTO 262 C PARTICLE IS PHOTON 270 CALL PHOTON(IRCODE) C PHOTON DISCARDED ? IF ( IRCODE .EQ. 2 ) GOTO 262 IF ( IQ(NP) .LT. 2 .OR. IQ(NP) .GT. 3 ) GOTO 261 C PARTICLE IS ELECTRON OR POSITRON 280 CALL ELECTR(IRCODE) C ELECTRON DISCARDED ? IF ( IRCODE .EQ. 2 ) GOTO 262 IF ( IQ(NP) .EQ. 1 ) GOTO 270 C LOOP BACK UP TO PARTICLE SELECTION GOTO 261 262 CONTINUE C CHECK TO SEE IF ANYTHING LEFT ON STACK IF ( NP .GT. 0 ) GOTO 261 C NOTHING ON STACK, SO JUMP OUT OF LOOP RETURN END *CMZ : 18/12/2001 10.00.42 by D. HECK IK FZK KARLSRUHE *-- Author : STANFORD LINEAR ACCELERATOR CENTER C======================================================================= C STANFORD LINEAR ACCELERATOR CENTER SUBROUTINE UPHI(IENTRY,LVL) C VERSION 4.00 -- 26 JAN 1986/1900 C----------------------------------------------------------------------- C U(NIFORM) PHI (DISTRIBUTION) C C SET COORDINATES FOR NEW PARTICLE OR RESET DIRECTION COSINES OF C OLD ONE. GENERATE RANDOM AZIMUTH SELECTION AND REPLACE THE C DIRECTION COSINES WITH THEIR NEW VALUES. C THIS SUBROUTINE IS CALLED FROM ANNIH, BHABHA, BREMS, COMPT, ELECTR, C MOLLER, MUPAIR, PAIR, PHOTON, PIGEN1, PIGEN2, RHOGEN. C ARGUMENTS: C IENTRY = 1 THETA IS KNOWN, DETERMINE SINTHE,COSTHE AND PHI C 2 SINTHE AND COSTHE ARE KNOWN, SELECT PHI AT RANDOM C 3 SINTHE, COSTHE NAD PHI ARE KNOWN C LVL = 1 OLD PARTICLE, SAVE ITS DIRECTION AND ADJUST IT C 2 NEW PARTICLE. ADJUST DIRECTION USING SAVED A,B,C C 3 BREMSSTRAHLUNG GAMMA. SAVE ELECTRON DIRECTION AND ADJUST C GAMMA DIRECTION C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,EPCONT. COMMON /EPCONT/ EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP, * RHOFAC,EOLD,ENEW,EKE,ELKE,BETA2,GLE,TSCAT, * IDISC,IROLD,IRNEW DOUBLE PRECISION EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP, * RHOFAC,EOLD,ENEW, EKE,ELKE,BETA2,GLE,TSCAT INTEGER IDISC,IROLD,IRNEW *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,STACKE. COMMON /STACKE/ E,TIM,U,V,W,X,Y,Z,DNEAR, * ZAP,WAP,WA, * IQ,IGEN,IR,IOBS,LPCTE,NP DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60), * X(60),Y(60),Z(60),DNEAR(60) * ,ZAP(60),WAP(60),WA(60) INTEGER IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP *KEND. COMMON /UPHIOT/ THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI DOUBLE PRECISION A,B,C,COSDEL,PHI,SINDEL,SINPSI,SINPS2,US,VS INTEGER IENTRY,LVL SAVE C----------------------------------------------------------------------- IF ( IENTRY .EQ. 2 ) GOTO 1070 IF ( IENTRY .EQ. 3 ) GOTO 1080 1090 CONTINUE SINTHE = SIN(THETA) COSTHE = COS(THETA) C USE THE FOLLOWING ENTRY IF SINTHE AND COSTHE ARE ALREADY KNOWN. C SELECT PHI UNIFORMLY OVER THE INTERVAL (0,TWO PI). 1070 CALL RMMAR(RD,1,2) PHI = RD(1)*TWOPI SINPHI = SIN(PHI) COSPHI = COS(PHI) C USE THE FOLLOWING ENTRY FOR THE SECOND OF TWO PARTICLES WHEN WE C KNOW TWO PARTICLES HAVE A RELATIONSHIP IN THEIR CORRECTIONS. C NOTE: SINTHE AND COSTHE CAN BE CHANGED OUTSIDE THROUGH COMMON. C LVL IS A PARAMETER TELLING WHICH PARTICLES TO WORK WITH. C THETA (SINTHE AND COSTHE) ARE ALWAYS RELATIVE TO THE DIRECTION C OF THE INCIDENT PARTICLE BEFORE ITS DIRECTION WAS ADJUSTED. C THUS WHEN TWO PARTICLES NEED TO HAVE THEIR DIRECTIONS COMPUTED, C THE ORIGINAL INCIDENT DIRECTION IS SAVED IN THE VARIABLE A,B,C C SO THAT IT CAN BE USED ON BOTH CALLS. C LVL=1 -- OLD PARTICLE, SAVE ITS DIRECTION AND ADJUST IT C LVL=2 -- NEW PARTICLE. ADJUST DIRECTION USING SAVED A,B,C C LVL=3 -- BREMSSTRAHLUNG GAMMA. SAVE ELECTRON DIRECTION (NEXT C TO TOP OF STACK), AND THEN ADJUST GAMMA DIRECTION. 1080 IF ( LVL .EQ. 2 ) GOTO 1100 IF ( LVL .EQ. 3 ) GOTO 1110 1120 A = U(NP) B = V(NP) C = W(NP) GOTO 1130 1110 A = U(NP-1) B = V(NP-1) C = W(NP-1) C SEE H.H. NAGEL DISSERTATION FOR COORDINATE SYSTEM DESCRIPTION. C A ROTATION IS PERFORMED TO TRANSFORM DIRECTION COSINES OF THE C PARTICLE BACK TO THE PHYSICAL FRAME (FROM THE TRANSPORT FRAME) 1100 X(NP) = X(NP-1) Y(NP) = Y(NP-1) Z(NP) = Z(NP-1) LPCTE(NP) = LPCTE(NP-1) IR(NP) = IR(NP-1) DNEAR(NP) = DNEAR(NP-1) TIM(NP) = TIM(NP-1) IGEN(NP) = IGEN(NP-1) IOBS(NP) = IOBS(NP-1) ZAP(NP) = ZAP(NP-1) WAP(NP) = WAP(NP-1) WA(NP) = WA(NP-1) 1130 SINPS2 = A*A+B*B C SMALL POLAR ANGLE CASE, NO ROTATION IS NEEDED IF ( SINPS2 .LT. 1.D-20 ) THEN U(NP) = SINTHE*COSPHI V(NP) = SINTHE*SINPHI W(NP) = C*COSTHE ELSE C LARGE POLAR ANGLE CASE SINPSI = SQRT(SINPS2) US = SINTHE*COSPHI VS = SINTHE*SINPHI SINDEL = B*(1.D0/SINPSI) COSDEL = A*(1.D0/SINPSI) U(NP) = C*COSDEL*US-SINDEL*VS+A*COSTHE V(NP) = C*SINDEL*US+COSDEL*VS+B*COSTHE W(NP) = (-SINPSI)*US+C*COSTHE ENDIF RETURN END *CMZ : 28/02/2002 10.19.53 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE AGE( R,S ) C----------------------------------------------------------------------- C AGE C C CALCULATES LONGITUDINAL AGE PARAMETER C ORIGINALLY DEVELOPED BY: J. KEMPA, UNIVERSITY OF LODZ, POLAND C THIS SUBROUTINE IS CALLED FROM AVAGE. C ARGUMENTS: C R = AVERAGED AGE PARAMETER C S = LONGITUDINAL AGE PARAMETER OF TOTAL SHOWER C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DOUBLE PRECISION A,B,C,R,R1,R2,R3,R4,R5,S SAVE DATA R1 / 1.9096D-02 /, R2 / 1.7964D-01 /, R3 / 5.3644D-01 /, * R4 / 1.0332D0 /, R5 / 1.4856D0 / C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'AGE : R=',SNGL(R) R = MAX( R, R1 ) R = MIN( R, R5 ) IF ( R .LT. R2 ) THEN A = 3.109121D-1 B = 2.146465D-1 C = -5.451040D-3 ELSEIF ( R .LT. R3 ) THEN A = 3.666449D-1 B = 1.639189D-1 C = 5.970362D-3 ELSEIF ( R .LT. R4 ) THEN A = 1.459842D-1 B = 6.317027D-1 C = -2.420241D-1 ELSEIF ( R .LE. R5 ) THEN A = -3.375703D-1 B = 2.090333D0 C = -1.343802D0 ENDIF S = ( SQRT(B**2 - 4.D0 * A * (C-R)) - B ) / ( 2.D0 * A ) IF ( DEBUG ) WRITE(MDEBUG,*) 'AGE : S=',SNGL(S) RETURN END *CMZ : 23/11/2000 10.59.37 by D. HECK IK3 FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE AVAGE C----------------------------------------------------------------------- C AVE(ERAGE) AGE C C CALCULATES AVERAGE AGE AS A FUNCTION OF RADIUS C THIS SUBROUTINE IS CALLED FROM AAMAIN. C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,BUFFS. COMMON /BUFFS/ RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH INTEGER MAXBUF,MAXLEN PARAMETER (MAXLEN=16) PARAMETER (MAXBUF=39*7) REAL RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF), * RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF) INTEGER LH CHARACTER*4 CRUNH,CRUNE,CEVTH,CEVTE,CLONG EQUIVALENCE (RUNH(1),CRUNH), (RUNE(1),CRUNE) EQUIVALENCE (EVTH(1),CEVTH), (EVTE(1),CEVTE) EQUIVALENCE (ARRAYLONG(1),CLONG) *KEEP,ELABCT. COMMON /ELABCT/ ELCUT DOUBLE PRECISION ELCUT(4) *KEEP,NKGI. COMMON /NKGI/ SEL,SELLG,STH,ZEL,ZELLG,ZSL,DIST, * DISX,DISY,DISXY,DISYX,DLAX,DLAY,DLAXY,DLAYX, * OBSATI,RADNKG,RMOL,TLEV,TLEVCM,IALT DOUBLE PRECISION SEL(10),SELLG(10),STH(10),ZEL(10),ZELLG(10), * ZSL(10),DIST(10), * DISX(-10:10),DISY(-10:10), * DISXY(-10:10,2),DISYX(-10:10,2), * DLAX (-10:10,2),DLAY (-10:10,2), * DLAXY(-10:10,2),DLAYX(-10:10,2), * OBSATI(2),RADNKG,RMOL(2),TLEV(10),TLEVCM(10) INTEGER IALT(2) *KEEP,NKGS. COMMON /NKGS/ CZX,CZY,CZXY,CZYX,SAH,SL,ZNE DOUBLE PRECISION CZX(-10:10,2),CZY(-10:10,2),CZXY(-10:10,2), * CZYX(-10:10,2),SAH(10),SL(10),ZNE(10) *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DOUBLE PRECISION AJ,BJ,CJ,DF(10),SJ(10),SLLG,TH,ZF INTEGER I,ID,IL,IOL,J,K,L SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'AVAGE :' IF ( FPRINT ) WRITE(MONIOU,1110) ISHOWNO,ELCUT(3),ELCUT(4) 1110 FORMAT (/' ---------- NKG - OUTPUT OF SHOWER NO ',I10, * ' --------------------------------'/ * ' ELECTRON/PHOTON THRESHOLD AT ',F10.5,' /',F10.5,' GEV') C LOOP OVER ALL DISTANCES WHERE ELECTRON NUMBER IS CALCULATED DO 302 K = 1,2 IF ( OBSATI(K) .GE. 0.D0 ) THEN DO 301 ID = -10,10 DLAX (ID,K) = DLAX (ID,K) + CZX (ID,K) DLAY (ID,K) = DLAY (ID,K) + CZY (ID,K) DLAXY(ID,K) = DLAXY(ID,K) + CZXY(ID,K) DLAYX(ID,K) = DLAYX(ID,K) + CZYX(ID,K) 301 CONTINUE ENDIF 302 CONTINUE C CALCULATE LONGITUDINAL SHOWER DEVELOPMENT DO 311 IL = 1,IALT(1) IF ( SL(IL) .GT. 0.D0 ) THEN SEL(IL) = SEL(IL) + SL(IL) SLLG = LOG10(SL(IL)) SELLG(IL) = SELLG(IL) + SLLG ZEL(IL) = ZEL(IL) + SL(IL)**2 ZELLG(IL) = ZELLG(IL) + SLLG**2 ZF = ZNE(IL)/SL(IL) CALL AGE( ZF,TH ) C AGE PARAMETERS AVERAGED ON ALL SUBCASCADES AT THIS LEVEL SAH(IL) = TH STH(IL) = STH(IL) + TH ZSL(IL) = ZSL(IL) + TH**2 ELSE SL(IL) = 0.D0 SAH(IL) = 0.D0 ENDIF EVTE(175+IL) = SL(IL) EVTE(185+IL) = SAH(IL) EVTE(215+IL) = TLEV(IL) EVTE(225+IL) = TLEVCM(IL) 311 CONTINUE C PRINT LONGITUDINAL SHOWER DEVELOPMENT IF ( FPRINT ) WRITE(MONIOU,229) * (I,TLEV(I),TLEVCM(I),SL(I),SAH(I),I=1,IALT(1)) 229 FORMAT( * /' LEVEL',2X,'THICKNESS',8X,'HEIGHT',5X,'ELECT. NUMBER',7X,'AGE' * /' NO. ',2X,' G/CM**2',8X,' CM'/ * (' ',I4,F12.0,2X,F12.0,1X,F17.3,F10.3) ) DO 312 IOL = 1,2 IF ( OBSATI(IOL) .LT. 0.D0 ) GOTO 312 C DETERMINE LOCAL AGE PARAMETER DO 50 J = 1,9 IF ( CZX(J+1,IOL).GT.0.D0 .AND. CZX(-J-1,IOL).GT.0.D0 .AND. * CZXY(J+1,IOL).GT.0.D0 .AND. CZXY(-J-1,IOL).GT.0.D0 .AND. * CZYX(J+1,IOL).GT.0.D0 .AND. CZYX(-J-1,IOL).GT.0.D0 .AND. * CZY(J+1,IOL).GT.0.D0 .AND. CZY(-J-1,IOL).GT.0.D0 ) THEN AJ = 0.125D0 * ( * CZX(J,IOL) /CZX(J+1,IOL) + CZX(-J,IOL) /CZX(-J-1,IOL) * + CZXY(J,IOL)/CZXY(J+1,IOL)+ CZXY(-J,IOL)/CZXY(-J-1,IOL) * + CZYX(J,IOL)/CZYX(J+1,IOL)+ CZYX(-J,IOL)/CZYX(-J-1,IOL) * + CZY(J,IOL) /CZY(J+1,IOL) + CZY(-J,IOL) /CZY(-J-1,IOL) ) ELSE AJ = 0.D0 ENDIF IF ( AJ .GT. 0.D0 ) THEN BJ = DIST(J) / DIST(J+1) CJ = (DIST(J)+RMOL(IOL)) / (DIST(J+1)+RMOL(IOL)) SJ(J) = LOG(AJ * BJ**2 * CJ**4.5D0) / LOG(BJ * CJ) DF(J) = 0.5D0 * (DIST(J) + DIST(J+1)) ELSE SJ(J) = 0.D0 DF(J) = 0.D0 ENDIF 50 CONTINUE DO L = 1,10 EVTE(165+IOL*40+L) = SJ(L) ENDDO IF ( FPRINT ) THEN C WRITE LOCAL AGE PARAMETER WRITE(MONIOU,60) IOL,OBSATI(IOL), (I,DF(I),SJ(I),I=1,9) 60 FORMAT(/' RADIAL BIN DISTANCE(CM) LOCAL AGE AT LEVEL NO.', * I4,' AT HEIGHT:',F10.0,' CM'/ * (' ',I10,' ',F10.0,' ',F10.3 ) ) C PRINT LATERAL ELECTRON DISTRIBUTION WRITE(MONIOU,507) IOL,OBSATI(IOL) 507 FORMAT(/' LATERAL ELECTRON DENSITY (/CM**2) AT LEVEL NO.', * I4,' AT HEIGHT:',F10.0,' CM'/ * ' --------------------------------------------------', * '---------------------------'/ * ' DIST (CM) CZX CZXY ', * ' CZY CZYX ') WRITE(MONIOU,508) (DISX(I),CZX(I,IOL),CZXY(I,IOL), * CZY(I,IOL),CZYX(I,IOL),I=-10,10) 508 FORMAT(' ',0P,F10.0,1P,4E15.5) WRITE(MONIOU,*)' ' ENDIF 312 CONTINUE DO L = 1,10 EVTE(195+L) = DIST(L) EVTE(235+L) = DF(L) ENDDO C WRITE NKG - SHOWER INFORMATION TO EVENT END BLOCK DO 353 L = 1,21 EVTE( 7+L) = CZX (-11+L,1) EVTE( 28+L) = CZY (-11+L,1) EVTE( 49+L) = CZXY(-11+L,1) EVTE( 70+L) = CZYX(-11+L,1) EVTE( 91+L) = CZX (-11+L,2) EVTE(112+L) = CZY (-11+L,2) EVTE(133+L) = CZXY(-11+L,2) EVTE(154+L) = CZYX(-11+L,2) 353 CONTINUE RETURN END *CMZ : 14/06/2000 14.40.12 by D. HECK IK3 FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= DOUBLE PRECISION FUNCTION GAM( Z ) C----------------------------------------------------------------------- C GAM(MA FUNCTION) C C EULER'S GAMMA FUNCTION C THE INTERNAL PRECISION OF THIS FUNCTION IS ONLY SINGLE PRECISION. C THIS FUNCION IS CALLED FROM NKG. C ARGUMENT: C Z = ARGUMENT OF GAMMA FUNCTION (0 < Z < 57) C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION U,Y,YY,Z SAVE C----------------------------------------------------------------------- C CALCULATE CORRESPONDING FUNCTION VALUE IN INTERVAL 1 ... 2 Y = MOD(Z,1.D0) YY = Y + 1.D0 C PARAMETRIZATION FOR VALUES IN INTERVAL 1 ... 2 GAM = 1.D0 + Y*(-0.5771017D0 + Y*(0.9858540D0+ * Y*(-0.8764218D0 + Y*(0.8328212D0+ * Y*(-0.5684729D0 + Y*(0.2548205D0+ * Y*(-0.0514993D0 ))))))) C GET FUNCTION VALUE IN DESIRED INTERVAL BY ITERATION IF ( Z .LT. 1.D0 ) THEN C GAMMA(Z-1) IS GAMMA(Z) / (Z-1) GAM = GAM / Z ELSE C GAMMA(Z+1) IS GAMMA(Z) * Z DO 1 U = YY, Z-1.D0, 1.D0 GAM = GAM * U 1 CONTINUE ENDIF RETURN END *CMZ : 18/10/2000 09.15.11 by D. HECK IK3 FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE ININKG C----------------------------------------------------------------------- C INI(TIALIZE) NKG C C INITIALIZES ARRAYS FOR NKG CALCULATING VARIABLES C THIS SUBROUTINE IS CALLED FROM AAMAIN. C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,BUFFS. COMMON /BUFFS/ RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH INTEGER MAXBUF,MAXLEN PARAMETER (MAXLEN=16) PARAMETER (MAXBUF=39*7) REAL RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF), * RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF) INTEGER LH CHARACTER*4 CRUNH,CRUNE,CEVTH,CEVTE,CLONG EQUIVALENCE (RUNH(1),CRUNH), (RUNE(1),CRUNE) EQUIVALENCE (EVTH(1),CEVTH), (EVTE(1),CEVTE) EQUIVALENCE (ARRAYLONG(1),CLONG) *KEEP,NKGI. COMMON /NKGI/ SEL,SELLG,STH,ZEL,ZELLG,ZSL,DIST, * DISX,DISY,DISXY,DISYX,DLAX,DLAY,DLAXY,DLAYX, * OBSATI,RADNKG,RMOL,TLEV,TLEVCM,IALT DOUBLE PRECISION SEL(10),SELLG(10),STH(10),ZEL(10),ZELLG(10), * ZSL(10),DIST(10), * DISX(-10:10),DISY(-10:10), * DISXY(-10:10,2),DISYX(-10:10,2), * DLAX (-10:10,2),DLAY (-10:10,2), * DLAXY(-10:10,2),DLAYX(-10:10,2), * OBSATI(2),RADNKG,RMOL(2),TLEV(10),TLEVCM(10) INTEGER IALT(2) *KEEP,OBSPAR. COMMON /OBSPAR/ OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP, * THETPR,PHIPR, * VUECON, * NOBSLV DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10), * HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2) DOUBLE PRECISION VUECON(2) INTEGER NOBSLV *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DOUBLE PRECISION DEPTH,HEIGH,RHOF,RMGCM,THICK INTEGER I,IL,K,KL SAVE EXTERNAL HEIGH,RHOF,THICK DATA RMGCM / 9.6D0 / C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'ININKG:' C SET LATERAL DISTRIBUTION DISTANCES IF ( RADNKG .LE. 100.D0 ) THEN WRITE(MONIOU,*) 'ININKG: RADNKG=',RADNKG,' CM TOO SMALL ' RADNKG = 200.D2 WRITE(MONIOU,*) ' RADNKG CORRECTED TO ',RADNKG,' CM' ENDIF EVTH(147) = RADNKG DO I = 1,10 DIST(I) = 100.D0 * 10.D0**(LOG10(RADNKG/100.D0)*0.1D0*I) DISX(I) = DIST(I) DISX(-I) = -DIST(I) ENDDO DISX(0) = 0.D0 C MOLIERE RADIUS FOR COULOMB SCATTERING ; EQUIVALENT TO 9.6 G/CM**2 C OBSERVATION LEVELS AND CORRESPONDING MOLIERE RADII (IN CM) FOR NKG OBSATI(1) = OBSLEV(NOBSLV) RMOL (1) = RMGCM / RHOF(OBSATI(1)) IF ( NOBSLV .GT. 1 ) THEN OBSATI(2) = OBSLEV(NOBSLV-1) RMOL (2) = RMGCM / RHOF(OBSATI(2)) ELSE OBSATI(2) = -1.D0 RMOL (2) = 0.D0 IALT (2) = 0 ENDIF C CALCULATE COORDINATES OF POINTS ON THE X AND Y AXIS AND THE TWO C DIAGONAL LINES Y IS X AND Y IS -X DO 3333 KL = -10,10 DISY (KL) = DISX (KL) DISXY(KL,1) = DISX (KL) / SQRT(2.D0) DISXY(KL,2) = DISXY(KL,1) DISYX(KL,1) = DISXY(KL,1) DISYX(KL,2) = -DISXY(KL,2) 3333 CONTINUE C CLEAR ARRAY FOR LATERAL ELECTRON DISTR. (AVERAGE OVER ALL SHOWERS) DO 45 K = 1,2 DO 45 I = -10,10 DLAX (I,K) = 0.D0 DLAY (I,K) = 0.D0 DLAXY(I,K) = 0.D0 DLAYX(I,K) = 0.D0 45 CONTINUE C CLEAR ARRAY FOR AGE PARAMETER CALCULATION (AVERAGE OVER ALL SHOWERS) DO 17 I = 1,10 SEL(I) = 0.D0 SELLG(I) = 0.D0 STH(I) = 0.D0 ZELLG(I) = 0.D0 ZEL(I) = 0.D0 ZSL(I) = 0.D0 17 CONTINUE C LAST OBSERVATION LEVEL DEPTH IS GIVEN IN G/CM**2 DEPTH = THICK(OBSATI(1)) IALT(1) = MIN( 10, INT(DEPTH/102.D0)+1 ) C CALCULATE 10 LEVELS AT EACH 100 G/CM**2 DO 111 IL = 1,IALT(1)-1 TLEV (IL) = 100.D0 * IL TLEVCM(IL) = HEIGH(TLEV(IL)) 111 CONTINUE C FOR LAST LEVEL NOT IL*100 BUT OBSERVATION LEVEL TLEV (IALT(1)) = DEPTH TLEVCM(IALT(1)) = OBSATI(1) C SECOND OBSERVATION LEVEL ? IF ( OBSATI(2) .GE. 0.D0 ) THEN DEPTH = THICK(OBSATI(2)) IALT(2) = INT(DEPTH/102.D0) + 1 IF ( IALT(2) .GE. IALT(1) ) IALT(2) = MAX( 1, IALT(1)-1 ) TLEV (IALT(2)) = DEPTH TLEVCM(IALT(2)) = OBSATI(2) ENDIF RETURN END *CMZ : 23/11/2000 10.59.37 by D. HECK IK3 FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE MITAGE C----------------------------------------------------------------------- C MIT(TELWERT) AGE (AVERAGE AGE) C C CALCULATES AVERAGE DISTRIBUTION FOR NKG FUNCTION OVER ALL SHOWERS C THIS SUBROUTINE IS CALLED FROM AAMAIN. C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,ELABCT. COMMON /ELABCT/ ELCUT DOUBLE PRECISION ELCUT(4) *KEEP,NKGI. COMMON /NKGI/ SEL,SELLG,STH,ZEL,ZELLG,ZSL,DIST, * DISX,DISY,DISXY,DISYX,DLAX,DLAY,DLAXY,DLAYX, * OBSATI,RADNKG,RMOL,TLEV,TLEVCM,IALT DOUBLE PRECISION SEL(10),SELLG(10),STH(10),ZEL(10),ZELLG(10), * ZSL(10),DIST(10), * DISX(-10:10),DISY(-10:10), * DISXY(-10:10,2),DISYX(-10:10,2), * DLAX (-10:10,2),DLAY (-10:10,2), * DLAXY(-10:10,2),DLAYX(-10:10,2), * OBSATI(2),RADNKG,RMOL(2),TLEV(10),TLEVCM(10) INTEGER IALT(2) *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DOUBLE PRECISION AJ,ATH,BJ,CJ,DF(10),RISH,SELEC,SELCLG,SJ(10), * ZEC,ZECLG,ZSE INTEGER I,ID,J,K,LI SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'MITAGE:' WRITE(MONIOU,349) ELCUT(3),ELCUT(4) 349 FORMAT(/' ========== NKG - AVERAGE VALUES OF ALL SHOWERS ', * '==============================='/ * ' ELECTRON/PHOTON THRESHOLDS AT ',F10.5,' /',F10.5,' GEV'// * ' LEVEL THICKNESS HEIGHT DEV', * ' DEV DEV'/ * ' NO. (G/CM**2) (M) ' ) C NORMALIZE AVERAGE ELECTRON DENSITIES RISH = 1.D0 / ISHW DO 161 K = 1,2 IF ( OBSATI(K) .GE. 0.D0 ) THEN DO 162 ID = -10,10 DLAX (ID,K) = DLAX (ID,K) * RISH DLAY (ID,K) = DLAY (ID,K) * RISH DLAXY(ID,K) = DLAXY(ID,K) * RISH DLAYX(ID,K) = DLAYX(ID,K) * RISH 162 CONTINUE ENDIF 161 CONTINUE DO 16 LI = 1,IALT(1) C ELECTRON NUMBER SELEC = SEL(LI) * RISH C LOG10 ELECTRON NUMBER SELCLG = SELLG(LI) * RISH C AVERAGE LONGITUDINAL AGE ATH = STH(LI) * RISH IF ( ISHW .GT. 1 ) THEN C ELECTRON NUMBER ZEC = SQRT( MAX( 0.D0, (ZEL(LI) - SEL(LI)**2*RISH)/ * (ISHW-1.D0) ) ) C LOG10 ELECTRON NUMBER ZECLG = SQRT( MAX( 0.D0, (ZELLG(LI) - SELLG(LI)**2*RISH)/ * (ISHW-1.D0) ) ) C AVERAGE LONGITUDINAL AGE ZSE = SQRT( MAX( 0.D0, (ZSL(LI) - STH(LI)**2*RISH)/ * (ISHW-1.D0) ) ) ELSE ZEC = 0.D0 ZECLG = 0.D0 ZSE = 0.D0 ENDIF C WRITE ELECTRON INFORMATION FOR ALL NKG LEVELS (LONG. DEVELOPMENT) WRITE(MONIOU,219) LI,TLEV(LI),TLEVCM(LI)*0.01, * SELEC,ZEC,SELCLG,ZECLG,ATH,ZSE 219 FORMAT (' ',I4,F10.0,F11.2,1X,2F15.0,3X,2F12.5,F13.3,F9.3) 16 CONTINUE DO 520 K = 1,2 IF ( OBSATI(K) .LT. 0.D0 ) GOTO 520 C DETERMINE LOCAL AGE PARAMETER DO 50 J = 1,9 IF ( DLAX(J+1,K).GT.0.D0 .AND. DLAX(-J-1,K).GT.0.D0 .AND. * DLAXY(J+1,K).GT.0.D0 .AND. DLAXY(-J-1,K).GT.0.D0 .AND. * DLAYX(J+1,K).GT.0.D0 .AND. DLAYX(-J-1,K).GT.0.D0 .AND. * DLAY(J+1,K).GT.0.D0 .AND. DLAY(-J-1,K).GT.0.D0 ) THEN AJ = 0.125D0 * ( * DLAX(J,K) /DLAX(J+1,K) + DLAX(-J,K) /DLAX(-J-1,K) * + DLAXY(J,K)/DLAXY(J+1,K) + DLAXY(-J,K)/DLAXY(-J-1,K) * + DLAYX(J,K)/DLAYX(J+1,K) + DLAYX(-J,K)/DLAYX(-J-1,K) * + DLAY(J,K) /DLAY(J+1,K) + DLAY(-J,K) /DLAY(-J-1,K)) ELSE AJ = 0.D0 ENDIF IF ( AJ .GT. 0.D0 ) THEN BJ = DIST(J) / DIST(J+1) CJ = (DIST(J)+RMOL(K)) / (DIST(J+1)+RMOL(K)) SJ(J) = LOG(AJ * BJ**2 * CJ**4.5D0) / LOG(BJ * CJ) DF(J) = 0.5D0* (DIST(J) + DIST(J+1)) ELSE SJ(J) = 0.D0 DF(J) = 0.D0 ENDIF 50 CONTINUE C WRITE LOCAL AGE PARAMETER WRITE(MONIOU,60) K,OBSATI(K), (I,DF(I),SJ(I),I=1,9) 60 FORMAT(/' RADIAL BIN DISTANCE(CM) LOCAL AGE AT LEVEL NO.', * I4,' AT HEIGHT:',F10.0,' CM'/ * (' ',I9,' ',F10.0,' ',F10.3 ) ) C WRITE LATERAL ELECTRON DISTRIBUTION WRITE(MONIOU,507) K,OBSATI(K) 507 FORMAT(/' AVERAGE ELECTRON DENSITY (/CM**2) FOR LEVEL NO.', * I4,' AT HEIGHT:',F10.0,' CM'/ * ' ==================================================', * '=========================='/ * ' DIST (CM) DLAX DLAXY ', * ' DLAY DLAYX') WRITE(MONIOU,508) (DISX(I),DLAX(I,K),DLAXY(I,K), * DLAY(I,K),DLAYX(I,K),I=-10,10) 508 FORMAT(' ',0P,F10.0,1P,4E15.5) WRITE(MONIOU,*)' ' 520 CONTINUE RETURN END *CMZ : 07/01/2002 13.20.15 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE NKG( ENERN ) C----------------------------------------------------------------------- C N(ISHIMURA) K(AMATA) G(REISEN) C C CALCULATES ELECTROMAGNETIC COMPONENT OF SHOWERS USING THE ANALYTIC C NKG FORMULAS, INCLUDING ELECTRON ENERGY THRESHOLD ELCUT(3) C SEE J.N. CAPDEVIELLE, 22ND ICRC, DUBLIN 1991, CONTRIB. HE 3.5.10 C THIS SUBROUTINE IS CALLED FROM EM. C ARGUMENT: C ENERN = ENERGY OF ELECTRON/PHOTON GENERATING A SUBSHOWER C NEGATIVE FOR SUBSHOWERS TO BE SUBTRACTED AFTER C PHOTONUCLEAR REACTION C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,ELABCT. COMMON /ELABCT/ ELCUT DOUBLE PRECISION ELCUT(4) *KEEP,NKGI. COMMON /NKGI/ SEL,SELLG,STH,ZEL,ZELLG,ZSL,DIST, * DISX,DISY,DISXY,DISYX,DLAX,DLAY,DLAXY,DLAYX, * OBSATI,RADNKG,RMOL,TLEV,TLEVCM,IALT DOUBLE PRECISION SEL(10),SELLG(10),STH(10),ZEL(10),ZELLG(10), * ZSL(10),DIST(10), * DISX(-10:10),DISY(-10:10), * DISXY(-10:10,2),DISYX(-10:10,2), * DLAX (-10:10,2),DLAY (-10:10,2), * DLAXY(-10:10,2),DLAYX(-10:10,2), * OBSATI(2),RADNKG,RMOL(2),TLEV(10),TLEVCM(10) INTEGER IALT(2) *KEEP,NKGS. COMMON /NKGS/ CZX,CZY,CZXY,CZYX,SAH,SL,ZNE DOUBLE PRECISION CZX(-10:10,2),CZY(-10:10,2),CZXY(-10:10,2), * CZYX(-10:10,2),SAH(10),SL(10),ZNE(10) *KEEP,OBSPAR. COMMON /OBSPAR/ OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP, * THETPR,PHIPR, * VUECON, * NOBSLV DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10), * HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2) DOUBLE PRECISION VUECON(2) INTEGER NOBSLV *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DOUBLE PRECISION AE,AS,ASE,AUXIL,BS,CCP,CPC,CPCP,CPH,CSGA, * DE,DISTL,ECRI,ECR1,ECR2,ENERN,GAM,GRCUT, * G1,G2,G3,S,SC1,SC2,SIGNE,SM,SMRM, * SQRZ1I,SQZC1I,SQZC2I,SS2,SS45,TEX,THICK,THICKP, * XMOL,XNE,XS,X0,YM,YS,ZC1,ZC2,ZG1,ZG2,ZG3,Z1 INTEGER IL,IOL,M SAVE EXTERNAL GAM,THICK C X0 IS RADIATON LENGTH IN AIR (G/CM**2) C (SEE ALSO MIKOCKI ET AL. J.PHYS.G.:NUCL.PART.PHYS. 17 (1991) 1303 ) C GRCUT IS GREISEN CUT OFF, ECRI IS CRITICAL ENERGY IN AIR C ECR2 IS 0.4 * ECRI CDH DATA X0 / 37.1D0 /, GRCUT / 0.1D0 /, ECRI / 0.082D0 / CDH DATA ECR2 / 0.0328D0 / DATA X0 / 36.66D0 /, GRCUT / 0.1D0 /, ECRI / 0.086D0 / DATA ECR2 / 0.0344D0 / C----------------------------------------------------------------------- IF (DEBUG) WRITE(MDEBUG,*)'NKG : ',SNGL(SECPAR(1)),SNGL(ENERN) C CHECK WETHER SUBSHOWER IS SUBTRACTED IF ( ENERN .GE. 0.D0 ) THEN SIGNE = +1.D0 ELSE ENERN = -ENERN SIGNE = -1.D0 ENDIF C ENERGY CUT OFF IN GREISEN FORMULA C (EM PARTICLE BELOW THIS CUT CAN NOT PRODUCE A SHOWER) IF ( ENERN .LT. GRCUT ) RETURN C DON'T CALCULATE NKG FOR BACKWARD GOING PARTICLES IF ( SECPAR(3) .LE. 0.D0 ) RETURN C DON'T CALCULATE NKG IF PARTICLE BELOW THE LOWEST OBSERVATION LEVEL IF ( SECPAR(5) .LT. OBSATI(1) ) RETURN Z1 = LOG(ENERN / ECRI) SQRZ1I = 1.D0 / SQRT(Z1) C THIS CUT IS ONLY IMPORTANT FOR ELCUT > .0672 ECR1 = ECR2 + ELCUT(3) IF ( ENERN .LT. ECR1 ) RETURN ZC1 = LOG(ENERN / ECR1) SQZC1I = 1.D0 / SQRT(ZC1) C LOG(ENERN/ECR2) IS LOG(ENERN / ECRI) - LOG(0.4) ZC2 = Z1 + 0.916290732D0 SQZC2I = 1.D0 / SQRT(ZC2) THICKP = THICK(SECPAR(5)) C LOOP OVER LEVELS DO 14 IL = 1,IALT(1) C DISREGARD LEVELS ABOVE THE PARTICLE IF ( TLEVCM(IL) .GT. SECPAR(5) ) GOTO 14 C DISTANCE IN G/CM**2 .... (ALONG PHOTON-AXIS) IN RADIATION LENGTHS XMOL = (TLEV(IL) - THICKP) / ( X0 * SECPAR(3) ) C CORRECT DEPTH FOR SUBSHOWERS TO BE SUBTRACTED BY 9/7 C CORRECTION IS ALREADY DONE IN PIGEN (D.H. MARCH 10, 1998) CDH IF ( SIGNE .LT. 0.D0 ) XMOL = XMOL + 1.285714286D0 C XMOL IS DEPTH IN RADIATION LENGTHS C RESPECT THE DIFFERENT DEVELOPMENT OF ELECTRON-INDUCED SUBSHOWERS C BY 0.6 RADIATION LENGTH (D.H. MAY 2001) C SEE J. NISHIMURA, HANDBUCH DER PHYSIK XLVI/2 (1967) 27 IF ( SECPAR(1) .NE. 1.D0 ) XMOL = XMOL + 0.6D0 IF ( XMOL .GT. 60.D0 .OR. XMOL .LT. 1.D0 ) GOTO 14 C S IS AGE PARAMETER S = 3.D0 * XMOL / (XMOL + 2.D0 * Z1) IF ( S .LE. 0.2D0 ) GOTO 14 SC1 = 3.D0 * XMOL / (XMOL + 2.D0 * ZC1) SC2 = 3.D0 * XMOL / (XMOL + 2.D0 * ZC2) C ELECTRON NUMBER AT OBSERVATION LEVEL CPH = .31D0 * EXP( XMOL * (1.D0 - 1.5D0 * LOG(S) ) ) * SQRZ1I CPC = EXP( XMOL * ( 1.D0 - 1.5D0 * LOG(SC1) ) ) * SQZC1I CCP = EXP( XMOL * ( 1.D0 - 1.5D0 * LOG(SC2) ) ) * SQZC2I CPCP = SIGNE * CPH * CPC / CCP C INTERMEDIATE FACTORS FOR LATERAL DISTRIBUTION AND AGE PARAMETER AE = 4.D0 * EXP( 0.915D0 * (S - 1.D0) ) / S DE = ( 1.D0 + S ) / ( 1.15D0 + 0.15D0 * S ) ASE = AE**DE ZG3 = GAM( (S + 2.D0) * DE ) IF ( ZG3 .LE. 0.D0 ) GOTO 14 ZG1 = GAM(S * DE) ZG2 = GAM( (S + 1.D0) * DE ) AUXIL = 4.D0 / (S * ASE) XNE = CPCP * ( ZG2 + AUXIL * ZG3 ) / ( ASE * (ZG1 + AUXIL*ZG2) ) C SUM OF N_E AT FIXED LEVEL ZNE(IL) = ZNE(IL) + XNE SL(IL) = SL(IL) + CPCP C CALCULATE THE ELECTRON LATERAL DISTRIBUTION FOR THE 2 SELECTED C OBSERVATION LEVELS IF ( IL .EQ. IALT(1) ) THEN IOL = 1 ELSEIF ( IL .EQ. IALT(2) ) THEN IOL = 2 ELSE GOTO 14 ENDIF C CALCULATION OF LATERAL ELECTRON DISTRIBUTION IF ( SC1 .GE. 2.25D0 ) GOTO 14 G1 = GAM(4.5D0 - SC1) G2 = GAM(SC1) G3 = GAM(4.5D0 - 2.D0 * SC1) C DISTANCE IN CM BETWEEN PHOTON INITIATION AND OBSERVATION (VERTICAL) DISTL = SECPAR(5) - TLEVCM(IL) C MODULATION BY AGE PARAMETER FOLLOWING LAGUTIN & UCHAIKIN C (AGE PARAMETER LIES BETWEEN 0.2 AND 2.25) SM = 0.78D0 - 0.21D0 * SC1 SMRM = 1.D0 / ( SM * RMOL(IOL) ) CSGA = CPCP * SMRM**2 * G1 / ( PI2 * G2 * G3 ) SS2 = SC1 - 2.D0 SS45 = SC1 - 4.5D0 AS = SIN( SECPAR(4) ) BS = COS( SECPAR(4) ) TEX = DISTL * SQRT( 1.D0 - SECPAR(3)**2 ) / SECPAR(3) C DISTANCE TO THE CENTER OF THE CASCADE (IN CM) XS = SECPAR(7) + TEX * BS - XOFF(NOBSLV+1-IOL) YS = SECPAR(8) + TEX * AS - YOFF(NOBSLV+1-IOL) C NKG-FORMULA C LOOP OVER ALL LATERAL DISTANCES GETTING THE DENSITY IN MOLIERE UNITS DO 171 M = -10,10 IF ( M .EQ. 0 ) GOTO 171 C X DIRECTION YM = SMRM * MAX( SQRT((DISX(M)-XS)**2 + YS**2), 1.D0 ) CZX (M,IOL) = CZX (M,IOL) + CSGA * YM**SS2 * (YM+1.D0)**SS45 C Y DIRECTION YM = SMRM * MAX( SQRT(XS**2 + (DISY(M)-YS)**2), 1.D0 ) CZY (M,IOL) = CZY (M,IOL) + CSGA * YM**SS2 * (YM+1.D0)**SS45 C XY DIRECTION YM = SMRM * * MAX( SQRT((DISXY(M,1)-XS)**2 + (DISXY(M,2)-YS)**2), 1.D0 ) CZXY(M,IOL) = CZXY(M,IOL) + CSGA * YM**SS2 * (YM+1.D0)**SS45 C YX DIRECTION YM = SMRM * * MAX( SQRT((DISYX(M,1)-XS)**2 + (DISYX(M,2)-YS)**2), 1.D0 ) CZYX(M,IOL) = CZYX(M,IOL) + CSGA * YM**SS2 * (YM+1.D0)**SS45 171 CONTINUE 14 CONTINUE RETURN END *CMZ : 18/10/2000 09.15.11 by D. HECK IK3 FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE STANKG C----------------------------------------------------------------------- C STA(RT) NKG C C INITIALIZES ARRAYS FOR SINGLE SHOWERS NKG CALCULATED VARIABLES C THIS SUBROUTINE IS CALLED FROM AAMAIN. C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,NKGS. COMMON /NKGS/ CZX,CZY,CZXY,CZYX,SAH,SL,ZNE DOUBLE PRECISION CZX(-10:10,2),CZY(-10:10,2),CZXY(-10:10,2), * CZYX(-10:10,2),SAH(10),SL(10),ZNE(10) *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. INTEGER I,K SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'STANKG:' C CLEAR ARRAYS FOR AGE PARAMETER CALCULATION FOR EACH SHOWER DO 17 I = 1,10 SAH(I) = 0.D0 SL (I) = 0.D0 ZNE(I) = 0.D0 17 CONTINUE C CLEAR LATERAL ELECTRON DISTRIBUTION COUNTERS FOR EACH SHOWER DO 45 K = 1,2 DO 45 I = -10,10 CZX (I,K) = 0.D0 CZY (I,K) = 0.D0 CZXY(I,K) = 0.D0 CZYX(I,K) = 0.D0 45 CONTINUE RETURN END *CMZ : 28/02/2002 13.08.20 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE CGHEI C----------------------------------------------------------------------- C C(ORSIKA) GHE(ISHA) I(NTERFACE) C C MAIN STEERING SUBROUT. FOR HADRON PACKAGE GHEISHA *** C THIS SUBROUTINE IS CALLED FROM NUCINT. C C ORIGIN : F.CARMINATI, H.FESEFELDT (SUBROUT. GHESIG) C REDESIGN: P. GABRIEL IK1 FZK KARLSRUHE C----------------------------------------------------------------------- *KEEP,CGCOMP. PARAMETER (KK=3) COMMON/CGCOMP/ ACOMP,ZCOMP,WCOMP REAL ACOMP(KK),ZCOMP(KK),WCOMP(KK) *KEEP,ELABCT. COMMON /ELABCT/ ELCUT DOUBLE PRECISION ELCUT(4) *KEEP,ELADPM. COMMON /ELADPM/ ELMEAN,ELMEAA,IELDPM,IELDPA DOUBLE PRECISION ELMEAN(40),ELMEAA(40) INTEGER IELDPM(40,13),IELDPA(40,13) *KEEP,ELASTY. COMMON /ELASTY/ ELAST DOUBLE PRECISION ELAST *KEEP,GENER. COMMON /GENER/ GEN,ALEVEL DOUBLE PRECISION GEN,ALEVEL *KEEP,ISTA. COMMON /ISTA/ IFINET,IFINNU,IFINKA,IFINPI,IFINHY INTEGER IFINET,IFINNU,IFINKA,IFINPI,IFINHY *KEEP,LONGI. COMMON /LONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG, * SDLONG,SELONG,SPLONG,THSTEP,THSTPI, * LHEIGH,NSTEP,LLONGI,FLGFIT DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9), * APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9), * HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9), * SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI INTEGER LHEIGH,NSTEP LOGICAL LLONGI,FLGFIT *KEEP,MULT. COMMON /MULT/ EKINL,MSMM,MULTMA,MULTOT DOUBLE PRECISION EKINL INTEGER MSMM,MULTMA(40,13),MULTOT(40,13) *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,SIGM. COMMON /SIGM/ SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO DOUBLE PRECISION SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO *KEND. DOUBLE PRECISION ELASTI,ELABOR,ETOT,PLX,PLY,PLZ,PLSQ,PLTOT,RMASSK COMMON/GSECTI/ AIEL(20),AIIN(20),AIFI(20),AICA(20),ALAM,K0FLAG INTEGER K0FLAG REAL AIEL,AIIN,AIFI,AICA,ALAM C --- GHEISHA COMMONS --- PARAMETER (MXGKGH=100) PARAMETER (MXGKPV=MXGKGH) COMMON /VECUTY/ PV(10,MXGKPV) COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI, $ SMU,CT,CTKCH,CTK0, $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM, $ RMASS(35),RCHARG(35) REAL MP,MPI,MMU,MEL,MKCH,MK0, * ML0,MSP,MS0,MSM,MX0,MXM PARAMETER (MXEVEN=12*MXGKGH) COMMON/EVENT / NSIZE,NCUR,NEXT,NTOT,EVE(MXEVEN) COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT C --- "NEVENT" CHANGED TO "KEVENT" IN COMMON /CURPAR/ DUE TO CLASH --- C --- WITH VARIABLE "NEVENT" IN GEANT COMMON --- PARAMETER (MXGKCU=MXGKGH) COMMON /CURPAR/ WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,KEVENT,SHFLAG, $ ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), $ RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), $ ATNO2,ZNO2 C --- "IPART" CHANGED TO "KPART" IN COMMON /RESULT/ DUE TO CLASH --- C --- WITH VARIABLE "IPART" IN GEANT COMMON --- COMMON /RESULT/ XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, $ USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,KPART,IND, $ LCALO,ICEL,SINL,COSL,SINP,COSP, $ XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, $ XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT C --- "ABSL(21)" CHANGED TO "ABSLTH(21)" IN COMMON /MAT/ DUE TO CLASH --- C --- WITH VARIABLE "ABSL" IN GEANT COMMON --- COMMON /MAT/ LMAT, $ DEN(21),RADLTH(21),ATNO(21),ZNO(21),ABSLTH(21), $ CDEN(21),MDEN(21),X0DEN(21),X1DEN(21),RION(21), $ MATID(21),MATID1(21,24),PARMAT(21,10), $ IFRAT,IFRAC(21),FRAC1(21,10),DEN1(21,10), $ ATNO1(21,10),ZNO1(21,10) * DIMENSION IPELOS(35) REAL EMAX,EEESQ DIMENSION RNDM(1) C --- DIMENSION STMTS. FOR GEANT/GHEISHA PARTICLE CODE CONVERSIONS --- C --- KIPART(I)=GHEISHA CODE CORRESPONDING TO GEANT CODE I --- C --- IKPART(I)=GEANT CODE CORRESPONDING TO GHEISHA CODE I --- DIMENSION KIPART(48),IKPART(35) C --- ANGLES FOR NEW COUPLING WITH CORSIKA D. HECK DEC. 2000 DOUBLE PRECISION PHIRAN,PHIG,THETG SAVE C --- DATA STMTS. FOR GEANT/GHEISHA PARTICLE CODE CONVERSIONS --- C --- KIPART(I)=GHEISHA CODE CORRESPONDING TO GEANT CODE I --- C --- IKPART(I)=GEANT CODE CORRESPONDING TO GHEISHA CODE I --- DATA KIPART/ $ 1, 3, 4, 2, 5, 6, 8, 7, $ 9, 12, 10, 13, 16, 14, 15, 11, $ 35, 18, 20, 21, 22, 26, 27, 33, $ 17, 19, 23, 24, 25, 28, 29, 34, $ 35, 35, 35, 35, 35, 35, 35, 35, $ 35, 35, 35, 35, 30, 31, 32, 35/ DATA IKPART/ $ 1, 4, 2, 3, 5, 6, 8, 7, $ 9, 11, 16, 10, 12, 14, 15, 13, $ 25, 18, 26, 19, 20, 21, 27, 28, $ 29, 22, 23, 30, 31, 45, 46, 47, $ 24, 32, 48/ C --- DENOTE STABLE PARTICLES ACCORDING TO GHEISHA CODE --- C --- STABLE : GAMMA, NEUTRINO, ELECTRON, PROTON AND HEAVY FRAGMENTS --- C --- WHEN STOPPING THESE PARTICLES ONLY LOOSE THEIR KINETIC ENERGY --- * DATA IPELOS/ * $ 1, 1, 0, 1, 0, 0, 0, 0, * $ 0, 0, 0, 0, 0, 1, 0, 0, * $ 0, 0, 0, 0, 0, 0, 0, 0, * $ 0, 0, 0, 0, 0, 1, 1, 1, * $ 0, 0, 1/ C --- LOWERBOUND OF KINETIC ENERGY BIN IN N CROSS-SECTION TABLES --- DATA TEKLOW /0.0001/ C --- KINETIC ENERGY TO SWITCH FROM "CASN" TO "GNSLWD" FOR N CASCADE --- DATA SWTEKN /0.05/ C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,445) (CURPAR(I),I=1,9) 445 FORMAT(' CGHEI : CURPAR=',1P,9E10.3) IF ( DEBUG ) WRITE(MDEBUG,*) * 'CGHEI : E = ',CURPAR(2)*PAMA(NINT(CURPAR(1))) C --- DEFINE PARTICLE TYPE IF ( ITYPE .LE. 48 ) THEN IPART = ITYPE ELSEIF ( ITYPE .EQ. 201 ) THEN IPART = 45 ELSEIF ( ITYPE .EQ. 301 ) THEN IPART = 46 ELSEIF ( ITYPE .EQ. 402 ) THEN IPART = 47 ELSE WRITE(MONIOU,444) (CURPAR(I),I=1,9) 444 FORMAT(' CGHEI : CURPAR=',1P,9E10.3) WRITE(MONIOU,7795) ITYPE 7795 FORMAT (//,' *CGHEI* ILLEGAL PARTICLE TYPE OCCURS =',I5) IPART = 48 ENDIF NETEST=IKPART(KPART) IF ( NETEST .EQ. IPART ) GOTO 9004 WRITE(MONIOU,8881) IPART,KPART 8881 FORMAT(' *CGHEI* IPART,KPART = ',2(I3,1X)/ $ ' *CGHEI* ======> PARTICLE TYPES DO NOT MATCH <=======') STOP 9004 CONTINUE KPART = KIPART(IPART) KKPART = KPART C --- TRANSPORT THE TRACK NUMBER TO GHEISHA AND INITIALIZE SOME NUMBERS C --- NTK=ITRA ITRA = CURRENT TRACK NUMBER IN GEANT (GCKINE) NTK = 0 INTCT = 0.0 NEXT = 1 NTOT = 0 INT = 0 TOF = 0.0 C --- RESET ITYPE SECPAR(1) = 0. C --- FILL RESULT COMMON FOR THIS TRACK WITH CORSIKA VALUES --- AMAS = RMASS(KPART) NCH = RCHARG(KPART) 107 XEND = CURPAR(7) YEND = CURPAR(8) ZEND = CURPAR(5) USERW = 0.0 AMASQ=AMAS*AMAS EN = CURPAR(2) * ABS(AMAS) EK = ABS ( EN - ABS(AMAS) ) ENOLD = EN EMAX = 0. ETOT = 0.D0 P = SQRT ( EN*EN - AMASQ ) ELABOR = EN C OLD COUPLING OF GHEISHA WITH CORSIKA C SINL = -CURPAR(3) C PHI = CURPAR(4) C SINP = SIN(PHI) C COSP = COS(PHI) C COSL = SQRT ( ABS(1.-SINL**2) ) C NEW COUPLING WITH CORSIKA D. HECK DEC. 2000 C WE ASSUME MOVEMENT ALONG Z AXIS. AFTER COLLISION WE ROTATE THE C INTERACTION PLANE AROUND Z AT RANDOM TO ELIMINATE PREFERENCES OF PHI SINL = -1. COSL = 0. SINP = 0. COSP = 1. PX = COSL * COSP PY = COSL * SINP PZ = SINL CALL GRNDM(RNDM,1) PHIRAN = RNDM(1) * TWPI C --- SET GHEISHA INDEX FOR THE CURRENT MEDIUM ALWAYS TO 1 --- IND = 1 C --- TRANSFER GLOBAL MATERIAL CONSTANTS FOR CURRENT MEDIUM --- C --- DETAILED DATA FOR COMPOUNDS IS OBTAINED VIA SUBROUT. COMPO --- ATNO(IND+1) = 14.56 ZNO(IND+1) = 7.265 DEN(IND+1) = 0.0 RADLTH(IND+1)= 0.0 ABSLTH(IND+1)= 0.0 C --- SETUP PARMAT FOR PHYSICS STEERING --- PARMAT(IND+1,10)=0.0 5 CONTINUE C --- INDICATE LIGHT (<= PI) AND HEAVY PARTICLES (HISTORICALLY) --- C --- CALIM CODE --- J = 2 TEST = RMASS(7)-0.001 IF ( ABS(AMAS) .LT. TEST ) J=1 C *** DIVISION INTO VARIOUS INTERACTION CHANNELS DENOTED BY "INT" *** C THE CONVENTION FOR "INT" IS THE FOLLOWING C INT = -1 REACTION CROSS-SECTIONS NOT YET TABULATED/PROGRAMMED C = 0 NO INTERACTION C = 1 ELEASTIC SCATTERING C = 2 INELASTIC SCATTERING C = 3 NUCLEAR FISSION WITH INELEASTIC SCATTERING C = 4 NEUTRON CAPTURE C INT = 3, 4 SHOULD BE DELETED FOR AIR TARGET C --- INTACT CODE --- ALAM1 = 0.0 CALL GRNDM(RNDM,1) RAT = RNDM(1)*ALAM ATNO2 = 14.56 ZNO2 = 7.265 DO 6 K = 1,KK ATNO2 = ACOMP(K) ZNO2 = ZCOMP(K) C --- TRY FOR ELASTIC SCATTERING --- INT = 1 ALAM1 = ALAM1+AIEL(K) IF ( RAT .LT. ALAM1 ) GOTO 8 C --- TRY FOR INELASTIC SCATTERING --- INT = 2 ALAM1 = ALAM1+AIIN(K) IF ( RAT .LT. ALAM1 ) GOTO 8 C --- TRY FOR NEUTRON CAPTURE --- INT = 4 ALAM1 = ALAM1+AICA(K) IF ( RAT .LT. ALAM1 ) GOTO 8 6 CONTINUE C --- NO REACTION SELECTED ==> ELASTIC SCATTERING --- INT = 1 C *** TAKE ACTION ACCORDING TO SELECTED REACTION CHANNEL *** C --- FOLLOWING CODE IS A TRANSLATION OF "CALIM" INTO GEANT JARGON --- 8 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,1001) INT 1001 FORMAT(' *CGHEI* INTERACTION TYPE CHOSEN INT = ',I3) IF ( INT .NE. 4 ) GOTO 10 C --- NEUTRON CAPTURE --- IF ( NPRT(9) ) WRITE(MDEBUG,2000) 2000 FORMAT(' *CGHEI* SUBROUT. CAPTUR WILL BE CALLED') CALL CAPTUR(NOPT) GOTO 40 10 CONTINUE C --- ELASTIC AND INELASTIC SCATTERING --- PV(1,MXGKPV) = P*PX PV(2,MXGKPV) = P*PY PV(3,MXGKPV) = P*PZ PV(4,MXGKPV) = EN PV(5,MXGKPV) = AMAS PV(6,MXGKPV) = NCH PV(7,MXGKPV) = TOF PV(8,MXGKPV) = KPART PV(9,MXGKPV) = 0. PV(10,MXGKPV)= USERW C --- ADDITIONAL PARAMETERS TO SIMULATE FERMI MOTION AND EVAPORATION --- DO 111 JENP = 1,10 ENP(JENP) = 0. 111 CONTINUE ENP(5) = EK ENP(6) = EN ENP(7) = P IF ( INT .NE. 1 ) GOTO 12 C *** ELASTIC SCATTERING PROCESSES *** C --- ONLY NUCLEAR INTERACTIONS FOR HEAVY FRAGMENTS --- IF ( (KPART .GE. 30) .AND. (KPART .LE. 32) ) GOTO 35 C --- NORMAL ELASTIC SCATTERING FOR LIGHT MEDIA --- IF ( ATNO2 .LT. 1.5 ) GOTO 35 C --- COHERENT ELASTIC SCATTERING FOR HEAVY MEDIA --- IF ( NPRT(9) ) WRITE(MDEBUG,2002) 2002 FORMAT(' *CGHEI* SUBROUT. COSCAT WILL BE CALLED') CALL COSCAT GOTO 40 C *** NON-ELASTIC SCATTERING PROCESSES *** 12 CONTINUE C --- ONLY NUCLEAR INTERACTIONS FOR HEAVY FRAGMENTS --- IF ( (KPART .GE. 30) .AND. (KPART .LE. 32) ) GOTO 35 C *** USE SOMETIMES NUCLEAR REACTION SUBROUT. "NUCREC" FOR LOW ENERGY C *** PROTON AND NEUTRON SCATTERING *** CALL GRNDM(RNDM,1) TEST1 = RNDM(1) TEST2 = 4.5*(EK-0.01) IF ( (KPART .EQ. 14) .AND. (TEST1 .GT. TEST2) ) GOTO 85 IF ( (KPART .EQ. 16) .AND. (TEST1 .GT. TEST2) ) GOTO 86 C *** FERMI MOTION AND EVAPORATION *** TKIN = CINEMA(EK) PV(9,MXGKPV) = TKIN ENP(5) = EK+TKIN C --- CHECK FOR LOWERBOUND OF EKIN IN CROSS-SECTION TABLES --- IF ( ENP(5) .LE. TEKLOW ) ENP(5)=TEKLOW ENP(6) = ENP(5)+ABS(AMAS) ENP(7) = (ENP(6)-AMAS)*(ENP(6)+AMAS) ENP(7) = SQRT(ABS(ENP(7))) TKIN = FERMIG(ENP(5)) ENP(5) = ENP(5)+TKIN C --- CHECK FOR LOWERBOUND OF EKIN IN CROSS-SECTION TABLES --- IF ( ENP(5) .LE. TEKLOW ) ENP(5)=TEKLOW ENP(6) = ENP(5)+ABS(AMAS) ENP(7) = (ENP(6)-AMAS)*(ENP(6)+AMAS) ENP(7) = SQRT(ABS(ENP(7))) TKIN = EXNU(ENP(5)) ENP(5) = ENP(5)-TKIN C --- CHECK FOR LOWERBOUND OF EKIN IN CROSS-SECTION TABLES --- IF ( ENP(5) .LE. TEKLOW ) ENP(5)=TEKLOW ENP(6) = ENP(5)+ABS(AMAS) ENP(7) = (ENP(6)-AMAS)*(ENP(6)+AMAS) ENP(7) = SQRT(ABS(ENP(7))) C *** IN CASE OF ENERGY ABOVE CUT-OFF LET THE PARTICLE CASCADE *** IF ( ENP(5) .GT. ELCUT(1) ) GOTO 35 C --- SECOND CHANCE FOR ANTI-BARYONS DUE TO POSSIBLE ANNIHILATION --- IF ( (AMAS .GE. 0.0) .OR. (KPART .LE. 14) ) GOTO 13 ANNI = 1.3*P IF ( ANNI .GT. 0.4 ) ANNI=0.4 CALL GRNDM(RNDM,1) TEST = RNDM(1) IF ( TEST .GT. ANNI ) GOTO 35 C *** PARTICLE WITH ENERGY BELOW CUT-OFF *** C --- ==> ONLY NUCLEAR EVAPORATION AND QUASI-ELASTIC SCATTERING --- 13 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,1002) * KPART,EK,EN,P,ENP(5),ENP(6),ENP(7) 1002 FORMAT(' *CGHEI* ENERGY BELOW CUT-OFF FOR GHEISHA PARTICLE ',I3/ $ ' EK,EN,P,ENP(5),ENP(6),ENP(7) = ',6(G12.5,1X)) IF ( (KPART .NE. 14) .AND. (KPART .NE. 16) ) GOTO 14 IF ( KPART .EQ. 16 ) GOTO 86 C --- SLOW PROTON --- 85 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,2003) EK,KPART 2003 FORMAT(' *CGHEI* SUBROUT. NUCREC WILL BE CALLED', $ ' EK = ',G12.5,' GEV KPART = ',I3) CALL NUCREC(NOPT,2) IF ( NOPT .NE. 0 ) GOTO 50 IF ( NPRT(9) ) WRITE(MDEBUG,2004) EK,KPART 2004 FORMAT(' *CGHEI* SUBROUT. COSCAT WILL BE CALLED', $ ' EK = ',G12.5,' GEV KPART = ',I3) CALL COSCAT GOTO 40 C --- SLOW NEUTRON --- 86 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,2015) NUCFLG = 0 CALL GNSLWD(NUCFLG,INT,NFL,TEKLOW) IF ( NUCFLG .NE. 0 ) GOTO 50 GOTO 40 C --- OTHER SLOW PARTICLES --- 14 CONTINUE IPA(1) = KPART C --- DECIDE FOR PROTON OR NEUTRON TARGET --- IPA(2) = 16 CALL GRNDM(RNDM,1) TEST1 = RNDM(1) TEST2 = ZNO2/ATNO2 IF ( TEST1 .LT. TEST2 ) IPA(2) = 14 AVERN = 0.0 NFL = 1 IF ( IPA(2) .EQ. 16 ) NFL = 2 IPPP = KPART IF ( NPRT(9) ) WRITE(MDEBUG,2005) 2005 FORMAT(' *CGHEI* SUBROUT. TWOB WILL BE CALLED') CALL TWOB(IPPP,NFL,AVERN) GOTO 40 C --- INITIALIZATION OF CASCADE QUANTITIES --- 35 CONTINUE C *** CASCADE GENERATION *** C --- CALCULATE FINAL STATE MULTIPLICITY AND LONGITUDINAL AND --- C --- TRANSVERSE MOMENTUM DISTRIBUTIONS --- C --- FIXED PARTICLE TYPE TO STEER THE CASCADE --- KKPART = KPART C --- NO CASCADE FOR LEPTONS --- IF ( KKPART .LE. 6 ) GOTO 9999 C *** WHAT TO DO WITH "NEW PARTICLES" FOR GHEISHA ?????? *** C --- RETURN FOR THE TIME BEING --- IF ( KKPART .GE. 35 ) GOTO 9999 C --- CASCADE OF HEAVY FRAGMENTS IF ( (KKPART .GE. 30) .AND. (KKPART .LE. 32) ) GOTO 390 C --- INITIALIZE THE IPA ARRAY --- * CALL VZERO(IPA(1),MXGKCU) CDH DO III = 1, MXGKCU IPA(III) = 0 ENDDO C --- CASCADE OF OMEGA - AND OMEGA - BAR --- IF ( KKPART .EQ. 33 ) GOTO 330 IF ( KKPART .EQ. 34 ) GOTO 331 NVEPAR = KKPART-17 IF ( NVEPAR .LE. 0 ) GOTO 15 GOTO (318,319,320,321,322,323,324,325,326,327,328,329),NVEPAR 15 CONTINUE NVEPAR = KKPART-6 GOTO (307,308,309,310,311,312,313,314,315,316,317,318),NVEPAR C --- PI+ CASCADE --- 307 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,2006) 2006 FORMAT(' *CGHEI* SUBROUT. CASPIP WILL BE CALLED') CALL CASPIP(J,INT,NFL) GOTO 40 C --- PI0 ==> NO CASCADE --- 308 CONTINUE GOTO 40 C --- PI- CASCADE --- 309 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,2007) 2007 FORMAT(' *CGHEI* SUBROUT. CASPIM WILL BE CALLED') CALL CASPIM(J,INT,NFL) GOTO 40 C --- K+ CASCADE --- 310 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,2008) 2008 FORMAT(' *CGHEI* SUBROUT. CASKP WILL BE CALLED') CALL CASKP(J,INT,NFL) GOTO 40 C --- K0 CASCADE --- 311 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,2009) 2009 FORMAT(' *CGHEI* SUBROUT. CASK0 WILL BE CALLED') CALL CASK0(J,INT,NFL) GOTO 40 C --- K0 BAR CASCADE --- 312 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,2010) 2010 FORMAT(' *CGHEI* SUBROUT. CASK0B WILL BE CALLED') CALL CASK0B(J,INT,NFL) GOTO 40 C --- K- CASCADE --- 313 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,2011) 2011 FORMAT(' *CGHEI* SUBROUT. CASKM WILL BE CALLED') CALL CASKM(J,INT,NFL) GOTO 40 C --- PROTON CASCADE --- 314 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,2012) 2012 FORMAT(' *CGHEI* SUBROUT. CASP WILL BE CALLED') CALL CASP(J,INT,NFL) GOTO 40 C --- PROTON BAR CASCADE --- 315 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,2013) 2013 FORMAT(' *CGHEI* SUBROUT. CASPB WILL BE CALLED') CALL CASPB(J,INT,NFL) GOTO 40 C --- NEUTRON CASCADE --- 316 CONTINUE NUCFLG = 0 IF ( EK .GT. SWTEKN ) THEN CALL CASN(J,INT,NFL) IF ( NPRT(9) ) WRITE(MDEBUG,2014) 2014 FORMAT(' *CGHEI* SUBROUT. CASN WILL BE CALLED') ELSE CALL GNSLWD(NUCFLG,INT,NFL,TEKLOW) IF ( NPRT(9) ) WRITE(MDEBUG,2015) 2015 FORMAT(' *CGHEI* SUBROUT. GNSLWD WILL BE CALLED') ENDIF IF ( NUCFLG .NE. 0 ) GOTO 50 GOTO 40 C --- NEUTRON BAR CASCADE --- 317 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,2016) 2016 FORMAT(' *CGHEI* SUBROUT. CASNB WILL BE CALLED') CALL CASNB(J,INT,NFL) GOTO 40 C --- LAMBDA CASCADE --- 318 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,2017) 2017 FORMAT(' *CGHEI* SUBROUT. CASL0 WILL BE CALLED') CALL CASL0(J,INT,NFL) GOTO 40 C --- LAMBDA BAR CASCADE --- 319 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,2018) 2018 FORMAT(' *CGHEI* SUBROUT. CASAL0 WILL BE CALLED') CALL CASAL0(J,INT,NFL) GOTO 40 C --- SIGMA + CASCADE --- 320 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,2019) 2019 FORMAT(' *CGHEI* SUBROUT. CASSP WILL BE CALLED') CALL CASSP(J,INT,NFL) GOTO 40 C --- SIGMA 0 ==> NO CASCADE --- 321 CONTINUE GOTO 40 C --- SIGMA - CASCADE --- 322 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,2020) 2020 FORMAT(' *CGHEI* SUBROUT. CASSM WILL BE CALLED') CALL CASSM(J,INT,NFL) GOTO 40 C --- SIGMA + BAR CASCADE --- 323 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,2021) 2021 FORMAT(' *CGHEI* SUBROUT. CASASP WILL BE CALLED') CALL CASASP(J,INT,NFL) GOTO 40 C --- SIGMA 0 BAR ==> NO CASCADE --- 324 CONTINUE GOTO 40 C --- SIGMA - BAR CASCADE --- 325 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,2022) 2022 FORMAT(' *CGHEI* SUBROUT. CASASM WILL BE CALLED') CALL CASASM(J,INT,NFL) GOTO 40 C --- XI 0 CASCADE --- 326 CONTINUE IF ( NPRT(9) ) PRINT 2023 2023 FORMAT(' *CGHEI* SUBROUT. CASX0 WILL BE CALLED') CALL CASX0(J,INT,NFL) GOTO 40 C --- XI - CASCADE --- 327 CONTINUE IF ( NPRT(9) ) PRINT 2024 2024 FORMAT(' *CGHEI* SUBROUT. CASXM WILL BE CALLED') CALL CASXM(J,INT,NFL) GOTO 40 C --- XI 0 BAR CASCADE --- 328 CONTINUE IF ( NPRT(9) ) PRINT 2025 2025 FORMAT(' *CGHEI* SUBROUT. CASAX0 WILL BE CALLED') CALL CASAX0(J,INT,NFL) GOTO 40 C --- XI - BAR CASCADE --- 329 CONTINUE IF ( NPRT(9) ) PRINT 2026 2026 FORMAT(' *CGHEI* SUBROUT. CASAXM WILL BE CALLED') CALL CASAXM(J,INT,NFL) GOTO 40 C --- OMEGA - CASCADE --- 330 CONTINUE IF ( NPRT(9) ) PRINT 2027 2027 FORMAT(' *CGHEI* SUBROUT. CASOM WILL BE CALLED') CALL CASOM(J,INT,NFL) GOTO 40 C --- OMEGA - BAR CASCADE --- 331 CONTINUE IF ( NPRT(9) ) PRINT 2028 2028 FORMAT(' *CGHEI* SUBROUT. CASAOM WILL BE CALLED') CALL CASAOM(J,INT,NFL) GOTO 40 C --- HEAVY FRAGMENT CASCADE --- 390 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,2090) 2090 FORMAT(' *CGHEI* SUBROUT. CASFRG WILL BE CALLED') NUCFLG = 0 CALL CASFRG(NUCFLG,INT,NFL) IF ( NUCFLG .NE. 0 ) GOTO 50 C *** CHECK WHETHER THERE ARE NEW PARTICLES GENERATED *** 40 CONTINUE IF ( (NTOT .NE. 0) .OR. (KKPART .NE. KPART) ) GOTO 50 50 CONTINUE NVEDUM=KIPART(IPART) IF ( NPRT(9) ) WRITE(MDEBUG,1004)NTOT,IPART,KPART,KKPART,NVEDUM 1004 FORMAT(' *CGHEI* SEC. GEN. NTOT,IPART,KPART,KKPART,KIPART = ', $ 5(I3,1X)) C --- INITIAL PARTICLE TYPE HAS BEEN CHANGED ==> PUT NEW TYPE ON --- C --- THE TEMPORARY STACK --- C --- MAKE CHOICE BETWEEN K0 LONG / K0 SHORT --- IF ( (KPART .NE. 11) .AND. (KPART .NE. 12) ) GOTO 52 CALL GRNDM(RNDM,1) KPART = 11.5+RNDM(1) 52 CONTINUE C --- IN CASE THE NEW PARTICLE IS A NEUTRINO ==> FORGET IT --- IF ( KPART .EQ. 2 ) GOTO 60 C --- PUT CURRENT GHEISHA PARTICLE ON THE CORSIKA STACK C --- ( IF SURVIVING ANGLE CUT ! ) NGKINE = 1 C --- CALCULATE ELASTICITY IF ( EN .GT. EMAX ) THEN EMAX = EN ENDIF ITY=IKPART(KPART) C OLD COUPLING C SECPAR(3) = -PZ C IF ( SECPAR(3) .GT. C(29) ) THEN IF ( ITY .LT. 45 ) THEN SECPAR(1) = DBLE(ITY) ELSEIF ( ITY .EQ. 45 ) THEN SECPAR(1) = 201.D0 ELSEIF ( ITY .EQ. 46 ) THEN SECPAR(1) = 301.D0 ELSEIF ( ITY .EQ. 47 ) THEN SECPAR(1) = 402.D0 ENDIF IF ( ABS(AMAS) .LT. 1.E-9 ) THEN SECPAR(2) = EN ELSE SECPAR(2) = DBLE(EN) / DBLE(ABS(AMAS)) ENDIF IF ( ITY .EQ. 13 .OR. ITY .EQ. 14 ) THEN ETOT = ETOT + (SECPAR(2) - 1.D0) * PAMA(ITY) ELSEIF ( ITY .EQ. 15 .OR. ITY .EQ. 25 ) THEN ETOT = ETOT + (SECPAR(2) + 1.D0) * PAMA(ITY) ELSE ETOT = ETOT + EN ENDIF C NEW COUPLING WITH CORSIKA D. HECK DEC. 2000 THETG = -PZ IF ( PX .NE. 0. .OR. PY .NE. 0. ) THEN PHIG = ATAN2( DBLE(PY), DBLE(PX) ) + PHIRAN ELSE PHIG = 0.D0 + PHIRAN ENDIF CALL ADDANG( CURPAR(3),CURPAR(4),THETG,PHIG, SECPAR(3),SECPAR(4)) C CHECK WETHER PARTICLE SURVIVES ANGULAR CUT IF ( SECPAR(3) .GT. C(29) ) THEN CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( ITY .EQ. 1 ) THEN DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + EN ELSEIF ( ITY .EQ. 2 ) THEN DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + EN + PAMA(2) ELSEIF ( ITY .EQ. 3 ) THEN DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + EN - PAMA(2) ELSEIF ( ITY .EQ. 5 .OR. ITY .EQ. 6 ) THEN DLONG(LHEIGH,5) = DLONG(LHEIGH,5) + EN ELSEIF ( ITY .GE. 7 ) THEN DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + EN - RESTMS(ITY) ENDIF ENDIF ENDIF C *** CHECK WHETHER SECONDARIES HAVE BEEN GENERATED AND COPY THEM *** C *** ALSO ON THE GEANT STACK *** 60 CONTINUE C --- ALL QUANTITIES ARE TAKEN FROM THE GHEISHA STACK WHERE THE --- C --- CONVENTION IS THE FOLLOWING --- C C EVE(INDEX+ 1)= X C EVE(INDEX+ 2)= Y C EVE(INDEX+ 3)= Z C EVE(INDEX+ 4)= NCAL C EVE(INDEX+ 5)= NCELL C EVE(INDEX+ 6)= MASS C EVE(INDEX+ 7)= CHARGE C EVE(INDEX+ 8)= TOF C EVE(INDEX+ 9)= PX C EVE(INDEX+10)= PY C EVE(INDEX+11)= PZ C EVE(INDEX+12)= TYPE IF ( NTOT .LE. 0 ) GOTO 9999 C --- ONE OR MORE SECONDARIES HAVE BEEN GENERATED --- DO 61 L = 1,NTOT INDEX = (L-1)*12 JND = EVE(INDEX+12) C --- MAKE CHOICE BETWEEN K0 LONG / K0 SHORT --- IF ( (JND .NE. 11) .AND. (JND .NE. 12) ) GOTO 63 CALL GRNDM(RNDM,1) JND = 11.5+RNDM(1) C --- FORGET ABOUT NEUTRINOS --- 63 CONTINUE IF ( JND .EQ. 2 ) GOTO 61 C --- SWITCH TO CORSIKA QUANTITIES --- ITY = IKPART(JND) IF (NPRT(9)) WRITE(MDEBUG,1006) ITY,NGKINE,L,(EVE(INDEX+J),J=1,12) 1006 FORMAT(' *CGHEI* GEANT PART. ',I3,' ALSO PUT ONTO STACK AT', $ ' POS. ',I3/ $ ' EVE(',I2,') = ',(' ',10G12.5)) PLX = EVE(INDEX+9) PLY = EVE(INDEX+10) PLZ = EVE(INDEX+11) PLSQ = PLX**2 + PLY**2 + PLZ**2 PLTOT = SQRT (PLSQ) RMASSK = ABS(RMASS(JND)) C FIND HIGHEST ENERGY PARTICLE FOR ELASTICITY EEESQ = PLSQ + RMASSK**2 IF ( EEESQ .GT. EMAX**2 ) THEN EMAX = SQRT(EEESQ) ENDIF C --- APPLY ANGLE CUT AND C --- ADD PARTICLE TO THE CORSIKA STACK (RESTRICTED TO 100) --- IF ( PLTOT .LE. 1.D-10 ) GOTO 61 C SECPAR(3) = (-PLZ) / PLTOT THETG = (-PLZ) / PLTOT IF ( RMASSK .LT. 1.D-9 ) THEN SECPAR(2) = PLTOT ELSE SECPAR(2) = SQRT (PLSQ+RMASSK**2) / RMASSK ENDIF IF ( ITY .LT. 45 ) THEN SECPAR(1) = DBLE(ITY) ELSEIF ( ITY .EQ. 45 ) THEN SECPAR(1) = 201.D0 ELSEIF ( ITY .EQ. 46 ) THEN SECPAR(1) = 301.D0 ELSEIF ( ITY .EQ. 47 ) THEN SECPAR(1) = 402.D0 ELSE SECPAR(1) = 0.D0 WRITE(MONIOU,*) '*CGHEI* ILLEGAL PARTICLE TYPE',ITY ENDIF C --- COUNTERS FOR FIRST INTERACTION ITY = SECPAR(1) IF ( ITY .EQ. 1 ) THEN ETOT = ETOT + SQRT(EEESQ) ELSEIF ( ITY .EQ. 13 .OR. ITY .EQ. 14 ) THEN ETOT = ETOT + (SECPAR(2) - 1.D0) * PAMA(ITY) ELSEIF ( ITY .EQ. 15 .OR. ITY .EQ. 25 ) THEN ETOT = ETOT + (SECPAR(2) + 1.D0) * PAMA(ITY) ELSE ETOT = ETOT + SECPAR(2) * PAMA(ITY) ENDIF IF ( FIRSTI ) THEN IF ( ITY .EQ. 7 .OR. ITY .EQ. 8 .OR. * ITY .EQ. 9 ) THEN IFINPI = IFINPI + 1 ELSEIF ( ITY .EQ. 13 .OR. ITY .EQ. 14 .OR. * ITY .EQ. 15 .OR. ITY .EQ. 25 ) THEN IFINNU = IFINNU + 1 ELSEIF ( ITY .EQ. 10 .OR. ITY .EQ. 11 .OR. * ITY .EQ. 12 .OR. ITY .EQ. 16 ) THEN IFINKA = IFINKA + 1 ELSEIF ( ITY .EQ. 17 ) THEN IFINET = IFINET + 1 ELSEIF ( (ITY .GE. 18 .AND. ITY .LE. 24) .OR. * (ITY .GE. 26 .AND. ITY .LE. 32) ) THEN IFINHY = IFINHY + 1 ENDIF ENDIF C OLD COUPLING C IF ( SECPAR(3) .GT. C(29) ) THEN C NEW COUPLING WITH CORSIKA D. HECK DEC. 2000 IF ( NGKINE .GE. MXGKGH ) GOTO 9999 NGKINE = NGKINE+1 IF ( PLX .NE. 0.D0 .OR. PLY .NE. 0.D0 ) THEN PHIG = ATAN2( PLY, PLX ) + PHIRAN ELSE PHIG = 0.D0 + PHIRAN ENDIF CALL ADDANG( CURPAR(3),CURPAR(4),THETG,PHIG, SECPAR(3),SECPAR(4)) C CHECK WETHER PARTICLE SURVIVES ANGULAR CUT IF ( SECPAR(3) .GT. C(29) ) THEN CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( ITY .EQ. 1 ) THEN DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + SECPAR(2) ELSEIF ( ITY .EQ. 2 ) THEN DLONG(LHEIGH,3) = DLONG(LHEIGH,3) * + (SECPAR(2)+1.D0)*PAMA(2) ELSEIF ( ITY .EQ. 3 ) THEN DLONG(LHEIGH,3) = DLONG(LHEIGH,3) * + (SECPAR(2)-1.D0)*PAMA(2) ELSEIF ( ITY .EQ. 5 .OR. ITY .EQ. 6 ) THEN DLONG(LHEIGH,5) = DLONG(LHEIGH,5) + SECPAR(2)*PAMA(5) ELSEIF ( ITY .GE. 7 ) THEN DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + SECPAR(2)*PAMA(ITY) * - RESTMS(ITY) ENDIF ENDIF ENDIF 61 CONTINUE C --- COUNTER FOR ENERGY-MULTIPLICITY MATRIX MSMM = MSMM + NTOT C --- FILL ELASTICITY IN MATRICES ELASTI = EMAX/ENOLD MELL = MIN ( 1.D0+10.D0* MAX( 0.D0, ELASTI ) , 11.D0 ) MEN = MIN ( 4.D0+ 3.D0*LOG10(MAX( .1D0, EKINL )), 40.D0 ) IELDPM(MEN,MELL) = IELDPM(MEN,MELL) + 1 IELDPA(MEN,MELL) = IELDPA(MEN,MELL) + 1 IF ( ELASTI .LT. 1. ) THEN ELMEAN(MEN) = ELMEAN(MEN) + ELASTI ELMEAA(MEN) = ELMEAA(MEN) + ELASTI ENDIF IF ( FIRSTI ) THEN TARG1I = ATNO2 SIG1I = SIGAIR ELAST = ELASTI FIRSTI = .FALSE. ENDIF IF ( DEBUG ) WRITE(MDEBUG,*)'CGHEI : EXIT WITH ETOT=',SNGL(ETOT) 9999 CONTINUE C --- LIMIT THE VALUE OF NGKINE IN CASE OF OVERFLOW --- NGKINE = MIN(NGKINE,MXGKGH) RETURN END *CMZ : 28/02/2002 11.42.37 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE CGHINI C----------------------------------------------------------------------- C C(ORSIKA) GH(EISHA) INI(TIALIZATION) C INITIALIZATION OF RELEVANT GHEISHA VARIABLES C THIS SUBROUTINE IS CALLED FROM START. C C ORIGIN : GHEISHA SUBROUT. "GHEINI", F.CARMINATI C REDESIGN: P. GABRIEL IK1 FZK KARLSRUHE C----------------------------------------------------------------------- *KEEP,AIR. COMMON /AIR/ COMPOS,PROBTA,AVERAW,AVOGAD DOUBLE PRECISION COMPOS(3),PROBTA(3),AVERAW,AVOGAD *KEEP,CGCOMP. PARAMETER (KK=3) COMMON/CGCOMP/ ACOMP,ZCOMP,WCOMP REAL ACOMP(KK),ZCOMP(KK),WCOMP(KK) *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. COMMON/GSECTI/ AIEL(20),AIIN(20),AIFI(20),AICA(20),ALAM,K0FLAG INTEGER K0FLAG REAL AIEL,AIIN,AIFI,AICA,ALAM C --- GHEISHA COMMONS --- C --- INITIALIZATION FLAGS FOR VARIOUS GHEISHA ROUTINES --- COMMON /KGINIT/ KGINIT(50) COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI, $ SMU,CT,CTKCH,CTK0, $ ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM, $ RMASS(35),RCHARG(35) REAL MP,MPI,MMU,MEL,MKCH,MK0, * ML0,MSP,MS0,MSM,MX0,MXM PARAMETER (MXGKGH=100) PARAMETER (MXEVEN=12*MXGKGH) COMMON/EVENT / NSIZE,NCUR,NEXT,NTOT,EVE(MXEVEN) COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT PARAMETER (MXGKPV=MXGKGH) COMMON /VECUTY/ PV(10,MXGKPV) C --- BOUNDARY LIMITS FOR ARGUMENTS OF INTRINSIC FUNCTIONS --- C --- XL DENOTES LOWER BOUND WHEREAS XU DENOTES UPPER BOUND --- COMMON /LIMITS/ EXPXL,EXPXU C --- "NEVENT" CHANGED TO "KEVENT" IN COMMON /CURPAR/ DUE TO CLASH --- C --- WITH VARIABLE "NEVENT" IN GEANT COMMON --- PARAMETER (MXGKCU=MXGKGH) COMMON /CURPAR/ WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,KEVENT,SHFLAG, $ ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5), $ RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU), $ ATNO2,ZNO2 SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'CGHINI:' C --- INITIALIZE COMPOSITION OF AIR WCOMP(1) = COMPOS(1) WCOMP(2) = COMPOS(2) WCOMP(3) = COMPOS(3) ACOMP(1) = 14. ACOMP(2) = 16. ACOMP(3) = 40. ZCOMP(1) = 7. ZCOMP(2) = 8. ZCOMP(3) = 18. C --- SET GHEISHA I/O UNITS TO THE SAME AS FOR CORSIKA -- INBCD = MONIIN NEWBCD = MONIOU IF ( DEBUG .OR. DEBDEL ) NEWBCD = MDEBUG C --- INITIALIZE ALL GHEISHA PRINT FLAGS AS FALSE --- C --- ACTIVATION IS DONE BY "DEBUG" STEERING CARD --- DO 11 J = 1,10 NPRT(J)=.FALSE. 11 CONTINUE IF ( DEBUG .AND. GHEISDB ) THEN NPRT(4)=.TRUE. NPRT(9)=.TRUE. ELSE NPRT(4)=.FALSE. NPRT(9)=.FALSE. ENDIF LPRT=.FALSE. DO 12 I = 1,MXGKPV DO 12 J = 1,10 PV(J,I)=0. 12 CONTINUE C --- INITIALIZE KGINIT ARRAY --- DO 20 J = 1,50 KGINIT(J)=0 20 CONTINUE C --- INITIALIZE SOME CUT-OFF PARAMETERS WITH GEANT VALUES --- TOFCUT=1.0E+20 NSIZE=MXEVEN K0FLAG=0 CENG(3)=0. CENG(4)=0. C --- INITIALIZE PI, 2*PI, PI/2 AND PARTICLE PARAMETERS --- PI=ACOS(-1.0) TWPI=2.0*PI PIBTW=PI/2.0 C *** GAMMA *** RMASS(1)=PAMA(1) RCHARG(1)=0.0 C *** NEUTRINO *** RMASS(2)=PAMA(4) RCHARG(2)=0.0 C *** E+ *** RMASS(3)=PAMA(2) RCHARG(3)=1.0 C *** E- *** RMASS(4)=PAMA(3) RCHARG(4)=-1.0 C *** MU+ *** RMASS(5)=PAMA(5) RCHARG(5)=1.0 C *** MU- *** RMASS(6)=PAMA(6) RCHARG(6)=-1.0 C *** PI+ *** RMASS(7)=PAMA(8) RCHARG(7)=1.0 CT=780.4 C *** PI0 *** RMASS(8)=PAMA(7) RCHARG(8)=0.0 C *** PI- *** RMASS(9)=PAMA(9) RCHARG(9)=-1.0 C *** K+ *** RMASS(10)=PAMA(11) RCHARG(10)=1.0 CTKCH=370.9 C *** K0 SHORT (==> K0) *** RMASS(11)=PAMA(16) RCHARG(11)=0.0 CTK0=2.675 C *** K0 LONG (==> K0 BAR) *** RMASS(12)=-PAMA(10) RCHARG(12)=0.0 C *** K- *** RMASS(13)=PAMA(12) RCHARG(13)=-1.0 C *** P *** RMASS(14)=PAMA(14) RCHARG(14)=1.0 C *** P BAR *** RMASS(15)=-PAMA(15) RCHARG(15)=-1.0 C *** N *** RMASS(16)=PAMA(13) RCHARG(16)=0.0 C *** N BAR *** RMASS(17)=-PAMA(25) RCHARG(17)=0.0 C *** L0 *** RMASS(18)=PAMA(18) RCHARG(18)=0.0 CTL0=7.89 C *** L0 BAR *** RMASS(19)=-PAMA(26) RCHARG(19)=0.0 C *** S+ *** RMASS(20)=PAMA(19) RCHARG(20)=1.0 CTSP=2.40 C *** S0 *** RMASS(21)=PAMA(20) RCHARG(21)=0.0 C *** S- *** RMASS(22)=PAMA(21) RCHARG(22)=-1.0 CTSM=4.44 C *** S+ BAR *** RMASS(23)=-PAMA(27) RCHARG(23)=-1.0 C *** S0 BAR *** RMASS(24)=-PAMA(28) RCHARG(24)=0.0 C *** S- BAR *** RMASS(25)=-PAMA(29) RCHARG(25)=1.0 C *** XI0 *** RMASS(26)=PAMA(22) RCHARG(26)=0.0 CTX0=8.69 C *** XI- *** RMASS(27)=PAMA(23) RCHARG(27)=-1.0 CTXM=4.92 C *** XI0 BAR *** RMASS(28)=-PAMA(30) RCHARG(28)=0.0 CTX0=8.69 C *** XI- BAR *** RMASS(29)=-PAMA(31) RCHARG(29)=1.0 C *** DEUTERON *** RMASS(30)=PAMA(45) RCHARG(30)=1.0 C *** TRITON *** RMASS(31)=PAMA(46) RCHARG(31)=1.0 C *** ALPHA *** RMASS(32)=PAMA(47) RCHARG(32)=2.0 C *** OMEGA- *** RMASS(33)=PAMA(24) RCHARG(33)=-1.0 C *** OMEGA- BAR *** RMASS(34)=-PAMA(32) RCHARG(34)=1.0 C *** NEW PARTICLE (GEANTINO) *** RMASS(35)=0.0 RCHARG(35)=0.0 IF ( NPRT(9) ) $ WRITE(MDEBUG,1000) (I,RMASS(I),RCHARG(I),I=1,33), $ CT,CTKCH,CTK0,CTL0,CTSP,CTSM,CTX0,CTXM 1000 FORMAT(' *CGHINI* === GHEISHA PARTICLE PROPERTIES ==='/ $ '0INDEX',5X,'MASS (GEV)',5X,'CHARGE'/1H / $ 33(1H ,1X,I3,5X,F11.6,6X,F5.2/), $ '0PI +- CT = ',G12.5,' K +- CT = ',G12.5/ $ ' K0 CT = ',G12.5,' L0 CT = ',G12.5/ $ ' S+ CT = ',G12.5,' S- CT = ',G12.5/ $ ' X0 CT = ',G12.5,' X- CT = ',G12.5) MP = RMASS(14) MPI = RMASS(7) MMU = RMASS(5) MEL = RMASS(3) MKCH = RMASS(10) MK0 = RMASS(11) SMP = MP**2 SMPI = MPI**2 SMU = MMU**2 ML0 = RMASS(18) MSP = RMASS(20) MS0 = RMASS(21) MSM = RMASS(22) MX0 = RMASS(26) MXM = RMASS(27) C --- LOAD LIMITS FOR INTRINSIC FUNCTION ARGUMENTS --- EXPXL = -82.0 EXPXU = 82.0 IF ( NPRT(9) ) WRITE(MDEBUG,1001) EXPXL,EXPXU 1001 FORMAT(' *GHEINI* === INTRINSIC FUNCTION BOUNDARIES ==='/ $ ' EXPXL,EXPXU = ',2(G12.5,1X)) RETURN END *CMZ : 28/02/2002 11.42.37 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= DOUBLE PRECISION FUNCTION CGHSIG( PPART,EKIN,LPART ) C----------------------------------------------------------------------- C C(ORSIKA) GH(EISHA) SIG(MA) C C CALCULATION OF THE PROBABILITIES FOR (IN)ELASTIC INTERACTIONS *** C THIS FUNCTION IS CALLED FROM BOX2. C ARGUMENTS: C PPART = R*4 PARTICLE MOMENTUM (GEV) C EKIN = R*4 KINETIC ENERGY (GEV) C LPART = PARTICLE TYPE C C ORIGIN : F.CARMINATI, H.FESEFELDT (SUBROUT. GHESIG) C REDESIGN: P. GABRIEL IK1 FZK KARLSRUHE C----------------------------------------------------------------------- C *** IPART DENOTES THE GHEISHA PARTICLE INDEX *** C C CONVENTION : C C PARTICLE IPART C ------------------------------ C GAMMA 1 C NEUTRINO 2 C POSITRON 3 C ELECTRON 4 C MUON + 5 C MUON - 6 C PION + 7 C PION 0 8 C PION - 9 C KAON + 10 C KAON 0 S 11 C KAON 0 L 12 C KAON - 13 C PROTON 14 C PROTON BAR 15 C NEUTRON 16 C NEUTRON BAR 17 C LAMBDA 18 C LAMBDA BAR 19 C SIGMA + 20 C SIGMA 0 21 C SIGMA - 22 C SIGMA + BAR 23 C SIGMA 0 BAR 24 C SIGMA - BAR 25 C XSI 0 26 C XSI - 27 C XSI 0 BAR 28 C XSI - BAR 29 C DEUTERON 30 C TRITON 31 C ALPHA 32 C OMEGA - 33 C OMEGA - BAR 34 C NEW PARTICLES 35 C C----------------------------------------------------------------------- *KEEP,CGCOMP. PARAMETER (KK=3) COMMON/CGCOMP/ ACOMP,ZCOMP,WCOMP REAL ACOMP(KK),ZCOMP(KK),WCOMP(KK) *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. COMMON/GSECTI/ AIEL(20),AIIN(20),AIFI(20),AICA(20),ALAM,K0FLAG INTEGER K0FLAG REAL AIEL,AIIN,AIFI,AICA,ALAM C --- GHEISHA COMMONS --- COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ, * USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND, * LCALO,ICEL,SINL,COSL,SINP,COSP, * XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD, * XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT REAL NCH,INTCT COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10) LOGICAL LPRT,NPRT DIMENSION ALPHA(35),ALPHAC(41),IPART2(7),CSA(4) DIMENSION PARTEL(35),PARTIN(35),INTRC(35) * DIMENSION ICORR(35) C --- DIMENSION STATEMENTS FOR CROSS-SECTION DATA --- DIMENSION PLAB(41),CSEL(35,41),CSIN(35,41),CSPIEL(3,41), $ CSPIIN(3,41),CSPNEL(3,41),CSPNIN(3,41), $ ELAB(17),CNLWAT(15),CNLWEL(15,17),CNLWIN(15,17), $ CSCAP(100) C --- DIMENSION STMTS. FOR GEANT/GHEISHA PARTICLE CODE CONVERSIONS --- C --- KIPART(I)=GHEISHA CODE CORRESPONDING TO GEANT CODE I --- C --- IKPART(I)=GEANT CODE CORRESPONDING TO GHEISHA CODE I --- DIMENSION KIPART(48) * DIMENSION IKPART(35) SAVE C --- CROSS-SECTION DATA BY "PCSDAT" 01-FEB-1989 --- DATA PLAB / $ 0.00000E+00, 0.10000 , 0.15000 , 0.20000 , 0.25000 , $ 0.30000 , 0.35000 , 0.40000 , 0.45000 , 0.50000 , $ 0.55000 , 0.60000 , 0.65000 , 0.70000 , 0.75000 , $ 0.80000 , 0.85000 , 0.90000 , 0.95000 , 1.0000 , $ 1.1000 , 1.2000 , 1.3000 , 1.4000 , 1.5000 , $ 1.6000 , 1.8000 , 2.0000 , 2.2000 , 2.4000 , $ 2.6000 , 2.8000 , 3.0000 , 4.0000 , 5.0000 , $ 6.0000 , 8.0000 , 10.000 , 20.000 , 100.00 , $ 1000.0 / C ELASTIC SCATTERING CROSS-SECTIONS ON FREE PROTONS C GAMMA, NEUTRINO, POSITRON, ELECTRON, MU(+), MU(-) DATA ((CSEL(I,J),I=1,6),J=1,41) / 246 * 0. / C PI(0) DATA (CSEL( 8,J),J=1,41) / 41 * 0. / C SIGMA(0) DATA (CSEL(21,J),J=1,41) / 41 * 0. / C SIGMA(0)_BAR DATA (CSEL(24,J),J=1,41) / 41 * 0. / C DEUTERIUM, TRITIUM, ALPHA DATA ((CSEL(I,J),I=30,32),J=1,41) / 123 * 0. / C NEW PARTICLES DATA (CSEL(35,J),J=1,41) / 41 * 0. / C PI(+) DATA (CSEL( 7,J),J=1,41) / $ 0.00000E+00, 6.0000 , 20.000 , 71.000 , 155.00 , $ 195.00 , 130.00 , 78.000 , 60.000 , 32.000 , $ 23.500 , 18.500 , 15.000 , 12.500 , 10.000 , $ 9.1000 , 8.6000 , 8.8000 , 9.5000 , 10.600 , $ 13.000 , 15.500 , 17.100 , 17.200 , 16.200 , $ 15.000 , 12.300 , 10.200 , 9.0000 , 8.0000 , $ 7.3000 , 6.8000 , 6.5000 , 5.8000 , 5.4000 , $ 5.2000 , 5.0000 , 4.9000 , 3.8000 , 3.2000 , $ 3.5000 / C PI(-) DATA (CSEL( 9,J),J=1,41) / $ 0.00000E+00, 1.0000 , 3.0000 , 8.0000 , 18.000 , $ 25.000 , 27.500 , 12.300 , 10.600 , 11.000 , $ 12.500 , 14.500 , 17.000 , 19.400 , 19.800 , $ 16.800 , 14.000 , 14.800 , 20.000 , 26.100 , $ 19.500 , 15.000 , 12.800 , 11.500 , 10.500 , $ 9.8000 , 8.8000 , 8.2000 , 7.8000 , 7.5000 , $ 7.2000 , 7.0000 , 6.8000 , 6.1000 , 5.7000 , $ 5.4000 , 4.9000 , 4.6000 , 4.0000 , 3.3000 , $ 3.5000 / C K(+) DATA (CSEL(10,J),J=1,41) / $ 10.000 , 11.200 , 11.300 , 11.400 , 11.500 , $ 11.600 , 11.800 , 12.000 , 12.100 , 12.200 , $ 12.300 , 12.400 , 12.500 , 12.500 , 12.500 , $ 12.400 , 12.300 , 12.200 , 12.000 , 11.800 , $ 11.200 , 11.500 , 9.9000 , 9.4000 , 8.8000 , $ 8.4000 , 7.5000 , 6.9000 , 6.3000 , 5.9000 , $ 5.5000 , 5.2000 , 5.0000 , 4.0000 , 3.5000 , $ 3.3000 , 3.1000 , 3.1000 , 3.0000 , 2.5000 , $ 3.0000 / C K(0) SHORT DATA (CSEL(11,J),J=1,41) / $ 10.000 , 11.200 , 11.300 , 11.400 , 11.500 , $ 11.600 , 11.800 , 12.000 , 12.100 , 12.200 , $ 12.300 , 12.400 , 12.500 , 12.500 , 12.500 , $ 12.400 , 12.300 , 12.200 , 12.000 , 11.800 , $ 11.200 , 11.500 , 9.9000 , 9.4000 , 8.8000 , $ 8.4000 , 7.5000 , 6.9000 , 6.3000 , 5.9000 , $ 5.5000 , 5.2000 , 5.0000 , 4.0000 , 3.5000 , $ 3.3000 , 3.1000 , 3.1000 , 3.0000 , 2.5000 , $ 3.0000 / C K(0) LONG DATA (CSEL(12,J),J=1,41) / $ 160.83 , 82.800 , 58.575 , 43.683 , 34.792 , $ 28.650 , 24.367 , 20.917 , 18.192 , 16.300 , $ 14.608 , 13.017 , 12.250 , 11.700 , 12.017 , $ 14.075 , 15.842 , 16.433 , 16.042 , 15.008 , $ 12.575 , 10.708 , 9.2000 , 8.0167 , 7.2833 , $ 7.0750 , 6.6333 , 6.1250 , 5.6583 , 5.2750 , $ 4.9333 , 4.6250 , 4.4583 , 3.7333 , 3.3833 , $ 3.1833 , 2.9833 , 2.7500 , 2.3667 , 2.2000 , $ 2.6000 / C K(-) DATA (CSEL(13,J),J=1,41) / $ 300.00 , 140.00 , 97.000 , 70.000 , 55.000 , $ 45.000 , 37.000 , 31.000 , 26.000 , 23.000 , $ 20.000 , 17.000 , 15.500 , 14.500 , 14.700 , $ 18.500 , 22.000 , 23.000 , 22.500 , 20.700 , $ 16.500 , 14.000 , 11.500 , 9.6000 , 8.6000 , $ 8.5000 , 8.3000 , 7.6000 , 7.0000 , 6.4000 , $ 5.9000 , 5.5000 , 5.3000 , 4.4000 , 4.1000 , $ 3.9000 , 3.7000 , 3.3000 , 2.6000 , 2.5000 , $ 3.0000 / C PROTON DATA (CSEL(14,J),J=1,41) / $ 1100.0 , 115.00 , 105.00 , 100.00 , 56.000 , $ 40.000 , 27.000 , 22.000 , 21.000 , 20.000 , $ 20.000 , 20.000 , 20.500 , 21.000 , 22.000 , $ 23.000 , 24.000 , 24.000 , 24.400 , 24.500 , $ 25.000 , 25.500 , 26.000 , 26.500 , 27.000 , $ 27.000 , 26.000 , 23.000 , 21.500 , 20.000 , $ 19.000 , 18.000 , 17.000 , 13.000 , 11.500 , $ 10.300 , 9.4000 , 9.0000 , 8.8000 , 7.0000 , $ 7.5000 / C PROTON_BAR DATA (CSEL(15,J),J=1,41) / $ 200.00 , 163.00 , 141.00 , 120.00 , 111.00 , $ 99.500 , 92.500 , 86.500 , 82.000 , 78.000 , $ 74.000 , 71.000 , 67.500 , 65.000 , 62.500 , $ 59.700 , 58.100 , 56.300 , 54.700 , 52.700 , $ 50.000 , 48.400 , 47.000 , 46.000 , 45.200 , $ 42.800 , 39.200 , 36.300 , 32.800 , 30.400 , $ 28.100 , 26.300 , 24.500 , 19.250 , 16.840 , $ 14.600 , 12.340 , 11.210 , 8.8500 , 7.5000 , $ 7.5000 / C NEUTRON DATA (CSEL(16,J),J=1,41) / $ 4200.0 , 440.00 , 420.00 , 400.00 , 230.00 , $ 160.00 , 105.00 , 80.000 , 62.000 , 50.000 , $ 45.000 , 41.000 , 38.000 , 36.000 , 35.000 , $ 34.000 , 33.000 , 32.000 , 31.500 , 31.000 , $ 30.500 , 30.000 , 29.500 , 29.000 , 28.500 , $ 28.000 , 26.000 , 23.000 , 21.500 , 20.000 , $ 19.000 , 18.000 , 17.000 , 13.000 , 11.500 , $ 10.300 , 9.4000 , 9.0000 , 8.8000 , 7.0000 , $ 7.5000 / C NEUTRON_BAR DATA (CSEL(17,J),J=1,41) / $ 185.88 , 133.23 , 119.37 , 102.86 , 93.102 , $ 82.752 , 76.205 , 71.008 , 67.366 , 64.096 , $ 60.891 , 58.501 , 55.735 , 53.773 , 51.839 , $ 49.671 , 48.485 , 47.045 , 45.803 , 44.306 , $ 42.623 , 41.786 , 41.115 , 40.630 , 40.129 , $ 38.242 , 35.233 , 32.662 , 29.639 , 27.573 , $ 25.536 , 23.948 , 22.356 , 17.723 , 15.614 , $ 13.653 , 11.675 , 10.653 , 8.6198 , 7.4464 , $ 7.4821 / C LAMBDA DATA (CSEL(18,J),J=1,41) / $ 1100.0 , 115.00 , 105.00 , 100.00 , 56.000 , $ 40.000 , 27.000 , 22.000 , 21.000 , 20.000 , $ 20.000 , 19.067 , 19.333 , 19.500 , 19.833 , $ 20.567 , 21.800 , 22.900 , 23.869 , 23.809 , $ 22.161 , 21.488 , 19.732 , 19.433 , 19.345 , $ 19.029 , 18.121 , 16.280 , 15.258 , 14.280 , $ 13.644 , 12.963 , 12.316 , 9.5333 , 8.4333 , $ 7.5728 , 6.9696 , 6.7518 , 6.6175 , 5.6000 , $ 6.1145 / C LAMBDA_BAR DATA (CSEL(19,J),J=1,41) / $ 157.65 , 73.701 , 76.096 , 68.571 , 57.305 , $ 49.257 , 43.616 , 40.024 , 38.098 , 36.287 , $ 34.674 , 33.105 , 31.712 , 30.685 , 29.613 , $ 28.602 , 28.336 , 28.075 , 27.786 , 27.215 , $ 26.380 , 26.146 , 25.108 , 24.783 , 24.360 , $ 23.219 , 21.431 , 20.095 , 18.382 , 17.267 , $ 16.100 , 15.175 , 14.271 , 11.573 , 10.305 , $ 9.1471 , 8.0149 , 7.4349 , 6.2499 , 5.8928 , $ 6.0774 / C SIGMA(+) DATA (CSEL(20,J),J=1,41) / $ 1100.0 , 115.00 , 105.00 , 100.00 , 56.000 , $ 40.000 , 27.000 , 22.000 , 21.000 , 20.000 , $ 20.000 , 19.067 , 19.333 , 19.500 , 19.833 , $ 20.567 , 21.800 , 22.900 , 23.869 , 23.809 , $ 22.161 , 21.488 , 19.732 , 19.433 , 19.345 , $ 19.029 , 18.121 , 16.280 , 15.258 , 14.280 , $ 13.644 , 12.963 , 12.316 , 9.5333 , 8.4333 , $ 7.5728 , 6.9696 , 6.7518 , 6.6175 , 5.6000 , $ 6.1145 / C SIGMA(-) DATA (CSEL(22,J),J=1,41) / $ 1100.0 , 115.00 , 105.00 , 100.00 , 56.000 , $ 40.000 , 27.000 , 22.000 , 21.000 , 20.000 , $ 20.000 , 19.067 , 19.333 , 19.500 , 19.833 , $ 20.567 , 21.800 , 22.900 , 23.869 , 23.809 , $ 22.161 , 21.488 , 19.732 , 19.433 , 19.345 , $ 19.029 , 18.121 , 16.280 , 15.258 , 14.280 , $ 13.644 , 12.963 , 12.316 , 9.5333 , 8.4333 , $ 7.5728 , 6.9696 , 6.7518 , 6.6175 , 5.6000 , $ 6.1145 / C SIGMA(+)_BAR DATA (CSEL(23,J),J=1,41) / $ 185.88 , 133.23 , 119.37 , 102.86 , 93.102 , $ 82.752 , 76.205 , 71.008 , 67.366 , 64.096 , $ 60.891 , 58.104 , 55.241 , 53.140 , 50.934 , $ 48.660 , 47.566 , 46.585 , 45.581 , 44.003 , $ 41.134 , 39.374 , 36.878 , 35.523 , 34.503 , $ 32.334 , 29.365 , 27.370 , 24.705 , 22.921 , $ 21.229 , 19.879 , 18.559 , 14.625 , 12.758 , $ 11.041 , 9.3440 , 8.5484 , 6.7104 , 6.0000 , $ 6.1131 / C SIGMA(-)_BAR DATA (CSEL(25,J),J=1,41) / $ 157.65 , 73.701 , 76.096 , 68.571 , 57.305 , $ 49.257 , 43.616 , 40.024 , 38.098 , 36.287 , $ 34.674 , 33.105 , 31.712 , 30.685 , 29.613 , $ 28.602 , 28.336 , 28.075 , 27.786 , 27.215 , $ 26.380 , 26.146 , 25.108 , 24.783 , 24.360 , $ 23.219 , 21.431 , 20.095 , 18.382 , 17.267 , $ 16.100 , 15.175 , 14.271 , 11.573 , 10.305 , $ 9.1471 , 8.0149 , 7.4349 , 6.2499 , 5.8928 , $ 6.0774 / C XI(0) DATA (CSEL(26,J),J=1,41) / $ 1100.0 , 115.00 , 105.00 , 100.00 , 56.000 , $ 40.000 , 27.000 , 22.000 , 21.000 , 20.000 , $ 20.000 , 18.133 , 18.167 , 18.000 , 17.667 , $ 18.133 , 19.600 , 21.800 , 23.338 , 23.118 , $ 19.323 , 17.476 , 13.464 , 12.367 , 11.691 , $ 11.057 , 10.242 , 9.5593 , 9.0151 , 8.5591 , $ 8.2884 , 7.9253 , 7.6311 , 6.0667 , 5.3667 , $ 4.8456 , 4.5392 , 4.5036 , 4.4351 , 4.2000 , $ 4.7289 / C XI(-) DATA (CSEL(27,J),J=1,41) / $ 1100.0 , 115.00 , 105.00 , 100.00 , 56.000 , $ 40.000 , 27.000 , 22.000 , 21.000 , 20.000 , $ 20.000 , 18.133 , 18.167 , 18.000 , 17.667 , $ 18.133 , 19.600 , 21.800 , 23.338 , 23.118 , $ 19.323 , 17.476 , 13.464 , 12.367 , 11.691 , $ 11.057 , 10.242 , 9.5593 , 9.0151 , 8.5591 , $ 8.2884 , 7.9253 , 7.6311 , 6.0667 , 5.3667 , $ 4.8456 , 4.5392 , 4.5036 , 4.4351 , 4.2000 , $ 4.7289 / C XI(0)_BAR DATA (CSEL(28,J),J=1,41) / $ 157.65 , 73.701 , 76.096 , 68.571 , 57.305 , $ 49.257 , 43.616 , 40.024 , 38.098 , 36.287 , $ 34.674 , 32.708 , 31.218 , 30.052 , 28.707 , $ 27.591 , 27.417 , 27.615 , 27.564 , 26.913 , $ 24.891 , 23.734 , 20.871 , 19.677 , 18.734 , $ 17.311 , 15.563 , 14.803 , 13.448 , 12.615 , $ 11.794 , 11.106 , 10.474 , 8.4745 , 7.4498 , $ 6.5350 , 5.6835 , 5.3300 , 4.3406 , 4.4464 , $ 4.7083 / C XI(-)_BAR DATA (CSEL(29,J),J=1,41) / $ 143.53 , 43.935 , 54.462 , 51.429 , 39.407 , $ 32.510 , 27.321 , 24.532 , 23.465 , 22.383 , $ 21.566 , 20.209 , 19.453 , 18.825 , 18.046 , $ 17.562 , 17.802 , 18.360 , 18.667 , 18.519 , $ 17.514 , 17.120 , 14.985 , 14.306 , 13.663 , $ 12.753 , 11.596 , 11.165 , 10.287 , 9.7882 , $ 9.2294 , 8.7539 , 8.3300 , 6.9480 , 6.2234 , $ 5.5881 , 5.0189 , 4.7733 , 4.1104 , 4.3929 , $ 4.6905 / C OMEGA(-) DATA (CSEL(33,J),J=1,41) / $ 1100.0 , 115.00 , 105.00 , 100.00 , 56.000 , $ 40.000 , 27.000 , 22.000 , 21.000 , 20.000 , $ 20.000 , 18.133 , 18.167 , 18.000 , 17.667 , $ 18.133 , 19.600 , 21.800 , 23.338 , 23.118 , $ 19.323 , 17.476 , 13.464 , 12.367 , 11.691 , $ 11.057 , 10.242 , 9.5593 , 9.0151 , 8.5591 , $ 8.2884 , 7.9253 , 7.6311 , 6.0667 , 5.3667 , $ 4.8456 , 4.5392 , 4.5036 , 4.4351 , 4.2000 , $ 4.7289 / C OMEGA(-)_BAR DATA (CSEL(34,J),J=1,41) / $ 143.53 , 43.935 , 54.462 , 51.429 , 39.407 , $ 32.510 , 27.321 , 24.532 , 23.465 , 22.383 , $ 21.566 , 20.209 , 19.453 , 18.825 , 18.046 , $ 17.562 , 17.802 , 18.360 , 18.667 , 18.519 , $ 17.514 , 17.120 , 14.985 , 14.306 , 13.663 , $ 12.753 , 11.596 , 11.165 , 10.287 , 9.7882 , $ 9.2294 , 8.7539 , 8.3300 , 6.9480 , 6.2234 , $ 5.5881 , 5.0189 , 4.7733 , 4.1104 , 4.3929 , $ 4.6905 / C INELASTIC CROSS-SECTIONS ON FREE PROTONS C GAMMA, NEUTRINO, POSITRON, ELECTRON, MU(+), MU(-) DATA ((CSIN(I,J),I=1,6),J=1,41) / 246 * 0. / C PI(0) DATA (CSIN( 8,J),J=1,41) / 41 * 0. / C SIGMA(0) DATA (CSIN(21,J),J=1,41) / 41 * 0. / C SIGMA(0)_BAR DATA (CSIN(24,J),J=1,41) / 41 * 0. / C DEUTERIUM, TRITIUM, ALPHA DATA ((CSIN(I,J),I=30,32),J=1,41) / 123 * 0. / C NEW PARTICLES DATA (CSIN(35,J),J=1,41) / 41 * 0. / C PI(+) DATA (CSIN( 7,J),J=1,41) / $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, $ 0.00000E+00, 0.00000E+00, 0.50000 , 1.2000 , 1.7000 , $ 2.2500 , 3.0000 , 3.6000 , 4.5000 , 5.4000 , $ 6.3000 , 8.6000 , 9.0000 , 10.000 , 11.500 , $ 14.000 , 17.000 , 19.500 , 22.000 , 24.000 , $ 21.500 , 18.500 , 19.000 , 20.500 , 22.200 , $ 23.000 , 23.300 , 23.000 , 21.000 , 20.500 , $ 20.200 , 20.100 , 20.000 , 20.000 , 20.000 , $ 21.000 / C PI(-) DATA (CSIN( 9,J),J=1,41) / $ 0.00000E+00, 3.0000 , 9.2000 , 20.500 , 36.500 , $ 45.000 , 28.000 , 19.500 , 15.500 , 14.200 , $ 15.500 , 17.500 , 20.000 , 23.000 , 26.000 , $ 20.000 , 23.000 , 26.500 , 32.000 , 35.000 , $ 28.500 , 22.000 , 22.500 , 23.500 , 24.000 , $ 24.500 , 26.000 , 27.500 , 27.500 , 27.000 , $ 26.500 , 25.500 , 25.000 , 23.000 , 22.500 , $ 22.200 , 22.000 , 22.000 , 21.200 , 20.700 , $ 21.000 / C K(+) DATA (CSIN(10,J),J=1,41) / $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, $ 0.50000 , 1.5000 , 2.7000 , 3.8000 , 4.8000 , $ 6.5000 , 7.6000 , 8.4000 , 9.0000 , 9.4000 , $ 9.8000 , 10.500 , 11.000 , 11.500 , 11.800 , $ 12.200 , 12.400 , 12.600 , 13.200 , 13.500 , $ 13.700 , 14.000 , 14.200 , 14.500 , 16.400 , $ 17.000 / C K(0) SHORT DATA (CSIN(11,J),J=1,41) / $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, $ 0.50000 , 1.5000 , 2.7000 , 3.8000 , 4.8000 , $ 6.5000 , 7.6000 , 8.4000 , 9.0000 , 9.4000 , $ 9.8000 , 10.500 , 11.000 , 11.500 , 11.800 , $ 12.200 , 12.400 , 12.600 , 13.200 , 13.500 , $ 13.700 , 14.000 , 14.200 , 14.500 , 16.400 , $ 17.000 / C K(0) LONG DATA (CSIN(12,J),J=1,41) / $ 266.67 , 133.33 , 83.333 , 57.083 , 44.500 , $ 33.250 , 24.583 , 20.833 , 18.333 , 16.083 , $ 15.625 , 15.083 , 14.833 , 15.083 , 15.833 , $ 17.042 , 18.958 , 20.758 , 22.533 , 22.825 , $ 21.250 , 18.567 , 17.767 , 18.100 , 19.933 , $ 20.783 , 21.225 , 21.000 , 20.558 , 20.258 , $ 20.017 , 19.767 , 19.600 , 19.183 , 18.850 , $ 18.575 , 18.350 , 18.175 , 17.808 , 17.558 , $ 19.250 / C K(-) DATA (CSIN(13,J),J=1,41) / $ 400.00 , 200.00 , 120.00 , 81.000 , 62.000 , $ 47.000 , 35.000 , 28.000 , 24.000 , 21.000 , $ 19.500 , 19.000 , 18.800 , 19.000 , 20.000 , $ 21.000 , 23.000 , 25.000 , 27.000 , 27.500 , $ 25.500 , 22.000 , 20.800 , 21.000 , 23.000 , $ 24.000 , 24.000 , 23.800 , 23.000 , 22.500 , $ 22.000 , 21.600 , 21.400 , 21.000 , 20.500 , $ 20.200 , 19.800 , 19.500 , 18.600 , 17.500 , $ 20.000 / C PROTON DATA (CSIN(14,J),J=1,41) / $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.10000 , 1.5000 , $ 7.0000 , 12.000 , 17.000 , 19.500 , 20.500 , $ 22.000 , 23.500 , 24.800 , 25.800 , 26.500 , $ 27.000 , 27.500 , 28.000 , 30.000 , 31.000 , $ 32.000 , 32.500 , 32.500 , 33.000 , 33.500 , $ 34.000 / C PROTON_BAR DATA (CSIN(15,J),J=1,41) / $ 1500.0 , 1160.0 , 310.00 , 230.00 , 178.00 , $ 153.00 , 134.00 , 124.00 , 113.00 , 106.00 , $ 101.00 , 96.000 , 92.000 , 89.000 , 87.000 , $ 84.000 , 81.000 , 78.500 , 76.500 , 75.000 , $ 72.000 , 70.000 , 68.000 , 64.500 , 63.000 , $ 62.000 , 61.000 , 59.500 , 58.500 , 56.500 , $ 56.500 , 56.000 , 55.500 , 52.000 , 50.000 , $ 48.000 , 45.000 , 44.000 , 39.200 , 34.500 , $ 34.500 / C NEUTRON DATA (CSIN(16,J),J=1,41) / $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.10000 , 1.5000 , $ 7.0000 , 12.000 , 17.000 , 19.500 , 20.500 , $ 22.000 , 23.500 , 24.800 , 25.800 , 26.500 , $ 27.000 , 27.500 , 28.000 , 30.000 , 31.000 , $ 32.000 , 32.500 , 32.500 , 33.000 , 33.500 , $ 34.000 / C NEUTRON_BAR DATA (CSIN(17,J),J=1,41) / $ 1394.1 , 948.17 , 262.43 , 197.14 , 149.30 , $ 127.25 , 110.39 , 101.79 , 92.834 , 87.104 , $ 83.109 , 79.099 , 75.965 , 73.627 , 72.161 , $ 69.889 , 67.595 , 65.595 , 64.057 , 63.054 , $ 61.377 , 60.434 , 59.485 , 56.970 , 55.931 , $ 55.398 , 54.827 , 53.538 , 52.861 , 51.247 , $ 51.344 , 50.992 , 50.644 , 47.876 , 46.358 , $ 44.887 , 42.577 , 41.815 , 38.180 , 34.254 , $ 34.418 / C LAMBDA DATA (CSIN(18,J),J=1,41) / $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.97815E-01, 1.4577 , $ 6.2052 , 10.112 , 12.902 , 14.300 , 14.688 , $ 15.505 , 16.379 , 17.554 , 18.309 , 18.920 , $ 19.389 , 19.804 , 20.284 , 22.000 , 22.733 , $ 23.527 , 24.097 , 24.382 , 24.816 , 26.800 , $ 27.719 / C LAMBDA_BAR DATA (CSIN(19,J),J=1,41) / $ 1182.4 , 524.50 , 167.30 , 131.43 , 91.895 , $ 75.743 , 63.184 , 57.376 , 52.502 , 49.313 , $ 47.326 , 44.762 , 43.222 , 42.015 , 41.221 , $ 40.244 , 39.504 , 39.145 , 38.860 , 38.731 , $ 37.987 , 37.814 , 36.326 , 34.750 , 33.953 , $ 33.635 , 33.349 , 32.938 , 32.785 , 32.092 , $ 32.373 , 32.312 , 32.329 , 31.261 , 30.597 , $ 30.073 , 29.228 , 29.182 , 27.683 , 27.107 , $ 27.956 / C SIGMA(+) DATA (CSIN(20,J),J=1,41) / $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.97815E-01, 1.4577 , $ 6.2052 , 10.112 , 12.902 , 14.300 , 14.688 , $ 15.505 , 16.379 , 17.554 , 18.309 , 18.920 , $ 19.389 , 19.804 , 20.284 , 22.000 , 22.733 , $ 23.527 , 24.097 , 24.382 , 24.816 , 26.800 , $ 27.719 / C SIGMA(-) DATA (CSIN(22,J),J=1,41) / $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.97815E-01, 1.4577 , $ 6.2052 , 10.112 , 12.902 , 14.300 , 14.688 , $ 15.505 , 16.379 , 17.554 , 18.309 , 18.920 , $ 19.389 , 19.804 , 20.284 , 22.000 , 22.733 , $ 23.527 , 24.097 , 24.382 , 24.816 , 26.800 , $ 27.719 / C SIGMA(+)_BAR DATA (CSIN(23,J),J=1,41) / $ 1394.1 , 948.17 , 262.43 , 197.14 , 149.30 , $ 127.25 , 110.39 , 101.79 , 92.834 , 87.104 , $ 83.109 , 78.563 , 75.292 , 72.760 , 70.900 , $ 68.467 , 66.314 , 64.955 , 63.746 , 62.623 , $ 59.233 , 56.946 , 53.355 , 49.810 , 48.090 , $ 46.839 , 45.695 , 44.863 , 44.062 , 42.599 , $ 42.684 , 42.328 , 42.041 , 39.508 , 37.880 , $ 36.299 , 34.075 , 33.553 , 29.723 , 27.600 , $ 28.120 / C SIGMA(-)_BAR DATA (CSIN(25,J),J=1,41) / $ 1182.4 , 524.50 , 167.30 , 131.43 , 91.895 , $ 75.743 , 63.184 , 57.376 , 52.502 , 49.313 , $ 47.326 , 44.762 , 43.222 , 42.015 , 41.221 , $ 40.244 , 39.504 , 39.145 , 38.860 , 38.731 , $ 37.987 , 37.814 , 36.326 , 34.750 , 33.953 , $ 33.635 , 33.349 , 32.938 , 32.785 , 32.092 , $ 32.373 , 32.312 , 32.329 , 31.261 , 30.597 , $ 30.073 , 29.228 , 29.182 , 27.683 , 27.107 , $ 27.956 / C XI(0) DATA (CSIN(26,J),J=1,41) / $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.95639E-01, 1.4154 , $ 5.4104 , 8.2240 , 8.8031 , 9.1000 , 8.8761 , $ 9.0095 , 9.2576 , 10.307 , 10.818 , 11.341 , $ 11.778 , 12.108 , 12.569 , 14.000 , 14.467 , $ 15.054 , 15.694 , 16.263 , 16.632 , 20.100 , $ 21.438 / C XI(-) DATA (CSIN(27,J),J=1,41) / $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.95639E-01, 1.4154 , $ 5.4104 , 8.2240 , 8.8031 , 9.1000 , 8.8761 , $ 9.0095 , 9.2576 , 10.307 , 10.818 , 11.341 , $ 11.778 , 12.108 , 12.569 , 14.000 , 14.467 , $ 15.054 , 15.694 , 16.263 , 16.632 , 20.100 , $ 21.438 / C XI(0)_BAR DATA (CSIN(28,J),J=1,41) / $ 1182.4 , 524.50 , 167.30 , 131.43 , 91.895 , $ 75.743 , 63.184 , 57.376 , 52.502 , 49.313 , $ 47.326 , 44.225 , 42.549 , 41.148 , 39.960 , $ 38.822 , 38.223 , 38.505 , 38.549 , 38.301 , $ 35.843 , 34.326 , 30.196 , 27.590 , 26.112 , $ 25.076 , 24.217 , 24.264 , 23.985 , 23.445 , $ 23.713 , 23.647 , 23.726 , 22.892 , 22.119 , $ 21.485 , 20.726 , 20.921 , 19.226 , 20.454 , $ 21.658 / C XI(-)_BAR DATA (CSIN(29,J),J=1,41) / $ 1076.5 , 312.66 , 119.74 , 98.571 , 63.193 , $ 49.990 , 39.579 , 35.168 , 32.335 , 30.417 , $ 29.434 , 27.325 , 26.514 , 25.775 , 25.120 , $ 24.711 , 24.818 , 25.600 , 26.106 , 26.355 , $ 25.220 , 24.760 , 21.681 , 20.060 , 19.044 , $ 18.474 , 18.044 , 18.301 , 18.347 , 18.192 , $ 18.557 , 18.639 , 18.870 , 18.769 , 18.478 , $ 18.372 , 18.302 , 18.735 , 18.206 , 20.207 , $ 21.576 / C OMEGA(-) DATA (CSIN(33,J),J=1,41) / $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.95639E-01, 1.4154 , $ 5.4104 , 8.2240 , 8.8031 , 9.1000 , 8.8761 , $ 9.0095 , 9.2576 , 10.307 , 10.818 , 11.341 , $ 11.778 , 12.108 , 12.569 , 14.000 , 14.467 , $ 15.054 , 15.694 , 16.263 , 16.632 , 20.100 , $ 21.438 / C OMEGA(-)_BAR DATA (CSIN(34,J),J=1,41) / $ 1076.5 , 312.66 , 119.74 , 98.571 , 63.193 , $ 49.990 , 39.579 , 35.168 , 32.335 , 30.417 , $ 29.434 , 27.325 , 26.514 , 25.775 , 25.120 , $ 24.711 , 24.818 , 25.600 , 26.106 , 26.355 , $ 25.220 , 24.760 , 21.681 , 20.060 , 19.044 , $ 18.474 , 18.044 , 18.301 , 18.347 , 18.192 , $ 18.557 , 18.639 , 18.870 , 18.769 , 18.478 , $ 18.372 , 18.302 , 18.735 , 18.206 , 20.207 , $ 21.576 / C ELASTIC CROSS-SECTION FOR MEDI WITH PIONS C ALUMINIUM DATA (CSPIEL( 1,J),J=1,41) / $ 0.00000E+00, 350.00 , 580.00 , 600.00 , 550.00 , $ 450.00 , 410.00 , 370.00 , 340.00 , 230.00 , $ 220.00 , 205.00 , 180.00 , 155.00 , 145.00 , $ 140.00 , 160.00 , 195.00 , 235.00 , 250.00 , $ 270.00 , 280.00 , 300.00 , 300.00 , 290.00 , $ 285.00 , 265.00 , 240.00 , 230.00 , 222.00 , $ 204.00 , 196.00 , 190.00 , 170.00 , 170.00 , $ 160.00 , 150.00 , 140.00 , 120.00 , 80.000 , $ 80.000 / C COPPER DATA (CSPIEL( 2,J),J=1,41) / $ 0.00000E+00, 700.00 , 1000.0 , 1200.0 , 1300.0 , $ 1300.0 , 1250.0 , 1250.0 , 1100.0 , 1000.0 , $ 940.00 , 740.00 , 700.00 , 670.00 , 660.00 , $ 670.00 , 680.00 , 700.00 , 735.00 , 800.00 , $ 810.00 , 820.00 , 820.00 , 810.00 , 800.00 , $ 800.00 , 700.00 , 600.00 , 500.00 , 470.00 , $ 440.00 , 410.00 , 380.00 , 330.00 , 330.00 , $ 330.00 , 330.00 , 330.00 , 285.00 , 240.00 , $ 240.00 / C LEAD DATA (CSPIEL( 3,J),J=1,41) / $ 0.00000E+00, 1700.0 , 2200.0 , 2200.0 , 1800.0 , $ 1300.0 , 1200.0 , 900.00 , 900.00 , 1000.0 , $ 1100.0 , 1300.0 , 1400.0 , 1420.0 , 1490.0 , $ 1560.0 , 1580.0 , 1690.0 , 1795.0 , 2000.0 , $ 2070.0 , 2140.0 , 2050.0 , 2010.0 , 1970.0 , $ 1880.0 , 1690.0 , 1500.0 , 1420.0 , 1390.0 , $ 1350.0 , 1360.0 , 1370.0 , 1280.0 , 1290.0 , $ 1295.0 , 1250.0 , 1200.0 , 1050.0 , 900.00 , $ 900.00 / C INELASTIC CROSS-SECTION FOR MEDIA WITH PIONS C ALIMINUIM DATA (CSPIIN( 1,J),J=1,41) / $ 0.00000E+00, 200.00 , 320.00 , 500.00 , 600.00 , $ 600.00 , 590.00 , 530.00 , 510.00 , 470.00 , $ 430.00 , 425.00 , 420.00 , 425.00 , 425.00 , $ 430.00 , 430.00 , 435.00 , 435.00 , 440.00 , $ 430.00 , 430.00 , 420.00 , 420.00 , 420.00 , $ 415.00 , 415.00 , 410.00 , 410.00 , 408.00 , $ 406.00 , 404.00 , 400.00 , 380.00 , 340.00 , $ 340.00 , 340.00 , 340.00 , 340.00 , 340.00 , $ 340.00 / C COPPER DATA (CSPIIN( 2,J),J=1,41) / $ 0.00000E+00, 400.00 , 800.00 , 1000.0 , 1100.0 , $ 1200.0 , 1150.0 , 1050.0 , 1000.0 , 900.00 , $ 860.00 , 860.00 , 850.00 , 850.00 , 840.00 , $ 830.00 , 820.00 , 810.00 , 805.00 , 800.00 , $ 800.00 , 800.00 , 800.00 , 800.00 , 800.00 , $ 800.00 , 800.00 , 800.00 , 800.00 , 780.00 , $ 760.00 , 740.00 , 720.00 , 720.00 , 700.00 , $ 690.00 , 680.00 , 670.00 , 665.00 , 660.00 , $ 660.00 / C LEAD DATA (CSPIIN( 3,J),J=1,41) / $ 0.00000E+00, 1000.0 , 1900.0 , 2600.0 , 2900.0 , $ 3000.0 , 2800.0 , 2600.0 , 2500.0 , 2300.0 , $ 2200.0 , 2000.0 , 1900.0 , 1880.0 , 1860.0 , $ 1840.0 , 1820.0 , 1810.0 , 1805.0 , 1800.0 , $ 1780.0 , 1760.0 , 1750.0 , 1740.0 , 1730.0 , $ 1720.0 , 1710.0 , 1700.0 , 1680.0 , 1660.0 , $ 1650.0 , 1640.0 , 1630.0 , 1620.0 , 1610.0 , $ 1605.0 , 1600.0 , 1600.0 , 1550.0 , 1500.0 , $ 1500.0 / C ELASTIC CROSS-SECTION FOR MEDI WITH NUCLEONS C ALUMINIUM DATA (CSPNEL( 1,J),J=1,41) / $ 2100.0 , 1800.0 , 1500.0 , 1050.0 , 900.00 , $ 950.00 , 800.00 , 650.00 , 570.00 , 390.00 , $ 300.00 , 240.00 , 230.00 , 230.00 , 220.00 , $ 220.00 , 225.00 , 225.00 , 240.00 , 240.00 , $ 290.00 , 330.00 , 335.00 , 350.00 , 355.00 , $ 370.00 , 350.00 , 330.00 , 310.00 , 290.00 , $ 270.00 , 265.00 , 260.00 , 230.00 , 210.00 , $ 210.00 , 200.00 , 200.00 , 190.00 , 180.00 , $ 180.00 / C COPPER DATA (CSPNEL( 2,J),J=1,41) / $ 3800.0 , 2900.0 , 1850.0 , 1550.0 , 1450.0 , $ 1520.0 , 1460.0 , 1300.0 , 1140.0 , 880.00 , $ 700.00 , 620.00 , 540.00 , 560.00 , 460.00 , $ 460.00 , 470.00 , 470.00 , 480.00 , 480.00 , $ 580.00 , 600.00 , 610.00 , 620.00 , 620.00 , $ 620.00 , 590.00 , 580.00 , 460.00 , 440.00 , $ 420.00 , 400.00 , 480.00 , 430.00 , 380.00 , $ 380.00 , 380.00 , 380.00 , 380.00 , 380.00 , $ 380.00 / C LEAD DATA (CSPNEL( 3,J),J=1,41) / $ 7000.0 , 6000.0 , 4500.0 , 3350.0 , 2700.0 , $ 3000.0 , 3550.0 , 3970.0 , 3280.0 , 2490.0 , $ 2100.0 , 1510.0 , 1440.0 , 1370.0 , 1370.0 , $ 1370.0 , 1400.0 , 1400.0 , 1420.0 , 1420.0 , $ 1440.0 , 1460.0 , 1460.0 , 1450.0 , 1450.0 , $ 1470.0 , 1400.0 , 1400.0 , 1380.0 , 1370.0 , $ 1360.0 , 1350.0 , 1340.0 , 1330.0 , 1320.0 , $ 1310.0 , 1305.0 , 1300.0 , 1300.0 , 1300.0 , $ 1300.0 / C INELASTIC CROSS-SECTION FOR MEDI WITH NUCLEONS C ALUMINIUM DATA (CSPNIN( 1,J),J=1,41) / $ 0.00000E+00, 200.00 , 400.00 , 800.00 , 800.00 , $ 550.00 , 500.00 , 450.00 , 430.00 , 410.00 , $ 400.00 , 390.00 , 380.00 , 370.00 , 370.00 , $ 370.00 , 365.00 , 365.00 , 360.00 , 360.00 , $ 360.00 , 360.00 , 365.00 , 370.00 , 375.00 , $ 380.00 , 400.00 , 410.00 , 420.00 , 430.00 , $ 440.00 , 440.00 , 440.00 , 440.00 , 440.00 , $ 440.00 , 440.00 , 440.00 , 440.00 , 440.00 , $ 440.00 / C COPPER DATA (CSPNIN( 2,J),J=1,41) / $ 0.00000E+00, 400.00 , 950.00 , 1050.0 , 1050.0 , $ 980.00 , 940.00 , 900.00 , 860.00 , 820.00 , $ 800.00 , 780.00 , 760.00 , 740.00 , 740.00 , $ 740.00 , 730.00 , 730.00 , 720.00 , 720.00 , $ 720.00 , 720.00 , 730.00 , 740.00 , 750.00 , $ 760.00 , 800.00 , 820.00 , 820.00 , 820.00 , $ 820.00 , 820.00 , 820.00 , 820.00 , 820.00 , $ 820.00 , 820.00 , 820.00 , 820.00 , 820.00 , $ 820.00 / C LEAD DATA (CSPNIN( 3,J),J=1,41) / $ 0.00000E+00, 0.00000E+00, 500.00 , 1450.0 , 1700.0 , $ 1800.0 , 1750.0 , 1730.0 , 1720.0 , 1710.0 , $ 1700.0 , 1690.0 , 1660.0 , 1630.0 , 1630.0 , $ 1630.0 , 1600.0 , 1600.0 , 1580.0 , 1580.0 , $ 1580.0 , 1580.0 , 1600.0 , 1630.0 , 1650.0 , $ 1670.0 , 1760.0 , 1800.0 , 1800.0 , 1800.0 , $ 1800.0 , 1800.0 , 1800.0 , 1800.0 , 1800.0 , $ 1800.0 , 1800.0 , 1800.0 , 1800.0 , 1800.0 , $ 1800.0 / DATA ELAB / $ 0.10000E-03, 0.20000E-03, 0.30000E-03, 0.40000E-03, 0.50000E-03, $ 0.70000E-03, 0.10000E-02, 0.20000E-02, 0.30000E-02, 0.40000E-02, $ 0.50000E-02, 0.70000E-02, 0.10000E-01, 0.15000E-01, 0.20000E-01, $ 0.25000E-01, 0.32700E-01/ C TABLES FOR VARIOUS ATOMIC WEIGHTS DATA CNLWAT / $ 1.0000 , 16.000 , 27.000 , 56.000 , 59.000 , $ 64.000 , 91.000 , 112.00 , 119.00 , 127.00 , $ 137.00 , 181.00 , 207.00 , 209.00 , 238.00 / DATA (CNLWEL( 1,J),J=1,17) / $ 6000.0 , 5500.0 , 5200.0 , 4900.0 , 4800.0 , $ 4400.0 , 4000.0 , 2900.0 , 2200.0 , 1800.0 , $ 1400.0 , 1100.0 , 900.00 , 700.00 , 600.00 , $ 560.00 , 520.00 / DATA (CNLWEL( 2,J),J=1,17) / $ 5400.0 , 5050.0 , 4800.0 , 4600.0 , 4399.0 , $ 4090.0 , 3700.0 , 2600.0 , 1950.0 , 1600.0 , $ 1300.0 , 900.00 , 700.00 , 800.00 , 1050.0 , $ 1250.0 , 1320.0 / DATA (CNLWEL( 3,J),J=1,17) / $ 5500.0 , 5150.0 , 4900.0 , 4699.0 , 4490.0 , $ 4150.0 , 3750.0 , 2790.0 , 2100.0 , 1650.0 , $ 1300.0 , 950.00 , 800.00 , 860.00 , 1000.0 , $ 1090.0 , 1080.0 / DATA (CNLWEL( 4,J),J=1,17) / $ 5499.0 , 4970.0 , 4450.0 , 4080.0 , 3750.0 , $ 3380.0 , 2900.0 , 2400.0 , 2380.0 , 2350.0 , $ 2300.0 , 2100.0 , 1720.0 , 1370.0 , 1200.0 , $ 1060.0 , 870.00 / DATA (CNLWEL( 5,J),J=1,17) / $ 5399.0 , 4710.0 , 4180.0 , 3760.0 , 3460.0 , $ 3150.0 , 2730.0 , 2270.0 , 1850.0 , 1850.0 , $ 2130.0 , 2330.0 , 2120.0 , 1640.0 , 1310.0 , $ 1100.0 , 1050.0 / DATA (CNLWEL( 6,J),J=1,17) / $ 5099.0 , 4405.0 , 3825.0 , 3455.0 , 3125.0 , $ 2695.0 , 2350.0 , 1850.0 , 1580.0 , 1820.0 , $ 2050.0 , 2210.0 , 2000.0 , 1590.0 , 1310.0 , $ 1120.0 , 1040.0 / DATA (CNLWEL( 7,J),J=1,17) / $ 6290.0 , 5960.0 , 5640.0 , 5370.0 , 5150.0 , $ 4800.0 , 4250.0 , 3150.0 , 2470.0 , 2100.0 , $ 2230.0 , 2420.0 , 2450.0 , 2050.0 , 1760.0 , $ 1550.0 , 1330.0 / DATA (CNLWEL( 8,J),J=1,17) / $ 6885.0 , 6650.0 , 6350.0 , 6150.0 , 6000.0 , $ 5700.0 , 5360.0 , 4250.0 , 2800.0 , 1870.0 , $ 1810.0 , 1820.0 , 2170.0 , 2450.0 , 2150.0 , $ 1700.0 , 1390.0 / DATA (CNLWEL( 9,J),J=1,17) / $ 6600.0 , 6500.0 , 6400.0 , 6249.0 , 6190.0 , $ 5950.0 , 5520.0 , 4250.0 , 2750.0 , 1900.0 , $ 1850.0 , 1950.0 , 2340.0 , 2800.0 , 2540.0 , $ 2100.0 , 1760.0 / DATA (CNLWEL(10,J),J=1,17) / $ 7400.0 , 7200.0 , 6999.0 , 6840.0 , 6655.0 , $ 6320.0 , 5820.0 , 4400.0 , 2850.0 , 2000.0 , $ 1800.0 , 1800.0 , 2150.0 , 2600.0 , 2350.0 , $ 1950.0 , 2100.0 / DATA (CNLWEL(11,J),J=1,17) / $ 7900.0 , 7700.0 , 7499.0 , 7390.0 , 7202.0 , $ 6810.0 , 6360.0 , 4920.0 , 3450.0 , 2600.0 , $ 2200.0 , 1950.0 , 2300.0 , 2800.0 , 2650.0 , $ 2250.0 , 2050.0 / DATA (CNLWEL(12,J),J=1,17) / $ 7900.0 , 7750.0 , 7699.0 , 7590.0 , 7450.0 , $ 7200.0 , 6850.0 , 5650.0 , 4400.0 , 3700.0 , $ 3400.0 , 2800.0 , 2700.0 , 3100.0 , 3250.0 , $ 3100.0 , 2750.0 / DATA (CNLWEL(13,J),J=1,17) / $ 6100.0 , 5950.0 , 5750.0 , 5599.0 , 5440.0 , $ 5200.0 , 4800.0 , 4300.0 , 5800.0 , 5750.0 , $ 4800.0 , 3420.0 , 2650.0 , 3200.0 , 3650.0 , $ 3500.0 , 2980.0 / DATA (CNLWEL(14,J),J=1,17) / $ 6100.0 , 5950.0 , 5750.0 , 5599.0 , 5440.0 , $ 5200.0 , 4800.0 , 4300.0 , 5800.0 , 5750.0 , $ 4800.0 , 3420.0 , 2650.0 , 3200.0 , 3650.0 , $ 3500.0 , 2980.0 / DATA (CNLWEL(15,J),J=1,17) / $ 6600.0 , 6350.0 , 6100.0 , 5899.0 , 5690.0 , $ 5300.0 , 4850.0 , 4450.0 , 5650.0 , 5700.0 , $ 4950.0 , 3850.0 , 3050.0 , 3050.0 , 3460.0 , $ 3650.0 , 3340.0 / DATA (CNLWIN( 1,J),J=1,17) / 17*0.0E+00 / DATA (CNLWIN( 2,J),J=1,17) / $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 1.0000 , $ 10.000 , 50.000 , 100.00 , 200.00 , 300.00 , $ 400.00 , 600.00 , 700.00 , 750.00 , 700.00 , $ 700.00 , 680.00 / DATA (CNLWIN( 3,J),J=1,17) / $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 1.0000 , 10.000 , $ 50.000 , 100.00 , 260.00 , 450.00 , 600.00 , $ 700.00 , 800.00 , 900.00 , 940.00 , 900.00 , $ 860.00 , 820.00 / DATA (CNLWIN( 4,J),J=1,17) / $ 1.0000 , 80.000 , 200.00 , 320.00 , 400.00 , $ 520.00 , 700.00 , 1000.0 , 1120.0 , 1200.0 , $ 1200.0 , 1200.0 , 1180.0 , 1130.0 , 1100.0 , $ 1090.0 , 1080.0 / DATA (CNLWIN( 5,J),J=1,17) / $ 1.0000 , 90.000 , 220.00 , 340.00 , 420.00 , $ 550.00 , 720.00 , 1080.0 , 1300.0 , 1400.0 , $ 1420.0 , 1420.0 , 1380.0 , 1260.0 , 1190.0 , $ 1150.0 , 1100.0 / DATA (CNLWIN( 6,J),J=1,17) / $ 1.0000 , 95.000 , 225.00 , 345.00 , 425.00 , $ 555.00 , 750.00 , 1150.0 , 1500.0 , 1680.0 , $ 1700.0 , 1690.0 , 1550.0 , 1360.0 , 1240.0 , $ 1180.0 , 1120.0 / DATA (CNLWIN( 7,J),J=1,17) / $ 10.000 , 140.00 , 260.00 , 380.00 , 450.00 , $ 600.00 , 750.00 , 1200.0 , 1580.0 , 1800.0 , $ 1820.0 , 1830.0 , 1800.0 , 1750.0 , 1690.0 , $ 1650.0 , 1620.0 / DATA (CNLWIN( 8,J),J=1,17) / $ 15.000 , 150.00 , 300.00 , 400.00 , 500.00 , $ 650.00 , 840.00 , 1500.0 , 2100.0 , 2130.0 , $ 2140.0 , 2130.0 , 2080.0 , 2000.0 , 1950.0 , $ 1900.0 , 1860.0 / DATA (CNLWIN( 9,J),J=1,17) / $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 1.0000 , 10.000 , $ 150.00 , 380.00 , 1000.0 , 1650.0 , 2100.0 , $ 2100.0 , 2100.0 , 2060.0 , 1950.0 , 1860.0 , $ 1800.0 , 1740.0 / DATA (CNLWIN(10,J),J=1,17) / $ 0.00000E+00, 0.00000E+00, 1.0000 , 10.000 , 45.000 , $ 180.00 , 380.00 , 1050.0 , 1900.0 , 2300.0 , $ 2300.0 , 2200.0 , 2150.0 , 2000.0 , 1900.0 , $ 1800.0 , 1750.0 / DATA (CNLWIN(11,J),J=1,17) / $ 0.00000E+00, 0.00000E+00, 1.0000 , 10.000 , 48.000 , $ 190.00 , 390.00 , 1080.0 , 2000.0 , 2400.0 , $ 2400.0 , 2300.0 , 2200.0 , 2100.0 , 1950.0 , $ 1850.0 , 1800.0 / DATA (CNLWIN(12,J),J=1,17) / $ 0.00000E+00, 0.00000E+00, 1.0000 , 10.000 , 50.000 , $ 200.00 , 400.00 , 1100.0 , 2100.0 , 2500.0 , $ 2500.0 , 2450.0 , 2300.0 , 2100.0 , 2000.0 , $ 1900.0 , 1850.0 / DATA (CNLWIN(13,J),J=1,17) / $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 1.0000 , 10.000 , $ 100.00 , 350.00 , 900.00 , 1400.0 , 2000.0 , $ 2300.0 , 2380.0 , 2400.0 , 2300.0 , 2250.0 , $ 2200.0 , 2120.0 / DATA (CNLWIN(14,J),J=1,17) / $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 1.0000 , 10.000 , $ 100.00 , 350.00 , 900.00 , 1400.0 , 2000.0 , $ 2300.0 , 2380.0 , 2400.0 , 2300.0 , 2250.0 , $ 2200.0 , 2120.0 / DATA (CNLWIN(15,J),J=1,17) / $ 0.00000E+00, 0.00000E+00, 0.00000E+00, 1.0000 , 10.000 , $ 100.00 , 400.00 , 950.00 , 1600.0 , 2200.0 , $ 2550.0 , 2750.0 , 2700.0 , 2600.0 , 2540.0 , $ 2450.0 , 2360.0 / DATA (CSCAP(J),J=1,50) / $ 6.0000 , 5.7000 , 5.5000 , 5.3000 , 5.2000 , $ 5.1000 , 5.0000 , 4.9000 , 4.8000 , 4.8000 , $ 4.8000 , 4.8000 , 4.8000 , 4.8000 , 4.8000 , $ 4.8000 , 4.9000 , 5.0000 , 5.2000 , 5.5000 , $ 6.0000 , 6.7000 , 7.5000 , 8.5000 , 10.000 , $ 12.000 , 14.500 , 19.000 , 26.500 , 40.000 , $ 75.000 , 120.00 , 180.00 , 260.00 , 360.00 , $ 330.00 , 60.000 , 7.0000 , 9.5000 , 20.000 , $ 75.000 , 140.00 , 250.00 , 360.00 , 480.00 , $ 580.00 , 590.00 , 500.00 , 300.00 , 100.00 / DATA (CSCAP(J),J=51,100) / $ 200.00 , 300.00 , 400.00 , 470.00 , 500.00 , $ 430.00 , 100.00 , 20.000 , 22.000 , 40.000 , $ 560.00 , 950.00 , 1000.0 , 1000.0 , 1000.0 , $ 990.00 , 920.00 , 860.00 , 790.00 , 740.00 , $ 650.00 , 600.00 , 540.00 , 470.00 , 440.00 , $ 390.00 , 360.00 , 340.00 , 320.00 , 310.00 , $ 280.00 , 2.0000 , 2.5000 , 6.0000 , 13.000 , $ 38.000 , 65.000 , 140.00 , 280.00 , 300.00 , $ 430.00 , 580.00 , 650.00 , 800.00 , 920.00 , $ 1100.0 , 1250.0 , 1400.0 , 1550.0 , 1700.0 / C --- END OF CROSS-SECTION DATA STATEMENTS --- C --- DATA STMTS. FOR GEANT/GHEISHA PARTICLE CODE CONVERSIONS --- C --- KIPART(I)=GHEISHA CODE CORRESPONDING TO GEANT CODE I --- C --- IKPART(I)=GEANT CODE CORRESPONDING TO GHEISHA CODE I --- DATA KIPART/ $ 1, 3, 4, 2, 5, 6, 8, 7, $ 9, 12, 10, 13, 16, 14, 15, 11, $ 35, 18, 20, 21, 22, 26, 27, 33, $ 17, 19, 23, 24, 25, 28, 29, 34, $ 35, 35, 35, 35, 35, 35, 35, 35, $ 35, 35, 35, 35, 30, 31, 32, 35/ * DATA IKPART/ * $ 1, 4, 2, 3, 5, 6, 8, 7, * $ 9, 11, 16, 10, 12, 14, 15, 13, * $ 25, 18, 26, 19, 20, 21, 27, 28, * $ 29, 22, 23, 30, 31, 45, 46, 47, * $ 24, 32, 48/ C PARAMETER (ONETHR=1./3.) DATA ONETHR / .33333333/ DATA ALPHA / 6*0.7, + 0.75 ,0.75 ,0.75 , + 0.76,0.76 ,0.76 ,0.76 , + 0.685,0.63 ,0.685,0.63,0.685,0.63, + 3*0.685,3*0.63,2*0.685,2*0.63, + 3*0.7,0.685,0.63,0.7/ DATA ALPHAC /1.2,1.2,1.2,1.15,0.90,0.91,0.98,1.06,1.10,1.11, + 1.10,1.08,1.05,1.01,0.985,0.962,0.945,0.932, + 0.925,0.920,0.920,0.921,0.922,0.923,0.928,0.931, + 0.940,0.945,0.950,0.955,0.958,0.962,0.965,0.976, + 0.982,0.988,0.992,1.010,1.020,1.030,1.040/ DATA PARTEL/6*0.,29*1./ DATA PARTIN/6*0.,1.00,0.00,1.05,1.20,1.35,1.30,1.20,1.00,1.30, + 1.00,1.30,1.00,1.30,1.00,1.00,1.00,1.30,1.30,1.30, + 1.00,1.00,1.30,1.30,1.00,1.,1.,1.,1.3,1./ * DATA ICORR /14*1, 0, 1, 0, 1, 0, 3*1, 3*0, 2*1, 2*0, 4*1, 2*0/ C-- SET INTRC TO 0 FOR IPART = 26-29, 33, 34 ( XI'S AND OMEGA'S ) C-DH- DATA INTRC /6*0, 1, 0, 12*1, 0, 2*2, 0, 1, 4*0, 3*1, 3*0 / C-- RESET INTRC FOR IPART = 26-29, 33, 34 ( XI'S AND OMEGA'S ) DATA INTRC /6*0, 1, 0, 12*1, 0, 2*2, 0, 10*1, 0/ C CROSS-SECTIONS ON NUCLEUS ARE KNOWN ONLY FOR PIONS AND PROTONS. C THE GENERAL LAW SIGMA(A)=1.25*SIGMA(TOT,PROTON)*A**ALPHA IS VALID C ONLY FOR MOMENTA > 2 GEV.THE PARAMETRIZATION DONE HERE GIVES ONLY C A BEHAVIOUR AVERAGED OVER MOMENTA AND PARTICLE TYPES. C FOR A DETECTOR WITH ONLY A FEW MATERIALS IT'S OF COURSE MUCHBETTER C TO USE TABLES OF THE MEASURED CROSS-SECTIONS . C FOR ELEMENTS WITH THE FOLLOWING ATOMIC NUMBERS MEASURED CROSS- C SECTIONS ARE AVAILABLE (SEE "PCSDATA"). C H AL CU PB DATA CSA /1. ,27.00 ,63.54 ,207.19 / DATA IPART2/9,8,7,11,10,13,12/ SAVE ALPHA,ALPHAC,PARTEL,PARTIN,CSA,IPART2,INTRC C----------------------------------------------------------------------- IF ( DEBUG .AND. GHEISDB ) THEN WRITE(MDEBUG,*) 'CGHSIG:' NPRT(4)=.TRUE. NPRT(9)=.TRUE. ELSE NPRT(4)=.FALSE. NPRT(9)=.FALSE. ENDIF C --- INITIALIZE CGHSIG AND SWITCH TO GHEISHA PARTICLE CODE --- CGHSIG=0.0 IF ( LPART .LE. 48 ) THEN IPART = KIPART(LPART) ELSEIF ( LPART .EQ. 201 ) THEN IPART = 30 ELSEIF ( LPART .EQ. 301 ) THEN IPART = 31 ELSEIF ( LPART .EQ. 402 ) THEN IPART = 32 ELSE GOTO 160 ENDIF C --- NO INTERACTION FOR GAMMAS, NEUTRINOS, ELECTRONS, POSITRONS, MUONS, C --- NEUTRAL PIONS, NEUTRAL SIGMAS AND ANTISIGMAS AND NEW PARTICLES. IF ( INTRC(IPART) .EQ. 0 ) GOTO 160 P = PPART EK = EKIN C --- INITIALIZE THE CROSS-SECTIONS WITH 0.0 --- DO 10 K = 1,KK AIEL(K) = 0.0 AIIN(K) = 0.0 AICA(K) = 0.0 10 CONTINUE C IF ( (IPART .GE. 30) .AND. (IPART .LE. 32) ) THEN C --- TAKE GEOMETRICAL CROSS-SECTIONS FOR INELASTIC SCATTERING --- C --- OF DEUTERONS, TRITONS AND ALPHAS --- IF ( IPART .EQ. 30 ) THEN APART = 2.0**ONETHR ELSEIF ( IPART .EQ. 31 ) THEN APART = 3.0**ONETHR ELSEIF ( IPART .EQ. 32 ) THEN APART = 4.0**ONETHR ENDIF DO 20 K = 1,KK AIIN(K) = 49.0*(APART+ACOMP(K)**ONETHR)**2 20 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,10000) ELSEIF ( (IPART .EQ. 16) .AND. (EK .LE. 0.0327) ) THEN C --- USE TABLES FOR LOW ENERGY NEUTRONS --- C --- GET ENERGY BIN --- JE2 = 17 DO 30 J = 2,17 IF ( EK .LT. ELAB(J) ) THEN JE2 = J GOTO 40 ENDIF 30 CONTINUE 40 JE1 = JE2-1 EKX = MAX(EK,1.0E-9) DELAB = ELAB(JE2)-ELAB(JE1) DO 70 K = 1,KK C --- GET A BIN --- JA2 = 15 DO 50 J = 2,15 IF ( ACOMP(K) .LT. CNLWAT(J) ) THEN JA2=J GOTO 60 ENDIF 50 CONTINUE 60 JA1 = JA2-1 DNLWAT = CNLWAT(JA2)-CNLWAT(JA1) C --- USE LINEAR INTERPOLATION OR EXTRAPOLATION BY Y=RCE*X+RCA*X+B --- C --- ELASTIC CROSS-SECTION --- C --- E INTERPOLATION OR EXTRAPOLATION AT JA1 --- DY = CNLWEL(JA1,JE2)-CNLWEL(JA1,JE1) RCE = DY/DELAB C --- A INTERPOLATION OR EXTRAPOLATION AT JE1 --- DY = CNLWEL(JA2,JE1)-CNLWEL(JA1,JE1) RCA = DY/DNLWAT B = CNLWEL(JA1,JE1)-RCE*ELAB(JE1)-RCA*CNLWAT(JA1) AIEL(K) = RCE*EK+RCA*ACOMP(K)+B C --- INELASTIC CROSS-SECTION --- C --- E INTERPOLATION OR EXTRAPOLATION AT JA1 --- DY = CNLWIN(JA1,JE2)-CNLWIN(JA1,JE1) RCE = DY/DELAB C --- A INTERPOLATION OR EXTRAPOLATION AT JE1 --- DY = CNLWIN(JA2,JE1)-CNLWIN(JA1,JE1) RCA = DY/DNLWAT B = CNLWIN(JA1,JE1)-RCE*ELAB(JE1)-RCA*CNLWAT(JA1) AIIN(K) = RCE*EK+RCA*ACOMP(K)+B IZNO = ZCOMP(K)+0.01 AICA(K) = 11.12*CSCAP(IZNO)/(EKX*1.0E6)**0.577 70 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,10100) ELSE C --- USE PARAMETRIZATION OF CROSS-SECTION DATA FOR ALL OTHER CASES --- IF ( NPRT(9) ) WRITE(MDEBUG,10200) C --- GET MOMENTUM BIN --- J = 40 DO 80 I = 2,41 IF (P .LT. PLAB(I)) THEN J = I - 1 GOTO 90 ENDIF 80 CONTINUE C --- START WITH CROSS-SECTIONS FOR SCATTERING ON FREE PROTONS --- C --- USE LINEAR INTERPOLATION OR EXTRAPOLATION BY Y=RC*X+B --- 90 DX = PLAB(J+1)-PLAB(J) C --- ELASTIC CROSS-SECTION --- DY = CSEL(IPART,J+1)-CSEL(IPART,J) RC = DY/DX B = CSEL(IPART,J)-RC*PLAB(J) AIELIN = RC*P+B C --- INELASTIC CROSS-SECTION --- DY = CSIN(IPART,J+1)-CSIN(IPART,J) RC = DY/DX B = CSIN(IPART,J)-RC*PLAB(J) AIININ = RC*P+B ALPH = ALPHA(IPART) IF ( IPART .LT. 14 ) THEN DY = ALPHAC(J+1)-ALPHAC(J) RC = DY/DX B = ALPHAC(J)-RC*PLAB(J) CORFAC = RC*P+B ALPH = ALPH*CORFAC IPART3 = IPART2(IPART-6) C --- ELASTIC CROSS-SECTION --- DY = CSEL(IPART3,J+1)-CSEL(IPART3,J) RC = DY/DX B = CSEL(IPART3,J)-RC*PLAB(J) XSECEL = RC*P+B C --- INELASTIC CROSS-SECTION --- DY = CSIN(IPART3,J+1)-CSIN(IPART3,J) RC = DY/DX B = CSIN(IPART3,J)-RC*PLAB(J) XSECIN = RC*P+B ENDIF C NO MAKE CROSS-SECTIONS FOR COMPONENT K OF COMPOSITION DO 100 K = 1,KK AIEL(K) = AIELIN AIIN(K) = AIININ IF ( ACOMP(K) .GE. 1.5 ) THEN C --- A-DEPENDENCE FROM PARAMETRIZATION --- CREL = 1.0 CRIN = 1.0 C --- GET MEDIUM BIN 1=HYDR. 2=AL 3=CU 4=PB --- I = 3 IF ( ACOMP(K) .LT. 50.0 ) I = 2 IF ( ACOMP(K) .GT. 100.0 ) I = 4 IF ( (IPART .EQ. 14) .OR. (IPART .EQ. 16) ) THEN C --- PROTONS AND NEUTRONS --- C --- ELASTIC CROSS-SECTION --- DY = CSPNEL(I-1,J+1)-CSPNEL(I-1,J) RC = DY/DX B = CSPNEL(I-1,J)-RC*PLAB(J) XSECEL = RC*P+B C --- INELASTIC CROSS-SECTION --- DY = CSPNIN(I-1,J+1)-CSPNIN(I-1,J) RC = DY/DX B = CSPNIN(I-1,J)-RC*PLAB(J) XSECIN = RC*P+B IF ( AIEL(K) .GE. 0.001 ) CREL = XSECEL/(0.36*AIEL(K)* + CSA(I)**1.17) AITOT = AIEL(K)+AIIN(K) IF ( AITOT .GE. 0.001 ) CRIN = XSECIN/(AITOT*CSA(I)** + ALPH) ELSEIF ( IPART .LT. 15 ) THEN C --- CALCULATE CORRECTION FACTORS FROM VALUES ON AL,CU,PB FOR ALL --- C --- MESONS USE LINEAR INTERPOLATION OR EXTRAPOLATION BY Y=RC*X+B --- C --- NOTE THAT DATA IS ONLY AVAILABLE FOR PIONS AND PROTONS WGCH = 0.5 IF ( ACOMP(K) .LT. 20.0 ) + WGCH = 0.5+0.5*EXP(-(ACOMP(K)-1.0)) AIEL(K) = WGCH*AIEL(K)+(1.0-WGCH)*XSECEL AIIN(K) = WGCH*AIIN(K)+(1.0-WGCH)*XSECIN C --- THIS SECTION NOT FOR KAONS --- IF ( IPART .LT. 10 ) THEN C --- ELASTIC CROSS-SECTION --- DY = CSPIEL(I-1,J+1)-CSPIEL(I-1,J) RC = DY/DX B = CSPIEL(I-1,J)-RC*PLAB(J) XSPIEL =R C*P+B C --- INELASTIC CROSS-SECTION --- DY = CSPIIN(I-1,J+1)-CSPIIN(I-1,J) RC = DY/DX B = CSPIIN(I-1,J)-RC*PLAB(J) XSPIIN = RC*P+B IF ( AIEL(K) .GE. 0.001 ) CREL = XSPIEL/ + (0.36* AIEL(K)*CSA(I)**1.17) AITOT = AIEL(K)+AIIN(K) IF ( AITOT .GE. 0.001 ) CRIN = XSPIIN/(AITOT*CSA(I) + **ALPH) ENDIF ENDIF AIIN(K) = CRIN*(AIIN(K)+AIEL(K))*ACOMP(K)**ALPH AIEL(K) = CREL*0.36*AIEL(K)*ACOMP(K)**1.17 AIEL(K) = AIEL(K)*PARTEL(IPART) AIIN(K) = AIIN(K)*PARTIN(IPART) ENDIF 100 CONTINUE ENDIF C --- CALCULATE INTERACTION PROBABILITY --- ALAM = 0.0 DO 150 K = 1,KK AIEL(K) = AIEL(K)*WCOMP(K) AIIN(K) = AIIN(K)*WCOMP(K) AICA(K) = AICA(K)*WCOMP(K) ALAM = ALAM + AIEL(K) + AIIN(K) + AICA(K) 150 CONTINUE C --- PASS THE CROSS-SECTION (MBARN) TO CORSIKA --- CGHSIG = ALAM GOTO 999 C --- PRINTOUT OF SKIPPED PARTICLES IN CASE OF INTERFACE DEBUG --- 160 IF ( NPRT(9) ) WRITE(MDEBUG,10300) IPART 10000 FORMAT(' *CGHSIG* GEOM X-SECT. FOR INEL. SCAT. OF D,T AND ALPHA') 10100 FORMAT(' *CGHSIG* X-SECT. FROM LOW ENERGY NEUTRON TABLES') 10200 FORMAT(' *CGHSIG* X-SECT. FROM PARAMETRIZATION OF DATA') 10300 FORMAT(' *CGHSIG* GHEISHA PARTICLE ',I3,' SKIPPED') 999 RETURN END *CMZ : 28/02/2002 11.42.37 by D. HECK IK FZK KARLSRUHE *-- Author : CERN PROGLIB# M103 C======================================================================= SUBROUTINE FLPSOR(A,N) C----------------------------------------------------------------------- C CERN PROGLIB# M103 FLPSOR .VERSION KERNFOR 3.15 820113 C ORIG. 29/04/78 C----------------------------------------------------------------------- C SORT THE ONE-DIMENSIONAL FLOATING POINT ARRAY A(1),...,A(N) BY C INCREASING VALUES C C PROGRAM M103 TAKEN FROM CERN PROGRAM LIBRARY, 29-APR-78 C----------------------------------------------------------------------- DIMENSION A(*) COMMON /SLATE/ LT(20),RT(20) INTEGER R,RT SAVE C----------------------------------------------------------------------- LEVEL = 1 LT(1) = 1 RT(1) = N 10 L = LT(LEVEL) R = RT(LEVEL) LEVEL = LEVEL-1 20 IF (R .GT. L ) GOTO 200 IF ( LEVEL ) 50,50,10 C C SUBDIVIDE THE INTERVAL L,R C L : LOWER LIMIT OF THE INTERVAL (INPUT) C R : UPPER LIMIT OF THE INTERVAL (INPUT) C J : UPPER LIMIT OF LOWER SUB-INTERVAL (OUTPUT) C I : LOWER LIMIT OF UPPER SUB-INTERVAL (OUTPUT) C 200 I = L J = R M = (L+R)/2 X = A(M) 220 IF ( A(I) .GE. X ) GOTO 230 I = I+1 GOTO 220 230 IF ( A(J) .LE. X ) GOTO 231 J = J-1 GOTO 230 C 231 IF ( I .GT. J ) GOTO 232 W = A(I) A(I) = A(J) A(J) = W I = I+1 J = J-1 IF ( I .LE. J ) GOTO 220 C 232 LEVEL = LEVEL+1 IF ( (R-I) .GE. (J-L) ) GOTO 30 LT(LEVEL) = L RT(LEVEL) = J L = I GOTO 20 30 LT(LEVEL) = I RT(LEVEL) = R R = J GOTO 20 50 RETURN END *CMZ : 03/11/2000 12.13.41 by D. HECK IK3 FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= REAL FUNCTION GARNDM( ) C----------------------------------------------------------------------- C 1 EXPONENTIALLY DISTRIBUTED RANDOM NUMBER C----------------------------------------------------------------------- REAL RD(1) SAVE C----------------------------------------------------------------------- CALL RMMAR(RD,1,1) GARNDM = -LOG(RD(1)) RETURN END *CMZ : 28/02/2002 11.42.37 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE GRANOR(A,B) C----------------------------------------------------------------------- C G(HEISHA) RA(NDOM NUMBERS WITH) NOR(MAL DISTRIBUTION) C TWO GAUSSIAN DISTRIBUTED RANDOM NUMBERS (MEAN=0, SIGMA=1) C C RANDOM NUMBER GENERATORS USED BY THE GHEISHA ROUTINES C ADAPTED FOR USE WITH THE CORSIKA RANDOM NUMBER GENERATORS C C DESIGN : J. KNAPP IK1 FZK KARLSRUHE C----------------------------------------------------------------------- REAL RD(2) SAVE C----------------------------------------------------------------------- CALL RMMAR(RD,2,1) U1 = SQRT((-2.)*LOG(RD(1))) U2 = RD(2) * 6.28318530718 A = COS(U2) * U1 B = SIN(U2) * U1 RETURN END *CMZ : 28/02/2002 13.08.20 by D. HECK IK FZK KARLSRUHE *-- Author : CERN PROGLIB# V113 C======================================================================= SUBROUTINE GRNDM(RVEC,LENV) C----------------------------------------------------------------------- C G(HEISHA) R(A)ND(O)M (NUMBER GENERATOR) C C THIS ROUTINE IS IDENTICAL TO RMMAR C DESCRIPTION OF ALGORITHM SEE SUBROUT. RMMAR C THIS SUBROUTINE IS CALLED FROM GHEISHA ROUTINES. C ARGUMENTS: C RVEC = VECTOR FIELD TO BE FILLED WITH RANDOM NUMBERS C LENV = LENGTH OF VECTOR (# OF RANDNUMBERS TO BE GENERATED) C C CERN PROGLIB# V113 RMMAR .VERSION KERNFOR 1.0 C ORIG. 01/03/89 FCA + FJ C----------------------------------------------------------------------- REAL RVEC(*) COMMON /RANMA2/ IU(1030),JSEQ COMMON /RANMA3/ TWOM24,TWOM48,CD,CM,CINT,MODCNS INTEGER I97(0:1030),J97(0:1030),NTOT(0:1030),NTOT2(0:1030), * IJKL(0:1030) REAL U(1030),C(0:1030) EQUIVALENCE (IJKL(0),IU(1)),(NTOT(0),IU(2)),(NTOT2(0),IU(3)) EQUIVALENCE (U(1),IU(4)),(C(0),IU(101)),(I97(0),IU(102)) EQUIVALENCE (J97(0),IU(103)) SAVE C----------------------------------------------------------------------- ISEQ = 1 IF ( ISEQ .GT. 0 ) JSEQ = ISEQ IBASE = (JSEQ-1)*103 DO 100 IVEC = 1,LENV UNI = U(IBASE+I97(IBASE))-U(IBASE+J97(IBASE)) IF ( UNI .LT. 0. ) UNI = UNI+1. U(IBASE+I97(IBASE)) = UNI I97(IBASE) = I97(IBASE)-1 IF ( I97(IBASE) .EQ. 0 ) I97(IBASE) = 97 J97(IBASE) = J97(IBASE)-1 IF ( J97(IBASE) .EQ. 0 ) J97(IBASE) = 97 C(IBASE) = C(IBASE) - CD IF ( C(IBASE) .LT. 0. ) C(IBASE) = C(IBASE)+CM UNI = UNI-C(IBASE) IF ( UNI .LT. 0. ) UNI = UNI+1. C REPLACE EXACT ZEROES BY UNIFORM DISTR. *2**-24 IF ( UNI .EQ. 0. ) THEN UNI = TWOM24*U(2) C AN EXACT ZERO HERE IS VERY UNLIKELY, BUT LET'S BE SAFE. IF ( UNI .EQ. 0. ) UNI = TWOM48 ENDIF RVEC(IVEC) = UNI 100 CONTINUE NTOT(IBASE) = NTOT(IBASE) + LENV IF ( NTOT(IBASE) .GE. MODCNS ) THEN NTOT2(IBASE) = NTOT2(IBASE) + 1 NTOT(IBASE) = NTOT(IBASE) - MODCNS ENDIF RETURN END *CMZ : 18/10/2000 09.15.12 by D. HECK IK3 FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE AVEPT( ECM,SLOG ) C----------------------------------------------------------------------- C AVE(RAGE) PT (TRANSVERSE MOMENTUM) C C CALCULATES AVERAGE RATIO PT(PARTICLE)/PT(PION) DEPENDING ON ENERGY C THE DEPENDENCE OF PT ON ENERGY IS DONE IN SUBROUT. PTRAM/PTRAN C THIS SUBROUTINE IS CALLED FROM HDPM. C ARGUMENTS: C ECM = ENERGY IN THE CM SYSTEM C SLOG = LOG(S) ( = LOG(ECM**2) ) C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,AVPT. COMMON /AVPT/ AVPT,AVPK,AVPN,AVPH,AVPE DOUBLE PRECISION AVPT,AVPK,AVPN,AVPH,AVPE *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DOUBLE PRECISION ECM,SLOG SAVE C----------------------------------------------------------------------- CC IF ( DEBUG ) WRITE(MDEBUG,*) 'AVEPT : ECM =',SNGL(ECM) C AVERAGE TRANSVERSE MOMENTUM C ... FOR PIONS (=AVPT) IF ( ECM .LT. 132.D0 ) THEN AVPT = 0.3D0 + 6.272D-3 * SLOG ELSE AVPT = ( 0.442105D0 + 0.016276D0 * SLOG )**2 ENDIF C ... FOR KAONS (=AVPK) IF ( ECM .LT. 131.D0 ) THEN AVPK = 1.27D0 * AVPT ELSE AVPK = (0.403146D0 + 0.0281D0 * SLOG)**2 ENDIF C ... FOR NUCLEONS (=AVPN) IF ( ECM .LT. 102.D0 ) THEN AVPN = 1.39D0 * AVPT ELSE AVPN = (0.389873D0 + 0.034127D0 * SLOG)**2 ENDIF C SET AVERAGE PT RELATED TO AVERAGE PT FOR PIONS C ... FOR STRANGE BARYONS (=AVPH) AVPH = 1.3D0 * (1.45D0 * AVPN - 0.45D0 * AVPK) / AVPT C ... FOR ETA MESONS (=AVPE) AVPE = 1.3D0 * (0.88D0 * AVPK + 0.12D0 * AVPN) / AVPT AVPK = 1.3D0 * AVPK / AVPT AVPN = 1.3D0 * AVPN / AVPT AVPT = 1.3D0 IF ( DEBUG ) WRITE(MDEBUG,100) * SNGL(AVPT),SNGL(AVPK),SNGL(AVPN),SNGL(AVPH),SNGL(AVPE) 100 FORMAT(' AVEPT : AVPT,AVPK,AVPN,AVPH,AVPE=',5F12.5) RETURN END *CMZ : 11/07/2000 10.08.31 by D. HECK IK3 FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE DIFRAC( NRETFL ) C----------------------------------------------------------------------- C (SINGLE) DIF(F)RAC(TION) C C SETS PARAMETERS FOR HDPM IN CASE OF SINGLE DIFFRACTION C THIS SUBROUTINE IS CALLED FROM HDPM. C ARGUMENT: C NRETFL = 0 CORRECT ENDING OF SUBROUTINE C = 1 INCORRECT ENDING OF SUBROUTINE C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) *KEEP,DPMFLG. COMMON /DPMFLG/ NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM INTEGER NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM *KEEP,INTER. COMMON /INTER/ AVCH,AVCH3,DC0,DLOG,DMLOG,ECMDIF,ECMDPM,ELAB, * FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3, * RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG, * WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN, * IDIF,ITAR DOUBLE PRECISION AVCH,AVCH3,DC0,DLOG,DMLOG,ECMDIF,ECMDPM,ELAB, * FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3, * RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG, * WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN INTEGER IDIF,ITAR *KEEP,LEPAR. COMMON /LEPAR/ LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS INTEGER LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,REST. COMMON /REST/ CONTNE,TAR,LT DOUBLE PRECISION CONTNE(3),TAR INTEGER LT *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'DIFRAC:' C DECIDE FIRST, WHETHER PROJECTILE OR TARGET DIFFRACTION CALL RMMAR( RD,1,1 ) IF ( RD(1) .LE. 0.5 ) THEN C PROJECTILE DIFFRACTON, TARGET DIFFRACTION FLAG IS NOT SET NFTARD = 0 C MASS OF INCOMING PARTICLE AND PI(0) MASS C PI(0) IS MINIMAL OUTCOME OF SECONDARIES IN DIFRAC XM0 = ( PAMA(LEPAR1) + PAMA(7) )**2 ELSE C TARGET DIFFRACTON, SET TARGET DIFFRACTION FLAG NFTARD = 1 C MASS OF NUCLEON AND PI(0) MASS C PI(0) IS MINIMAL OUTCOME OF SECONDARIES IN DIFRAC XM0 = ( PAMA(LEPAR2) + PAMA(7) )**2 ENDIF C MAXIMAL DIFFRACTIVE MASS, FACTOR 0.15 GIVEN BY COHERENCE CONDITION XMX = 0.15D0 * S C THROW MAXIMAL 200 TIMES TO GET A GOOD DIFFRACTIVE MASS NCDIFL = 0 7 CONTINUE C GET DIFFRACTIVE MASS CALL RMMAR( RD,2,1 ) C GET S (=ECM**2) (WHY THIS WAY OF THROWING ???) SDIF = (XMX/XM0)**RD(1) * XM0 IF ( SDIF .LE. XM0 ) THEN IF ( NCDIFL .LE. 200 ) THEN NCDIFL = NCDIFL + 1 GOTO 7 ELSE C SET RETURN FLAG TO ERROR NRETFL = 1 RETURN ENDIF ENDIF C DISTRIBUTION OF DIFFRACTIVE MASS FLATTENS OFF FOR DIFFRACTIVE C MASS SQUARED .LE. 2 GEV IF ( SDIF .LE. 2.D0 ) THEN C----- SO GEHT DAS NICHT!! 16.12.91 D.H. SDIF = RD(2) * (2.D0 - XM0) + XM0 ENDIF C SQRT(S) IS ECM ECMDIF = SQRT(SDIF) C LOG(S), LOG(S)**2 DLOG = LOG(SDIF) DLOGSQ = DLOG**2 IF ( DEBUG ) WRITE(MDEBUG,*) 'DIFRAC: SDIF,ECMDIF,NFTARD=', * SNGL(SDIF),SNGL(ECMDIF),NFTARD C RAPIDITY IN CMS OF DIFFRACTIVE SYSTEM C TO CALCULATE DMLOG, SUBTRACT SUM OF MASS SQUARES FROM SDIF C PI(0) MASS SQUARED IS 0.0182. IF ( NFTARD .EQ. 0 ) THEN YY0 = LOG(ECMDPM/ECMDIF) DMLOG = LOG(SDIF - 0.0182D0 - PAMA(LEPAR1)**2) ELSE YY0 = -LOG(ECMDPM/ECMDIF) DMLOG = LOG(SDIF - 0.0182D0 - PAMA(LEPAR2)**2) ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'DIFRAC: YY0,DMLOG=', * SNGL(YY0),SNGL(DMLOG) C CENTRAL RAPIDITY DENSITY IN CMS OF DIFFRACTIVE SYSTEM C PARAMETRISATION SEE CAPDEVIELLE,J.PHYS.G:NUCL.PHYS.16(1990)1539 EQ.7 C WE USE ONLY THE LOW-ENERGY PART OF THE PARAMETRISATION, AS SDIF DOES C NOT REACH THE HIGHER VALUES DC0 = 0.82D0 * (SDIF**0.107D0) C THERE ARE 3 ENERGY DEPENDENT FORMULAS FOR AVERAGE CHARGED C MULTIPLICITY ( AVCH1 ); C PARAMETRISATIONS SEE CAPDEVIELLE,J.PHYS.G:NUCL.PHYS.16(1990)1539 EQ.8 IF ( ECMDIF .LE. 187.5D0 ) THEN C CHARGED MULTIPLICITY (M**2 IN PLACE OF S) AVCH1 = 0.57D0 + 0.584D0*DLOG + 0.127D0*DLOGSQ ELSEIF ( ECMDIF .LE. 945.5D0 ) THEN AVCH1 = -6.55D0 + 6.89D0 * SDIF**0.131D0 ELSE AVCH1 = 3.4D0 * SDIF**0.17D0 ENDIF C PARAMETRISATION IS BASED ON COLLIDER DATA WHERE PROTON AND ANTIPROTON C ARE INCLUDED. LOWER LIMIT FOR AVERAGE CHARGED MULTIPLICITY IS 1. AVCH1 = MAX( 1.D0, AVCH1 ) C CENTER OF GAUSSIAN 1ST+2ND STRING OF FRAGMENTATION SYSTEM POSC2 = 0.146D0 * DMLOG + 0.072D0 C WIDTH OF GAUSSIAN 1ST+2ND STRING OF FRAGMENTATION SYSTEM WIDC2 = 0.120D0 * DMLOG + 0.180D0 C INTERACTION FACTOR GNU FOR INTERACTION WITH NUCLEUS; IF ( NFLAIN .EQ. 0 ) THEN GNU = 1.D0 AVCH3 = 0.D0 POSC3 = 0.D0 WIDC3 = 1.D0 ELSE C NEW PARAMETRIZATION OF J.N.CAPDEVIELLE (MARCH 93) GNU = (0.4826D0 + 3.522D-2 * DLOG) * TAR**0.31D0 C CENTER OF GAUSSIAN FOR 3RD STRING (FROM TARGET) POSC3 = +3.D0 - 2.575D0 * EXP( (-0.081756452D0) * GNU ) C WIDTH OF GAUSSIAN FOR 3RD STRING (FROM TARGET) WIDC3 = 1.2338466D0 + 0.078969916D0 * LOG(GNU) IF ( ECMDIF .LE. 137.D0 ) THEN AVCH3 = 0.57D0 * AVCH1 * (GNU-1.D0) ELSE AVCH3 = 0.5D0 * AVCH1 * (GNU-1.D0) ENDIF ENDIF IF ( DEBUG ) WRITE(MDEBUG,100) * SNGL(POSC2),SNGL(WIDC2),SNGL(POSC3),SNGL(WIDC3) 100 FORMAT(' DIFRAC: POSC2,WIDC2,POSC3,WIDC3=',4F12.7) C AVERAGE CHARGED, INCLUDING THOSE FROM TARGET AVCH = AVCH1 + AVCH3 C THE FOLOWING PROCEDURE IS TO PRODUCE PHOTONS FROM UNKNOWN NEUTRAL C DECAYS FOLLOWING CORRELATION WITH CHARGED PARTICLES BASED ON C PHOTON EXCESS AT COLLIDER EXPERIMENTS. SEUGP IS C PROBLEM OF THE RISE OF THE UNKNOWN ETA PRODUCTION CROSS-SECTION C IS SOLVED WITH PARAMETRISATION OF UA5 (Z. PHYS. C43 (1989) 75) IF ( ECMDIF .LE. 103.D0 ) THEN SEUGP = -1.27D0 + 0.52D0 * DLOG + 0.148D0 * DLOGSQ ELSE C AT HIGH DIFFRACTIVE MASS USE PARAMETRISATION OF THOUW ???? SEUGP = -18.7D0 + 11.55D0 * SDIF**0.1195D0 ENDIF SEUGP = MAX( 0.5D0, SEUGP ) IF ( DEBUG ) WRITE(MDEBUG,110) * SNGL(DC0),SNGL(AVCH1),SNGL(AVCH3),SNGL(AVCH),SNGL(SEUGP) 110 FORMAT(' DIFRAC: DC0,AVCH1,AVCH3,AVCH,SEUGP=',5F12.6) C SET RETURN FLAG TO OK NRETFL = 0 RETURN END *CMZ : 28/02/2002 12.02.13 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= DOUBLE PRECISION FUNCTION DPFUNC( ENER ) C----------------------------------------------------------------------- C D(IFFRACTION) P(ORTION) FUNC(TION) C C CALCULATES THE FRACTION OF DIFFRACTION C THIS FUNCTION IS CALLED FROM HDPM. C ARGUMNENT: C ENER = C.M. ENERGY C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DOUBLE PRECISION ENER SAVE C----------------------------------------------------------------------- C FUNCTION DPFUNC IS DUMMY DPFUNC = 0.15D0 IF ( DEBUG ) WRITE(MDEBUG,*) * 'DPFUNC: ENER=',SNGL(ENER),' DPFUNC=',SNGL(DPFUNC) RETURN END *CMZ : 28/02/2002 13.08.20 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE HDPM C----------------------------------------------------------------------- C H(ADRONIC) D(UAL) P(ARTON) M(ODEL) C C GENERATOR OF HADRONIC COLLISION INSPIRED BY DUAL PARTON MODEL C THIS SUBROUTINE IS CALLED FROM SDPM. C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,DPMFLG. COMMON /DPMFLG/ NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM INTEGER NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM *KEEP,ELADPM. COMMON /ELADPM/ ELMEAN,ELMEAA,IELDPM,IELDPA DOUBLE PRECISION ELMEAN(40),ELMEAA(40) INTEGER IELDPM(40,13),IELDPA(40,13) *KEEP,ELASTY. COMMON /ELASTY/ ELAST DOUBLE PRECISION ELAST *KEEP,INDICE. COMMON /INDICE/ NNUCN,NKA0,NHYPN,NETA,NETAS,NPIZER, * NNC,NKC,NHC,NPC,NCH,NNN,NKN,NHN,NET,NPN INTEGER NNUCN(2:3),NKA0(2:3),NHYPN(2:3),NETA(2:3,1:4), * NETAS(2:3),NPIZER(2:3), * NNC,NKC,NHC,NPC,NCH,NNN,NKN,NHN,NET,NPN *KEEP,INTER. COMMON /INTER/ AVCH,AVCH3,DC0,DLOG,DMLOG,ECMDIF,ECMDPM,ELAB, * FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3, * RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG, * WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN, * IDIF,ITAR DOUBLE PRECISION AVCH,AVCH3,DC0,DLOG,DMLOG,ECMDIF,ECMDPM,ELAB, * FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3, * RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG, * WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN INTEGER IDIF,ITAR *KEEP,ISTA. COMMON /ISTA/ IFINET,IFINNU,IFINKA,IFINPI,IFINHY INTEGER IFINET,IFINNU,IFINKA,IFINPI,IFINHY *KEEP,LEPAR. COMMON /LEPAR/ LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS INTEGER LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS *KEEP,LONGI. COMMON /LONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG, * SDLONG,SELONG,SPLONG,THSTEP,THSTPI, * LHEIGH,NSTEP,LLONGI,FLGFIT DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9), * APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9), * HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9), * SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI INTEGER LHEIGH,NSTEP LOGICAL LLONGI,FLGFIT *KEEP,MULT. COMMON /MULT/ EKINL,MSMM,MULTMA,MULTOT DOUBLE PRECISION EKINL INTEGER MSMM,MULTMA(40,13),MULTOT(40,13) *KEEP,NEWPAR. COMMON /NEWPAR/ EA,PT2,PX,PY,TMAS,YR,ITYP, * IA1,IA2,IB1,IB2,IC1,IC2,ID1,ID2,IE1,IE2,IF1,IF2, * IG1,IG2,IH1,IH2,II1,II2,IJ1,NTOT DOUBLE PRECISION EA(3000),PT2(3000),PX(3000),PY(3000),TMAS(3000), * YR(3000) INTEGER ITYP(3000), * IA1,IA2,IB1,IB2,IC1,IC2,ID1,ID2,IE1,IE2,IF1,IF2, * IG1,IG2,IH1,IH2,II1,II2,IJ1,NTOT *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RATIOS. COMMON /RATIOS/ RPI0R,RPIER,RPEKR,RPEKNR,PPICH,PPINCH,PPNKCH, * ISEL,NEUTOT,NTOTEM DOUBLE PRECISION RPI0R,RPIER,RPEKR,RPEKNR,PPICH,PPINCH,PPNKCH INTEGER ISEL,NEUTOT,NTOTEM *KEEP,RESON. COMMON /RESON/ RDRES,RESRAN,IRESPAR REAL RDRES(2),RESRAN(30000) INTEGER IRESPAR *KEEP,REST. COMMON /REST/ CONTNE,TAR,LT DOUBLE PRECISION CONTNE(3),TAR INTEGER LT *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,SIGM. COMMON /SIGM/ SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO DOUBLE PRECISION SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO *KEND. DOUBLE PRECISION DPFUNC,RANNOR SAVE EXTERNAL DPFUNC,RANNOR C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=1,9) 444 FORMAT(' HDPM : CURPAR=',1P,9E10.3) C SET ANTI-LEADER TO PROTON OR NEUTRON; TARGET IS ALWAYS NUCLEON CALL RMMAR( RD,1,1 ) IF ( RD(1) .LE. CONTNE(LT) ) THEN ITAR = 13 ELSE ITAR = 14 ENDIF C CALCULATE LAB AND CM ENERGY IF ( ITYPE .NE. 1 ) THEN ELAB = PAMA(ITYPE) * GAMMA PLAB = ELAB * BETA S = PAMA(ITYPE)**2 + PAMA(ITAR)**2 + 2.D0*PAMA(ITAR)*ELAB ELSE C FOR GAMMA-INDUCED REACTION TAKE PI(0) AS LEADING PARTICLE ITYPE = 7 ELAB = GAMMA PLAB = ELAB S = PAMA(ITAR)**2 + 2.D0*PAMA(ITAR)*ELAB ENDIF ECMDPM = SQRT(S) IF ( DEBUG ) WRITE(MDEBUG,*) 'HDPM : ITYPE,ELAB,PLAB,S,ECMDPM=', * ITYPE,SNGL(ELAB),SNGL(PLAB),SNGL(S),SNGL(ECMDPM) C LN(S), LN(S)**2 AND RAPIDITY OF C. M. SYSTEM IN LAB SLOG = LOG(S) SLOGSQ = SLOG**2 SMLOG = LOG( 2.D0 * PAMA(ITAR) * ELAB ) ELABLG = LOG(ELAB) EPLUSP = ELAB + PLAB * YCM = 0.5D0 * LOG( (ELAB+PAMA(ITAR)+PLAB)/(ELAB+PAMA(ITAR)-PLAB) ) YCM = 0.5D0 * LOG( (EPLUSP**2 +PAMA(ITAR)*EPLUSP)/ * (PAMA(ITYPE)**2+PAMA(ITAR)*EPLUSP) ) IF ( DEBUG ) WRITE(MDEBUG,*) 'HDPM : SLOG,SLOGSQ,YCM=', * SNGL(SLOG),SNGL(SLOGSQ),SNGL(YCM) C----------------------------------------------------------------------- C RETURN POINT IF CALCULATION OF PARTICLES GOES WRONG 1 CONTINUE IF ( ITYPE .NE. 7 ) THEN C CHOOSE NUMBER OF INTERACTIONS IN TARGET CALL TARINT ELSE C FOR GAMMA-INDUCED REACTIONS TAKE ALWAYS ONE COLLISION GNU = 1.D0 ENDIF C----------------------------------------------------------------------- C NO DIFFRACTION IF C OR THE NUMBER OF INTERACTIONS IN TARGET IS CHOSEN RANDOMLY C AND MORE THAN ONE INTERACTION TAKES PLACE C OR PRIMARY PARTICLE IS GAMMA (PI0) C NOW NFLDIF DECIDES WHETHER DIFFRACTIVE PROCESS POSSIBLE OR NOT IF ( ( NFLAIN.EQ.0 .AND. GNU.GT.1.D0 .AND. NFLDIF.EQ.0 ) * .OR. ( ITYPE .EQ. 7 ) ) THEN IDIF = 0 ELSE C SET DIFFRACTION FLAG IF RANDOM NUMBER < PROBABILITY CALL RMMAR( RD,1,1 ) C IDIF IS 0 : NO DIFFRACTION ; IDIF IS 1 : DIFFRACTION C DIFFRACTION RISES WITH ENERGY AND SATURATES AT 10000 GEV C ### DAS TUT ES ABER NICHT: ES IST KONSTANT 0.15 (SIEHE DPFUNC) !!!! IF ( RD(1) .GT. DPFUNC(ECMDPM) ) THEN IDIF = 0 ELSE IDIF = 1 ENDIF ENDIF C PRINTOUT FOR DEBUG IF ( DEBUG ) THEN WRITE(MDEBUG,*) ' DIFFRACTIVE INTERACTION (0/1) = ',IDIF ENDIF C SET COUNTER FOR REPEAT TO 0 NREPRD = 0 C GENERATION OF INTERACTION 1919 CONTINUE C FLAG TO CHECK NUMBER OF SECONDARIES; C IS CHANGED TO 1 IF SECONDARY MULTIPLICITY IS LOW ISEL = 0 C SET LEADING PARTICLE TO INCOMING PARTICLE AND ANTI-LEADER TO NUCLEON C (AS IT COMES FROM TARGET NUCLEUS) BOTH MAY BE CHANGED BY LEPACX LEPAR1 = ITYPE LEPAR2 = ITAR IF ( IDIF .EQ. 0 ) THEN C----------------------------------------------------------------------- C NON SINGLE DIFFRACTIVE PROCESS STARTS HERE CALL NSD C CHARGE EXCHANGE ENABLED? EXCHANGE LEADER AND ANTI-LEADER LASTPI = 0 NRESPC = 0 NRESPN = 0 NCPLUS = 0 IF ( NFLCHE .EQ. 0 ) THEN CALL LEPACX( ECMDPM,ELABLG,LEPAR1,1 ) CALL LEPACX( ECMDPM,ELABLG,LEPAR2,2 ) ENDIF 1921 CONTINUE CALL RNEGBI( NCH,AVCH,ECMDPM ) C NCH IS # OF ALL CHARGED PARTICLES INCLUDING EXCESS FROM TARGET IF ( NCH .LT. 1 ) THEN IF ( LEPAR1 .LT. 50 .OR. LEPAR2 .LT. 50 ) THEN NREPRD = NREPRD + 1 IF ( NREPRD .GT. 10 ) GOTO 1 GOTO 1921 ELSE C INTERACTION IS ONLY RESONANCE PRODUCTION ISEL = 1 ENDIF ENDIF C WIDTH PLATEAU FOR CLUSTERS AND FOR CALCULATION OF CENTR.RAP.DENSITY DELRAP = 0.6722D0 * (2.95D0 + 0.0302D0 * SLOG) C SET RSLOG FOR CALCULATION OF PARTICLE RATIOS RSLOG = SLOG C AVERAGE TRANSVERSE MOMENTUM CALL AVEPT( ECMDPM,SLOG ) ELSE C----------------------------------------------------------------------- C SINGLE DIFFRACTIVE PROCESS STARTS HERE 1920 CONTINUE CALL DIFRAC( NRETDF ) IF ( NRETDF .EQ. 1 ) GOTO 1 C CHARGE EXCHANGE ENABLED? EXCHANGE CHARGE OF DIFFRACTING PARTICLE LASTPI = 0 NRESPC = 0 NRESPN = 0 NCPLUS = 0 IF ( NFLCHE .EQ. 0 ) THEN IF ( YY0 .GT. 0.D0 ) THEN C PROJECTILE DIFFRACTION CALL LEPACX( ECMDIF,DMLOG,LEPAR1,1 ) ELSE C TARGET DIFFRACTION CALL LEPACX( ECMDIF,DMLOG,LEPAR2,2 ) ENDIF ENDIF C FLUCTUATION OF MULTIPLICITY ACCORDING TO NEG.BIN. DISTRIBUTION CALL RNEGBI( NCH,AVCH,ECMDIF ) C REPEAT CALCULATION AS SOMETHING WENT WRONG IF ( NCH .LT. 1 ) THEN IF ( (YY0 .GT. 0.D0 .AND. LEPAR1 .LT. 50) .OR. * (YY0 .LT. 0.D0 .AND. LEPAR2 .LT. 50) ) THEN NREPRD = NREPRD + 1 IF ( NREPRD .GT. 10 ) GOTO 1 GOTO 1920 ELSE C DIFFRACTIVE INTERACTION IS ONLY RESONANCE PRODUCTION ISEL = 1 ENDIF ENDIF C SET RSLOG FOR CALCULATION OF PARTICLE RATIOS RSLOG = DLOG C HERE WE USE ECMDPM, BECAUSE THE MOMENTUM TRANSFER IS DEPENDENT C ON THE ENERGY OF THE TOTAL SYSTEM AND NOT ON THE DIFFRACTING MASS CALL AVEPT( ECMDPM,SLOG ) ENDIF C----------------------------------------------------------------------- C NOW FOR NSD AND DIFFRACTIVE PROCESSES C IN CASE OF LOW MULTIPLICITY SET FLAG ISEL IF ( NCH .LE. 2 ) ISEL=1 C FNCH IS FLUCTUATING TOT.NUMBER OF CHARGED PARTICLES FOR ALL 3 STRINGS FNCH = DBLE(NCH) C RATIO ALL CHARGED PARTICLES WITH FLUCTUATION/WITHOUT FLUCTUATION XZ = FNCH / AVCH C FNCH3 IS FLUCTUATING NUMBER OF CHARGED PARTICLES FOR 3RD STRING FNCH3 = XZ * AVCH3 C FNCH2 IS FLUCTUATING NUMBER OF CHARGED PARTICLES 1ST AND 2ND STRING FNCH2 = FNCH - FNCH3 C RC3TO2 IS RATIO (CHARGED 3RD STRING)/(CHARGED 1ST AND 2ND STRING) IF ( FNCH2 .NE. 0.D0 ) THEN RC3TO2 = FNCH3 / FNCH2 ELSE RC3TO2 = 0.D0 ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) ' FNCH,FNCH2,FNCH3,RC3TO2=', * SNGL(FNCH),SNGL(FNCH2),SNGL(FNCH3),SNGL(RC3TO2) C IS NUMBER OF NEUTRALS FLUCTUATING AS NUMBER OF CHARGED ? IF ( NFLPIF .EQ. 0 .OR. IDIF .EQ. 1 .OR. ECMDPM .LT. 60.D0 ) THEN C SET NUMBER OF GAMMAS ACCORDING TO NEG. BIN. VARIABLE XZ C AS NUMBER OF NEUTRALS FLUCTUATES AS CHARGED. SEUGF = SEUGP * XZ ZG = XZ ELSE C NFLPIF IS 1 MEANS: # OF PI(0) FLUCTUATES AS MEASURED AT COLLIDER IF ( ECMDPM .LT. 200.D0 ) THEN SEUGF = SEUGP * XZ * SEUGF = (0.0786D0*SLOG-0.010D0)*FNCH2 + (0.391D0*SLOG+0.305D0) ELSE C DETERMINE NEW NUMBER OF GAMMAS WITH FLUCTUATION AROUND SEUGP*XZ AGR = EXP(-XZ) DGR = SEUGP * XZ * (0.9823D0 - 0.3756D0 * AGR) SGS = DGR * (0.14718D0 + 2.53213D0 * AGR) 723 CONTINUE SEUGF = 0.88D0 * RANNOR(DGR,SGS) IF ( SEUGF .LT. 1.D0 ) GOTO 723 ENDIF C SET NEGATIVE BINOMIAL VARIABLE ZG FOR GAMMAS ZG = SEUGF / SEUGP ENDIF SEUGF = MAX( 1.D0, SEUGF ) IF ( DEBUG ) WRITE(MDEBUG,*) 'HDPM :XZ,ZG,SEUGF=', * SNGL(XZ),SNGL(ZG),SNGL(SEUGF) C----------------------------------------------------------------------- C RATIO ALL-NUCLEON/ALL-CHARGED C PARAMETRISATION FROM UA5, NUCL. PHYS. B291 (1987) 445 EQ.(2.4) RNUCCH = MAX( 0.D0, -0.008D0 + 0.00865D0 * RSLOG ) C NUMBER FOR DIRECT NEUTRON/ANTINEUTRON PRODUCTION 1ST AND 2ND STRING C MULTIPLY BY 0.5 BECAUSE RATIO RNUCCH GIVES (ALL-NUCL)/(ALL-CHARGED) C AND HERE ONLY THE NEUTRON-ANTINEUTRONS ARE COUNTED FNUCN = 0.5D0 * RNUCCH * FNCH2 C RATIO (ALL CHARGED SIGMAS)/(ALL CHARGED) IS 1/3 OF ALL STRANGE BARYON C PARAMETRISATION FORM UA5, NUCL. PHYS. B291 (1987) 445 EQ.(2.5) RHYPCH = MAX( 0.D0, (-0.007D0 + 0.0028D0 * RSLOG) * OB3 ) C NEUTRAL STRANGE BARYONS ARE DOUBLE OF CHARGED STRANGE BARYONS FHYPN = 2.D0 * RHYPCH * FNCH2 C CORRECT NUMBER OF GAMMAS FROM NEUTRAL HYPERON DECAY S0-->L+GAMMA SEUGFC = MAX( 0.D0, SEUGF - 0.5D0 * FHYPN ) C RATIO CHARGED-KAON/CHARGED PIONS C PARAMETRISATION FROM UA5, NUCL. PHYS. B291 (1987) 445 EQ.(2.7) RKPI = MAX (0.D0, 0.024D0 + 0.0062D0 * RSLOG ) C RKCH IS RATIO (CHARGED-KAON)/(ALL-CHARGED) DERIVED FROM RKPI; C THE FACTOR 0.5 IN FRONT OF RNUCCH IS BECAUSE ONLY HALF OF NUCLEONS C ARE P/PBAR. THE 1.17 IS AN APROXIMATE CONVERSION FACTOR FROM C (ALL-NUCL)/(ALL-CHARGED) TO (ALL-NUCL)/(CHARGED-PI), WHICH IS A BIT C ENERGY DEPENDENT (1.14 ...1.21) SEE GEICH-GIMBEL TABLE 7.1 RKCH = RKPI / (1.D0 + RKPI + (0.5D0*RNUCCH+RHYPCH) * 1.17D0) C K0/K0-BAR FOR 1ST AND 2ND STRING C NEUTRAL KAONS ARE PRODUCED WITH THE SAME RATE AS CHARGED KAONS FKA0 = RKCH * FNCH2 C RATIO ETA/PI(0) IS ASSUMED TO BE INDEPENDENT OF ENERGY = 0.19 C SEE: ANSORGE ET AL. (UA5-COLLABORATION) Z.PHYS.C43(1989)75 * RETPI0 = 0.19D0 C RATIO ETA/PI(0) IS ASSUMED TO BE DEPENDENT ON ENERGY C SEE: GEICH-GIMBEL,INT.J.MOD.PHYS.A4(1989)1527 TAB.7.1 C HECK'S FIT: RETPI0 IS 0.06 + 0.006*RSLOG + 0.0011*RSLOG**2 RETPI0 = 0.06D0 + 0.006D0 * RSLOG + 0.0011D0 * RSLOG**2 C AUXIL1 IS FRACTION OF PI(0)/(PI(0)+ETA) AUXIL1 = 1.D0 / (1.D0 + RETPI0) C NUMBER OF GAMMAS FROM PI(0) IS 2, FROM ETA IS 3.216 IN AVERAGE; C AUXIL2 IS NUMBER OF GAMMA-PRODUCING-PARTICLES: PI(0) AND ETA AUXIL2 = SEUGFC / ( AUXIL1 * 2.D0 + (1.D0 - AUXIL1) * 3.216D0 ) FETA = (1.D0 - AUXIL1) * AUXIL2 FPI0 = AUXIL1 * AUXIL2 C CORRECT FPI0 BY DECAYS OF STRANGE BARYONS; NEUTRAL: FHYPN*0.357 C CHARGED: 0.5*FNCH2*RHYPCH*0.5157; IT YIELDS FHYPN*(0.357+0.12893) FPI0 = MAX( 0.D0, FPI0 - FHYPN * 0.486D0 ) C SUMMED NEUTRAL PARTICLES FOR 1ST AND 2ND STRING FNEUT2 = FNUCN + FKA0 + FHYPN + FETA + FPI0 C NEUTRAL PARTICLES FROM 3RD STRING FNEUT3 = RC3TO2 * FNEUT2 C TOTAL NUMBER OF NEUTRALS FNEUT = FNEUT2 + FNEUT3 NEUTOT = NINT( FNEUT ) C CALCULATE TOTAL NUMBER OF PARTICLES TO BE CREATED NTOTEM = NCH + NEUTOT IF ( DEBUG ) WRITE(MDEBUG,*) * ' FNUCN,FKA0,FHYPN,FETA,FPI0,FNEUT2,FNEUT3,NTOTEM=', * SNGL(FNUCN),SNGL(FKA0),SNGL(FHYPN),SNGL(FETA),SNGL(FPI0), * SNGL(FNEUT2),SNGL(FNEUT3),NTOTEM C LIMIT OF SECONDARIES PRODUCED (GIVEN BY SIZE OF ARRAY : 3000) C LIMIT IS ARRAY SIZE - SIZE OF LARGEST TARGET NUCLEUS(40) IF ( NTOTEM .GE. 2956 ) THEN WRITE(MONIOU,*) 'HDPM : REJECT EVENT WITH ',NTOTEM, * ' SECONDARIES' GOTO 1 ENDIF C SPECIAL TREATMENT IF MULTIPLICITY IS TOO LOW IF ( NTOTEM .LE. 3 ) ISEL = 1 C FRACTION OF THE VARIOUS NEUTRAL PARTICLES (NN, K(0), L+S0 AS PAIRS) C NORMALIZE WITH THE SUM OF ALL NEUTRAL PARTICLES FNORML = 1.D0 / ( 0.5D0 * (FNUCN+FKA0+FHYPN) + FETA + FPI0 ) RNUCNR = FNUCN * FNORML * 0.5D0 RKA0R = FKA0 * FNORML * 0.5D0 RHYPNR = FHYPN * FNORML * 0.5D0 RETAR = FETA * FNORML RPI0R = FPI0 * FNORML C CUMULATED RATIOS (NN, K(0), LAMBDA+SIGMA0 AS PAIRS) RPIER = RPI0R + RETAR RPEKR = RPIER + RKA0R RPEKNR = RPEKR + RNUCNR C THEN THE REMAINDER (1-RPEKNR) MUST BE NEUTRAL HYPERON PAIRS IF ( DEBUG ) WRITE(MDEBUG,*) * ' RPI0R,RETAR,RKA0R,RNUCNR,RHYPNR,FNORML=', * SNGL(RPI0R),SNGL(RETAR),SNGL(RKA0R),SNGL(RNUCNR),SNGL(RHYPNR), * SNGL(FNORML) C PROBABILITY TO PRODUCE CHARGED PIONS IS PROBABILITY NOT TO PRODUCE C CHARGED KAONS OR PROTONS OR CHARGED HYPERONS, WHERE PROTON/ANTIPROTON C IS HALF OF (ALL-NUCL)/(ALL-CHARGED) AUXIL = RKCH + 0.5D0 * RNUCCH + RHYPCH AUXIL3 = 1.D0 - AUXIL C RENORMALIZATION AS P/P_BAR, K+-, AND HYPERONS ARE PRODUCED IN PAIRS C AUXIL2 IS INVERSE OF NORMALISATION AUXIL2 = 1.D0 / (1.D0 - 0.5D0 * AUXIL) C CUMULATED PROBABILITIES (PP, K+-, SIGMA+- AS PAIRS) PPICH = AUXIL3 * AUXIL2 PPINCH = PPICH + 0.25D0 * RNUCCH * AUXIL2 PPNKCH = PPINCH + 0.5D0 * RKCH * AUXIL2 C THEN THE REMAINDER (1-PPNKCH) MUST BE CHARGED HYPERON PAIRS IF ( DEBUG ) WRITE(MDEBUG,*) ' PPICH,PPINCH,PPNKCH=', * SNGL(PPICH),SNGL(PPINCH),SNGL(PPNKCH) C NOW SELECT HOW MANY PARTICLES OF EACH TYPE ARE PRODUCED CALL PARNUM( INUMFL ) IF ( INUMFL .NE. 0 ) GOTO 1919 C DEFINE PARTICLE NUMBERS WHERE SPECIAL RAPIDITY IS CALCULATED C FOR PARTICLES FROM TARGET (THIRD STRING) PPP = RC3TO2 / (1.D0+RC3TO2) C NUMBER OF PARTICLES IN PROTON ANTIPROTON PAIRS FROM TARGET ITA = NINT(PPP * 2.D0 * NNC) C NUMBER OF PARTICLES IN K+ K- PAIRS FROM TARGET ITB = NINT(PPP * 2.D0 * NKC) C NUMBER OF PARTICLES IN SIGMA+ SIGMA- PAIRS FROM TARGET ITC = NINT(PPP * 2.D0 * NHC) C NUMBER OF PI+ PI- FROM TARGET ITD = NINT(PPP * NPC ) C CALCULATE BOUNDARIES IA1 = 2 IA2 = IA1 + ITA IB1 = IA1 + 2 * NNC IB2 = IB1 + ITB IC1 = IB1 + 2 * NKC IC2 = IC1 + ITC ID1 = IC1 + 2 * NHC ID2 = ID1 + ITD IE1 = ID1 + NPC C NUMBER OF PARTICLES IN NEUTRON ANTINEUTRON PAIRS FROM TARGET IE2 = IE1 + 2 * NNUCN(3) IF1 = IE1 + 2 * NNN C NUMBER OF PARTICLES IN K0S K0L PAIRS FROM TARGET IF2 = IF1 + 2 * NKA0(3) IG1 = IF1 + 2 * NKN C NUMBER OF PARTICLES IN NEUTRAL HYPERON PAIRS FROM TARGET IG2 = IG1 + 2 * NHYPN(3) IH1 = IG1 + 2 * NHN C NUMBER OF ETA FROM TARGET IH2 = IH1 + NETAS(3) II1 = IH1 + NET C NUMBER OF PI(0) FROM TARGET II2 = II1 + NPIZER(3) IJ1 = II1 + NPN IF ( DEBUG ) THEN WRITE(MDEBUG,*) ' CHARGED FROM TARGET:',ITA,ITB,ITC,ITD WRITE(MDEBUG,*) ' NEUTRAL FROM TARGET:', * 2*NNUCN(3),2*NKA0(3),2*NHYPN(3),NETAS(3),NPIZER(3) WRITE(MDEBUG,*) ' NTOTEM,IJ1=',NTOTEM,IJ1 ENDIF C REDEFINE TOTAL NUMBER OF SECONDARY PARTICLES : NTOTEM C BY CHARGE EXCHANGE AND RESONANCE FORMATION THIS NUMBER MAY BE ALTERED NTOTEM = IJ1 - 2 C----------------------------------------------------------------------- C RATIO OF RAPIDITY DENSITY TO MEAN PSEUDORAPIDITY IN CENTER C PARAMETRISATION SEE CAPDEVIELLE, J.PHYS.G:NUCL.PHYS.15(1989)909,EQ.6 IF ( XZ .LT. 1.5D0 ) THEN RDS = (0.24396D0 + 0.70150424D0 * XZ)**2 ELSE RDS = (0.55685D0 + 0.48664753D0 * XZ)**2 ENDIF C CALCULATE NOW: DN/DY AT Y = 0; DC0 IS AVERAGE PSEUDORAPIDITY DENSITY C TRAP IS RATIO (RAPID.DENS.)/(PSEUDORAP.DENS.) IN CENTER OF RAPIDITY TRAP = 1.25D0 IF ( IDIF .EQ. 0 .AND. ECMDPM .GT. 19.4D0 ) * TRAP = MAX( 1.D0, 1.28852D0 - 0.0065D0 * SMLOG ) DCN2 = DC0 * RDS * TRAP IF ( DEBUG ) WRITE(MDEBUG,*) ' RDS,TRAP,DCN2=', * SNGL(RDS),SNGL(TRAP),SNGL(DCN2) C AMPLITUDE OF GAUSSIAN 1ST AND 2ND STRING ATG2 = FNCH2 / (5.0132566D0 * WIDC2) C NEW DEFINITION OF POSITION BASED ON SEMI INCLUSIVE DATA SQ2 = 2.D0 * ATG2 / DCN2 C FINAL POSITION OF GAUSSIAN; WIDTH WIDC2 IS UNCHANGED IF ( SQ2 .GT. 1.D0 ) POSC2 = WIDC2 * SQRT( 2.D0*LOG(SQ2) ) C DENSITY OF CHARGED IN EXCESS FROM TARGET IN CENTER OF RAPIDITY DCN3 = 0.5D0 * (GNU - 1.D0) * DCN2 IF ( DEBUG ) WRITE(MDEBUG,*) ' SQ2,POSC2,DCN3=', * SNGL(SQ2),SNGL(POSC2),SNGL(DCN3) IF ( DCN3 .GT. 0.D0 ) THEN C AMPLITUDE 3RD GAUSSIAN ATG3 = FNCH3 / (5.0132566D0 * WIDC3) C AMPLITUDE IS DIVIDED BY DENSITY FOR GETTING CENTER OF 3RD GAUSSIAN SQ3 = 2.D0 * ATG3 / DCN3 C CHECK IF ADDITIVE MULTIPLICITY IS TOO LOW IF ( SQ3 .GT. 1.D0 ) POSC3 = WIDC3 * SQRT( 2.D0*LOG(SQ3) ) IF (DEBUG) WRITE(MDEBUG,*)' SQ3,POSC3=',SNGL(SQ3),SNGL(POSC3) ENDIF C NFLPI0 .EQ. 0 MEANS TREAT PI(0) RAPIDITY ACCORDING TO COLLIDER DATA IF ( NFLPI0 .EQ. 0 ) THEN C RATIO OF RAPIDITY DENSITY TO MEAN PSEUDORAPIDITY AT CENTER WITH Z<1.5 IF ( ZG .LT. 1.5D0 ) THEN RDG = (0.24396D0 + 0.70150424D0 * ZG)**2 ELSE RDG = (0.55685D0 + 0.48664753D0 * ZG)**2 ENDIF C GAMMAS USE RATIO TRAG TO CALCULATE RATIO OF RAPIDITY TO C PSEUDO RAPIDITY DENSITY IN CENTER (TRAG = 1.1 * 0.5 ). C FACTOR 0.5 COMES FROM RATIO NEUTRAL/CHARGED, AS WE USE DC0, WHICH C IS AVERAGE PSEUDORAPIDITY DENSITY FOR CHARGED PIONS TRAG = 0.55D0 IF ( IDIF .EQ. 0 ) THEN IF ( ECMDPM .GT. 19.4D0 ) * TRAG = MAX( 0.4D0, 0.6658D0 - 0.01954D0 * SMLOG ) IF ( ECMDPM .LE. 50.D0 ) THEN DCG = DC0 * RDG * TRAG ELSEIF ( ECMDPM .LE. 200.D0 ) THEN DCG = DC0 * RDG * TRAG * (1.D0 + 0.18D0 * LOG(ECMDPM/50.D0)) ELSE DCG = DC0 * RDG * TRAG * 1.25D0 ENDIF ELSE DCG = DC0 * RDG * TRAG ENDIF C DEFINE WIDTH OF STRINGS FOR NEUTRAL PIONS AND ETAS WIDN2 = WIDC2 * MIN( 1.D0, 1.12275D0 - 0.0208D0 * RSLOG ) C NEW DEFINITION OF CENTER OF GAUSSIAN BASED ON SEMI INCLUSIVE DATA C USING AMPLITUDE OF THE GAUSSIAN FOR NEUTRALS AUXIL = 2.D0 / (5.0132566D0 * WIDN2 * DCG) C TOTAL MULTIPLICITY USED FOR 1ST AND 2ND STRING OF PI(0) AND ETA C IS GIVEN BY THEIR NUMBERS. ANALOGOUS FOR 3RD STRING SP2 = DBLE ( NPIZER(2)+NETAS(2)) * AUXIL C FINAL CENTER OF GAUSSIANS FOR PI(0) AND ETA (WIDC2 IS UNCHANGED) IF ( SP2 .GT. 1.D0 ) THEN POSN2 = WIDN2 * SQRT( 2.D0 * LOG(SP2) ) ELSE POSN2 = POSC2 ENDIF WIDN3 = WIDN2 SP3 = DBLE(NPIZER(3)+NETAS(3)) * AUXIL IF ( SP3 .GT. 1.D0 ) THEN POSN3 = WIDN3 * SQRT( 2.D0 * LOG(SP3) ) ELSE POSN3 = POSC3 ENDIF ELSE C NFLPI0 .EQ. 1 MEANS RAPIDITY OF PI(0) AND ETA SAME AS THAT OF CHARGED POSN2 = POSC2 WIDN2 = WIDC2 POSN3 = POSC3 WIDN3 = WIDC3 ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) * ' ZG,RDG,DCG,SP2,SP3,POSN2,POSN3,WIDN2 =', * SNGL(ZG),SNGL(RDG),SNGL(DCG),SNGL(SP2),SNGL(SP3),SNGL(POSN2), * SNGL(POSN3),SNGL(WIDN2) C----------------------------------------------------------------------- NREPR1 = 0 C RETURN POINT. NUMBERS OF PARTICLES REMAIN UNCHANGED FOR NEXT TRY, C BUT INDIVIDUAL RAPIDITIES GET NEW VALUES. C START FROM BEGINNING IF NO MATCH AFTER 20 TRIES 30 CONTINUE NREPR1 = NREPR1 + 1 IF ( NREPR1 .GT. 20 ) THEN IF ( IDIF .EQ. 1 .AND. NREPRD .LE. 10 ) GOTO 1919 GOTO 1 ENDIF C FOR TOTAL NUMBER OF PARTICLES ADD 2 FOR LEADER AND ANTILEADER NTOT = NTOTEM + 2 C PRODUCTION OF INDIVIDUAL RAPIDITIES FOR ALL SECONDARY PARTICLES CALL PARRAP CC IF ( DEBUG ) THEN CC WRITE(MDEBUG,*) ' RAPIDITIES:' CC WRITE(MDEBUG,134) (I,YR(I), I=3,NTOT) C134 FORMAT(' ',1P, (1X, I4, 5X, G13.6 )) CC ENDIF C CALCULATION OF CENTRAL RAPIDITY WITHOUT (ANTI)LEADER C MULTIPLICITY IN CENTER OF RAPIDITY DISTRIBUTION IZN = 0.D0 IF ( IDIF .EQ. 0 ) THEN DO 111 I = 3,NTOT IF ( ABS(YR(I)) .LT. DELRAP ) IZN = IZN + 1 111 CONTINUE IF ( IZN .LT. 1 ) THEN IF ( ISEL .EQ. 0 ) GOTO 30 C IN CASE OF FEW PARTICLES, SET PARTICLE NUMBER IN PLATEAU TO 1 IZN = 1 ENDIF C CENTRAL RAPIDITY DENSITY FOR CHARGED PARTICLES IF ( NTOTEM .GE. 1 ) THEN ZNC = MAX( 1.1D0, DBLE(NCH)*IZN/(DBLE(NTOTEM)*2.D0*DELRAP) ) ELSE ZNC = 1.1D0 ENDIF ELSE C DIFFRACTION: SHIFT RAPIDITIES + TAKE CENT.RAP.DENS. FROM PARAMETRISAT DO 112 I = 3,NTOT YR(I) = YR(I) + YY0 112 CONTINUE ZNC = MAX( 1.1D0, DCN2 ) ENDIF C ZN ACCOUNTS FOR THE RISE OF PT WITH CENTRAL RAP.DENSITY. THE FORMULA C IS A FIT TO UA1 VALUES OF ARNISON ET AL, PHYS.LETT.B118(1982)167 C REGARD, THAT OUR ZN IS DEFINED DIFFERENT FROM LITERATURE N BY 1 C - - - - - - C MODIFICATION AFTER J.N. CAPDEVIELLE, (DEC.96) * IF ( ECMDPM .LE. 500.D0 ) THEN * ZN = MAX( 1.00001D0, 3.669D0 / ZNC**0.435D0 + 6.4D0 ) * ELSE C TAKE INTO ACCOUNT THE RESULTS OF UA1/MIMI EXPERIMENT C FOR SMALL CENTR. RAP. DENS. RHOC < 3.00 (MIMI)(TO BE USED IN PTRAM) IF ( ZNC .LT. 3.D0 ) THEN PTAVE = 0.0033D0 * (ZNC-1.56D0)**2 + 0.406D0 ELSE C FOR LARGE CENTR. RAP. DENSITIES PTAVE = ZNC*0.010853D0 + 0.3828D0 ENDIF ZN = 2.64D0/PTAVE + 3.D0 * ENDIF C - - - - - - C NOW SET PARTICLE TYPE AND TRANSV. MOMENTA FOR NEW PARTICLES IN PPARAM C SET ALSO TRANSVERSE MASS FOR ALL PARTICLES (INCL. LEADER+ANTILEADER) CALL PPARAM IF ( IDIF .EQ. 0 ) THEN C NOW SET THE RAPIDITY OF THE ANTILEADER ACCORDING TO THE DISTRIBUTION C IN THE FEYNMAN X VARIABLE; SET THE RAPIDITY OF LEADER TO CONSUME C THE REMAINDER OF ENERGY CALL LEDENY( LEDEFL ) IF ( LEDEFL .NE. 0 ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) ' LEDEFL=',LEDEFL GOTO 30 ENDIF C CALCULATE FOR SINGLE COLLISION SYSTEM C.M. ENERGY + RAPIDITY SHIFT IF ( GNU .LE. 1.D0 ) THEN JGNU = 0.D0 DYGNU = 0.D0 ECMJAD = ECMDPM ELSE C MULTIPLE COLLISION IN TARGET JGNU = NINT(GNU-1.D0) C ADD ADDITIONALLY INTERACTING C TARGET NUCLEONS TO GET CORRECT JADACH FILTERING C CHOSE RANDOMLY WHETHER PROTON OR NEUTRON CALL RMMAR( RD,JGNU,1 ) IPR = 0 INE = 0 TARMAS = PAMA(ITYP(2)) DO 114 I = 1,JGNU NTOT = NTOT + 1 IF ( RD(I) .LE. .5D0 ) THEN ITYP(NTOT) = 13 INE = INE + 1 ELSE ITYP(NTOT) = 14 IPR = IPR + 1 ENDIF TMAS(NTOT) = PAMA(ITYP(NTOT)) TARMAS = TARMAS + TMAS(NTOT) EA(NTOT) = TMAS(NTOT) PX(NTOT) = 0.D0 PY(NTOT) = 0.D0 PT2(NTOT) = 0.D0 114 CONTINUE C CALCULATE C.M. ENERGY + RAPIDITY SHIFT * YCMGNU = 0.5D0 * LOG( (ELAB+TARMAS+PLAB)/(ELAB+TARMAS-PLAB) ) YCMGNU = 0.5D0 * LOG( (EPLUSP**2 +TARMAS*EPLUSP)/ * (PAMA(ITYPE)**2+TARMAS*EPLUSP) ) DYGNU = YCM - YCMGNU C CALCULATE RAPIDITIES OF ADDITIONALLY INTERACTING TARGET NUCLEONS C IN THE CM SYSTEM OF NUCLEON-NUCLEON SYSTEM DO 115 I = NTOT-JGNU+1,NTOT YR(I) = - YCM 115 CONTINUE C SHIFT RAPIDITIES INTO CM SYSTEM OF GNU+1 MASSES DO 113 I = 1,NTOT YR(I) = YR(I) + DYGNU 113 CONTINUE C CENTER OF MASS ENERGY OF 1 PROJECTILE AND GNU TARGET NUCLEONS TO C BE USED IN THE JADACH FILTER. ECMJAD = SQRT( PAMA(ITYPE)**2 + TARMAS**2 + 2.D0*TARMAS*ELAB ) ENDIF ELSE C IN CASE OF DIFFRACTION SET THE RAPIDITY OF LEADER AND ANTILEADER C IN SUBROUT. LEADDF DYGNU = 0.D0 ECMJAD = ECMDPM CALL LEADDF( IFLGLD ) IF ( IFLGLD .NE. 0 ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) ' IFLGLD=',IFLGLD GOTO 30 ENDIF ENDIF C CORRECT THE RAPIDITIES TO CONSERVE LONGITUDINAL MOMENTA AND ENERGY C USING THE ALGORITHM OF JADACH (SIMPLIFIED VERSION BY R. ATTALLAH) CALL JADACH( ECMJAD,JADFLG ) IF ( JADFLG .NE. 0 ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) ' JADFLG=', JADFLG IF ( JADFLG .GT. 0 ) GOTO 30 IF ( JADFLG .LT. 0 ) THEN NREPRD = NREPRD + 1 IF ( NREPRD .GT. 10 ) GOTO 1 GOTO 1919 ENDIF ENDIF C CALCULATE LAB ENERGIES OF SECONDARY PARTICLES FROM THE RAPIDITIES C INCLUDING THE ADDITIONAL TARGET NUCLEONS ETOT = 0.D0 DO 135 I = 1,NTOT YR(I) = YR(I) + YCM - DYGNU EA(I) = TMAS(I) * COSH( YR(I) ) ETOT = ETOT + EA(I) 135 CONTINUE IF ( DEBUG ) WRITE(MDEBUG,136) * (I,ITYP(I),PX(I),PY(I),YR(I),EA(I),I=1,NTOT) 136 FORMAT(' NO ITYP PX PY YR EA'/ * (' ',I4,I3,1X,1P,4G13.6) ) C----------------------------------------------------------------------- C LOOP OVER ALL SECONDARY PARTICLES AND THE LEADING PARTICLE C PROCESS LOOP DO 140 J = 1,NTOT C REJECTION OF BACKWARD GOING PARTICLES IF ( YR(J) .LE. 0.D0 ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) 'HDPM : YR REJECT PARTICLE ',J IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + EA(J) ENDIF GOTO 140 ENDIF C CALCULATE THE PROPERTIES OF ALL SECONDARIES C PARTICLE TYPE SECPAR(1) = ITYP(J) C CALCULATE GAMMA FACTOR SECPAR(2) = EA(J) / PAMA(ITYP(J)) C TOTAL MOMENTUM SQUARED PTM = EA(J)**2 - PAMA(ITYP(J))**2 IF ( PT2(J) .GT. PTM ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) 'HDPM : PT REJECT PARTICLE ',J IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + EA(J) ENDIF GOTO 140 ENDIF C EMISSION ZENITH ANGLE AGAINST TRAJECTORY OF PROJECTILE IF ( PTM .EQ. 0.D0 ) THEN COSTET = 1.D0 ELSE COSTET = SQRT( 1.D0 - PT2(J) / PTM ) ENDIF C EMISSION AZIMUTH ANGLE IF ( PX(J) .NE. 0.D0 .OR. PY(J) .NE. 0.D0 ) THEN PHIJ = ATAN2( PY(J), PX(J) ) ELSE PHIJ = 0.D0 ENDIF CALL ADDANG( COSTHE,PHI, COSTET,PHIJ, SECPAR(3),SECPAR(4) ) IF ( SECPAR(3) .LT. C(29) ) THEN C OMIT UPWARD GOING PARTICLES IF (DEBUG) WRITE(MDEBUG,*) 'HDPM : ANGLE REJECT PARTICLE ',J IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + EA(J) ENDIF GOTO 140 ENDIF C PUT SECONDARY PARTICLES ON STACK, IF NOT GOING UPWARDS IF ( J .GT. 2 ) THEN CALL TSTACK ELSE C PUT LEADER OR ANTI-LEADER ON STACK, IF NOT GOING UPWARDS IF ( ITYP(J) .GT. 50 ) THEN C LEADER OR ANTI LEADER ARE RESONANCES AND DECAY IRESPAR = IRESPAR + 1 IF ( IRESPAR .GE. 30000 ) THEN WRITE(MONIOU,*) * 'HDPM : STACK OF RESDEC RANDOM NUMBERS FULL' IRESPAR = 29999 ENDIF RESRAN(IRESPAR) = RDRES(J) C COUNTER FOR ENERGY-MULTIPLICITY MATRIX MSMM = MSMM + 1 ENDIF CALL TSTACK C CALCULATE ELASTICITY FROM ENERGY OF LEADER (REST OF RESONANCE DECAY) IF ( J. EQ. 1 ) ELASTI = SECPAR(2)*PAMA(NINT(SECPAR(1)))/ELAB ENDIF C COUNTERS FOR FIRST INTERACTION IF ( FIRSTI ) THEN IF ( SECPAR(1) .EQ. 7.D0 .OR. SECPAR(1) .EQ. 8.D0 * .OR. SECPAR(1) .EQ. 9.D0 ) THEN IFINPI = IFINPI + 1 ELSEIF ( SECPAR(1) .EQ. 13.D0 .OR. SECPAR(1) .EQ. 14.D0 * .OR. SECPAR(1) .EQ. 15.D0 .OR. SECPAR(1) .EQ. 25.D0 ) THEN IFINNU = IFINNU + 1 ELSEIF ( SECPAR(1) .EQ. 10.D0 .OR. SECPAR(1) .EQ. 11.D0 * .OR. SECPAR(1) .EQ. 12.D0 .OR. SECPAR(1) .EQ. 16.D0 ) THEN IFINKA = IFINKA + 1 ELSEIF ( SECPAR(1) .GE. 71.D0 .AND. SECPAR(1) .LE. 74.D0) THEN IFINET = IFINET + 1 ELSEIF ((SECPAR(1) .GE. 18.D0 .AND. SECPAR(1) .LE. 24.D0) * .OR. (SECPAR(1) .GE. 26.D0 .AND. SECPAR(1) .LE. 32.D0))THEN IFINHY = IFINHY + 1 ENDIF ENDIF 140 CONTINUE C COUNTER FOR ENERGY-MULTIPLICITY MATRIX MSMM = MSMM + NTOT - 2 C FILL ELASTICITY IN MATRICES MEL = MIN ( 1.D0+10.D0* MAX( 0.D0, ELASTI ) , 11.D0 ) MEN = MIN ( 4.D0+ 3.D0*LOG10(MAX( .1D0, EKINL )), 40.D0 ) IELDPM(MEN,MEL) = IELDPM(MEN,MEL) + 1 IELDPA(MEN,MEL) = IELDPA(MEN,MEL) + 1 IF ( ELASTI .LT. 1.D0 ) THEN ELMEAN(MEN) = ELMEAN(MEN) + ELASTI ELMEAA(MEN) = ELMEAA(MEN) + ELASTI ENDIF IF ( FIRSTI ) THEN TARG1I = TAR SIG1I = SIGAIR ELAST = ELASTI FIRSTI = .FALSE. ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'HDPM : ELAST=',SNGL(ELASTI), * SNGL(ETOT),SNGL(ELAB) RETURN END *CMZ : 28/09/2001 16.38.22 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE JADACH( ECMJAD,JADFLG ) C----------------------------------------------------------------------- C JADACH (FILTER) C C ADJUSTS THE RAPIDITIES OF ALL SECONDARIES SUCH THAT C ENERGY AND LONGITUDINAL MOMENTUM ARE CONSERVED AT THE SAME TIME C THE ALGORITHM IS TAKEN FROM S.JADACH, COM.PHYS.COMM. 9 (1975) 297 C THE ROUTINE MUST BE CALLED AFTER THE PT IS CONSERVED AND BEFORE C THE TRANSFORMATION TO THE LAB SYSTEM IS DONE C THIS SUBROUTINE IS CALLED FROM HDPM. C ARGUMENTS: C ECMJAD = CM ENERGY IN THE PROJECTILE -- GNU*NUCLEONS SYSTEM C JADFLG = 0 JADACH FILTER CORRECTLY ENDED C = 1 BAD RAPIDITIES, SELECT RAPIDITIES AGAIN C =-1 SUM OF TRANSVERSE MASSES EXCEEDS AVAILABLE CM ENERGY C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) *KEEP,INTER. COMMON /INTER/ AVCH,AVCH3,DC0,DLOG,DMLOG,ECMDIF,ECMDPM,ELAB, * FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3, * RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG, * WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN, * IDIF,ITAR DOUBLE PRECISION AVCH,AVCH3,DC0,DLOG,DMLOG,ECMDIF,ECMDPM,ELAB, * FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3, * RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG, * WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN INTEGER IDIF,ITAR *KEEP,NEWPAR. COMMON /NEWPAR/ EA,PT2,PX,PY,TMAS,YR,ITYP, * IA1,IA2,IB1,IB2,IC1,IC2,ID1,ID2,IE1,IE2,IF1,IF2, * IG1,IG2,IH1,IH2,II1,II2,IJ1,NTOT DOUBLE PRECISION EA(3000),PT2(3000),PX(3000),PY(3000),TMAS(3000), * YR(3000) INTEGER ITYP(3000), * IA1,IA2,IB1,IB2,IC1,IC2,ID1,ID2,IE1,IE2,IF1,IF2, * IG1,IG2,IH1,IH2,II1,II2,IJ1,NTOT *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DIMENSION YRJAD(3000) SAVE DATA EPS / 1.D-7 / C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'JADACH: NTOT=',NTOT JADFLG = 0 C SUM UP TRANSVERSE MOMENTA AND COMPARE WITH AVAILABLE C.M.ENERGY STMAS = 0.D0 ECMI = 1.D0 / ECMJAD DO 4 I = 1,NTOT STMAS = STMAS + TMAS(I) YRJAD(I) = YR(I) 4 CONTINUE REST = ( ECMJAD - STMAS ) * ECMI IF ( REST .LE. 0.D0 ) THEN C SUMMED TRANSVERSE MASS > AVAILABLE C.M. ENERGY JADFLG = -1 RETURN ENDIF FACT = 1.5D0 / REST AA = 1.D0 DIFOLD = 0.D0 JCOUNT = 0 C OPTIMIZATION LOOP TO DEFINE PARAMETER AA 1 CONTINUE JCOUNT = JCOUNT + 1 IF ( JCOUNT .GE. 50 ) GOTO 999 C FORM SUMS S1 AND S2 S1 = 0.D0 S2 = 0.D0 DO 5 I = 1,NTOT EXPO = EXP( AA * YR(I) ) S1 = S1 + TMAS(I) * ECMI * EXPO S2 = S2 + TMAS(I) * ECMI / EXPO 5 CONTINUE DIFF = 0.1D0 * LOG(S1*S2) C ACCELERATING OF CONVERGENCE IF NO CHANGE OF SIGN IN DIFF IF ( DIFOLD*DIFF .GE. 0.D0 ) DIFF = DIFF * FACT DIFOLD = DIFF IF ( DEBUG ) WRITE(MDEBUG,*) ' DIFF=',SNGL(DIFF) AA = AA * MAX( 0.1D0, (1.D0 - DIFF) ) IF ( ABS(DIFF) .GT. EPS ) GOTO 1 C ITERATION HAS CONVERGED, CALCULATE PARAMETER BB BB = 0.5D0 * LOG(S2/S1) IF ( DEBUG ) WRITE(MDEBUG,110) JCOUNT,STMAS,REST 110 FORMAT(' JCOUNT, STMAS, REST = ',I5,2E13.5,/ * ' NUM ITYP TMAS YR(OLD) YR(NEW)') C CORRECT RAPIDITIES DO 10 I = 1,NTOT YR(I) = AA * YR(I) + BB IF ( DEBUG ) WRITE(MDEBUG,111) I,ITYP(I),TMAS(I),YRJAD(I),YR(I) 111 FORMAT(' ',I4,I6,F12.5,2F16.8) C IMPOSSIBLE RAPIDITY, DETERMINE AGAIN THE RAPIDITIES IF ( ABS(YR(I)) .GT. LOG(ECMJAD/PAMA(ITYP(I))) ) GOTO 999 10 CONTINUE RETURN C ERROR EXIT 999 JADFLG = 1 C NO CONVERGENCE AFTER 50 ITERATIONS OR IMPOSSIBLE RAPIDITY RETURN END *CMZ : 14/06/2000 14.29.37 by D. HECK IK3 FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE LEADDF( IFLGLD ) C----------------------------------------------------------------------- C LEAD(ING PARTICLE RAPIDITY FOR) D(I)F(FFRACTING SYSTEM) C C SELECTS THE RAPIDITY OF THE (ANTI)LEADING PARTICLES IN CASE OF C DIFFRACTION. THE NON-DIFFRACTING (ANTI)LEADER GETS ITS RAPIDITY C FROM THE REMAINDER ENERGY, THE DIFFRACTING (ANTI)LEADER GETS ITS C RAPIDITY FROM THE GAUSSIAN (STRING) OF THE DECAYING DIFFRACTIVE MASS. C THIS SUBROUTINE IS CALLED FROM HDPM. C ARGUMENT: C IFLGLD = 0 RAPIDITY SELECTION SUCCESSFUL C = 1 RAPIDITY SELECTION NOT SUCCESSFULL C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) *KEEP,INTER. COMMON /INTER/ AVCH,AVCH3,DC0,DLOG,DMLOG,ECMDIF,ECMDPM,ELAB, * FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3, * RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG, * WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN, * IDIF,ITAR DOUBLE PRECISION AVCH,AVCH3,DC0,DLOG,DMLOG,ECMDIF,ECMDPM,ELAB, * FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3, * RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG, * WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN INTEGER IDIF,ITAR *KEEP,LEPAR. COMMON /LEPAR/ LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS INTEGER LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS *KEEP,NEWPAR. COMMON /NEWPAR/ EA,PT2,PX,PY,TMAS,YR,ITYP, * IA1,IA2,IB1,IB2,IC1,IC2,ID1,ID2,IE1,IE2,IF1,IF2, * IG1,IG2,IH1,IH2,II1,II2,IJ1,NTOT DOUBLE PRECISION EA(3000),PT2(3000),PX(3000),PY(3000),TMAS(3000), * YR(3000) INTEGER ITYP(3000), * IA1,IA2,IB1,IB2,IC1,IC2,ID1,ID2,IE1,IE2,IF1,IF2, * IG1,IG2,IH1,IH2,II1,II2,IJ1,NTOT *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DOUBLE PRECISION RANNOR SAVE EXTERNAL RANNOR C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'LEADDF: LEPAR1,LEPAR2=', * LEPAR1,LEPAR2 IF ( YY0 .GT. 0.D0 ) THEN C PROJECTILE DIFFRACTION; CALCULATE TARGET RAPIDITY USING TARGET C ENERGY ECMTAR AND LONGITUDINAL MOMENTUM PCMTAR THE IN C.M. SYSTEM ECMTAR = (ECMDPM**2 - ECMDIF**2 + TMAS(2)**2) / (2.D0 * ECMDPM) PTLSQ = ECMTAR**2 - TMAS(2)**2 IF ( PTLSQ .LE. 0.D0 ) THEN IFLGLD = 1 RETURN ENDIF PCMTAR = SQRT(PTLSQ) * YR(2) = (-0.5D0) * LOG( (ECMTAR+PCMTAR) / (ECMTAR-PCMTAR) ) YR(2) = - LOG( (ECMTAR+PCMTAR) / TMAS(2) ) C RAPIDITY OF DIFFRACTING PROJECTILE CALL RMMAR( RD,1,1 ) IF ( RD(1) .GE. 0.5 ) THEN YR(1) = RANNOR( POSC2, WIDC2 ) + YY0 ELSE YR(1) = RANNOR(-POSC2, WIDC2 ) + YY0 ENDIF ELSE C TARGET DIFFRACTION; CALCULATE PROJECTILE RAPIDITY USING PROJECTILE C ENERGY ECMPRO AND LONGITUDINAL MOMENTUM PLPRO IN THE C.M. SYSTEM ECMPRO = (ECMDPM**2 -ECMDIF**2 +TMAS(1)**2) / (2.D0*ECMDPM) PPLSQ = ECMPRO**2 - TMAS(1)**2 IF ( PPLSQ .LE. 0.D0 ) THEN IFLGLD = 1 RETURN ENDIF PCMPRO = SQRT(PPLSQ) * YR(1) = 0.5D0 * LOG( (ECMPRO+PCMPRO) / (ECMPRO-PCMPRO) ) YR(1) = LOG( (ECMPRO+PCMPRO) / TMAS(1) ) C RAPIDITY OF DIFFRACTING TARGET NUCLEON CALL RMMAR( RD,1,1 ) IF ( RD(1) .GE. 0.5 ) THEN YR(2) = RANNOR( POSC2, WIDC2 ) + YY0 ELSE YR(2) = RANNOR(-POSC2, WIDC2 ) + YY0 ENDIF ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'LEADDF: YR(2),YR(1)=', * SNGL(YR(2)),SNGL(YR(1)) IFLGLD = 0 RETURN END *CMZ : 14/06/2000 14.29.37 by D. HECK IK3 FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE LEDENY( LEDEFL ) C----------------------------------------------------------------------- C LE(A)D(ER'S) EN(ERG)Y C C SELECTS THE FEYNMAN X OF THE ANTILEADING PARTICLES FROM A THEORETICAL C DISTRIBUTION AND CALCULATES THE RAPIDITY FROM IT C CALCULATE THE RAPIDITY OF THE LEADER FROM THE REMAINDER OF ENERGY C THIS SUBROUTINE IS CALLED FROM HDPM. C ARGUMENT: C LEDEFL = 0 CORRECT ENDING OF LEDENY C = 1 NOT CORRECT ENDING OF LEDENY C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) *KEEP,INTER. COMMON /INTER/ AVCH,AVCH3,DC0,DLOG,DMLOG,ECMDIF,ECMDPM,ELAB, * FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3, * RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG, * WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN, * IDIF,ITAR DOUBLE PRECISION AVCH,AVCH3,DC0,DLOG,DMLOG,ECMDIF,ECMDPM,ELAB, * FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3, * RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG, * WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN INTEGER IDIF,ITAR *KEEP,LEPAR. COMMON /LEPAR/ LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS INTEGER LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS *KEEP,NEWPAR. COMMON /NEWPAR/ EA,PT2,PX,PY,TMAS,YR,ITYP, * IA1,IA2,IB1,IB2,IC1,IC2,ID1,ID2,IE1,IE2,IF1,IF2, * IG1,IG2,IH1,IH2,II1,II2,IJ1,NTOT DOUBLE PRECISION EA(3000),PT2(3000),PX(3000),PY(3000),TMAS(3000), * YR(3000) INTEGER ITYP(3000), * IA1,IA2,IB1,IB2,IC1,IC2,ID1,ID2,IE1,IE2,IF1,IF2, * IG1,IG2,IH1,IH2,II1,II2,IJ1,NTOT *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,VKIN. COMMON /VKIN/ BETACM DOUBLE PRECISION BETACM *KEND. SAVE DATA SL / 3.D0 / C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'LEDENY: ITYPE,ITAR=',ITYPE,ITAR C BETACM IS AVAILABLE IN COMMON /VKIN/ BUT NOT FOR PHOTOPRODUCTION IF ( ITYPE .EQ. 7 ) BETACM = SQRT( 1.D0 - 1.D0 / GCM**2 ) C MOMENTUM OF INCOMING TARGET IN CM SYSTEM PNT = PAMA(ITAR) * GCM * BETACM IF ( DEBUG ) WRITE(MDEBUG,*) 'LEDENY: PNT=',SNGL(PNT) C GET FEYNMAN X FOR ANTILEADER DEPENDING ON ENERGY C DISCRIPTION OF THE FEYNMAN X DISTRIBUTION DEPENDING ON ENERGY C DN/DXF = SL*XF 0 < XF < X1 C DN/DXF = SL*X1 X1 < XF < X2 C DN/DXF = SL*X1 * EXP(-AL*(XF-X2)) X2 < XF < 1 IF ( ECMDPM .LT. 13.76D0 ) THEN X1 = 0.20D0 X2 = 0.65D0 AL = 1.265D0 ELSEIF ( ECMDPM .LT. 5580.D0 ) THEN X1 = 0.716D0 + 0.00543D0 * SMLOG X2 = 0.8175D0 - 0.032D0 * SMLOG AL = 1.14D0 + 0.022D0 * SMLOG ELSE X1 = 0.265D0 X2 = 0.265D0 AL = 1.14D0 + 0.022D0*SMLOG ENDIF C CALCULATE THE INTEGRALS OVER THE THREE PARTS OF THE FUNCTION AA = 0.5D0 * SL * X1**2 BB = SL * X1 * (X2 - X1) CC = SL * X1 / AL * ( 1.D0 - EXP( AL*(X2-1.D0) ) ) C NORMALIZE TO 1 TT = 1.D0 / (AA + BB + CC) CC = CC * TT AA = AA * TT BB = BB * TT AB = AA + BB CALL RMMAR( RD,1,1 ) C GET XF FOR ANTILEADER IF ( RD(1) .LE. AA ) THEN XF = SQRT( RD(1)*2.D0 / (SL*TT) ) ELSEIF ( RD(1) .LE. AB ) THEN XF = (RD(1)-AA) / (SL*X1*TT) + X1 ELSE XF = X2 - LOG( 1.D0 - (RD(1)-AB)*AL/(SL*X1*TT) ) / AL ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'LEDENY: XF(TARGET)=',SNGL(XF) C CONVERT FEYNMAN X INTO RAPIDITY FOR ANTILEADER PLAL = PNT * XF * PAMA(LEPAR2) / PAMA(ITAR) EA(2) = SQRT(PLAL**2 + TMAS(2)**2) * YR(2) = (-0.5D0) * LOG( (EA(2)+PLAL)/(EA(2)-PLAL) ) YR(2) = - LOG( (EA(2)+PLAL)/TMAS(2) ) C CALCULATE THE REMAINDER OF ENERGY AND LONG. MOMENTUM OF LEADER C THIS HOLDS ALSO FOR MULTIPLE COLLISIONS (GNU > 1) ESUM = 0.D0 DO 10 I = 2,NTOT EA(I) = TMAS(I) * COSH( YR(I) + YCM ) ESUM = ESUM + EA(I) 10 CONTINUE EA(1) = ELAB + PAMA(ITAR) - ESUM IF ( EA(1) .LE. TMAS(1) ) THEN LEDEFL = 1 RETURN ENDIF PLLBSQ = EA(1)**2 - TMAS(1)**2 PLLB = SQRT( PLLBSQ ) * YR(1) = 0.5D0 * LOG( (EA(1) + PLLB) / (EA(1) - PLLB) ) - YCM YR(1) = LOG( (EA(1) + PLLB) / TMAS(1) ) - YCM IF ( DEBUG ) WRITE(MDEBUG,*) 'LEDENY: EA(1),YR(2),YR(1)=', * SNGL(EA(1)),SNGL(YR(2)),SNGL(YR(1)) LEDEFL = 0 RETURN END *CMZ : 15/06/2000 14.13.19 by D. HECK IK3 FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE LEPACX( ECMCE,SDMLOG,LEPART,IPART ) C----------------------------------------------------------------------- C LE(ADING) PA(RTICLE) C(HARGE) (E)X(CHANGE) C C CONSIDERS CHARGE EXCHANGE POSSIBILITY OF (ANTI)LEADING PARTICLE C CONSIDERS RESONANCE EXCITATION WITHOUT/WITH CHARGE EXCHANGE C LASTPI INCREASED: CREATE ONE CHARGED PION FOR CHARGE CONSERVATION C LASTPI UNCHANGED: NO CHARGE EXCHANGE C LASTPI DECREASED: CANCEL ONE CHARGED PION FOR CHARGE CONSERVATION C NRESPC INCREASED BY 1, IF PI(+-) WILL BE GENERATED BY RESON. DECAY C NRESPN INCREASED BY 1, IF PI(0) WILL BE GENERATED BY RESON. DECAY C NCPLUS INCREASED BY 1, IF POSITIVE CHARGE IS CREATED C NCPLUS DECREASED BY 1, IF NEGATIVE CHARGE IS CREATED C THIS SUBROUTINE IS CALLED FROM HDPM. C ARGUMENTS: C ECMCE = ENERGY FOR CHARGE EXCHANGE (ECMDPM OR ECMDIF) C SDMLOG = ELABLG FOR NSD, DMLOG FOR DIFFRACTION C LEPART = PARTICLE CODE OF (ANTI)LEADER EXCHANGING CHARGE C IPART = PARTICLE NUMBER IN ARRAY OF SECONDARY PARTICLES C = 1 FOR LEADER, = 2 FOR ANTI-LEADER C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,LEPAR. COMMON /LEPAR/ LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS INTEGER LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RESON. COMMON /RESON/ RDRES,RESRAN,IRESPAR REAL RDRES(2),RESRAN(30000) INTEGER IRESPAR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'LEPACX: LEPART=',LEPART C SET PROBABILITIES FOR RESONANCE PRODUCTION (PRESPR) AND FOR C CHARGE EXCHANGE OR RESONANCE PRODUCTION (PCEXRS) IF ( ECMCE .LE. 19.4D0 ) THEN PCEXRS = 0.45D0 PRESPR = 0.35D0 ELSEIF ( ECMCE .LT. 968.5D0 ) THEN PCEXRS = 0.45D0 + 0.034509D0 * (SDMLOG - 5.29832D0) PRESPR = 0.0881897D0 * (SDMLOG - 5.29832D0) ELSE PCEXRS = 0.72D0 PRESPR = 0.69D0 ENDIF PRESPR = MAX( 0.35D0, PRESPR ) IF ( LEPART .EQ. 7 ) THEN C ASSUME 50% CHARGE EXCHANGE FOR GAMMA INITIATED INTERACTION PCEXRS = 0.5D0 PRESPR = 0.D0 ENDIF C THROW RANDOM NUMBER TO LOOK FOR RES. PRODUCTION OR CHARGE EXCHANGE CALL RMMAR( RD,2,1 ) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C RESONANCE IS FORMED. IF ADDITIONAL CHARGE EXCHANGE, THEN SET LASTPI IF ( RD(1) .LE. PRESPR ) THEN C FIRST FOR NUCLEONS (AS MOST FREQUENT) IF ( LEPART .EQ. 13 ) THEN IF ( RD(2) .LE. 0.5 ) THEN C NEUTRON ----> DELTA(-) LEPART = 57 NRESPC = NRESPC + 1 NCPLUS = NCPLUS - 1 ELSEIF ( RD(2) .GT. TB3 ) THEN C NEUTRON ----> DELTA(0) LEPART = 56 CALL RMMAR( RDRES(IPART),1,1 ) IF ( RDRES(IPART) .LE. TB3 ) THEN NRESPN = NRESPN + 1 ELSE NRESPC = NRESPC + 1 LASTPI = LASTPI - 1 ENDIF ELSE C NEUTRON ----> DELTA(+) LEPART = 55 CALL RMMAR( RDRES(IPART),1,1 ) IF ( RDRES(IPART) .LE. TB3 ) THEN NRESPN = NRESPN + 1 LASTPI = LASTPI - 1 ELSE NRESPC = NRESPC + 1 ENDIF NCPLUS = NCPLUS + 1 ENDIF ELSEIF ( LEPART .EQ. 14 ) THEN IF ( RD(2) .LE. 0.5 ) THEN C PROTON ----> DELTA(++) LEPART = 54 NRESPC = NRESPC + 1 NCPLUS = NCPLUS + 1 ELSEIF ( RD(2) .GT. TB3 ) THEN C PROTON ----> DELTA(+) LEPART = 55 CALL RMMAR( RDRES(IPART),1,1 ) IF ( RDRES(IPART) .LE. TB3 ) THEN NRESPN = NRESPN + 1 ELSE NRESPC = NRESPC + 1 LASTPI = LASTPI + 1 ENDIF ELSE C PROTON ----> DELTA(0) LEPART = 56 CALL RMMAR( RDRES(IPART),1,1 ) IF ( RDRES(IPART) .LE. TB3 ) THEN NRESPN = NRESPN + 1 LASTPI = LASTPI + 1 ELSE NRESPC = NRESPC + 1 ENDIF NCPLUS = NCPLUS - 1 ENDIF C NOW FOR PIONS ELSEIF ( LEPART .EQ. 8 .OR. LEPART .EQ. 9 ) THEN IF ( RD(2) .LE. 0.5 ) THEN C PI(+-) ----> RHO(+-) LEPART = LEPART + 44 NRESPN = NRESPN + 1 ELSE C PI(+-) ----> RHO(0) ( ----> PI(+) + PI(-) ) NCPLUS = NCPLUS + 2 * LEPART - 17 LEPART = 51 NRESPC = NRESPC + 1 ENDIF C NOW FOR KAONS ELSEIF ( LEPART .EQ. 11 .OR. LEPART .EQ. 12 ) THEN IF ( RD(2) .LE. 0.5 ) THEN C K(+-) ----> K*(+-) LEPART = LEPART + 52 CALL RMMAR( RDRES(IPART),1,1 ) IF ( RDRES(IPART) .LE. TB3 ) THEN NRESPN = NRESPN + 1 ELSE NRESPC = NRESPC + 1 LASTPI = LASTPI + 1 ENDIF ELSE C K(+) ----> K*(0) C K(-) ----> ANTI-K*(0) CALL RMMAR( RDRES(IPART),1,1 ) NCPLUS = NCPLUS + 2 * LEPART - 23 IF ( RDRES(IPART) .LE. TB3 ) THEN NRESPC = NRESPC + 1 ELSE NRESPN = NRESPN + 1 LASTPI = LASTPI + 1 ENDIF LEPART = 3*LEPART + 29 ENDIF ELSEIF ( LEPART .EQ. 10 .OR. LEPART .EQ. 16 ) THEN IF ( RD(2) .LE. 0.5 ) THEN C K(0) ----> (ANTI) K*(0) CALL RMMAR( RD,1,1 ) IF ( RD(1) .LE. 0.5 ) THEN LEPART = 62 ELSE LEPART = 65 ENDIF CALL RMMAR( RDRES(IPART),1,1 ) IF ( RDRES(IPART) .LE. TB3 ) THEN NRESPC = NRESPC + 1 LASTPI = LASTPI - 1 ELSE NRESPN = NRESPN + 1 ENDIF ELSE C K(0) ----> K*(+-) CALL RMMAR( RD,1,1 ) IF ( RD(1) .LE. 0.5 ) THEN LEPART = 63 NCPLUS = NCPLUS + 1 ELSE LEPART = 64 NCPLUS = NCPLUS - 1 ENDIF CALL RMMAR( RDRES(IPART),1,1 ) IF ( RDRES(IPART) .LE. TB3 ) THEN NRESPN = NRESPN + 1 LASTPI = LASTPI - 1 ELSE NRESPC = NRESPC + 1 ENDIF ENDIF C NOW FOR ANTINUCLEONS ELSEIF ( LEPART .EQ. 25 ) THEN IF ( RD(2) .LE. 0.5 ) THEN C ANTINEUTRON ----> ANTI-DELTA(0) LEPART = 60 CALL RMMAR( RDRES(IPART),1,1 ) IF ( RDRES(IPART) .LE. TB3 ) THEN NRESPN = NRESPN + 1 ELSE NRESPC = NRESPC + 1 LASTPI = LASTPI - 1 ENDIF ELSEIF ( RD(2) .GT. TB3 ) THEN C ANTINEUTRON ----> ANTI-DELTA(+) LEPART = 61 NRESPC = NRESPC + 1 NCPLUS = NCPLUS + 1 ELSE C ANTINEUTRON ----> ANTI-DELTA(-) LEPART = 59 CALL RMMAR( RDRES(IPART),1,1 ) IF ( RDRES(IPART) .LE. TB3 ) THEN NRESPN = NRESPN + 1 LASTPI = LASTPI - 1 ELSE NRESPC = NRESPC + 1 ENDIF NCPLUS = NCPLUS - 1 ENDIF ELSEIF ( LEPART .EQ. 15 ) THEN IF ( RD(2) .LE. 0.5 ) THEN C ANTIPROTON ----> ANTI-DELTA(--) LEPART = 58 NRESPC = NRESPC + 1 NCPLUS = NCPLUS - 1 ELSEIF ( RD(2) .GT. TB3 ) THEN C ANTIPROTON ----> ANTI-DELTA(-) LEPART = 59 CALL RMMAR( RDRES(IPART),1,1 ) IF ( RDRES(IPART) .LE. TB3 ) THEN NRESPN = NRESPN + 1 ELSE NRESPC = NRESPC + 1 LASTPI = LASTPI + 1 ENDIF ELSE C ANTIPROTON ----> ANTI-DELTA(0) LEPART = 60 CALL RMMAR( RDRES(IPART),1,1 ) IF ( RDRES(IPART) .LE. TB3 ) THEN NRESPN = NRESPN + 1 LASTPI = LASTPI + 1 ELSE NRESPC = NRESPC + 1 ENDIF NCPLUS = NCPLUS + 1 ENDIF ELSEIF ( LEPART .EQ. 7 ) THEN C NO RESONANCE FORMATION FOR INDUCING GAMMA RADIATION IF ( DEBUG ) WRITE(MDEBUG,*) 'LEPACX: NO EXCHANGE' ELSEIF ( (LEPART .GE. 18 .AND. LEPART .LE. 24) .OR. * (LEPART .GE. 26 .AND. LEPART .LE. 32) ) THEN C NO RESONANCE FORMATION FOR STRANGE BARYONS IF ( DEBUG ) WRITE(MDEBUG,*) 'LEPACX: NO EXCHANGE' ELSEIF ( LEPART .EQ. 17 ) THEN C NO RESONANCE FORMATION FOR INDUCING ETA IF ( DEBUG ) WRITE(MDEBUG,*) 'LEPACX: NO EXCHANGE' ELSEIF ( LEPART .GE. 71 .AND. LEPART .LE. 74 ) THEN C NO RESONANCE FORMATION FOR INDUCING ETA IF ( DEBUG ) WRITE(MDEBUG,*) 'LEPACX: NO EXCHANGE' ELSE WRITE(MONIOU,100) LEPART 100 FORMAT(1H ,'LEPACX: UNIDENTIFIED PARTICLE CODE= ',I4, * ' FOR RESONANCE FORMATION') ENDIF IF ( DEBUG ) WRITE(MDEBUG,102) * LEPART,LASTPI,NRESPC,NRESPN,NCPLUS 102 FORMAT(' LEPACX: LEPART,LASTPI,NRESPC,NRESPN,NCPLUS=',5I5) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C CHARGE EXCHANGE WITHOUT RESONANCE FORMATION ELSEIF ( RD(1) .LE. PCEXRS ) THEN C FIRST FOR NUCLEONS (AS MOST FREQUENT) IF ( LEPART .EQ. 13 ) THEN C NEUTRON ( + PI(+) ) ----> PROTON ( + PI(0) ) LEPART = 14 LASTPI = LASTPI - 1 NCPLUS = NCPLUS + 1 ELSEIF ( LEPART .EQ. 14 ) THEN C PROTON ( + PI(0) ) ----> NEUTRON ( + PI(+) ) LEPART = 13 LASTPI = LASTPI + 1 NCPLUS = NCPLUS - 1 C NOW FOR PIONS ELSEIF ( LEPART .EQ. 8 .OR. LEPART .EQ. 9 ) THEN C PI(+-) ----> PI(0) NCPLUS = NCPLUS + 2 * LEPART - 17 LEPART = 7 LASTPI = LASTPI + 1 C NOW FOR KAONS ELSEIF ( LEPART .EQ. 11 .OR. LEPART .EQ. 12 ) THEN C K(+-) ----> K(0) (S OR L) NCPLUS = NCPLUS + 2 * LEPART - 23 IF ( RD(2) .LE. 0.5 ) THEN LEPART = 10 ELSE LEPART = 16 ENDIF LASTPI = LASTPI + 1 ELSEIF ( LEPART .EQ. 10 .OR. LEPART .EQ. 16 ) THEN C K(0) ----> K(+-) IF ( RD(2) .LE. 0.5 ) THEN LEPART = 11 NCPLUS = NCPLUS + 1 ELSE LEPART = 12 NCPLUS = NCPLUS - 1 ENDIF LASTPI = LASTPI - 1 C NOW FOR ANTINUCLEONS ELSEIF ( LEPART .EQ. 25 ) THEN C ANTINEUTRON ( + PI(-) ) ----> ANTIPROTON ( + PI(0) ) LEPART = 15 LASTPI = LASTPI - 1 NCPLUS = NCPLUS - 1 ELSEIF ( LEPART .EQ. 15 ) THEN C ANTIPROTON ( + PI(0) ) ----> ANTINEUTRON ( + PI(-) ) LEPART = 25 LASTPI = LASTPI + 1 NCPLUS = NCPLUS + 1 C NOW FOR GAMMA INDUCED REACTIONS (ITYPE=7) ELSEIF ( LEPART .EQ. 7 ) THEN C TEST IF CHARGE EXCHANGE REACTION FOR PI(0) C PI(0) ----> PI(+-) IF ( RD(2) .LE. 0.5 ) THEN LEPART = 8 NCPLUS = NCPLUS + 1 ELSE LEPART = 9 NCPLUS = NCPLUS - 1 ENDIF LASTPI = LASTPI - 1 ELSEIF ( (LEPART .GE. 18 .AND. LEPART .LE. 24) .OR. * (LEPART .GE. 26 .AND. LEPART .LE. 32) ) THEN C NO CHARGE EXCHANGE FOR STRANGE BARYONS IF ( DEBUG ) WRITE(MDEBUG,*) 'LEPACX: NO EXCHANGE' ELSEIF ( LEPART .EQ. 17 ) THEN C NO CHARGE EXCHANGE FOR INDUCING ETA IF ( DEBUG ) WRITE(MDEBUG,*) 'LEPACX: NO EXCHANGE' ELSEIF ( LEPART .GE. 71 .AND. LEPART .LE. 74 ) THEN C NO CHARGE EXCHANGE FOR INDUCING ETA IF ( DEBUG ) WRITE(MDEBUG,*) 'LEPACX: NO EXCHANGE' ELSE WRITE(MONIOU,101) LEPART 101 FORMAT(1H ,'LEPACX: UNIDENTIFIED PARTICLE CODE= ',I4, * ' FOR CHARGE EXCHANGE') ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'LEPACX: LEPART,LASTPI,NCPLUS=', * LEPART,LASTPI,NCPLUS ELSE IF ( DEBUG ) WRITE(MDEBUG,*) 'LEPACX: NO EXCHANGE' ENDIF RETURN END *CMZ : 11/07/2000 10.08.31 by D. HECK IK3 FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE NSD C----------------------------------------------------------------------- C N(ON) S(INGLE) D(IFFRACTION CASE) C C SETS PARAMETERS FOR HDPM IN CASE OF NON-SINGLE-DIFFRACTION EVENT C THIS SUBROUTINE IS CALLED FROM HDPM. C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) *KEEP,INTER. COMMON /INTER/ AVCH,AVCH3,DC0,DLOG,DMLOG,ECMDIF,ECMDPM,ELAB, * FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3, * RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG, * WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN, * IDIF,ITAR DOUBLE PRECISION AVCH,AVCH3,DC0,DLOG,DMLOG,ECMDIF,ECMDPM,ELAB, * FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3, * RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG, * WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN INTEGER IDIF,ITAR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'NSD :' C CENTRAL RAPIDITY DENSITY ( RHO ) FOR NSD REACTION C PARAMETRISATION SEE CAPDEVIELLE,J.PHYS.G:NUCL.PHYS.16(1990)1539 EQ.7 IF ( ECMDPM .LE. 680.D0 ) THEN DC0 = 0.82D0 * (S**0.107D0) ELSE DC0 = 0.64D0 * (S**0.126D0) ENDIF C THERE ARE 3 ENERGY DEPENDENT FORMULAS FOR AVERAGE CHARGED C MULTIPLICITY ( AVCH0 ); C PARAMETRISATIONS SEE CAPDEVIELLE,J.PHYS.G:NUCL.PHYS.16(1990)1539 EQ.8 IF ( ECMDPM .LE. 187.5D0 ) THEN AVCH0 = 0.57D0 + 0.584D0 * SLOG + 0.127D0 * SLOGSQ ELSEIF ( ECMDPM .LT. 945.5D0 ) THEN AVCH0 = -6.55D0 + 6.89D0 * S**0.131D0 ELSE AVCH0 = 3.4D0 * S**0.17D0 ENDIF C MINIMUM AVERAGE CHARGED MULTIPLICITY IS 1 AVCH0 = MAX( 1.D0, AVCH0 ) C EXCESS OF CHARGED PARTICLES WHICH COME FROM AIR TARGET IF ( ECMDPM .LE. 137.D0 ) THEN AVCH3 = 0.57D0 * AVCH0 * (GNU - 1.D0) ELSE AVCH3 = 0.5D0 * AVCH0 * (GNU - 1.D0) ENDIF C AVERAGE NUMBER OF ALL CHARGED AVCH = AVCH0 + AVCH3 C THE FOLOWING PROCEDURE IS TO PRODUCE PHOTONS FROM UNKNOWN NEUTRAL C DECAYS FOLLOWING CORRELATION WITH CHARGED PARTICLES BASED ON PHOTON C EXCESS AT COLLIDER EXPERIMENTS. SEUGP IS C PARAMETRISATION OF UA5: ANSORGE ET AL., Z.PHYS.C43 (1989) 75 IF ( ECMDPM .LE. 103.D0 ) THEN SEUGP = -1.27D0 + 0.52D0 * SLOG + 0.148D0 * SLOGSQ ELSE C PROBLEM OF THE RISE OF THE UNKNOWN ETA PRODUCTION CROSS-SECTION C IS SOLVED WITH THOUW'S PARAMETRISATION OF UA5 DATA: SEUGP = -18.7D0 + 11.55D0 * S**0.1195D0 ENDIF SEUGP = MAX( 0.5D0, SEUGP ) IF ( DEBUG ) WRITE(MDEBUG,100) * SNGL(DC0),SNGL(AVCH0),SNGL(AVCH3),SNGL(AVCH),SNGL(SEUGP) 100 FORMAT(' NSD : DC0,AVCH0,AVCH3,AVCH,SEUGP=',5F12.7) C CENTER OF GAUSSIAN FOR CHARGED SECONDARIES 1ST AND 2ND STRING C NEEDED FOR SOME CALCULATION ; FINAL POSITION CALCULATED LATER POSC2 = 0.146D0 * SMLOG + 0.072D0 C WIDTH OF GAUSSIAN FOR CHARGED SECONDARIES 1ST AND 2ND STRING WIDC2 = 0.12D0 * SMLOG + 0.18D0 IF ( GNU .LE. 1.D0 ) THEN POSC3 = 0.D0 WIDC3 = 1.D0 ELSE C CENTER OF GAUSSIAN 3RD STRING (TARGET CONTRIB. FOR PROJECTILE-AIR) POSC3 = 3.D0 - 2.575D0 * EXP( (-0.081756452D0) * GNU ) C WIDTH OF GAUSSIAN FOR 3RD STRING WIDC3 = 1.2338466D0 + 0.078969916D0 * LOG(GNU) ENDIF IF ( DEBUG ) WRITE(MDEBUG,110) * SNGL(POSC2),SNGL(WIDC2),SNGL(POSC3),SNGL(WIDC3) 110 FORMAT(' NSD : POSC2,WIDC2,POSC3,WIDC3=',4F12.7) RETURN END *CMZ : 28/02/2002 13.08.20 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE PARNUM( INUMFL ) C----------------------------------------------------------------------- C PART(ICLE TYPE) NUM(BERS) C C DETERMINES THE NUMBERS OF SECONDARY PARTICLES FOR EACH TYPE C THIS SUBROUTINE IS CALLED FROM HDPM. C ARGUMENT: C INUMFL = 0 CORRECT DETERMINATION OF PARTICLE NUMBERS C = 1 SOMETHING WENT WRONG WITH NEUTRAL PARTICLE NUMBERS C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,EDECAY. COMMON /EDECAY/ CETA DOUBLE PRECISION CETA(5) *KEEP,INDICE. COMMON /INDICE/ NNUCN,NKA0,NHYPN,NETA,NETAS,NPIZER, * NNC,NKC,NHC,NPC,NCH,NNN,NKN,NHN,NET,NPN INTEGER NNUCN(2:3),NKA0(2:3),NHYPN(2:3),NETA(2:3,1:4), * NETAS(2:3),NPIZER(2:3), * NNC,NKC,NHC,NPC,NCH,NNN,NKN,NHN,NET,NPN *KEEP,INTER. COMMON /INTER/ AVCH,AVCH3,DC0,DLOG,DMLOG,ECMDIF,ECMDPM,ELAB, * FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3, * RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG, * WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN, * IDIF,ITAR DOUBLE PRECISION AVCH,AVCH3,DC0,DLOG,DMLOG,ECMDIF,ECMDPM,ELAB, * FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3, * RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG, * WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN INTEGER IDIF,ITAR *KEEP,LEPAR. COMMON /LEPAR/ LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS INTEGER LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RATIOS. COMMON /RATIOS/ RPI0R,RPIER,RPEKR,RPEKNR,PPICH,PPINCH,PPNKCH, * ISEL,NEUTOT,NTOTEM DOUBLE PRECISION RPI0R,RPIER,RPEKR,RPEKNR,PPICH,PPINCH,PPNKCH INTEGER ISEL,NEUTOT,NTOTEM *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. REAL RDETA SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'PARNUM: NCH,NEUTOT,NTOTEM=', * NCH,NEUTOT,NTOTEM INUMFL = 0 C RESET PARTICLE NUMBERS NNC = 0 NKC = 0 NHC = 0 NPC = 0 C ISEL IS 1 MEANS VERY LOW MULTIPLICITY C CREATE ONLY PIONS (TO RISKY TO CREATE OTHER PARTICLES) IF ( ISEL .EQ. 1 ) THEN NNN = 0 NKN = 0 NET = 0 NHN = 0 NPN = 0 NNUCN(2) = 0 NKA0(2) = 0 NHYPN(2) = 0 NETAS(2) = 0 NPIZER(2) = 0 C CREATE RANDOM NUMBERS CALL RMMAR( RD,NTOTEM,1 ) DO 1000 I = 1,NTOTEM IF ( RD(I) .LE. TB3 ) THEN NPC = NPC + 1 ELSE NPN = NPN + 1 ENDIF 1000 CONTINUE C NO NEUTRAL PARTICLES FOR THE 3RD STRING EXCEPT EVENTUALLY PI(0) NNUCN(3) = 0 NKA0(3) = 0 NHYPN(3) = 0 NETAS(3) = 0 NPIZER(3) = MAX( 0, NINT(RC3TO2/(1.D0+RC3TO2)*DBLE(NPN)) ) IF ( DEBUG ) WRITE(MDEBUG,*) ' ISEL=1, NTOTEM=',NTOTEM ELSE C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C NOW THE CASE OF HAVING ENOUGH PARTICLES TO BE ABLE TO CREATE C KAONS, NUCLEONS, AND HYPERONS TOO. C ...FOR NEUTRALS NCOUNT = 0 C BEGIN OF REJECT LOOP 1002 K = 1 CALL RMMAR( RD,NEUTOT+3,1 ) C DETERMINE NUMBER OF PI(0), ETA, K0S/K0 PAIRS, NEUTRON/ANTINEUTRON C PAIRS, AND NEUTRAL HYPERON PAIRS AND SUM UP THE GAMMAS C FOR 1ST + 2ND STRING: J IS 2; FOR 3RD STRING: J IS 3 SGAMMA = 0.D0 DO 1010 J = 2,3 NNUCN(J) = 0 NKA0(J) = 0 NHYPN(J) = 0 NETA(J,1) = 0 NETA(J,2) = 0 NETA(J,3) = 0 NETA(J,4) = 0 NPIZER(J) = 0 IF ( J .EQ. 2 ) THEN C SET BOUNDARY FOR GAMMA SUM GABOU = SEUGF NNTOT = INT(FNEUT2) C CALCULATE BOUNDARY NNTOT OF PARTICLE LOOP RATHER AT RANDOM THAN BY C ROUNDING OF FNEUT2 TO AVOID DIGITIZING EFFECTS ON THE NEUTRAL C PARTICLE COMPOSITION AT COLLISIONS WITH LOW MULTIPLICITY IF ( NNTOT+RD(NEUTOT+2) .GE. FNEUT2 ) NNTOT = NNTOT+1 ELSE IF ( RC3TO2 .LE. 0.D0 ) GOTO 1010 GABOU = GABOU + SEUGF* RC3TO2 NNTOT = INT(FNEUT) IF ( NNTOT+RD(NEUTOT+3) .GE. FNEUT ) NNTOT = NNTOT+1 ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) ' J,NNTOT=',J,NNTOT C START NEUTRAL PARTICLE PRODUCTION LOOP 1003 CONTINUE IF ( K .LT. NNTOT ) THEN RNDM = RD(K) ELSEIF ( K .EQ. NNTOT ) THEN C RENORMALIZE THE RANDOM NUMBER, THAT ONLY PI(0) OR ETA IS PRODUCED C BUT PAIR PRODUCTION BECOMES IMPOSSIBLE RNDM = RD(K) * RPIER ELSEIF ( K .GT. NNTOT ) THEN GOTO 1010 ENDIF IF ( RNDM .LE. RPI0R ) THEN C PI(0) SGAMMA = SGAMMA + 2.D0 NPIZER(J) = NPIZER(J) + 1 K = K + 1 ELSEIF ( RNDM .LE. RPIER ) THEN C ETA CALL RMMAR( RDETA,1,1 ) IF ( RDETA .LE. CETA(1) ) THEN SGAMMA = SGAMMA + 2.D0 NETA(J,1) = NETA(J,1) + 1 ELSEIF ( RDETA .LE. CETA(2) ) THEN SGAMMA = SGAMMA + 6.D0 NETA(J,2) = NETA(J,2) + 1 ELSEIF ( RDETA .LE. CETA(3) ) THEN SGAMMA = SGAMMA + 2.D0 NETA(J,3) = NETA(J,3) + 1 ELSE SGAMMA = SGAMMA + 1.D0 NETA(J,4) = NETA(J,4) + 1 ENDIF K = K + 1 ELSEIF ( RNDM .LE. RPEKR ) THEN C K0S/K0L PAIR; RPEKR IS NORMALIZED FOR K0 PAIR FORMATION C THE UA5 GAMMA YIELD DOES NOT INCLUDE GAMMAS FROM K DECAY !!! C SEE: ANSORGE ET AL., Z. PHYS. C43 (1989) 75 NKA0(J) = NKA0(J) + 1 K = K + 2 ELSEIF ( RNDM .LE. RPEKNR ) THEN C NEUTRON-ANTINEUTRON PAIR NNUCN(J) = NNUCN(J) + 1 K = K + 2 ELSE C HYPERON-ANTIHYPERON PAIR C AVERAGE NEUTRAL HYPERON PAIR L0 --> .357*2 GAMMAS = 0.714 GAMMAS C S0 --> L0 + 1 GAMMA = 1.714 GAMMAS C THEY ARE INCLUDED IN UA5 GAMMA MULTIPLICITIES, THEREFORE COUNT SGAMMA = SGAMMA + 2.428D0 NHYPN(J) = NHYPN(J) + 1 K = K + 2 ENDIF GOTO 1003 1010 CONTINUE IF ( DEBUG ) WRITE(MDEBUG,1020) ( 2*NNUCN(J),2*NKA0(J), * 2*NHYPN(J),NETA(J,1),NETA(J,2),NETA(J,3),NETA(J,4), * NPIZER(J),J=2,3 ), NNTOT,GABOU,SGAMMA,SGAMMA/GABOU 1020 FORMAT(' PARNUM: NEUTRALS (1.,2.STRING)=',8I5,/ * ' NEUTRALS (3. STRING) =',8I5,/ * ' NNTOT,SEUGF2+3,SGAMMA,RATIO=',I6,3(2X,F10.5)) C REJECT ALL NEUTRALS, IF SUM OF GAMMAS DEVIATES BY MORE THAN SIGMA IF ( (SGAMMA - GABOU)**2 .GT. GABOU ) THEN NCOUNT = NCOUNT + 1 C AFTER 20 TRIES SET FLAG INUMFL TO 1 AND RETURN IF ( NCOUNT .LE. 20 ) GOTO 1002 INUMFL = 1 RETURN ENDIF C ALL NEUTRALS NNN = NNUCN(2) + NNUCN(3) NKN = NKA0(2) + NKA0(3) NHN = NHYPN(2) + NHYPN(3) NETAS(2) = NETA(2,1) + NETA(2,2) + NETA(2,3) + NETA(2,4) NETAS(3) = NETA(3,1) + NETA(3,2) + NETA(3,3) + NETA(3,4) NET = NETAS(2) + NETAS(3) NPN = NPIZER(2) + NPIZER(3) C ...FOR CHARGED I = 1 CALL RMMAR( RD,NCH-1,1 ) C START CHARGED PARTICLE PRODUCTION LOOP 1101 CONTINUE RNDM = RD(I) IF ( RNDM .LT. PPICH ) THEN C PI(+-) NPC = NPC + 1 I = I + 1 ELSEIF ( RNDM .LT. PPINCH ) THEN C PROTON/ANTIPROTON PAIR NNC = NNC + 1 I = I + 2 ELSEIF ( RNDM .LT. PPNKCH ) THEN C KAON(+,-) PAIR NKC = NKC + 1 I = I + 2 ELSE C CHARGED HYPERON/ANTIHYPERON PAIR NHC = NHC + 1 I = I + 2 ENDIF IF ( I .LT. NCH ) THEN GOTO 1101 ELSEIF ( I .EQ. NCH ) THEN C ONLY 1 CHARGED PARTICLE TO BE PRODUCED WHICH IS PI(+-) NPC = NPC + 1 ENDIF C CORRECT CHARGED PION NUMBER FOR DECAY OF ETA'S NCORR = 2 * ( NETA(2,3) + NETA(2,4) + NETA(3,3) + NETA(3,4) ) NPC = MAX( 0, NPC - NCORR ) IF ( DEBUG ) WRITE(MDEBUG,*) ' NPC,NPN,NCORR,LASTPI=', * NPC,NPN,NCORR,LASTPI ENDIF C CORRECT NUMBER OF CHARGED AND NEUTRAL PIONS FOR RESONANCE DECAY C (NRESPC, NRESPN) NPC = MAX( 0, NPC - NRESPC + LASTPI ) C INCREASE NPN ADDITIONALLY BY 1 TO MEET UA5 DATA, WHICH REPRODUCE ON C AVERAGE ONE EXCHANGED CHARGE (LASTPI = +1). NPN = MAX( 0, NPN - NRESPN - LASTPI + 1 ) C TOTAL NUMBER OF CHARGED PARTICLES NCH = (NNC + NKC + NHC) * 2 + NPC C NOW ALL PARTICLES ARE DETERMINED IF ( DEBUG ) WRITE(MDEBUG,*) * 'PARNUM: TOT.CHARGED=',2*NNC,2*NKC,2*NHC,NPC, * 'PARNUM: TOT.NEUTRAL=',2*NNN,2*NKN,2*NHN,NET,NPN RETURN END *CMZ : 14/06/2000 14.29.37 by D. HECK IK3 FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE PARRAP C----------------------------------------------------------------------- C PAR(TICLE) RAP(IDITY) C C ROUTINE GIVES THE NEW PARTICLES OF HDPM THEIR RAPIDITIES C THIS SUBROUTINE IS CALLED FROM HDPM. C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) *KEEP,INTER. COMMON /INTER/ AVCH,AVCH3,DC0,DLOG,DMLOG,ECMDIF,ECMDPM,ELAB, * FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3, * RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG, * WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN, * IDIF,ITAR DOUBLE PRECISION AVCH,AVCH3,DC0,DLOG,DMLOG,ECMDIF,ECMDPM,ELAB, * FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3, * RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG, * WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN INTEGER IDIF,ITAR *KEEP,NEWPAR. COMMON /NEWPAR/ EA,PT2,PX,PY,TMAS,YR,ITYP, * IA1,IA2,IB1,IB2,IC1,IC2,ID1,ID2,IE1,IE2,IF1,IF2, * IG1,IG2,IH1,IH2,II1,II2,IJ1,NTOT DOUBLE PRECISION EA(3000),PT2(3000),PX(3000),PY(3000),TMAS(3000), * YR(3000) INTEGER ITYP(3000), * IA1,IA2,IB1,IB2,IC1,IC2,ID1,ID2,IE1,IE2,IF1,IF2, * IG1,IG2,IH1,IH2,II1,II2,IJ1,NTOT *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. REAL RAND(3000) SAVE DOUBLE PRECISION RANNOR EXTERNAL RANNOR C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'PARRAP: NTOT=',NTOT C PROTON ANTIPROTON PAIRS CALL RMMAR( RAND(3),IJ1-2,1 ) DO 1013 K = 3,IB1 C GENERATION OF RAPIDITY FOR EXTRA PARTICLES FROM TARGET. IF ( K .LE. IA2 ) THEN YR(K) = RANNOR(-POSC3,WIDC3) ELSE C GENERATION OF RAPIDITY FOR PARTICLES FROM PP-COLLISION AND PROJECTILE IF ( RAND(K) .LE. 0.5 ) THEN YR(K) = RANNOR(POSC2,WIDC2) ELSE YR(K) = RANNOR(-POSC2,WIDC2) ENDIF ENDIF 1013 CONTINUE C K+ K- PAIRS DO 1014 K = IB1+1,IC1 IF ( K .LE. IB2 ) THEN C GENERATION OF RAPIDITY FOR EXTRA PARTICLES FROM TARGET. YR(K) = RANNOR(-POSC3,WIDC3) ELSE C GENERATION OF RAPIDITY FOR PARTICLES FROM PP-COLLISION AND PROJECTILE IF ( RAND(K) .LE. 0.5 ) THEN YR(K) = RANNOR(POSC2,WIDC2) ELSE YR(K) = RANNOR(-POSC2,WIDC2) ENDIF ENDIF 1014 CONTINUE C CHARGED HYPERON PAIRS DO 1015 K = IC1+1,ID1 IF ( K .LE. IC2 ) THEN C GENERATION OF RAPIDITY FOR EXTRA PARTICLES FROM TARGET. YR(K) = RANNOR(-POSC3,WIDC3) ELSE C GENERATION OF RAPIDITY FOR PARTICLES FROM PP-COLLISION AND PROJECTILE IF ( RAND(K) .LE. 0.5 ) THEN YR(K) = RANNOR(POSC2,WIDC2) ELSE YR(K) = RANNOR(-POSC2,WIDC2) ENDIF ENDIF 1015 CONTINUE C PI +- DO 1017 K = ID1+1,IE1 IF ( K .LE. ID2 ) THEN C GENERATION OF RAPIDITY FOR EXTRA PARTICLES FROM TARGET. YR(K) = RANNOR(-POSC3,WIDC3) ELSE C GENERATION OF RAPIDITY FOR PARTICLES FROM PP-COLLISION AND PROJECTILE IF ( RAND(K) .LE. 0.5 ) THEN YR(K) = RANNOR(POSC2,WIDC2) ELSE YR(K) = RANNOR(-POSC2,WIDC2) ENDIF ENDIF 1017 CONTINUE C NEUTRON ANTINEUTRON PAIRS DO 1021 K = IE1+1,IF1 IF ( K .LE. IE2 ) THEN C GENERATION OF RAPIDITY FOR EXTRA PARTICLES FROM TARGET. YR(K) = RANNOR(-POSC3,WIDC3) ELSE C GENERATION OF RAPIDITY FOR PARTICLES FROM PP-COLLISION AND PROJECTILE IF ( RAND(K) .LE. 0.5 ) THEN YR(K) = RANNOR(POSC2,WIDC2) ELSE YR(K) = RANNOR(-POSC2,WIDC2) ENDIF ENDIF 1021 CONTINUE C K0L K0S PAIRS DO 1022 K = IF1+1,IG1 IF ( K .LE. IF2 ) THEN C GENERATION OF RAPIDITY FOR EXTRA PARTICLES FROM TARGET. YR(K) = RANNOR(-POSC3,WIDC3) ELSE C GENERATION OF RAPIDITY FOR PARTICLES FROM PP-COLLISION AND PROJECTILE IF ( RAND(K) .LE. 0.5 ) THEN YR(K) = RANNOR(POSC2,WIDC2) ELSE YR(K) = RANNOR(-POSC2,WIDC2) ENDIF ENDIF 1022 CONTINUE C NEUTRAL HYPERON PAIRS DO 1023 K = IG1+1,IH1 IF ( K .LE. IG2 ) THEN C GENERATION OF RAPIDITY FOR EXTRA PARTICLES FROM TARGET. YR(K) = RANNOR(-POSC3,WIDC3) ELSE C GENERATION OF RAPIDITY FOR PARTICLES FROM PP-COLLISION AND PROJECTILE IF ( RAND(K) .LE. 0.5 ) THEN YR(K) = RANNOR(POSC2,WIDC2) ELSE YR(K) = RANNOR(-POSC2,WIDC2) ENDIF ENDIF 1023 CONTINUE C ETA DO 1025 K = IH1+1,II1 IF ( K .LE. IH2 ) THEN C GENERATION OF RAPIDITY FOR EXTRA PARTICLES FROM TARGET. YR(K) = RANNOR(-POSN3,WIDN3) ELSE C GENERATION OF RAPIDITY FOR PARTICLES FROM PP-COLLISION AND PROJECTILE IF ( RAND(K) .LE. 0.5 ) THEN YR(K) = RANNOR(POSN2,WIDN2) ELSE YR(K) = RANNOR(-POSN2,WIDN2) ENDIF ENDIF 1025 CONTINUE C PI(0) DO 1026 K = II1+1,IJ1 IF ( K .LE. II2 ) THEN C GENERATION OF RAPIDITY FOR EXTRA PARTICLES FROM TARGET. YR(K) = RANNOR(-POSN3,WIDN3) ELSE C GENERATION OF RAPIDITY FOR PARTICLES FROM PP-COLLISION AND PROJECTILE IF ( RAND(K) .LE. 0.5 ) THEN YR(K) = RANNOR(POSN2,WIDN2) ELSE YR(K) = RANNOR(-POSN2,WIDN2) ENDIF ENDIF 1026 CONTINUE RETURN END *CMZ : 02/11/2000 13.39.47 by D. HECK IK3 FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE PPARAM C----------------------------------------------------------------------- C P(ARTICLE) PARAM(ETERS) C C SETS PARAMETERS (PARTICLE TYP, TRANSVERSE MOMENTUM) C OF SECONDARY PARTICLES IN HDPM C THIS SUBROUTINE IS CALLED FROM HDPM. C C DESIGN : D. HECK IK3 FZK KARLSRUHE C CHANGES : J.N. CAPDEVIELLE CDF PARIS C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) *KEEP,AVPT. COMMON /AVPT/ AVPT,AVPK,AVPN,AVPH,AVPE DOUBLE PRECISION AVPT,AVPK,AVPN,AVPH,AVPE *KEEP,DPMFLG. COMMON /DPMFLG/ NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM INTEGER NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM *KEEP,INDICE. COMMON /INDICE/ NNUCN,NKA0,NHYPN,NETA,NETAS,NPIZER, * NNC,NKC,NHC,NPC,NCH,NNN,NKN,NHN,NET,NPN INTEGER NNUCN(2:3),NKA0(2:3),NHYPN(2:3),NETA(2:3,1:4), * NETAS(2:3),NPIZER(2:3), * NNC,NKC,NHC,NPC,NCH,NNN,NKN,NHN,NET,NPN *KEEP,INTER. COMMON /INTER/ AVCH,AVCH3,DC0,DLOG,DMLOG,ECMDIF,ECMDPM,ELAB, * FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3, * RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG, * WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN, * IDIF,ITAR DOUBLE PRECISION AVCH,AVCH3,DC0,DLOG,DMLOG,ECMDIF,ECMDPM,ELAB, * FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3, * RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG, * WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN INTEGER IDIF,ITAR *KEEP,LEPAR. COMMON /LEPAR/ LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS INTEGER LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS *KEEP,NEWPAR. COMMON /NEWPAR/ EA,PT2,PX,PY,TMAS,YR,ITYP, * IA1,IA2,IB1,IB2,IC1,IC2,ID1,ID2,IE1,IE2,IF1,IF2, * IG1,IG2,IH1,IH2,II1,II2,IJ1,NTOT DOUBLE PRECISION EA(3000),PT2(3000),PX(3000),PY(3000),TMAS(3000), * YR(3000) INTEGER ITYP(3000), * IA1,IA2,IB1,IB2,IC1,IC2,ID1,ID2,IE1,IE2,IF1,IF2, * IG1,IG2,IH1,IH2,II1,II2,IJ1,NTOT *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'PPARAM: NTOT,NPC,NCPLUS=', * NTOT,NPC,NCPLUS C FILL PARTICLES INTO ARRAYS, CALCULATE PT AND SUM UP SPX = 0.D0 SPY = 0.D0 NPART = 3 C PROTON ANTIPROTON PAIRS DO 1003 K = 1,NNC CALL RMMAR( RD,1,1 ) IF ( RD(1) .LT. 0.5 ) THEN ITYP(NPART) = 14 ITYP(NPART+1) = 15 ELSE ITYP(NPART) = 15 ITYP(NPART+1) = 14 ENDIF CALL PTRAM( ZN,AVPN,PX(NPART),PY(NPART) ) CALL PTRAM( ZN,AVPN,PX(NPART+1),PY(NPART+1) ) SPX = SPX + PX(NPART) + PX(NPART+1) SPY = SPY + PY(NPART) + PY(NPART+1) NPART = NPART + 2 1003 CONTINUE C K+ K- PAIRS DO 1004 K = 1,NKC CALL RMMAR( RD,1,1 ) IF ( RD(1) .LT. 0.5 ) THEN ITYP(NPART) = 11 ITYP(NPART+1) = 12 ELSE ITYP(NPART) = 12 ITYP(NPART+1) = 11 ENDIF CALL PTRAM( ZN,AVPK,PX(NPART),PY(NPART) ) CALL PTRAM( ZN,AVPK,PX(NPART+1),PY(NPART+1) ) SPX = SPX + PX(NPART) + PX(NPART+1) SPY = SPY + PY(NPART) + PY(NPART+1) NPART = NPART + 2 1004 CONTINUE C SIGMA PAIRS DO 1005 K = 1,NHC CALL RMMAR( RD,2,1 ) IF ( RD(1) .LT. 0.5 ) THEN IF ( RD(2) .LT. 0.5 ) THEN ITYP(NPART) = 19 ITYP(NPART+1) = 27 ELSE ITYP(NPART) = 27 ITYP(NPART+1) = 19 ENDIF ELSE IF ( RD(2) .LT. 0.5 ) THEN ITYP(NPART) = 21 ITYP(NPART+1) = 29 ELSE ITYP(NPART) = 29 ITYP(NPART+1) = 21 ENDIF ENDIF CALL PTRAM( ZN,AVPH,PX(NPART),PY(NPART) ) CALL PTRAM( ZN,AVPH,PX(NPART+1),PY(NPART+1) ) SPX = SPX + PX(NPART) + PX(NPART+1) SPY = SPY + PY(NPART) + PY(NPART+1) NPART = NPART + 2 1005 CONTINUE C DECIDE WITH WHICH CHARGED PION TO START WITH C NUMBER OF PIONS MAY BE ODD IN THE CASE IF ISEL IS 1 CALL RMMAR( RD,1,1 ) IF ( RD(1) .GT. 0.5 ) THEN NPIOCH = 0 ELSE NPIOCH = 1 ENDIF NPOS = NCPLUS C PI +- DO 1007 K = 1,NPC IF ( NPC-K+1 .LE. NPOS ) THEN NPIOCH = 1 IF ( DEBUG ) WRITE(MDEBUG,*) ' NPC,K,NPOS,NPIOCH=', * NPC,K,NPOS,NPIOCH ELSEIF ( NPC-K+1 .LE. -NPOS ) THEN NPIOCH = 0 IF ( DEBUG ) WRITE(MDEBUG,*) ' NPC,K,-NPOS,NPIOCH=', * NPC,K,-NPOS,NPIOCH ENDIF IF ( NPIOCH .EQ. 0 ) THEN ITYP(NPART) = 8 NPIOCH = 1 NPOS = NPOS + 1 ELSE ITYP(NPART) = 9 NPIOCH = 0 NPOS = NPOS - 1 ENDIF CALL PTRAM( ZN,AVPT,PX(NPART),PY(NPART) ) SPX = SPX + PX(NPART) SPY = SPY + PY(NPART) NPART = NPART + 1 1007 CONTINUE C NEUTRON ANTINEUTRON PAIRS DO 1008 K = 1,NNN CALL RMMAR( RD,1,1 ) IF ( RD(1) .LT. 0.5 ) THEN ITYP(NPART) = 13 ITYP(NPART+1) = 25 ELSE ITYP(NPART) = 25 ITYP(NPART+1) = 13 ENDIF CALL PTRAM( ZN,AVPN,PX(NPART),PY(NPART) ) CALL PTRAM( ZN,AVPN,PX(NPART+1),PY(NPART+1) ) SPX = SPX + PX(NPART) + PX(NPART+1) SPY = SPY + PY(NPART) + PY(NPART+1) NPART = NPART + 2 1008 CONTINUE C K0L K0S PAIRS DO 1009 K = 1,NKN CALL RMMAR( RD,1,1 ) IF ( RD(1) .LT. 0.5 ) THEN ITYP(NPART) = 10 ITYP(NPART+1) = 16 ELSE ITYP(NPART) = 16 ITYP(NPART+1) = 10 ENDIF CALL PTRAM( ZN,AVPK,PX(NPART),PY(NPART) ) CALL PTRAM( ZN,AVPK,PX(NPART+1),PY(NPART+1) ) SPX = SPX + PX(NPART) + PX(NPART+1) SPY = SPY + PY(NPART) + PY(NPART+1) NPART = NPART + 2 1009 CONTINUE C LAMDA/SIGMA0 PAIRS DO 1010 K = 1,NHN CALL RMMAR( RD,2,1 ) IF ( RD(1) .LT. 0.5 ) THEN IF ( RD(2) .LT. 0.5 ) THEN ITYP(NPART) = 18 ITYP(NPART+1) = 28 ELSE ITYP(NPART) = 28 ITYP(NPART+1) = 18 ENDIF ELSE IF ( RD(2) .LT. 0.5 ) THEN ITYP(NPART) = 26 ITYP(NPART+1) = 20 ELSE ITYP(NPART) = 20 ITYP(NPART+1) = 26 ENDIF ENDIF C ----- CHANGE BY JNC DEC.96) * IF ( ECMDPM .LE. 500.D0 ) THEN * CALL PTRAN( ZN,AVPH,PX(NPART),PY(NPART) ) * CALL PTRAN( ZN,AVPH,PX(NPART+1),PY(NPART+1) ) * ELSE CALL PTRAM( ZN,AVPH,PX(NPART),PY(NPART) ) CALL PTRAM( ZN,AVPH,PX(NPART+1),PY(NPART+1) ) * ENDIF SPX = SPX + PX(NPART) + PX(NPART+1) SPY = SPY + PY(NPART) + PY(NPART+1) NPART = NPART + 2 1010 CONTINUE C ETA DO 1013 K = 1,NET C FIRST FOR ETAS FROM THIRD STRING IF ( K .LE. NETA(3,1) ) THEN ITYP(NPART) = 71 ELSEIF ( K .LE. NETA(3,1)+NETA(3,2) ) THEN ITYP(NPART) = 72 ELSEIF ( K .LE. NETA(3,1)+NETA(3,2)+NETA(3,3) ) THEN ITYP(NPART) = 73 ELSEIF ( K .LE. NETA(3,1)+NETA(3,2)+NETA(3,3)+NETA(3,4)) THEN ITYP(NPART) = 74 C NOW FOR ETAS FROM FIRST AND SECOND STRING ELSEIF ( K .LE. NETAS(3)+NETA(2,1) ) THEN ITYP(NPART) = 71 ELSEIF ( K .LE. NETAS(3)+NETA(2,1)+NETA(2,2) ) THEN ITYP(NPART) = 72 ELSEIF ( K .LE. NETAS(3)+NETA(2,1)+NETA(2,2)+NETA(2,3) ) THEN ITYP(NPART) = 73 ELSE ITYP(NPART) = 74 ENDIF C ----- CHANGE BY JNC DEC.96) IF ( ECMDPM .LE. 500.D0 ) THEN CALL PTRAN( ZN,AVPE,PX(NPART),PY(NPART) ) ELSE CALL PTRAM( ZN,AVPE,PX(NPART),PY(NPART) ) ENDIF SPX = SPX + PX(NPART) SPY = SPY + PY(NPART) NPART = NPART + 1 1013 CONTINUE C PI(0) DO 1014 K = 1,NPN ITYP(NPART) = 7 C ----- CHANGE BY JNC DEC.96) IF ( ECMDPM .LE. 500.D0 ) THEN CALL PTRAN( ZN,AVPT,PX(NPART),PY(NPART) ) ELSE CALL PTRAM( ZN,AVPT,PX(NPART),PY(NPART) ) ENDIF SPX = SPX + PX(NPART) SPY = SPY + PY(NPART) NPART = NPART + 1 1014 CONTINUE C ANTILEADER (FROM TARGET, THEREFORE ALWAYS NUCLEON OR DELTA RESONANCE) ITYP(2) = LEPAR2 C ----- CHANGE BY JNC DEC.96) IF ( ECMDPM .LE. 500.D0 ) THEN CALL PTRAN( ZN,AVPN,PX(2),PY(2) ) ELSE CALL PTRAM( ZN,AVPN,PX(2),PY(2) ) ENDIF C FIRST PARTICLE IS LEADING PARTICLE ITYP(1) = LEPAR1 IF ( (LEPAR1 .GE. 7 .AND. LEPAR1 .LE. 9) .OR. * (LEPAR1 .GE. 51 .AND. LEPAR1 .LE. 53) ) THEN C LEADING PARTICLE IS PION OR RHO RESONANCE AVERPT = AVPT C LEADING PARTICLE IS KAON OR KAON RESONANCE ELSEIF ( LEPAR1 .EQ. 10 .OR. LEPAR1 .EQ. 11 .OR. * LEPAR1 .EQ. 12 .OR. LEPAR1 .EQ. 16 .OR. * (LEPAR1 .GE. 62 .AND. LEPAR1 .LE. 68) ) THEN AVERPT = AVPK ELSE C LEADING PARTICLE IS NUCLEON OR ANTINUCLEON OR DELTA RESONANCE C OR STRANGE BARYON AVERPT = AVPN ENDIF C ----- CHANGE BY JNC DEC.96) IF ( ECMDPM .LE. 500.D0 ) THEN CALL PTRAN( ZN,AVERPT,PX(1),PY(1) ) ELSE CALL PTRAM( ZN,AVERPT,PX(1),PY(1) ) ENDIF SPX = SPX + PX(1) + PX(2) SPY = SPY + PY(1) + PY(2) C AVERAGE EXCESS PT PER PARTICLE SPX = SPX / NTOT SPY = SPY / NTOT C RENORMALIZATION OF PT AND CALCULATION OF TRANSVERSE MASSES DO 130 I = 1,NTOT PX(I) = PX(I) - SPX PY(I) = PY(I) - SPY PT2(I) = PX(I)**2 + PY(I)**2 TMAS(I) = SQRT( PAMA(ITYP(I))**2 + PT2(I) ) 130 CONTINUE RETURN END *CMZ : 28/02/2002 12.02.13 by D. HECK IK FZK KARLSRUHE *-- Author : J.N. Capdevielle CdF Paris/France 26/11/96 C======================================================================= SUBROUTINE PTRAM( ZN,FACT,PTX,PTY ) C----------------------------------------------------------------------- C TRA(NSVERSE MOMENTUM FROM) M(IMI EXPERIMENT) C C GENERATION OF TRANSVERSE MOMENTUM FOR PARTICLES IN HDPM GENERATOR C SEE RESULTS FROM UA1/MIMI/96 C SOME CONSTANTS CHANGED FROM MATHEMATICAL SOLUTION BY DICHOTOMY TO C TO TAKE INTO ACCOUNT EFFECT OF REJECTIONS. (TESTIFIED AT VS=630 GEV C ONLY) SEE J.N. CAPDEVIELLE, 24TH ICRC, ROMA 1995, RAPPORTEUR TALK C NUOV. CIM. C19 (1996) 623 C AND J.N. CAPDEVIELLE, 9TH ISVHECRI, KARLSRUHE 1996 C NUCL.PHYS.B (CONF.PROC.) 52B (1997) 146 C THIS SUBROUTINE IS CALLED FROM PPARAM. C ARGUMENTS: C ZN = POWER OF TRANSV.MOMENTUM FUNCTION, DEP. ON CENT.RAP.DENSITY C FACT = FACTOR TAKING INTO ACCOUNT PARTICLE SPEC. TRANSV.MOMENTUM C PTX = TRANSVERSE MOMENTUM IN X DIRECTION C PTY = TRANSVERSE MOMENTUM IN Y DIRECTION C C DESIGN : J.N. CAPDEVIELLE CDF PARIS C CHANGES : D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. SAVE C----------------------------------------------------------------------- CC IF ( DEBUG ) WRITE(MDEBUG,*) 'PTRAM : ZN=',SNGL(ZN) C TWO RANDOM NUMBERS CALL RMMAR( RD,2,1 ) C GENERATE ALFA = -0.05D0 B = ZN-1.D0 A = RD(1)/B U = 0.D0 DO 5 J = 1,1000 F1 = A * (U+1.D0)**B - 1.D0/B IF ( F1 .GE. U ) GOTO 15 U = U + 0.05D0 5 CONTINUE 15 BETA = U ALFA = U - 0.05D0 IF ( F1-U .EQ. 0.D0 ) GOTO 30 I = 0 14 U = 0.5D0 * (ALFA+BETA) I = I + 1 F = A * (U+1.D0)**B - 1.D0/B - U IF ( F .EQ. 0.D0 ) GOTO 30 IF ( ABS(U-BETA) .LE. 1.D-4 ) GOTO 30 FA = A * (ALFA+1.D0)**B - ALFA - 1.D0/B FB = B * (BETA+1.D0)**B - BETA - 1.D0/B IF ( F*FA .GE. 0.D0 ) THEN ALFA = U ELSE BETA = U ENDIF GOTO 14 30 XPT = 0.9154D0 * U C 2*PI*RANDOM NUMBER FOR ANGLE PHI Z = PI2 * RD(2) PTX = XPT * FACT * COS(Z) PTY = XPT * FACT * SIN(Z) CC IF ( DEBUG ) WRITE(MDEBUG,*) 'PTRAM : RD(1,2),XPT=', CC * RD(1),RD(2),SNGL(XPT) RETURN END *CMZ : 14/06/2000 14.29.37 by D. HECK IK3 FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE PTRAN( ZN,FACT,PTX,PTY ) C----------------------------------------------------------------------- C TRAN(SVERSE MOMENTUM) C C GENERATION OF TRANSVERSE MOMENTUM FOR PARTICLES IN HDPM C THIS SUBROUTINE IS CALLED FROM PPARAM. C ARGUMENTS: C ZN = POWER OF TRANSV.MOMENTUM FUNCTION, DEP. ON CENT.RAP.DENSITY C FACT = FACTOR TAKING INTO ACCOUNT PARTICLE SPEC. TRANSV.MOMENTUM C PTX = TRANSVERSE MOMENTUM IN X DIRECTION C PTY = TRANSVERSE MOMENTUM IN Y DIRECTION C C DESIGN : T. THOUW IK3 FZK KARLSRUHE C CHANGES : D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. SAVE C----------------------------------------------------------------------- CC IF ( DEBUG ) WRITE(MDEBUG,*) 'PTRAN : ZN=',SNGL(ZN) C TWO RANDOM NUMBERS CALL RMMAR( RD,2,1 ) C GENERATE (REFERENCE??) B = ZN * (ZN - 1.D0) ZZ = SQRT(1.D0/RD(1) - 1.D0) XPT = ZZ * SQRT(2.D0/B) 11 CONTINUE IF ( XPT .LT. 0.5D-3 ) GOTO 22 X1 = 1.D0 + XPT XB = X1**ZN XC = 1.D0 + ZN * XPT ZA = SQRT(XB/XC - 1.D0) XD = (ZZ - ZA) * (X1 * 2.D0 * ZA * XC**2 ) / ( B * XPT * XB ) XPT = XPT + XD IF ( ABS(XD) .GT. 1.D-3 ) GOTO 11 22 CONTINUE C 2*PI*RANDOM NUMBER FOR ANGLE PHI Z = PI2 * RD(2) PTX = XPT * FACT * COS(Z) PTY = XPT * FACT * SIN(Z) CC IF ( DEBUG ) WRITE(MDEBUG,*) 'PTRAN : RD(1,2),XPT=', CC * RD(1),RD(2),SNGL(XPT) RETURN END *CMZ : 24/10/2000 15.41.00 by D. HECK IK3 FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE RESDEC C----------------------------------------------------------------------- C RES(ONANCE) DEC(AY) C C ROUTINE TREATES DECAY OF THE RESONANCES RHO, K*, AND DELTA C THE DECAY MODE IS SELECTED BY THE RANDOM NUMBER RESRAN, WHICH IS C SET IN THE SUBROUT. HDPM/LEPACX, WHERE THE RESONANCE IS FORMED C DECAY WITH FULL KINEMATIC, ENERGY AND MOMENTA CONSERVED C THIS SUBROUTINE IS CALLED FROM BOX3. C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,DECAY. COMMON /DECAY/ GAM345,COS345,PHI345 DOUBLE PRECISION GAM345(3),COS345(3),PHI345(3) *KEEP,GENER. COMMON /GENER/ GEN,ALEVEL DOUBLE PRECISION GEN,ALEVEL *KEEP,LONGI. COMMON /LONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG, * SDLONG,SELONG,SPLONG,THSTEP,THSTPI, * LHEIGH,NSTEP,LLONGI,FLGFIT DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9), * APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9), * HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9), * SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI INTEGER LHEIGH,NSTEP LOGICAL LLONGI,FLGFIT *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RESON. COMMON /RESON/ RDRES,RESRAN,IRESPAR REAL RDRES(2),RESRAN(30000) INTEGER IRESPAR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. INTEGER I,KK,M3,M4 SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=1,9) 444 FORMAT(' RESDEC: CURPAR=',1P,9E10.3) C COPY VERTEX COORDINATES INTO SECPAR DO 141 KK = 5,8 SECPAR(KK) = CURPAR(KK) 141 CONTINUE SECPAR( 9) = GEN SECPAR(10) = ALEVEL SECPAR(14) = CURPAR(14) SECPAR(15) = CURPAR(15) SECPAR(16) = CURPAR(16) BETA = SQRT( GAMMA**2 - 1.D0 ) / GAMMA IF ( IRESPAR .LE. 0 ) THEN WRITE(MONIOU,*) 'RESDEC: IRESPAR .LE. 0, CORRECTED' IRESPAR = 1 ENDIF C----------------------------------------------------------------------- C TREAT FIRST NUCLEON RESONANCES, AS MOST FREQUENT IF ( ITYPE .EQ. 54 ) THEN C DECAY DELTA(++) ----> P + PI(+) CALL DECAY1( ITYPE, 14, 8 ) ELSEIF ( ITYPE .EQ. 55 .OR. ITYPE .EQ. 56 ) THEN C DECAY DELTA(+) OR DECAY DELTA(0) IF ( RESRAN(IRESPAR) .LE. TB3 ) THEN C DECAY DELTA(+) ----> P + PI(0) C DECAY DELTA(0) ----> N + PI(0) M3 = 69 - ITYPE CALL DECAY1( ITYPE, M3, 7 ) ELSE C DECAY DELTA(+) ----> N + PI(+) C DECAY DELTA(0) ----> P + PI(-) M3 = ITYPE - 42 M4 = M3 - 5 CALL DECAY1( ITYPE, M3, M4 ) ENDIF ELSEIF ( ITYPE .EQ. 57 ) THEN C DECAY DELTA(-) ----> N + PI(-) CALL DECAY1( ITYPE, 13, 9 ) C----------------------------------------------------------------------- C RHO RESONANCES ELSEIF ( ITYPE .EQ. 51 ) THEN C DECAY RHO(0) ----> PI(+) + PI(-) CALL DECAY1( ITYPE, 8, 9 ) ELSEIF ( ITYPE .EQ. 52 .OR. ITYPE .EQ. 53 ) THEN C DECAY RHO(+,-) ----> PI(+,-) + PI(0) M3 = ITYPE - 44 CALL DECAY1( ITYPE, M3, 7 ) C----------------------------------------------------------------------- C OMEGA MESON RESONANCE (COMES FROM PHOTONUCLEAR REACTION) ELSEIF ( ITYPE .EQ. 50 ) THEN CALL RMMAR(RD,1,1) IF ( RD(1) .LE. 0.8924 ) THEN C DECAY OMEGA ----> PI(+) + PI(-) + PI(0) C (UNIFORM PHASE SPACE DISTRIBUTION IS ASSUMED FOR THIS DECAY) CALL DECAY6 ( PAMA(50), PAMA(8), PAMA(9), PAMA(7), * 0.D0,0.D0,0.D0, 1.D0, 2) DO I = 1,3 CALL ADDANG( COSTHE,PHI, COS345(I),PHI345(I), * SECPAR(3),SECPAR(4) ) IF ( SECPAR(3) .GT. C(29) ) THEN IF ( I .EQ. 3 ) THEN SECPAR(1) = 7.D0 ELSE SECPAR(1) = 7 + I ENDIF SECPAR(2) = GAM345(I) CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( I .EQ. 3 ) THEN DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + GAM345(I)*PAMA(7) ELSE DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + GAM345(I)*PAMA(8) ENDIF ENDIF ENDIF ENDDO ELSEIF ( RD(1) .LE. 0.9778 ) THEN C DECAY OMEGA ----> PI(0) + GAMMA CALL DECAY1 ( ITYPE, 7, 1 ) ELSE C DECAY OMEGA ----> PI(+) + PI(-) CALL DECAY1( ITYPE, 8, 9 ) ENDIF C----------------------------------------------------------------------- C EXCITED KAON RESONANCES ELSEIF ( ITYPE .EQ. 62 ) THEN C DECAY K*(0) ----> 2/3: K(+) + PI(-) C ----> 1/3: K0(L,S) + PI(0) IF ( RESRAN(IRESPAR) .LE. TB3 ) THEN CALL DECAY1( ITYPE, 11, 9 ) ELSEIF ( RESRAN(IRESPAR) .LE. .8333333 ) THEN CALL DECAY1( ITYPE, 10, 7 ) ELSE CALL DECAY1( ITYPE, 16, 7 ) ENDIF ELSEIF ( ITYPE .EQ. 65 ) THEN C DECAY ANTI-K*(0) ----> 2/3: K(-) + PI(+) C ----> 1/3: K0(L,S) + PI(0) IF ( RESRAN(IRESPAR) .LE. TB3 ) THEN CALL DECAY1( ITYPE, 12, 8 ) ELSEIF ( RESRAN(IRESPAR) .LE. .8333333 ) THEN CALL DECAY1( ITYPE, 10, 7 ) ELSE CALL DECAY1( ITYPE, 16, 7 ) ENDIF ELSEIF ( ITYPE .EQ. 63 .OR. ITYPE .EQ. 64 ) THEN C DECAY K*(+-) ----> 2/3: K(+-) + PI(0) C ----> 1/3: K0(L,S) + PI(+-) IF ( RESRAN(IRESPAR) .LE. TB3 ) THEN CALL DECAY1( ITYPE, ITYPE-52, 7 ) ELSEIF ( RESRAN(IRESPAR) .LE. .8333333 ) THEN CALL DECAY1( ITYPE, 10, ITYPE-55 ) ELSE CALL DECAY1( ITYPE, 16, ITYPE-55 ) ENDIF C----------------------------------------------------------------------- C ANTI-NUCLEON RESONANCES ELSEIF ( ITYPE .EQ. 58 ) THEN C DECAY ANTI-DELTA(--) ----> ANTI-P + PI(-) CALL DECAY1( ITYPE, 15, 9 ) ELSEIF ( ITYPE .EQ. 59 .OR. ITYPE .EQ. 60 ) THEN C DECAY ANTI-DELTA(-) OR DECAY ANTI-DELTA(0) IF ( RESRAN(IRESPAR) .LE. TB3 ) THEN C DECAY ANTI-DELTA(-) ----> ANTI-P + PI(0) C DECAY ANTI-DELTA(0) ----> ANTI-N + PI(0) M3 = 15 + (ITYPE - 59) * 10 CALL DECAY1( ITYPE, M3, 7 ) ELSE C DECAY ANTI-DELTA(-) ----> ANTI-N + PI(-) C DECAY ANTI-DELTA(0) ----> ANTI-P + PI(+) M3 = 15 + (60 - ITYPE) * 10 M4 = 68 - ITYPE CALL DECAY1( ITYPE, M3, M4 ) ENDIF ELSEIF ( ITYPE .EQ. 61 ) THEN C DECAY ANTI-DELTA(+) ----> ANTI-N + PI(+) CALL DECAY1( ITYPE, 25, 8 ) C----------------------------------------------------------------------- ELSE WRITE(MONIOU,444) (CURPAR(I),I=1,9) WRITE(MONIOU,*) 'RESDEC: UNFORESEEN PARTICLE CODE =',ITYPE ENDIF IRESPAR = IRESPAR - 1 RETURN END *CMZ : 14/06/2000 14.29.37 by D. HECK IK3 FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE RNEGBI( N,XN,ECM ) C----------------------------------------------------------------------- C R(ANDOM NUMBER WITH) NEG(ATIVE) BI(NOMIAL DISTRIBUTION) C C RANDOM NUMBER GENERATOR FOR INTEGER NUMBERS DISTRIBUTED ACCORDING TO C A NEGATIVE BINOMIAL DISTRIBUTION WITH PARAMETERS AND K C DELIVERS ONLY EVEN NUMBERS AS CHARGE MUST BE CONSERVED C THIS SUBROUTINE IS CALLED FROM HDPM. C ARGUMENTS: C XN = AVERAGE VALUE OF N C ECM = CENTER OF MASS ENERGY C N = RANDOM NUMBER DISTRIBUTED WITH NEG. BIN. DISTR. C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DOUBLE PRECISION ECM,P,PN,Q,R,SUM,XI,XK,XN INTEGER N SAVE C----------------------------------------------------------------------- CC IF ( DEBUG ) WRITE(MDEBUG,*) 'RNEGBI: XN,ECM=',SNGL(XN),SNGL(ECM) C PARAMETRIZATION OF PARAMETER K OF NEG.BIN. DISTRIBUTION ACCORDING C TO UA5 COLLABORATION, PHYS. LETT. 167B (1986) 476 XK = 1.D0 / ( -0.104D0 + 0.058D0 * LOG(ECM) ) C OTHER PARAMETERS R = XN / XK Q = 1.D0 / (1.D0 + R) P = R * Q C VALUES FOR N EQUAL 0 1 CONTINUE N = 0 PN = Q**XK SUM = PN C GET UNIFORM RANDOM NUMBER CALL RMMAR( RD,1,1 ) IF ( RD(1) .LE. SUM ) GOTO 100 C COMPARE WITH SUM OVER P(N) DO 2 XI = 1.D0, 1350.D0 PN = PN * P * (XK - 1.D0 + XI) / XI SUM = SUM + PN IF ( RD(1) .LE. SUM ) THEN N = XI GOTO 100 ENDIF 2 CONTINUE N = 1350 100 CONTINUE IF ( MOD(N,2) .NE. 0 .AND. N .NE. 1 ) GOTO 1 CC IF (DEBUG) WRITE(MDEBUG,*)'RNEGBI: RD(1),N,=',RD(1),N,SNGL(XN) RETURN END *CMZ : 14/06/2000 14.29.37 by D. HECK IK3 FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE TARINT C----------------------------------------------------------------------- C TAR(GET) INT(ERACTIONS) C C ROUTINE DETERMINES HOW MANY INTERACTIONS OCCUR IN TARGET C THIS SUBROUTINE IS CALLED FROM HDPM. C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) *KEEP,DPMFLG. COMMON /DPMFLG/ NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM INTEGER NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM *KEEP,GNUPR. COMMON /GNUPR/ SE14,SE16,SE40 DOUBLE PRECISION SE14(3,14),SE16(3,16),SE40(3,40) *KEEP,INTER. COMMON /INTER/ AVCH,AVCH3,DC0,DLOG,DMLOG,ECMDIF,ECMDPM,ELAB, * FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3, * RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG, * WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN, * IDIF,ITAR DOUBLE PRECISION AVCH,AVCH3,DC0,DLOG,DMLOG,ECMDIF,ECMDPM,ELAB, * FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3, * RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG, * WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN INTEGER IDIF,ITAR *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,REST. COMMON /REST/ CONTNE,TAR,LT DOUBLE PRECISION CONTNE(3),TAR INTEGER LT *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,SIGM. COMMON /SIGM/ SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO DOUBLE PRECISION SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO *KEND. SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'TARINT: ITYPE,TAR,NFLAIN', * ITYPE,SNGL(TAR),NFLAIN C NFLAIN EQUAL 0 : NUMBER OF INTERACTIONS IN TARGET CHOSEN RANDOMLY IF ( NFLAIN .EQ. 0 ) THEN C SIGMA IS ALREADY CALCULATED IN BOX2 DELSIG = SIGMA - 45.D0 DSIGSQ = DELSIG**2 C CHOOSE RANDOM NUMBER CALL RMMAR( RD,1,1 ) IF ( DEBUG ) WRITE(MDEBUG,*) 'TARINT: DELSIG,DSIGSQ,RD(1),TAR=', * SNGL(DELSIG),SNGL(DSIGSQ),RD(1),SNGL(TAR) C DO INTERACTION WITH CHOSEN TARGET ( N, O, AR ) PROB = 0.D0 C TREAT INTERACTION WITH NITROGEN TARGET IF ( TAR .EQ. 14.D0 ) THEN C SUM OF PROBABILITIES FOR COLLISION WITH NITROGEN TARGET DO 6151 JL = 1,14 PROB = PROB + * SE14(1,JL) + SE14(2,JL)*DELSIG + SE14(3,JL)*DSIGSQ IF ( RD(1) .LE. PROB ) GOTO 7332 6151 CONTINUE C TREAT INTERACTION WITH OXYGEN TARGET ELSEIF ( TAR .EQ. 16.D0 ) THEN C SUM OF PROBABILITIES FOR COLLISION WITH OXYGEN TARGET DO 6152 JL = 1,16 PROB = PROB + * SE16(1,JL) + SE16(2,JL)*DELSIG + SE16(3,JL)*DSIGSQ IF ( RD(1) .LE. PROB ) GOTO 7332 6152 CONTINUE C TREAT INTERACTION WITH ARGON TARGET ELSEIF ( TAR .EQ. 40.D0 ) THEN C SUM OF PROBABILITIES FOR COLLISION WITH ARGON TARGET DO 6153 JL = 1,40 PROB = PROB + * SE40(1,JL) + SE40(2,JL)*DELSIG + SE40(3,JL)*DSIGSQ IF ( RD(1) .LE. PROB ) GOTO 7332 6153 CONTINUE ELSE WRITE(MONIOU,*) 'TARINT: UNKNOWN TARGET = ',SNGL(TAR) ENDIF JL = 1 C NUMBER OF COLLISIONS IN TARGET 7332 CONTINUE GNU = DBLE(JL) ELSE C NFLAIN EQUAL 1 : AVERAGE NUMBER OF INTERACTIONS IN TARGET IS TAKEN C NEW PARAMETRIZATION OF J.N.CAPDEVIELLE (MARCH 93) GNU = (0.4826D0 + 3.522D-2 * SLOG) * TAR**0.31D0 ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) * 'TARINT: # COLLISIONS IN TARGET=',SNGL(GNU) RETURN END *CMZ : 28/02/2002 13.08.20 by D. HECK IK FZK KARLSRUHE *-- Author : CERN PROGLIB# V113 C======================================================================= FUNCTION RANGEN() C----------------------------------------------------------------------- C RAN(DOM NUMBER) GEN(ERATOR) C C SEE SUBROUT. RMMAR C THIS FUNCTION IS CALLED FROM MANY VENUS ROUTINES. C C CERN PROGLIB# V113 RMMAR .VERSION KERNFOR 1.0 C ORIG. 01/03/89 FCA + FJ C C CHANGES : D. HECK IK3 FZK KARLSRUHE C DATE : FEB 02, 1994 C----------------------------------------------------------------------- C REAL RVEC(1) COMMON /RANMA2/ IU(1030),JSEQ COMMON /RANMA3/ TWOM24,TWOM48,CD,CM,CINT,MODCNS INTEGER I97(0:1030),J97(0:1030),NTOT(0:1030) INTEGER NTOT2(0:1030),IJKL(0:1030) REAL U(97),C(0:1030) EQUIVALENCE (IJKL(0),IU(1)),(NTOT(0),IU(2)),(NTOT2(0),IU(3)) EQUIVALENCE (U(1),IU(4)),(C(0),IU(101)),(I97(0),IU(102)) EQUIVALENCE (J97(0),IU(103)) SAVE C----------------------------------------------------------------------- C ISEQ = 1 LENV = 1 C IF ( ISEQ .GT. 0 ) JSEQ = ISEQ C IBASE = (JSEQ-1)*103 IBASE = 0 IVEC = 1 C DO 100 IVEC = 1,LENV UNI = U( +I97(IBASE))-U( +J97(IBASE)) IF ( UNI .LT. 0. ) UNI = UNI+1. U( +I97(IBASE)) = UNI I97(IBASE) = I97(IBASE)-1 IF ( I97(IBASE) .EQ. 0 ) I97(IBASE) = 97 J97(IBASE) = J97(IBASE)-1 IF ( J97(IBASE) .EQ. 0 ) J97(IBASE) = 97 C(IBASE) = C(IBASE) - CD IF ( C(IBASE) .LT. 0. ) C(IBASE) = C(IBASE)+CM UNI = UNI-C(IBASE) IF ( UNI .LT. 0. ) UNI = UNI+1. C REPLACE EXACT ZEROES BY UNIFORM DISTR. *2**-24 IF ( UNI .EQ. 0. ) THEN UNI = TWOM24*U(2) C AN EXACT ZERO HERE IS VERY UNLIKELY, BUT LET'S BE SAFE. IF ( UNI .EQ. 0. ) UNI = TWOM48 ENDIF RANGEN = UNI 100 CONTINUE NTOT(IBASE) = NTOT(IBASE) + LENV IF ( NTOT(IBASE) .GE. MODCNS ) THEN NTOT2(IBASE) = NTOT2(IBASE) + 1 NTOT(IBASE) = NTOT(IBASE) - MODCNS ENDIF RETURN END *CMZ : 28/02/2002 12.36.15 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE UTQSEA(X1,X2,X3) C----------------------------------------------------------------------- C UT(ILITY ROUTINE) SEA (QUARK STRUCTURE FUNCTION) C C SEA QUARK STRUCTURE FUNCTION INTEGRAL C RETURNS INTEGRAL (XSE(1)->XSE(I)) OF FU(Z) DZ C THIS SUBROUTINE IS CALLED FROM VENLNK. C ARGUMENTS: C X1 = C X2 = C X3 = C C DESIGN : D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. PARAMETER (NSTRU=2049) COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT COMMON /STRU2/ DELTA0,DELTA1,QSEH(NSTRU),QSEPI(NSTRU) * ,QVAH(NSTRU),QVAPI(NSTRU),XSE(NSTRU),XVA(NSTRU) SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'UTQSEA:' X0 = 0. N = NSTRU IF ( ISH .GE. 90 ) THEN IF ( X1.LT.X0 .OR. X2.LT.X1 .OR. X3.LT.X2 ) THEN CALL UTMSG('UTQSEA') WRITE(IFCH,*) ' XI=',X0,X1,X2,X3 CALL UTMSGF ENDIF ENDIF I1 = N/3 I2 = 2*N/3 FAC1 = (X1-X0)/FLOAT(I1-1) DO 11 I = 1,I1-1 XSE(I)=(I-1.)*FAC1+X0 11 CONTINUE FAC2 = (X2-X1)/FLOAT(I2-I1) DO 12 I = I1,I2-1 XSE(I)=FLOAT(I-I1)*FAC2 +X1 12 CONTINUE FAC3 = (X3-X2)/FLOAT(N-I2) DO 13 I = I2,N XSE(I)=MIN( FLOAT(I-I2)*FAC3 +X2, 0.99999999 ) 13 CONTINUE XCUT2 = XCUT**2 XCUT4 = XCUT2**2 XCUT6 = XCUT2*XCUT4 CUTLOG = LOG(XCUT) C COEFFICIENTS FOR HADRONIC SEA QUARK STRUCTURE FUNCTION AH0 = -8. + 37.333333*XCUT2 - 29.866667*XCUT4 + 3.65714286*XCUT6 AH1 = 14. - 26.25*XCUT2 + 8.75*XCUT4 - 0.2734375*XCUT6 AH2 = -18.666667 + 14.933333*XCUT2 - 1.82857143*XCUT4 AH3 = 17.5 - 5.8333333*XCUT2 + 0.182291667*XCUT4 AH4 = -11.2 + 1.37142857*XCUT2 AH5 = 4.6666667 - 0.14583333*XCUT2 AH6 = -1.14285714 AH7 = 0.125 QAH = 1. - AH1 * XCUT2 AHCUT = AH0 * XCUT C COEFFICIENTS FOR PIONIC SEA QUARK STRUCTURE FUNCTION API0 = -5. + 6.6666667*XCUT2 - 0.53333333*XCUT4 API1 = 5. - 1.875*XCUT2 API2 = -3.3333333 + 0.26666667*XCUT2 API3 = 1.25 API4 = -0.2 QAPI = 1. - API1 * XCUT2 APICUT = API0 * XCUT QSEH(1) = 0. QSEPI(1) = 0. DO 2 I = 2,N Z = XSE(I) ROOT = SQRT(Z**2 + XCUT2) ROOTLG = LOG( Z + ROOT ) - CUTLOG QSEH(I) = 1.265 * ( QAH * ROOTLG - AHCUT * + ROOT * (AH0 + Z*(AH1 + Z*(AH2 + Z*(AH3 * + Z*(AH4 + Z*(AH5 + Z*(AH6 + Z*AH7))))))) ) QSEPI(I) = 0.9 * ( QAPI * ROOTLG - APICUT * + ROOT * (API0+Z*(API1+Z*(API2+Z*(API3+Z*API4)))) ) 2 CONTINUE RETURN END *CMZ : 14/06/2000 14.17.24 by D. HECK IK3 FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE UTQVAL(Q,NEND) C----------------------------------------------------------------------- C UT(ILITY ROUTINE) VAL(ENCE QUARK STRUCTURE FUNCTION) C C VALENCE QUARK STRUCTURE FUNCTION C RETURNS INTEGRAL (XVA(1)->XVA(I)) FU(Z) DZ C THIS INTEGRAL IS ONLY CALCULATED FOR SMALL VALUES OF XVA UP TO 25 C TIMES THE VALUE OF XCUT. FOR LARGER VALUES THE TABULATED VALUES OF C DATASET 'VENUSDAT' ARE TAKEN AND CORRECTED BY THE CONSTANT SHIFT C DELTA0 (FOR HADRONS) OR DELTA1 (FOR PIONS). C THIS SUBROUTINE IS CALLED FROM VENLNK. C ARGUMENTS: C Q = INTEGRAL VALUE C NEND = POINTER TO LAST ARGUMENT C C DESIGN : D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. PARAMETER (NSTRU=2049) COMMON /CIPIO/ IPIO COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /STRU2/ DELTA0,DELTA1,QSEH(NSTRU),QSEPI(NSTRU) * ,QVAH(NSTRU),QVAPI(NSTRU),XSE(NSTRU),XVA(NSTRU) DIMENSION Y0(9),Y1(9),Q(NEND) SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'UTQVAL: IPIO,NEND=',IPIO,NEND XCUT2 = XCUT**2 Q(1) = 0. Z = XVA(1) DENOMI = 1. / SQRT(Z**2 + XCUT2) IF ( IPIO .EQ. 0 ) THEN C CALCULATE THE FIRST NEND VALUES OF STRUCTURE FUNCTION FOR HADRONS Y0(1) = 0. DO 3 I = 2,NEND FACT = (XVA(I) - Z) * 0.125 DO 2 J = 2,8 Z = Z + FACT DENOMI = 1. / SQRT(Z**2 + XCUT2) Y0(J) = (1.-Z)**3.46 * Z**.419 * (2.74793064*Z + 0.62452969) * * DENOMI 2 CONTINUE Z = XVA(I) DENOMI = 1. / SQRT(Z**2 + XCUT2) Y0(9) = (1.-Z)**3.46 * Z**.419 * (2.74793064*Z + 0.62452969) * * DENOMI C INTEGRATION AFTER BODE'S RULE (ABRAMOWITZ + STEGUN, HANDBOOK OF C MATHEMATICAL FUNCTIONS, DOVER PUBLICATIONS (1970), FORMULA 25.4.18) Q(I) = 2.8218694E-4 * FACT * ( 989. * (Y0(1) + Y0(9)) * + 5888. * (Y0(2) + Y0(8)) - 928. * (Y0(3) + Y0(7)) * + 10496. * (Y0(4) + Y0(6)) - 4540. * Y0(5) ) * + Q(I-1) Y0(1) = Y0(9) 3 CONTINUE ELSE C CALCULATE THE FIRST NEND VALUES OF STRUCTURE FUNCTION FOR PIONS Y1(1) = 0. DO 5 I = 2,NEND FACT = (XVA(I) - Z) * 0.125 DO 4 J = 2,8 Z = Z + FACT DENOMI = 1. / SQRT(Z**2 + XCUT2) Y1(J) = (1.-Z)**0.7 * Z**.4 * DENOMI 4 CONTINUE Z = XVA(I) DENOMI = 1. / SQRT(Z**2 + XCUT2) Y1(9) = (1.-Z)**0.7 * Z**.4 * DENOMI C INTEGRATION AFTER BODE'S RULE (ABRAMOWITZ + STEGUN, HANDBOOK OF C MATHEMATICAL FUNCTIONS, DOVER PUBLICATIONS (1970), FORMULA 25.4.18) Q(I) = 2.8218694E-4 * FACT * ( 989. * (Y1(1) + Y1(9)) * + 5888. * (Y1(2) + Y1(8)) - 928. * (Y1(3) + Y1(7)) * + 10496. * (Y1(4) + Y1(6)) - 4540. * Y1(5) ) * * 0.1730725 + Q(I-1) Y1(1) = Y1(9) 5 CONTINUE ENDIF RETURN END *CMZ : 14/04/2000 12.25.46 by D. HECK IK3 FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= BLOCK DATA VENDAT C----------------------------------------------------------------------- C VEN(US) DAT(A INITIALIZATION) C C INITIALIZES DATA FOR VENUS LINK C C DESIGN : D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- COMMON /VENLIN/ PTQ1,PTQ2,PTQ3,QMUST1,QMUST2,QMUST3 * ,IDTABL(100) DATA IDTABL/ * 10, -12, 12, 0, -14, 14, 110, 120, -120, -20, * 130, -130, 1220, 1120,-1120, 20, 220, 2130, 1130, 1230, * 2230, 1330, 2330, 3331,-1220,-2130,-1130,-1230,-2230,-1330, *-2330,-3331, -16, 16, -240, 240, -140, 140, -340, 340, * 2140, 0, 0, 0, 0, 0, 0, 0, 0, 0, * 111, 121, -121, 1111, 1121, 1221, 2221,-1111,-1121,-1221, *-2221, 231, 131, -131, -231, 11, -11, 13, -13, 0, * 220, 220, 220, 220, 0, 25*0 / END *CMZ : 28/02/2002 12.36.15 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE VENINI C----------------------------------------------------------------------- C VEN(US) INI(TIALIZATION) C C FIRST INITIALIZATION OF VENUS ARRAYS AND PARAMETERS C THIS SUBROUTINE IS CALLED FROM START. C C DESIGN : D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- *KEEP,AIR. COMMON /AIR/ COMPOS,PROBTA,AVERAW,AVOGAD DOUBLE PRECISION COMPOS(3),PROBTA(3),AVERAW,AVOGAD *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,VENPAR. COMMON /VENPAR/ PARVAL,NPARAM,PARCHA REAL PARVAL(100) INTEGER NPARAM CHARACTER*6 PARCHA(100) *KEEP,VENUS. COMMON /VENUS/ ISH00,IVERVN,MTAR99,FVENUS,FVENSG INTEGER ISH00,IVERVN,MTAR99 LOGICAL FVENUS,FVENSG *KEND. PARAMETER (KOLLMX=2500) PARAMETER (MXEPS=10) PARAMETER (MXTAU=4) PARAMETER (MXVOL=10) PARAMETER (NGAU=129) PARAMETER (NDEP=129) PARAMETER (NDET=129) PARAMETER (NPTF=129) PARAMETER (NPTJ=129) PARAMETER (NSTRU=2049) COMMON /ACCUM/ AMSAC,ILAMAS,IMSG,INOIAC,IPAGE,JERR,NAEVT,NREVT * ,NRPTL,NRSTR,NTEVT COMMON /CDEN/ MASSNR,RMX,R0 COMMON /CGAU/ QGAU(NGAU),XGAU(NGAU) COMMON /CIUTOT/ IUTOTC,IUTOTE COMMON /CJINTC/ CLUST(MXTAU,MXVOL,MXEPS) COMMON /CJINTD/ VOLSUM(MXTAU),VO2SUM(MXTAU),NCLSUM(MXTAU) COMMON /CLEP/ ICINPU,IDSCAT COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /COL/ BIMP,BMAX,COORD(4,KOLLMX),DISTCE(KOLLMX) * ,QDEP(NDEP),QDET14(NDET),QDET16(NDET),QDET40(NDET) * ,QDET99(NDET),RMPROJ,RMTARG(4),XDEP(NDEP) * ,XDET14(NDET),XDET16(NDET),XDET40(NDET) * ,XDET99(NDET) * ,KOLL,LTARG,NORD(KOLLMX),NPROJ,NRPROJ(KOLLMX) * ,NRTARG(KOLLMX),NTARG COMMON /CPTF/ FPTFS,FPTFSS,FPTFU,FPTFUS,FPTFUU * ,QPTFS(NPTF),QPTFSS(NPTF),QPTFU(NPTF),QPTFUS(NPTF) * ,QPTFUU(NPTF),XPTF(NPTF) COMMON /CPTJ/ QPTJ(NPTJ),XPTJ(NPTJ) COMMON /CPTLU/ NPTLU COMMON /CQUAMA / QUAMA DOUBLE PRECISION SEEDC,SEEDI COMMON /CSEED/ SEEDC,SEEDI COMMON /CVSN/ IVERSN COMMON /EPSCR/ EPSCRI COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /NEVNT/ NEVNT COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT COMMON /PARO3/ ASUHAX(7),ASUHAY(7),OMEGA,SIGPPD,SIGPPE,UENTRO * ,IWZZZZ COMMON /PARO4/ GRICEL,GRIDEL,GRIGAM,GRIRSQ,GRISLO COMMON /PARO5/ DELEPS,DELVOL COMMON /QUARKM/ SMAS,SSMAS,USMAS,UUMAS COMMON /STRU2/ DELTA0,DELTA1,QSEH(NSTRU),QSEPI(NSTRU) * ,QVAH(NSTRU),QVAPI(NSTRU),XSE(NSTRU),XVA(NSTRU) COMMON /VENLIN/ PTQ1,PTQ2,PTQ3,QMUST1,QMUST2,QMUST3 * ,IDTABL(100) SAVE EXTERNAL SDENSI,SGAU,SPTF,SPTJ C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'VENINI:' IFMT = MONIOU IFCH = MDEBUG ICHOIC = 2 NEVNT = 0 C VERSION NUMBER C -------------- IVERSN=4125 IVERVN=IVERSN C FRAGMENTATION PARAMETERS/OPTIONS C -------------------------------- C PROB. FOR U OR D QUARK PRODUCTION ( =(1-P_STRANGE)/2 ): PUD=0.455 C QQ-QQBAR PROBABILITY PDIQUA=0.12 C SPIN PROBABILITIES (FOR LIGHT AND HEAVY FLAVOURS): PSPINL=0.50 PSPINH=0.75 C ISOSPIN PROBABILITY: PISPN=0.50 C OPTION FOR P_T DISTRIBUTION (1=EXPONENTIAL,2=GAUSSIAN): IOPTF=1 C AVERAGE P_TRANSVERSE PTF=0.40 C STRING TENSION: TENSN=1.0 C STRING DECAY PARAMETER PAREA=.60 C THRESHOLD RESONANCE -> STRING DELREM=1.0 C CUTOFF FOR KMAXOR BEYOND WHICH PDIQ=0 IN SR JSPLIT KUTDIQ=4 C OPTION FOR BREAKING PROCEDURE (1=AMOR,2=SAMBA) IOPBRK=1 C PROTON-PROTON PARAMETERS/OPTIONS C -------------------------------- C OPTION FOR QUARK P_T DISTRIBUTION (1=EXPONENTIAL,2=GAUSSIAN,3=POWE IOPTQ=2 C MEAN TRANSVERSE MOMENTUM OF QUARKS C (Q1+Q2*LN(E)+Q3*LN(E)**2, E=SQRT(S)): PTQ1=0.260 PTQ2=0. PTQ3=0. C PROBABILITY FOR SEMIHARD INTERACTION (NOT USED IF NEGATIVE): C PHARD=-1.0 C CUTOFF PARAMETER FOR P_T DISTR. FOR SEMIHARD INTERACTIONS: PTH=1.0 C EFFECTIVE RATIO OF STRANGE SEA OVER U SEA: RSTRAS=0. C EFFECTIVE CUTOFF MASS IN STRUCTURE FUNCTIONS: CUTMSQ=2.0 CUTMSS=0.001 C VALENCE QUARK FRACTION IN CASE OF DIFFRACTIVE INTERACTION PVALEN=0.30 C PHASE SPACE PARAMETERS: DELMSS=0.300 C GRIBOV-REGGE-THEORY PARAMETERS C ------------------------------ C GAMMA (IN FM**2): GRIGAM=3.64*0.04 C R**2(IN FM**2): GRIRSQ=3.56*0.04 C DELTA=INTERCEPT OF REGGE TRAJECTORY-1: GRIDEL=0.07 C SLOPE OF REGGE TRAJECTORY (IN FM**2): GRISLO=0.25*0.04 C C (DETERMINES RELATIVE WEIGHT OF ELASTIC AND DIFFR CROSS-SCTN): GRICEL=1.5 C NUCLEUS-NUCLEUS PARAMETERS C -------------------------- C HARD CORE DISTANCE: CORE=0.8 C JPSI NUCLEON CROSS-SECTION (FM**2): SIGJ=0.2 C RESCATTERING PARAMETERS C ----------------------- C REACTION TIME: TAUREA=1.5 C OVERLAP PARAMETER (NOT USED IF NEGATIVE) OVERLP=-1.0 C BARYON RADIUS: RADIAC=0.65 C MESON RADIUS: RADIAS=0.35 C CRITICAL ENERGY DENSITY (<0 TO AVOID SECONDARY INTERACTIONS): EPSCRI=1.0 C BARYON ENERGY DENSITY EPSBAR=2.0 C INTERACTION MASS: AMSIAC=0.8 C OPTION TO CALL JINTA1 (1) OR JINTA2 (2) IOJINT=2 C PRINT OPTIONS AMPRIF=0. DELVOL=1.0 DELEPS=1.0 C CLUSTER DECAY PARAMETERS/OPTIONS C -------------------------------- C CORRELATION LENGTH C (CORLEN>1.0: FIRST FIX SHORT CLUSTER BREAKING CORLEN=1.0 C MINIMUM MASS AMUSEG=3.0 C BAG CONSTANT -1/4 BAG4RT=0.200 C OPTION FOR ENTROPY CALCULATION: C IOPENT=0: ZERO ENTROPY C IOPENT=1: OSCILLATOR MODEL (0 FOR K.LE.UENTRO) C IOPENT=2: FERMI GAS WITH CONST VOLUME (0 FOR K.LE.UENTRO) C IOPENT=3: FERMI GAS WITH CONST DENSITY (0 FOR K.LE.UENTRO) C IOPENT=4: FERMI GAS WITH CONST VOLUME - NEW (0 FOR K.LE.UENTRO) C IOPENT=5: RESONANCE GAS (HAGEDORN) (0 FOR U.LE.UENTRO) IOPENT=5 UENTRO=4.0 KENTRO=100000 C DECAY TIME (COMOVING FRAME): TAUNLL=1.0 C OSCILLATOR QUANTUM OMEGA=0.500 C PRESENTLY NOT USED C ------------------ C CLUSTER DECAY INITIALIZATIONS C ----------------------------- C AVERAGE HADRON MASSES, TWO LOWEST MULTIPLETS (IF POSSIBLE): C N/DELTA,LAMBDA/SIGMA,XI,OMEGA,PI/RHO,KAON,DELTA: ASUHAX(1)=1.134 ASUHAX(2)=1.301 ASUHAX(3)=1.461 ASUHAX(4)=1.673 ASUHAX(5)=0.6125 ASUHAX(6)=0.7915 ASUHAX(7)=1.2320 C LOWEST MASSES: ASUHAY(1)=0.940 ASUHAY(2)=1.200 ASUHAY(3)=1.322 ASUHAY(4)=1.673 ASUHAY(5)=0.1400 ASUHAY(6)=0.4977 ASUHAY(7)=1.2320 C TECHNICAL PARAMETERS C -------------------- C DELTA_ZETA FOR /C4PTL/...WEIPTL() DLZETA=0.5 C MIN TAU FOR SPACE-TIME EVOLUTION: TAUMIN=0. C MAX TAU FOR SPACE-TIME EVOLUTION TAUMAX=10.0 C TAU STEPS FOR SPACE-TIME EVOTUTION (46+40) NUMTAU=51 C RANGE FOR PT DISTRIBUTION PTMX=6.0 C RANGE FOR GAUSS DISTRIBUTION GAUMX=8.0 C PARAMETER DETERMINING RANGE FOR DENSITY DISTRIBUTION FCTRMX=10.0 C TRY-AGAIN PARAMETER NTRYMX=10 C MAX TIME FOR JPSI EVOLUTION TAUMX=20.0 C TIME STEPS FOR JPSI EVOLUTION NSTTAU=100 C OPTIONS C ------- C OPTION FOR MINIMUM ENERGY IN SJCGAM: C IOPENU = 1 : SUM OF HADRON MASSES C IOPENU = 2 : BAG MODEL CURVE WITH MINIMUM AT NONZERO STRANGEN. IOPENU=1 C PARAMETER THETA IN BERGER/JAFFE MASS FORMULA THEMAS=0.51225 C SEA PROBABILITY (IF .LT. 0. THEN CALCULATED FROM STRUCTURE FNCTS) PROSEA=-1.0 C INELASTIC PP CROSS-SECTION (FM**2) C (IF NEGATIVE: CALCULATED FROM GRIBOV-REGGE-THEORY): CDH SIGPPI=-1.0 C MULTISTRING PARAMETER (Q1+Q2*LN(E)+Q3*LN(E)**2, E=SQRT(S)): C (NOT USED IF RACPRO IS CALLED WITH 'GRI'-OPTION (DEFAULT)) QMUST1=0.50 QMUST2=0. QMUST3=0. C ENTRO() CALCULATED (1) OR FROM DATA (2) IENTRO=2 C DUAL PARTON MODEL (1) OR NOT (ELSE) IDPM=0 C ANTIQUARK COLOR EXCHANGE (1) OR NOT (0): IAQU=1 C MINIMUM NUMBER OF VALENCE QUARKS: NEQMN=-5 C MAXIMUM NUMBER OF VALENCE QUARKS: NEQMX=5 C UPPER LIMIT FOR RAPIDITY INTERVAL FOR INTERMITTENCY ANALYSIS YMXIMI=2.0 C CLEAN /CPTL/ IF NCLEAN > 0 (EVERY NCLEAN_TH TIME STEP) NCLEAN=0 C TRAFO FROM PP-CM INTO LAB-SYSTEM (1) OR NOT (.NE.1) LABSYS=1 C MAXIMUM NUMBER OF COLLISIONS: NCOLMX=1000 C MAXIMUM RESONANCE SPIN (SPIN IN A GENARAL SENSE: MOD(/ID/,10)) MAXRES=99999 C MOMENTUM RESCALING (1=YES): IRESCL=1 C NUE ENERGY ELEPTI=43.00 C MUE ENERGY ELEPTO=26.24 C MUE ANGLE ANGMUE=3.9645/180.*3.1415926 C JPSI TO BE PRODUCED (1) OR NOT (0): JPSI=0 C JPSI FINAL STATE INTERACTION (1) OR NOT (0): JPSIFI=0 C COLLISION TRIGGER (ONLY COLL BETWEEN KO1 AND KO2 ARE USED): KO1KO2=00009999 C PRINT OPTION: C ISH=14: CALL UTTIMA C ISH=15: PRINTS PTLS READ FROM DATA FILE IN SR VEANLY C ISH=16: PRINTS SEA PROB. C ISH=17: PRINTS RANDOM NUMBERS C ISH=18: SR JCLUDE, NO-PHASE-SPACE CLUSTERS C ISH=19: SR AINITL, CALL SMASSP C ISH=20: SR VEANLY, PRINTS EVT NR IF EVT IS ACCEPTED C ISH=21: CREATES HISTOGRAM FOR SEA DISTRIBUTION C ISH=22: SR JFRADE, MSG AFTER CALL UTCLEA C ISH=23: CALL JINTFP C ISH=24: CALL JINTCL C ISH=25: CALL JCHPRT C ISH=90,91,92,93,94,95: MORE AND MORE DETAILED MESSAGES. IF ( DEBUG ) THEN ISH = ISH00 ELSE ISH = 0 ENDIF C PRINT OPTION: C ISHSUB=IJMN, IJ SPECIFIES LOCATION WHERE ISH=MN. C IJ=01: SR JCLUDE C IJ=02: SR JETGEN C IJ=03: SR JFRADE, STARTING BEFORE FRAGMENTATION C IJ=04: SR JDECAY C IJ=05: SR JDECAX C IJ=06: SR NUCOLL C IJ=07: SR NUCOGE+- C IJ=08: SR ASTORE C IJ=09: SR JFRADE, STARTING AFTER FRAGMENTATION C IJ=10: SR JFRADE, STARTING BEFORE DECAY C IJ=11: SR JFRADE, STARTING AFTER INTERACTIONS C IJ=12: SR JCENTR, ENTRO() IN DATA FORMAT C IJ=13: SR JCENTP C IJ=14: SR JDECAX IF CLUSTER DECAY C IJ=15: SR JSPLIT C IJ=16: SR JFRADE C IJ=17: SR RACPRO C IJ=18: SR UTCLEA C IJ=19: SR JINTA1, JINTA2, AFTER CALL UTCLEA C IJ=20: SR JDECAS C IJ=21: SR JDECAS (WITHOUT JDECAX) ISHSUB=0 C PRINT OPTION: C IF ISHEVT.NE.0: FOR EVT#.NE.ISHEVT ISH IS SET TO 0 ISHEVT=0 C PRINT MARKS BETWEEN WHOM ISH IS SET TO ISH(INIT): IPAGI=0 C VERIFY OPTION FOR INPUT READING: IVI=1 C MAXIMUM IMPACT PARAMETER (BMAXIM=0=>CENTRAL): BMAXIM=10000. C MINIMUM IMPACT PARAMETER: BMINIM=0. C STORE ONLY STABLE PTL (0) OR ALSO PARENTS (1): ISTMAX=0 C RANDOM GENERATOR SEED SEEDI=ISEED(1,1) SEEDC=ISEED(2,1)+1.D9*ISEED(3,1) C SUPPRESSION (1) OR NOT OF MESSAGES ISUP=0 C SUPPRESSION OF CALLING JFRADE (0). JFRADE=FRAGM+DECAY+RESCATTERING IFRADE=1 C.. DECAY SUPPRESSION. NDECAY SPECIFIES WHICH RESONANCES ARE NOT DECAY C.. 0000001 : ALL RESONANCES C.. 0000010 : K_SHORT/LONG (+-20) C.. 0000100 : LAMBDA (+-2130) C.. 0001000 : SIGMA (+-1130,+-2230) C.. 0010000 : CASCADE (+-2330,+-1330) C.. 0100000 : OMEGA (+-3331) C.. 1000000 : PI0 (110) NDECAY=1111110 C.. DECAY SUPPRESSION. NDECAX SPECIFIES WHICH RESONANCES ARE NOT DECAY C.. 0000001 : JPSI C.. 0000010 : K_ZERO (+-230) C.. 0000100 : DELTA (+-1111,+-1121,+-1221,+-2221) C.. 0001000 : RHO,OMEGA,PHI (111,+-121,221,331) C.. 0010000 : ETA (220) C.. 0100000 : ETAPRIME (330) C.. 1000000 : A0 (112), A+- (+-122) NDECAX=0010000 C.. DECAY SUPPRESSION. NDECAW SPECIFIES WHICH RESONANCES ARE NOT DECAY C.. 0000001 : F0 (332) C.. 0000010 : K* (+-131,+-231) NDECAW=0 C FILL ZZZZ HISTOGRAMS (1) OR NOT (0) C IWZZZZ=0 C FILL INTERMITTENCY HISTOGRAMS (1) OR NOT (0) C IMIHIS=0 C FILL SPACE-TIME HISTOGRAMS (1) OR NOT (0) ISPHIS=0 C FILL CLUSTER HISTOGRAMS (1) OR NOT (0) C ICLHIS=0 C FILL JPSI HISTOGRAMS (1) OR NOT (0) C IJPHIS=0 C RHO/RHO+PHI RATIO RHOPHI=0.5 C WSPA: ALL PTLS (1) OR ONLY INTERACTING PTLS (ELSE) ISPALL=1 C TMIN IN WSPA WTMINI=-3.0 C T-STEP IN WSPA WTSTEP=1.0 C ONLY CENTRAL POINT (1) OR LONGITUDINAL DISTRIBUTION (ELSE) IN WSPA IWCENT=0 C QUARK MASSES SMAS=0. UUMAS=0. USMAS=0. SSMAS=0. C CONSTANTS (PROTON MASS, PION MASS, PI, INFINITE) C --------- C PROM=0.94 PROM=PAMA(14) C PIOM=0.14 PIOM=PAMA(8) PI=3.141592654 AINFIN=1.E+30 C INITIALIZATIONS C --------------- LAPROJ = 0 MAPROJ = 0 LATARG = 0 MAPROJ = 0 IDPROJ = 1120 IDTARG = 1120 DO 6 I = 1,99 PROB(I) = 0. ICBAC(I,1) = 0 ICBAC(I,2) = 0 ICFOR(I,1) = 0 ICFOR(I,2) = 0 6 CONTINUE PNLL = 0. C FEW INITIALIZATIONS FOR CROSS-SECTION CALCULATIONS C -------------------------------------------------- IMSG=0 JERR=0 NTEVT=0 NREVT=0 NAEVT=0 NRSTR=0 NRPTL=0 INOIAC=0 ILAMAS=0 NPTLU=0 DO 44 ITAU = 1,MXTAU VOLSUM(ITAU)=0. VO2SUM(ITAU)=0. NCLSUM(ITAU)=0 44 CONTINUE DO 43 IEPS = 1,MXEPS DO 43 IVOL = 1,MXVOL DO 43 ITAU = 1,MXTAU CLUST(ITAU,IVOL,IEPS) = 0. 43 CONTINUE IUTOTC=0 IUTOTE=0 IF ( NPARAM .GT. 0 ) THEN DO 3 N = 1,NPARAM CALL UTLOW6(PARCHA(N)) IF ( DEBUG ) WRITE(MDEBUG,*) PARCHA(N),PARVAL(N) IF ( PARCHA(N) .EQ. 'AMPRIF' ) THEN AMPRIF = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'AMSIAC' ) THEN AMSIAC = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'AMUSEG' ) THEN AMUSEG = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'ANGMUE' ) THEN ANGMUE = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'BAG4RT' ) THEN BAG4RT = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'BMAXIM' ) THEN BMAXIM = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'BMINIM' ) THEN BMINIM = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'CORE ' ) THEN CORE = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'CORLEN' ) THEN CORLEN = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'CUTMSQ' ) THEN CUTMSQ = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'CUTMSS' ) THEN CUTMSS = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'DELEPS' ) THEN DELEPS = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'DELMSS' ) THEN DELMSS = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'DELREM' ) THEN DELREM = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'DELVOL' ) THEN DELVOL = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'ELEPTI' ) THEN ELEPTI = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'ELEPTO' ) THEN ELEPTO = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'EPSCRI' ) THEN EPSCRI = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'FCTRMX' ) THEN FCTRMX = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'GAUMX ' ) THEN GAUMX = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'GRICEL' ) THEN GRICEL = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'GRIDEL' ) THEN GRIDEL = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'GRIGAM' ) THEN GRIGAM = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'GRIRSQ' ) THEN GRIRSQ = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'GRISLO' ) THEN GRISLO = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'IAQU ' ) THEN IAQU = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'ICLHIS' ) THEN ICLHIS = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'IDPM ' ) THEN IDPM = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'IENTRO' ) THEN IENTRO = NINT(PARVAL(N)) ELSEIF ( PARCHA(N) .EQ. 'IFRADE' ) THEN IFRADE = NINT(PARVAL(N)) ELSEIF ( PARCHA(N) .EQ. 'IJPHIS' ) THEN IJPHIS = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'IMIHIS' ) THEN IMIHIS = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'IOJINT' ) THEN IOJINT = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'IOPBRK' ) THEN IOPBRK = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'IOPENT' ) THEN IOPENT = PARVAL(N) IOPENT = MOD(IOPENT,10) ELSEIF ( PARCHA(N) .EQ. 'IOPENU' ) THEN IOPENU = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'IOPTF ' ) THEN IOPTF = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'IOPTQ ' ) THEN IOPTQ = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'IPAGI ' ) THEN IPAGI = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'IRESCL' ) THEN IRESCL = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'ISH ' ) THEN ISH = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'ISHEVT' ) THEN ISHEVT = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'ISHSUB' ) THEN ISHSUB = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'ISPALL' ) THEN ISPALL = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'ISPHIS' ) THEN ISPHIS = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'ISTMAX' ) THEN ISTMAX = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'ISUP ' ) THEN ISUP = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'IVERSN' ) THEN IVERSN = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'IVI ' ) THEN IVI = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'IWCENT' ) THEN IWCENT = NINT(PARVAL(N)) ELSEIF ( PARCHA(N) .EQ. 'IWZZZZ' ) THEN IWZZZZ = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'JPSI ' ) THEN JPSI = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'JPSIFI' ) THEN JPSIFI = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'KENTRO' ) THEN KENTRO = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'KO1KO2' ) THEN KO1KO2 = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'KUTDIQ' ) THEN KUTDIQ = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'LABSYS' ) THEN LABSYS = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'MAXRES' ) THEN MAXRES = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'NCLEAN' ) THEN NCLEAN = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'NCOLMX' ) THEN NCOLMX = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'NDECAW' ) THEN NDECAW = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'NDECAX' ) THEN NDECAX = NINT(PARVAL(N)) ELSEIF ( PARCHA(N) .EQ. 'NDECAY' ) THEN NDECAY = NINT(PARVAL(N)) ELSEIF ( PARCHA(N) .EQ. 'NEQMN ' ) THEN NEQMN = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'NEQMX ' ) THEN NEQMX = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'NSTTAU' ) THEN NSTTAU = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'NTRYMX' ) THEN NTRYMX = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'NUMTAU' ) THEN NUMTAU = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'OVERLP' ) THEN OVERLP = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'PAREA ' ) THEN PAREA = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'PDIQUA' ) THEN PDIQUA = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'PISPN ' ) THEN PISPN = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'PROSEA' ) THEN PROSEA = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'PSPINH' ) THEN PSPINH = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'PSPINL' ) THEN PSPINL = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'PTF ' ) THEN PTF = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'PTH ' ) THEN PTH = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'PHARD ' ) THEN PHARD = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'PTMX ' ) THEN PTMX = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'PTQ1 ' ) THEN PTQ1 = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'PTQ2 ' ) THEN PTQ2 = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'PTQ3 ' ) THEN PTQ3 = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'PUD ' ) THEN PUD = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'PVALEN' ) THEN PVALEN = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'QMUST ' ) THEN CALL UTSTOP('VENINI: *** QMUST NOT USED ANYMORE! *** ') ELSEIF ( PARCHA(N) .EQ. 'QMUST1' ) THEN QMUST1 = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'QMUST2' ) THEN QMUST2 = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'QMUST3' ) THEN QMUST3 = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'RADIAC' ) THEN RADIAC = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'RADIAS' ) THEN RADIAS = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'RHOPHI' ) THEN RHOPHI = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'RSTRAS' ) THEN RSTRAS = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'SEEDI ' ) THEN SEEDI = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'SIGJ ' ) THEN SIGJ = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'SIGPPI' ) THEN SIGPPI = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'SMAS ' ) THEN SMAS = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'SSMAS ' ) THEN SSMAS = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'TAUMAX' ) THEN TAUMAX = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'TAUMIN' ) THEN TAUMIN = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'TAUMX ' ) THEN TAUMX = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'TAUNLL' ) THEN TAUNLL = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'TAUREA' ) THEN TAUREA = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'TENSN ' ) THEN TENSN = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'THEMAS' ) THEN THEMAS = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'UENTRO' ) THEN UENTRO = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'USMAS ' ) THEN USMAS = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'UUMAS ' ) THEN UUMAS = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'WPROJ ' ) THEN WPROJ = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'WTARG ' ) THEN WTARG = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'WTMINI' ) THEN WTMINI = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'WTSTEP' ) THEN WTSTEP = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'YMXIMI' ) THEN YMXIMI = PARVAL(N) ENDIF 3 CONTINUE ENDIF IF ( ISPHIS .EQ. 1 ) LABSYS = 0 IF ( IDPM .EQ. 1 ) THEN IAQU = 0 NEQMN = 2 NEQMX = 3 ENDIF IF ( IOPENU .EQ. 2 ) THEN CALL SMASSI(THEMAS) IF ( ISH .EQ. 19 ) THEN CALL SMASSP CALL UTSTOP(' VENINI: ') ENDIF ENDIF IF ( IOJINT .EQ. 2 ) THEN IF ( EPSCRI .LT. 0. ) THEN RADIAC = 0. RADIAS = 0. ELSEIF ( EPSCRI .GT. 0. ) THEN VOLBAR = PROM/EPSBAR*PI*0.25 CDH RADIAC = (VOLBAR*0.5/PI)**0.3333333 VOLMES = 0.455/EPSCRI*PI*0.25 CDH RADIAS = (VOLMES*0.5/PI)**0.3333333 ELSE CALL UTSTOP('EPSCRI MUST NOT BE 0. ') ENDIF ENDIF CALL JDECIN(.FALSE.) C INITIALIZE ALL PT DISTRIBUTIONS CX = PTMX QUAMA = 0. IF ( IOPTF .EQ. 1 ) THEN ROOT = SQRT(PTMX**2+QUAMA**2) AUXIL = 2./PTF BPTFU = (+0.25)*PTF**2*EXP((-AUXIL)*QUAMA)*(AUXIL*QUAMA+1.) FPTFU = (-0.25)*PTF**2*EXP((-AUXIL)*ROOT)*(AUXIL*ROOT+1.)+BPTFU CALL UTQUAF(SPTF,NPTF,XPTF,QPTFU,0.,.33*CX,.66*CX,CX) C DO 199 N = 1,NPTF C WRITE(IFCH,*) 'N,X,Q=',N,XPTF(N),QPTFU(N) C199 CONTINUE ELSE AUXIL = 0.25*PI/PTF**2 BPTFU = (+EXP((-AUXIL)* QUAMA**2))*0.5/AUXIL FPTFU = (-EXP((-AUXIL)*(QUAMA**2+PTMX**2)))*0.5/AUXIL+BPTFU ENDIF QUAMA = SMAS IF ( QUAMA .NE. 0. ) THEN IF ( IOPTF .EQ. 1 ) THEN ROOT = SQRT(PTMX**2+SMAS**2) AUXIL = 2./PTF BPTFS = (+0.25)*PTF**2*EXP((-AUXIL)*SMAS)*(AUXIL*SMAS+1.) FPTFS = (-0.25)*PTF**2*EXP((-AUXIL)*ROOT)*(AUXIL*ROOT+1.)+ * BPTFS CALL UTQUAF(SPTF,NPTF,XPTF,QPTFS,0.,.33*CX,.66*CX,CX) ELSE AUXIL = 0.25*PI/PTF**2 BPTFS = (+EXP((-AUXIL)* SMAS**2))*0.5/AUXIL FPTFS = (-EXP((-AUXIL)*(SMAS**2+PTMX**2)))*0.5/AUXIL+BPTFS ENDIF ELSE DO 201 N = 1,NPTF QPTFS(N) = QPTFU(N) 201 CONTINUE FPTFS = FPTFU ENDIF QUAMA = UUMAS IF ( QUAMA .NE. 0. ) THEN IF ( IOPTF .EQ. 1 ) THEN ROOT = SQRT(PTMX**2+UUMAS**2) AUXIL = 2./PTF BPTFUU = (+0.25)*PTF**2*EXP((-AUXIL)*UUMAS)*(AUXIL*UUMAS+1.) FPTFUU = (-0.25)*PTF**2*EXP((-AUXIL)*ROOT)*(AUXIL*ROOT+1.)+ * BPTFUU CALL UTQUAF(SPTF,NPTF,XPTF,QPTFUU,0.,.33*CX,.66*CX,CX) ELSE AUXIL = 0.25*PI/PTF**2 BPTFUU = EXP((-AUXIL)* UUMAS**2)*0.5/AUXIL FPTFUU = (-EXP((-AUXIL)*(UUMAS**2+PTMX**2)))*0.5/AUXIL+BPTFUU ENDIF ELSE DO 202 N = 1,NPTF QPTFUU(N) = QPTFU(N) 202 CONTINUE FPTFUU = FPTFU ENDIF QUAMA = USMAS IF ( QUAMA .NE. 0. ) THEN IF ( IOPTF .EQ. 1 ) THEN ROOT = SQRT(PTMX**2+USMAS**2) AUXIL = 2./PTF BPTFUS = 0.25*PTF**2*EXP((-AUXIL)*USMAS)*(AUXIL*USMAS+1.) FPTFUS = (-0.25)*PTF**2*EXP((-AUXIL)*ROOT)*(AUXIL*ROOT+1.)+ * BPTFUS CALL UTQUAF(SPTF,NPTF,XPTF,QPTFUS,0.,.33*CX,.66*CX,CX) ELSE AUXIL = 0.25*PI/PTF**2 BPTFUS = EXP((-AUXIL)* USMAS**2)*0.5/AUXIL FPTFUS = (-EXP((-AUXIL)*(USMAS**2+PTMX**2)))*0.5/AUXIL+BPTFUS ENDIF ELSE DO 203 N = 1,NPTF QPTFUS(N) = QPTFU(N) 203 CONTINUE FPTFUS = FPTFU ENDIF QUAMA = SSMAS IF ( QUAMA .NE. 0. ) THEN IF ( IOPTF .EQ. 1 ) THEN ROOT = SQRT(PTMX**2+SSMAS**2) AUXIL = 2./PTF BPTFSS = (+0.25)*PTF**2*EXP((-AUXIL)*SSMAS)*(AUXIL*SSMAS+1.) FPTFSS = (-0.25)*PTF**2*EXP((-AUXIL)*ROOT)*(AUXIL*ROOT+1.)+ * BPTFSS CALL UTQUAF(SPTF,NPTF,XPTF,QPTFSS,0.,.33*CX,.66*CX,CX) ELSE AUXIL = 0.25*PI/PTF**2 BPTFSS = EXP((-AUXIL)* SSMAS**2)*0.5/AUXIL FPTFSS =(-EXP((-AUXIL)*(SSMAS**2+PTMX**2)))*0.5/AUXIL+BPTFSS ENDIF ELSE DO 204 N = 1,NPTF QPTFSS(N) = QPTFU(N) 204 CONTINUE FPTFSS = FPTFU ENDIF C INITIALIZE FUNCTIONS FOR JPSI GENERATION IF ( JPSI .EQ. 1 ) THEN CX = GAUMX CALL UTQUAF(SGAU,NGAU,XGAU,QGAU,0.,.33*CX,.66*CX,CX) CX = PTMX CALL UTQUAF(SPTJ,NPTJ,XPTJ,QPTJ,0.,.33*CX,.66*CX,CX) ENDIF C INITIALIZE DENSITY DISTRIBUTION INTEGRALS FOR NITROGEN, OXYGEN, ARGON MASSNR = 14. R0 = 1.19*MASSNR**(.3333333) -1.61*MASSNR**(-.3333333) CX = R0+FCTRMX*0.54 RMTARG(1) = CX CALL UTQUAF(SDENSI,NDET,XDET14,QDET14,0.,.33*CX,.66*CX,CX) MASSNR = 16. R0 = 1.19*MASSNR**(.3333333) -1.61*MASSNR**(-.3333333) CX = R0+FCTRMX*0.54 RMTARG(2) = CX CALL UTQUAF(SDENSI,NDET,XDET16,QDET16,0.,.33*CX,.66*CX,CX) MASSNR = 40. R0 = 1.19*MASSNR**(.3333333) -1.61*MASSNR**(-.3333333) CX = R0+FCTRMX*0.54 RMTARG(3) = CX CALL UTQUAF(SDENSI,NDET,XDET40,QDET40,0.,.33*CX,.66*CX,CX) C QDET99 AND XDET99 ARE NOT INITIALIZED MTAR99 = 0 OPEN(UNIT=14,FILE='VENUSDAT',STATUS='OLD') READ(14,*)(IDUMMY, XVA(I), QVAH(I), QVAPI(I), I=1,2049) CLOSE(UNIT=14) WRITE(IFMT,105) FLOAT(IVERSN)/1000. 105 FORMAT( * ' !-----------------------------------------------------!' */' ! V(ERY) E(NERGETIC) NU(CLEAR) S(CATTERING) !' */' ! VENUS',F6.3,5X,'- K. WERNER !' */' ! SUBROUTINE TURBOVERSION D. HECK !' */' !-----------------------------------------------------!') RETURN END *CMZ : 28/02/2002 12.36.15 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE VENLNK C----------------------------------------------------------------------- C VEN(US) L(I)NK (TO CORSIKA) C C LINKS VENUS PACKAGE TO CORSIKA, NEEDS FIRST CALL OF VENINI C THIS SUBROUTINE IS CALLED FROM SDPM. C C DESIGN : D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- *KEEP,INTER. COMMON /INTER/ AVCH,AVCH3,DC0,DLOG,DMLOG,ECMDIF,ECMDPM,ELAB, * FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3, * RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG, * WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN, * IDIF,ITAR DOUBLE PRECISION AVCH,AVCH3,DC0,DLOG,DMLOG,ECMDIF,ECMDPM,ELAB, * FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3, * RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG, * WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN INTEGER IDIF,ITAR *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,REST. COMMON /REST/ CONTNE,TAR,LT DOUBLE PRECISION CONTNE(3),TAR INTEGER LT *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,VENUS. COMMON /VENUS/ ISH00,IVERVN,MTAR99,FVENUS,FVENSG INTEGER ISH00,IVERVN,MTAR99 LOGICAL FVENUS,FVENSG *KEND. PARAMETER (KOLLMX=2500) PARAMETER (MXEPS=10) PARAMETER (NDEP=129) PARAMETER (NDET=129) PARAMETER (NPRBMS=20) PARAMETER (NPTQ=129) PARAMETER (NSTRU=2049) COMMON /ACCUM/ AMSAC,ILAMAS,IMSG,INOIAC,IPAGE,JERR,NAEVT,NREVT * ,NRPTL,NRSTR,NTEVT COMMON /CDEN/ MASSNR,RMX,R0 COMMON /CIPIO/ IPIO COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /COL/ BIMP,BMAX,COORD(4,KOLLMX),DISTCE(KOLLMX) * ,QDEP(NDEP),QDET14(NDET),QDET16(NDET),QDET40(NDET) * ,QDET99(NDET),RMPROJ,RMTARG(4),XDEP(NDEP) * ,XDET14(NDET),XDET16(NDET),XDET40(NDET) * ,XDET99(NDET) * ,KOLL,LTARG,NORD(KOLLMX),NPROJ,NRPROJ(KOLLMX) * ,NRTARG(KOLLMX),NTARG COMMON /CPRBMS/ PRBMS(NPRBMS) COMMON /CPTQ/ QPTH(NPTQ),QPTQ(NPTQ),XPTQ(NPTQ),QPTQMX,QPTHMX DOUBLE PRECISION SEEDC,SEEDI COMMON /CSEED/ SEEDC,SEEDI COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /NEVNT/ NEVNT COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT COMMON /PARO3/ ASUHAX(7),ASUHAY(7),OMEGA,SIGPPD,SIGPPE,UENTRO * ,IWZZZZ COMMON /PARO4/ GRICEL,GRIDEL,GRIGAM,GRIRSQ,GRISLO COMMON /PARO5/ DELEPS,DELVOL COMMON /QUARKM/ SMAS,SSMAS,USMAS,UUMAS COMMON /STRU/ QSEP(NSTRU),QSET(NSTRU),QVAP(NSTRU) * ,QVAT(NSTRU),XCUTAR,XSTRU(NSTRU) * ,IDTG COMMON /STRU2/ DELTA0,DELTA1,QSEH(NSTRU),QSEPI(NSTRU) * ,QVAH(NSTRU),QVAPI(NSTRU),XSE(NSTRU),XVA(NSTRU) DOUBLE PRECISION ERRER,VALUE INTEGER IFLAG COMMON /VENLIN/ PTQ1,PTQ2,PTQ3,QMUST1,QMUST2,QMUST3 * ,IDTABL(100) SAVE EXTERNAL SDENSI,SPTQ,SSE0,SVA0,SVA1 C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'VENLNK: TAR',SNGL(TAR) NSTRUC = NSTRU IF ( DEBUG ) THEN ISH = ISH00 ELSE ISH = 0 ENDIF NEVNT = ISHOWNO C SET RANDOM NUMBER GENERATOR STATUS SEEDC=ISEED(2,1)+1.D9*ISEED(3,1) C CALCULATE ENERGY IN LAB SYSTEM FOR ELASTICITY FOR VARIOUS PROJECTILES IF ( ITYPE .EQ. 1 ) THEN C TREAT PHOTON PROJECTILES (FROM EGS) CALL RMMAR(RD,1,1) IF ( RD(1) .LE. 0.5 ) THEN ITYPE = 7 ELSE ITYPE = 17 ENDIF ELAB = CURPAR(2) CURPAR(2) = ELAB / PAMA(ITYPE) ELSEIF ( ITYPE .LT. 100 ) THEN C TREAT ORDINARY PROJECTILES ELAB = CURPAR(2) * PAMA(ITYPE) ELSE C TREAT NUCLEI PROJECTILES NPROT = MOD(ITYPE,100) NNEUT = ITYPE/100 - NPROT ELAB = CURPAR(2) * ( PAMA(14)*NPROT + PAMA(13)*NNEUT ) ENDIF C SET TARGET PARAMETERS MATARG = NINT(TAR) IDTARG = 1120 AMTARG = PAMA(14) IF ( TAR. EQ. 14.D0 ) THEN LTARG = 1 LATARG = 7 ELSEIF ( TAR .EQ. 16.D0 ) THEN LTARG = 2 LATARG = 8 ELSEIF ( TAR .EQ. 40.D0 ) THEN LTARG = 3 LATARG = 18 ELSE WRITE(MONIOU,*) 'VENLNK: UNDEFINED TARGET TAR=',SNGL(TAR) ENDIF C FOR THE CASE OF AN ARBITRARY TARGET (NOT AIR) IF ( LTARG .GT. 3 ) THEN MASSNR = MATARG IF ( MASSNR .GT. 1 ) THEN IF ( MASSNR .NE. MTAR99 ) THEN R0 = 1.19*MASSNR**(.3333333) -1.61*MASSNR**(-.3333333) CX = R0+FCTRMX*0.54 RMTARG(4) = CX CALL UTQUAF(SDENSI,NDET,XDET99,QDET99,0.,.33*CX,.66*CX,CX) MTAR99 = MATARG ENDIF ELSE RMTARG(4) = 0. ENDIF ENDIF C SET PROJECTILE PARAMETERS IF ( ITYPE .LT. 100 ) THEN IDPROJ = IDTABL(ITYPE) IF ( IDPROJ .EQ. 20 .OR. IDPROJ .EQ. -20 ) THEN C TREAT NEUTRAL KAONS (K(0)S AND K(0)L) CALL RMMAR(RD,1,1) IF ( RD(1) .LE. 0.5 ) THEN IDPROJ = 230 ELSE IDPROJ = -230 ENDIF ELSEIF ( IDPROJ .EQ. 2130 ) THEN C VENUS CANNOT TREAT LAMBDA, TAKE INSTEAD SIGMA(0)) IDPROJ = 1230 ELSEIF ( IDPROJ .EQ. -2130 ) THEN C VENUS CANNOT TREAT ANTI-LAMBDA, TAKE INSTEAD ANTI-SIGMA(0)) IDPROJ = -1230 ENDIF C ALL OTHER PARTICLE CODES UNCHANGED CALL IDMASS(IDPROJ,AMPROJ) LAPROJ = -1 MAPROJ = 1 PNLL = CURPAR(2)*AMPROJ ELSE C PROJECTILE IS NUCLEUS IDPROJ = 1120 CALL IDMASS(IDPROJ,AMPROJ) LAPROJ = MOD(ITYPE,100) MAPROJ = ITYPE/100 PNLL = CURPAR(2)*(PAMA(14)+PAMA(13))*0.5 ENDIF IF ( ABS(IDPROJ) .LT. 1000 ) THEN IF ( ABS(IDPROJ) .EQ. 230 .OR. ABS(IDPROJ) .EQ. 130 ) THEN C DIFFRACTIVE PROBABILITY FOR KAON PROJECTILES WPROJ = 0.24 ELSE C DIFFRACTIVE PROBABILITY FOR PION PROJECTILES WPROJ = 0.20 ENDIF ELSE C DIFFRACTIVE PROBABILITY FOR BARYON PROJECTILES WPROJ = 0.32 ENDIF C DIFFRACTIVE PROBABILITY FOR TARGET (ALWAYS NUCLEONS) WTARG = 0.32 ENGY = SQRT( 2.*SQRT(PNLL**2+AMPROJ**2)*AMTARG+AMTARG**2 * +AMPROJ**2 ) IF ( DEBUG ) WRITE(MDEBUG,*) 'VENLNK: ELAB = ',PNLL, * ' ENGY = ',ENGY CDH IF ( ENGY .LT. 12. ) THEN IF ( ENGY .LT. 9.5 ) THEN WRITE(IFMT,*) 'VENLNK: ENGY, IDPROJ=',ENGY,IDPROJ CALL UTSTOP('VENLNK: INCIDENT ENERGY TOO SMALL ') ENDIF ENGYI = ENGY PNLLI = PNLL IF ( PNLL .LT. 1.E2 * AMPROJ ) THEN TRM = SQRT(PNLL**2+AMPROJ**2) ENGY = SQRT((TRM+AMTARG-PNLL)*(TRM+AMTARG+PNLL)) ELSE TRM = AMPROJ**2*0.5/PNLL+AMTARG ENGY = SQRT(TRM*(2.*PNLL+TRM)) ENDIF D1 = ABS(PNLLI-PNLL)/PNLL D2 = ABS(ENGYI-ENGY)/ENGY IF ( D1 .GT. 1.E-3 .OR. D2 .GT. 1.E-3 ) THEN IF ( ISH .GE. 0 ) THEN CALL UTMSG('VENLNK') WRITE(IFCH,*) '***** PNLL,PNLLI:',PNLL,PNLLI WRITE(IFCH,*) '***** ENGY,ENGYI:',ENGY,ENGYI CALL UTMSGF ENDIF ENDIF S = ENGY**2 SROOTI = 1./ENGY PNLLX = UTPCM(ENGY,AMPROJ,AMTARG) YHAHA = LOG((SQRT(PNLL**2+S)+PNLL)/ENGY) YPJTL = LOG((SQRT(PNLL**2+AMPROJ**2)+PNLL)/AMPROJ) IF ( ISH .GE. 91 ) WRITE(IFCH,*) 'VENLNK: YPJTL=',YPJTL ENGYLG = LOG(ENGY) QMUST = QMUST1+QMUST2*ENGYLG+QMUST3*ENGYLG**2 PTQ = PTQ1+PTQ2*ENGYLG+PTQ3*ENGYLG**2 CDH PHARD = 0.030+0.12*(LOG10(S)-LOG10(30.**2)) PHARD = 0.030+0.12*(LOG10(S)-2.9542425) PHARD = MIN(1.,PHARD) PHARD = MAX(0.030,PHARD) C PROJECTILE XCUT = CUTMSQ*SROOTI XCUT2 = XCUT**2 IF ( ABS(IDPROJ) .GE. 1000 ) THEN C STRUCTURE FUNCTION INTEGRAL FOR BARYONS OF PROJECTILE IPIO = 0 CALL UINTEG(VALUE,SSE0,0.D0,1.D0,0.D0,1.D-5,1,ERRER,IFLAG) IF ( IFLAG .GT. 3 .AND. ISH .GT. 0 ) * WRITE(IFCH,*) 'VENLNK: SSE0:IFLAG=',IFLAG QSEPC = VALUE CALL UINTEG(VALUE,SVA0,0.D0,1.D0,0.D0,1.D-5,1,ERRER,IFLAG) IF ( IFLAG .GT. 3 .AND. ISH .GT. 0 ) * WRITE(IFCH,*) 'VENLNK: SVA0:IFLAG=',IFLAG QVAPC = VALUE ELSE C STRUCTURE FUNCTION INTEGRAL FOR MESONS OF PROJECTILE IPIO = 1 A0 = -5.0 + 6.6666667*XCUT2 - 0.53333333*XCUT2**2 A1 = 5.0 - 1.875*XCUT2 A2 = -3.3333333 + 0.26666667*XCUT2 A3 = 1.25 A4 = -0.2 ROOT = SQRT(XCUT2+1.) QSEPC = 0.9*( (1.-XCUT2*A1)*( LOG(1.+ROOT)-LOG(XCUT) ) * - XCUT*A0 + ROOT*(A0+A1+A2+A3+A4) ) CALL UINTEG(VALUE,SVA1,0.D0,1.D0,0.D0,1.D-5,1,ERRER,IFLAG) IF ( IFLAG .GT. 3 .AND. ISH .GT. 0 ) * WRITE(IFCH,*) 'VENLNK: SVA1:IFLAG=',IFLAG QVAPC = VALUE ENDIF IDTG = IPIO C TARGET IF ( IDTG .EQ. 1 ) THEN IF ( ABS(IDTARG) .GE. 1000 ) THEN C STRUCTURE FUNCTION INTEGRAL FOR BARYONS OF TARGET IPIO = 0 CALL UINTEG(VALUE,SSE0,0.D0,1.D0,0.D0,1.D-5,1,ERRER,IFLAG) IF ( IFLAG .GT. 3 .AND. ISH .GT. 0 ) * WRITE(IFCH,*) 'VENLNK: SSE0:IFLAG=',IFLAG QSETC = VALUE CALL UINTEG(VALUE,SVA0,0.D0,1.D0,0.D0,1.D-5,1,ERRER,IFLAG) IF ( IFLAG .GT. 3 .AND. ISH .GT. 0 ) * WRITE(IFCH,*) 'VENLNK: SVA0:IFLAG=',IFLAG QVATC = VALUE ELSE IPIO=1 QVATC = QVAPC QSETC = QSEPC ENDIF ELSE IF ( ABS(IDTARG) .GE. 1000 ) THEN IPIO = 0 QVATC = QVAPC QSETC = QSEPC ELSE C STRUCTURE FUNCTION INTEGRAL FOR BARYONS OF TARGET IPIO=1 A0 = -5.0 + 6.6666667*XCUT2 - 0.53333333*XCUT2**2 A1 = 5.0 - 1.875*XCUT2 A2 = -3.3333333 + 0.26666667*XCUT2 A3 = 1.25 A4 = -0.2 ROOT = SQRT(XCUT2+1.) QSETC = 0.9*( (1.-XCUT2*A1)*( LOG(1.+ROOT)-LOG(XCUT) ) * - XCUT*A0 + ROOT*(A0+A1+A2+A3+A4) ) CALL UINTEG(VALUE,SVA1,0.D0,1.D0,0.D0,1.D-5,1,ERRER,IFLAG) IF ( IFLAG .GT. 3 .AND. ISH .GT. 0 ) * WRITE(IFCH,*) 'VENLNK: SVA1:IFLAG=',IFLAG QVATC = VALUE ENDIF ENDIF IF ( ISH .EQ. 16 .OR. DEBUG ) THEN WRITE(IFCH,301) QVAPC, QSEPC, QVATC, QSETC 301 FORMAT(' VENLNK: QVAPC, QSEPC, QVATC, QSETC=',4(F10.7,2X)) ENDIF IF ( PROSEA .GE. 0. ) THEN QVAPC = 1.0 QVATC = 1.0 QSEPC = PROSEA QSETC = PROSEA ENDIF XCUT = CUTMSS*SROOTI XCUTAR = XCUT B = MIN( 0.05, XCUT*500. ) A = MIN( 0.2*B, XCUT*100. ) PNLLLG = LOG(PNLL) DELTA0 = EXP(-2.791922 - 0.2091742 * PNLLLG) DELTA1 = EXP(-3.885293 - 0.2029558 * PNLLLG) CALL UTQSEA(A,B,1.) IF ( XCUT .LT. 0.04 ) THEN NEND=1.+REAL(NSTRUC)*2./PI*ACOS(1.-2./PI*ACOS(1.-25.*XCUT)) ELSE NEND = NSTRUC ENDIF IF ( ABS(IDPROJ) .GE. 1000 ) THEN IPIO = 0 DO 203 N = 1,NSTRUC QSEP(N) = QSEH(N) 203 CONTINUE DO 2031 N = NEND,NSTRUC QVAP(N) = QVAH(N) - DELTA0 2031 CONTINUE ELSE IPIO = 1 DO 204 N = 1,NSTRUC QSEP(N) = QSEPI(N) 204 CONTINUE DO 2041 N = NEND,NSTRUC QVAP(N) = QVAPI(N) - DELTA1 2041 CONTINUE ENDIF CALL UTQVAL(QVAP,NEND) IF ( IDTG .EQ. 0 ) THEN IF ( ABS(IDTARG) .GE. 1000 ) THEN IPIO = 0 DO 205 N = 1,NSTRUC QSET(N) = QSEP(N) QVAT(N) = QVAP(N) 205 CONTINUE ELSE IPIO = 1 DO 209 N = 1,NSTRUC QSET(N) = QSEPI(N) 209 CONTINUE DO 2091 N = NEND,NSTRUC QVAT(N) = QVAPI(N) - DELTA1 2091 CONTINUE CALL UTQVAL(QVAT,NEND) ENDIF ELSE IF ( ABS(IDTARG) .GE. 1000 ) THEN IPIO = 0 DO 210 N = 1,NSTRUC QSET(N) = QSEH(N) 210 CONTINUE DO 2101 N = NEND,NSTRUC QVAT(N) = QVAH(N) - DELTA0 2101 CONTINUE CALL UTQVAL(QVAT,NEND) ELSE IPIO = 1 DO 216 N = 1,NSTRUC QSET(N) = QSEP(N) QVAT(N) = QVAP(N) 216 CONTINUE ENDIF ENDIF IF ( ISH .EQ. 21 ) THEN CALL UTHSEA CALL UTSTOP(' VENLNK: ') ENDIF QPTHMX = 0.5/PTH**2-PTH**2/(2.*(PTH**2+PTMX**2)**2) IF ( IOPTQ .EQ. 2 ) THEN QPTQMX = 1. - EXP((-PI)*PTMX**2/(4.*PTQ**2) ) ELSEIF ( IOPTQ .EQ. 3 ) THEN QPTQMX = 1. - PTQ**2/(PTQ**2+PTMX**2) ELSE CX = PTMX CALL UTQUAF(SPTQ,NPTQ,XPTQ,QPTQ,0.,.33*CX,.66*CX,CX) ENDIF SIGPPI = -1.0 C CALCULATE ENERGY DEPENDENT CROSS-SECTION FOR BARYONS CALL RACPRO('GRI',QMUST,NPRBMS,PRBMS) IF ( ABS(IDPROJ) .LE. 120 .OR. ABS(IDPROJ) .EQ. 220 ) THEN C CROSS-SECTION FOR PIONS (OR ETA FOR PHOTONS FROM EGS) SIGPPI = SIGPPI * 0.6667 ELSEIF ( ABS(IDPROJ) .EQ. 130 .OR. ABS(IDPROJ) .EQ. 230 ) THEN C CROSS-SECTION FOR KAONS SIGPPI = SIGPPI * 0.5541 ENDIF MASSNR = MAPROJ RMPROJ = 0. IF ( MASSNR .GT. 1 ) THEN R0 = 1.19*MASSNR**(.3333333) -1.61*MASSNR**(-.3333333) CX = R0+FCTRMX*0.54 RMPROJ = CX CALL UTQUAF(SDENSI,NDEP,XDEP,QDEP,0.,.33*CX,.66*CX,CX) ENDIF IF ( IDPM .EQ. 1 ) THEN QSEPC = 0. QSETC = 0. ENDIF BMAX = RMPROJ+RMTARG(LTARG) IF ( ISH .GE. 91 ) WRITE(IFCH,*) 'VENLNK: AVENUS IS NOW CALLED' CALL AVENUS C NOW BRING PARTICLES TO CORSIKA STACK CALL VSTORE IF ( ISH .GE. 91 ) WRITE(IFCH,*) 'VENLNK: (EXIT)' RETURN END *CMZ : 11/07/2000 10.08.31 by D. HECK IK3 FZK KARLSRUHE *-- Author : D. HECK IK3 FZK KARLSRUHE 21/11/96 C======================================================================= SUBROUTINE VENSIG(ELAB,ITYPV) C----------------------------------------------------------------------- C VEN(US) SIG(MAS) C C CALCULATES INELASTIC HADRON-AIR CROSS-SECTIONS FOR VENUS MODEL C NUCLEUS-AIR CROSS-SECTIONS ARE DETERMINED BY P-P CROSS-SECTIONS AND C THE CORSIKA GLAUBER TABLES (SEE BOX2) C THIS SUBROUTINE IS CALLED FROM BOX2. C ARGUMENTS: C ELAB = LABORATORY ENERGY (IN GEV) C ITYPV = HADRON TYPE: 1 = NUCLEON, 2 = PION, 3 = KAON C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,SIGM. COMMON /SIGM/ SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO DOUBLE PRECISION SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO *KEEP,VENSSG. COMMON /VENSSG/ FRNVKL,FRNVPIL,FRNVPL,FRNOVKL,FRNOVPIL,FRNOVPL, * SGVKL,SGVPIL,SGVPL,SVPPL DOUBLE PRECISION FRNVKL(11), FRNVPIL(11), FRNVPL(11), * FRNOVKL(11),FRNOVPIL(11),FRNOVPL(11), * SGVKL(11),SGVPIL(11),SGVPL(11),SVPPL(11) *KEND. DOUBLE PRECISION DELTAE,ELAB,SECT,WK(3),YE INTEGER I,ITYPV,JE SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'VENSIG: ELAB=',SNGL(ELAB), * ' ITYPV=',ITYPV C DETERMINE ENERGY INTERVAL FOR INTERPOLATION YE = DLOG10(ELAB) IF ( YE .LT. 1.D0 ) YE = 1.D0 JE = INT(YE) IF ( JE .GT. 9 ) JE = 9 DELTAE = YE - JE WK(3) = DELTAE * (DELTAE-1.D0) * .5D0 WK(1) = 1.D0 - DELTAE + WK(3) WK(2) = DELTAE - 2.D0 * WK(3) IF ( ITYPV .EQ. 1 ) THEN C FOR BARYON PROJECTILES SECT = 0.D0 DO 16 I = 1,3 SECT = SECT + SGVPL(JE+I-1)*WK(I) 16 CONTINUE SIGAIR = EXP(SECT) SECT = 0.D0 DO 17 I = 1,3 SECT = SECT + FRNVPL(JE+I-1)*WK(I) 17 CONTINUE FRACTN = EXP(SECT) SECT = 0.D0 DO 18 I = 1,3 SECT = SECT + FRNOVPL(JE+I-1)*WK(I) 18 CONTINUE FRCTNO = EXP(SECT) SIGMA = 0.D0 ELSEIF ( ITYPV .EQ. 2 ) THEN C FOR PION PROJECTILES SECT = 0.D0 DO 26 I = 1,3 SECT = SECT + SGVPIL(JE+I-1)*WK(I) 26 CONTINUE SIGAIR = EXP(SECT) SECT = 0.D0 DO 27 I = 1,3 SECT = SECT + FRNVPIL(JE+I-1)*WK(I) 27 CONTINUE FRACTN = EXP(SECT) SECT = 0.D0 DO 28 I = 1,3 SECT = SECT + FRNOVPIL(JE+I-1)*WK(I) 28 CONTINUE FRCTNO = EXP(SECT) SIGMA = 0.D0 ELSEIF ( ITYPV .EQ. 3 ) THEN C FOR KAON PROJECTILES SECT = 0.D0 DO 36 I = 1,3 SECT = SECT + SGVKL(JE+I-1)*WK(I) 36 CONTINUE SIGAIR = EXP(SECT) SECT = 0.D0 DO 37 I = 1,3 SECT = SECT + FRNVKL(JE+I-1)*WK(I) 37 CONTINUE FRACTN = EXP(SECT) SECT = 0.D0 DO 38 I = 1,3 SECT = SECT + FRNOVKL(JE+I-1)*WK(I) 38 CONTINUE FRCTNO = EXP(SECT) SIGMA = 0.D0 ELSEIF ( ITYPV .GE. 100 ) THEN C FOR NUCLEUS PROJECTILES DETERMINE ONLY NN CROSS-SECTION SIGAIR = 0.D0 FRACTN = 0.D0 FRCTNO = 0.D0 SIGMA = 0.D0 DO 47 I = 1,3 SIGMA = SIGMA + SVPPL(JE+I-1)*WK(I) 47 CONTINUE SIGMA = EXP(SIGMA) ELSE WRITE(MONIOU,444) (CURPAR(I),I=1,9) 444 FORMAT(' VENSIG: CURPAR=',1P,9E10.3) WRITE(MONIOU,*) 'VENSIG: ILLEGAL PROJECTILE TYP =',ITYPV STOP ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'VENSIG: SIGMA=',SNGL(SIGMA), * ' SIGAIR=',SNGL(SIGAIR) RETURN END *CMZ : 11/07/2000 10.08.31 by D. HECK IK3 FZK KARLSRUHE *-- Author : D. HECK IK3 FZK KARLSRUHE 21/11/96 C======================================================================= SUBROUTINE VENSIGINI C----------------------------------------------------------------------- C VEN(US) SIG(MAS) INI(TIALIZATION) C C INITIALIZES INELASTIC CROSS-SECTION C THIS SUBROUTINE IS CALLED FROM START. C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,VENSSG. COMMON /VENSSG/ FRNVKL,FRNVPIL,FRNVPL,FRNOVKL,FRNOVPIL,FRNOVPL, * SGVKL,SGVPIL,SGVPL,SVPPL DOUBLE PRECISION FRNVKL(11), FRNVPIL(11), FRNVPL(11), * FRNOVKL(11),FRNOVPIL(11),FRNOVPL(11), * SGVKL(11),SGVPIL(11),SGVPL(11),SVPPL(11) *KEND. DOUBLE PRECISION AI,ELAB(11),FRNVK(11),FRNVPI(11),FRNVP(11), * FRNOVK(11),FRNOVPI(11),FRNOVP(11), * SIGP(11),SIGPI(11),SIGK(11), SPP(11) INTEGER I SAVE C THE CROSS-SECTION TABLES START AT ELAB=10., 100., 1000., .... C BUT AFTERWARDS IS USED ONLY ABOVE 80 GEV C PROTON AIR INELASTIC CROSS-SECTION DATA SIGP /0.241E+03, * 0.264E+03,0.287E+03,0.311E+03,0.334E+03,0.358E+03, * 0.381E+03,0.405E+03,0.429E+03,0.454E+03,0.478E+03/ C PION AIR INELASTIC CROSS-SECTION DATA SIGPI/0.182E+03, * 0.201E+03,0.222E+03,0.242E+03,0.263E+03,0.284E+03, * 0.303E+03,0.323E+03,0.346E+03,0.363E+03,0.386E+03/ C KAON AIR INELASTIC CROSS-SECTION DATA SIGK /0.157E+03, * 0.176E+03,0.195E+03,0.215E+03,0.234E+03,0.253E+03, * 0.270E+03,0.290E+03,0.311E+03,0.328E+03,0.348E+03/ C PROTON NITROGEN INELASTIC CROSS-SECTION DATA FRNVP /0.184E+03, * 0.202E+03,0.219E+03,0.239E+03,0.255E+03,0.276E+03, * 0.289E+03,0.311E+03,0.329E+03,0.349E+03,0.368E+03/ C PION NITROGEN INELASTIC CROSS-SECTION DATA FRNVPI/0.137E+03, * 0.153E+03,0.169E+03,0.185E+03,0.201E+03,0.217E+03, * 0.232E+03,0.246E+03,0.265E+03,0.278E+03,0.296E+03/ C KAON NITROGEN INELASTIC CROSS-SECTION DATA FRNVK /0.119E+03, * 0.134E+03,0.149E+03,0.164E+03,0.179E+03,0.194E+03, * 0.207E+03,0.221E+03,0.239E+03,0.251E+03,0.266E+03/ C PROTON NITROGEN+OXYGEN INELASTIC CROSS-SECTION DATA FRNOVP /0.238E+03, * 0.261E+03,0.284E+03,0.309E+03,0.331E+03,0.357E+03, * 0.375E+03,0.401E+03,0.424E+03,0.450E+03,0.474E+03/ C PION NITROGEN+OXYGEN INELASTIC CROSS-SECTION DATA FRNOVPI/0.178E+03, * 0.199E+03,0.220E+03,0.240E+03,0.261E+03,0.281E+03, * 0.300E+03,0.319E+03,0.343E+03,0.360E+03,0.382E+03/ C KAON NITROGEN+OXYGEN INELASTIC CROSS-SECTION DATA FRNOVK /0.157E+03, * 0.175E+03,0.193E+03,0.212E+03,0.232E+03,0.251E+03, * 0.268E+03,0.287E+03,0.308E+03,0.325E+03,0.345E+03/ C PROTON PROTON INELASTIC CROSS-SECTION * DATA SPP / 24.705D0, * * 28.749D0,33.001D0,37.675D0,42.785D0,48.348D0, * * 54.381D0,60.897D0,67.905D0,75.415D0,83.433D0 / C PROTON PROTON INELASTIC CROSS-SECTION (INCLUDING DIFFRACTION) C (MODIFIED APR 2ND, 1997) DATA SPP / 27.444D0, * 31.599D0,36.382D0,41.693D0,47.555D0,54.000D0, * 61.059D0,68.756D0,77.113D0,86.146D0,95.870D0 / C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'VENSIGINI: START' C FORM LOGARITH OF THE CROSS-SECTIONS FOR BETTER INTERPOLATION DO 10 I = 1,11 SGVPL(I) = LOG(SIGP(I)) SGVPIL(I) = LOG(SIGPI(I)) SGVKL(I) = LOG(SIGK(I)) FRNVKL(I) = LOG(FRNVK(I)) FRNVPIL(I) = LOG(FRNVPI(I)) FRNVPL(I) = LOG(FRNVP(I)) FRNOVKL(I) = LOG(FRNOVK(I)) FRNOVPIL(I) = LOG(FRNOVPI(I)) FRNOVPL(I) = LOG(FRNOVP(I)) SVPPL(I) = LOG(SPP(I)) 10 CONTINUE IF ( DEBUG ) THEN WRITE(MDEBUG,25) 25 FORMAT(' LOGARITHMS OF THE INELASTIC CROSS-SECTIONS (MBARN)'/ * ' ELAB(GEV) SIG(P,P) ', * 'SIG(P,AIR) SG(PI,AIR) SIG(K,AIR)') DO 30 I = 1,11 AI = FLOAT(I) ELAB(I) = 10.D0**AI WRITE(MDEBUG,26) ELAB(I),SVPPL(I), * SGVPL(I),SGVPIL(I),SGVKL(I) 26 FORMAT(1X,1P,E9.3,4(1X,E10.4)) 30 CONTINUE WRITE(MDEBUG,*) 'VENSIGINI: END' ENDIF RETURN END *CMZ : 28/02/2002 12.36.16 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE VSTORE C----------------------------------------------------------------------- C V(ENUS PARTICLES) STORE (INTO CORSIKA STACK) C C STORES VENUS OUTPUT PARTICLES INTO CORSIKA STACK C THIS SUBROUTINE IS CALLED FROM VENLNK. C C DESIGN : D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,DPMFLG. COMMON /DPMFLG/ NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM INTEGER NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM *KEEP,ELADPM. COMMON /ELADPM/ ELMEAN,ELMEAA,IELDPM,IELDPA DOUBLE PRECISION ELMEAN(40),ELMEAA(40) INTEGER IELDPM(40,13),IELDPA(40,13) *KEEP,ELASTY. COMMON /ELASTY/ ELAST DOUBLE PRECISION ELAST *KEEP,INTER. COMMON /INTER/ AVCH,AVCH3,DC0,DLOG,DMLOG,ECMDIF,ECMDPM,ELAB, * FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3, * RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG, * WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN, * IDIF,ITAR DOUBLE PRECISION AVCH,AVCH3,DC0,DLOG,DMLOG,ECMDIF,ECMDPM,ELAB, * FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3, * RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG, * WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN INTEGER IDIF,ITAR *KEEP,ISTA. COMMON /ISTA/ IFINET,IFINNU,IFINKA,IFINPI,IFINHY INTEGER IFINET,IFINNU,IFINKA,IFINPI,IFINHY *KEEP,LONGI. COMMON /LONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG, * SDLONG,SELONG,SPLONG,THSTEP,THSTPI, * LHEIGH,NSTEP,LLONGI,FLGFIT DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9), * APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9), * HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9), * SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI INTEGER LHEIGH,NSTEP LOGICAL LLONGI,FLGFIT *KEEP,MULT. COMMON /MULT/ EKINL,MSMM,MULTMA,MULTOT DOUBLE PRECISION EKINL INTEGER MSMM,MULTMA(40,13),MULTOT(40,13) *KEEP,PAM. COMMON /PAM/ PAMA,SIGNUM,RESTMS DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000) *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,PARPAE. DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM * ,WEIGHT * ,HAPP,COSTAP,COSTEA EQUIVALENCE (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE), * (CURPAR(4), PHI ), (CURPAR(5), H ), * (CURPAR(6), T ), (CURPAR(7), X ), * (CURPAR(8), Y ), (CURPAR(9), CHI ), * (CURPAR(10),BETA ), (CURPAR(11),GCM ), * (CURPAR(12),ECM ) * ,(CURPAR(13),WEIGHT) * ,(CURPAR(14),HAPP ), (CURPAR(15),COSTAP), * (CURPAR(16),COSTEA) *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,REST. COMMON /REST/ CONTNE,TAR,LT DOUBLE PRECISION CONTNE(3),TAR INTEGER LT *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,SIGM. COMMON /SIGM/ SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO DOUBLE PRECISION SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO *KEND. PARAMETER (KOLLMX=2500) PARAMETER (MXPTL=70000) PARAMETER (MXSTR=3000) PARAMETER (NDEP=129) PARAMETER (NDET=129) COMMON /ACCUM/ AMSAC,ILAMAS,IMSG,INOIAC,IPAGE,JERR,NAEVT,NREVT * ,NRPTL,NRSTR,NTEVT COMMON /CEVT/ BIMEVT,COLEVT,EGYEVT,PHIEVT,PMXEVT * ,KOLEVT,NEVT,NPJEVT,NTGEVT COMMON /COL/ BIMP,BMAX,COORD(4,KOLLMX),DISTCE(KOLLMX) * ,QDEP(NDEP),QDET14(NDET),QDET16(NDET),QDET40(NDET) * ,QDET99(NDET),RMPROJ,RMTARG(4),XDEP(NDEP) * ,XDET14(NDET),XDET16(NDET),XDET40(NDET) * ,XDET99(NDET) * ,KOLL,LTARG,NORD(KOLLMX),NPROJ,NRPROJ(KOLLMX) * ,NRTARG(KOLLMX),NTARG COMMON /CPTL/ PPTL(5,MXPTL),TIVPTL(2,MXPTL),XORPTL(4,MXPTL) * ,IBPTL(4,MXPTL),ICLPTL(MXPTL),IDPTL(MXPTL) * ,IFRPTL(2,MXPTL),IORPTL(MXPTL),ISTPTL(MXPTL) * ,JORPTL(MXPTL),NPTL,NQJPTL(MXPTL) COMMON /CSTR/ PSTR(5,MXSTR),ROTSTR(3,MXSTR),XORSTR(4,MXSTR) * ,ICSTR(4,MXSTR),IORSTR(MXSTR),IRLSTR(MXSTR),NSTR COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT COMMON /PARO3/ ASUHAX(7),ASUHAY(7),OMEGA,SIGPPD,SIGPPE,UENTRO * ,IWZZZZ DOUBLE PRECISION EA,ELASTI,EMAX,COSTET,PHIV,PL2,PT2,PTM CC DOUBLE PRECISION GAMMAX DOUBLE PRECISION PFRX(60),PFRY(60) INTEGER ITYP(60),NRPTLA(MXPTL) SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'VSTORE:' C NUMBER OF SPECTATORS OF REMAINING NUCLEUS IS NREST NREST = ITYPE/100 - NPJEVT IREST = ITYPE NNEW = 0 INEW = 0 ETOT = 0. ELASTI = 0. NZNEW = 0 NNNEW = 0 KNEW = 0 LEVT = 1 LPTL = 3 NPTLS = 0 DO 1 I = 1,NPTL NRPTLA(I) = -999 IF ( ISTPTL(I) .GT. ISTMAX ) GOTO 1 NPTLS = NPTLS+1 NRPTLA(I) = NPTLS 1 CONTINUE C EVENT VARIABLES: C LEVT................... RECORD LABEL (LEVT=1) C NREVT.................. EVENT NUMBER C NPTLS ................. NUMBER OF (STORED!) PARTICLES PER EVENT C BIMEVT ................ IMPACT PARAMETER C KOLEVT,COLEVT ......... REAL/EFFECTIVE # OF COLLISIONS C PMXEVT ................ REFERENCE MOMENTUM C EGYEVT ................ PP CM ENERGY (HAD) OR STRING ENERGY (STR) C NPJEVT,NTGEVT ......... # OF PROJ/TARG PARTICIPANTS GNU = KOLEVT GNU = COLEVT CC GAMMAX = 0.D0 EMAX = 0.D0 C PARTICLE LOOP DO 5 I = 1,NPTL IF ( NRPTLA(I) .LE. 0 ) GOTO 5 C PARTICLE VARIABLES: C LPTL ......... RECORD LABEL (LPTL=3) C NREVT ........ EVENT NUMBER C NRPTL ........ PARTICLE NUMBER C I ............ ORIGINAL PTL NUMBER C IDPTL ........ PARTICLE ID C PPTL ......... 5-MOMENTUM (PX,PY,PZ,EN,MASS) IN LAB C IOPTL ........ ORIGIN (-999:PARENT NOT STORED, -1,0:NO PARENT) C JOPTL ........ ORIGIN (SECOND PARENT) C ISTPTL ....... STABLE (=0) OR NOT (=1) C XORPTL ....... SPACE-TIME POINT (X,Y,Z,T) ON PTL TRACK (PP-CM) C TIVPTL ....... TIME INTERVAL OF EXISTENCE C NQJPTL ....... QUARK NUMBERS OF JETS C ELIMINATE TARGET SPECTATORS IF ( PPTL(3,I) .EQ. 0. ) GOTO 5 C ELIMINATE BACKWARD GOING PARTICLES IF ( .NOT. LLONGI .AND. PPTL(3,I) .LT. 0. ) GOTO 5 C CONVERT PARTICLE CODE VEN(US) ---> C(O)RS(IKA) C MOST FREQUENT PARTICLES COME FIRST KODVEN = IDPTL(I) C MESONS IF ( KODVEN .EQ. 110 ) THEN KODCRS = 7 ELSEIF ( KODVEN .EQ. 120 ) THEN KODCRS = 8 ELSEIF ( KODVEN .EQ. -120 ) THEN KODCRS = 9 ELSEIF ( KODVEN .EQ. 220 ) THEN KODCRS = 17 C NUCLEONS ELSEIF ( KODVEN .EQ. 1220 ) THEN KODCRS = 13 ELSEIF ( KODVEN .EQ. 1120 ) THEN KODCRS = 14 ELSEIF ( KODVEN .EQ. -1120 ) THEN KODCRS = 15 ELSEIF ( KODVEN .EQ. -1220 ) THEN KODCRS = 25 C STRANGE MESONS ELSEIF ( KODVEN .EQ. -20 ) THEN KODCRS = 10 ELSEIF ( KODVEN .EQ. 130 ) THEN KODCRS = 11 ELSEIF ( KODVEN .EQ. -130 ) THEN KODCRS = 12 ELSEIF ( KODVEN .EQ. 20 ) THEN KODCRS = 16 C STRANGE BARYONS ELSEIF ( KODVEN .EQ. 2130 ) THEN KODCRS = 18 ELSEIF ( KODVEN .EQ. 1130 ) THEN KODCRS = 19 ELSEIF ( KODVEN .EQ. 1230 ) THEN KODCRS = 20 ELSEIF ( KODVEN .EQ. 2230 ) THEN KODCRS = 21 ELSEIF ( KODVEN .EQ. 1330 ) THEN KODCRS = 22 ELSEIF ( KODVEN .EQ. 2330 ) THEN KODCRS = 23 ELSEIF ( KODVEN .EQ. 3331 ) THEN KODCRS = 24 ELSEIF ( KODVEN .EQ. -2130 ) THEN KODCRS = 26 ELSEIF ( KODVEN .EQ. -1130 ) THEN KODCRS = 27 ELSEIF ( KODVEN .EQ. -1230 ) THEN KODCRS = 28 ELSEIF ( KODVEN .EQ. -2230 ) THEN KODCRS = 29 ELSEIF ( KODVEN .EQ. -1330 ) THEN KODCRS = 30 ELSEIF ( KODVEN .EQ. -2330 ) THEN KODCRS = 31 ELSEIF ( KODVEN .EQ. -3331 ) THEN KODCRS = 32 C LEPTONS ELSEIF ( KODVEN .EQ. 10 ) THEN KODCRS = 1 ELSEIF ( KODVEN .EQ. -12 ) THEN KODCRS = 2 ELSEIF ( KODVEN .EQ. 12 ) THEN KODCRS = 3 ELSEIF ( KODVEN .EQ. -14 ) THEN KODCRS = 5 ELSEIF ( KODVEN .EQ. 14 ) THEN KODCRS = 6 C NEUTRINOS ARE SKIPPED ELSEIF ( KODVEN .EQ. 11 ) THEN GOTO 55 ELSEIF ( KODVEN .EQ. -11 ) THEN GOTO 55 ELSEIF ( KODVEN .EQ. 13 ) THEN GOTO 55 ELSEIF ( KODVEN .EQ. -13 ) THEN GOTO 55 ELSE WRITE(MONIOU,*)'VSTORE: UNKNOWN PARTICLE CODE IDPTL=',IDPTL(I) GOTO 5 ENDIF SECPAR(1) = KODCRS C ELIMINATE BACKWARD GOING PARTICLES IF ( LLONGI .AND. PPTL(3,I) .LT. 0. ) GOTO 56 IF ( KODCRS .NE. 1 .AND. KODCRS .LE. 65 ) THEN C ORDINARY SECONDARY PARTICLES SECPAR(2) = PPTL(4,I)/PAMA(KODCRS) C LOOK FOR SPECTATOR NUCLEONS IF ( KODCRS .EQ. 13 .OR. KODCRS .EQ. 14 ) THEN C ELIMINATE TARGET SPECTATORS IF ( SECPAR(2) .LE. 1.002D0 ) GOTO 5 C TREAT PROJECTILE SPECTATORS IF ( SECPAR(2) .GT. 0.999D0*GAMMA .AND. * SECPAR(2) .LT. 1.001D0*GAMMA .AND. * PPTL(1,I).EQ.0. .AND. PPTL(2,I).EQ.0. ) THEN IF ( NFRAGM .NE. 0 ) THEN C COMPOSE PROJECTILE SPECTATORS TO REMAINING NUCLEUS NREST = NREST - 1 NNEW = NNEW + 1 IF ( KODCRS .EQ. 14 ) THEN INEW = INEW + 101 IREST = IREST - 101 ELSEIF ( KODCRS .EQ. 13 ) THEN INEW = INEW + 100 IREST = IREST - 100 ENDIF GOTO 5 ENDIF C DISREGARD PROJECTILE SPECTATORS FOR ELASTICITY GOTO 7 ENDIF ENDIF CC IF ( SECPAR(2) .GT. GAMMAX ) THEN CC GAMMAX = SECPAR(2) C CALCULATE ELASTICITY FROM ENERGY OF FASTEST PARTICLE (LEADER) CC ELASTI = GAMMAX * PAMA(KODCRS) / ELAB CC ENDIF IF ( SECPAR(2)*PAMA(KODCRS) .GT. EMAX ) THEN EMAX = SECPAR(2)*PAMA(KODCRS) C CALCULATE ELASTICITY FROM MOST ENERGETIC PARTICLE (LEADER) ELASTI = EMAX * MAPROJ / ELAB ENDIF ELSE C GAMMAS AND NEUTRINOS SECPAR(2) = PPTL(4,I) ENDIF C COUNTER FOR ENERGY-MULTIPLICITY MATRIX MSMM = MSMM + 1 C DETERMINE ANGLES FROM LONGITUDINAL AND TRANSVERSAL MOMENTA 7 CONTINUE PT2 = DBLE(PPTL(1,I))**2 + DBLE(PPTL(2,I))**2 PL2 = DBLE(PPTL(3,I))**2 IF ( PL2+PT2 .LE. 0.D0 ) THEN COSTET = 0.D0 ELSE COSTET = PPTL(3,I) / SQRT(PL2+PT2) ENDIF COSTET = MAX( MIN(COSTET, 1.D0), -1.D0 ) IF ( PPTL(1,I) .NE. 0. .OR. PPTL(2,I) .NE. 0. ) THEN PHIV = ATAN2( DBLE(PPTL(2,I)), DBLE(PPTL(1,I)) ) ELSE PHIV = 0.D0 ENDIF C COUNTERS FOR FIRST INTERACTION IF ( FIRSTI ) THEN IF ( SECPAR(1) .EQ. 7.D0 .OR. SECPAR(1) .EQ. 8.D0 * .OR. SECPAR(1) .EQ. 9.D0 ) THEN IFINPI = IFINPI + 1 ELSEIF ( SECPAR(1) .EQ. 13.D0 .OR. SECPAR(1) .EQ. 14.D0 * .OR. SECPAR(1) .EQ. 15.D0 .OR. SECPAR(1) .EQ. 25.D0 ) THEN IFINNU = IFINNU + 1 ELSEIF ( SECPAR(1) .EQ. 10.D0 .OR. SECPAR(1) .EQ. 11.D0 * .OR. SECPAR(1) .EQ. 12.D0 .OR. SECPAR(1) .EQ. 16.D0 ) THEN IFINKA = IFINKA + 1 ELSEIF ( SECPAR(1) .EQ. 17.D0 ) THEN IFINET = IFINET + 1 ELSEIF ((SECPAR(1) .GE. 18.D0 .AND. SECPAR(1) .LE. 24.D0) * .OR. (SECPAR(1) .GE. 26.D0 .AND. SECPAR(1) .LE. 32.D0))THEN IFINHY = IFINHY + 1 ENDIF ENDIF ETOT = ETOT + PPTL(4,I) CALL ADDANG( COSTHE,PHI, COSTET,PHIV, SECPAR(3),SECPAR(4) ) IF ( SECPAR(3) .GE. C(29) ) THEN CALL TSTACK GOTO 5 ELSE GOTO 56 ENDIF 55 IF ( LLONGI ) THEN C ADD NEUTRINO ENERGY TO LONGITUDINAL ENERGY DEPOSIT DLONG(LHEIGH,9) = DLONG(LHEIGH,9) + PPTL(4,I) ENDIF GOTO 5 56 IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( KODCRS .LE. 3 ) THEN DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + PPTL(4,I) ELSEIF ( KODCRS .EQ. 5 .OR. KODCRS .EQ. 6 ) THEN DLONG(LHEIGH,5) = DLONG(LHEIGH,5) + PPTL(4,I) ELSE DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + PPTL(4,I) * - RESTMS(KODCRS) ENDIF ENDIF 5 CONTINUE IF ( DEBUG ) WRITE(MDEBUG,*) 'VSTORE: NTGEVT,ETOT =',NTGEVT,ETOT IF ( NFRAGM .NE. 0 .AND. INEW .GT. 0 ) THEN C TREAT REMAINING NUCLEUS IF ( DEBUG ) WRITE(MDEBUG,150) INEW,(CURPAR(I),I=2,8) 150 FORMAT(' VSTORE: REMNNT=',1P,I10,7E10.3) SECPAR(2) = CURPAR(2) SECPAR(3) = CURPAR(3) SECPAR(4) = CURPAR(4) IF ( INEW .EQ. 100 ) THEN C REMAINING NUCLEUS IS SINGLE NEUTRON SECPAR(1) = 13.D0 CALL TSTACK ETOT = ETOT + SECPAR(2) * PAMA(13) GOTO 140 ELSEIF ( INEW .EQ. 101 ) THEN C REMAINING NUCLEUS IS SINGLE PROTON SECPAR(1) = 14.D0 CALL TSTACK ETOT = ETOT + SECPAR(2) * PAMA(14) GOTO 140 ELSEIF ( NFRAGM .GE. 2 ) THEN C REMAINING NUCLEUS IS EVAPORATING NUCLEONS AND ALPHA PARTICLES NZNEW = MOD(INEW,100) NNNEW = INEW/100 - NZNEW JFIN = 0 CALL VAPOR(MAPROJ,INEW,JFIN,ITYP,PFRX,PFRY) IF ( JFIN .EQ. 0 ) GOTO 139 C LOOP TO TREAT THE REMANENTS OF THE DESINTEGRATED FRAGMENT KNEW = 0 DO 135 J = 1,JFIN EA = GAMMA * PAMA(ITYP(J)) IF (DEBUG) WRITE(MDEBUG,*) 'VSTORE: J,ITYP,EA=',J,ITYP(J),EA C MOMENTA SQUARED PTM = EA**2 - PAMA(ITYP(J))**2 PT2 = PFRX(J)**2 + PFRY(J)**2 IF ( PT2 .GE. PTM ) THEN IF (DEBUG) WRITE(MDEBUG,*) 'VSTORE: PT REJECT PARTICLE',J GOTO 135 ENDIF IF ( PTM .GT. 0.D0 ) THEN COSTET = SQRT( 1.D0 - PT2/PTM ) ELSE COSTET = 1.D0 ENDIF IF ( PFRX(J) .NE. 0.D0 .OR. PFRY(J) .NE. 0.D0 ) THEN PHIV = ATAN2( PFRY(J), PFRX(J) ) ELSE PHIV = 0.D0 ENDIF CALL ADDANG( COSTHE,PHI, COSTET,PHIV, SECPAR(3),SECPAR(4) ) IF ( SECPAR(3) .GE. C(29) ) THEN IF ( J .LT. JFIN ) THEN SECPAR(1) = ITYP(J) CALL TSTACK ELSE KNEW = ITYP(JFIN) ENDIF ELSE IF(DEBUG)WRITE(MDEBUG,*) 'VSTORE: ANGLE REJECT PARTICLE',J IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + EA ENDIF ENDIF 135 CONTINUE ELSEIF ( NFRAGM .EQ. 1 ) THEN C REMAINING NUCLEUS IS ONE FRAGMENT NZNEW = MOD(INEW,100) NNNEW = INEW/100 - NZNEW KNEW = INEW ENDIF IF ( KNEW/100 .EQ. 5 ) THEN C REMAINING NUCLEUS: MASS 5 CANNOT BE TREATED IN BOX2 IF ( MOD(KNEW,100) .GE. 3 ) THEN C MASS 5: SPLIT OFF ONE PROTON SECPAR(1) = 14.D0 CALL TSTACK KNEW = KNEW - 101 ELSE C MASS 5: SPLIT OFF ONE NEUTRON SECPAR(1) = 13.D0 CALL TSTACK KNEW = KNEW - 100 ENDIF ELSEIF ( KNEW/100 .EQ. 8 ) THEN C REMAINING NUCLEUS: MASS 8 CANNOT BE TREATED IN BOX2 IF ( MOD(KNEW,100) .GE. 5 ) THEN C MASS 8: SPLIT OFF ONE PROTON SECPAR(1) = 14.D0 CALL TSTACK KNEW = KNEW - 101 ELSEIF ( MOD(KNEW,100) .LE. 3 ) THEN C MASS 8: SPLIT OFF ONE NEUTRON SECPAR(1) = 13.D0 CALL TSTACK KNEW = KNEW - 100 ELSE C MASS 8: SPLIT OFF ONE ALPHA PARTICLE SECPAR(1) = 402.D0 CALL TSTACK KNEW = KNEW - 402 ENDIF ENDIF SECPAR(1) = KNEW CALL TSTACK ENDIF 139 ETOT = ETOT + SECPAR(2)*(PAMA(13)*NNNEW + PAMA(14)*NZNEW) 140 CONTINUE IF ( DEBUG ) WRITE(MDEBUG,*) 'VSTORE: ELASTI,ETOT,ELAB=', * SNGL(ELASTI),ETOT,ELAB C FILL ELASTICITY IN MATRICES MEL = MIN ( 1.D0+10.D0* MAX( 0.D0, ELASTI ) , 11.D0 ) MEN = MIN ( 4.D0+ 3.D0*LOG10(MAX( .1D0, EKINL )), 40.D0 ) IELDPM(MEN,MEL) = IELDPM(MEN,MEL) + 1 IELDPA(MEN,MEL) = IELDPA(MEN,MEL) + 1 IF ( ELASTI .LT. 1.D0 ) THEN ELMEAN(MEN) = ELMEAN(MEN) + ELASTI ELMEAA(MEN) = ELMEAA(MEN) + ELASTI ENDIF IF ( FIRSTI ) THEN TARG1I = TAR SIG1I = SIGAIR ELAST = ELASTI FIRSTI = .FALSE. ENDIF RETURN END *CMZ : 28/02/2002 12.41.48 by D. HECK IK FZK KARLSRUHE *-- Author : K. BERNLOEHR MPIK HEIDELBERG 15/06/98 C======================================================================= SUBROUTINE CERENK(STEPCR,UMEAN,VMEAN,WMEAN,EBEG,EEND,XBEG,YBEG, * ZBEG,XEND,YEND,ZEND,TBEG,TEND,AMASS,CHARGE,WTTHIN,CTEA) C----------------------------------------------------------------------- C C(H)ERENK(OV RADIATION FROM ALL KINDS OF CHARGED PARTICLES) C C CREATION OF CHERENKOV PHOTONS ALONG THE TRACKS OF CHARGED PARTICLES. C CHERENKOV RADIATION IS ONLY CALCULATED FOR THE LOWEST OBSERVATION C LEVEL. ALL PARAMETERS OF THE PARTICLE TRACK STEP ARE PASSED AS C ARGUMENTS. C THIS SUBROUTINE IS CALLED FROM ELECTR AND UPDATE.. C ARGUMENTS (ALL DOUBLE PRECISION): C STEPCR = STEP LENGTH FOR THE PARTICLE [CM] C UMEAN = DIRECTION COSINE TO X AXIS (STEP AVERAGE) C VMEAN = DIRECTION COSINE TO Y AXIS (STEP AVERAGE) C WMEAN = DIRECTION COSINE TO -Z AXIS (STEP AVERAGE) C EBEG = ENERGY [GEV] AT BEGINNING OF STEP C EEND = ENERGY [GEV] AT END OF STEP C XBEG = X POSITION [CM] AT BEGINNING OF STEP C XEND = X POSITION [CM] AT END OF STEP C YBEG = Y POSITION [CM] AT BEGINNING OF STEP C YEND = Y POSITION [CM] AT END OF STEP C ZBEG = Z POSITION [CM] AT BEGINNING OF STEP C ZEND = Z POSITION [CM] AT END OF STEP C AMASS = PARTICLE MASS [GEV/C**2] C CHARGE = CHARGE NUMBER (OR NEGATIVE - WE NEED ONLY THE SQUARE OF IT) C WTTHIN = PARTICLE WEIGHT FOR THINNING VERSION, ELSE 1. C CTEA = COSINE OF EARTH ANGLE IN CURVED VERSION, ELSE 1. C C THIS IMPLEMENTATION WRITTEN BY C K. BERNLOEHR MPIK HEIDELBERG (1998) C THIS SUBROUTINE IS BASED IN PART ON THE FORMER CHERENKOV ROUTINES C CERENE AND CERENH ORIGINALLY WRITTEN BY C M. ROZANSKA UNIVERSITY OF KRAKOW C S. MARTINEZ UNIVERSITY OF MADRID C F. ARQUEROS UNIVERSITY OF MADRID C AND SUBSEQUENTLY MODIFIED BY C D. HECK IK3 FZK KARLSRUHE C R. ATTALLAH UNIVERSITY OF PERPIGNAN C C EXTERNAL IACT (IMAGING ATMOSPHERIC CHERENKOV TECHNIQUE) FUNCTIONS C FOR COLLECTING PHOTON BUNCHES AT ARBITRARY TELESCOPE LOCATIONS C WRITTEN (IN C) BY C K. BERNLOEHR MPIK HEIDELBERG (1997) C AND AVAILABLE SEPARATELY. C THE SAME APPLIES TO FUNCTIONS FOR TABULATED ATMOSPHERIC MODELS AND C FUNCTIONS TO ACCOUNT FOR THE ATMOSPHERIC REFRACTION. C C----------------------------------------------------------------------- c-----changed-add-comand c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> parameter (xct=1) parameter (yct=2) parameter (zct=3) parameter (ctthet=4) parameter (ctphi=5) parameter (ctdiam=6) parameter (ctfoc=7) c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> c IMPLICIT NONE cx------------ c IMPLICIT NONE *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,EGSDEB. COMMON /EGSDEB/ JCLOCK,NCLOCK,FEGSDB INTEGER JCLOCK,NCLOCK LOGICAL FEGSDB *KEEP,LONGI. COMMON /LONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG, * SDLONG,SELONG,SPLONG,THSTEP,THSTPI, * LHEIGH,NSTEP,LLONGI,FLGFIT DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9), * APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9), * HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9), * SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI INTEGER LHEIGH,NSTEP LOGICAL LLONGI,FLGFIT *KEEP,MAGANG. COMMON /MAGANG/ ARRANG,ARRANR,COSANG,SINANG DOUBLE PRECISION ARRANG,ARRANR,COSANG,SINANG *KEEP,OBSPAR. COMMON /OBSPAR/ OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP, * THETPR,PHIPR, * VUECON, * NOBSLV DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10), * HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2) DOUBLE PRECISION VUECON(2) INTEGER NOBSLV *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,STACKE. COMMON /STACKE/ E,TIM,U,V,W,X,Y,Z,DNEAR, * ZAP,WAP,WA, * IQ,IGEN,IR,IOBS,LPCTE,NP DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60), * X(60),Y(60),Z(60),DNEAR(60) * ,ZAP(60),WAP(60),WA(60) INTEGER IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP *KEEP,CEREN1. COMMON /CEREN1/ CERELE,CERHAD,ETADSN,WAVLGL,WAVLGU,CYIELD, * CERSIZ,CERNOR,LCERFI DOUBLE PRECISION CERELE,CERHAD,ETADSN,WAVLGL,WAVLGU,CYIELD, * CERSIZ,CERNOR LOGICAL LCERFI *KEEP,CEREN2. COMMON /CEREN2/ ACERX,ACERY,CERXOS,CERYOS, * DCERX,DCERXI,DCERY,DCERYI,EPSX,EPSY,FCERX,FCERY, * WL,XCMAX,XCMAXS,XSCATT,YCMAX,YCMAXS,YSCATT, * PHOTCM,XCER,YCER,UEMIS,VEMIS,WEMIS,CARTIM,ZEMIS, * NCERX,NCERY,ICERML DOUBLE PRECISION ACERX,ACERY,CERXOS(20),CERYOS(20), * DCERX,DCERXI,DCERY,DCERYI,EPSX,EPSY,FCERX,FCERY, * WL,XCMAX,XCMAXS,XSCATT,YCMAX,YCMAXS,YSCATT DOUBLE PRECISION PHOTCM,XCER,YCER,UEMIS,VEMIS,WEMIS,CARTIM,ZEMIS INTEGER NCERX,NCERY,ICERML *KEEP,ATMOSX. C EXTERNAL ATMOSPHERIC MODELS COMMON /ATMOSX/ IATMOX,FREFRX INTEGER IATMOX LOGICAL FREFRX *KEEP,CORFRAM, IF=CURVED. COMMON /CORFRAM/ DETSYS LOGICAL DETSYS *KEND. *keep,certel. common /certel/ cormxd,cord,coralp,ctpars,omega, + photn,photnp,phpt,pht,vphot, + vchi,veta,vzeta,vchim,vetam,vzetam, + lambda,mu,nu,nctels,ncph,phip1,thetap1 double precision cormxd,cord,coralp,ctpars(20,7),omega(20,3,3), + photn(3),photnp(3),phpt(3),pht,vphot(3), + vchi(3),veta(3),vzeta(3),vchim,vetam,vzetam, + lambda,mu,nu integer nctels,ncph(5) double precision xg,yg,zg,xgp,ygp,zgp,up,vp,wp,xpcut,ypcut,zpcut double precision thetap1,phip1 equivalence (photn(1) ,xg) ,(photn(2) ,yg) ,(photn(3) ,zg) , + (photnp(1),xgp) ,(photnp(2),ygp) ,(photnp(3),zgp), + (phpt(1) ,xpcut),(phpt(2) ,ypcut),(phpt(3) ,zpcut), + (vphot(1) ,up) ,(vphot(2) ,vp) ,(vphot(3) ,wp) character *72 ctfile *keep,graal1. common /graal1/ wavelength ! (nm) real wavelength c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> cxx -------- double precision dist2 integer imov,ntt,nct,nx double precision xx,yy,r c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> C-changes---add C JOK SLIGHT CHANGE HERE BECAUSE WEMIS IS NOW IN COMMON CERENK2 DOUBLE PRECISION PHICER,SINPSI,SINPS2,UEMIS2, * VEMIS2, XCER2,XEMIS,YCER2,YEMIS DOUBLE PRECISION STEPCR DOUBLE PRECISION UMEAN,VMEAN,WMEAN DOUBLE PRECISION EBEG,EEND DOUBLE PRECISION XBEG,YBEG,ZBEG,XEND,YEND,ZEND DOUBLE PRECISION TBEG,TEND,AMASS,CHARGE,WTTHIN,CTEA DOUBLE PRECISION BETAE,BETAI,CTHETA,ETA1,ETA1I,ETA1E,STHETA DOUBLE PRECISION BETAM,ETA1M DOUBLE PRECISION TC11,TC21,TC12,TC22,TC32,TC13,TC23,TC33 DOUBLE PRECISION BETA,BETAN,BETANI,DBETAN,ENER DOUBLE PRECISION ETALI,ETALE,DETAL,CINTEN DOUBLE PRECISION PHOTCT,PSTEP,PATHL,XSTEP,YSTEP,ZSTEP,ZEM DOUBLE PRECISION DEDPL,STHET2, SINPHI,COSPHI DOUBLE PRECISION BEMX,STCP,STSP,TEMIS,TSTEP DOUBLE PRECISION THKBEG,DTHKLG C WLFLAG PHOTON/PHOTO-ELECTRON FLAG (OR WAVELENGTH IN NANOMETER) DOUBLE PRECISION WLFLAG SAVE C FOR WLFLAG = 0.D0: OUTPUT DATA ARE PHOTON BUNCHES PARAMETER (WLFLAG = 0.D0 ) INTEGER MAXRDM PARAMETER ( MAXRDM = 100 ) REAL RDM(MAXRDM) INTEGER LOOPFL,IRDM,NRDM INTEGER ISTC,NSTEPC DOUBLE PRECISION XCER1,YCER1,XXX,YYY,DXXX,DYYY INTEGER I DOUBLE PRECISION REFIDX EXTERNAL REFIDX DOUBLE PRECISION RHOF,THICK EXTERNAL RHOF,THICK DOUBLE PRECISION AUXILSQ,CDDIF,CDIFA,CDIFB,CUMEAN,CVMEAN, * CWMEAN,DISTIP,ETA2,RDIST,SDIFB,STHE,STHE2, * SWEMIS,TOFIP,ZAPP,ZHBEG,ZHEM,ZHEND,ZHSTEP EXTERNAL DISTIP,TOFIP C----------------------------------------------------------------------- IF ( FEGSDB ) WRITE(MDEBUG,*) 'CERENK: EBEG=',EBEG,' AMASS=',AMASS C SKIP PARTICLES OUT OF ZENITH ANGULAR CUT (WITH WMEAN>0 DOWNWARDS). C NOTE: USUALLY C(29) IS 0, I.E. UPWARD GOING PARTICLES ARE REJECTED. IF ( WMEAN .LT. C(29) .OR. STEPCR .LE. 0.D0 ) RETURN C LOOK WETHER CHERENKOV CONDITION IS FULFILLED FOR THIS STEP. BETAI = SQRT( 1.D0 - (AMASS/EBEG)**2 ) BETAE = SQRT( 1.D0 - (AMASS/EEND)**2 ) C REFRACTIVE INDEX PARAMETRISATION: N=1+ETA = ETA1 IF ( IATMOX .GE. 1 ) THEN ETA1I = REFIDX(ZBEG) ETA1E = REFIDX(ZEND) ELSE ETA1I = 1.D0 + ETADSN * RHOF(ZBEG) ETA1E = 1.D0 + ETADSN * RHOF(ZEND) ENDIF IF ( BETAI*ETA1I.LT.1.D0 .AND. BETAE*ETA1E.LT.1.D0 ) RETURN BETAM = SQRT( 1.D0 - (AMASS*2.D0/(EBEG+EEND))**2 ) IF ( IATMOX .GE. 1 ) THEN ETA1M = REFIDX(0.5D0 * (ZBEG+ZEND)) ELSE ETA1M = 1.D0 + ETADSN * RHOF(0.5D0 * (ZBEG+ZEND)) ENDIF BEMX = MAX( BETAE*ETA1E, BETAI*ETA1I ) CINTEN = CYIELD * CHARGE**2 PHOTCT = CINTEN * STEPCR * (1.D0 - 1.D0/BEMX**2) NSTEPC = PHOTCT / CERSIZ + 1 IF ( NSTEPC .LT. 1 ) RETURN C TRANSFORM ALL COORDINATES INTO DETECTOR FRAME (IF NOT DONE UNTIL NOW) C XBEG, XEND, YBEG, YEND ARE TRANSFORMED IN UPDATE (OR PARTLY IN UPDATC) IF ( .NOT. DETSYS ) THEN C FIRST TRANSFORM ANGLES INTO DETECTOR FRAME C (ROTATE LOCAL FRAME WITH EARTH ANGLE DIF) CDIFB = CTEA CDIFB = MIN( 1.D0, CDIFB ) SDIFB = SQRT( 1.D0 - CTEA**2 ) SDIFB = MIN( 1.D0, SDIFB ) STHE = SQRT(UMEAN**2 + VMEAN**2) IF ( STHE .GT. 0.D0 ) THEN CUMEAN = UMEAN/STHE CVMEAN = VMEAN/STHE CUMEAN = WMEAN*SDIFB*CUMEAN + CDIFB*STHE*CUMEAN CVMEAN = WMEAN*SDIFB*CVMEAN + CDIFB*STHE*CVMEAN CWMEAN = WMEAN*CDIFB - SDIFB*STHE ELSE CUMEAN = WMEAN*SDIFB*UMEAN CVMEAN = WMEAN*SDIFB*VMEAN CWMEAN = WMEAN*CDIFB ENDIF IF ( FEGSDB ) WRITE(MDEBUG,*) 'CERENK: CURVED; CWMEAN=',CWMEAN IF ( CWMEAN .LT. C(29) ) RETURN C ZBEG, ZEND IN DETECTOR FRAME (ZHBEG, ZHEND) C ACTUAL EARTH ANGLE AUXILSQ = SQRT( XBEG**2 + YBEG**2 ) CDIFA = COS( AUXILSQ/C(1) ) IF ( CDIFA .GT. CTEA ) THEN C TRANSFORM FIRST INTO THE INTERMEDIATE LOCAL SYSTEM CDDIF = CTEA*CDIFA + SQRT( (1.D0-CTEA**2)*(1.D0-CDIFA**2) ) ZBEG = (ZBEG+C(1)) / CDDIF - C(1) ZEND = (ZEND+C(1)) / CDDIF - C(1) ENDIF ZHBEG = (ZBEG+C(1)) * CDIFA - C(1) IF ( ZHBEG .LE. OBSLEV(1) ) RETURN C TAKE EARTH ANGLE OF END POINT OF PART OF TRACK FOR CALCULATING ZHEND AUXILSQ = SQRT( XEND**2 + YEND**2) ZHEND = (ZEND+C(1)) * COS(AUXILSQ/C(1)) - C(1) C NOW TRANSFORM CURVED COORDINATES INTO FLAT COORDINATE FRAME C TAKING THE NOW AVAILABLE VALUES OF HAPP (X = X(HAPP)) XBEG = (ZHBEG+C(1)) * TAN(XBEG/C(1)) YBEG = (ZHBEG+C(1)) * TAN(YBEG/C(1)) XEND = (ZHEND+C(1)) * TAN(XEND/C(1)) YEND = (ZHEND+C(1)) * TAN(YEND/C(1)) ENDIF C NOW CHECK WHICH KIND OF CALCULATING (BETA*N) FOR EACH SUB-STEP C IS LIKELY TO BE THE MOST EFFICIENT. C CASE 0: ONLY ONE STEP - WE HAVE ALREADY THE NUMBERS AT MID-STEP. IF ( NSTEPC .EQ. 1 ) THEN LOOPFL = 0 C CASE 1: LINEAR INTERPOLATION OF (BETA*N) IF THE RELATIVE ERROR ON C THE LIGHT INTENSITY IN THE MIDDLE IS LESS THAN 1E-3 (THEN THE ERROR C ON THE IMPACT POINT FOR VERTICAL INCIDENCE IS LESS THAN ABOUT 5 CM). ELSEIF ( (BETAE*ETA1E).GT.1D0 .AND. (BETAI*ETA1I).GT.1D0 .AND. * (BETAM*ETA1M).GT.1D0 .AND. * ABS((2.D0-1.D0/(BETAI*ETA1I)**2-1.D0/(BETAE*ETA1E)**2)/ * (1.D0-1.D0/(BETAM*ETA1M)**2)-2.D0) .LT. 2.D-3*WMEAN ) THEN LOOPFL = 1 DBETAN = (BETAE*ETA1E-BETAI*ETA1I) / STEPCR BETANI = BETAI * ETA1I DEDPL = (EEND-EBEG) / STEPCR C CASE 2: LOGARITHMIC INTERPOLATION OF (N-1) IS GOOD ENOUGH FOR C ERRORS ON THE IMPACT POINT BEING LESS THAN 10 CM. C BETA IS CALCULATED EXPLICITLY ASSUMING CONSTANT ENERGY LOSS. C NOTE THAT WE USE CONSTANT ENERGY LOSS PER CENTIMETER RATHER THAN C PER UNIT G/CM**2 FOR EFFICIENCY REASONS. THE POSSIBLE DIFFERENCE C OF ENERGY AT MIDDLE OF STEP SHOULD BE INSIGNIFICANT IN ALMOST C ANY CASE. ELSEIF ( ABS((ETA1I-1.D0)*(ETA1E-1.D0)/(ETA1M-1.D0)**2 - 1.D0) * .LT. (10.D0/ZBEG*WMEAN)**2 ) THEN LOOPFL = 2 ETALI = LOG(ETA1I-1.D0) ETALE = LOG(ETA1E-1.D0) DETAL = (ETALE-ETALI) / STEPCR DEDPL = (EEND-EBEG) / STEPCR ELSE C CASE 3: BOTH N AND BETA HAVE TO BE CALCULATED IN FULL DETAIL. LOOPFL = 3 DEDPL = (EEND-EBEG) / STEPCR ENDIF C VARIOUS START VALUES AND STEP LENGTHS FOR SUB-STEP LOOP PSTEP = STEPCR * (1.D0/DBLE(NSTEPC)) PATHL = (-0.5D0)*PSTEP XSTEP = (XEND-XBEG) * (1.D0/DBLE(NSTEPC)) YSTEP = (YEND-YBEG) * (1.D0/DBLE(NSTEPC)) TSTEP = (TEND-TBEG) * (1.D0/DBLE(NSTEPC)) XEMIS = XBEG - 0.5D0*XSTEP YEMIS = YBEG - 0.5D0*YSTEP TEMIS = TBEG - 0.5D0*TSTEP ZSTEP = (ZEND-ZBEG) * (1.D0/DBLE(NSTEPC)) ZEM = ZBEG - 0.5D0*ZSTEP C THE TC.. ELEMENTS ARE DESCRIBED FURTHER DOWN. IF ( .NOT. DETSYS ) THEN ZHSTEP = (ZHEND-ZHBEG) * (1.D0/DBLE(NSTEPC)) ZHEM = ZHBEG - 0.5D0*ZHSTEP IF ( ZHEM .LE. OBSLEV(1) ) RETURN SINPS2 = CUMEAN**2 + CVMEAN**2 IF ( SINPS2 .LT. 1.D-20 ) SINPS2 = 1.D-20 SINPSI = SQRT(SINPS2) TC11 = CVMEAN*(1.D0/SINPSI) TC12 = CUMEAN*CWMEAN*(1.D0/SINPSI) TC13 = CUMEAN TC21 = (-CUMEAN)*(1.D0/SINPSI) TC22 = CVMEAN*CWMEAN*(1.D0/SINPSI) TC23 = CVMEAN TC32 = -SINPSI TC33 = CWMEAN ELSE SINPS2 = UMEAN**2 + VMEAN**2 IF ( SINPS2 .LT. 1.D-20 ) SINPS2 = 1.D-20 SINPSI = SQRT(SINPS2) TC11 = VMEAN*(1.D0/SINPSI) TC12 = UMEAN*WMEAN*(1.D0/SINPSI) TC13 = UMEAN TC21 = (-UMEAN)*(1.D0/SINPSI) TC22 = VMEAN*WMEAN*(1.D0/SINPSI) TC23 = VMEAN TC32 = -SINPSI TC33 = WMEAN ENDIF C SINCE EXPONENTIAL ATMOSPHERIC LAYERS ARE ASSUMED, A LOGARITHMIC C INTERPOLATION OF THE ATMOSPHERIC THICKNESS CAN BE APPLIED. IF ( NSTEPC .GT. 3 ) THEN THKBEG = MAX( 1.D-3, THICK(ZBEG)) DTHKLG = LOG(THICK(ZEND)/THKBEG) / STEPCR ENDIF C DON'T GET RANDOM NUMBERS ONE-BY-ONE BUT IN LARGER CHUNKS. NRDM = NSTEPC IRDM = 0 IF ( NRDM .GT. MAXRDM ) THEN CALL RMMAR(RDM,MAXRDM,3) ELSE CALL RMMAR(RDM,NRDM,3) ENDIF C LOOP OVER THE NUMBER OF SUB-STEPS WITH CONSTANT PARTICLE DIRECTION C BUT CONTINUOUS ENERGY LOSS AND REFRACTION INDEX CHANGE ACCOUNTED FOR. C SINCE ACTUAL VELOCITY CHANGES OF PARTICLES EMITTING CHERENKOV LIGHT C IN THE ATMOSPHERE ARE VERY SMALL, CONSTANT STEPS IN (X,Y,Z,T) ARE USED. DO 1000 ISTC = 1,NSTEPC PATHL = PATHL + PSTEP XEMIS = XEMIS + XSTEP YEMIS = YEMIS + YSTEP ZEM = ZEM + ZSTEP TEMIS = TEMIS + TSTEP IF ( .NOT. DETSYS ) THEN ZHEM = ZHEM + ZHSTEP IF ( ZHEM .LE. OBSLEV(1) ) RETURN ENDIF C DEPENDING ON CONDITIONS USE THE FASTEST METHOD TO GET (BETA*N). IF ( LOOPFL .EQ. 1 ) THEN C THE MOST FREQUENT AND SIMPLEST CASE (WELL ABOVE THRESHOLD). BETAN = BETANI + DBETAN*PATHL ELSEIF ( NSTEPC .EQ. 1 ) THEN C THIS CASE IS USALLY ENCOUNTERED NEAR THRESHOLD. BETAN = BETAM*ETA1M ELSEIF ( LOOPFL .EQ. 2 ) THEN C THIS CASE IS ALSO USALLY ENCOUNTERED NEAR THRESHOLD. ETA1 = 1.D0 + EXP(ETALI+DETAL*PATHL) ENER = EBEG + DEDPL*PATHL BETA = SQRT(1.D0-(AMASS/ENER)**2) BETAN = BETA*ETA1 ELSE C THIS MOST GENERAL CASE IS RARELY ENCOUNTERED. IF ( IATMOX .GE. 1 ) THEN ETA1 = REFIDX(ZEM) ELSE ETA1 = 1.D0 + ETADSN * RHOF(ZEM) ENDIF ENER = EBEG + DEDPL*PATHL BETA = SQRT(1.D0-(AMASS/ENER)**2) BETAN = BETA*ETA1 ENDIF IF ( FEGSDB ) WRITE(MDEBUG,*) * 'CERENK: LOOPFL=',LOOPFL,' BETAN=',BETAN CTHETA = 1.D0 / BETAN STHET2 = 1.D0 - CTHETA**2 C PARTICLE IS BELOW ENERGY THRESHOLD IF THE EMISSION ANGLE IS <=0 IF ( CTHETA .GT. 1.D0 .OR. STHET2 .LE. 0.D0 ) THEN NRDM = NRDM - 1 GOTO 1000 ENDIF C NUMBER OF EMITTED PHOTONS IN THIS SUB-STEP PHOTCM = (CINTEN*PSTEP) * STHET2 STHETA = SQRT(STHET2) C ASSUME EMISSION POINT OF ALL PHOTONS IN THE MIDDLE OF THE STEP C SAVE EMMISION HEIGHT SEEN FROM THE DETECTOR IF ( .NOT. DETSYS ) THEN ZEMIS = ZHEM ZAPP = ZHEM ELSE ZEMIS = ZEM ZAPP = ZEM ENDIF C CALCULATE PHOTON DIRECTION IN THE CORSIKA COORDINATE FRAME C C NOTE: TO DERIVE THESE EQUATIONS YOU SHOULD FIRST DERIVE A MATRIX (T) C WHICH ROTATES THE PARTICLE DIRECTION (U, V, W) TO (0, 0, 1): C C ( V/SQRT(U**2+V**2) -U/SQRT(U**2+V**2) 0 ) C (T) = ( UW/SQRT(U**2+V**2) VW/SQRT(U**2+V**2) -SQRT(U**2+V**2) ) C ( U V W ) C C CHERENKOV EMISSION IN THIS ROTATED COORDINATE SYSTEM IS DESCRIBED BY C A MATRIX (C): C C ( COS(PHI) -SIN(PHI) 0 ) ( COS(THETA) 0 SIN(THETA) ) C (C) = ( SIN(PHI) COS(PHI) 0 ) ( 0 1 0 ) C ( 0 0 1 ) ( -SIN(THETA) 0 COS(THETA) ) C C WHERE THETA IS THE CHERENKOV OPENING ANGLE AND PHI IS RANDOM. C THE RESULT IS (T_T)**-1 (C) (0,0,1): C C (0) C (T_T)**-1 (C) (0) = C (1) C C ( V/S*SIN(T)*COS(PHI)+U*W/S*SIN(T)*SIN(PHI)+U*COS(T) ) C = (-U/S*SIN(T)*COS(PHI)+V*W/S*SIN(T)*SIN(PHI)+V*COS(T) ) C ( -S*SIN(T)*SIN(PHI)+W*COS(T) ) C C WITH S = SQRT(U**2+V**2) AND T=THETA. THE CONSTANT PARTS ARE CALCULATED C AS TC11 ... TC33 BEFORE THE '1000' LOOP. C DON'T GET RANDOM NUMBERS ONE-BY-ONE BUT IN LARGER CHUNKS FROM SEQ. 3 IRDM = IRDM + 1 IF ( IRDM .GT. MAXRDM ) THEN IF ( NRDM .GT. MAXRDM ) THEN CALL RMMAR(RDM,MAXRDM,3) NRDM = NRDM - MAXRDM ELSE CALL RMMAR(RDM,NRDM,3) NRDM = 0 ENDIF IRDM = 1 ENDIF PHICER = RDM(IRDM) * PI2 SINPHI = SIN(PHICER) COSPHI = COS(PHICER) IF ( SINPS2 .LE. 1.D-12 ) THEN UEMIS2 = STHETA * COSPHI VEMIS2 = STHETA * SINPHI WEMIS = CTHETA IF ( WMEAN .LT. 0.D0 ) WEMIS = -CTHETA ELSE STCP = STHETA * COSPHI STSP = STHETA * SINPHI UEMIS2 = TC11*STCP + TC12*STSP + TC13*CTHETA VEMIS2 = TC21*STCP + TC22*STSP + TC23*CTHETA WEMIS = TC32*STSP + TC33*CTHETA ENDIF IF ( FEGSDB ) WRITE(MDEBUG,*) 'CERENK: UEMIS2,VEMIS2,WEMIS=', * UEMIS2,VEMIS2,WEMIS C EMISSION ANGLE WITHIN ZENITH ANGULAR CUT? IF ( WEMIS .LT. C(29) ) GOTO 1000 WEMIS = MIN( 1.D0, WEMIS ) C CALCULATE OFFSET FROM SHOWER AXIS AT THE DETECTOR LEVEL. C CALCULATE NEW DETECTOR COORDINATES BY INTERPOLATING BETWEEN C TABULATED VALUES WHICH WERE NUMERICALLY INTEGRATED C TAKING INTO ACCOUNT ATMOSPHERIC REFRACTION IN A CURVED GEOMETRY STHE = SQRT(UEMIS2**2 + VEMIS2**2) RDIST = DISTIP( WEMIS, ZAPP) IF ( FEGSDB ) WRITE(MDEBUG,*) 'CERENK: WEMIS,ZEM,STHE,RDIST=', * WEMIS,ZEM,STHE,RDIST IF ( STHE .GT. 0.D0 ) THEN C UEMIS2=COSPHI, VEMIS2=SINPHI XCER2 = XEMIS + RDIST * UEMIS2/STHE YCER2 = YEMIS + RDIST * VEMIS2/STHE ELSE XCER2 = XEMIS YCER2 = YEMIS ENDIF C ADD THE CHERENKOV PHOTONS TO THE LONGITUDINAL DEVELOPMENT. IF ( LLONGI ) THEN IF ( AMASS .LT. 1.D-3 ) THEN CALL CERLDE ELSE CALL CERLDH ENDIF ENDIF C TAKE THE ROTATION RELATIVE TO MAGNETIC NORTH INTO ACCOUNT XCER = XCER2 * COSANG + YCER2 * SINANG YCER = YCER2 * COSANG - XCER2 * SINANG UEMIS = UEMIS2 * COSANG + VEMIS2 * SINANG VEMIS = VEMIS2 * COSANG - UEMIS2 * SINANG IF ( FEGSDB ) WRITE(MDEBUG,*) 'CERENK: UEMIS,VEMIS,PHOTCM=', * SNGL(UEMIS),SNGL(VEMIS),SNGL(PHOTCM) C ONLY PHOTON BUNCHES INSIDE CHERENKOV ARRAY c--changes--add c IF ( ABS(XCER) .LT. XCMAXS .AND. ABS(YCER) .LT. YCMAXS ) THEN IF ( AMASS .LT. 1.D-3 ) THEN CERELE = CERELE + PHOTCM ELSE CERHAD = CERHAD + PHOTCM ENDIF DO 7001 I = 1,ICERML DO 101 NCT=1,NCTELS XCER1 = XCER - CERXOS(I) - CTPARS(NCT,XCT) c XXX = XCER1 * DCERXI + FCERX c DXXX = ABS( XXX - NINT(XXX) ) c IF ( DXXX .LE. EPSX ) THEN c IF ( XCER1.LT.-XCMAX .OR. XCER1.GT.XCMAX ) GOTO 7001 YCER1 = YCER - CERYOS(I) - CTPARS(NCT,YCT) c YYY = YCER1 * DCERYI + FCERY c DYYY = ABS( YYY - NINT(YYY) ) c IF ( DYYY .LE. EPSY ) THEN c IF ( YCER1.LT.-YCMAX .OR. YCER1.GT.YCMAX ) GOTO 7001 c xx=xcer1*dcos(phip1)-ycer1*dsin(phip1) yy=xcer1*dsin(phip1)+ycer1*dcos(phip1) dist2=dsqrt((xx*dcos(thetap1))**2+yy**2+1.d-10) c c IF (dist2.GT.(CTPARS(NCT,CTDIAM)/2.)) GOTO 7001 c c Fixed by AM, 24/7/2002, to allow use of CERTEL option with more c than one telescope: c IF (dist2.LT.(CTPARS(NCT,CTDIAM)/2.)) GOTO 102 101 continue c If photon is not within reach of any of the telescopes, skip it: GOTO 7001 c--changes C BUNCH FALLS ON A DETECTOR, CALCULATE ARRIVAL TIME (NSEC) 102 IF ( FREFRX ) THEN C CALCULATE TIME OF FLIGHT BY INTERPOLATING BETWEEN TABULATED VALUES CARTIM = TEMIS * 1.D9 + TOFIP(WEMIS,ZAPP) ELSE C CALCULATE TIME OF FLIGHT BY INTERPOLATING BETWEEN TABULATED VALUES CARTIM = TEMIS * 1.D9 + TOFIP(WEMIS,ZAPP) ENDIF C CORRECT ZENITH ANGLE DUE TO ATMOSPHERIC REFRACTION FOR OUTPUT IF ( IATMOX .GE. 1 ) THEN ETA2 = REFIDX( OBSLEV(1) ) ELSE ETA2 = 1.D0 + ETADSN * RHOF( OBSLEV(1) ) ENDIF SWEMIS = 1.D0 - WEMIS**2 SWEMIS = (ETA1/ETA2)**2 * SWEMIS WEMIS = MIN( 1.D0, SQRT(1.D0 - SWEMIS) ) C NOW CORRECT ALSO THE OTHER DIRECTION COSINE STHE = SQRT( VEMIS**2 + UEMIS**2 ) STHE2 = SQRT( 1.D0 - WEMIS**2 ) VEMIS = VEMIS/STHE * STHE2 UEMIS = UEMIS/STHE * STHE2 c-changes c CALL OUTPT2 c GOTO 1000 c ENDIF c ENDIF C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> C GENERATE RANDOM WAVELENGTH FOR SINGLE C-PHOTON. CALL RMMAR( RD,1,3 ) WAVELENGTH = 1. / (1/WAVLGL - + RD(1)/(WAVLGL*WAVLGU/(WAVLGU-WAVLGL))) C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> if(amass.lt.5.11d-4) then nx=2 else nx=itype endif c write(moniou,*) itype,nx,amass CALL OUTPT2(nx,I) c CALL OUTPT2(NCT,I) GOTO 1000 7001 CONTINUE cxx ENDIF 1000 CONTINUE RETURN END *CMZ : 19/10/2000 11.44.20 by D. HECK IK3 FZK KARLSRUHE *-- Author : K. BERNLOEHR MPIK HEIDELBERG 15/06/98 C======================================================================= SUBROUTINE CERLDE C----------------------------------------------------------------------- C C(H)ER(ENKOV) L(ONGITUNAL) D(EVELOPMENT FOR) E(LECTRONS & POSITRONS) C C THIS SUBROUTINE IS CALLED FROM CERENK. C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,CEREN2. COMMON /CEREN2/ ACERX,ACERY,CERXOS,CERYOS, * DCERX,DCERXI,DCERY,DCERYI,EPSX,EPSY,FCERX,FCERY, * WL,XCMAX,XCMAXS,XSCATT,YCMAX,YCMAXS,YSCATT, * PHOTCM,XCER,YCER,UEMIS,VEMIS,WEMIS,CARTIM,ZEMIS, * NCERX,NCERY,ICERML DOUBLE PRECISION ACERX,ACERY,CERXOS(20),CERYOS(20), * DCERX,DCERXI,DCERY,DCERYI,EPSX,EPSY,FCERX,FCERY, * WL,XCMAX,XCMAXS,XSCATT,YCMAX,YCMAXS,YSCATT DOUBLE PRECISION PHOTCM,XCER,YCER,UEMIS,VEMIS,WEMIS,CARTIM,ZEMIS INTEGER NCERX,NCERY,ICERML *KEEP,LONGI. COMMON /LONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG, * SDLONG,SELONG,SPLONG,THSTEP,THSTPI, * LHEIGH,NSTEP,LLONGI,FLGFIT DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9), * APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9), * HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9), * SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI INTEGER LHEIGH,NSTEP LOGICAL LLONGI,FLGFIT *KEEP,STACKE. COMMON /STACKE/ E,TIM,U,V,W,X,Y,Z,DNEAR, * ZAP,WAP,WA, * IQ,IGEN,IR,IOBS,LPCTE,NP DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60), * X(60),Y(60),Z(60),DNEAR(60) * ,ZAP(60),WAP(60),WA(60) INTEGER IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP *KEND. INTEGER I1,LPCT1 SAVE C----------------------------------------------------------------------- C IF STARTING POINT IS BELOW LOWEST LEVEL THEN DON'T CHECK. IF ( HLONG(NSTEP) .LE. ZEMIS ) THEN C FIND FIRST THE EQUIVALENT LEVELS LPCT1 = LPCTE(NP) C ZEMIS IS ONLY LITTLE BELOW Z OLD, THEREFORE INCREMENTAL SEARCH. C (REMEMBER: LPCTE IS AT START OF ELECTRON STEP) DO 6002 I1 = LPCT1,NSTEP IF ( HLONG(I1) .LT. ZEMIS ) GOTO 6003 6002 CONTINUE I1 = NSTEP + 1 6003 CONTINUE C PHOTONS ENTER THE VERTICAL DISTRIBUTION ONLY IN THE STEP WHERE THEY C WERE EMITTED. THIS IS FAR MORE EFFICIENT THAN OLD, INTEGRATED MODE. PLONG(I1,9) = PLONG(I1,9) + PHOTCM ENDIF RETURN END *CMZ : 19/10/2000 11.45.12 by D. HECK IK3 FZK KARLSRUHE *-- Author : K. BERNLOEHR MPIK HEIDELBERG 15/06/98 C======================================================================= SUBROUTINE CERLDH C----------------------------------------------------------------------- C C(H)ER(ENKOV) L(ONGITUNAL) D(EVELOPMENT FOR) H(ADRONS & MUONS) C C THIS SUBROUTINE IS CALLED FROM CERENK. C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,CEREN2. COMMON /CEREN2/ ACERX,ACERY,CERXOS,CERYOS, * DCERX,DCERXI,DCERY,DCERYI,EPSX,EPSY,FCERX,FCERY, * WL,XCMAX,XCMAXS,XSCATT,YCMAX,YCMAXS,YSCATT, * PHOTCM,XCER,YCER,UEMIS,VEMIS,WEMIS,CARTIM,ZEMIS, * NCERX,NCERY,ICERML DOUBLE PRECISION ACERX,ACERY,CERXOS(20),CERYOS(20), * DCERX,DCERXI,DCERY,DCERYI,EPSX,EPSY,FCERX,FCERY, * WL,XCMAX,XCMAXS,XSCATT,YCMAX,YCMAXS,YSCATT DOUBLE PRECISION PHOTCM,XCER,YCER,UEMIS,VEMIS,WEMIS,CARTIM,ZEMIS INTEGER NCERX,NCERY,ICERML *KEEP,LONGI. COMMON /LONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG, * SDLONG,SELONG,SPLONG,THSTEP,THSTPI, * LHEIGH,NSTEP,LLONGI,FLGFIT DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9), * APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9), * HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9), * SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI INTEGER LHEIGH,NSTEP LOGICAL LLONGI,FLGFIT *KEND. INTEGER I1,I2,II SAVE C----------------------------------------------------------------------- C IF STARTING POINT BELOW LOWEST LEVEL THEN DON'T CHECK IF ( HLONG(NSTEP) .LE. ZEMIS ) THEN C FIND FIRST THE EQUIVALENT LEVELS I1 = 0 I2 = NSTEP 6001 CONTINUE II = (I1+I2)/2 IF ( HLONG(II) .LT. ZEMIS ) THEN I2 = II ELSE I1 = II ENDIF IF ( I2-I1 .GT. 1 ) GOTO 6001 C PHOTONS ENTER THE VERTICAL DISTRIBUTION ONLY IN THE STEP WHERE THEY C WERE EMITTED. THIS IS FAR MORE EFFICIENT THAN OLD, INTEGRATED MODE. PLONG(I2,9) = PLONG(I2,9) + PHOTCM ENDIF RETURN END *CMZ : 18/12/2001 11.46.20 by D. HECK IK FZK KARLSRUHE *-- Author : F. SCHROEDER UNI WUPPERTAL 30/06/99 C======================================================================= DOUBLE PRECISION FUNCTION DISTIP(THEAP,HEAPP) C----------------------------------------------------------------------- C DIST(ANCE) I(NTER)P(OLATION) C C DETERMINES CHANGE IN DISTANCE FROM SHOWER CORE BY INTERPOLATING C BETWEEN VALUES OF A TWO DIMENSIONAL TABLE TAKING INTO ACCOUNT BENDING C OF THE CHERENKOV LIGHT IN CURVED ATMOSPHERE. C THIS FUNCTION IS CALLED FROM CERENK. C ARGUMENTS: C THEAP = COSINE OF EMISSION ANGLE IN DEG OF CHERENKOV PHOTON C SEEN FROM THE DETECTOR C HEAPP = EMISSION HEIGHT IN CM OF CHERENKOV PHOTON C SEEN FROM THE DETECTOR IN CM C C DESIGN : F. SCHROEDER UNI WUPPERTAL C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,OBSPAR. COMMON /OBSPAR/ OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP, * THETPR,PHIPR, * VUECON, * NOBSLV DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10), * HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2) DOUBLE PRECISION VUECON(2) INTEGER NOBSLV *KEEP,RTABLE, IF=CURVED. COMMON /RTABLE/ DISTEF, TOF INTEGER MHEIGH,NTHETA PARAMETER ( MHEIGH = 453 ) ! NUMBER OF VALUES IN HEIGHT PARAMETER ( NTHETA = 361 ) ! NUMBER OF VALUES IN THETA DOUBLE PRECISION DISTEF(NTHETA,MHEIGH),TOF(NTHETA,MHEIGH) *KEND. DOUBLE PRECISION ADIST,BDIST,B,FACT,HEAPP,HEAPP2,HM,HM1,OBS, * THEAP,THEAP2,THN,THN1 INTEGER M,M1,M2,N,N1,N2 LOGICAL FIRST SAVE DATA FIRST /.TRUE. / C----------------------------------------------------------------------- IF ( FIRST ) THEN FACT = 90.D0/ACOS(0.D0) FIRST = .FALSE. C TRANSFORM OBSLEV(1) IN UNITS OF KM OBS = OBSLEV(1) * 1.D-5 ENDIF C TRANSFORM INPUT PARAMETERS IN BETTER UNITS THEAP2 = ACOS( THEAP ) * FACT * 4.D0 ! NOW THETA IN DEG*4 HEAPP2 = HEAPP * 1.D-5 * 4.D0 ! AND HEIGHT IN KM*4 C DISTIP = DISTIP(THEAP, HEAPP) = DISTEF(N, M) (N*M-MATRIX) C MONOTONIC ASCENDING ORDER: C THEAP: [0- 90] DEG => THEAP(1) = 0 DEG, THEAP(NTHETA) = 90 DEG C HEAPP: [0-113] KM => HEAPP(1) = 0 KM, HEAPP(MHEIGH) = 113 KM C GET NUMBERS (APPARENT THETA) (N-1,N) WHICH ARE NEAREST TO THEAP N2 = INT(THEAP2) N1 = N2 + 1 N = N2 + 2 C GET NUMBERS (APPARENT HEIGHT) (M-1,M) WHICH ARE NEAREST TO HEAPP M2 = INT(HEAPP2) M1 = M2 + 1 M = M2 + 2 C NOW PERFORM LINEAR INTERPOLATION OF DISTEF BETWEEN TABULATED VALUES C HEAPP(M) = (M-1) [KM] C THEAP(N) = (N-1) [DEG] THN = DBLE(N1) THN1 = DBLE(N2) HM = DBLE(M1) HM1 = DBLE(M2) IF ( HM1 .LT. OBS ) HM1 = OBS C INTERPOLATE BETWEEN DISTEF(N-1, M-1) AND DISTEF(N-1,M) B = ( DISTEF(N1, M) - DISTEF(N1, M1) ) / ( HM - HM1 ) ADIST = B * ( HEAPP2 - HM1 ) + DISTEF(N1,M1) C INTERPOLATE BETWEEN DISTEF(N, M-1) AND DISTEF(N,M) B = ( DISTEF(N, M) - DISTEF(N, M1) ) / ( HM - HM1 ) BDIST = B * ( HEAPP2 - HM1 ) + DISTEF(N,M1) C INTERPOLATE BETWEEN ADIST=DISTEF(N-1,M_MEAN) C AND BDIST=DISTEF(N,M_MEAN) B = ( BDIST - ADIST ) / ( THN - THN1 ) DISTIP = B * ( THEAP2 - THN1 ) + ADIST RETURN END *CMZ : 28/02/2002 13.08.20 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE GETBUS( IPARTI,ENERGYP,THETAP,CERSZE ) C----------------------------------------------------------------------- C GET BU(NCH) S(IZE) C C CALCULATES OPTIMAL BUNCH SIZE FOR CHERENKOV PHOTONS. CHERENKOV PHOTONS C ARE GROUPED IN BUNCHES IN ORDER TO ACCELERATE COMPUTING TIME. C HOWEVER, WE SET A MAXIMAL VALUE FOR THE GROUPING OF CHERENKOV PHOTONS C SO THAT WE GET AT LEAST 100 BUNCHES/M**2 AT A CHERENKOV FLUX OF 3000 C PHOTONS/M**2. THIS IS THE MINIMUM CHERENKOV FLUX WHICH CAN BE C DISTINGUISHED FROM THE NIGHT SKY LIGHT BACKGROUND IN THE HEGRA C EXPERIMENT AT THE ISLAND LA PALMA. SO THE PARAMETRIZATION OF THE C CHERENKOV BUNCH AS CALCULATED IN THIS SUBROUTINE IS VALID FOR C OBSERVATION LEVELS SIMILAR TO THAT OF THE HEGRA EXPERIMENT. C FOR A GIVEN PRIMARY PARTICLE, INCIDENT ENERGY AND ANGLE, AN C OPTIMAL BUNCH SIZE IS CALCULATED BY INTERPOLATION IN A TABLE, C WHERE WE HAVE CHOSEN AN ENERGY RANGE UP TO 1000 TEV, INCIDENT C ANGLES 0 AND 40 DEGREES, AND 4 TYPES OF PRIMARIS: GAMMAS, C PROTONS, NITROGEN, AND IRON. C THIS SUBROUTINE IS CALLED FROM AAMAIN. C ARGUMENTS: C IPARTI = TYPE OF PRIMARY PARTICLE C ENERGYP= PARTICLES ENERGY IN GEV C THETAP = ANGLE IN RAD C CERSZE = SIZE OF CHERENKOV BUNCH C C AUTHORS : S. MARTINEZ UNIVERSITY OF MADRID C F. ARQUEROS UNIVERSITY OF MADRID C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DOUBLE PRECISION ANGLE(2),ENGAM(3),ENHAD(3),ENNIT(2), * SIFE(3,2),SIGAM(3,2),SINIT(2),SIPRO(3,2) DOUBLE PRECISION CERSZE,ENERGY,ENERGYP,THETA,THETAP DOUBLE PRECISION CERS1F,CERS1P,S1,S2 INTEGER I,IANFE,IANP,IATNUM,IPARTI,I1,I2 DATA ANGLE / 0.D0, 40.D0 / DATA ENGAM / 100.D0, 200.D0, 500.D0 / DATA ENHAD / 100.D0, 200.D0, 1000.D0 / DATA ENNIT / 200.D0, 1000.D0 / DATA ( SIFE (I,1),I=1,3 ) / 30.D0, 30.D0, 140.D0 / DATA ( SIFE (I,2),I=1,3 ) / 30.D0, 30.D0, 110.D0 / DATA ( SIGAM(I,1),I=1,3 ) / 30.D0, 45.D0, 100.D0 / DATA ( SIGAM(I,2),I=1,3 ) / 30.D0, 40.D0, 100.D0 / DATA SINIT / 30.D0, 150.D0 / DATA ( SIPRO(I,1),I=1,3 ) / 30.D0, 30.D0, 120.D0 / DATA ( SIPRO(I,2),I=1,3 ) / 30.D0, 30.D0, 160.D0 / DATA IANP / 1 /, IANFE / 26 / C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,100) IPARTI,ENERGYP,THETAP 100 FORMAT(' GETBUS: INPUT PARTICLE = ',I5,1P,2E10.3) C DEFAULT VALUE CERSZE = 100.D0 ENERGY = 1.D-3*ENERGYP IF ( ENERGY .LE. 100.D0 ) THEN CERSZE = 30.D0 IF ( DEBUG ) WRITE(MDEBUG,101) CERSZE RETURN ENDIF THETA = THETAP / PI * 180.D0 C----------------------------------------------------------------------- C PHOTON, ELECTRON OR POSITRON AS PRIMARY PARTICLE IF ( IPARTI .LE. 3 ) THEN C FIND ENERGY BIN FOR INTERPOLATION IF ( ENERGY .LE. ENGAM(2) ) THEN I1 = 1 I2 = 2 ELSE I1 = 2 I2 = 3 ENDIF S1 = SIGAM(I1,1) + (ENERGY - ENGAM(I1)) * / (ENGAM(I2) - ENGAM(I1)) * * (SIGAM(I2,1) - SIGAM(I1,1)) S2 = SIGAM(I1,2) + (ENERGY - ENGAM(I1)) * / (ENGAM(I2) - ENGAM(I1)) * * (SIGAM(I2,2) - SIGAM(I1,2)) CERSZE = S1 + (THETA-ANGLE(1))/(ANGLE(2)-ANGLE(1)) * (S2-S1) IF ( DEBUG ) WRITE(MDEBUG,101) CERSZE RETURN ENDIF C----------------------------------------------------------------------- C NITROGEN AS PRIMARY PARTICLE AND VERTICAL INCIDENCE CJOK WHY SPECIAL TREATMENT FOR NITROGEN ???? CJOK WHY ONLY VERTICAL INCIDENCE ???? IF ( IPARTI .EQ. 1407 .AND. ABS(THETA) .LT. 1.D-1 ) THEN IF ( ENERGY .LT. 200.D0 ) THEN CERSZE = 30.D0 ELSE CERSZE = SINIT(1) + (ENERGY-ENNIT(1)) * / (ENNIT(2)-ENNIT(1)) * (SINIT(2)-SINIT(1)) ENDIF IF ( DEBUG ) WRITE(MDEBUG,101) CERSZE RETURN ENDIF C----------------------------------------------------------------------- C GET THE ATOMIC NUMBER OF THE NUCLEUS C Z IS 1, IF PROTON IF ( IPARTI .EQ. 14 ) THEN IATNUM = 1 C REST OF POSSIBLE NUCLEI ELSEIF ( IPARTI .GT. 100 ) THEN IATNUM = MOD(IPARTI,100) IF ( IATNUM .GT. 26 ) THEN WRITE(MONIOU,*) 'GETBUS: UNEXPECTED PARTICLE CODE',IPARTI RETURN ENDIF ELSE WRITE(MONIOU,*) 'GETBUS: UNEXPECTED PARTICLE CODE',IPARTI RETURN ENDIF C FIND ENERGY BIN FOR INTERPOLATION IN CASE OF HADRONIC PRIMARY IF ( ENERGY .LE. ENHAD(2) ) THEN I1 = 1 I2 = 2 ELSE I1 = 2 I2 = 3 ENDIF C INTERPOLATION FOR HADRONS S1 = SIPRO(I1,1) + (ENERGY-ENHAD(I1)) * / (ENHAD(I2)-ENHAD(I1)) * (SIPRO(I2,1)-SIPRO(I1,1)) S2 = SIPRO(I1,2) + (ENERGY-ENHAD(I1)) * / (ENHAD(I2)-ENHAD(I1)) * (SIPRO(I2,2)-SIPRO(I1,2)) CERS1P = S1 + (THETA-ANGLE(1)) / (ANGLE(2)-ANGLE(1)) * (S2-S1) S1 = SIFE(I1,1) + (ENERGY-ENHAD(I1)) / (ENHAD(I2)-ENHAD(I1)) * * (SIFE(I2,1)-SIFE(I1,1)) S2 = SIFE(I1,2) + (ENERGY-ENHAD(I1)) / (ENHAD(I2)-ENHAD(I1)) * * (SIFE(I2,2)-SIFE(I1,2)) CERS1F = S1 + (THETA-ANGLE(1)) / (ANGLE(2)-ANGLE(1)) * (S2-S1) CERSZE = CERS1P + (IATNUM-IANP) * (CERS1F-CERS1P) / (IANFE-IANP) IF ( DEBUG ) WRITE(MDEBUG,101) CERSZE 101 FORMAT(' GETBUS: BUNCH SIZE = ',1P,1E10.3) RETURN END *CMZ : 14/09/2000 08.40.31 by D. HECK IK3 FZK KARLSRUHE *-- Author : F. SCHROEDER UNI WUPPERTAL 09/04/99 C======================================================================= SUBROUTINE INRTAB C----------------------------------------------------------------------- C IN(IT) R(EFRACTION) TAB(LE) C C INITIALIZES TABLE FOR INTERPOLATION OF DISTANCE FROM SHOWER CORE C AND TIME OF FLIGHT OF THE CHERENKOV PHOTON C NUMERICAL CALCULATION OF DISTANCE FROM SHOWER CORE AND TIME OF FLIGHT C FOR DISCRETE ZENITH ANGLES AND HEIGHT DIFFERENCES TAKING INTO ACCOUNT C BENDING OF THE CHERENKOV LIGHT IN A CURVED ATMOSPHERE C THIS SUBROUTINE IS CALLED FROM INPRM. C ARGUMENTS: C OBS = HEIGHT OF OBSERVATION LEVEL IN CM C C DESIGN : F. SCHROEDER UNI WUPPERTAL C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,CONSTA. COMMON /CONSTA/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,OBSPAR. COMMON /OBSPAR/ OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP, * THETPR,PHIPR, * VUECON, * NOBSLV DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10), * HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2) DOUBLE PRECISION VUECON(2) INTEGER NOBSLV *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEEP,RTABLE, IF=CURVED. COMMON /RTABLE/ DISTEF, TOF INTEGER MHEIGH,NTHETA PARAMETER ( MHEIGH = 453 ) ! NUMBER OF VALUES IN HEIGHT PARAMETER ( NTHETA = 361 ) ! NUMBER OF VALUES IN THETA DOUBLE PRECISION DISTEF(NTHETA,MHEIGH),TOF(NTHETA,MHEIGH) *KEEP,ATMOSX. C EXTERNAL ATMOSPHERIC MODELS COMMON /ATMOSX/ IATMOX,FREFRX INTEGER IATMOX LOGICAL FREFRX *KEND. DOUBLE PRECISION DDIST,DHAPP,DHELP,DLEN,DT,ETADSN,HE,HAPPST,HEAPP, * HST,HSTM,HSTOLD,R,RHE, * RHST,RHSTM,THEAP,THAPP1,THAPP2,VLIGHTI INTEGER I,M,N,NSTEPS SAVE DOUBLE PRECISION REFIDX EXTERNAL REFIDX DOUBLE PRECISION RHOF EXTERNAL RHOF C NUMBER OF STEPS FOR NUMERIC INTEGRATION DATA NSTEPS/ 1000 / C----------------------------------------------------------------------- ETADSN = 0.00028232D0 / RHOF(0.D0) C INVERSE OF VELOCITY OF LIGHT IN CM/NS VLIGHTI = 1.D9/C(25) C EARTH RADIUS IN CM R = C(1) C DISTEF = DISTEF(THEAP, HEAPP) = DISTEF(N, M) (N*M-MATRIX) C TOF = TOF(THEAP, HEAPP) = TOF(N, M) (N*M-MATRIX) C MONOTONIC ASCENDING ORDER: C THEAP: [0- 90] DEG => THEAP(1) = 0 DEG, THEAP(NTHETA) = 90 DEG C HEAPP: [0-113] KM => HEAPP(1) = 0 KM, HEAPP(MHEIGH) = 113 KM C THEAP = EMISSION ANGLE OF CHERENKOV PHOTON SEEN FROM THE DETECTOR C HEAPP = EMISSION HEIGHT OF CHERENKOV PHOTON SEEN FROM THE DETECTOR DO N = 1, NTHETA DO M = 1, MHEIGH C APPARENT EMISSION ANGLE IN RAD * 1/4 THEAP = DBLE(N-1) * .25D0 * PI / 180.D0 C APPARENT EMISSION HEIGHT IN CM * 1/4 HEAPP = DBLE(M-1) * .25D0 * 1.D5 IF ( HEAPP .LE. OBSLEV(1) .OR. * THEAP .GT. 89.0D0*PI/180.D0 ) THEN DISTEF(N,M) = 0.D0 ! NO CALCULATION OF DISTEF AND TOF TOF(N, M) = 0.D0 ! IF EMISSION HEIGHT IS UNDER GOTO 100 ! OBSERVATION LEVEL ENDIF C LOCAL EMISSION HEIGHT FOR INDEX OF REFRACTION DHELP = (HEAPP-OBSLEV(1)) * TAN(THEAP) HE = -R + SQRT( DHELP**2 + (R+HEAPP)**2 ) IF ( IATMOX .GE. 1 ) THEN RHE = REFIDX( HE ) ELSE RHE = 1.D0 + ETADSN * RHOF(HE) ENDIF C SMALL CHANGE IN HEAPP FOR NUMERICAL INTEGRATION DHAPP = (HEAPP-OBSLEV(1))/DBLE(NSTEPS) C START VALUES FOR NUMERICAL INTEGRATION C PERFORM CALCULATION IN APPARENT COORDINATES + LOCAL HEIGHT C FOR THE INDEX OF REFRACTION HST = HE HAPPST = HEAPP THAPP2 = THEAP DISTEF(N,M) = 0.D0 TOF(N, M) = 0.D0 DO I = 1, NSTEPS HAPPST = HAPPST - DHAPP DHELP = (HAPPST-OBSLEV(1)) * TAN(THAPP2) HSTOLD = HST HST = -R + SQRT( DHELP**2 + (R+HAPPST)**2 ) HSTM = HST + 0.5D0 * (HSTOLD-HST) IF ( IATMOX .GE. 1 ) THEN RHST = REFIDX( HST ) RHSTM = REFIDX( HSTM ) ELSE RHST = 1.D0 + ETADSN * RHOF(HST) RHSTM = 1.D0 + ETADSN * RHOF(HSTM) ENDIF THAPP1 = THAPP2 THAPP2 = ASIN( RHE/RHST * SIN(THEAP) ) DDIST = DHAPP * TAN(0.5D0*(THAPP1 + THAPP2)) DLEN = DHAPP / COS(0.5D0*(THAPP1 + THAPP2)) DT = DLEN * RHSTM * VLIGHTI DISTEF(N, M) = DISTEF(N,M) + DDIST TOF(N, M) = TOF(N, M) + DT ENDDO 100 CONTINUE ENDDO ENDDO RETURN END *CMZ : 18/10/2000 09.15.12 by D. HECK IK3 FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE OUTND2 C----------------------------------------------------------------------- C OUT(PUT AT E)ND (OF SHOWER) C C WRITE REST OF PARTICLES TO OUTPUT BUFFER C THIS SUBROUTINE IS CALLED FROM AAMAIN. C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,CEREN2. COMMON /CEREN2/ ACERX,ACERY,CERXOS,CERYOS, * DCERX,DCERXI,DCERY,DCERYI,EPSX,EPSY,FCERX,FCERY, * WL,XCMAX,XCMAXS,XSCATT,YCMAX,YCMAXS,YSCATT, * PHOTCM,XCER,YCER,UEMIS,VEMIS,WEMIS,CARTIM,ZEMIS, * NCERX,NCERY,ICERML DOUBLE PRECISION ACERX,ACERY,CERXOS(20),CERYOS(20), * DCERX,DCERXI,DCERY,DCERYI,EPSX,EPSY,FCERX,FCERY, * WL,XCMAX,XCMAXS,XSCATT,YCMAX,YCMAXS,YSCATT DOUBLE PRECISION PHOTCM,XCER,YCER,UEMIS,VEMIS,WEMIS,CARTIM,ZEMIS INTEGER NCERX,NCERY,ICERML *KEEP,CEREN3. COMMON /CEREN3/ CERCNT,DATAB2,NRECER,LHCER INTEGER MAXBF2 PARAMETER ( MAXBF2 = 39 * 7 ) DOUBLE PRECISION CERCNT REAL DATAB2(MAXBF2) INTEGER NRECER,LHCER *KEND. INTEGER I C----------------------------------------------------------------------- IF ( LHCER .GT. 0 ) THEN IF ( FPAROUT ) CALL TOBUFC( DATAB2,0 ) C CLEAR DATAB2 BUFFER DO 2 I = 1,MAXBF2 DATAB2(I) = 0. 2 CONTINUE ENDIF LHCER = 0 WRITE(MONIOU,*) 'CERCNT = ',SNGL( CERCNT ) CERCNT = 0.D0 RETURN END *CMZ : 28/02/2002 12.41.48 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE OUTPT2(J,IMOV) c---changed--name C----------------------------------------------------------------------- C (WRITE CHERENKOV RADIATION) OUTP(U)T C C OUTPUT SUBROUT. FOR CHERENKOV PHOTONS C THIS SUBROUTINE IS CALLED FROM CERENK. C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,BUFFS. COMMON /BUFFS/ RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH INTEGER MAXBUF,MAXLEN PARAMETER (MAXLEN=16) PARAMETER (MAXBUF=39*7) REAL RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF), * RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF) INTEGER LH CHARACTER*4 CRUNH,CRUNE,CEVTH,CEVTE,CLONG EQUIVALENCE (RUNH(1),CRUNH), (RUNE(1),CRUNE) EQUIVALENCE (EVTH(1),CEVTH), (EVTE(1),CEVTE) EQUIVALENCE (ARRAYLONG(1),CLONG) *KEEP,EGSDEB. COMMON /EGSDEB/ JCLOCK,NCLOCK,FEGSDB INTEGER JCLOCK,NCLOCK LOGICAL FEGSDB *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,CEREN1. COMMON /CEREN1/ CERELE,CERHAD,ETADSN,WAVLGL,WAVLGU,CYIELD, * CERSIZ,CERNOR,LCERFI DOUBLE PRECISION CERELE,CERHAD,ETADSN,WAVLGL,WAVLGU,CYIELD, * CERSIZ,CERNOR LOGICAL LCERFI *KEEP,CEREN2. COMMON /CEREN2/ ACERX,ACERY,CERXOS,CERYOS, * DCERX,DCERXI,DCERY,DCERYI,EPSX,EPSY,FCERX,FCERY, * WL,XCMAX,XCMAXS,XSCATT,YCMAX,YCMAXS,YSCATT, * PHOTCM,XCER,YCER,UEMIS,VEMIS,WEMIS,CARTIM,ZEMIS, * NCERX,NCERY,ICERML DOUBLE PRECISION ACERX,ACERY,CERXOS(20),CERYOS(20), * DCERX,DCERXI,DCERY,DCERYI,EPSX,EPSY,FCERX,FCERY, * WL,XCMAX,XCMAXS,XSCATT,YCMAX,YCMAXS,YSCATT DOUBLE PRECISION PHOTCM,XCER,YCER,UEMIS,VEMIS,WEMIS,CARTIM,ZEMIS INTEGER NCERX,NCERY,ICERML *KEEP,CEREN3. COMMON /CEREN3/ CERCNT,DATAB2,NRECER,LHCER INTEGER MAXBF2 PARAMETER ( MAXBF2 = 39 * 7 ) DOUBLE PRECISION CERCNT REAL DATAB2(MAXBF2) INTEGER NRECER,LHCER *KEND. c-----changed-add c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> COMMON /GRAAL1/ WAVELENGTH ! (NM) REAL WAVELENGTH c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> *KEND. INTEGER J,IMOV cxx-------------------- c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> c-----changed-add INTEGER I LOGICAL ROUT SAVE C----------------------------------------------------------------------- IF ( FEGSDB ) WRITE(MDEBUG,3) * PHOTCM,XCER,YCER,UEMIS,VEMIS,CARTIM,ZEMIS 3 FORMAT(' OUTPT2: ',1P,8E10.3) ROUT = .TRUE. C WRITE A BLOCK OF 39 PARTICLES TO THE CHERENKOV OUTPUT BUFFER AND C CLEAR FIELD CERCNT = CERCNT + PHOTCM IF ( LCERFI ) THEN IF ( ROUT ) THEN c------changed--add -adn comand c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> c DATAB2(LHCER+1) = PHOTCM cc DATAB2(LHCER+1) = WAVELENGTH + J*1000. DATAB2(LHCER+1) = J*100000. + IMOV*1000. + WAVELENGTH c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> c------changed--add -adn comand DATAB2(LHCER+2) = XCER DATAB2(LHCER+3) = YCER DATAB2(LHCER+4) = UEMIS DATAB2(LHCER+5) = VEMIS DATAB2(LHCER+6) = CARTIM DATAB2(LHCER+7) = ZEMIS LHCER = LHCER + 7 IF ( LHCER .GE. MAXBF2 ) THEN IF ( FPAROUT ) CALL TOBUFC( DATAB2,0 ) DO 1 I = 1,MAXBF2 DATAB2(I) = 0. 1 CONTINUE LHCER = 0 ENDIF ENDIF ELSE C WRITE A BLOCK OF 39 PARTICLES TO THE PARTICLE OUTPUT BUFFER AND C CLEAR FIELD IF ( ROUT ) THEN DATAB(LH+1) = 99.E5 + NINT(PHOTCM)*10. + 1. DATAB(LH+2) = XCER DATAB(LH+3) = YCER DATAB(LH+4) = UEMIS DATAB(LH+5) = VEMIS DATAB(LH+6) = CARTIM DATAB(LH+7) = ZEMIS LH = LH + 7 NOPART = NOPART + 1 IF ( LH .GE. MAXBUF ) THEN IF ( FPAROUT ) CALL TOBUF( DATAB,0 ) DO 2 I = 1,MAXBUF DATAB(I) = 0. 2 CONTINUE LH = 0 ENDIF ENDIF ENDIF RETURN END *CMZ : 25/04/2001 09.21.09 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 06/10/95 C======================================================================= SUBROUTINE SELCOR(XX,YY) C----------------------------------------------------------------------- C SEL(ECT) COR(E LOCATION) C C SELECT A QUASI RANDOM CORE LOCATION C THIS SUBROUTINE IS CALLED FROM INPRM. C ARGUMENTS: C XX = X-VALUE OF QUASI-RANDOM CORE LOCATION C YY = Y-VALUE OF QUASI-RANDOM CORE LOCATION C C DESIGN : J. KNAPP IK1 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,CEREN2. COMMON /CEREN2/ ACERX,ACERY,CERXOS,CERYOS, * DCERX,DCERXI,DCERY,DCERYI,EPSX,EPSY,FCERX,FCERY, * WL,XCMAX,XCMAXS,XSCATT,YCMAX,YCMAXS,YSCATT, * PHOTCM,XCER,YCER,UEMIS,VEMIS,WEMIS,CARTIM,ZEMIS, * NCERX,NCERY,ICERML DOUBLE PRECISION ACERX,ACERY,CERXOS(20),CERYOS(20), * DCERX,DCERXI,DCERY,DCERYI,EPSX,EPSY,FCERX,FCERY, * WL,XCMAX,XCMAXS,XSCATT,YCMAX,YCMAXS,YSCATT DOUBLE PRECISION PHOTCM,XCER,YCER,UEMIS,VEMIS,WEMIS,CARTIM,ZEMIS INTEGER NCERX,NCERY,ICERML *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DOUBLE PRECISION RND(2),XX,YY INTEGER I LOGICAL FIRST SAVE DATA FIRST /.TRUE./ C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'SELCOR:' C INITIALIZE SOBOL NUMBER GENERATOR IF ( FIRST ) THEN FIRST = .FALSE. CALL SOBSEQ(-2,RND) C CALL THE RANDOM GENERATOR MANY TIMES ACCORDING SEED OF THIRD SEQUENCE C TO PREVENT STARTING WITH IDENTICAL NUMBER FOR DIFFERENT RUNS DO I = 1,ISEED(1,3) CALL SOBSEQ(1,RND) ENDDO ENDIF C TAKE A PAIR OF QUASI RANDOM NUMBERS CALL SOBSEQ(2,RND) c--------change XX = ySCATT * (2.D0*RND(1)-1.D0) YY = YSCATT * (2.D0*RND(2)-1.D0) IF (DEBUG) WRITE(MDEBUG,*) 'SELCOR: CORE LOCATION X=',XX,' Y=',YY RETURN END *CMZ : 25/04/2001 09.21.09 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 06/10/95 C======================================================================= SUBROUTINE SOBSEQ(N,XX) C----------------------------------------------------------------------- C SOB(OL) SEQ(UENCE) C C SOBOL QUASI RANDOM NUMBER GENERATOR C REFERENCE : NUMERICAL RECIPES, W.H. PRESS ET AL., C CAMBRIDGE UNIVERSITY PRESS, 1992 ISBN 0 521 43064 X C THIS SUBROUTINE IS CALLED FROM SELCOR. C ARGUMENTS: C N = NUMBER OF QUASI-RANDOM NUMBERS C XX = ARRAY CONTAINING THE RANDOM NUMBERS C C THIS ROUTINE USES `LOGICAL AND' AND `EXCLUSIVE OR' SYSTEM FUNCTIONS C `IAND' AND `IEOR' WHICH ARE NON-STANDARD FORTRAN FUNCTIONS !! C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEND. DOUBLE PRECISION XX(*),FAC INTEGER N,MAXBIT,MAXDIM PARAMETER ( MAXBIT = 30, MAXDIM = 6 ) INTEGER I,IM,IN,IPP,J,K,L,IP(MAXDIM),IU(MAXDIM,MAXBIT), * IV(MAXBIT*MAXDIM),IX(MAXDIM),MDEG(MAXDIM) EQUIVALENCE (IV,IU) SAVE DATA IP /0,1,1,2,1,4/, MDEG /1,2,3,3,4,4/, IX /6*0/, * IV /6*1,3,1,3,3,1,1,5,7,7,3,3,5,15,11,5,15,13,9, * 156*0/ C----------------------------------------------------------------------- IF ( N .LT. 0 ) THEN DO 14 K = 1,MAXDIM DO 11 J = 1,MDEG(K) IU(K,J) = IU(K,J)*2**(MAXBIT-J) 11 CONTINUE DO 13 J = MDEG(K)+1,MAXBIT IPP = IP(K) I = IU(K,J-MDEG(K)) C IEOR IS A NON-STANDARD FORTRAN SYSTEM FUNCTION MAKING `EXCLUSIVE OR' I = IEOR(I,I/2**MDEG(K)) DO 12 L = MDEG(K)-1,1,-1 C IAND IS A NON-STANDARD FORTRAN SYSTEM FUNCTION MAKING `LOGICAL AND' IF ( IAND(IPP,1) .NE. 0 ) I = IEOR(I,IU(K,J-L)) IPP = IPP/2 12 CONTINUE IU(K,J) = I 13 CONTINUE 14 CONTINUE FAC = 1.D0/(2.D0**MAXBIT) IN = 0 ELSE IM = IN DO 15 J = 1,MAXBIT C IAND IS A NON-STANDARD FORTRAN SYSTEM FUNCTION MAKING `LOGICAL AND' IF ( IAND(IM,1) .EQ. 0 ) GOTO 1 IM = IM/2 15 CONTINUE WRITE(MONIOU,*)'MAXBIT =',MAXBIT,' TOO SMALL IN SOBSEQ' STOP 1 IM = (J-1)*MAXDIM DO 16 K = 1,MIN(N,MAXDIM) C IEOR IS A NON-STANDARD FORTRAN SYSTEM FUNCTION MAKING `EXCLUSIVE OR' IX(K) = IEOR(IX(K),IV(IM+K)) XX(K) = IX(K)*FAC 16 CONTINUE IN = IN+1 ENDIF RETURN END *CMZ : 30/01/2001 17.27.18 by D. HECK IK FZK KARLSRUHE *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE TOBUFC( A,IFL ) C----------------------------------------------------------------------- C (WRITE) TO BUF(FER) C(HERENKOV DATA) C C COPY TO BUFFER CHERENKOV DATA C THIS SUBROUTINE IS CALLED FROM AAMAIN, INPRM, ELECTR, PHOTON, OUTND2, C AND OUTPT2. C ARGUMENTS: C A = ARRAY TO BE WRITTEN TO TAPE C IFL = STARTING OF FINAL OUTPUT C = 0 NORMAL BLOCK C = 1 NORMAL BLOCK WITH END OF OUTPUT C = 2 ONLY END OF OUTPUT C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,BUFFS. COMMON /BUFFS/ RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH INTEGER MAXBUF,MAXLEN PARAMETER (MAXLEN=16) PARAMETER (MAXBUF=39*7) REAL RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF), * RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF) INTEGER LH CHARACTER*4 CRUNH,CRUNE,CEVTH,CEVTE,CLONG EQUIVALENCE (RUNH(1),CRUNH), (RUNE(1),CRUNE) EQUIVALENCE (EVTH(1),CEVTH), (EVTE(1),CEVTE) EQUIVALENCE (ARRAYLONG(1),CLONG) *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I, * STEPFC,NRRUN,NSHOW,MPATAP,MONIIN, * MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT, * MCETAP, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN COMMON /RUNPAC/ DSN,DSNTAB,DSNLONG,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC INTEGER NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC, * ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE,MTABOUT,MLONGOUT INTEGER MCETAP CHARACTER*79 DSN,DSNTAB,DSNLONG CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT, * FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN *KEEP,CEREN3. COMMON /CEREN3/ CERCNT,DATAB2,NRECER,LHCER INTEGER MAXBF2 PARAMETER ( MAXBF2 = 39 * 7 ) DOUBLE PRECISION CERCNT REAL DATAB2(MAXBF2) INTEGER NRECER,LHCER *KEND. C NSUBBL IS NUMBER OF SUBBLOCKS IN ONE OUTPUT RECORD INTEGER NSUBBL PARAMETER ( NSUBBL = 21 ) REAL A(*) C (OUTPUT RECORD LENGTH = NSUBBL * 39 * 7 * 4 BYTES <= 22932 ) C OUTPUT BUFFER FOR CHERENKOV OUTPUT REAL OUTBF2(MAXBF2,NSUBBL) C IBLK2 IS COUNTER FOR SUBBLOCKS OF CHERENKOV OUTPUT INTEGER I,IBLK2,IFL,K SAVE DATA IBLK2 / 0 / C----------------------------------------------------------------------- IF ( IFL .LE. 1 ) THEN IBLK2 = IBLK2 + 1 DO 3 I = 1,MAXBF2 OUTBF2(I,IBLK2) = A(I) 3 CONTINUE ENDIF C WRITE TO TAPE IF BLOCK IS FULL OR IF IFL IS 1 IF ( IFL .GE. 1 .OR. IBLK2 .EQ. NSUBBL ) THEN NRECER = NRECER + 1 c-----changed---add------command cxx WRITE(MCETAP) ((OUTBF2(I,K),I=1,MAXBF2),K=1,NSUBBL) c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> c WRITE(CETAPE) ((OUTBF2(I,K),I=1,MAXBF2),K=1,NSUBBL) call jccersave(outbf2) c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> c-----changed---add------command IBLK2 = 0 DO 4 K = 1,NSUBBL DO 4 I = 1,MAXBF2 OUTBF2(I,K) = 0.0 4 CONTINUE ENDIF RETURN END *CMZ : 14/06/2000 14.14.41 by D. HECK IK3 FZK KARLSRUHE *-- Author : F. SCHROEDER UNI WUPPERTAL 01/07/99 C======================================================================= DOUBLE PRECISION FUNCTION TOFIP(THEAP,HEAPP) C----------------------------------------------------------------------- C T(IME) O(F) F(LIGHT) I(NTER)P(OLATION) C C DETERMINES TIME OF FLIGHT OF CHERENKOV PHOTON BY INTERPOLATING C BETWEEN VALUES OF A TWO DIMENSIONAL TABLE TAKING INTO ACCOUNT C BENDING OF THE CHERENKOV LIGHT IN A CURVED ATMOSPHERE C THIS SUBROUTINE IS CALLED FROM CERENK. C ARGUMENTS: C THEAP = COSINE OF EMISSION ANGLE OF CHERENKOV PHOTON C SEEN FROM THE DETECTOR C HEAPP = EMISSION HEIGHT IN CM OF CHERENKOV PHOTON C SEEN FROM THE DETECTOR C C DESIGN : F. SCHROEDER UNI WUPPERTAL C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,OBSPAR. COMMON /OBSPAR/ OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP, * THETPR,PHIPR, * VUECON, * NOBSLV DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10), * HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2) DOUBLE PRECISION VUECON(2) INTEGER NOBSLV *KEEP,RTABLE, IF=CURVED. COMMON /RTABLE/ DISTEF, TOF INTEGER MHEIGH,NTHETA PARAMETER ( MHEIGH = 453 ) ! NUMBER OF VALUES IN HEIGHT PARAMETER ( NTHETA = 361 ) ! NUMBER OF VALUES IN THETA DOUBLE PRECISION DISTEF(NTHETA,MHEIGH),TOF(NTHETA,MHEIGH) *KEND. DOUBLE PRECISION ATOF,BTOF,B,FACT,HEAPP,HEAPP2,HM,HM1,OBS, * THEAP,THEAP2,THN,THN1 INTEGER M,M1,M2,N,N1,N2 LOGICAL FIRST SAVE DATA FIRST /.TRUE. / C----------------------------------------------------------------------- IF ( FIRST ) THEN FACT = 90.D0/ACOS(0.D0) FIRST = .FALSE. C TRANSFORM ALSO OBSLEV(1) IN UNITS OF KM OBS = OBSLEV(1) * 1.D-5 ENDIF C TRANSFORM INPUT PARAMETERS IN BETTER UNITS THEAP2 = ACOS( THEAP ) * FACT * 4.D0 ! NOW THETA IN DEG*4 HEAPP2 = HEAPP * 1.D-5 * 4.D0 ! AND HEIGHT IN KM*4 C TOF = TOF(THEAP, HEAPP) = TOF(N, M) (N*M-MATRIX) C MONOTONIC ASCENDING ORDER: C THEAP: [0- 90] DEG => THEAP(1) = 0 DEG, THEAP(NTHETA) = 90 DEG C HEAPP: [0-113] KM => HEAPP(1) = 0 KM, HEAPP(MHEIGH) = 113 KM C GET NUMBERS (APPARENT THETA) (N-1,N) WHICH ARE NEAREST TO THEAP N2 = INT(THEAP2) N1 = N2 + 1 N = N2 + 2 C GET NUMBERS (APPARENT HEIGHT) (M-1,M) WHICH ARE NEAREST TO HEAPP M2 = INT(HEAPP2) M1 = M2 + 1 M = M2 + 2 C NOW PERFORM LINEAR INTERPOLATION OF TOF BETWEEN TABULATED VALUES C HEAPP(M) = (M-1) [KM] C THEAP(N) = (N-1) [DEG] THN = DBLE(N1) THN1 = DBLE(N2) HM = DBLE(M1) HM1 = DBLE(M2) IF ( HM1 .LT. OBS ) HM1 = OBS C INTERPOLATE BETWEEN TOF(N-1, M-1) AND TOF(N-1,M) B = ( TOF(N1, M) - TOF(N1, M1) ) / ( HM - HM1 ) ATOF = B * ( HEAPP2 - HM1 ) + TOF(N1,M1) C INTERPOLATE BETWEEN TOF(N, M-1) AND TOF(N,M) B = ( TOF(N, M) - TOF(N, M1) ) / ( HM - HM1 ) BTOF = B * ( HEAPP2 - HM1 ) + TOF(N,M1) C INTERPOLATE BETWEEN ATOF = TOF(N-1,M_MEAN) C AND BTOF = TOF(N,M_MEAN) B = ( BTOF - ATOF ) / ( THN - THN1 ) TOFIP = B * ( THEAP2 - THN1 ) + ATOF RETURN END