C********************************************* C %W% modified on %G% C program Kinematics implicit none C************************************************************************ C @(#)fiducial.cdk 1.1 modified on 12/29/92 real FV common/fidv/FV integer i1 C**** Declare space for any hbook stuff that may be done later integer hmax parameter (hmax=50000) integer hmem(hmax) common /pawc/ hmem C**** Declare a seed value integer iseed data iseed /0/ C**** The File name to read the mc input from. character*132 inpfile C**** The File Name to write the kinematics output to. character*132 outfile C**** The number of arguments on the command line. integer iargc C**** The argument character*132 argv C**** The flux to use integer Use_Flux common /Flux_To_Use/ Use_Flux C**** Flag that only contained events are to be counted. Events outside the C fiducial volume will be generated, but not counted. integer contained common /Contained_Events/ contained C**** The number of files found. integer FileFound fv = 0.0 contained = -1 FileFound = 0 do i1 = 1, iargc() call getarg(i1,argv) if (argv(1:2).eq.'-s') then read(argv(3:132),*) iseed write(6,*) 'seed read from command line:',iseed else if (argv(1:5).eq.'-flux') then read(argv(6:132),*) Use_Flux else if (argv(1:2).eq.'-f') then read(argv(3:132),*) fv write(6,*) 'fiducial distance read from command line:',fv else if (argv(1:2).eq.'-c') then contained = 1 write(6,*) 'only counting contained events.' else FileFound = FileFound + 1 if (FileFound.eq.1) then inpfile = argv write(6,*) 'input file from command line: ',inpfile(1:32) C*** Open up the input file. open(unit=5, $ file = inpfile, $ status='old', $ form='formatted', $ readonly, $ shared) else if (FileFound.eq.2) then outfile = argv write(6,*) 'output file from command line: ',outfile(1:32) C*** Open up the input file. open(unit=6, $ file = outfile, $ status='new', $ form='formatted') endif endif enddo C*** Seed the random number generator if (iseed.eq.0) then call initseed(iseed) type *, 'Using Random Seed',iseed endif call seedranf(iseed) C*** Initialize for hbook. call hlimit(hmax) C*** Generate the events. CALL SPOT close(21) stop end subroutine getarg_parser() implicit none integer i1 C**** The number of arguments in the command line integer nargs C**** The length of the command line integer larg0 C**** The command line character*1024 carg0 C**** The individual arguements integer nchar character*128 cargs(40) common /getarg_common/ nargs, larg0, carg0, cargs data nargs /-1/ data larg0 /0/ C**** The state and states for the parser. integer state, START, HAVEARG, HAVEQUOTE parameter (START=0,HAVEARG=1,HAVEQUOTE=2) if (nargs.ge.0) return C**** Get the command line call lib$get_foreign(carg0,0,larg0) C**** Now Parse it. nargs = 0 do i1 = 1,40 cargs(i1) = ' ' enddo state = START do i1 = 1,larg0 if (state.eq.START) then if (carg0(i1:i1).eq.'''') then nargs = nargs + 1 state = HAVEQUOTE nchar = 0 else if (carg0(i1:i1).ne.' ') then nargs = nargs + 1 state = HAVEARG nchar = 1 cargs(nargs)(nchar:nchar) = carg0(i1:i1) else state = START endif else if (state.eq.HAVEARG) then if (carg0(i1:i1).eq.' ') then state = START else nchar = nchar + 1 cargs(nargs)(nchar:nchar) = carg0(i1:i1) state = HAVEARG endif else if (state.eq.HAVEQUOTE) then if (carg0(i1:i1).eq.'''') then state = START else nchar = nchar + 1 cargs(nargs)(nchar:nchar) = carg0(i1:i1) state = HAVEQUOTE endif endif enddo return end integer function iargc() implicit none C**** The number of arguments in the command line integer nargs C**** The length of the command line integer larg0 C**** The command line character*1024 carg0 C**** The individual arguements integer nchar character*128 cargs(40) common /getarg_common/ nargs, larg0, carg0, cargs call getarg_parser() if (nargs.gt.0) then iargc = nargs else iargc = 0 endif return end subroutine getarg(iarg,carg) implicit none integer i1 C**** The number of arguments in the command line integer nargs C**** The length of the command line integer larg0 C**** The command line character*1024 carg0 C**** The individual arguements integer nchar character*128 cargs(40) common /getarg_common/ nargs, larg0, carg0, cargs C**** The index of the argument to return integer iarg C**** The string of the command argument to return character*(*) carg call getarg_parser() if (iarg.ge.1.and.iarg.le.nargs) then carg = cargs(iarg) do i1 =1,len(carg) if (carg(i1:i1).ge.'A'.and.carg(i1:i1).le.'Z') then carg(i1:i1) = char(ichar(carg(i1:i1)) $ - ichar('A') + ichar('a')) endif enddo else if (iarg.eq.0) then carg = 'COMMAND' else carg = ' ' endif return end C********************************************************************** C Provide a ranf call if there is not a good random number generater C defined. real function ranf() implicit none integer seedranf integer iseed, seed data iseed /987654321/ ranf = ran(iseed) return entry seedranf(seed) iseed = seed return end subroutine INITSEED(iseed) integer ijk(2) call sys$gettim(ijk) iseed = iabs(ijk(1)).or.1 return end C************************************************* C %W% modified on %G% C SUBROUTINE SPOT implicit none integer i1, i2 real r1 C SPOT: C 1) READS THE DATA FROM UNIT=5 C 2) CALLS KINEM FOR EVERY EVENT THAT IS GOING TO BE GENERATED C 3) WRITES THE RESULTS ON UNIT=1 IN BINARY FORM C AND ON UNIT=20 IN FORMATTED FORM C******************************************************************** C C**** The input unit. integer inunit parameter (inunit=5) C*************************************************** C @(#)masses.cdk 1.2 modified on 12/30/92 C The particle masses C PROTON - AMP C NEUTRON - AMN C LAMBDA - AML C SIGMA - AMS C ELECTRON - AMEL C MUON - AMMU C PI 0 - AMPO C PI +/- - AMPC C ETA = AMETA C OMEGA = AMOM C RHO = AMRHO C K 0 = AMKO C K +- = AMKC C K* 0 = AMKSO C K* +- = AMKSC C*** The leptons real AMEL, AMMU C*** The baryons real AMP, AMN, AML, AMS C*** The mesons real AMPO, AMPC, AMETA, AMOMG, AMRHO C*** The strange mesons. real AMKO, AMKC, AMKSO, AMKSC COMMON/MASSES/AMEL,AMMU, $ AMP, AMN, AML, AMS, $ AMPO, AMPC, AMETA, AMRHO, AMOMG, $ AMKO, AMKC, AMKSO, AMKSC C**** The common block with the detector wall positions in it. real HT(3) COMMON/GEO/HT character *60 text character *32 file1,file2 C******************************************************************** C @(#)prdec.cdk 1.1 modified on 12/29/92 C pass information about the initail particls and the desired products. C**** The amass and info about the interaction from spot. real amint, amlep, amd, amm(5) integer np(5), npar, kt COMMON/PRDEC/AMINT,AMLEP,AMD,AMM,NP,NPAR,KT C******************************************************************* C @(#)inter.cdk 1.1 modified on 12/29/92 C the interaction point. C real xint(3) common/inter/xint C**************************************************************** C @(#)momentum.cdk 1.2 modified on 1/12/93 C Include the information about the primary particles to be tracked. C**** The number of momenta. integer nmom C**** The particle 4 momentum. real ppr(4,20) C**** The particle masses real ppm(20) C**** The particle charges real chh(20) C**** The particle id. integer pid(20) COMMON/MOM/ nmom,ppr,ppm,chh,pid C***** Gamma ray information real ppg(4,20) integer ngam common /gamm1/ ppg,ngam integer inot, itrans, idec, inel, iel, iabs, icx common /hadron/inot,itrans,idec,inel,iel,iabs,icx logical fileopen data fileopen /.false./ C**** The number of events to generat integer nev, iev C**** Flag for the event type. integer key C**** Flag for if fermi momentum is generated. integer ifer C**** A mode variable that is not used. integer mode integer moda C**** A random seed to start the program with. integer iseed C**** Flag this run as a test integer ktest C**** Flag that only contained events are to be counted. Events outside the C fiducial volume will be generated, but not counted. integer contained common /Contained_Events/ contained 1000 continue call mcinit C*************************************************************** C NEV IS NUMBER OF EVENTS C KEY IS -3 for atmospheric muon c -2 for thru mu C -1 FOR SINGLE TRACKS C 0 FOR PDK C 1 FOR NU+NUCLEON=LEPTON+DELTA C 2 FOR NU+NUCLEON=LEPTON+PRODUCTS (ONEPI MODEL) C IFER=0 FOR FREE NUCLEONS C =1 FOR NUCLEONS WITH FERMI MOTION C MODE FOR KEY=-1 IRRELEVANT C KEY=0 irrelevant c KEY=1 MODE=0 IF A MIXTURE OF NUEL/NUMU C 10 ',5) else if (i1.lt.npar) then call setcat(text,t1,' + ',3) endif enddo call setcat(text,t1,' **********',11) call setcat(file1,f1,'.dk91',5) call setcat(file2,f2,'.kk91',5) return end subroutine setcat(str1,lst1,str2,lst2) implicit none C**** The string to add the characters to. character*(*) str1 C**** The last character in str1 integer lst1 C**** The string to add to str2. character*(*) str2 C**** The number of characters in str2. integer lst2 C**** some counters. integer i1, i2 C**** The character to istert the string after in str1. integer ins do i1 = 1,lst2 lst1 = lst1 + 1 str1(lst1:lst1) = str2(i1:i1) enddo return end C***************************************************** C @(#)ranve.f 1.1 modified on 12/7/92 SUBROUTINE RANVE(VR,V,Q1,Q2) C C ASSIGNS TO V(3) A RANDOM VECTOR OF LENGTH VR DIMENSION V(3) CT=Q1 PHI=Q2 IF(abs(CT).GT.1.0)CT=2.*ranf()-1. IF(PHI.LT.0..or.phi.gt.6.28318)PHI=6.28318*ranf() ST=SQRT(1.-CT**2) V(1)=VR*ST*COS(PHI) V(2)=VR*ST*SIN(PHI) V(3)=VR*CT RETURN END C******************************************************** C @(#)interpolation.f 1.1 modified on 12/7/92 C Interpolate in 2 dimensions. C C Do a two dimensional interpolation that will work for N dimensions C with N greater than NMax. This uses the save interpolation routine C to get the best value of the function. I would recomend copying this C routine when you want to use it and substituting the best interpolation C routine for the one dimensional interpolations. subroutine interpol2(x1a,x2a,ya,d1,d2,x1,x2,y,dy,int1,int2) implicit none integer i1 real r1 C**** The interpolation functions for the x1 and x2 directions. These should C be either polint or ratint depending on the function. external int1, int2 C**** The dimensions of the arrays. integer d1, d2 C**** The independent coordinates of the function. real x1a(d1), x2a(d2) C**** The dependent values of the function. real ya(d1,d2) C**** The x1 and x2 values to find the function at. real x1, x2 C**** The estimated function at the function value. real y C**** The estimated error at the function value. real dy C**** The maximum number of secondary interpolation values integer MaxD2 parameter (MaxD2=3) C**** The intermediate interpolations values real xt(MaxD2), yt(MaxD2) C**** The number of temporary interpolation values to use. integer NumD2 C**** The offset from the first x2a value to the first one to be used. integer OffD2 C**** Find the index of the nearest x2a to the requested x2. NumD2 = d2 OffD2 = 0 if (NumD2.gt.MaxD2) then NumD2 = MaxD2 call HUNT(X2A,D2,X2,i1) OffD2 = i1 - NumD2/2 if (OffD2+NumD2-1.gt.D2) OffD2 = D2 - NumD2 + 1 if (OffD2.lt.1) OffD2 = 1 OffD2 = OffD2 - 1 endif C**** Fill xt with x2a values that bracket x2 and interpolate to find C function values for the x2a values at x1. dy = 0.0 do i1 = 1, NumD2 xt(i1) = x2a(i1+OffD2) call Int1(x1a,ya(1,i1+OffD2),D1,x1,yt(i1),r1) dy = dy + r1*r1 enddo C**** Use the interpolated yt values for x2a values to interpolate the final C y values. call int2(xt,yt,NumD2,x2,y,r1) dy = dy + r1*r1 dy = sqrt(dy) return end C From Numerical Recipes chap 3.1 c Polynomial interpolation and exterpolation: c Given arrays XA and YA each of length N and given a value c of X, this routine returns a value of Y, and an error estimate c DY. If P(x) is the polynomial of degree n-1 such that c P(XA) = YA, then the returned value Y = P(X) C 2/8/89 - Routine modified to handle arrays N larger than NMAX C SUBROUTINE POLINT(XA,YA,N,X,Y,DY) PARAMETER (NMAX=5, HUGE = 1.E+25) REAL XA(*), YA(*), C(NMAX), D(NMAX) integer NElem NTop = N NOff = 0 if (NTop.gt.NMax) then NTop = NMax C Binary search for the element closest to X. call HUNT(XA,N,X,NElem) NBase = NElem - NTop/2 if (NBase+NTop-1.gt.N) NBase = N - NTop + 1 if (NBase.lt.1) NBase = 1 NOff = NBase - 1 endif NS = 1 DIF = ABS(X-XA(1+NOff)) DO I = 1,NTop DIFT = ABS(X-XA(I+NOff)) IF (DIFT.LT.DIF) THEN NS = I DIF = DIFT ENDIF C(I) = YA(I+NOff) D(I) = YA(I+NOff) ENDDO Y = YA(NS+NOff) NS = NS - 1 DO M = 1, NTop-1 DO I = 1, NTop-M HO = XA(I+NOff) - X HP = XA(I+M+NOff) - X W = C(I+1) - D(I) DEN = HO - HP IF (DEN.EQ.0) THEN TYPE *, $ 'POLINT: The input points are to close together:', $ HO, HP Y = 0.0 DY = HUGE GOTO 99 ENDIF DEN = W/DEN C(I) = HO*DEN D(I) = HP*DEN ENDDO IF (2*NS.LT.NTop-M) THEN DY = C(NS+1) ELSE DY = D(NS) NS = NS - 1 ENDIF Y = Y + DY ENDDO 99 continue if (DY.gt.0.05*Y) then C type *, 'POLINT: Big Error',X,Y,' +-',DY C do i1 = 1,ntop C type *, x,xa(i1+noff),ya(i1+noff),y C enddo endif RETURN END c Routine take from Numerical Recipes Chap 3.2 c c Rational exterpolation routine: c Given arrays XA and YA each of length N and given a value X, this c routine returns a value of Y and accuracy estimate DY. The value c returned is that of a tiagonal rational function, evaluated at X c which passes through the N points (XA, YA). C 2/8/89 - modified to handle arrays N larger than nmax. C SUBROUTINE RATINT(XA,YA,N,X,Y,DY) PARAMETER (NMAX=5, TINY=1.E-25, HUGE = 1.E+25) REAL XA(*), YA(*), X, Y, DY REAL C(NMAX), D(NMAX) INTEGER N integer NElem NTop = N NOff = 0 if (NTop.gt.NMax) then NTop = NMax C Binary search for the element closest to X. call HUNT(XA,N,X,NElem) NBase = NElem - NTop/2 if (NBase+NTop-1.gt.N) NBase = N - NTop + 1 if (NBase.lt.1) NBase = 1 NOff = NBase - 1 endif NS = 1 HH = ABS(X-XA(1+NOff)) DO I = 1,NTop H = ABS(X-XA(I+NOff)) IF (H.EQ.0) THEN Y = YA(I+NOff) DY = 0.0 GOTO 99 ELSE IF (H.LT.HH) THEN NS = I HH = H ENDIF C(I) = YA(I+NOff) D(I) = YA(I+NOff) + TINY ENDDO Y = YA(NS+NOff) NS = NS - 1 DO M = 1, NTop-1 DO I = 1, NTop-M W = C(I+1) - D(I) H = XA(I+M+NOff) - X T = (XA(I+NOff) - X)*D(I)/H DD = T-C(I+1) IF (DD.EQ.0) THEN TYPE *, 'RATINT: There is a pole at X =', X Y = 0 DY = HUGE GOTO 99 ENDIF DD = W/DD D(I) = C(I*1)*DD C(I) = T*DD ENDDO IF (2*NS.LT.NTop-M) THEN DY = C(NS+1) ELSE DY = D(NS) NS = NS - 1 ENDIF Y = Y + DY ENDDO 99 CONTINUE if (DY.gt.0.05*Y) then C type *, 'RATINT: Big Error',X,Y,' +-',DY C do i1 = 1,ntop C type *, x,xa(i1+noff),ya(i1+noff),y C enddo endif RETURN END C From Numerical Recipes Chap 3.4 C Given an array XX of length N and a given value X, returns a value C such that X is between XX(J) and XX(J+1). XX must be monotonic. C J = 0 or N is returned if X is out of range. Jon input is C taken as the initial guess for J on output subroutine HUNT(XX,N,X,JL) integer N real XX(N), X C**** THE UPPER AND LOWER BOUND ON THE POSITION BEING SEARCHED FOR. integer jl, ju C**** The last position found. save j integer j data j /0/ C**** flag assending or decending order. LOGICAL ASCND C**** The increment for the lower and upper bound integer inc C**** The middle value for j. integer JM ASCND = XX(N).gt.XX(1) C**** Is the first guess useful? if (j.le.0.or.j.gt.n) then JL = 0 JU = N+1 goto 10 else jl = j endif INC = 1 if (X.ge.XX(JL).eqv.ASCND) then 1 JU = JL + INC if (JU.gt.N) then JU = N + 1 else if (X.ge.XX(JU).eqv.ASCND) then JL = JU INC = INC + INC goto 1 endif else ju = jl 2 jl = ju - inc if (JL.lt.1) then JL = 0 else if (X.lt.XX(JL).eqv.ASCND) then JU = JL INC = INC + INC goto 2 endif endif 10 if (JU-JL.gt.1) then JM = (JU+JL)/2 if (ASCND.eqv.(X.gt.XX(JM))) then JL = JM else JU = JM endif goto 10 endif j = JL return end C************************************************ C C Perform a linear interpolation on the values in XA, and YA. C XA, YA must be ordered. C SUBROUTINE LININT(XA,YA,N,X,Y,DY) PARAMETER (NMAX=10, TINY=1.E-25, HUGE = 1.E+25) REAL XA(N), YA(N), X, Y, DY integer NElem call HUNT(XA,N,X,NElem) if (NElem.ge.N) NElem = N - 1 if (NElem.lt.1) NElem = 1 DYDX = (YA(NElem+1) - YA(NElem)) / (XA(NElem+1) - XA(NElem)) DX = X - XA(NElem) + Tiny Y = YA(NElem) + DYDX*DX DY = DYDX*DX return end C****************************** C Convert the probablity distribution Y into a cumulative probablity C distribution YI. Y does not need to be normalized. YI will be C normalized correctly. SUBROUTINE CFD(YI,N,Y) INTEGER N REAL Y(N),YI(N+1) CF=0.0 DO I=1,N CF=CF+Y(I) YI(I+1)=CF ENDDO YI(1)=0.0 cf=1./cf DO I=2,n+1 YI(I)=YI(I)*cf ENDDO RETURN END C***************************************************** C @(#)prbin.f 1.1 modified on 12/7/92 FUNCTION PRBIN(YI,N,XMIN,XSTEP,YR) DIMENSION YI(1) MIN=1 MAX=N+1 GO TO 3 1 IF((MAX-MIN).EQ.1) GO TO 5 IF(YI(M)-YR) 2,6,4 2 MIN=M 3 M=(MAX+MIN)/2 GO TO 1 4 MAX=M GO TO 3 5 M=MIN FR=(YR-YI(MIN))/(YI(MAX)-YI(MIN)) PRBIN=XMIN+XSTEP*(FLOAT(MIN)+FR-1.0) RETURN 6 FR=0.0 PRBIN=XMIN+XSTEP*(FLOAT(M)-1.0) RETURN END C******************************************* C @(#)cone.f 1.1 modified on 12/7/92 SUBROUTINE CONE(SAa,SB,CTH,PHI) C ASSIGNS TO SB(3) A VECTOR FORMING AN ANGLE ACOS(CTH) WITH SA(3) C IF PHI<0 THEN A RANDOM PHI IS TAKEN (FROM CONICAL SURFACE) C DIMENSION SA(4),saa(3),SB(3),D(3,3),RK(3) r=0. do i=1,3 r=r+saa(i)**2 end do r=sqrt(r) do i=1,3 sa(i)=saa(i)/r end do CALL RANVE(1.,RK,CTH,PHI) R=SQRT(SA(1)**2+SA(2)**2) IF(R.Eq.0.)then SB(1)=RK(1) sb(2)=rk(2) sb(3)=rk(3)*sa(3) else D(1,1)=SA(1)*SA(3)/R D(1,2)=SA(2)*SA(3)/R D(1,3)=-R D(2,1)=-SA(2)/R D(2,2)=SA(1)/R D(2,3)=0. D(3,1)=SA(1) D(3,2)=SA(2) D(3,3)=SA(3) DO 1 I=1,3 SB(I)=0. DO 1 J=1,3 1 SB(I)=SB(I)+D(J,I)*RK(J) end if 10 RETURN END C***************************************************** C @(#)lorentz.f 1.1 modified on 12/7/92 subroutine lorentz(pi,pf,beta) dimension pi(4),pf(4),beta(3) betamag=0. do i=1,3 betamag=betamag+beta(i)**2 end do if(betamag.le.0.) return betamag=sqrt(betamag) if(betamag.ge.1.) betamag=.9999 gamma=1./sqrt(1.-betamag**2) pperp=0. if(betamag.eq.0.) then do i=1,4 pf(i)=pi(i) end do return end if do i=1,3 pperp=pperp+pi(i)*beta(i)/betamag end do do i=1,3 pf(i)=(gamma*pperp-gamma*betamag*pi(4))*beta(i)/betamag+ 2 (pi(i)-pperp*beta(i)/betamag) end do pf(4)=gamma*pi(4)-gamma*betamag*pperp return end C**************************************************** C @(#)lloren.f 1.1 modified on 12/7/92 SUBROUTINE lLOREN(PPRIME,EPRIME,P,E,BETA) DIMENSION PPRIME(3),P(3),BETA(3) BSQ=0. BDP=0. DO 10 I=1,3 BSQ=BSQ+BETA(I)**2 10 BDP=BDP+BETA(I)*P(I) IF(BSQ) 30,30,15 15 GAM=SQRT(1./(1.-BSQ)) SHIFT=(GAM-1.)*BDP/BSQ -GAM*E DO 20 I=1,3 20 PPRIME(I)=P(I)+SHIFT*BETA(I) EPRIME=GAM*(E-BDP) RETURN 30 DO 40 I=1,3 40 PPRIME(I)=P(I) EPRIME=E RETURN END C*********************************************** C @(#)loren.f 1.1 modified on 12/7/92 SUBROUTINE LOREN(C,P,Q,N,K) DIMENSION C(4),P(4,N),Q(4,N) S=0. DO 1 I=1,3 1 S=S+C(I)**2 IF(S.EQ.0.)GO TO 100 S=C(4)**2-S W=SQRT(S) Z=W+C(4) DO 20 J=1,N D=C(4)*P(4,J) DO 21 I=1,3 21 D=D-K*C(I)*P(I,J) E=D/W A=(P(4,J)+E)/Z Q(4,J)=E DO 22 I=1,3 22 Q(I,J)=P(I,J)-A*K*C(I) 20 CONTINUE GO TO 1000 100 DO 101 J=1,N DO 101 I=1,4 101 Q(I,J)=P(I,J) GO TO 1000 1000 RETURN END C**************************************************** C @(#)twob.f 1.2 modified on 1/27/93 SUBROUTINE TWOB(AMD,AM1,AM2,PD,P1) DIMENSION PD(4),P1(4,2),PTEM(4,2) AMD2=AMD**2 A2M1=AM1**2 A2M2=AM2**2 E1=(AMD2+A2M1-A2M2)/AMD/2. E2=(AMD2+A2M2-A2M1)/AMD/2. P=E1**2-A2M1 IF(P.LT.0)THEN P=0 print 100,AMD,AM1,AM2 100 FORMAT(/' error in TWOB - masses:',3G12.4) END IF P=SQRT(P) CALL RANVE(P,PTEM,2.,-1.) PTEM(4,1)=E1 PTEM(4,2)=E2 DO I=1,3 PTEM(I,2)=-PTEM(I,1) enddo CALL LOREN(PD,PTEM,P1,2,-1) RETURN END C******************************************************* C @(#)threeb.f 1.2 modified on 12/29/92 SUBROUTINE THREEB(AMD,AM1,AM2,AM3,PD,PP) common/number/ntry DIMENSION PD(4),PP(4,3) DIMENSION PD1(4),PTEM(4,3) A=(AM1+AM2)**2 A1=(AMD-AM3)**2-A B=(AM1+AM3)**2 B1=(AMD-AM2)**2-B SM1=AM1**2 SM2=AM2**2 SM3=AM3**2 SMD=AMD**2 2 CONTINUE ntry=ntry+1 AM12=A+ranf()*A1 AM13=B+ranf()*B1 DM12=1/(2*SQRT(AM12)) E1=(AM12+SM1-SM2)*DM12 E3=(SMD-AM12-SM3)*DM12 P1=SQRT(E1**2-SM1) P3=SQRT(E3**2-SM3) C=(E1+E3)**2 IF(AM13.LT.C-(P1+P3)**2)GOTO 2 IF(AM13.GT.C-(P1-P3)**2)GOTO 2 E1=(AM12+AM13-SM3-SM2)/2/AMD P1=SQRT(E1**2-SM1) EMR=AMD-E1 AMR=SQRT(EMR**2-P1**2) CALL RANVE(P1,PD1,2.,-1.) PD1(4)=EMR CALL TWOB(AMR,AM2,AM3,PD1,PTEM(1,2)) DO 1 I=1,3 1 PTEM(I,1)=-PD1(I) PTEM(4,1)=E1 CALL LOREN(PD,PTEM,PP,3,-1) RETURN END C******************************************************** C @(#)putgam.f 1.3 modified on 1/4/93 C SUBROUTINE PUTGAM(P) implicit none real P(4) integer k C**************************************************************** C @(#)momentum.cdk 1.2 modified on 1/12/93 C Include the information about the primary particles to be tracked. C**** The number of momenta. integer nmom C**** The particle 4 momentum. real ppr(4,20) C**** The particle masses real ppm(20) C**** The particle charges real chh(20) C**** The particle id. integer pid(20) COMMON/MOM/ nmom,ppr,ppm,chh,pid C***** Gamma ray information real ppg(4,20) integer ngam common /gamm1/ ppg,ngam NGAM = NGAM + 1 DO K=1,4 PPG(K,NGAM)=P(K) enddo RETURN END C************************************************** C @(#)entryexit.f 1.2 modified on 10/20/93 C c ****************** Entryexit c This takes a track reference point and direction and returns the c distance to the point the track enters and exits the detector. c not enter the region entry and exit are equal and arbitrary. subroutine Entryexit(Pos,Dir,PEntry,PExit) implicit none integer i1,i2 real r1,r2 c The Position of the track reference point. real Pos(3) c The direction of the track real Dir(3) C The distance along the track direction to the entray and exit point. real PEntry,PExit C**** The detector box. real Walls(6) data Walls / -1154.0, -843.0, -876.0, 1154.0, 843.0, 876.0 / C high and low corner of the box. real hc(3), lc(3) c the distances to be traveled real t1(6) integer it C**** The fiducial distance. real Fidd, PFidd Fidd = 0.0 goto 10 entry enterfidu(Pos,Dir,PFidd,PEntry,PExit) Fidd = Pfidd 10 continue c make sure HCorner and LCorner are in the right order do i1 = 1,3 LC(i1) = walls(i1) + Fidd HC(i1) = walls(i1+3) - Fidd enddo c find the distances to each plane crossing. it = 0 do i1=1,3 if (Dir(i1).ne.0) then it = it + 1 t1(it) = (LC(i1)-Pos(i1))/Dir(i1) it = it + 1 t1(it) = (HC(i1)-Pos(i1))/Dir(i1) endif enddo C**** Make sure the box was hit. (Direction non zero.) if (it.lt.2) then PExit = PEntry return endif c sort the distances do i1 = 1,it-1 do i2 = i1+1,it if (t1(i1).gt.t1(i2)) then r1 = t1(i1) t1(i1) = t1(i2) t1(i2) = r1 endif enddo enddo c the entry and exit points will be the middle two entries i1 = it/2 PEntry = t1(i1) PExit = t1(i1+1) c make sure the track entered the region. r1 = (PEntry + PExit)/ 2.0 do i1 = 1,3 r2 = Pos(i1) + r1*Dir(i1) if ((r2.lt.LC(i1)).or.(r2.gt.HC(i1))) then PEntry = PExit return endif enddo return end SUBROUTINE bspline(XA,YA,Y2A,N,X,Y) DIMENSION XA(N),YA(N),Y2A(N) KLO=1 KHI=N 1 IF (KHI-KLO.GT.1) THEN K=(KHI+KLO)/2 IF(XA(K).GT.X)THEN KHI=K ELSE KLO=K ENDIF GOTO 1 ENDIF H=XA(KHI)-XA(KLO) IF (H.EQ.0.) then type *, ' BAD XA, must be monotonic' stop endif A=(XA(KHI)-X)/H B=(X-XA(KLO))/H Y=A*YA(KLO)+B*YA(KHI)+ * ((A**3-A)*Y2A(KLO)+(B**3-B)*Y2A(KHI))*(H**2)/6. RETURN END SUBROUTINE SPLINE(X,Y,N,YP1,YPN,Y2) PARAMETER (NMAX=100) DIMENSION X(N),Y(N),Y2(N),U(NMAX) IF (YP1.GT..99E30) THEN Y2(1)=0. U(1)=0. ELSE Y2(1)=-0.5 U(1)=(3./(X(2)-X(1)))*((Y(2)-Y(1))/(X(2)-X(1))-YP1) ENDIF DO 11 I=2,N-1 SIG=(X(I)-X(I-1))/(X(I+1)-X(I-1)) P=SIG*Y2(I-1)+2. Y2(I)=(SIG-1.)/P U(I)=(6.*((Y(I+1)-Y(I))/(X(I+1)-X(I))-(Y(I)-Y(I-1)) * /(X(I)-X(I-1)))/(X(I+1)-X(I-1))-SIG*U(I-1))/P 11 CONTINUE IF (YPN.GT..99E30) THEN QN=0. UN=0. ELSE QN=0.5 UN=(3./(X(N)-X(N-1)))*(YPN-(Y(N)-Y(N-1))/(X(N)-X(N-1))) ENDIF Y2(N)=(UN-QN*U(N-1))/(QN*Y2(N-1)+1.) DO 12 K=N-1,1,-1 Y2(K)=Y2(K)*Y2(K+1)+U(K) 12 CONTINUE RETURN END C************************************************************** C %W% modified on %G% C SUBROUTINE KINEM(KEY,IFER,MODE,moda) C***************************************** C Generate the kinimatics of the initial particles. The results are placed C into the ppr and pgam arrays. C*************************************************** C @(#)masses.cdk 1.2 modified on 12/30/92 C The particle masses C PROTON - AMP C NEUTRON - AMN C LAMBDA - AML C SIGMA - AMS C ELECTRON - AMEL C MUON - AMMU C PI 0 - AMPO C PI +/- - AMPC C ETA = AMETA C OMEGA = AMOM C RHO = AMRHO C K 0 = AMKO C K +- = AMKC C K* 0 = AMKSO C K* +- = AMKSC C*** The leptons real AMEL, AMMU C*** The baryons real AMP, AMN, AML, AMS C*** The mesons real AMPO, AMPC, AMETA, AMOMG, AMRHO C*** The strange mesons. real AMKO, AMKC, AMKSO, AMKSC COMMON/MASSES/AMEL,AMMU, $ AMP, AMN, AML, AMS, $ AMPO, AMPC, AMETA, AMRHO, AMOMG, $ AMKO, AMKC, AMKSO, AMKSC C**************************************************************** C @(#)momentum.cdk 1.2 modified on 1/12/93 C Include the information about the primary particles to be tracked. C**** The number of momenta. integer nmom C**** The particle 4 momentum. real ppr(4,20) C**** The particle masses real ppm(20) C**** The particle charges real chh(20) C**** The particle id. integer pid(20) COMMON/MOM/ nmom,ppr,ppm,chh,pid C***** Gamma ray information real ppg(4,20) integer ngam common /gamm1/ ppg,ngam C******************************************************************** C @(#)prdec.cdk 1.1 modified on 12/29/92 C pass information about the initail particls and the desired products. C**** The amass and info about the interaction from spot. real amint, amlep, amd, amm(5) integer np(5), npar, kt COMMON/PRDEC/AMINT,AMLEP,AMD,AMM,NP,NPAR,KT C*************************************************************** C ASSIGN A GENERATED VERTEX TO XINT(3) C*************************************************************** CALL GEOM(KEY) if (KEY.eq.0) then C*************************************************************** C MAKE A PROTON DECAY C*************************************************************** CALL PROTON(IFER,MODE,MODA) else if(key.eq.1) then C*************************************************************** C MAKE A NEUTRINO INTERACTION C*************************************************************** c old delta production model CALL DELT(IFER,MODE,MODA) else if (key.eq.2) then C*************************************************************** C MAKE A NEUTRINO INTERACTION C*************************************************************** c new single-pi model with the addition of multipips CALL MCPI(ifer,mode,moda) else if (key.eq.-1) then C*************************************************************** C PREPARE PPR ARRAY FOR SINGLE PARTICLE TRACKING C*************************************************************** nmom = 1 call idgeant(np(1),ppm(nmom),chh(nmom)) call ranve(1.0,ppr,2.0,-2.0) ppr(4,nmom) = np(2) if (np(3).gt.np(2)) then ppr(4,nmom) = ppr(4,nmom) + ranf()*(np(3)-ppr(4,nmom)) endif ppr(4,nmom) = ppr(4,nmom)/1000000.0 else if ((key.eq.-2).or.(key.eq.-3)) then C*************************************************************** C CALL STMIU FOR COSMIC MUONS C KEY = -2 Central Muon C KEY = -3 Atmospheric Muon C*************************************************************** CALL STMIU(key) endif RETURN END SUBROUTINE GEOM(KEY) C C GENERATES VERTEX XINT(3) IN THE FIDUCIAL VOLUME C C******************************************************************* C @(#)inter.cdk 1.1 modified on 12/29/92 C the interaction point. C real xint(3) common/inter/xint C**** The common block with the detector wall positions in it. real HT(3) COMMON/GEO/HT C************************************************************************ C @(#)fiducial.cdk 1.1 modified on 12/29/92 real FV common/fidv/FV data fv/0./ DO 1 I=1,3 1 XINT(I)=(2*ranf()-1)*(HT(I)-fv) RETURN END C******************************************* C @(#)onepionmodel.f 1.9 modified on 2/23/93 SUBROUTINE mcpi(IFER,MODE,MODA) implicit none real r1 integer i1, i2, i3 c this subroutine calculates the single pion production model c developed at Irvine c c *** np = 0 for gamma c 1 for pi negative c 2 for pi zero c 3 for pi plus c 4 for K negative c 5 for K zero stable c 6 for K plus c C**** Use fermi 1) momentum 1 or 0) not. integer ifer C**** The input control parameters from kinem that the onepi model C ignores. integer mode, moda c ***************************************************** c dimensions to handle inernuclear interactions c ***************************************************** c C**** Number of input particles for partnuc integer nin C**** The initial energy (ei), mass (ui), momentum (pi) and charge (chi) real ei(20), ui(20), pi(3,20), chi(20) C**** The final energy (ei), mass (ui), momentum (pi) and charge (chi) real eo(20), uo(20), po(3,20), cho(20) real stpt(3,20),start(3),decp(3) C**** Flags to pass information to partnuc C to use or not use fermi momentum. integer imode parameter (imode = 0) C**** integer icont C*************************************************** C @(#)masses.cdk 1.2 modified on 12/30/92 C The particle masses C PROTON - AMP C NEUTRON - AMN C LAMBDA - AML C SIGMA - AMS C ELECTRON - AMEL C MUON - AMMU C PI 0 - AMPO C PI +/- - AMPC C ETA = AMETA C OMEGA = AMOM C RHO = AMRHO C K 0 = AMKO C K +- = AMKC C K* 0 = AMKSO C K* +- = AMKSC C*** The leptons real AMEL, AMMU C*** The baryons real AMP, AMN, AML, AMS C*** The mesons real AMPO, AMPC, AMETA, AMOMG, AMRHO C*** The strange mesons. real AMKO, AMKC, AMKSO, AMKSC COMMON/MASSES/AMEL,AMMU, $ AMP, AMN, AML, AMS, $ AMPO, AMPC, AMETA, AMRHO, AMOMG, $ AMKO, AMKC, AMKSO, AMKSC C******************************************************************* C @(#)inter.cdk 1.1 modified on 12/29/92 C the interaction point. C real xint(3) common/inter/xint C******************************************************************** C @(#)prdec.cdk 1.1 modified on 12/29/92 C pass information about the initail particls and the desired products. C**** The amass and info about the interaction from spot. real amint, amlep, amd, amm(5) integer np(5), npar, kt COMMON/PRDEC/AMINT,AMLEP,AMD,AMM,NP,NPAR,KT C**************************************************************** C @(#)momentum.cdk 1.2 modified on 1/12/93 C Include the information about the primary particles to be tracked. C**** The number of momenta. integer nmom C**** The particle 4 momentum. real ppr(4,20) C**** The particle masses real ppm(20) C**** The particle charges real chh(20) C**** The particle id. integer pid(20) COMMON/MOM/ nmom,ppr,ppm,chh,pid C***** Gamma ray information real ppg(4,20) integer ngam common /gamm1/ ppg,ngam C**** God Only Knows, But PARTNUC wants it. integer isetn parameter (isetn = 0) C**** The Atomic number of oxygen. REAL ANuc parameter (ANuc = 16.0) C**** The momentum of the final nucleus, lepton, and initial neutrino. real pnuc(4), plep(4) C**** The momentum of the initial neutrino and nucleus. real pnu(4), pfermi(4) real efnuc C**** The transverse momentum and center of mass energy of nu neucleon. real pt, tecm C**** The initial type of the neutrino. 1) electron 2) muon integer nutype C**** The initial type of the neucleon. 0) neutron 1) proton integer nuctype C**** The initial energy of the neutrino. real enu C**** The initial direction of the neutrino. real dirnu(3) C**** The final type of the lepton and nucleon. integer leptypef,nuctypef C**** The pions from the final state. integer npion real ppi(4,10) integer pitypef(10) C**** The total weight of this event from final state. real wttot, wtmax common/weights/wttot,wtmax C**** The weight of the subprocess from final state. real wt C**** The weight of the neutrino energy and direction. real wtnu C**** the indentity of the interaction from final state. integer ident C**** The pauli blocking energy in GeV. real ppauli parameter (ppauli=.26) C**** Flag if this has been called before. integer icalled data icalled/0/ real ranf C**** The number of trials to get a successful event. integer ntry C**** The number of good events found. integer nnn C**** Flag if event includes fermi momentum 0) has fermi -1) has no fermi. integer nc C**** Geant neutrino type. integer gnutype integer wtblock, pblock real pmag C**** The version of the nukin file if one already exists. character*6 nvers if(icalled.eq.0) then C**** If this is the first call then open up a nukin.b86 kinematics file. icalled=1 ntry = 0 nnn = 0 call hbook2(1000,'Neutrino Energy Spectrum Produced by UCIKine$', $ 50,0.0,5.0, $ 40,1.0,21.0,0.0) call hbook2(1001,'Lepton Energy Spectrum Produced by UCIKine$', $ 50,0.0,5.0, $ 4,1.0,3.0,0.0) call hbook1(1002,'Fermi Momentum of Nucleon$',50,0.0,.500,0.0) end if c***************************************************************** c INITIALIZATION c***************************************************************** do i1 = 1,20 ppm(i1)=0. do i2=1,4 ppr(i2,i1)=0. end do end do do i1=1,3 start(i1)=0. decp(i1)=0. end do 30 continue do i1=1,3 pfermi(i1)=0.0 end do pfermi(4)=amp C**** Generate an initial energy and direction for the neutrino. call nu_energy(enu,dirnu,nutype,wtnu) C type *, enu, nutype, wtnu c**** Decide if the struck nucleon was a neutron or a proton. if(ranf().gt..555555) then nuctype=0 !neutron else nuctype=1 !proton end if c**** Find initial fermi momentum of nucleon. nc=nuctype if(ifer.gt.0) then call fermid(nc,pfermi,efnuc) !nc=0 -> got fermi'd else nc=-1 end if C******************************************************* c decide on final state particles/momenta c c first calculate total energy in the cms c for now let the neutrino direction be along x c and remember the initital nucleon momentum is in pfermi pnu(1)=enu pnu(2)=0. pnu(3)=0. pnu(4)=enu C**** Find the transverse momentum and the center of mass energy of C the collision. pt=(pfermi(1)+enu)**2+pfermi(2)**2+pfermi(3)**2 tecm=sqrt((enu+pfermi(4))**2-(pnu(1)+pfermi(1))**2 $ -(pnu(2)+pfermi(2))**2-(pnu(3)+pfermi(3))**2) C******************************************************************* C Find the final state products from the interaction. call final_state(nuctype,pfermi,nutype,pnu,tecm,nuctypef,pnuc, $ leptypef,plep,npion,pitypef,ppi,wt,ident) ntry=ntry+1 if(wt.le.0.0)then wtblock=wtblock+1 go to 30 ! dont keep event end if if(npion.gt.3) then print *,' error npion too big',npion go to 30 end if c********************************************************** c do pauli blocking of the final nucleon c if(nc.eq.0)then pmag = sqrt(pnuc(1)**2 + pnuc(2)**2 + pnuc(3)**2) if(pmag.lt.ppauli)then pblock = pblock + 1 go to 30 !dont keep event end if end if C************************** C We have a good event. nnn=nnn+1 C**** Write the incoming neutrino to the output if (nutype.eq.1) then gnutype = -3 else if (nutype.eq.-1) then gnutype = -2 else if (nutype.eq.2) then gnutype = -6 else if (nutype.eq.-2) then gnutype = -5 else gnutype = 4 endif i2 = gnutype write(6,'('' $ INCOMING '',I3,F12.6,3F10.6,F10.1)'),I2,enu, $ dirnu(1),dirnu(2),dirnu(3), wtnu C**** Write the incoming nucleon to the output if (nuctype.eq.0) then i2 = 13 else if (nuctype.eq.1) then i2 = 14 else write(6,*) 'ONEPI: bad nuctype', nuctype endif call rotatenu(pnu,dirnu,pfermi,1) write(6,'('' $ INCOMING '',I3,F12.6,3F10.6,F10.1)'),I2, pfermi(4), $ pfermi(1), pfermi(2), pfermi(3), wtnu c************************************** c fill arrays with the final state do i1=1,4 ppr(i1,1)=plep(i1) ppr(i1,2)=pnuc(i1) do i2=1,npion if(abs(pitypef(i2)).le.1) then ppr(i1,2+i2)=ppi(i1,i2) else ppr(i1,2+i2)=0. end if end do end do nmom=2 if(abs(pitypef(1)).le.1) nmom=3 if(npion.ge.1) nmom=2+npion C**** Set the Lepton Type C LepTypeF: 1 - electron C 2 - muon C 0 - neutrino if(abs(leptypef).eq.1)then ppm(1)=amel chh(1)=sign(1,leptypef) else if(abs(leptypef).eq.2)then ppm(1)=ammu chh(1)=sign(1,leptypef) else ppm(1)=0. chh(1)=0. end if amlep=ppm(1) C**** Set the nucleon type C NucTypeF: 1 - Proton C 0 - Neutron if(nuctypef.eq.1) then ppm(2)=amp chh(2)=1. else if (nuctypef.eq.0) then ppm(2)=amn chh(2)=0. else write(6,*) 'ONEPI: invalid nuctypef',nuctypef stop end if C***** Set the Pion Types if(nmom.gt.2) then do i1=1,npion chh(2+i1)=pitypef(i1) if(pitypef(i1).eq.0)then ppm(2+i1)=ampo else ppm(2+i1)=ampc end if end do else chh(3)=0. ppm(3)=0. end if C**** Write the outgoing lepton information to output. if (leptypef.eq.0) then i2 = gnutype else if (abs(leptypef).eq.1) then if (leptypef.gt.0) then i2 = 2 else i2 = 3 endif else if (abs(leptypef).eq.2) then if (leptypef.gt.0) then i2 = 5 else i2 = 6 endif else write(6,*) 'ONEPI:: Bad leptypef', leptypef call exit(1) endif write(6,'('' $ OUTGOING '',I3,F12.6,3F10.6,I4)'),I2, plep(4), $ plep(1), plep(2), plep(3), ident C**** Write the outgoing hadron information to output if (NucTypeF.eq.0) then i2 = 13 else if (NucTypeF.eq.1) then i2 = 14 else write(6,*) 'ONEPI:: bad nuctypef',nuctypef call exit(1) endif write(6,'('' $ OUTGOING '',I3,F12.6,3F10.6,I4)'),I2, pnuc(4), $ pnuc(1), pnuc(2), pnuc(3), ident C**** Write the outgoing pions to the output. do i1 = 1,npion if (pitypef(i1).eq.0) then i2 = 7 else if (pitypef(i1).eq.1) then i2 = 8 else if (pitypef(i1).eq.-1) then i2 = 9 else write(6,*) 'ONEPI: bad pitypef', i1, pitypef(i1) call exit(1) endif write(6,'('' $ OUTGOING '',I3,F12.6,3F10.6,I4)'),I2, ppi(4,i1), $ ppi(1,i1), ppi(2,i1), ppi(3,i1), ident enddo ********************************************************************** c c do nuclear interactions of pion and nucleon c if(nc.eq.-1) go to 40 !no nuclear interactions of free proton icont=0 nin=0 do i1=2,nmom nin=nin+1 ei(nin)=ppr(4,i1) ui(nin)=ppm(i1) do i2=1,3 pi(i2,nin)=ppr(i2,i1) end do chi(nin)=chh(i1) end do if(nin.eq.0) go to 40 ! no pions or nucleons found call partnuc( isetn,anuc,stpt, $ ei,pi,ui,chi, ! input hadrons $ nin, ! number of initial hadrons. $ eo,po,uo,cho, ! output hadrons $ start, decp,imode,icont) i3=1 do i1=1,nin if(abs(uo(i1)).ge.1.e-4) then !pion not absorbed i3=i3+1 do i2=1,3 ppr(i2,i3)=po(i2,i1) end do ppr(4,i3)=eo(i1) ppm(i3)=uo(i1) chh(i3)=cho(i1) if (abs((abs(chh(i3))-1.0)).lt.0.5 $ .and.abs(ppm(i3)-AMPC).lt.0.01) ppm(i3) = AMPC if (abs(chh(i3)).lt.0.5 $ .and.abs(ppm(i3)-AMP).lt.0.05) ppm(i3) = AMN endif end do nmom=i3 do i1=nmom+1,20 ppm(i1)=0 chh(i1)=0 do i2=1,4 ppr(i2,i1)=0 end do end do 40 continue C**** Rotate the neutrino and produces into the detector coordinate system. call rotatenu(pnu,dirnu,ppr,nmom) C************************** C Histogram the results. C******************* Histogram the energy of the incoming neutrino. C r1 will contain the ident of the interaction. if (ident.lt.20) then r1 = ident else if (ident.lt.40) then r1 = 17 else if (ident.lt.60) then r1 = 18 else if (ident.lt.120) then r1 = 19 else r1 = 20 endif r1 = r1 + 0.25 if (abs(nutype).eq.2) r1 = r1 + 0.5 call hfill(1000,enu,r1,1.0) C******************* Histogram the energy of the outgoing lepton. C Ignore Neutrinos. C r1 0.25 -- e- C 0.75 -- e+ C 1.25 -- m- C 1.75 -- m+ if (ident.eq.15.or.ident.eq.16) then r1 = abs(LepTypeF) + 0.25 if (LepTypeF.gt.0) r1 = r1 + 0.5 call hfill(1001,plep(4),r1,1.0) endif C******************** Histogram the Fermi momentum. r1 = pfermi(1)**2 + pfermi(2)**2 + pfermi(3)**2 if (r1.gt.0.0) then r1 = sqrt(r1) else r1 = 0.0 endif call hfill(1002,r1,0.0,1.0) return END subroutine rotatenu(pnu,dirnu,ppr,nmom) c c routine to rotate ppr fron pnu to dirnu c C**** The momentum of the neutrino. real pnu(4) C**** The direction of the neutrino. That things should be rotated to. real dirnu(3) C**** The number of primary particles. integer nmom C**** The momenum of the primary particles in the detector. real ppr(4,nmom) C**** The rotation matrices ru and rv are rotations around the euler axis. real r(3,3), rv(3,3), ru(3,3) C**** the normalized direction of pnu() real dir(3) C**** The normalized direction of dirnu() real dir2(3) C**** A temporary variable used to rotate ppr real xr(3) C**** The basis vectors in the new coordinate system. real khat(3),ahat(3),bhat(3) rr=0. rrr=0. do i=1,3 rr=rr+pnu(i)**2 rrr=rrr+dirnu(i)**2 end do rr=sqrt(rr) rrr=sqrt(rrr) do i=1,3 dir(i)=pnu(i)/rr dir2(i)=dirnu(i)/rrr end do c c pick random khat c 10 call ranve(1.0,khat,2.0,-2.0) udotk=khat(1)*dir(1)+khat(2)*dir(2)+khat(3)*dir(3) if(udotk.eq.0) go to 10 vdotk=khat(1)*dir2(1)+khat(2)*dir2(2)+khat(3)*dir2(3) if(vdotk.eq.0) go to 10 call cross_product(khat,dir2,ahat) call normalize(ahat) call cross_product(dir2,ahat,bhat) call normalize(bhat) do i=1,3 rv(i,1)=dir2(i) rv(i,2)=ahat(i) rv(i,3)=bhat(i) end do call cross_product(khat,dir,ahat) call normalize(ahat) call cross_product(dir,ahat,bhat) call normalize(bhat) do i=1,3 ru(1,i)=dir(i) ru(2,i)=ahat(i) ru(3,i)=bhat(i) end do do i=1,3 do j=1,3 r(i,j)=0. do k=1,3 r(i,j)=r(i,j)+rv(i,k)*ru(k,j) end do end do end do do ii=1,nmom do i=1,3 xr(i)=0. do j=1,3 xr(i)=xr(i)+r(i,j)*ppr(j,ii) end do end do do i=1,3 ppr(i,ii)=xr(i) end do end do return end subroutine cross_product(a,b,c) dimension a(3),b(3),c(3) c(1)=a(2)*b(3)-a(3)*b(2) c(2)=a(3)*b(1)-a(1)*b(3) c(3)=a(1)*b(2)-a(2)*b(1) return end subroutine normalize(x) dimension x(3) r=0. do i=1,3 r=r+x(i)**2 end do r=sqrt(r) do i=1,3 x(i)=x(i)/r end do return end C****************************************************************** C Generate the final state of the neutrino and the nucleon. subroutine final_state(nuctype,pnuci,nutype,pnui,tecm,nuctypef, $ pnuc,leptypef,plep,npion, $ pitypef,ppi,wtf,identf) implicit none integer i1, i2 C**** nuctype: The nucleon type. 0) neutron 1) proton integer nuctype C**** pnuci: The initial momentum of the nucleon. real pnuci(4) C**** nutype: The neutrino type. 1) electron 2) muon +) nu -) nubar integer nutype C**** pnui: The initial momentum of the neutrion real pnui(4) C**** tecm: The center of mass energy. real tecm C**** nuctypef:The final nucleon type 0) neutron 1) proton integer nuctypef C**** pnuc: The final nucleon momentum. real pnuc(4) C**** leptypef:The final lepton type 0) neutrino +-1) electron +-2) muon integer leptypef C**** plep: The lepton momentum. real plep(4) C**** npion: The number of produced pions. integer npion, npion2p C**** pitypef: The type of the produced pions 0) pi0 +1) pi+ -1) pi- integer pitypef(*) C**** ppi: the momentum of the pions. real ppi(4,*) C**** wtf: The weight of the final state interaction returned to the C calling routine. If this is zero then no valid interaction was found. real wtf C**** identf: The identity of the interaction. C 1) nu p --> l- p pi+ 4) nubar p --> l+ p pi- C 2) nu n --> l- p pi0 5) nubar p --> l+ n pi0 C 3) nu n --> l- n pi+ 6) nubar n --> l+ n pi- C 7) nu p --> nu p pi0 11) nubar p --> nubar p pi0 C 8) nu n --> nu n pi0 12) nubar n --> nubar n pi0 C 9) nu p --> nu n pi+ 13) nubar p --> nubar n pi+ C 10) nu n --> nu p pi- 14) nubar n --> nubar p pi- C 15) nu n --> l- p 16) nubar p --> l+ n integer identf C**** The phase space weight for the two body charged current interactions. C 15, 16 real wt2 C**** The matrix element for the two body interactions. This is forced to C zero for the neutral current interactions since they produce no C visible interactions in imb3 real wtm2 C**** The phase space weight for 3 body charged current interactions C 1, 2, 3, 4, 5, 6 real wt3 C**** The phase space weight for 3 body neutral current interactions C 7, 8, 9, 10, 11, 12, 13, 14 real wt3nc C**** The interaction weights of the individual onepion modes. The mode for C each of these elements is identified nchanel(1..nfin,nutype,nuctype+1) C where nutype is 1) nubar, 2) nu and nuctype is 0) neutron, 1) proton. real wtt(5) C**** The interaction weight of the 2 pion charged current mode. real wt2pcc C**** The interaction weight of the 2 pion neutral current mode. real wt2pnc C**** The interaction weight of the 3 pion charged current mode. real wt3pcc C**** The interaction weight of the 3 pion neutral current mode. real wt3pnc C**** Dummy variables to hold the initial neutrino or nucleon. real pnuii(4),pnui2(4) real pnui3(4),pnuci3(4),pnucii(4),pnuci2(4) real pnuc2(4),pnuc3(4),plep2(4),plep3(4),ppi3(4) real pnui3nc(4),pnuci3nc(4),pnuc3nc(4),plep3nc(4),ppi3nc(4) integer nuctypef2pcc, leptypefpcc integer ident2pcc, nuctypef2pnc integer ident2pnc, npion3p, nuctypef3pcc, leptypef2pcc integer ident3pcc, nuctypef3pnc, leptypefpnc integer leptypef2pnc, leptypef3pcc, leptypef3pnc, ident3pnc C**** The number of times the total weight has been greater than wtmax. integer ngreat C**** The sum of the partial weights real wtsum C**** The random weight for this event real wtrand C**** The total and maximum weights passed to onepi for debuging. real wttot, wtmax common/weights/wttot,wtmax C************************************************** C Control for matvect, matform, matcoeff, and matdia c**** iel=1 for elastic (fills arrays .mnu) c iel=0 for pi production integer iel c**** ncc=-1 for isoscalar nc (fills arrays a..s) c ncc= 0 for isovector nc (fills arrays ...2) c ncc= 1 for isovector cc (fills arrays ...1) integer ncc common/elastic/iel,ncc C**** The momentum input vectors for matvect. real p1(4),p2(4),pe(4),pnub(4),dumm(9),s,ped,z common/vectors/p1,p2,pe,pnub common/matscal/dumm equivalence (s,dumm(1)),(ped,dumm(4)) C**** The proton mass plus the pion mass. real scut parameter (scut=(0.938+0.139)*1.078) C*************************************************** C @(#)masses.cdk 1.2 modified on 12/30/92 C The particle masses C PROTON - AMP C NEUTRON - AMN C LAMBDA - AML C SIGMA - AMS C ELECTRON - AMEL C MUON - AMMU C PI 0 - AMPO C PI +/- - AMPC C ETA = AMETA C OMEGA = AMOM C RHO = AMRHO C K 0 = AMKO C K +- = AMKC C K* 0 = AMKSO C K* +- = AMKSC C*** The leptons real AMEL, AMMU C*** The baryons real AMP, AMN, AML, AMS C*** The mesons real AMPO, AMPC, AMETA, AMOMG, AMRHO C*** The strange mesons. real AMKO, AMKC, AMKSO, AMKSC COMMON/MASSES/AMEL,AMMU, $ AMP, AMN, AML, AMS, $ AMPO, AMPC, AMETA, AMRHO, AMOMG, $ AMKO, AMKC, AMKSO, AMKSC C**** Flag an anti neutrion or a neutrino. 1) anti-neutrino 2) neutrino integer intype C**** The number of possible final states given the initial state. C indexed by (anti-nu/nu,neutron/proton) integer nfin, ifinal integer nfinal(2,2) data nfinal/3,5, $ 5,3/ C**** The identity of the channels available for a particular particle C combination. integer ident integer nchanel(5,2,2) data nchanel/ $ 6,12,14, 0, 0, $ 2, 3, 8,10,15, $ 4, 5,11,13,16, $ 1, 7, 9, 0, 0 $ / C**** The type of the produced pion for various quasi-elastic reactions. integer iptype(16) data iptype/1,0,1,-1,0,-1,0,0,1,-1,0,0,1,-1,3,3/ C**** The type of interacton for twopi and threepi interactions. C 0) charge current interactions 1) neutral current interactions integer itype real pnuc2pcc(4),pnuc2pnc(4),plep2pcc(4),plep2pnc(4), $ ppi2pcc(4,10),ppi2pnc(4,10) integer pitypef2pcc(10),pitypef2pnc(10) real pnuc3pcc(4),plep3pcc(4),ppi3pcc(4,10) integer pitypef3pcc(10) real pnuc3pnc(4),plep3pnc(4),ppi3pnc(4,10) integer pitypef3pnc(10) real ranf, qmat C************************************************ C INITIALIZE FOR THIS EVENT. wtmax = 60.0 wtf=0.0 npion=-1 do i1=1,10 pitypef(i1)=10 end do do i1=1,5 wtt(i1)=0.0 end do wt2pcc = 0.0 wt2pnc = 0.0 wt3pcc = 0.0 wt3pnc = 0.0 C**** Find if this is an anti neutrino or a neutrino if(nutype.lt.0) then intype=1 else intype=2 endif C************************************************ C Find the weights for the zero and one pion final states. nfin=nfinal(intype,nuctype+1) c**************************************** c**** Do phase space for one pion C.C. pnuc2(4)=amp pnuc3(4)=amp ppi3(4)=ampc plep2(4)=amel plep3(4)=amel if(abs(nutype).eq.2) then plep2(4)=ammu plep3(4)=ammu end if c after calls to threebod and twobod pnui has been changed c so save original values do i1=1,4 pnuii(i1)=pnui(i1) pnucii(i1)=pnuci(i1) end do call threebod(pnucii,pnuii,tecm,pnuc3,plep3,ppi3,wt3) do i1=1,4 pnui3(i1)=pnuii(i1) pnuci3(i1)=pnucii(i1) pnuii(i1)=pnui(i1) pnucii(i1)=pnuci(i1) end do call twobod(pnucii,pnuii,tecm,pnuc2,plep2,wt2) do i1=1,4 pnui2(i1)=pnuii(i1) pnuci2(i1)=pnucii(i1) pnuii(i1)=pnui(i1) pnucii(i1)=pnuci(i1) end do c*************************************** c**** Do Phase Space for one pion N.C. pnuc3nc(4)=amp ppi3nc(4)=ampc plep3nc(4)=0. do i1=1,4 pnuii(i1) = pnui(i1) pnucii(i1) = pnuci(i1) enddo call threebod(pnucii,pnuii,tecm,pnuc3nc,plep3nc,ppi3nc,wt3nc) do i1=1,4 pnui3nc(i1)=pnuii(i1) pnuci3nc(i1)=pnucii(i1) end do do i2=1,nfin wtt(i2)=0. ident=nchanel(i2,intype,nuctype+1) C**** For Three Body Final States INELASTIC. if(ident.lt.15) then C**** Set iel for pion production. iel=0 if(ident.lt.7) then C**** For three body Charged Current interactions if(wt3.le.0.0) go to 100 C**** Set the input kinematics do i1=1,4 p1(i1)=pnuci3(i1) p2(i1)=pnuc3(i1) pe(i1)=plep3(i1) pnub(i1)=pnui3(i1) end do C**** Set ncc for isovector charged current. ncc=1 C**** Get the kinematic variables. call matvect if(s.lt.scut.or.ped.gt.0.)go to 100 call matform ! get form factors call matcoeff ! get coeffs call matdia(ident) !get a's and b's C**** Set z for neutrino or anti neutrino. 1) neutrino -1) anti-neutrino if(nutype.gt.0) then z = 1. else z = -1. endif C**** Find the weight for this interaction. wtt(i2)=wt3*qmat(z)*1.02e-3 !x10**-38 cm**2 else C**** For three body Neutral Current interactions if(wt3nc.le.0.0) go to 100 C**** Set the input kinematics do i1=1,4 p1(i1)=pnuci3nc(i1) p2(i1)=pnuc3nc(i1) pe(i1)=plep3nc(i1) pnub(i1)=pnui3nc(i1) end do call matvect if(s.lt.scut.or.ped.gt.0.)go to 100 C**** Set ncc for isovector neutral current. ncc=0 call matform call matcoeff C**** Set ncc for isoscalar neutral current. ncc=-1 call matform call matcoeff call matdia(ident) C**** Set z for neutrino or anti neutrino. 1) neutrino -1) anti-neutrino if(nutype.gt.0) then z = 1. else z = -1. endif wtt(i2)=wt3nc*qmat(z)*1.02e-3 !x10**-38 cm**2 end if else C**** For two body final states. ELASTIC if(wt2.le.0.0) go to 100 C**** Set the input kinematics do i1=1,4 p1(i1)=pnuci2(i1) p2(i1)=pnuc2(i1) pe(i1)=plep2(i1) pnub(i1)=pnui2(i1) end do C**** Set iel for no pion production. iel=1 C**** Set ncc for charged current isovector interactions ncc=1 call matvect call matform call matcoeff if(nutype.gt.0 .and. nuctype.eq.0) then C**** nu n --> l- p z=1. call matdia(15) wtm2=qmat(z) else if (nutype.lt.0 .and. nuctype.eq.1) then C**** nubar p --> l+ n z=-1. call matdia(16) wtm2=qmat(z) else C**** interactions that make no visible particle. C**** nu p --> nu p C**** nubar n --> nubar n wtm2 = 0.0 end if wtt(i2)=wt2*wtm2*.0631 ! x10**-38 cm**2 end if 100 continue end do c***************************** c Find the weights for the two pion final states npion2p=2 C**** Find the charged current weight. itype=0 call twopi(npion2p,itype,nutype,pnui,nuctype,pnuci, $ nuctypef2pcc,pnuc2pcc,leptypef2pcc,plep2pcc, $ pitypef2pcc,ppi2pcc,wt2pcc) if(wt2pcc.gt.0.) then ident2pcc=1 do i2=1,2 ident2pcc=ident2pcc+(pitypef2pcc(i2)+1)*3**(2-i2) end do ident2pcc=ident2pcc+nuctypef2pcc*9+20 else C***** In Original Version These are NOT SET TO ZERO. wt2pcc = 0.0 ident2pcc = 0 end if C**** Find the neutral current weight. itype=1 call twopi(npion2p,itype,nutype,pnui,nuctype,pnuci, $ nuctypef2pnc,pnuc2pnc,leptypef2pnc,plep2pnc, $ pitypef2pnc,ppi2pnc,wt2pnc) if(wt2pnc.gt.0.) then ident2pnc=1 do i2=1,2 ident2pnc=ident2pnc+(pitypef2pnc(i2)+1)*3**(2-i2) end do ident2pnc=ident2pnc+nuctypef2pnc*9+40 else wt2pnc = 0.0 ident2pnc = 0 end if C*************************************************** C Find the weights for the three pion final states. npion3p=3 C**** Find the weight for three pion charged current. itype=0 call threepi(npion3p,itype,nutype,pnui,nuctype,pnuci, $ nuctypef3pcc,pnuc3pcc,leptypef3pcc,plep3pcc, $ pitypef3pcc,ppi3pcc,wt3pcc) if(wt3pcc.gt.0.) then ident3pcc=1 do i2=1,3 ident3pcc=ident3pcc+(pitypef3pcc(i2)+1)*3**(3-i2) end do ident3pcc=ident3pcc+nuctypef3pcc*27 + 60 else wt3pcc = 0.0 ident3pcc = 0 end if C**** Find the weight for three pion neutral current. itype=1 call threepi(npion3p,itype,nutype,pnui,nuctype,pnuci, $ nuctypef3pnc,pnuc3pnc,leptypef3pnc,plep3pnc, $ pitypef3pnc,ppi3pnc,wt3pnc) if(wt3pnc.gt.0.) then ident3pnc=1 do i2=1,3 ident3pnc=ident3pnc+(pitypef3pnc(i2)+1)*3**(3-i2) end do ident3pnc=ident3pnc+nuctypef3pnc*27 + 120 else wt3pnc = 0.0 ident3pnc = 0 end if c******************************************************** c pick particular final state from nfinal choices C**** Find the total weight of having an interaction. wttot=0. do i1=1,nfin if(wtt(i1).lt.0.) wtt(i1) = 0.0 wttot=wttot+wtt(i1) end do wttot=wttot+wt2pcc+wt2pnc wttot=wttot+wt3pcc+wt3pnc C**** Generate a random weight for this event. wtrand = ranf()*wtmax C**** If wttot is larger than wtmax warn incase this is happening to much. if(wttot.gt.wtmax) then ngreat=ngreat+1 type *, 'FINAL_STATE:: wtmax no large enough, rescaling wttot.' type '('' number: '',I4,'' weight:'',F10.6, $ '' energy:'',2F7.3)', $ ngreat,wttot,pnui(4),pnuci(4) wtrand = wtrand*wttot/wtmax end if C**** If the random weight is greater that the total weight C of this event then return with no interaction. if(wtrand.gt.wttot) then wtf=0. return end if C******************************************************** C Find the final state interaction by summing weights until the sum C is greater than the random weight of this event. wtsum=0. C**** Check if this event is a quasi elastic or a one pion interaction. do i1=1,nfin wtsum=wtsum+wtt(i1) if(wtsum.gt.wtrand) then ifinal=i1 go to 500 end if end do C**** Check if this event is a two pion interaction. wtsum=wtsum+wt2pcc if(wtsum.gt.wtrand) go to 600 !two pion cc wtsum=wtsum+wt2pnc if(wtsum.gt.wtrand) go to 700 !two pion nc C**** Check if this event is a three pion interaction. wtsum=wtsum+wt3pcc if(wtsum.gt.wtrand) go to 6003 !three pion cc wtsum=wtsum+wt3pnc if(wtsum.gt.wtrand) go to 7003 !three pion nc C**** If this is reached then wtsum is less than wttot and we have a problem. type *, 'FINAL_STATE: wtsum less than random weight' type *, ' wtsum',wtsum,' wtrand',wtrand,' wttot',wttot wtf = 0.0 return 500 continue !single pion+QE wtf=wtt(ifinal) ident=nchanel(ifinal,intype,nuctype+1) identf=ident if(ident.lt.15) then ! final state single pi prod npion=1 pitypef(1)=iptype(ident) if(ident.lt.7) then ! C.C. leptypef=-nutype nuctypef=nuctype-pitypef(1)-sign(1,leptypef) do i1=1,4 ppi(i1,1)=ppi3(i1) pnuc(i1)=pnuc3(i1) pnuci(i1)=pnuci3(i1) plep(i1)=plep3(i1) pnui(i1)=pnui3(i1) end do if (wt3.gt.149.) then type *, 'FINAL_STATE:: wt3 is big',wt3,ident,nutype endif else ! N.C. leptypef=0 nuctypef=nuctype-pitypef(1) do i1=1,4 ppi(i1,1)=ppi3nc(i1) pnuc(i1)=pnuc3nc(i1) pnuci(i1)=pnuci3nc(i1) plep(i1)=plep3nc(i1) pnui(i1)=pnui3nc(i1) end do end if else npion=0 pitypef(1)=3 ! Q.E. so no pion in f.s. leptypef=-nutype nuctypef=abs(1.-nuctype) do i1=1,4 ppi(i1,1)=0. pnuc(i1)=pnuc2(i1) pnuci(i1)=pnuci2(i1) plep(i1)=plep2(i1) pnui(i1)=pnui2(i1) end do end if return 600 continue !double pi wtf=wt2pcc ident=ident2pcc identf=ident npion=2 do i1=1,npion pitypef(i1)=pitypef2pcc(i1) end do leptypef=leptypef2pcc nuctypef=nuctypef2pcc do i1=1,4 do i2=1,npion ppi(i1,i2)=ppi2pcc(i1,i2) end do pnuc(i1)=pnuc2pcc(i1) pnuci(i1)=pnuci(i1) plep(i1)=plep2pcc(i1) pnui(i1)=pnui(i1) end do return 700 continue wtf=wt2pnc ident=ident2pnc identf=ident npion=2 do i1=1,npion pitypef(i1)=pitypef2pnc(i1) end do leptypef=leptypef2pnc nuctypef=nuctypef2pnc do i1=1,4 do i2=1,npion ppi(i1,i2)=ppi2pnc(i1,i2) end do pnuc(i1)=pnuc2pnc(i1) pnuci(i1)=pnuci(i1) plep(i1)=plep2pnc(i1) pnui(i1)=pnui(i1) end do return 6003 continue !triple pi wtf=wt3pcc ident=ident3pcc identf=ident npion=3 do i1=1,npion pitypef(i1)=pitypef3pcc(i1) end do leptypef=leptypef3pcc nuctypef=nuctypef3pcc do i1=1,4 do i2=1,npion ppi(i1,i2)=ppi3pcc(i1,i2) end do pnuc(i1)=pnuc3pcc(i1) pnuci(i1)=pnuci(i1) plep(i1)=plep3pcc(i1) pnui(i1)=pnui(i1) end do return 7003 continue wtf=wt3pnc ident=ident3pnc identf=ident npion=3 do i1=1,npion pitypef(i1)=pitypef3pnc(i1) end do leptypef=leptypef3pnc nuctypef=nuctypef3pnc do i1=1,4 do i2=1,npion ppi(i1,i2)=ppi3pnc(i1,i2) end do pnuc(i1)=pnuc3pnc(i1) pnuci(i1)=pnuci(i1) plep(i1)=plep3pnc(i1) pnui(i1)=pnui(i1) end do return end C********************************************************** subroutine twobod(pnuci,pnui,tecm,pnuc,plep,wt) dimension pnuci(4),pnui(4),pnuc(4),plep(4),ppi(4) dimension ppiprime(4),pnucprime(4),beta(3),dir(3),pdum(4) C*************************************************** C @(#)masses.cdk 1.2 modified on 12/30/92 C The particle masses C PROTON - AMP C NEUTRON - AMN C LAMBDA - AML C SIGMA - AMS C ELECTRON - AMEL C MUON - AMMU C PI 0 - AMPO C PI +/- - AMPC C ETA = AMETA C OMEGA = AMOM C RHO = AMRHO C K 0 = AMKO C K +- = AMKC C K* 0 = AMKSO C K* +- = AMKSC C*** The leptons real AMEL, AMMU C*** The baryons real AMP, AMN, AML, AMS C*** The mesons real AMPO, AMPC, AMETA, AMOMG, AMRHO C*** The strange mesons. real AMKO, AMKC, AMKSO, AMKSC COMMON/MASSES/AMEL,AMMU, $ AMP, AMN, AML, AMS, $ AMPO, AMPC, AMETA, AMRHO, AMOMG, $ AMKO, AMKC, AMKSO, AMKSC real mpn,m0,ksq,ksqmin,ksqmax data slope/2.26/ c c routine to generate three body phase space c in cms and lab frames c pass lepton mass input in plep(4), ditto for pion + nucleon c amlep=plep(4) amnuc=pnuc(4) c c calculate lepton 4-momenta c do i=1,3 beta(i)=(pnui(i)+pnuci(i))/(pnui(4)+pnuci(4)) end do call lorentz(pnui,pdum,beta) do i=1,4 pnui(i)=pdum(i) end do call lorentz(pnuci,pdum,beta) do i=1,4 pnuci(i)=pdum(i) end do tecm2=sqrt((pnui(4)+pnuci(4))**2-(pnui(1)+pnuci(1))**2 2 -(pnui(2)+pnuci(2))**2-(pnui(3)+pnuci(3))**2) tecm=tecm2 if(tecm.lt.(amlep+amnuc)) then wt=0. return end if elep=(tecm**2+amlep**2-amnuc**2)/(2.*tecm) plepm=sqrt(elep**2-amlep**2) c c now do k-squared importance sampling c k-squared usually <0. c pncm=pnui(4) pn=pnui(4) ksq=2.*pn*plepm ksqmin=amlep**2-2.*pn*elep-ksq ksqmax=ksqmin+2.*ksq if(ksqmax.gt.amlep**2) then wt=0. return end if r=ranf() if((slope*ksqmin).gt.-30.) then b=r*exp(slope*ksqmax)+(1.-r)*exp(slope*ksqmin) else b=(r)*exp(slope*ksqmax) end if ksq=log(b)/slope c c calculate k**2 weight c if(slope*ksqmin.gt.-30.) then zmien=exp(slope*ksqmax)-exp(slope*ksqmin) if(abs(zmien).lt.1e-10)then wt=0. return end if aa=slope/zmien else aa=slope/(exp(slope*ksqmax)) end if wtksq=aa*exp(slope*ksq) c c calculate total phase space weight c including the "1/V" factor c wt=3.1416/(wtksq*tecm*pncm)/(tecm*pncm) if(wt.gt.150.) then type *, 'TWOBOD:: wt2 is two big',wt wt=150. endif c c calculate nu-lep angle given k**2 c ct=(ksq-amlep**2+2.*pn*elep)/(2.*pn*plepm) if(abs(ct).gt.1.) then print *,'TWOBOD:: trouble in twobod abs(ct)>1' wt=0. return end if call cone(pnui,dir,ct,-1.) !get nu dir given k**2 pnucm=0. do i=1,3 plep(i)=dir(i)*plepm pnuc(i)=-plep(i) pnucm=pnucm+pnuc(i)**2 end do plep(4)=elep pnuc(4)=sqrt(pnucm+amnuc**2) c c transform everything into lab frame c do i=1,3 beta(i)=-beta(i) end do call lorentz(plep,pdum,beta) do i=1,4 plep(i)=pdum(i) end do call lorentz(pnuc,pdum,beta) do i=1,4 pnuc(I)=pdum(i) end do call lorentz(pnuci,pdum,beta) do i=1,4 pnuci(I)=pdum(i) end do call lorentz(pnui,pdum,beta) do i=1,4 pnui(I)=pdum(i) end do return end C************************************************************* subroutine threebod(pnuci,pnui,tecm,pnuc,plep,ppi,wt) dimension pnuci(4),pnui(4),pnuc(4),plep(4),ppi(4) dimension ppiprime(4),pnucprime(4),beta(3),dir(3),pdum(4) dimension beta2(3) C*************************************************** C @(#)masses.cdk 1.2 modified on 12/30/92 C The particle masses C PROTON - AMP C NEUTRON - AMN C LAMBDA - AML C SIGMA - AMS C ELECTRON - AMEL C MUON - AMMU C PI 0 - AMPO C PI +/- - AMPC C ETA = AMETA C OMEGA = AMOM C RHO = AMRHO C K 0 = AMKO C K +- = AMKC C K* 0 = AMKSO C K* +- = AMKSC C*** The leptons real AMEL, AMMU C*** The baryons real AMP, AMN, AML, AMS C*** The mesons real AMPO, AMPC, AMETA, AMOMG, AMRHO C*** The strange mesons. real AMKO, AMKC, AMKSO, AMKSC COMMON/MASSES/AMEL,AMMU, $ AMP, AMN, AML, AMS, $ AMPO, AMPC, AMETA, AMRHO, AMOMG, $ AMKO, AMKC, AMKSO, AMKSC data gm/.25/,m0/1.35/ real mpn,m0,ksq,ksqmin,ksqmax,mpncut data slope/2.26/ data mpncut/1.5/ !cut to fit nu data c c routine to generate three body phase space c in lab frame for nu-nuc->lep nuc pi c pass lepton mass input in plep(4), ditto for pion + nucleon c amlep=plep(4) ampi=ppi(4) amnuc=pnuc(4) do i=1,3 beta(i)=(pnui(i)+pnuci(i))/(pnui(4)+pnuci(4)) end do call lorentz(pnui,pdum,beta) do i=1,4 pnui(i)=pdum(i) end do call lorentz(pnuci,pdum,beta) do i=1,4 pnuci(i)=pdum(i) end do tecm2=sqrt((pnui(4)+pnuci(4))**2-(pnui(1)+pnuci(1))**2 2 -(pnui(2)+pnuci(2))**2-(pnui(3)+pnuci(3))**2) tecm=tecm2 if(tecm.lt.(amlep+ampi+amnuc)) then wt=0. return end if c c importance sample on mpn c ampnmin=ampi+amnuc ampnmax=tecm-amlep if(ampnmin.ge.ampnmax) then wt=0. return end if thmin=atan(2.*(ampnmin-m0)/gm) thmax=atan(2.*(ampnmax-m0)/gm) anorm=gm/(2.*(thmax-thmin)) r=ranf() th=thmin+gm*r/(2.*anorm) mpn=m0+gm*tan(th)/2. if(mpn.gt.mpncut) then wt=0. return end if if(mpn.gt.tecm) then type *,'THREEBOD:: mpn>tecm',mpn,tecm wt=0. return end if c c calculate weight of mpn c wtmpn=anorm/((mpn-m0)**2+gm**2/4.) c c calculate lepton 4-momenta c elep=(tecm**2+amlep**2-mpn**2)/(2.*tecm) plepm=(elep**2-amlep**2) if(plepm.le..000025) then plepm=.000025 elep=sqrt(plepm+amlep**2) end if plepm=sqrt(plepm) c c now do k-squared importance sampling in lab c k-squared is usually < 0. c pncm=pnui(4) pn=pnui(4) ksq=2.*pn*plepm ksqmin=amlep**2-2.*pn*elep-ksq ksqmax=ksqmin+2.*ksq if(ksqmax.gt.amlep**2) then type *,'THREEBOD:: ksqmax too big' wt=0. return end if if(ksqmax.le.ksqmin) then type *,'THREEBOD:: ksqmax.le.ksqmin' wt=0. return end if r=ranf() if((slope*ksqmin).gt.-30.) then b=r*exp(slope*ksqmax)+(1.-r)*exp(slope*ksqmin) else b=(1.-r)*exp(slope*ksqmax) end if ksq=log(b)/slope c c calculate k**2 weight c if(slope*ksqmin.gt.-30.) then cc=(exp(slope*ksqmax)-exp(slope*ksqmin)) if(cc.le.0.) cc=1.e-10 aa=slope/cc else aa=slope/(exp(slope*ksqmax)) end if wtksq=aa*exp(slope*ksq) c c calculate nu-lep angle given k**2 c ct=(ksq-amlep**2+2.*pn*elep)/(2.*pn*plepm) if(abs(ct).gt.1.) then if (abs(ct).gt.1.01) then type *, 'THREEBOD::' type *, 'err in 3b abs(ct)>1.' type *, 'ct,ksq,amlep,pn,elep,plepm,ksqmin,ksqmax' type *, ct,ksq,amlep,pn,elep,plepm,ksqmin,ksqmax endif ct=sign(1.,ct) end if call cone(pnui,dir,ct,-1.) !get nu dir given k**2 c c get new lep dir c do i=1,3 plep(i)=dir(i)*plepm end do plep(4)=elep c c calculate pion and nucleon 4-momenta in the mpn frame c epi=(mpn**2+ampi**2-amnuc**2)/(2.*mpn) enuc=mpn-epi ppim=sqrt(epi**2-ampi**2) ppimprime=ppim call ranve(1.0,dir,2.,-2.) do i=1,3 ppiprime(i)=dir(i)*ppim pnucprime(i)=-ppiprime(i) end do ppiprime(4)=epi pnucprime(4)=enuc c c lorentz pion and nuc momenta into cms frame c do i=1,3 beta2(i)=plep(i)/sqrt(mpn**2+plepm**2) end do call lorentz(pnucprime,pnuc,beta2) call lorentz(ppiprime,ppi,beta2) c c calculate total phase space weight c wt=3.1416**2*ppimprime/(2.*wtksq*wtmpn*tecm*pncm)/(tecm*pncm) if(wt.gt.150.) then type '(''THREEBOD:: wt is two big.'',F8.1,F,F,F,F6.3,F6.3)', $ wt,ppimprime,wtksq,wtmpn,tecm,pncm wt=150. endif c c transform everything into lab frame c do i=1,3 beta(i)=-beta(i) end do call lorentz(plep,pdum,beta) do i=1,4 plep(i)=pdum(i) end do call lorentz(pnuc,pdum,beta) do i=1,4 pnuc(i)=pdum(i) end do call lorentz(ppi,pdum,beta) do i=1,4 ppi(i)=pdum(i) end do call lorentz(pnui,pdum,beta) do i=1,4 pnui(i)=pdum(i) end do call lorentz(pnuci,pdum,beta) do i=1,4 pnuci(i)=pdum(i) end do return end subroutine twopi(npion,itype,nutype,pnui,nuctype,pnuci, $ nuctypef,pnuc,leptypef,plep,pitypef,ppi,wt) c c call once per cc and nc event c itype=0 C.C. c itype=1 N.C. c dimension pnui(4),pnuci(4),pnuc(4),plep(4),ppi(4,10) integer pitypef(10) dimension wtcorrect(18,2) !correction (ident,itype+1) data wtcorrect/36*0./ if(icalled.eq.0) then icalled=1 end if 1234 continue if(npion.ne.2) then wt=0. return end if call multi2pi(npion,itype,nutype,pnui,nuctype,pnuci, $ nuctypef,pnuc,leptypef,plep,pitypef,ppi,wt) ident=1 do ijk=1,npion ident=ident + (pitypef(ijk)+1)*3**(npion-ijk) end do ident=ident+nuctypef*9 return end subroutine threepi(npion,itype,nutype,pnui,nuctype,pnuci, $ nuctypef,pnuc,leptypef,plep,pitypef,ppi,wt) c c call once per cc and nc event c itype=0 C.C. c itype=1 N.C. c dimension pnui(4),pnuci(4),pnuc(4),plep(4),ppi(4,10) integer pitypef(10) dimension wtcorrect(18,2) !correction (ident,itype+1) data wtcorrect/36*0./ if(icalled.eq.0) then icalled=1 end if 1234 continue if(npion.ne.3) then wt=0. return end if call multi3pi(npion,itype,nutype,pnui,nuctype,pnuci, $ nuctypef,pnuc,leptypef,plep,pitypef,ppi,wt) ident=1 do ijk=1,npion ident=ident+(pitypef(ijk)+1)*3**(npion-ijk) end do ident=ident+nuctypef*9 return end subroutine multi2pi(npion,itype,nutype,pnui,nuctype,pnuci $ ,nuctypef,pnuc,leptypef,plep,pitypef,ppi,wt) c c itype=0 C.C. c itype=1 N.C. c dimension pnui(4),pnuci(4),pnuc(4),plep(4),ppi(4,10) integer pitypef(10) dimension constant(2,2) ! const(itype+1,i) i=1 for nubar i=2 for nu data constant/1.,1.,1.,1./ ! to convert to abs. cross sec. c c initialization c if(icalled.eq.0) then icalled=1 constant(1,1)=19500. ! cc nu in 10**-38 cm**2 constant(2,1)=.34*19500. ! nc nu constant(1,2)=19500. ! cc nubar constant(2,2)=.39*19500. ! nc nubar end if if(npion.gt.10) then wt=0. return end if do i=1,10 pitypef(i)=10 end do nupquarki=1 if(nuctype.eq.1) nupquarki=2 initcharge=nuctype wtquark=0. c c pick initial meson type c if(itype.eq.0) then ! do C.C. wtquark=3-nupquarki ! weight from # quarks if(nutype.lt.0) wtquark=nupquarki leptypef=-nutype lepcharge=sign(1,leptypef) iquark=lepcharge !identify struck quark ss=(nuctype-.5)*nutype if(ss.lt.0) then ! nu-n or nubar-p r=ranf() if(r.lt..333333) then nuctypef=0 pitypef(1)=1 pitypef(2)=0 else if(r.gt..66666) then nuctypef=1 pitypef(1)=1 pitypef(2)=-1 else nuctypef=1 pitypef(1)=0 pitypef(2)=0 end if end if if(nutype.lt.0) then nuctypef=1-nuctypef pitypef(1)=-pitypef(1) pitypef(2)=-pitypef(2) end if else ! nu-p or nubar-n r=ranf() if(r.lt..5) then nuctypef=0 pitypef(1)=1 pitypef(2)=1 else nuctypef=1 pitypef(1)=1 pitypef(2)=0 end if if(nutype.lt.0) then nuctypef=1-nuctypef pitypef(1)=-pitypef(1) pitypef(2)=-pitypef(2) end if end if else ! do N.C.s leptypef=0 lepcharge=0 wtquark=1.5 r=ranf() if(r.lt..33333) then pitypef(1)=1 pitypef(2)=-1 else if(r.gt..666666) then pitypef(1)=0 pitypef(2)=0 else pitypef(1)=-1 pitypef(2)=0 end if end if if(nuctype.eq.1) then pitypef(1)=-pitypef(1) pitypef(2)=-pitypef(2) end if nuctypef=nuctype-pitypef(1)-pitypef(2) end if if(nuctype-nuctypef-lepcharge-pitypef(1)-pitypef(2).ne.0) then wt=0. print *,'error bad charges' print *,nuctype,nuctypef,leptypef,pitypef return end if call multipips(npion,itype,nutype,pnui,nuctype,pnuci $ ,nuctypef,pnuc,leptypef,plep,pitypef,ppi,wtps) qq=(pnui(4)-plep(4))**2-(pnui(1)-plep(1))**2 $ -(pnui(2)-plep(2))**2- $ (pnui(3)-plep(3))**2 wtff=1. ijk=1 if(nutype.lt.0) ijk=2 wt=constant(itype+1,ijk)*wtps*wtquark*wtff return end subroutine multi3pi(npion,itype,nutype,pnui,nuctype,pnuci, $ nuctypef,pnuc,leptypef,plep,pitypef,ppi,wt) c c itype=0 C.C. c itype=1 N.C. c dimension pnui(4),pnuci(4),pnuc(4),plep(4),ppi(4,10) integer pitypef(10) dimension constant(2,2) ! const(itype+1,i) i=1 for nubar i=2 for nu data constant/1.,1.,1.,1./ ! to convert to abs. cross sec. c c initialization c if(icalled.eq.0) then icalled=1 constant(1,1)=7.6e5 ! cc nu in 10**-38 cm**2 constant(2,1)=7.6e5*.34 ! nc nu constant(1,2)=7.6e5 ! cc nubar constant(2,2)=7.6e5*.39 ! nc nubar end if if(npion.gt.10) then wt=0. return end if do i=1,10 pitypef(i)=10 end do nupquarki=1 if(nuctype.eq.1) nupquarki=2 initcharge=nuctype wtquark=0. c c pick charges c if(itype.eq.0) then ! do C.C. wtquark=3-nupquarki ! weight from # quarks if(nutype.lt.0) wtquark=nupquarki leptypef=-nutype lepcharge=sign(1,leptypef) iquark=lepcharge !identify struck quark if(nutype.gt.0) then if(nuctype.gt.0) then !nu-p r=ranf() if(r.lt..33333333) then pitypef(1)=1 pitypef(2)=0 pitypef(3)=0 nuctypef=1 else if(r.gt..66666666) then pitypef(1)=1 pitypef(2)=1 pitypef(3)=0 nuctypef=0 else pitypef(1)=1 pitypef(2)=1 pitypef(3)=-1 nuctypef=1 end if end if else !nu-n r=ranf() if(r.lt..25) then pitypef(1)=0 pitypef(2)=0 pitypef(3)=0 nuctypef=1 end if if(r.gt..25.and.r.lt..5) then pitypef(1)=1 pitypef(2)=0 pitypef(3)=0 nuctypef=0 end if if(r.gt..5.and.r.lt..75) then pitypef(1)=1 pitypef(2)=0 pitypef(3)=-1 nuctypef=1 end if if(r.gt..75) then pitypef(1)=1 pitypef(2)=1 pitypef(3)=-1 nuctypef=0 end if end if else !nubar-p if(nuctype.gt.0) then r=ranf() if(r.lt..25) then pitypef(1)=0 pitypef(2)=0 pitypef(3)=0 nuctypef=0 end if if(r.gt..25.and.r.lt..5) then pitypef(1)=-1 pitypef(2)=0 pitypef(3)=0 nuctypef=1 end if if(r.gt..5.and.r.lt..75) then pitypef(1)=1 pitypef(2)=0 pitypef(3)=-1 nuctypef=0 end if if(r.gt..75) then pitypef(1)=1 pitypef(2)=-1 pitypef(3)=-1 nuctypef=1 end if else !nubar-n r=ranf() if(r.lt..3333333333) then pitypef(1)=-1 pitypef(2)=0 pitypef(3)=0 nuctypef=0 else if(r.gt..666666666) then pitypef(1)=-1 pitypef(2)=-1 pitypef(3)=0 nuctypef=1 else pitypef(1)=1 pitypef(2)=-1 pitypef(3)=-1 nuctypef=0 end if end if end if end if else ! do N.C.s leptypef=0 lepcharge=0 nuctypef=nuctype-ich wtquark=3./2. r=ranf() if(r.lt..5) then nuctypef=nuctype r=ranf() if(r.lt..5) then pitypef(1)=0 pitypef(2)=0 pitypef(3)=0 else pitypef(1)=1 pitypef(2)=-1 pitypef(3)=0 end if else nuctypef=1-abs(nuctype) r=ranf() if(r.gt..5) then pitypef(1)=1 pitypef(2)=-1 else pitypef(1)=0 pitypef(2)=0 end if pitypef(3)=nuctype-nuctypef-pitypef(1)-pitypef(2) end if end if 7654 continue if(abs(pitypef(npion)).gt.1) then wt=0. print *,'pi charge wrong',initcharge,lepcharge,nuctypef print *,(pitypef(i),i=1,npion) return end if call multipips(npion,itype,nutype,pnui,nuctype,pnuci $ ,nuctypef,pnuc,leptypef,plep,pitypef,ppi,wtps) ijk=1 if(nutype.lt.0) ijk=2 wt=constant(itype+1,ijk)*wtps*wtquark return end subroutine multipips(npion,itype,nutype,pnui,nuctype,pnuci 2 ,nuctypef,pnuc,leptypef,plep,pitypef,ppi,wt) c c itype=0 C.C. c itype=1 N.C. c dimension pnui(4),pnuci(4),pnuc(4),plep(4),ppi(4,10) integer pitypef(10) dimension pnucm(4),pnuccm(4),beta(3),dir(3),phad(4),pdum(4) dimension betacmtolab(3),constant(2),pdumdum(4),plepcm(4) data constant/1.,1./ common/genin/npgenbod,tecmgenbod,amass(18),kgenev common/genout/pcm(5,18),wtgenbod C*************************************************** C @(#)masses.cdk 1.2 modified on 12/30/92 C The particle masses C PROTON - AMP C NEUTRON - AMN C LAMBDA - AML C SIGMA - AMS C ELECTRON - AMEL C MUON - AMMU C PI 0 - AMPO C PI +/- - AMPC C ETA = AMETA C OMEGA = AMOM C RHO = AMRHO C K 0 = AMKO C K +- = AMKC C K* 0 = AMKSO C K* +- = AMKSC C*** The leptons real AMEL, AMMU C*** The baryons real AMP, AMN, AML, AMS C*** The mesons real AMPO, AMPC, AMETA, AMOMG, AMRHO C*** The strange mesons. real AMKO, AMKC, AMKSO, AMKSC COMMON/MASSES/AMEL,AMMU, $ AMP, AMN, AML, AMS, $ AMPO, AMPC, AMETA, AMRHO, AMOMG, $ AMKO, AMKC, AMKSO, AMKSC data twopi/6.2832/ if(npion.gt.10) then wt=0. return end if c c next, pick scaling variables x and y c call pickx(x,nutype,itype) if(x.gt.1.) then print *,' x>1',x wt=0. return end if wtx=1. !should be like # of proper quarks in the struk nucleon??? enu=pnui(4) amnucleon=amp call picky(x,enu,amnucleon,y,nutype,itype) if(y.gt.1.) then print *,' y>1',y wt=0. return end if c c now generate plep c amlep=0. !remember partons are massless elep=enu*(1.-y) plepm=elep amlep=0. if(itype.eq.0) then amlep=amel if(abs(nutype).gt.1) amlep=ammu end if plep(4)=sqrt(elep**2+amlep**2) c anuscal=enu*y c qsqscal=x*2.*amp*anuscal ct=1.- amp*x*y/elep if(abs(ct).gt.1.) then print *,' ct>1',ct wt=0. return end if call cone(pnui,dir,ct,-1.) do i=1,3 plep(i)=dir(i)*plepm end do c c go to cms system c do i=1,3 beta(i)=(pnui(i)+pnuci(i))/(pnui(4)+pnuci(4)) betacmtolab(i)=-beta(i) end do call lorentz(pnui,pnucm,beta) call lorentz(pnuci,pnuccm,beta) call lorentz(plep,plepcm,beta) enucm=pnucm(4) elepcm=plepcm(4) tecm=pnucm(4)+pnuccm(4) s=tecm**2 c c calculate weights for x and y distributions c wtx=1. !should be like # of proper quarks in the struk nucleon??? wty=s*x c c calculate hadronic momenta c do i=1,4 phad(i)=pnui(i)+pnuci(i)-plep(i) end do c c go to hadronic cms c do i=1,3 beta(i)=phad(i)/phad(4) end do call lorentz(phad,pdum,beta) teh=pdum(4) kgenev=2 amass(1)=amp amtot=amass(1) do i=2,npion+1 amass(i)=ampc amtot=amtot+amass(i) end do if(teh.lt.amtot) then wt=0. return end if tecmgenbod=teh npgenbod=npion+1 call genbod wtps=wtgenbod*(twopi**4.) 2 /((twopi**3.)**float(npgenbod))/(tecm*enucm) c c get hadronic momenta back into lab c do i=1,3 beta(i)=-beta(i) end do do i=1,4 pnuc(i)=pcm(i,1) end do call lorentz(pnuc,pdum,beta) do i=1,4 pnuc(i)=pdum(i) end do do i=1,npion do j=1,4 pdumdum(j)=pcm(j,i+1) end do call lorentz(pdumdum,pdum,beta) do j=1,4 ppi(j,i)=pdum(j) end do end do wt=wtx*wty*wtps*constant(itype+1) return end subroutine pickx(x,nutype,itype) external fnubarcc,fnucc,fnubarnc,fnunc dimension probx(100,2,2) c c itype=0 C.C. c itype=1 N.C. c if(icalled.eq.0) then icalled=1 xlow=0. xhigh=1. call funpre(fnubarcc,probx(1,1,1),xlow,xhigh) call funpre(fnucc,probx(1,2,1),xlow,xhigh) call funpre(fnubarnc,probx(1,1,2),xlow,xhigh) call funpre(fnunc,probx(1,2,2),xlow,xhigh) end if inutype=2 !neutrino if(nutype.lt.0) inutype=1 ! anti-nu call funran(probx(1,inutype,itype+1),x) return end subroutine picky(x,enu,amnuc,y,nutype,itype) c c itype=0 C.C. c itype=1 N.C. c inutype=1. !neutrino if(nutype.lt.0) inutype=2 !anti-nu r=ranf() c ymin=0. chi=2.*enu/(amnuc*x) ymax=chi/(1.+chi) if(inutype.eq.1) then y=r*ymax else xxx= 1. - r*(1.-(1.-ymax)**3) y=1.-xxx**.333333333 end if return end real function fnubarcc(xx) real x, xx if (xx.le.0.0) then x = 1.0E-4 else if (xx.ge.1.0) then x = 1.0 - 1.0E-4 else x = xx endif fnubarcc = (3.9*2./3.-1.2)*x**.55 $ * (1.-x)**3.2 + 1.1*2./3.*(1.-x)**8. return end real function fnubarnc(xx) real x, xx if (xx.le.0.0) then x = 1.0E-4 else if (xx.ge.1.0) then x = 1.0 - 1.0E-4 else x = xx endif fnubarnc=2./3.*(.1464+.1874) $ *(3.9*x**.55*(1.-x)**3.2+1.1*(1.-x)**8.) $ -1./3.*(.1033+.1767)*3.6*x**.55*(1.-x)**3.2 return end real function fnucc(xx) real x, xx if (xx.le.0.0) then x = 1.0E-4 else if (xx.ge.1.0) then x = 1.0 - 1.0E-4 else x = xx endif fnucc = (3.9*2./3.+1.2)*x**.55 * (1.-x)**3.2 $ + 1.1*2./3.*(1.-x)**8. return end real function fnunc(xx) real x, xx if (xx.le.0.0) then x = 1.0E-4 else if (xx.ge.1.0) then x = 1.0 - 1.0E-4 else x = xx endif fnunc = 2./3.*(.1464+.1874) $ *(3.9*x**.55*(1.-x)**3.2+1.1*(1.-x)**8.) $ +1./3.*(.1033+.1767)*3.6*x**.55*(1.-x)**3.2 return end C************************************************** C @(#)fermid.f 1.3 modified on 1/12/93 SUBROUTINE FERMId(NC,P,EFNUC) C NUCLEON MOMENTUM INSIDE O16 NUCLEUS IS GENERATED FOLLOWING C THE FIT OF PHYS. REV. C20(1979)744 DIMENSION P(4),PROBP(20),PROBPI(21),A(6) DATA A/.06140,-.38597,1.7283,-.30007,-.05410,-.04974/ DATA ALFA/.59206/,BETA/1.5428/,PI/3.1416/,HC/197./ logical isw/.true./ C*************************************************** C @(#)masses.cdk 1.2 modified on 12/30/92 C The particle masses C PROTON - AMP C NEUTRON - AMN C LAMBDA - AML C SIGMA - AMS C ELECTRON - AMEL C MUON - AMMU C PI 0 - AMPO C PI +/- - AMPC C ETA = AMETA C OMEGA = AMOM C RHO = AMRHO C K 0 = AMKO C K +- = AMKC C K* 0 = AMKSO C K* +- = AMKSC C*** The leptons real AMEL, AMMU C*** The baryons real AMP, AMN, AML, AMS C*** The mesons real AMPO, AMPC, AMETA, AMOMG, AMRHO C*** The strange mesons. real AMKO, AMKC, AMKSO, AMKSC COMMON/MASSES/AMEL,AMMU, $ AMP, AMN, AML, AMS, $ AMPO, AMPC, AMETA, AMRHO, AMOMG, $ AMKO, AMKC, AMKSO, AMKSC C**** The mass of the nucleon. REAL NucMass IF(ISW)then isw=.false. DO I=1,20 Q=((I-1)*20+10)/HC PR=0 DO J=1,6 AN=ALFA*BETA**J PR=PR+A(J)*(AN/PI)**1.5*EXP(-AN*Q**2) END DO PROBP(I)=PR*Q**2 END DO CALL CFD(PROBPI,20,PROBP) end if if (NC.eq.1) then NucMass = amp else NucMass = amn endif IF(NC.EQ.1.AND.ranf().LT..2)THEN C**** If nucleon is proton then it may be in a hydrogen. DO I=1,3 P(I)=0.0 END DO p(4)= NucMass EFNUC = NucMass NC=-1 ELSE C**** This nucleon is in an oxygen so find fermi momentum. PR=ranf() Q=PRBIN(PROBPI,20,0.,20.,PR) Q=Q*1.e-3 CALL RANVE(Q,P,2.,-1.) P(4)=sqrt(NucMass**2+Q**2) EFNUC=SQRT(.931**2-Q**2) NC=0 END IF RETURN END C********************************************* C @(#)nu_energy.f 1.2 modified on 12/29/92 C Generate a neutrino energy from a spectrum. subroutine nu_energy(enu, nudir, nutype, wtnu) implicit none integer i1 real r1, r2 C**** The neutrino energy real enu C**** The direction of the neutrino real nudir(3) C**** The internal definition of the neutrino type is: C 1 - electron C 2 - muon C 3 - anti-electron C 4 - anti-muon C**** The external definition of the neutrino type is: C 1 - electron C 2 - muon C -1 - anti-electron C -2 - anti-muon integer nutype C**** The event weight real wtnu C**** The number of energy bins. integer ebins, ebin parameter (ebins=200) C**** The number of cosine bins. integer cbins, cbin parameter (cbins=10) real cmin, cmax C**** The average cosine of the cosine bins. parameter (cmin=-1.0, cmax=1.0) real cosine(cbins) real dcos parameter (dcos = (cmax-cmin)/cbins) C**** The lowest energy of the energy bin. real emax, emin parameter (emax=5.0, emin=0.050) real energy(ebins+1) C**** The flux of the energy bin. real flux(ebins,cbins,4) C**** Make the conversion table from probability to energy real prob(ebins,cbins,4) C**** Make the sum table from probability to energy integer sbins, sbin parameter (sbins=ebins*cbins*4) real sum(sbins+1) integer called data called/0/ real ranf, nu_flux if (called.eq.0) then called = 1 C**** Set up the energy binning. do ebin = 1, ebins+1 energy(ebin) = emax*exp(-emax)*exp(emax*ebin/ebins) enddo C**** Set up the cosine binning. do cbin = 1, cbins cosine(cbin) = cmin + dcos*cbin - 0.5*dcos enddo C**** Set the flux. do nutype = 1,4 do cbin = 1,cbins do ebin = 1,ebins flux(ebin,cbin,nutype) = $ nu_flux(energy(ebin),cosine(cbin),nutype) enddo enddo enddo C**** Make the probability table. sbin = 1 sum(sbin) = 0 r1 = 0.0 do nutype = 1,4 do cbin = 1,cbins do ebin = 1,ebins sbin = sbin + 1 prob(ebin,cbin,nutype) = flux(ebin,cbin,nutype) sum(sbin) = sum(sbin-1) $ + prob(ebin,cbin,nutype) $ *dcos*(energy(ebin+1)-energy(ebin)) enddo enddo enddo C**** Normalize everything do nutype = 1, 4 do cbin = 1, cbins do ebin = 1, ebins prob(ebin,cbin,nutype) = $ prob(ebin,cbin,nutype)/sum(sbins+1) enddo enddo enddo do sbin = 1,sbins sum(sbin) = sum(sbin)/sum(sbins+1) enddo sum(sbins+1) = 1.0 endif C**** Find the bin of the probability. r1 = ranf() sbin = sbins/2 i1 = sbin 100 continue if (i1.gt.1) i1 = i1 / 2 if (r1.lt.sum(sbin)) then if (sbin.gt.1) then sbin = sbin - i1 goto 100 endif else if (r1.gt.sum(sbin+1)) then if (sbin.lt.sbins) then sbin = sbin + i1 goto 100 endif endif C**** Find the ebin,cbin,nutype index of the prob. nutype = sbin/ebins/cbins sbin = sbin - ebins*cbins*nutype cbin = sbin/ebins ebin = sbin - ebins*cbin nutype = nutype + 1 cbin = cbin + 1 ebin = ebin + 1 C**** Do a linear interpolation to find the actual values of enu and dirnu. r1 = ranf() enu = energy(ebin) + r1*(energy(ebin+1)-energy(ebin)) r2 = ranf() wtnu = cosine(cbin) + (r2-0.5)*dcos call ranve(1.0,nudir,wtnu,-1.0) C**** Return the weight of this event in Number/GeV/Cos/NuType wtnu = flux(ebin,cbin,nutype) if (nutype.gt.2) nutype = 2-nutype return end real function nu_flux(energy,cosine,nutype) implicit none real energy, cosine integer nutype real fluxnaumov real fluxleekoh89 integer last_used data last_used /0/ integer Use_Flux data Use_Flux /2/ common /Flux_To_Use/ Use_Flux if (Use_Flux.eq.1) then if (Last_Used.ne.1) then Last_Used = 1 write(6,*) 'NEUTRINO FLUX: Bugaev and Naumov Solar Minimum Flux.' endif nu_flux = fluxnaumov(energy,cosine,nutype) else if (Use_Flux.eq.2) then if (Last_Used.ne.2) then Last_Used = 2 write(6,*) 'NEUTRINO FLUX: Lee and Koh 89 Solar Average Flux.' endif nu_flux = FluxLeeKoh89(energy,cosine,nutype) else if (Use_Flux.eq.3) then if (Last_Used.ne.3) then Last_Used = 3 write(6,*) 'NEUTRINO FLUX: Uniform Flux.' endif nu_flux = 1.0 endif return end C***************************************************** C @(#)matrixelements.f 1.2 modified on 2/3/94 C C This contains the routines MAT* for calculating matrix elements in the C uci onepi model. C C FUNCTION FOR CALCULATING A FOUR DIMENSIONAL C DOT PRODUCT (A METRIC CONTRACTION OF TWO FOUR VECTORS) C THE METRIC IS gmunu=(1,-1,-1,-1) C 10/2/84 KSG FUNCTION D4(A,B) DIMENSION A(4),B(4) C=0. DO I=1,3 C=C+A(I)*B(I) END DO D4=A(4)*B(4)-C RETURN END FUNCTION EPS(A,B,C,D) dimension a(4),b(4),c(4),d(4) dimension v(24) V(1)=-A(1)*B(2)*C(3)*D(4) V(2)= A(1)*B(2)*C(4)*D(3) V(3)= A(1)*B(3)*C(2)*D(4) V(4)=-A(1)*B(4)*C(2)*D(3) V(5)=-A(1)*B(3)*C(4)*D(2) V(6)= A(1)*B(4)*C(3)*D(2) V(7)= A(2)*B(1)*C(3)*D(4) V(8)=-A(2)*B(1)*C(4)*D(3) V(9)=-A(3)*B(1)*C(2)*D(4) V(10)= A(4)*B(1)*C(2)*D(3) V(11)= A(3)*B(1)*C(4)*D(2) V(12)=-A(4)*B(1)*C(3)*D(2) V(13)=-A(2)*B(3)*C(1)*D(4) V(14)= A(2)*B(4)*C(1)*D(3) V(15)= A(3)*B(2)*C(1)*D(4) V(16)=-A(4)*B(2)*C(1)*D(3) V(17)=-A(3)*B(4)*C(1)*D(2) V(18)= A(4)*B(3)*C(1)*D(2) V(19)= A(2)*B(3)*C(4)*D(1) V(20)=-A(2)*B(4)*C(3)*D(1) V(21)=-A(3)*B(2)*C(4)*D(1) V(22)= A(4)*B(2)*C(3)*D(1) V(23)= A(3)*B(4)*C(2)*D(1) V(24)=-A(4)*B(3)*C(2)*D(1) EPS=0 DO I=1,24 EPS=EPS+V(I) END DO RETURN END subroutine matcoeff c****************************************************** c iel=1 for elastic (fills arrays .mnu) * c iel=0 for pi production * c * c ncc=-1 for isoscalar nc (fills arrays a..s) * c ncc= 0 for isovector nc (fills arrays ...2) * c ncc= 1 for isovector cc (fills arrays ...1) * c****************************************************** implicit real m,k common/elastic/iel,ncc common/coeff/AMpi1(8),BMpi1(8),AMN1(8),BMN1(8),AMNN1(8),BMNN1(8), 1 AMP1(8), BMP1(8), AMs1(8),BMs1(8),AMDL1(8),BMDL1(8), 2 AMD1(8),BMD1(8), 3 AMpi2(8),BMpi2(8),AMN2(8),BMN2(8),AMNN2(8),BMNN2(8), 4 AMP2(8), BMP2(8), AMs2(8),BMs2(8),AMDL2(8),BMDL2(8), 5 AMD2(8),BMD2(8), amnu(8),bmnu(8), 6 amns(8),amnns(8),amss(8),amds(8) COMPLEX AMpi(6),BMpi(6),ampi1,bmpi1,ampi2,bmpi2 COMPLEX AMN(6) ,BMN(6) ,amn1 ,bmn1, amn2 ,bmn2 ,amns COMPLEX AMNN(6),BMNN(6),amnn1,bmnn1,amnn2,bmnn2,amnns COMPLEX AMP(6) ,BMP(6) ,amp1 ,bmp1, amp2 ,bmp2 COMPLEX AMs(6) ,BMs(6) ,ams1 ,bms1 ,ams2 ,bms2 ,amss COMPLEX AMDL(6),BMDL(6),amdl1,bmdl1,amdl2,bmdl2 COMPLEX AMD(6) ,BMD(6) ,amd1 ,bmd1 ,amd2 ,bmd2 ,amds COMPLEX AMNU ,BMNU complex c1,q1,r1,e1,s1 common/matkin/p1p2,p1pe,p2pe,p1pnub,p2pnub,pepnub common/matscal/s,t,u,kk,kq,p1k,p2k,p1q,p2q common/form/fpit,f1vt,f2vt,c3vt,c4vt,g1vt,g2vt,h3vt,h4vt,h5vt, 1 fat,c5at,d1at,g1at,h5at c######################################################################### parameter (PI=3.14159263) c parameter (gNNpi=13.637, g=2.11, fp=4.45, fs=.48, fD=1.56) parameter (gNNpi=13.405, g=2.11, fp=4.45, fs=.48, fD=1.56) parameter (RT2=1.414213562, rt3=1.732050808) parameter (C2=1.5/RT2, C3=RT2, C4=.5/RT2, C5=1/RT2) parameter (C6=2/3., C7=1/3.*RT2, C8=1./RT3, C9=RT2/rt3) parameter (C10=RT3/2., C11=1/3., C12=2/3., C13=RT2/3.) parameter (C14=1./6., C15=3./2.) parameter (M=.938, MDL=1.232, MS=1.505, MP=1.434) parameter (MD=1.514, mpi=.139, mmu=.106) parameter (m2=M*M, mmdl=M+MDL, mmd=M+MD, mpi2=mpi*mpi) parameter (mndl=MDL-M, mnd=MD-M) parameter (mdl6=1./(6.*MDL), md6=1./(6.*MD)) parameter (mdl23=1./(3.*MDL*MDL), md23=1./(3.*MD*MD)) parameter (m2mdl=2.*m*mdl, m2md=2.*m*md) dimension lr(4),gr(4),qr(4) c width of the resonances c n=1 - p33 c n=2 - p11 c n=3 - s11 c n=4 - d13 data lr/1,1,0,2/ data gr/0.114,0.200,0.100,0.130/ data qr/0.2254,0.390,0.446,0.450/ parameter (xsq=0.1225) complex gam GAM(n)=(0.,1.)/2.*Gr(n)*(QP/QR(n))**(2*Lr(n)+1) 1 *((QR(n)**2+xsq)/(QP**2+xsq))**Lr(n) c******************* if(iel.eq.1)then c1=(1.,0.) amnu(5)=c1*fat bmnu(5)=c1*f1vt bmnu(6)=-f2vt/m go to 1000 end if c************************************************************* ep=(s+mpi2-m2)/2./sqrt(s) xxxx=ep**2-mpi2 if(xxxx.gt.0.) then qp=sqrt(xxxx) else open(unit=91,status='new',form='formatted',name='spoty.err') write(91,*) ' error in matcoeff qp=0.' write(91,*) ' xx,ep,s,mpi2',xxxx,ep,s,mpi2 write(91,*) ' p1p2,p1pe,p2pe,p1pnub,p2pnub,pepnub, 2s,t,u,kk,kq,p1k,p2k,p1q,p2q' write(91,*) p1p2,p1pe,p2pe,p1pnub,p2pnub,pepnub, 2 s,t,u,kk,kq,p1k,p2k,p1q,p2q close(unit=91) qp=0.01 end if p1kq=p1q+kq p1kk=p1k+kk p12kk=s-m2 p14kk=4*p1k+kk p1p2k=p1k+p2k p1p22k=p1p2+p2k sc1=s-2*p1p22k sc2=sc1+m2 sc3=sc1-m2+m2md sc4=sc1-m2-m2mdl c******************** FFVt=F1Vt+2*F2Vt C1=(1.,0.)*RT2*gNNpi/(u-M2) q1=c1*F1Vt AMN(1)= q1 AMN(2)=-q1 e1=C1*F2Vt/M AMN(3)=-e1 AMN(4)= e1 AMN(5)= e1*(2*p2k-kk) AMN(6)=-C1*FFVt c AMN(7)= C1*FFVt q1=c1*FAt BMN(1)= q1 BMN(2)=-q1 BMN(5)=-q1*2*M BMN(6)=-q1 c BMN(7)= q1 c******************** C1=(1.,0.)*RT2*gNNpi/(s-M2) e1=C1*F1Vt AMNN(1)= e1 AMNN(2)= e1 r1=C1*F2Vt/M AMNN(3)=-r1 AMNN(4)=-r1 AMNN(5)= r1*p12kk AMNN(6)=-C1*FFVt c AMNN(7)= C1*FFVt q1=C1*FAt BMNN(1)=-q1 BMNN(2)=-q1 BMNN(5)= q1*2*M BMNN(6)= q1 c BMNN(7)=-q1 c*********************** C1=C15*fs/(s-(Ms-gam(3))**2) q1=C1*G1Vt AMs(1)= q1 AMs(2)= q1 e1=C1*G2Vt/M AMs(3)= e1 AMs(4)= e1 AMs(5)=-q1*(M+Ms)-e1*p12kk Ams(6)=-q1-e1*(Ms-M) c Ams(7)= q1+e1*(Ms-M) q1=C1*G1At BMs(1)=-q1 BMs(2)=-q1 BMs(5)=-q1*(Ms-M) BMs(6)= q1 c BMs(7)=-q1 c*********************** C1=3/(2*mpi)*fD/(s-(MD-gam(4))**2) q1=C1*H3Vt/M r1=C1*H4Vt/m2 s1=C1*H5Vt/m2 y2=kq-(p1kq*md23+md6*mnd)*kk y3=mmd*kq/2+(mnd*C14-md6*p1kq)*kk y4=mmd*kq/2-((mmd*md23-md6)*p1kq+md6*sc3+mnd*C14)*kk AMD(1)=q1*y2+r1*y3+s1*y4 AMD(2)=q1*(y2-p12kk)+r1*(y3-mmd*p1kk)+s1*(y4-mmd*p1k) y2=kq/2+md6*p1kq*mnd-C14*sc2 y3=y2-(mnd*md6+md23*p1kq)*kk y4=-m*p1kq*md23-md6*(s-m2)+c12*mnd AMD(3)=q1*y4+r1*y2+s1*y3 AMD(4)=q1*(y4-mnd)+r1*(y2-p1kk)+s1*(y3-p1k) y2=kq-2*p1kq*p1kk*md23 y3=-2*md6*p1kq*mnd+C11*sc2 AMD(5)=q1*(mnd*y2 1 +2*md6*(2*p1kq*p12kk-p1kk*sc2)-C12*mnd*p12kk) 2 +r1*y3*p1kk+s1*y3*p1k y3=2*md6*p1kq-C11*mnd AMD(6)=q1*(-y2 1 +2*md6*(mnd*p1kk-2*m*p1kq)+c12*(sc3-p1kq)) 2 +r1*p1kk*y3+s1*p1k*y3 c y2=-kq/2+md23*p1kq*p12kk c y3=md6*(sc3*p12kk-p1kq*p14kk) c AMD(7)=q1*(-kk*(md23*p1kq+md6*mnd) c 1 +2*md6*(2*mmd*p1kq+md*(3*kq-2*sc3))) c 2 +r1*(kq/2*mmd-md6*p1kq*kk+C14*mnd*kk) c 3 +s1*(mmd*y2+y3+c14*mnd*p14kk) c AMD(8)=q1*(md23*mnd*p1kq+md6*sc2) c 1 +r1*(kq/2+md6*mnd*p1kq-C14*sc2) c 2 +s1*(y2+md6*(mmd*(m2-p1p22k)+md*p12kk)) c*************************************************************** if(ncc.lt.0)go to 100 c*************************************************************** C1=c1*H5At y2=-md6*(s-m2)+md23*mnd*p1kq BMD(1)=C1*(C11*mnd+y2) BMD(2)=C1*(-C12*mnd+y2) BMD(3)=-C1*(md6*mnd+p1kq*md23) BMD(4)=BMD(3)+c1 BMD(5)=C1*(-C11*sc3+p1kq*mmd*2*md6) BMD(6)=C1*(p1kq*2*md6-C11*mnd) c BMD(7)=C1*((mnd*sc2-p12kk*m)*md23/2+mnd*c11) c BMD(8)=C1*(md23*(p1p22k-s)-mnd*md6) c******************* C1=(1.,0.)*RT2*gNNpi*fpit/(t-mpi2) AMpi(2)=-C1*2 c AMpi(7)=C1 c******************* C1=C15*fp*D1At/(s-(Mp-gam(2))**2) BMp(1)=-C1 BMp(2)=-C1 BMp(5)= C1*(M+Mp) BMp(6)= C1 c BMp(7)=-C1 c****************** C1=g/mpi/(s-(MDL-gam(1))**2) q1=C1*C3Vt/M r1=C1*C4Vt/m2 y2=kq-(p1kq*mdl23+mdl6*mmdl)*kk y3=mndl*kq/2+(mmdl*C14-mdl6*p1kq)*kk AMDL(1)=q1*y2+r1*y3 AMDL(2)=q1*(y2-p12kk)+r1*(y3-mndl*p1kk) y2=-m*mdl23*p1kq+mdl6*p12kk-C12*mmdl y3=-kq/2-mdl6*p1kq*mmdl+C14*sc2 AMDL(3)=q1*y2+r1*y3 AMDL(4)=q1*(mmdl+y2)+r1*(y3+p1kk) y3=kq-2*p1kq*p1kk*mdl23 AMDL(5)=q1*(-mmdl*y3-2*mdl6*(2*p1kq*p12kk-sc2*p1kk) 1 +C12*mmdl*p12kk)+ 2 r1*p1kk*(2*mdl6*p1kq*mmdl-C11*sc2) AMDL(6)=q1*(-y3+2*mdl6*mmdl*(p1kk-2*p1p22k)+ 1 4*mdl6*m*s-c12*m*(mmdl+mdl))+ 1 r1*p1kk*(2*mdl6*p1kq-C11*mmdl) c AMDL(7)=q1*(-kk*(mdl23*p1kq+mdl6*mmdl)+ c 1 2*mdl6*(2*mndl*p1kq+mdl*(3*kq-2*sc4)))+ c 2 r1*(kq/2*mndl-mdl6*p1kq*kk+C14*mmdl*kk) c AMDL(8)=q1*(-mdl23*mmdl*p1kq-mdl6*sc2)+ c 1 r1*(-kq/2-mdl6*mmdl*p1kq+C14*sc2) C1=c1*C5At y2=-mdl6*(s-m2)+p1kq*mdl23*mmdl BMDL(1)=C1*( C11*mmdl+y2) BMDL(2)=C1*(-C12*mmdl+y2) BMDL(3)=C1*(mdl6*mmdl+p1kq*mdl23) BMDL(4)=BMDL(3)-c1 BMDL(5)=C1*(C11*sc4-p1kq*mndl*2*mdl6) BMDL(6)=C1*(2*p1kq*mdl6-C11*mmdl) c BMDL(7)=C1*((mmdl*sc2+p12kk*m)*mdl23/2+mmdl*c11) c BMDL(8)=C1*(mdl23*(s-p1p22k)+mmdl*mdl6) c************************************************************ c************************************************************ 100 if(ncc)1,2,3 1 continue do i=1,6 amns(i)=amn(i) amnns(i)=amnn(i) amss(i)=ams(i) amds(i)=amd(i) end do go to 1000 2 continue do i=1,6 ampi2(i)=ampi(i) bmpi2(i)=bmpi(i) amn2(i) =amn(i) bmn2(i) =bmn(i) amnn2(i)=amnn(i) bmnn2(i)=bmnn(i) amp2(i) =amp(i) bmp2(i) =bmp(i) ams2(i) =ams(i) bms2(i) =bms(i) amdl2(i)=amdl(i) bmdl2(i)=bmdl(i) amd2(i) =amd(i) bmd2(i) =bmd(i) end do go to 1000 3 continue do i=1,6 ampi1(i)=ampi(i) bmpi1(i)=bmpi(i) amn1(i) =amn(i) bmn1(i) =bmn(i) amnn1(i)=amnn(i) bmnn1(i)=bmnn(i) amp1(i) =amp(i) bmp1(i) =bmp(i) ams1(i) =ams(i) bms1(i) =bms(i) amdl1(i)=amdl(i) bmdl1(i)=bmdl(i) amd1(i) =amd(i) bmd1(i) =bmd(i) end do 1000 return end subroutine matdia(id) c****************************************************** c iel=1 for elastic (fills arrays .mnu) * c iel=0 for pi production * c * c ncc=-1 for isoscalar nc (fills arrays a..s) * c ncc= 0 for isovector nc (fills arrays ...2) * c ncc= 1 for isovector cc (fills arrays ...1) * c****************************************************** common/elastic/iel,ncc common/coeff/AMpi1(8),BMpi1(8),AMN1(8),BMN1(8),AMNN1(8),BMNN1(8), 1 AMP1(8), BMP1(8), AMs1(8),BMs1(8),AMDL1(8),BMDL1(8), 2 AMD1(8),BMD1(8), 3 AMpi2(8),BMpi2(8),AMN2(8),BMN2(8),AMNN2(8),BMNN2(8), 4 AMP2(8), BMP2(8), AMs2(8),BMs2(8),AMDL2(8),BMDL2(8), 5 AMD2(8),BMD2(8), amnu(8),bmnu(8), 6 amns(8),amnns(8),amss(8),amds(8) COMPLEX ampi1,bmpi1,ampi2,bmpi2 COMPLEX amn1 ,bmn1, amn2 ,bmn2 ,amns COMPLEX amnn1,bmnn1,amnn2,bmnn2,amnns COMPLEX amp1 ,bmp1, amp2 ,bmp2 COMPLEX ams1 ,bms1 ,ams2 ,bms2 ,amss COMPLEX amdl1,bmdl1,amdl2,bmdl2 COMPLEX amd1 ,bmd1 ,amd2 ,bmd2 ,amds COMPLEX AMNU ,BMNU common/cofmat/a(8),b(8) complex a,b c######################################################################### parameter (RT2=1.414213562, rt3=1.732050808) parameter (C2=1.5/RT2, C3=RT2, C4=.5/RT2, C5=1/RT2) parameter (C6=2/3., C7=1/3.*RT2, C8=1./RT3, C9=RT2/rt3) parameter (C10=RT3/2., C11=1/3., C12=2/3., C13=RT2/3.) parameter (C14=1./6., C15=3./2.) c******************* fun ******* complex a1fcc,a2fcc,b1fcc,b2fcc complex a1fnc,a2fnc,b1fnc,b2fnc,a3fnc a1fcc(n)=C2*AMNN1(n)-C3*AMpi1(n)-C4*AMN1(n)+AMP1(n)+AMs1(n)+AMD1(n) b1fcc(n)=C2*BMNN1(n)-C3*BMpi1(n)-C4*BMN1(n)+BMP1(n)+BMs1(n)+BMD1(n) a2fcc(n)=c5*(AMpi1(n)+AMN1(n)+AMDL1(n)) b2fcc(n)=c5*(BMpi1(n)+BMN1(n)+BMDL1(n)) a1fnc(n)=C2*AMNN2(n)-C3*AMpi2(n)-C4*AMN2(n)+AMP2(n)+AMs2(n)+AMD2(n) b1fnc(n)=C2*BMNN2(n)-C3*BMpi2(n)-C4*BMN2(n)+BMP2(n)+BMs2(n)+BMD2(n) a2fnc(n)=c5*(AMpi2(n)+AMN2(n)+AMDL2(n)) b2fnc(n)=c5*(BMpi2(n)+BMN2(n)+BMDL2(n)) A3fnc(n)=C10*(C5*(AMNs(n)+AMNNs(n))+C12*(AMss(n)+AMDs(n))) if(id.gt.20)go to 20 GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18)id C *********************************************************************** C CHARGED CURRENT NEUTRINO NUCLEON SINGLE PION PRODUCTION AMPLITUDES C *********************************************************************** C NEUTRINO PROTON PI+ PRODUCTION 1 do n=1,6 A(n)=c3*a2fcc(n) B(n)=c3*b2fcc(n) end do GO TO 100 C NEUTRINO NEUTRON PI0 PRODUCTION 2 do n=1,6 A(n)=-C6*(a2fcc(n)-a1fcc(n)) B(n)=-C6*(b2fcc(n)-b1fcc(n)) end do GO TO 100 C NEUTRINO NEUTRON PI+ PRODUCTION 3 do n=1,6 A(n)=C7*(a2fcc(n)+2*a1fcc(n)) B(n)=C7*(b2fcc(n)+2*b1fcc(n)) end do GO TO 100 c******************************************************* c anti-neutrino interaction c******************************************************* C ANTI-NEUTRINO NEUTRON PI- PRODUCTION 4 do n=1,6 A(n)=c3*(a2fcc(n)) B(n)=c3*(b2fcc(n)) end do GO TO 100 C ANTI-NEUTRINO PROTON PI0 PRODUCTION 5 do n=1,6 A(n)=C6*(a2fcc(n)-a1fcc(n)) B(n)=C6*(b2fcc(n)-b1fcc(n)) end do GO TO 100 C ANTI-NEUTRINO NEUTRON PI- PRODUCTION 6 do n=1,6 A(n)=C7*(a2fcc(n)+2*a1fcc(n)) B(n)=C7*(b2fcc(n)+2*b1fcc(n)) end do GO TO 100 C ************************************************************************ C NEUTRAL CURRENT NEUTRINO NUCLEON INTERACTION DIAGRAMS C ************************************************************************ C NEUTRINO PROTON TO NEUTRINO, PROTON, AND PI0 (NEUTRAL CURRENT) 7 do n=1,6 A(n)=C11*(2*a2fnc(n)+a1fnc(n))+C8*A3fnc(n) B(n)=C11*(2*b2fnc(n)+b1fnc(n)) end do GO TO 100 C NEUTRINO NEUTRON TO NEUTRINO, NEUTRON, AND PI0 8 do n=1,6 A(n)=C11*(2*a2fnc(n)+a1fnc(n))-C8*A3fnc(n) B(n)=C11*(2*b2fnc(n)+b1fnc(n)) end do GO TO 100 C NEUTRINO PROTON TO NEUTRINO, NEUTRON, PI+ (NEUTRAL CURRENT) 9 do n=1,6 A(n)=-C13*(a2fnc(n)-a1fnc(n))+C9*A3fnc(n) B(n)=-C13*(b2fnc(n)-b1fnc(n)) end do GO TO 100 C NEUTRINO NEUTRON TO NEUTRINO, PROTON PI- (NEUTRAL CURRENT) 10 do n=1,6 A(n)=C13*(a2fnc(n)-a1fnc(n))+C9*A3fnc(n) B(n)=C13*(b2fnc(n)-b1fnc(n)) end do GO TO 100 C ************************************************************************ C NEUTRAL CURRENT ANTI-NEUTRINO NUCLEON INTERACTION DIAGRAMS C ************************************************************************ C ANTI-NEUTRINO PROTON TO ANTI-NEUTRINO PROTON PI0 (NEUTRAL CURRENT) 11 do n=1,6 A(n)=C11*(2*a2fnc(n)+a1fnc(n))+C8*A3fnc(n) B(n)=C11*(2*b2fnc(n)+b1fnc(n)) end do GO TO 100 C ANTI-NEUTRINO NEUTRON TO ANTI-NEUTRINO, NEUTRON, PI0 (NEUTRAL CURRENT) 12 do n=1,6 A(n)=C11*(2*a2fnc(n)+a1fnc(n))-C8*A3fnc(n) B(n)=C11*(2*b2fnc(n)+b1fnc(n)) end do GO TO 100 C ANTI-NEUTRINO PROTON TO ANTI-NEUTRINO, NEUTRON, PI+ (NEUTRAL CURRENT) 13 do n=1,6 A(n)=-C13*(a2fnc(n)-a1fnc(n))+C9*A3fnc(n) B(n)=-C13*(b2fnc(n)-b1fnc(n)) end do GO TO 100 C ANTI-NEUTRINO NEUTRON TO ANTI-NEUTRINO, PROTON PI- (NEUTRAL CURRENT) 14 do n=1,6 A(n)=C13*(a2fnc(n)-a1fnc(n))+C9*A3fnc(n) B(n)=C13*(b2fnc(n)-b1fnc(n)) end do GO TO 100 C ******************************************************************** C QUASI-ELASTIC NEUTRINO AND ANTINEUTRINO INTERACTIONS C ******************************************************************** C NEUTRINO NEUTRON TO PROTON (QUASI-ELASTIC) SCATTERING 15 do n=1,6 A(n)=AMNU(n) B(n)=BMNU(n) end do GO TO 100 C ANTI-NEUTRINO PROTON TO NEUTRON (QUASI ELASTIC) SCATTERING 16 do n=1,6 A(n)= AMNU(n) B(n)= BMNU(n) end do GO TO 100 17 continue go to 100 18 continue go to 100 20 go to (21,22,23,24,25,26,27)(id-20) C ******************************************************************** C CALCULATE THE Mpi DIAGRAM 21 do n=1,6 A(n)=AMpi1(n) B(n)=BMpi1(n) end do GO TO 100 C CALCULATE THE MN DIAGRAM 22 do n=1,6 A(n)=AMN1(n) B(n)=BMN1(n) end do GO TO 100 C CALCULATE THE MNN DIAGRAM 23 do n=1,6 A(n)=AMNN1(n) B(n)=BMNN1(n) end do GO TO 100 C CALCULATE THE MP DIAGRAM 24 do n=1,6 A(n)=AMP1(n) B(n)=BMP1(n) end do GO TO 100 C CALCULATE THE Ms DIAGRAM 25 do n=1,6 A(n)=AMs1(n) B(n)=BMs1(n) end do GO TO 100 C CALCULATE THE MDL DIAGRAM 26 do n=1,6 A(n)=AMDL1(n) B(n)=BMDL1(n) end do GO TO 100 C CALCULATE THE MD DIAGRAM 27 do n=1,6 A(n)=AMD1(n) B(n)=BMD1(n) end do C ***************************************************************************** 100 CONTINUE RETURN END subroutine matform c****************************************************** c iel=1 for elastic (fills arrays .mnu) * c iel=0 for pi production * c * c ncc=-1 for isoscalar nc (fills arrays a..s) * c ncc= 0 for isovector nc (fills arrays ...2) * c ncc= 1 for isovector cc (fills arrays ...1) * c****************************************************** implicit real m,k common/elastic/iel,ncc common/form/fpit,f1vt,f2vt,c3vt,c4vt,g1vt,g2vt,h3vt,h4vt,h5vt, 1 fat,c5at,d1at,g1at,h5at common/matscal/s,t,u,kk,kq,p1k,p2k,p1q,p2q dimension ffv(10),ffa(5) equivalence (ffv,fpit),(ffa,fat) c######################################################################### parameter (rt3=1.732050808) parameter (C2THC=.95, SIN2THW=.22, ga=1./c2thc, gap=0.) parameter (gv=(1.-2.*SIN2THW)/c2thc, gvp=-2./3.*SIN2THW/c2thc) parameter (M=.938, MDL=1.232, MS=1.505, MP=1.434) parameter (MD=1.514, mpi=.139, mmu=.106) C**** Proposal for Long bno at ags jan 26 1993 C maxial = 1.061 +- 0.026 GeV/c^2 C The code actually uses maxial**2 = 1.1257 c parameter (maxial=0.81) C parameter (maxial=1.) parameter (maxial=1.1257) parameter (m2=M*M, mmdl=M+MDL, mmd=M+MD, mpi2=mpi*mpi) parameter (mndl=MDL-M, mnd=MD-M) c if(ncc.eq.1.or.iel.eq.1)then c******************* tt=kk fvv=1./(1-tt/.71)**2 fmv=1./(4*m2-tt) F1Vpt=(1-1.79*tt*fmv)*fvv F1Vnt=1.91*tt*fmv*fvv F2Vpt= 3.59*m2*fmv*fvv F2Vnt=-3.83*m2*fmv*fvv if(iel.eq.1)go to 1001 g2v=1./((1.-tt/4.3)**2*(1-tt/(ms-m)**2)) g2vpt=-0.28*g2v g2vnt= 0.14*g2v g1v=tt/(m*(ms-m)) g1vpt=g2vpt*g1v g1vnt=g2vnt*g1v h3v=1./((1-tt/1.38)*(1-tt/1.79)*(1-tt/2.19)) h3vpt=-2.49*h3v h3vnt= 4.12*h3v h4v=1./(1-tt/0.73)**3 h4vpt= 2.24*h4v h4vnt=-2.58*h4v h5v=-2.*m*md/(md**2+m2-tt) h5vpt=h5v*(h3vpt+h4vpt*md/m) h5vnt=h5v*(h3vnt+h4vnt*md/m) C ************************************************************ fpitt=1/(1-tt/.47) sqtt=sqrt(-tt) c3vtt=2.07*sqrt(3.*(1.+9.*sqtt)*exp(-6.3*sqtt)) C4Vtt=-M*c3vtt/sqrt(s) C AXIAL FORM FACTORS AS A FUNCTION OF t FAtt=1.23/(1-tt/maxial)**2 C5Att=rt3*1.18/(1-tt/(.65*.65))**2 aat=1./(1-tt)**2 D1Att=0.35*aat G1Att=0.16*aat H5Att=2.12*aat c end if c************************************************************* if(ncc.ge.0)then fpit=fpitt c3vt=c3vtt c4vt=c4vtt fat=fatt c5at=c5att d1at=d1att g1at=g1att h5at=h5att f1vt=f1vpt-f1vnt f2vt=f2vpt-f2vnt G1Vt=G1Vpt-G1Vnt G2Vt=G2Vpt-G2Vnt H3Vt=H3Vpt-H3Vnt H4Vt=H4Vpt-H4Vnt H5Vt=H5Vpt-H5Vnt if(ncc.eq.0)then do i=1,10 ffv(i)=ffv(i)*gv end do do i=1,5 ffa(i)=ffa(i)*ga end do end if else f1vt=gvp*(f1vpt+f1vnt) f2vt=gvp*(f2vpt+f2vnt) G1Vt=gvp*(G1Vpt+G1Vnt) G2Vt=gvp*(G2Vpt+G2Vnt) H3Vt=gvp*(H3Vpt+H3Vnt) H4Vt=gvp*(H4Vpt+H4Vnt) H5Vt=gvp*(H5Vpt+H5Vnt) do i=1,5 ffa(i)=0. end do end if 1000 return 1001 continue f1vt=f1vpt-f1vnt f2vt=f2vpt-f2vnt FAt=1.23/(1-tt/maxial)**2 go to 1000 end subroutine matvect implicit real k,m common/vectors/p1(4),p2(4),pe(4),pnub(4) common/matkin/p1p2,p1pe,p2pe,p1pnub,p2pnub,pepnub common/matscal/s,t,u,kk,kq,p1k,p2k,p1q,p2q parameter (m=.938,m2=m*m,mlep=0.,mlep2=mlep*mlep) pe(4)=sqrt(pe(1)**2+pe(2)**2+pe(3)**2) p1p2=d4(p1,p2) p1pe=d4(p1,pe) p2pe=d4(p2,pe) p1pnub=d4(p1,pnub) p2pnub=d4(p2,pnub) pepnub=d4(pe,pnub) t2=-p1p2+m2 kk=-2*pepnub+mlep2 c if(kk.gt.0.) kk=0. p1k=p1pnub-p1pe p2k=p2pnub-p2pe p1q= t2+p1k p2q=-t2+p2k kq=p1k-p2k+kk t=2*t2 s= 2*p1k+kk+m2 u=-2*p2k+kk+m2 return end function qmat(z) implicit real m,k common/cofmat/a(8),b(8) complex a,b common/matkin/p1p2,p1pe,p2pe,p1pnub,p2pnub,pepnub common/matscal/s,t,u,kk,kq,p1k,p2k,p1q,p2q common/vectors/p1(4),p2(4),pe(4),pnub(4) c######################################################################### dimension x(12),xx(7) parameter (M=.938, m2=m*m) aa(n1,n2)=2*(real(a(n1))*real(a(n2))+aimag(a(n1))*aimag(a(n2))) bb(n1,n2)=2*(real(b(n1))*real(b(n2))+aimag(b(n1))*aimag(b(n2))) ab(n1,n2)=2*(real(a(n1))*real(b(n2))+aimag(a(n1))*aimag(b(n2))) caa(n1,n2)=2*(-real(a(n1))*aimag(a(n2))+aimag(a(n1))*real(a(n2))) cbb(n1,n2)=2*(-real(b(n1))*aimag(b(n2))+aimag(b(n1))*real(b(n2))) cab(n1,n2)=2*(-real(a(n1))*aimag(b(n2))+aimag(a(n1))*real(b(n2))) ppp=-pepnub ppm=2*m*ppp scc1=p1p2-m2 scc2=p1p2+m2 p12pe=p1pe+p2pe p12pnub=p1pnub+p2pnub p1w=p1pe+p1pnub p2w=p2pe+p2pnub p12kp=(p1k+p2k) p12km=(p1k-p2k) p12wp=(p1w+p2w) p12wm=(p1w-p2w) p1pf=ppp*p1w p2pf=ppp*p2w pcr=p1pnub*p2pe-p1pe*p2pnub z1=p1w*pcr z2=p2w*pcr z3=2*p1k*p2k z4=ppp*p12kp*scc1 z5=ppp*p12kp*scc2 z6=ppp*p12km*scc1 z7=ppp*p12km*scc2 y1=p12pe*p12pnub+ppp*scc2 y2=(p1pe-p2pe)*(p1pnub-p2pnub)-ppp*scc1 y3=p1pe*p1pnub-p2pe*p2pnub y4=4*(p1pe*p1pnub*p2k+p2pe*p2pnub*p1k) y5=4*(p1pe*p1pnub*p2k-p2pe*p2pnub*p1k) y6=p1pe*p2pnub+p2pe*p1pnub y7=-ppp*z3 y8= p1p2*p1pf-m2*p2pf+p1k*pcr y9=-p1p2*p2pf+m2*p1pf+p2k*pcr z8=y6-m2*ppp z9=y6+m2*ppp baz1= y1*aa(1,1)+y2*aa(2,2)+2*y3*aa(1,2) baz2= y1*aa(3,3)+y2*aa(4,4)+2*y3*aa(3,4) baz5= 2*(y1*aa(1,3)+y2*aa(2,4)+y3*(aa(1,4)+aa(2,3))) baz6= -2*m*(y3*aa(1,5)+y2*aa(2,5)) baz41= y1*bb(1,1)+y2*bb(2,2)+2*y3*bb(1,2) baz42= y1*bb(3,3)+y2*bb(4,4)+2*y3*bb(3,4) baz45= 2*(y1*bb(1,3)+y2*bb(2,4)+y3*(bb(1,4)+bb(2,3))) baz46= 2*m*(y1*bb(1,5)+y3*bb(2,5)) x(1)=scc1*baz1+ (z3-scc2*kk)*baz2+ 1 scc2*baz41+(z3-scc1*kk)*baz42 x(2)=z8*aa(5,5)+ (y7-kk*z9)*aa(6,6)+ 1 z9*bb(5,5)+ (y7-kk*z8)*bb(6,6) x(3)=-m*p12km*baz5+ 1 m*p12kp*baz45 x(4)= baz6+baz46 x(5)= (z7+z1+z2)*(aa(1,6)+bb(1,6))+(z4+z1-z2)*(aa(2,6)+bb(2,6)) x(6)= (z5+z1-z2+y4)*(aa(3,5)+bb(3,5))+(z6+z1+z2+y5)*(aa(4,5)+bb(4,5)) x(7)= 2*ppm*(y1*aa(3,6)+y3*(aa(4,6)-bb(3,6))-y2*bb(4,6)) x(8)= ppm*p12km*bb(5,6) x(9)=-ppm*p12kp*aa(5,6) x(10)=z*(2*pcr*ab(5,5)-2*(kk*pcr-2*ppp*p1k*p2w)*ab(6,6)) x(11)=z*ppm*(p12wp*ab(5,6)-p12wm*ab(6,5)) x(12)=z*(y8+y9)*(ab(5,3)+ab(3,5)-ab(6,1)-ab(1,6))+ 1 z*(y8-y9)*(ab(5,4)+ab(4,5)-ab(6,2)-ab(2,6)) fac=2*eps(p1,p2,pe,pnub) xx(1)=z*(scc1*caa(1,2)+(z3-scc2*kk)*caa(3,4)) xx(2)=z*(scc2*cbb(1,2)+(z3-scc1*kk)*cbb(3,4)) xx(3)=-z*m*(p12km*(-caa(2,3)+caa(1,4))+caa(1,5)+kk*caa(4,6)) xx(4)= z*m*(p12kp*(-cbb(2,3)+cbb(1,4))-cbb(2,5)-kk*cbb(3,6)) xx(5)=-z*p12kp/2*(caa(1,6)+caa(4,5)+cbb(1,6)+cbb(4,5)) xx(6)=-z*p12km/2*(caa(3,5)+caa(2,6)+cbb(3,5)+cbb(2,6)) xx(7)= p12wp/2*(cab(5,3)-cab(3,5)-cab(6,1)+cab(1,6))+ 1 p12wm/2*(cab(5,4)-cab(4,5)-cab(6,2)+cab(2,6)) ss=0 do j=1,7 ss=ss+xx(j) end do mat=0 do j=1,12 mat=mat+x(j) end do qmat=mat+fac*ss return end C******************************************************** C @(#)fluxnaumov.f 1.1 modified on 12/7/92 C C Return-Path: 27.239::danka C Date: Wed, 26 Aug 92 14:30:06 -0700 C From: 27.239::danka C To: mcgrew C Subject: function to calculate Bugaev-Naumov fluxes C real function fluxnaumov(en,cs,nutype) c c en - neutrino energy in GeV c cs - cosine of the zenith angle (ignored) c c id=1 for muon neutrinos c id=2 for muon antineutrinos c id=3 for electron neutrinos c id=4 for electron antineutrinos c c fluxnaumov is calculated in #/(m^2*sec*GeV*srd) c C**** Convert nutype to id. C nutype = 1 for electron neutrino C 2 for muon neutrino C 3 for electron anti-neutrino C 4 for muon anti-neutrino integer id(4) data id / 3, 1, 4, 2 / dimension c(4),a(4),b1(4),b2(4) data c/152.,150.,71.6,51./ data a/2.31,2.36,2.44,2.47/ data b1/0.247,0.261,0.271,0.276/ data b2/0.127,0.148,0.207,0.205/ flux=0 if(en.le.0)goto 100 if(id(nutype).lt.1.or.id(nutype).gt.4)goto 100 if(en.gt.1.)then bb=en*b2(id(nutype)) else bb=en*b1(id(nutype)) end if d=a(id(nutype))+bb*log(en) flux=c(id(nutype))*en**(-d) 100 fluxnaumov=flux return end C******************************************************** C @(#)fluxleekoh89.f 1.1 modified on 12/7/92 C C This returns the lee and koh calculated flux as a function of energy C and cosine of the zenith angle. Notice that the data from the table C is hard coded below. This data is for the 1989 paper with the bug C fix (I forget the problem they had, but Danka mentioned that this data C had "the bug fixed"). The spectra are the average of the solar minimum C and solar maximum. real function fluxleekoh89(en,cs,id) implicit none integer i1, i2 real r1, r2, r3 c c en - neutrino energy in GeV c cs - zenith cosine of the neutrino. c c id=1 for electron neutrinos c id=2 for muon neutrinos c id=3 for electron antineutrinos c id=4 for muon antineutrinos c c fluxleekoh89 is calculated in #/(m^2*sec*GeV*srd) C C**** The energy to return the flux at real en C**** The cosine of the angle to return the flux at. real cs C**** The neutrino type to return the data for. integer id C**** The angle for the flux real angle C**** The estimated error on the flux. real FluxError C**** Lee and Koh's normalization factor to convert bin counts to C #/m^2/sec/bin real FluxNormal parameter (FluxNormal=3.981E-3) C**** The number of energy bins integer nenergies parameter (nenergies=135) C**** The energy bins and the data for the energy bins. Note that these must C be summed since the data is for the bin width. real DEnr(nenergies) data DEnr / 50*0.005, 25*0.010, 25*0.020, 20*0.050, 15*0.200/ C**** The low energy of each bin. real lenr(nenergies) C**** The mean energy of each bin. real aenr(nenergies) C**** The number of bins integer nangles parameter (nangles=15) real angles(nangles) data angles /6.,14*12./ real DCos(nangles) C**** Flag if this is called. logical called data called /.false./ C**** The total number of neutrinos and anti-neutrinos in the flux. integer NLeptons parameter (NLeptons=4) C**** Indices into the flux array integer ie, it, in C**** The Flux data. real FluxData(NEnergies, NAngles, NLeptons) C**** The interpolation functions. The energy is falling exponentially so C it is best approximated by a function with a pole (ie. a rational C function with (a+b*x+c*x**2...)/(A+B*x+C*x**2...)). The angle C distributions are relatively smooth so use a polynomial. external ratint, polint, linint C####************************************************************ C THE FLUX DATA AS PROVIDED BY LEE AND KOH THROUGH DANKA KIELSEWSKA C search for #### to get to the other end. real fd00101(135) equivalence (fluxdata( 1, 1, 1),fd00101) data fd00101 / $ 146.63, 523.25, 874.75, 1232.90, 1489.70, $ 1647.00, 1809.80, 1709.80, 1685.70, 1643.50, $ 1462.50, 1406.50, 1280.50, 1223.70, 1118.00, $ 1135.30, 1049.00, 1053.90, 993.10, 920.73, $ 822.06, 801.72, 832.44, 691.80, 759.13, $ 688.64, 665.09, 672.28, 593.23, 618.30, $ 564.64, 513.55, 512.21, 500.09, 460.06, $ 440.59, 426.88, 444.02, 359.49, 375.46, $ 337.71, 373.83, 362.71, 313.96, 301.75, $ 311.13, 250.88, 285.38, 247.34, 288.17, $ 503.71, 455.83, 401.04, 399.76, 387.75, $ 361.88, 326.00, 332.21, 329.83, 310.75, $ 306.54, 274.00, 246.54, 253.29, 205.97, $ 206.00, 167.13, 203.34, 188.29, 167.25, $ 162.00, 135.29, 147.25, 146.00, 128.00, $ 211.00, 224.00, 200.25, 186.00, 175.00, $ 131.00, 133.00, 142.00, 130.00, 114.00, $ 106.00, 98.00, 88.00, 98.00, 99.00, $ 74.00, 89.00, 57.00, 63.00, 57.00, $ 51.00, 67.00, 63.00, 50.00, 32.00, $ 81.00, 100.00, 82.00, 71.00, 56.00, $ 53.00, 62.00, 33.00, 45.00, 44.00, $ 43.00, 29.00, 35.00, 28.00, 29.00, $ 22.00, 24.00, 22.00, 12.00, 21.00, $ 48.00, 38.00, 27.00, 14.00, 20.00, $ 19.00, 11.00, 10.00, 13.00, 6.00, $ 2.00, 2.00, 2.00, 3.00, 3.00/ real fd00201(135) equivalence (fluxdata( 1, 2, 1),fd00201) data fd00201 / $ 371.43, 1490.60, 2610.80, 3468.70, 4217.00, $ 4754.40, 4987.80, 5061.20, 4937.50, 4723.00, $ 4424.80, 4072.90, 3865.50, 3654.90, 3501.00, $ 3421.50, 3152.20, 2904.80, 2786.80, 2666.20, $ 2617.90, 2470.40, 2375.30, 2209.80, 2153.70, $ 1994.80, 1914.40, 1844.90, 1677.90, 1700.50, $ 1646.90, 1530.60, 1544.10, 1441.10, 1340.90, $ 1297.00, 1288.30, 1211.90, 1179.10, 1113.10, $ 1076.90, 1014.40, 988.92, 967.05, 907.34, $ 925.05, 862.92, 851.09, 798.25, 772.39, $ 1476.40, 1463.70, 1297.20, 1242.10, 1203.20, $ 1101.40, 1040.40, 913.60, 924.30, 842.50, $ 807.63, 799.34, 685.26, 690.88, 661.05, $ 610.67, 553.00, 551.04, 505.25, 493.67, $ 477.51, 448.92, 459.17, 400.58, 389.00, $ 747.58, 691.29, 604.63, 604.00, 489.29, $ 537.00, 395.29, 395.00, 386.00, 345.00, $ 327.00, 321.00, 243.00, 269.00, 254.00, $ 230.00, 206.00, 213.00, 196.00, 191.00, $ 168.00, 173.00, 150.00, 148.00, 139.00, $ 337.00, 287.00, 208.00, 228.00, 190.00, $ 164.00, 166.00, 117.00, 126.00, 101.00, $ 121.00, 94.00, 79.00, 85.00, 73.00, $ 68.00, 73.00, 54.00, 54.00, 61.00, $ 149.00, 100.00, 77.00, 84.00, 35.00, $ 54.00, 30.00, 22.00, 22.00, 20.00, $ 9.00, 14.00, 12.00, 16.00, 5.00/ real fd00301(135) equivalence (fluxdata( 1, 3, 1),fd00301) data fd00301 / $ 601.10, 2426.70, 4224.20, 5531.30, 6619.30, $ 7374.90, 7689.60, 7879.90, 7964.80, 7489.50, $ 6984.20, 6498.20, 6238.90, 5888.50, 5585.80, $ 5379.80, 5097.10, 4980.30, 4685.90, 4402.80, $ 4277.10, 4053.60, 3724.40, 3625.70, 3432.10, $ 3276.40, 3165.00, 3022.40, 2898.50, 2718.00, $ 2618.40, 2470.60, 2486.70, 2220.70, 2316.30, $ 2094.00, 2123.20, 1906.20, 1880.60, 1824.90, $ 1789.20, 1722.80, 1649.80, 1683.60, 1536.70, $ 1463.10, 1394.10, 1406.90, 1337.20, 1238.40, $ 2499.20, 2282.00, 2185.60, 2054.60, 1907.10, $ 1765.80, 1732.80, 1652.10, 1511.10, 1451.00, $ 1368.00, 1297.60, 1181.40, 1128.00, 1101.60, $ 1080.30, 983.64, 929.46, 871.00, 840.88, $ 800.21, 720.50, 691.17, 645.34, 650.13, $ 1243.30, 1152.10, 1087.30, 967.13, 885.29, $ 828.00, 693.29, 722.58, 589.00, 559.00, $ 542.29, 498.00, 458.00, 415.00, 441.00, $ 380.00, 392.00, 368.00, 325.00, 298.00, $ 305.00, 260.00, 274.00, 250.00, 230.00, $ 520.00, 463.00, 442.00, 358.00, 337.00, $ 302.00, 285.00, 231.00, 224.00, 189.00, $ 157.00, 138.00, 139.00, 140.00, 118.00, $ 112.00, 97.00, 105.00, 70.00, 82.00, $ 234.00, 177.00, 154.00, 126.00, 99.00, $ 71.00, 58.00, 47.00, 50.00, 34.00, $ 32.00, 20.00, 21.00, 25.00, 16.00/ real fd00401(135) equivalence (fluxdata( 1, 4, 1),fd00401) data fd00401 / $ 818.60, 3218.40, 5371.20, 6993.00, 8495.30, $ 9516.30, 9792.60,10257.00,10280.00, 9701.60, $ 8856.40, 8518.40, 8296.70, 7726.70, 7498.90, $ 7166.90, 6961.50, 6590.00, 6174.90, 6031.70, $ 5687.50, 5519.60, 5252.80, 4854.40, 4766.60, $ 4511.70, 4317.70, 4176.40, 3806.50, 3808.90, $ 3534.20, 3361.70, 3390.00, 3140.10, 3059.20, $ 3008.00, 2850.50, 2717.10, 2597.50, 2483.10, $ 2404.80, 2329.90, 2282.20, 2173.90, 2138.30, $ 2063.20, 1962.50, 1878.10, 1909.80, 1797.80, $ 3445.90, 3278.60, 3016.80, 2763.00, 2550.60, $ 2573.30, 2435.50, 2211.40, 2126.20, 2063.60, $ 1906.00, 1834.10, 1687.90, 1588.30, 1532.80, $ 1447.90, 1350.90, 1278.50, 1257.60, 1157.00, $ 1124.40, 1045.20, 993.27, 990.88, 935.08, $ 1726.50, 1560.80, 1472.30, 1288.60, 1188.30, $ 1133.30, 996.00, 923.00, 915.00, 883.00, $ 769.00, 739.00, 694.00, 645.00, 586.00, $ 574.00, 511.00, 488.00, 480.00, 483.00, $ 421.00, 407.00, 341.00, 346.00, 312.00, $ 784.00, 681.00, 594.00, 507.00, 512.00, $ 430.00, 391.00, 355.00, 300.00, 282.00, $ 233.00, 227.00, 188.00, 189.00, 180.00, $ 150.00, 140.00, 124.00, 117.00, 131.00, $ 386.00, 272.00, 212.00, 187.00, 136.00, $ 108.00, 89.00, 84.00, 42.00, 52.00, $ 51.00, 34.00, 33.00, 17.00, 22.00/ real fd00501(135) equivalence (fluxdata( 1, 5, 1),fd00501) data fd00501 / $ 1053.20, 3860.50, 6276.60, 8066.80, 9675.30, $ 10586.00,11262.00,11431.00,11527.00,10903.00, $ 10223.00, 9894.40, 9430.80, 9137.80, 8913.70, $ 8227.60, 8138.90, 7794.20, 7374.50, 7081.70, $ 6803.70, 6578.40, 6201.80, 5941.00, 5691.80, $ 5355.10, 5165.30, 4953.90, 4762.20, 4616.20, $ 4461.70, 4117.80, 4024.10, 3942.60, 3734.20, $ 3632.20, 3465.30, 3228.50, 3187.80, 3123.60, $ 3006.30, 2933.00, 2828.60, 2645.60, 2555.70, $ 2648.20, 2491.80, 2381.90, 2422.20, 2198.10, $ 4106.40, 3918.70, 3854.30, 3540.40, 3322.10, $ 3163.00, 2994.50, 2837.50, 2682.40, 2479.20, $ 2426.00, 2307.30, 2120.50, 2011.80, 1969.50, $ 1801.50, 1718.00, 1655.50, 1502.70, 1446.60, $ 1401.00, 1396.20, 1298.80, 1206.90, 1178.10, $ 2160.20, 2038.30, 1852.00, 1728.30, 1588.30, $ 1542.60, 1300.60, 1164.00, 1194.00, 1146.00, $ 1037.00, 958.00, 887.00, 808.00, 779.00, $ 737.00, 684.00, 680.00, 622.00, 610.00, $ 536.00, 478.00, 489.00, 460.00, 462.00, $ 1007.00, 869.00, 815.00, 660.00, 610.00, $ 557.00, 514.00, 438.00, 418.00, 406.00, $ 344.00, 311.00, 277.00, 277.00, 239.00, $ 205.00, 185.00, 183.00, 174.00, 158.00, $ 490.00, 414.00, 333.00, 237.00, 201.00, $ 164.00, 130.00, 106.00, 71.00, 68.00, $ 60.00, 54.00, 53.00, 41.00, 26.00/ real fd00601(135) equivalence (fluxdata( 1, 6, 1),fd00601) data fd00601 / $ 1096.40, 4218.50, 6662.30, 8511.60, 9965.00, $ 10788.00,11459.00,11582.00,11524.00,11132.00, $ 10353.00, 9981.30, 9553.10, 9244.40, 9065.80, $ 8781.60, 8347.60, 8189.00, 7772.50, 7491.60, $ 7332.70, 7026.70, 6680.60, 6635.20, 6105.10, $ 6011.10, 5570.00, 5493.40, 5315.00, 5049.90, $ 4941.10, 4697.40, 4599.10, 4402.60, 4195.80, $ 4012.70, 3949.90, 3798.80, 3612.70, 3388.50, $ 3314.80, 3288.60, 3188.80, 3049.00, 2922.80, $ 2761.50, 2832.00, 2674.10, 2657.00, 2524.10, $ 4899.70, 4497.30, 4257.50, 3977.40, 3807.20, $ 3551.00, 3347.60, 3203.70, 3049.30, 2933.40, $ 2786.30, 2584.00, 2509.80, 2441.60, 2228.30, $ 2140.70, 2204.90, 1953.20, 1951.00, 1817.20, $ 1724.40, 1615.60, 1559.20, 1490.90, 1423.30, $ 2591.60, 2513.60, 2295.60, 2079.80, 1908.70, $ 1816.60, 1591.30, 1504.00, 1383.30, 1269.30, $ 1306.00, 1145.00, 1006.00, 970.00, 987.00, $ 871.00, 916.00, 811.00, 743.00, 719.00, $ 655.00, 644.00, 558.00, 574.00, 495.00, $ 1290.00, 1133.00, 1030.00, 932.00, 832.00, $ 697.00, 686.00, 572.00, 555.00, 466.00, $ 409.00, 356.00, 363.00, 316.00, 315.00, $ 254.00, 269.00, 221.00, 236.00, 242.00, $ 755.00, 529.00, 408.00, 369.00, 266.00, $ 195.00, 163.00, 145.00, 142.00, 103.00, $ 79.00, 68.00, 64.00, 68.00, 48.00/ real fd00701(135) equivalence (fluxdata( 1, 7, 1),fd00701) data fd00701 / $ 1272.60, 4542.40, 7106.30, 8789.80, 9722.70, $ 10259.00,10624.00,10790.00,10648.00, 9716.90, $ 9005.00, 8765.30, 8481.00, 8006.70, 7766.90, $ 7459.60, 7385.60, 7138.90, 7018.10, 6674.90, $ 6428.30, 6270.40, 6136.40, 5799.20, 5589.40, $ 5366.30, 5263.80, 4941.70, 4889.90, 4614.80, $ 4652.60, 4386.70, 4185.40, 4041.00, 3963.70, $ 3837.70, 3594.70, 3614.50, 3463.10, 3324.40, $ 3270.40, 3010.20, 3019.20, 2932.10, 2989.10, $ 2755.90, 2782.00, 2605.10, 2470.00, 2507.90, $ 4765.20, 4440.20, 4248.20, 4026.40, 3744.10, $ 3657.10, 3349.60, 3238.50, 3048.10, 2961.30, $ 2756.10, 2611.30, 2424.90, 2427.20, 2303.10, $ 2295.60, 2139.20, 2038.50, 1908.60, 1862.90, $ 1811.50, 1688.40, 1614.70, 1632.70, 1404.80, $ 2814.50, 2573.80, 2352.60, 2177.40, 2076.20, $ 1908.00, 1790.30, 1606.30, 1551.00, 1456.00, $ 1370.00, 1263.00, 1243.00, 1133.00, 1050.00, $ 1042.00, 998.00, 859.00, 849.00, 809.00, $ 760.00, 702.00, 701.00, 669.00, 627.00, $ 1434.00, 1216.00, 1125.00, 999.00, 923.00, $ 858.00, 738.00, 666.00, 591.00, 508.00, $ 493.00, 471.00, 445.00, 396.00, 356.00, $ 300.00, 288.00, 319.00, 246.00, 269.00, $ 832.00, 631.00, 515.00, 385.00, 340.00, $ 238.00, 253.00, 191.00, 156.00, 116.00, $ 131.00, 101.00, 86.00, 86.00, 57.00/ real fd00801(135) equivalence (fluxdata( 1, 8, 1),fd00801) data fd00801 / $ 1402.50, 4588.80, 6787.20, 8116.90, 9230.60, $ 9557.90, 9638.20, 9518.30, 9086.60, 8296.30, $ 7430.60, 7032.50, 6468.70, 6476.90, 6158.80, $ 5841.20, 5582.80, 5373.50, 5326.30, 5126.00, $ 5017.50, 4721.10, 4513.90, 4220.80, 4203.20, $ 4210.20, 3870.50, 3875.90, 3702.90, 3573.90, $ 3275.50, 3168.60, 3062.00, 3066.10, 2935.00, $ 2765.50, 2641.00, 2582.20, 2533.60, 2522.70, $ 2460.10, 2199.40, 2226.70, 2201.90, 2103.70, $ 2096.50, 1952.20, 2062.50, 1916.70, 1799.00, $ 3495.90, 3345.20, 3151.40, 3038.00, 2910.70, $ 2745.00, 2592.80, 2520.00, 2217.90, 2224.90, $ 2053.70, 1994.80, 1833.50, 1678.70, 1768.80, $ 1681.90, 1617.00, 1489.30, 1393.60, 1277.90, $ 1282.50, 1249.90, 1177.40, 1168.60, 1103.10, $ 2209.50, 1929.70, 1849.00, 1756.60, 1615.00, $ 1443.70, 1279.90, 1351.10, 1199.80, 1054.00, $ 1025.40, 1005.20, 947.72, 911.25, 780.00, $ 810.77, 680.00, 699.24, 667.24, 652.00, $ 550.00, 610.00, 488.00, 475.24, 492.00, $ 1135.20, 983.24, 849.25, 776.00, 694.00, $ 776.00, 620.00, 572.00, 464.00, 498.00, $ 468.00, 420.00, 384.00, 352.00, 282.00, $ 284.00, 242.00, 238.00, 246.00, 198.00, $ 824.00, 588.00, 510.00, 370.00, 336.00, $ 274.00, 234.00, 162.00, 160.00, 156.00, $ 88.00, 100.00, 84.00, 70.00, 72.00/ real fd00901(135) equivalence (fluxdata( 1, 9, 1),fd00901) data fd00901 / $ 1071.50, 3730.60, 5770.50, 7136.70, 7932.70, $ 8303.90, 8601.70, 8691.30, 8701.60, 7899.10, $ 7300.00, 7090.50, 6887.20, 6501.00, 6339.00, $ 6058.80, 5960.60, 5790.10, 5728.70, 5456.50, $ 5276.10, 5142.40, 5013.20, 4766.70, 4653.90, $ 4467.70, 4378.20, 4136.70, 4081.00, 3818.00, $ 3874.90, 3688.30, 3514.00, 3443.40, 3368.40, $ 3222.00, 3040.80, 3057.50, 2966.40, 2862.70, $ 2813.00, 2569.70, 2613.60, 2505.30, 2552.90, $ 2366.10, 2413.90, 2269.50, 2145.70, 2166.00, $ 4113.80, 3861.00, 3685.90, 3486.20, 3288.40, $ 3191.40, 2935.60, 2873.40, 2664.30, 2603.50, $ 2428.90, 2311.20, 2136.30, 2133.50, 2051.30, $ 2046.70, 1922.10, 1826.90, 1710.90, 1684.90, $ 1643.90, 1524.70, 1472.60, 1470.00, 1289.50, $ 2575.00, 2326.00, 2164.00, 2017.40, 1925.20, $ 1769.90, 1669.50, 1503.80, 1442.70, 1364.00, $ 1290.20, 1182.40, 1178.60, 1073.10, 990.67, $ 985.01, 960.09, 812.71, 801.51, 771.10, $ 728.00, 673.09, 669.72, 648.04, 602.56, $ 1375.30, 1160.40, 1097.10, 967.37, 894.85, $ 835.66, 721.67, 654.65, 575.88, 494.98, $ 477.49, 466.32, 434.69, 390.76, 347.76, $ 296.85, 283.78, 314.82, 241.98, 263.60, $ 826.35, 624.73, 514.17, 384.16, 338.40, $ 237.19, 252.20, 191.00, 156.00, 116.00, $ 131.00, 101.00, 85.19, 86.00, 57.00/ real fd01001(135) equivalence (fluxdata( 1, 10, 1),fd01001) data fd01001 / $ 760.82, 2745.90, 4313.60, 5436.20, 6242.50, $ 6674.30, 7155.10, 7278.90, 7237.40, 6903.20, $ 6531.70, 6211.50, 5989.90, 5829.10, 5758.10, $ 5590.70, 5393.50, 5160.20, 4963.10, 4894.40, $ 4692.00, 4551.90, 4391.10, 4341.90, 4068.00, $ 3898.50, 3663.10, 3606.10, 3535.30, 3405.80, $ 3286.90, 3133.40, 3099.60, 3063.00, 2843.80, $ 2727.90, 2717.60, 2606.80, 2507.10, 2347.60, $ 2328.00, 2276.70, 2235.50, 2139.20, 2053.50, $ 1947.10, 1982.10, 1922.30, 1857.30, 1783.40, $ 3473.60, 3148.70, 3020.90, 2878.70, 2757.60, $ 2560.30, 2388.70, 2335.80, 2198.40, 2173.50, $ 2003.60, 1929.40, 1862.40, 1841.70, 1663.60, $ 1606.40, 1651.40, 1437.70, 1470.10, 1395.30, $ 1301.60, 1236.40, 1180.00, 1157.30, 1110.10, $ 2052.20, 1955.60, 1784.20, 1652.80, 1523.60, $ 1474.90, 1283.20, 1214.30, 1140.70, 1028.10, $ 1059.60, 940.34, 843.28, 819.56, 825.46, $ 726.88, 761.71, 675.00, 618.76, 615.38, $ 547.97, 543.17, 474.89, 494.00, 418.12, $ 1121.90, 958.60, 914.56, 831.75, 753.88, $ 611.66, 614.95, 510.47, 504.36, 418.94, $ 374.47, 330.46, 333.19, 282.78, 294.49, $ 234.31, 253.03, 208.38, 220.86, 224.68, $ 711.08, 500.15, 396.12, 354.94, 256.88, $ 188.36, 157.81, 144.18, 140.35, 100.51, $ 79.00, 67.18, 64.00, 68.00, 47.15/ real fd01101(135) equivalence (fluxdata( 1, 11, 1),fd01101) data fd01101 / $ 575.35, 2060.70, 3142.80, 3975.80, 4713.30, $ 5226.70, 5364.10, 5539.70, 5598.20, 5324.00, $ 4911.40, 4868.90, 4588.00, 4489.90, 4432.80, $ 4049.70, 3971.00, 3873.90, 3660.80, 3539.70, $ 3470.20, 3384.30, 3164.10, 3121.40, 2926.80, $ 2821.60, 2712.60, 2633.80, 2542.90, 2525.50, $ 2429.00, 2294.90, 2193.30, 2163.40, 2100.70, $ 2031.80, 1983.10, 1838.90, 1847.80, 1797.10, $ 1770.40, 1667.80, 1663.90, 1520.40, 1470.80, $ 1522.30, 1433.90, 1396.20, 1419.90, 1301.70, $ 2437.70, 2312.10, 2335.50, 2159.90, 2013.50, $ 1941.90, 1835.30, 1747.50, 1697.40, 1549.10, $ 1504.80, 1499.60, 1357.10, 1285.20, 1273.80, $ 1174.00, 1109.30, 1119.60, 1006.90, 952.73, $ 899.22, 923.46, 902.92, 841.13, 792.82, $ 1514.10, 1457.80, 1341.70, 1236.90, 1106.40, $ 1119.50, 958.41, 850.04, 879.78, 843.96, $ 775.98, 744.01, 655.05, 599.71, 606.44, $ 566.92, 520.61, 536.84, 484.68, 485.90, $ 413.67, 379.53, 401.39, 380.64, 379.65, $ 825.87, 690.88, 671.97, 555.71, 521.51, $ 478.53, 423.88, 376.47, 359.26, 337.15, $ 302.71, 277.89, 249.92, 252.96, 212.12, $ 185.80, 157.51, 163.44, 159.42, 144.03, $ 450.48, 378.75, 309.99, 222.00, 191.46, $ 155.83, 125.84, 98.85, 68.45, 63.64, $ 58.15, 54.00, 52.15, 41.00, 26.00/ real fd01201(135) equivalence (fluxdata( 1, 12, 1),fd01201) data fd01201 / $ 421.02, 1485.10, 2398.20, 2981.30, 3602.40, $ 4011.10, 4206.20, 4305.00, 4301.10, 4072.50, $ 3748.80, 3617.10, 3455.20, 3302.10, 3233.90, $ 3113.30, 3007.60, 2959.40, 2786.40, 2688.30, $ 2592.80, 2602.00, 2394.70, 2229.00, 2224.10, $ 2166.80, 2075.60, 2036.60, 1847.40, 1922.50, $ 1762.80, 1688.30, 1661.00, 1577.60, 1584.20, $ 1553.40, 1515.80, 1400.80, 1410.40, 1274.40, $ 1261.90, 1228.40, 1201.90, 1193.90, 1153.70, $ 1082.70, 1085.60, 1016.70, 1055.90, 985.02, $ 1927.70, 1821.10, 1716.70, 1555.40, 1419.00, $ 1452.90, 1419.90, 1256.30, 1257.30, 1184.70, $ 1104.50, 1105.20, 1023.60, 1003.20, 952.12, $ 928.20, 826.62, 799.93, 809.83, 726.10, $ 730.31, 677.83, 631.06, 619.85, 614.68, $ 1091.10, 1038.70, 1009.20, 911.34, 816.07, $ 795.43, 712.92, 652.83, 643.22, 658.72, $ 559.37, 529.88, 520.88, 499.39, 423.54, $ 437.76, 380.89, 380.30, 359.12, 363.60, $ 317.09, 308.89, 265.78, 277.52, 247.69, $ 629.73, 561.40, 462.45, 393.94, 423.37, $ 357.36, 323.19, 297.35, 247.96, 242.49, $ 200.96, 196.13, 162.95, 169.44, 165.94, $ 128.94, 127.77, 108.67, 105.14, 117.94, $ 356.94, 255.63, 197.53, 179.55, 131.91, $ 104.64, 87.23, 82.30, 40.30, 50.36, $ 51.00, 32.34, 33.00, 17.00, 21.15/ real fd01301(135) equivalence (fluxdata( 1, 13, 1),fd01301) data fd01301 / $ 370.24, 1389.30, 2433.80, 3019.30, 3542.20, $ 4018.40, 4195.20, 4359.10, 4372.20, 4078.80, $ 3843.40, 3574.00, 3466.90, 3205.70, 3097.00, $ 2956.50, 2880.30, 2784.90, 2678.00, 2463.40, $ 2491.20, 2318.60, 2127.60, 2117.70, 2011.20, $ 1904.70, 1855.20, 1784.80, 1716.20, 1594.50, $ 1614.90, 1498.30, 1500.50, 1378.50, 1396.50, $ 1279.00, 1285.20, 1193.20, 1147.90, 1155.90, $ 1089.00, 1078.90, 1033.90, 1066.10, 955.86, $ 959.47, 903.46, 871.55, 834.54, 801.23, $ 1595.00, 1472.10, 1373.80, 1344.10, 1226.10, $ 1160.30, 1127.50, 1078.90, 995.84, 981.24, $ 924.26, 880.95, 817.86, 771.17, 758.52, $ 737.28, 698.43, 634.76, 618.72, 577.81, $ 542.53, 501.59, 493.05, 457.65, 461.67, $ 920.22, 818.86, 776.03, 711.85, 661.91, $ 604.02, 532.12, 547.85, 451.17, 430.39, $ 422.59, 375.57, 359.14, 328.67, 352.75, $ 308.28, 308.28, 293.14, 267.97, 241.33, $ 250.65, 203.33, 212.09, 202.93, 186.80, $ 424.97, 384.38, 360.62, 293.22, 279.27, $ 259.55, 247.27, 211.08, 198.76, 162.57, $ 133.89, 122.11, 124.36, 126.58, 106.60, $ 95.26, 90.03, 96.76, 63.98, 75.18, $ 216.43, 165.73, 144.63, 119.34, 93.82, $ 67.45, 56.31, 46.17, 50.00, 34.00, $ 32.00, 19.15, 21.00, 23.30, 16.00/ real fd01401(135) equivalence (fluxdata( 1, 14, 1),fd01401) data fd01401 / $ 293.35, 1093.30, 1875.10, 2461.10, 3047.70, $ 3431.80, 3576.20, 3662.10, 3546.70, 3326.50, $ 3118.80, 2915.40, 2768.60, 2652.00, 2528.80, $ 2481.10, 2296.60, 2094.80, 2039.50, 1936.00, $ 1929.60, 1840.80, 1735.70, 1640.10, 1606.00, $ 1479.10, 1444.80, 1380.20, 1243.60, 1280.90, $ 1228.90, 1177.30, 1189.80, 1133.10, 1031.30, $ 1011.40, 964.38, 936.92, 914.47, 875.18, $ 840.32, 801.31, 755.54, 771.38, 698.82, $ 736.09, 681.38, 657.21, 614.58, 600.40, $ 1154.90, 1183.50, 1040.40, 989.80, 969.50, $ 898.23, 840.07, 733.88, 741.93, 677.37, $ 661.19, 645.86, 566.85, 577.98, 551.46, $ 490.82, 452.54, 460.13, 424.28, 415.53, $ 399.66, 369.96, 374.17, 337.95, 326.46, $ 641.44, 586.13, 524.02, 531.15, 420.74, $ 468.71, 353.00, 333.00, 341.32, 313.49, $ 285.70, 283.22, 210.54, 234.84, 224.49, $ 208.28, 186.39, 189.16, 180.65, 178.34, $ 148.42, 159.02, 136.53, 131.49, 127.48, $ 309.99, 263.27, 189.63, 218.10, 178.32, $ 149.09, 155.66, 111.80, 119.49, 97.62, $ 112.75, 89.75, 75.38, 79.75, 69.77, $ 63.75, 69.51, 52.37, 52.21, 61.00, $ 146.58, 97.46, 75.38, 83.22, 35.00, $ 54.00, 30.00, 22.00, 21.17, 20.00, $ 9.00, 14.00, 12.00, 16.00, 5.00/ real fd01501(135) equivalence (fluxdata( 1, 15, 1),fd01501) data fd01501 / $ 136.33, 495.49, 817.99, 1131.60, 1389.70, $ 1513.90, 1674.90, 1555.10, 1521.50, 1510.40, $ 1346.10, 1305.80, 1180.80, 1124.50, 1039.50, $ 1052.20, 977.85, 994.12, 927.48, 852.18, $ 766.78, 745.22, 779.28, 630.61, 710.61, $ 644.13, 620.51, 634.47, 553.83, 580.66, $ 525.55, 483.99, 484.87, 471.89, 433.53, $ 418.72, 395.46, 424.26, 349.19, 360.53, $ 319.30, 354.31, 343.55, 300.48, 284.72, $ 295.49, 240.98, 267.84, 238.96, 273.33, $ 475.99, 436.48, 377.87, 386.76, 376.29, $ 341.25, 313.20, 315.46, 316.11, 301.77, $ 291.75, 263.26, 239.08, 239.76, 202.52, $ 198.92, 161.84, 198.56, 181.18, 160.06, $ 157.53, 130.89, 144.21, 142.27, 128.00, $ 203.12, 221.06, 191.60, 179.62, 174.43, $ 126.93, 131.47, 139.47, 128.22, 113.24, $ 105.25, 98.00, 84.71, 97.24, 96.91, $ 74.00, 86.72, 54.08, 62.24, 57.00, $ 49.46, 65.47, 63.00, 50.00, 32.00, $ 79.47, 99.23, 82.00, 69.46, 55.24, $ 52.23, 61.23, 33.00, 45.00, 44.00, $ 43.00, 29.00, 35.00, 27.23, 29.00, $ 22.00, 24.00, 22.00, 12.00, 21.00, $ 48.00, 38.00, 27.00, 14.00, 20.00, $ 19.00, 11.00, 10.00, 13.00, 6.00, $ 2.00, 2.00, 2.00, 3.00, 3.00/ real fd00102(135) equivalence (fluxdata( 1, 1, 2),fd00102) data fd00102 / $ 123.00, 704.60, 1369.00, 2082.10, 2510.70, $ 2911.70, 3186.00, 3074.40, 3114.20, 3111.90, $ 2960.50, 2812.00, 2573.20, 2673.40, 2454.70, $ 2270.40, 2220.60, 2141.60, 1984.10, 1933.90, $ 1852.40, 1740.80, 1691.50, 1480.20, 1491.50, $ 1469.90, 1362.80, 1300.10, 1206.00, 1221.00, $ 1121.60, 1057.40, 1025.70, 998.05, 1004.30, $ 915.42, 881.88, 882.63, 820.00, 813.84, $ 734.34, 746.63, 716.10, 701.92, 668.67, $ 665.13, 671.05, 609.42, 578.55, 561.75, $ 1090.80, 967.93, 1004.10, 931.68, 830.77, $ 776.09, 673.29, 716.34, 620.25, 611.00, $ 596.00, 521.00, 518.00, 532.00, 454.00, $ 454.29, 418.00, 372.00, 398.00, 371.00, $ 328.00, 327.00, 326.00, 305.00, 289.00, $ 540.00, 485.00, 444.29, 418.00, 380.00, $ 347.00, 339.00, 306.00, 265.00, 271.00, $ 268.00, 247.00, 205.00, 195.00, 169.00, $ 150.00, 161.00, 179.00, 146.00, 123.00, $ 125.00, 125.00, 113.00, 107.00, 103.00, $ 253.00, 202.00, 197.00, 159.00, 156.00, $ 147.00, 98.00, 96.00, 95.00, 94.00, $ 79.00, 67.00, 77.00, 80.00, 57.00, $ 49.00, 56.00, 44.00, 37.00, 41.00, $ 140.00, 103.00, 96.00, 59.00, 63.00, $ 37.00, 34.00, 35.00, 24.00, 32.00, $ 22.00, 7.00, 11.00, 15.00, 23.00/ real fd00202(135) equivalence (fluxdata( 1, 2, 2),fd00202) data fd00202 / $ 395.29, 2108.00, 4047.10, 5835.60, 7263.90, $ 8446.00, 9376.40, 9450.40, 9231.00, 9027.30, $ 8707.30, 8119.20, 7682.80, 7552.90, 7158.50, $ 6992.30, 6604.90, 6420.50, 6018.80, 5948.20, $ 5546.20, 4987.00, 4687.80, 4454.40, 4338.00, $ 4140.50, 3940.40, 3762.60, 3639.90, 3451.10, $ 3327.40, 3237.50, 3005.80, 3037.20, 2914.50, $ 2744.50, 2581.70, 2635.70, 2542.90, 2417.60, $ 2231.90, 2195.30, 2076.10, 2066.40, 1962.80, $ 1939.10, 1878.00, 1820.20, 1704.60, 1677.10, $ 3269.40, 3042.70, 2841.90, 2662.40, 2465.00, $ 2332.80, 2250.10, 2150.00, 2074.90, 1822.90, $ 1785.10, 1689.00, 1519.30, 1485.60, 1350.00, $ 1347.00, 1273.00, 1166.00, 1130.60, 1128.00, $ 977.00, 972.00, 901.00, 907.00, 861.00, $ 1654.00, 1517.00, 1383.00, 1250.00, 1164.00, $ 1037.00, 926.00, 925.00, 869.00, 778.00, $ 743.00, 672.00, 671.00, 595.00, 566.00, $ 515.00, 492.00, 498.00, 444.00, 380.00, $ 363.00, 374.00, 347.00, 310.00, 333.00, $ 726.00, 630.00, 574.00, 473.00, 445.00, $ 376.00, 370.00, 328.00, 287.00, 259.00, $ 216.00, 236.00, 186.00, 149.00, 153.00, $ 156.00, 154.00, 140.00, 128.00, 110.00, $ 377.00, 307.00, 250.00, 194.00, 149.00, $ 123.00, 100.00, 81.00, 89.00, 67.00, $ 54.00, 48.00, 39.00, 40.00, 35.00/ real fd00302(135) equivalence (fluxdata( 1, 3, 2),fd00302) data fd00302 / $ 712.63, 3419.30, 6628.90, 8907.90,11062.00, $ 12987.00,14770.00,14876.00,14907.00,14629.00, $ 13962.00,13117.00,12794.00,12302.00,11585.00, $ 11128.00,10808.00,10372.00,10051.00, 9542.90, $ 9163.70, 8264.20, 7609.30, 7280.40, 6927.50, $ 6707.10, 6455.40, 6151.60, 6066.20, 5727.50, $ 5542.00, 5206.10, 5061.70, 4845.80, 4658.70, $ 4374.30, 4336.90, 4133.30, 4011.80, 3922.40, $ 3864.70, 3607.00, 3587.20, 3433.50, 3424.80, $ 3132.30, 3045.40, 2899.00, 2925.80, 2822.90, $ 5159.20, 4822.90, 4602.70, 4420.10, 4196.70, $ 3852.70, 3635.20, 3375.60, 3196.80, 2938.60, $ 2892.60, 2758.00, 2526.60, 2402.30, 2258.00, $ 2202.30, 2044.00, 1925.00, 1874.30, 1805.80, $ 1649.00, 1570.60, 1496.50, 1407.00, 1399.00, $ 2670.00, 2396.00, 2241.00, 2070.00, 1770.00, $ 1789.00, 1595.00, 1496.00, 1412.00, 1331.00, $ 1240.00, 1162.00, 1086.00, 1019.00, 963.00, $ 827.00, 814.00, 678.00, 710.00, 722.00, $ 639.00, 612.00, 626.00, 574.00, 529.00, $ 1171.00, 1014.00, 936.00, 833.00, 717.00, $ 676.00, 599.00, 531.00, 485.00, 455.00, $ 410.00, 387.00, 327.00, 294.00, 285.00, $ 252.00, 243.00, 201.00, 228.00, 191.00, $ 651.00, 487.00, 405.00, 350.00, 271.00, $ 211.00, 192.00, 151.00, 152.00, 106.00, $ 93.00, 66.00, 79.00, 49.00, 56.00/ real fd00402(135) equivalence (fluxdata( 1, 4, 2),fd00402) data fd00402 / $ 988.05, 4639.50, 8508.70,11747.00,13984.00, $ 16360.00,18052.00,19030.00,19086.00,19031.00, $ 18260.00,17285.00,16510.00,16170.00,15677.00, $ 14799.00,14408.00,13749.00,13321.00,12939.00, $ 12225.00,10994.00,10034.00, 9815.80, 9230.10, $ 8870.40, 8725.60, 8456.90, 7955.00, 7559.40, $ 7476.00, 7011.50, 6803.90, 6619.40, 6205.70, $ 5965.60, 5750.50, 5568.80, 5394.60, 5253.50, $ 5043.70, 4832.10, 4813.00, 4609.20, 4375.10, $ 4317.00, 4173.20, 3995.10, 3971.20, 3757.40, $ 7044.90, 6664.70, 6325.00, 5963.00, 5565.90, $ 5228.00, 4920.40, 4683.60, 4376.70, 4138.30, $ 3866.60, 3711.60, 3511.30, 3260.00, 3037.00, $ 2954.20, 2706.30, 2609.50, 2470.00, 2424.00, $ 2255.00, 2199.30, 2169.30, 1969.30, 1924.00, $ 3538.00, 3213.00, 3057.30, 2778.00, 2568.00, $ 2405.00, 2190.00, 2041.00, 1893.00, 1775.00, $ 1697.00, 1531.00, 1445.00, 1272.00, 1275.00, $ 1209.00, 1119.00, 1051.00, 1003.00, 962.00, $ 874.00, 801.00, 825.00, 750.00, 727.00, $ 1676.00, 1433.00, 1221.00, 1154.00, 1008.00, $ 900.00, 889.00, 736.00, 639.00, 644.00, $ 563.00, 539.00, 506.00, 466.00, 392.00, $ 355.00, 344.00, 331.00, 300.00, 256.00, $ 961.00, 715.00, 569.00, 458.00, 348.00, $ 302.00, 265.00, 199.00, 172.00, 158.00, $ 115.00, 122.00, 94.00, 98.00, 73.00/ real fd00502(135) equivalence (fluxdata( 1, 5, 2),fd00502) data fd00502 / $ 1328.80, 5733.80,10231.00,13228.00,15855.00, $ 17939.00,19871.00,20264.00,21107.00,21226.00, $ 20728.00,19747.00,19209.00,18672.00,17963.00, $ 17402.00,16988.00,16478.00,16051.00,15541.00, $ 14472.00,13166.00,12241.00,11691.00,11416.00, $ 10899.00,10521.00,10334.00, 9567.60, 9148.70, $ 8851.60, 8511.70, 8216.80, 7811.90, 7539.70, $ 7292.50, 7070.00, 6760.10, 6598.60, 6440.00, $ 6311.60, 5912.80, 5626.40, 5669.70, 5289.20, $ 5158.20, 5196.90, 4945.60, 4780.40, 4532.70, $ 8636.10, 8084.50, 7782.00, 7239.90, 6726.90, $ 6468.10, 6189.40, 5674.50, 5383.60, 5101.30, $ 4840.80, 4506.20, 4390.60, 3997.30, 3750.50, $ 3571.30, 3482.00, 3344.30, 3026.30, 3005.50, $ 2895.60, 2776.00, 2657.70, 2558.30, 2452.00, $ 4382.80, 4168.00, 3773.60, 3511.00, 3180.00, $ 2961.00, 2762.00, 2500.00, 2369.00, 2308.00, $ 2103.00, 1925.00, 1762.00, 1770.00, 1666.00, $ 1508.00, 1387.00, 1352.00, 1277.00, 1192.00, $ 1161.00, 1020.00, 1015.00, 1012.00, 986.00, $ 2127.00, 1857.00, 1637.00, 1503.00, 1253.00, $ 1165.00, 1075.00, 930.00, 846.00, 764.00, $ 727.00, 646.00, 643.00, 554.00, 527.00, $ 450.00, 432.00, 414.00, 356.00, 348.00, $ 1205.00, 911.00, 718.00, 589.00, 481.00, $ 381.00, 322.00, 293.00, 244.00, 218.00, $ 160.00, 166.00, 126.00, 131.00, 105.00/ real fd00602(135) equivalence (fluxdata( 1, 6, 2),fd00602) data fd00602 / $ 1531.70, 6616.10,11169.00,14113.00,16521.00, $ 18181.00,19788.00,20292.00,21038.00,20925.00, $ 20489.00,19299.00,19007.00,18792.00,18541.00, $ 18229.00,17588.00,17306.00,17065.00,16286.00, $ 15536.00,14053.00,13371.00,12916.00,12398.00, $ 11839.00,11391.00,11047.00,10407.00,10200.00, $ 9785.80, 9567.00, 9203.00, 8719.10, 8576.00, $ 8151.20, 7923.00, 7669.80, 7399.00, 6918.10, $ 6862.20, 6534.40, 6509.00, 6170.90, 6030.10, $ 5830.20, 5653.00, 5474.80, 5419.40, 5098.00, $ 9770.90, 9120.70, 8822.00, 8157.00, 7705.60, $ 7218.10, 6757.70, 6470.50, 6038.30, 5732.40, $ 5396.20, 5126.40, 4924.10, 4481.80, 4325.90, $ 4084.00, 3922.80, 3665.60, 3549.60, 3363.60, $ 3262.00, 3144.70, 2939.90, 2888.30, 2761.30, $ 5179.00, 4673.30, 4390.60, 4033.00, 3685.00, $ 3369.00, 3213.00, 2944.00, 2738.00, 2591.00, $ 2444.00, 2266.00, 2165.00, 2062.00, 1829.00, $ 1794.00, 1635.00, 1557.00, 1465.00, 1353.00, $ 1339.00, 1366.00, 1188.00, 1154.00, 1078.00, $ 2336.00, 2337.00, 1968.00, 1713.00, 1505.00, $ 1445.00, 1279.00, 1153.00, 1064.00, 1000.00, $ 844.00, 739.00, 738.00, 661.00, 630.00, $ 563.00, 524.00, 490.00, 445.00, 402.00, $ 1457.00, 1132.00, 830.00, 712.00, 591.00, $ 484.00, 413.00, 347.00, 299.00, 238.00, $ 207.00, 184.00, 178.00, 137.00, 136.00/ real fd00702(135) equivalence (fluxdata( 1, 7, 2),fd00702) data fd00702 / $ 1735.20, 7283.90,11777.00,14591.00,16448.00, $ 17810.00,18974.00,19022.00,19046.00,18858.00, $ 18029.00,16775.00,16567.00,16028.00,15823.00, $ 15533.00,15317.00,14797.00,14498.00,14262.00, $ 13711.00,12526.00,11860.00,11008.00,11080.00, $ 10826.00,10406.00,10073.00, 9656.20, 9275.10, $ 8993.10, 8698.90, 8396.30, 8150.00, 8082.70, $ 7577.80, 7295.20, 7201.30, 6995.60, 6672.50, $ 6504.30, 6438.50, 6100.70, 5849.00, 5770.20, $ 5644.90, 5439.70, 5288.80, 5020.50, 4913.20, $ 9489.90, 9006.40, 8663.30, 7959.50, 7629.70, $ 7293.50, 6847.40, 6357.30, 5795.60, 5688.70, $ 5418.40, 5066.90, 4975.20, 4496.90, 4271.30, $ 4258.60, 4027.60, 3737.60, 3566.00, 3481.20, $ 3218.00, 3169.60, 3032.00, 2949.00, 2823.60, $ 5250.50, 4757.50, 4351.60, 4066.00, 3797.00, $ 3556.00, 3329.00, 3094.00, 2847.00, 2656.00, $ 2497.00, 2392.00, 2231.00, 2114.00, 1984.00, $ 1874.00, 1829.00, 1700.00, 1572.00, 1479.00, $ 1413.00, 1339.00, 1251.00, 1173.00, 1147.00, $ 2598.00, 2415.00, 2084.00, 1883.00, 1639.00, $ 1533.00, 1319.00, 1255.00, 1141.00, 1057.00, $ 975.00, 825.00, 866.00, 700.00, 586.00, $ 597.00, 569.00, 548.00, 515.00, 473.00, $ 1631.00, 1252.00, 1032.00, 817.00, 638.00, $ 541.00, 435.00, 368.00, 322.00, 244.00, $ 259.00, 190.00, 171.00, 153.00, 149.00/ real fd00802(135) equivalence (fluxdata( 1, 8, 2),fd00802) data fd00802 / $ 1938.90, 7367.30,12057.00,14133.00,15903.00, $ 16987.00,17114.00,17508.00,16907.00,16387.00, $ 15315.00,14265.00,13495.00,13035.00,12590.00, $ 12173.00,11459.00,11815.00,11009.00,10527.00, $ 10303.00, 9522.30, 8722.00, 8517.50, 8252.90, $ 7766.20, 7525.20, 7484.60, 7127.90, 6730.30, $ 6558.20, 6242.00, 6204.70, 5944.10, 5733.60, $ 5442.70, 5492.30, 5313.70, 5054.90, 4876.90, $ 4749.20, 4547.90, 4316.60, 4362.20, 4290.40, $ 4112.30, 3853.40, 3789.90, 3770.90, 3559.60, $ 6803.80, 6389.40, 6261.60, 5596.20, 5598.30, $ 5165.70, 4871.00, 4663.50, 4303.10, 4192.80, $ 4044.40, 3638.80, 3555.60, 3268.90, 3169.00, $ 3070.10, 2872.50, 2975.40, 2838.20, 2572.20, $ 2477.10, 2178.30, 2340.80, 2130.30, 2206.10, $ 3862.30, 3577.00, 3426.10, 3088.20, 2790.30, $ 2655.80, 2382.30, 2206.60, 2120.50, 1924.50, $ 1902.40, 1846.70, 1613.20, 1655.00, 1408.50, $ 1420.60, 1332.00, 1208.00, 1111.20, 1001.20, $ 1144.50, 1066.50, 875.25, 1000.50, 939.24, $ 2090.00, 1681.20, 1664.00, 1560.00, 1302.00, $ 1104.00, 1136.00, 1066.00, 878.00, 846.00, $ 788.00, 686.00, 618.00, 628.00, 536.00, $ 464.00, 450.00, 412.00, 400.00, 382.00, $ 1396.00, 978.00, 848.00, 668.00, 560.00, $ 474.00, 356.00, 274.00, 278.00, 286.00, $ 216.00, 174.00, 172.00, 126.00, 138.00/ real fd00902(135) equivalence (fluxdata( 1, 9, 2),fd00902) data fd00902 / $ 1541.70, 6069.90, 9612.30,11827.00,13282.00, $ 14269.00,15235.00,15297.00,15392.00,15206.00, $ 14557.00,13553.00,13384.00,12941.00,12780.00, $ 12534.00,12290.00,11874.00,11843.00,11515.00, $ 11137.00,10408.00, 9841.30, 9238.30, 9282.30, $ 9086.50, 8710.80, 8441.10, 8082.50, 7794.80, $ 7549.00, 7363.00, 7133.80, 6925.30, 6868.40, $ 6454.40, 6249.40, 6201.50, 6005.70, 5745.20, $ 5585.30, 5528.30, 5280.80, 5020.70, 5058.00, $ 4838.20, 4672.80, 4592.70, 4339.40, 4290.70, $ 8234.60, 7929.50, 7562.60, 6989.60, 6696.10, $ 6454.40, 6065.00, 5628.30, 5177.30, 5084.60, $ 4865.40, 4561.60, 4434.40, 4072.60, 3862.90, $ 3884.20, 3640.00, 3384.10, 3259.70, 3171.80, $ 2913.30, 2929.20, 2762.60, 2709.80, 2616.50, $ 4811.00, 4380.70, 4051.60, 3796.60, 3533.90, $ 3325.20, 3116.30, 2912.40, 2691.50, 2516.70, $ 2367.90, 2250.30, 2115.90, 2006.00, 1886.40, $ 1789.80, 1740.80, 1626.10, 1515.50, 1408.40, $ 1349.70, 1287.40, 1203.20, 1133.00, 1104.80, $ 2509.90, 2346.90, 2014.00, 1839.00, 1598.70, $ 1495.40, 1290.30, 1226.70, 1106.80, 1043.90, $ 961.08, 813.61, 849.97, 689.45, 573.93, $ 586.59, 559.21, 543.85, 511.00, 467.38, $ 1617.90, 1241.40, 1029.70, 815.38, 638.00, $ 540.18, 434.15, 368.00, 320.41, 244.00, $ 259.00, 190.00, 169.42, 153.00, 149.00/ real fd01002(135) equivalence (fluxdata( 1, 10, 2),fd01002) data fd01002 / $ 1089.10, 4435.00, 7201.40, 8916.80,10360.00, $ 11316.00,12387.00,12610.00,13087.00,13040.00, $ 12634.00,12014.00,11840.00,11624.00,11610.00, $ 11447.00,11107.00,10815.00,10738.00,10278.00, $ 9889.70, 9028.20, 8722.00, 8525.70, 8179.60, $ 7816.00, 7571.60, 7310.70, 6935.90, 6756.60, $ 6601.30, 6476.90, 6241.70, 5896.60, 5845.50, $ 5565.30, 5463.20, 5208.90, 5199.30, 4848.90, $ 4724.90, 4541.50, 4540.30, 4309.00, 4187.30, $ 4088.40, 3983.10, 3851.30, 3903.50, 3578.90, $ 6904.40, 6472.30, 6303.30, 5836.90, 5592.30, $ 5233.70, 4957.90, 4747.60, 4471.20, 4222.40, $ 4067.50, 3819.70, 3731.20, 3436.40, 3287.30, $ 3086.20, 2965.50, 2796.30, 2740.50, 2600.30, $ 2518.80, 2444.40, 2276.80, 2276.30, 2173.40, $ 4106.00, 3703.30, 3539.40, 3254.60, 2943.70, $ 2755.30, 2626.90, 2404.90, 2293.50, 2181.80, $ 2044.90, 1883.50, 1829.90, 1717.10, 1543.10, $ 1520.50, 1395.80, 1327.60, 1254.20, 1167.90, $ 1146.20, 1193.10, 1032.10, 1001.30, 932.26, $ 2036.00, 2072.70, 1746.50, 1544.60, 1357.30, $ 1289.80, 1163.80, 1050.40, 972.58, 910.11, $ 787.17, 688.74, 692.39, 621.61, 592.39, $ 532.03, 494.86, 461.07, 419.66, 383.75, $ 1397.20, 1094.40, 804.80, 697.55, 578.01, $ 470.40, 407.91, 342.14, 292.07, 236.39, $ 206.15, 183.18, 177.18, 136.21, 136.00/ real fd01102(135) equivalence (fluxdata( 1, 11, 2),fd01102) data fd01102 / $ 803.08, 3130.50, 5246.40, 6510.50, 7781.20, $ 8695.40, 9496.10, 9677.10,10031.00,10228.00, $ 9944.90, 9690.90, 9256.20, 9101.40, 8738.90, $ 8519.70, 8273.00, 8146.70, 7871.10, 7701.40, $ 7310.80, 6764.40, 6421.70, 6205.00, 6109.90, $ 5928.20, 5742.00, 5608.40, 5217.40, 5025.20, $ 4913.30, 4727.40, 4599.00, 4355.80, 4201.20, $ 4066.20, 4066.70, 3855.10, 3840.60, 3729.60, $ 3621.40, 3432.30, 3263.60, 3317.50, 3031.50, $ 3049.40, 3019.40, 2919.40, 2835.10, 2723.80, $ 5070.90, 4864.70, 4703.10, 4442.50, 4134.40, $ 4018.30, 3838.70, 3623.40, 3458.70, 3300.60, $ 3167.40, 2957.80, 2892.70, 2621.30, 2532.20, $ 2416.70, 2376.20, 2254.50, 2022.60, 2062.20, $ 1998.10, 1907.00, 1860.20, 1754.30, 1733.70, $ 3125.80, 2972.50, 2745.80, 2542.70, 2327.30, $ 2211.70, 2056.50, 1855.30, 1793.10, 1744.30, $ 1613.60, 1489.70, 1358.50, 1375.50, 1315.30, $ 1209.10, 1095.90, 1071.70, 1035.60, 961.32, $ 945.96, 832.85, 804.64, 809.07, 822.53, $ 1747.90, 1541.80, 1383.00, 1271.50, 1087.10, $ 1000.40, 936.25, 820.83, 752.01, 678.14, $ 647.75, 575.38, 583.69, 505.48, 470.17, $ 409.97, 399.23, 377.85, 326.88, 315.69, $ 1122.60, 854.47, 691.26, 571.34, 466.49, $ 374.30, 316.03, 288.66, 236.67, 211.90, $ 159.15, 163.45, 126.00, 130.15, 102.45/ real fd01202(135) equivalence (fluxdata( 1, 12, 2),fd01202) data fd01202 / $ 555.11, 2254.60, 3887.30, 5224.60, 6036.60, $ 6778.50, 7527.20, 7914.20, 7901.40, 8055.90, $ 7693.50, 7250.00, 6987.60, 6992.90, 6742.90, $ 6333.40, 6200.00, 6000.50, 5766.40, 5681.50, $ 5348.60, 5180.40, 4850.10, 4760.40, 4537.80, $ 4454.90, 4308.20, 4079.20, 4007.70, 3847.70, $ 3850.30, 3546.90, 3509.50, 3424.80, 3258.30, $ 3077.20, 3024.60, 2923.40, 2819.60, 2741.50, $ 2665.30, 2617.50, 2655.10, 2511.80, 2454.50, $ 2314.80, 2345.20, 2207.80, 2138.70, 2068.30, $ 3906.20, 3789.60, 3576.80, 3426.70, 3236.30, $ 3058.00, 2902.30, 2804.20, 2623.70, 2568.00, $ 2403.80, 2298.60, 2225.70, 2033.50, 1970.70, $ 1856.70, 1738.10, 1711.70, 1651.50, 1631.90, $ 1475.00, 1470.90, 1466.70, 1314.60, 1312.40, $ 2488.00, 2206.70, 2154.10, 1942.70, 1821.60, $ 1730.00, 1562.00, 1509.00, 1386.20, 1313.10, $ 1269.20, 1134.30, 1085.20, 989.27, 987.55, $ 919.11, 877.71, 818.51, 787.69, 754.27, $ 694.87, 634.59, 655.84, 611.97, 588.53, $ 1342.40, 1198.80, 1026.70, 980.57, 853.33, $ 761.83, 762.30, 643.65, 573.32, 568.30, $ 499.53, 480.87, 461.42, 417.28, 360.15, $ 328.72, 316.83, 312.14, 276.26, 240.50, $ 903.28, 674.95, 541.74, 438.16, 333.06, $ 288.54, 250.12, 195.46, 170.39, 157.15, $ 114.15, 119.45, 92.30, 95.55, 71.30/ real fd01302(135) equivalence (fluxdata( 1, 13, 2),fd01302) data fd01302 / $ 441.23, 2100.10, 3785.50, 4935.00, 6164.50, $ 7063.90, 8025.50, 7943.20, 8105.10, 7998.20, $ 7611.50, 7220.20, 7034.30, 6745.40, 6386.30, $ 6112.50, 6076.90, 5690.90, 5587.20, 5325.50, $ 5167.20, 4713.60, 4506.70, 4308.10, 4067.40, $ 4080.30, 3832.90, 3666.50, 3674.90, 3466.70, $ 3307.70, 3117.80, 3101.00, 2995.80, 2892.50, $ 2671.90, 2697.20, 2607.60, 2550.80, 2456.20, $ 2399.90, 2207.30, 2237.50, 2153.90, 2132.10, $ 2029.20, 1941.80, 1836.10, 1923.40, 1794.90, $ 3355.90, 3126.60, 3018.60, 2912.50, 2765.70, $ 2566.20, 2434.10, 2247.10, 2146.60, 2023.00, $ 2031.00, 1916.40, 1751.70, 1728.60, 1598.10, $ 1583.20, 1452.90, 1371.80, 1353.20, 1321.30, $ 1184.20, 1152.30, 1113.30, 1039.50, 1020.30, $ 1977.20, 1821.80, 1669.80, 1594.30, 1347.90, $ 1353.10, 1226.00, 1153.10, 1107.30, 1023.30, $ 985.60, 917.70, 874.43, 826.77, 752.62, $ 661.80, 634.58, 544.78, 590.60, 595.56, $ 533.36, 507.34, 521.94, 472.28, 447.76, $ 969.99, 867.57, 812.14, 727.52, 631.07, $ 591.69, 516.83, 469.35, 435.97, 416.66, $ 362.91, 360.14, 298.50, 265.37, 272.46, $ 233.21, 225.45, 191.25, 214.37, 180.56, $ 606.79, 468.32, 387.38, 338.79, 262.55, $ 206.66, 186.01, 144.98, 147.05, 104.30, $ 90.48, 66.00, 75.62, 48.23, 56.00/ real fd01402(135) equivalence (fluxdata( 1, 14, 2),fd01402) data fd01402 / $ 320.79, 1609.40, 3008.10, 4197.90, 5159.60, $ 5999.80, 6552.60, 6670.40, 6602.00, 6429.00, $ 6106.60, 5735.00, 5463.20, 5418.40, 5167.80, $ 5004.80, 4763.00, 4625.90, 4336.40, 4352.00, $ 4034.40, 3684.70, 3491.90, 3289.30, 3190.70, $ 3101.40, 2992.60, 2832.20, 2703.60, 2642.10, $ 2493.50, 2457.50, 2300.60, 2308.40, 2236.60, $ 2128.40, 1980.20, 1993.70, 1982.60, 1848.80, $ 1736.30, 1692.10, 1638.60, 1612.10, 1529.20, $ 1501.50, 1447.50, 1413.90, 1345.90, 1312.80, $ 2560.30, 2404.00, 2265.80, 2131.60, 1997.40, $ 1881.40, 1815.40, 1743.30, 1679.70, 1503.40, $ 1480.20, 1378.80, 1272.30, 1237.10, 1116.70, $ 1113.60, 1068.30, 1001.00, 964.55, 958.67, $ 830.77, 806.53, 758.36, 771.56, 724.63, $ 1409.70, 1324.60, 1208.20, 1063.70, 1025.60, $ 918.98, 832.03, 825.30, 756.99, 691.66, $ 664.30, 614.84, 593.74, 546.62, 513.13, $ 463.02, 436.26, 461.11, 412.16, 348.98, $ 332.69, 345.21, 318.59, 282.00, 305.25, $ 683.32, 590.53, 541.76, 444.00, 419.82, $ 355.23, 354.13, 311.20, 279.37, 244.44, $ 206.24, 225.04, 178.05, 147.31, 147.31, $ 152.55, 151.40, 135.94, 123.90, 107.62, $ 369.46, 296.82, 247.54, 193.22, 148.18, $ 122.18, 97.59, 80.15, 88.15, 66.16, $ 54.00, 48.00, 39.00, 39.18, 35.00/ real fd01502(135) equivalence (fluxdata( 1, 15, 2),fd01502) data fd01502 / $ 118.79, 661.57, 1287.10, 1943.90, 2307.20, $ 2664.80, 2925.50, 2815.20, 2852.20, 2826.80, $ 2747.10, 2599.60, 2374.90, 2464.20, 2270.00, $ 2114.80, 2044.60, 1959.70, 1856.00, 1807.30, $ 1704.10, 1615.20, 1599.60, 1386.10, 1387.90, $ 1375.40, 1268.50, 1215.10, 1140.70, 1135.90, $ 1065.10, 1001.40, 965.75, 937.15, 950.30, $ 873.05, 821.16, 833.21, 788.58, 767.60, $ 695.80, 701.99, 672.02, 668.42, 635.17, $ 626.21, 637.95, 574.42, 555.03, 538.98, $ 1039.30, 914.61, 955.12, 894.32, 783.17, $ 745.42, 637.13, 692.44, 599.12, 587.33, $ 582.51, 508.41, 504.80, 509.12, 440.11, $ 437.49, 404.10, 366.00, 385.55, 355.45, $ 318.99, 320.13, 317.87, 300.40, 282.70, $ 526.55, 475.10, 434.80, 409.12, 373.34, $ 337.98, 335.22, 297.44, 258.85, 265.41, $ 265.71, 241.65, 202.70, 192.71, 168.24, $ 148.46, 158.69, 176.89, 146.00, 123.00, $ 124.24, 125.00, 112.23, 105.47, 102.22, $ 251.47, 199.90, 195.45, 159.00, 154.47, $ 147.00, 98.00, 96.00, 95.00, 94.00, $ 79.00, 67.00, 76.22, 80.00, 57.00, $ 49.00, 56.00, 44.00, 37.00, 41.00, $ 140.00, 103.00, 96.00, 59.00, 63.00, $ 37.00, 34.00, 35.00, 24.00, 32.00, $ 22.00, 7.00, 11.00, 15.00, 23.00/ real fd00103(135) equivalence (fluxdata( 1, 1, 3),fd00103) data fd00103 / $ 0.00, 0.00, 0.00, 0.00, 0.00, $ 1473.10, 1641.90, 1582.70, 1621.20, 1478.80, $ 1449.30, 1324.40, 1252.40, 1184.20, 1125.00, $ 1082.90, 1037.90, 932.88, 928.42, 906.21, $ 804.38, 779.04, 768.13, 711.88, 705.13, $ 683.05, 586.29, 567.38, 590.83, 529.17, $ 513.88, 505.84, 507.00, 491.29, 451.25, $ 417.58, 413.29, 409.21, 392.00, 350.00, $ 369.00, 329.29, 334.00, 282.00, 281.29, $ 286.29, 266.34, 257.00, 274.00, 265.00, $ 506.00, 466.00, 407.00, 407.34, 352.00, $ 368.00, 350.58, 309.29, 307.34, 294.00, $ 270.54, 260.00, 266.00, 246.00, 200.00, $ 177.00, 207.00, 205.00, 187.00, 165.00, $ 157.00, 128.00, 138.00, 143.00, 134.00, $ 232.00, 214.00, 201.00, 184.00, 162.00, $ 150.00, 126.00, 131.00, 127.00, 109.00, $ 116.00, 94.00, 102.00, 92.00, 87.00, $ 81.00, 76.00, 73.00, 76.00, 60.00, $ 49.00, 50.00, 46.00, 38.00, 58.00, $ 97.00, 79.00, 84.00, 70.00, 69.00, $ 57.00, 42.00, 45.00, 48.00, 41.00, $ 29.00, 36.00, 18.00, 18.00, 22.00, $ 25.00, 21.00, 17.00, 13.00, 12.00, $ 42.00, 32.00, 19.00, 23.00, 25.00, $ 15.00, 12.00, 8.00, 4.00, 6.00, $ 4.00, 2.00, 2.00, 4.00, 1.00/ real fd00203(135) equivalence (fluxdata( 1, 2, 3),fd00203) data fd00203 / $ 363.59, 1480.80, 2437.20, 3370.80, 3977.70, $ 4486.30, 4659.90, 4825.60, 4706.00, 4358.90, $ 4153.00, 3909.70, 3695.80, 3435.40, 3326.60, $ 3140.80, 2996.20, 2850.50, 2723.50, 2578.00, $ 2475.80, 2301.20, 2172.20, 2192.20, 2052.80, $ 1947.80, 1824.50, 1874.80, 1720.80, 1627.80, $ 1589.00, 1499.40, 1474.20, 1379.30, 1316.20, $ 1330.20, 1218.20, 1170.10, 1090.00, 1068.60, $ 1073.90, 1016.50, 959.29, 915.58, 892.34, $ 887.54, 920.88, 855.00, 792.88, 808.29, $ 1515.50, 1341.00, 1295.60, 1189.20, 1099.00, $ 1023.50, 1025.00, 947.29, 887.17, 877.54, $ 824.58, 811.88, 721.29, 690.29, 684.25, $ 643.58, 563.83, 531.29, 491.54, 489.00, $ 468.00, 458.00, 417.00, 419.29, 415.00, $ 758.29, 647.00, 613.00, 536.00, 531.00, $ 489.00, 470.00, 418.00, 410.00, 315.00, $ 296.00, 266.00, 258.00, 243.00, 241.00, $ 196.00, 231.00, 211.00, 232.00, 168.00, $ 185.00, 175.00, 179.00, 138.00, 146.00, $ 316.00, 277.00, 241.00, 247.00, 182.00, $ 143.00, 123.00, 132.00, 126.00, 106.00, $ 103.00, 85.00, 81.00, 73.00, 52.00, $ 54.00, 63.00, 48.00, 44.00, 35.00, $ 127.00, 127.00, 78.00, 66.00, 51.00, $ 55.00, 42.00, 29.00, 23.00, 17.00, $ 11.00, 12.00, 7.00, 12.00, 7.00/ real fd00303(135) equivalence (fluxdata( 1, 3, 3),fd00303) data fd00303 / $ 573.54, 2328.60, 3924.80, 5366.30, 6214.90, $ 6847.90, 7403.50, 7773.20, 7522.30, 7174.70, $ 6516.90, 6046.20, 5869.90, 5662.50, 5525.80, $ 5157.80, 4917.40, 4674.20, 4269.40, 4296.70, $ 4113.60, 3744.30, 3619.20, 3592.20, 3433.10, $ 3270.10, 3058.40, 2934.40, 2814.90, 2719.90, $ 2640.50, 2419.70, 2356.40, 2289.90, 2164.90, $ 2078.50, 2003.20, 1849.00, 1847.50, 1795.70, $ 1778.80, 1687.70, 1634.20, 1549.20, 1500.30, $ 1471.80, 1452.60, 1355.30, 1287.60, 1281.90, $ 2404.20, 2243.20, 2203.00, 2015.00, 1874.50, $ 1753.60, 1624.90, 1615.10, 1502.50, 1379.50, $ 1384.00, 1292.10, 1112.30, 1095.00, 1053.50, $ 1038.30, 968.88, 923.00, 891.08, 824.00, $ 779.43, 713.25, 726.00, 726.34, 697.00, $ 1261.30, 1124.00, 1047.00, 941.00, 861.29, $ 819.00, 714.00, 667.00, 641.00, 564.00, $ 555.00, 527.00, 491.00, 458.00, 413.00, $ 362.00, 367.00, 343.00, 302.00, 348.00, $ 316.00, 269.00, 267.00, 260.00, 218.00, $ 499.00, 461.00, 386.00, 350.00, 316.00, $ 306.00, 230.00, 205.00, 214.00, 186.00, $ 159.00, 155.00, 137.00, 134.00, 112.00, $ 111.00, 112.00, 88.00, 84.00, 78.00, $ 250.00, 158.00, 144.00, 112.00, 83.00, $ 59.00, 62.00, 47.00, 35.00, 26.00, $ 29.00, 19.00, 19.00, 20.00, 9.00/ real fd00403(135) equivalence (fluxdata( 1, 4, 3),fd00403) data fd00403 / $ 757.58, 3053.60, 5111.50, 6828.20, 8056.80, $ 8901.90, 9604.90, 9727.70, 9573.80, 9182.20, $ 8433.90, 8086.00, 7994.60, 7403.10, 7169.40, $ 6842.10, 6397.30, 6277.40, 5992.50, 5707.10, $ 5424.70, 5267.70, 5127.20, 4820.80, 4598.90, $ 4296.90, 4132.70, 3957.70, 3782.80, 3654.90, $ 3473.20, 3338.90, 3160.20, 3108.20, 2939.30, $ 2828.30, 2731.80, 2642.80, 2516.70, 2354.00, $ 2426.50, 2237.50, 2169.80, 2169.90, 2058.20, $ 2128.40, 1967.20, 1894.50, 1828.80, 1706.40, $ 3194.70, 3155.50, 2964.10, 2662.80, 2666.90, $ 2455.10, 2306.50, 2165.60, 2031.90, 1938.10, $ 1741.60, 1722.90, 1697.60, 1528.30, 1504.30, $ 1451.00, 1379.50, 1275.30, 1177.20, 1160.00, $ 1072.60, 1126.00, 981.29, 914.58, 887.00, $ 1727.60, 1540.90, 1453.00, 1255.00, 1193.00, $ 1167.00, 998.00, 978.00, 893.00, 866.00, $ 747.00, 750.00, 651.00, 647.00, 598.00, $ 551.00, 466.00, 458.00, 452.00, 474.00, $ 438.00, 371.00, 371.00, 329.00, 313.00, $ 707.00, 665.00, 599.00, 512.00, 440.00, $ 406.00, 334.00, 321.00, 323.00, 255.00, $ 234.00, 222.00, 182.00, 190.00, 151.00, $ 162.00, 135.00, 131.00, 115.00, 101.00, $ 366.00, 281.00, 217.00, 167.00, 138.00, $ 113.00, 82.00, 65.00, 62.00, 46.00, $ 43.00, 31.00, 31.00, 28.00, 17.00/ real fd00503(135) equivalence (fluxdata( 1, 5, 3),fd00503) data fd00503 / $ 975.63, 3700.90, 6172.30, 7846.10, 9264.10, $ 10179.00,10676.00,10917.00,11026.00,10494.00, $ 9610.80, 9387.40, 9100.10, 8732.00, 8381.50, $ 7997.60, 7636.00, 7462.00, 7258.60, 6840.10, $ 6531.80, 6295.90, 6030.80, 5724.00, 5479.60, $ 5204.40, 5087.50, 4689.10, 4584.60, 4415.60, $ 4317.80, 4059.60, 3950.60, 3774.30, 3652.50, $ 3473.50, 3383.30, 3230.90, 3112.30, 3024.30, $ 2922.50, 2828.50, 2650.80, 2602.40, 2588.20, $ 2415.50, 2362.90, 2327.10, 2235.30, 2249.10, $ 4087.40, 3881.80, 3676.40, 3412.30, 3317.80, $ 3102.40, 2860.90, 2763.70, 2659.60, 2439.50, $ 2229.20, 2237.60, 2080.60, 1966.40, 1900.30, $ 1827.60, 1708.30, 1661.30, 1579.30, 1495.30, $ 1427.30, 1322.00, 1299.00, 1280.30, 1178.00, $ 2142.00, 1977.40, 1878.00, 1641.30, 1552.00, $ 1477.00, 1283.00, 1295.00, 1130.00, 1087.00, $ 993.00, 929.00, 914.00, 860.00, 760.00, $ 708.00, 687.00, 671.00, 587.00, 575.00, $ 539.00, 506.00, 489.00, 466.00, 442.00, $ 1017.00, 885.00, 784.00, 716.00, 624.00, $ 551.00, 472.00, 465.00, 406.00, 369.00, $ 353.00, 326.00, 297.00, 267.00, 216.00, $ 232.00, 174.00, 180.00, 172.00, 166.00, $ 498.00, 379.00, 329.00, 235.00, 179.00, $ 144.00, 113.00, 107.00, 78.00, 61.00, $ 69.00, 48.00, 47.00, 44.00, 48.00/ real fd00603(135) equivalence (fluxdata( 1, 6, 3),fd00603) data fd00603 / $ 1121.30, 4104.10, 6492.40, 8332.90, 9555.50, $ 10378.00,10844.00,11135.00,11054.00,10453.00, $ 9690.70, 9220.40, 9140.60, 8771.00, 8643.90, $ 8378.00, 8135.60, 7796.20, 7769.40, 7130.30, $ 6948.90, 6693.80, 6564.20, 6175.20, 5991.30, $ 5615.30, 5680.20, 5420.30, 5126.70, 5036.70, $ 4678.60, 4533.60, 4355.10, 4334.60, 4038.80, $ 4003.70, 3868.00, 3673.40, 3638.10, 3388.50, $ 3295.30, 3085.00, 3029.10, 3059.70, 2908.60, $ 2688.30, 2748.80, 2670.90, 2517.80, 2386.50, $ 4631.40, 4462.60, 4132.80, 3872.50, 3645.20, $ 3567.40, 3322.00, 3085.40, 2989.50, 2882.80, $ 2727.60, 2537.90, 2452.20, 2292.60, 2177.90, $ 2153.80, 2002.20, 1859.30, 1803.00, 1766.30, $ 1620.60, 1587.00, 1477.00, 1424.00, 1369.00, $ 2625.10, 2409.30, 2114.00, 2029.30, 1910.00, $ 1699.00, 1623.00, 1433.00, 1416.00, 1308.00, $ 1254.00, 1217.00, 1069.00, 1036.00, 972.00, $ 930.00, 833.00, 796.00, 739.00, 716.00, $ 674.00, 628.00, 639.00, 553.00, 565.00, $ 1322.00, 1107.00, 973.00, 820.00, 763.00, $ 684.00, 623.00, 579.00, 537.00, 439.00, $ 430.00, 424.00, 386.00, 362.00, 293.00, $ 280.00, 227.00, 250.00, 258.00, 212.00, $ 693.00, 547.00, 403.00, 327.00, 256.00, $ 201.00, 184.00, 140.00, 131.00, 90.00, $ 76.00, 84.00, 77.00, 41.00, 46.00/ real fd00703(135) equivalence (fluxdata( 1, 7, 3),fd00703) data fd00703 / $ 1313.00, 4445.70, 6714.80, 8195.40, 9219.00, $ 9989.00,10120.00,10342.00,10134.00, 9435.60, $ 8538.70, 8205.60, 8031.70, 7793.90, 7547.10, $ 7285.40, 7036.20, 6782.20, 6612.00, 6308.40, $ 6057.80, 5986.60, 5751.40, 5715.70, 5478.80, $ 5290.90, 5026.70, 4766.20, 4763.00, 4704.40, $ 4413.70, 4302.10, 4089.80, 3945.00, 3809.30, $ 3701.60, 3584.00, 3399.80, 3248.90, 3195.50, $ 3130.70, 3019.50, 2883.80, 2917.20, 2888.90, $ 2774.00, 2609.40, 2480.20, 2446.70, 2407.30, $ 4667.90, 4473.10, 4083.60, 3915.00, 3763.80, $ 3535.90, 3223.10, 3260.30, 3092.00, 2823.50, $ 2658.60, 2623.30, 2529.80, 2284.30, 2264.70, $ 2158.30, 2098.00, 1919.60, 1874.30, 1839.30, $ 1682.90, 1663.30, 1533.30, 1526.30, 1469.00, $ 2723.00, 2613.90, 2371.00, 2146.00, 2083.30, $ 1893.00, 1663.00, 1700.00, 1495.00, 1471.00, $ 1386.00, 1273.00, 1169.00, 1088.00, 1099.00, $ 984.00, 918.00, 869.00, 841.00, 791.00, $ 706.00, 711.00, 686.00, 676.00, 619.00, $ 1389.00, 1250.00, 1193.00, 985.00, 924.00, $ 822.00, 701.00, 669.00, 591.00, 566.00, $ 512.00, 439.00, 433.00, 419.00, 377.00, $ 308.00, 338.00, 264.00, 257.00, 248.00, $ 828.00, 702.00, 521.00, 414.00, 315.00, $ 259.00, 220.00, 194.00, 161.00, 138.00, $ 108.00, 97.00, 74.00, 84.00, 63.00/ real fd00803(135) equivalence (fluxdata( 1, 8, 3),fd00803) data fd00803 / $ 1289.70, 4362.80, 6503.90, 7771.00, 8747.10, $ 8983.20, 9228.50, 9224.80, 8723.10, 7757.80, $ 7016.00, 6778.80, 6583.40, 6063.60, 5932.30, $ 5864.10, 5571.70, 5358.70, 5044.70, 4787.10, $ 4836.60, 4396.50, 4294.70, 4199.20, 4085.20, $ 3990.50, 3712.20, 3716.00, 3423.00, 3427.80, $ 3158.60, 3053.40, 2995.60, 2940.00, 2896.10, $ 2757.00, 2561.20, 2474.40, 2434.20, 2467.60, $ 2335.00, 2163.50, 2228.20, 2103.30, 1979.40, $ 1947.80, 1923.30, 1867.70, 1842.80, 1868.10, $ 3464.20, 3209.00, 2978.60, 2871.80, 2704.70, $ 2533.50, 2493.20, 2301.30, 2189.30, 2090.00, $ 2028.10, 1899.30, 1891.10, 1759.70, 1790.30, $ 1549.30, 1402.90, 1425.60, 1282.60, 1376.20, $ 1313.30, 1200.10, 1169.60, 1188.20, 1083.80, $ 2004.60, 1926.10, 1741.60, 1663.00, 1574.60, $ 1391.60, 1255.90, 1199.10, 1230.00, 1075.10, $ 1036.20, 931.73, 824.49, 840.68, 779.24, $ 770.00, 746.48, 716.00, 648.00, 634.00, $ 622.00, 594.00, 552.00, 524.00, 490.00, $ 1165.20, 996.00, 894.68, 849.24, 724.49, $ 654.00, 608.00, 540.00, 554.00, 460.00, $ 446.00, 322.00, 334.00, 310.00, 302.00, $ 262.00, 298.00, 240.00, 234.00, 196.00, $ 710.00, 586.00, 478.00, 418.00, 294.00, $ 232.00, 170.00, 196.00, 136.00, 154.00, $ 86.00, 70.00, 92.00, 98.00, 60.00/ real fd00903(135) equivalence (fluxdata( 1, 9, 3),fd00903) data fd00903 / $ 1126.90, 3691.10, 5525.40, 6749.90, 7590.20, $ 8191.90, 8218.00, 8409.20, 8266.00, 7675.40, $ 6896.40, 6649.40, 6535.30, 6346.70, 6208.10, $ 5946.20, 5741.70, 5616.70, 5478.60, 5222.50, $ 4978.40, 4922.60, 4793.60, 4771.10, 4544.00, $ 4415.90, 4246.60, 4011.20, 3980.10, 3963.90, $ 3741.40, 3603.60, 3445.80, 3326.30, 3238.60, $ 3161.10, 3043.00, 2911.30, 2782.50, 2724.60, $ 2690.30, 2607.60, 2485.10, 2493.90, 2488.70, $ 2404.50, 2276.80, 2152.30, 2126.90, 2095.80, $ 4086.90, 3900.90, 3569.40, 3442.00, 3304.70, $ 3125.60, 2827.70, 2904.70, 2735.60, 2508.50, $ 2339.60, 2334.00, 2275.30, 2040.90, 2033.70, $ 1957.20, 1894.50, 1738.50, 1677.40, 1661.90, $ 1545.20, 1504.00, 1374.00, 1413.60, 1336.70, $ 2491.50, 2385.80, 2193.40, 1998.60, 1943.40, $ 1758.90, 1534.00, 1604.50, 1397.10, 1378.40, $ 1305.60, 1191.50, 1092.10, 1033.40, 1050.90, $ 928.10, 873.86, 841.70, 802.56, 752.37, $ 673.13, 686.41, 653.45, 649.81, 592.53, $ 1322.80, 1204.90, 1150.00, 956.56, 898.59, $ 799.75, 685.67, 651.41, 573.76, 554.05, $ 506.44, 426.72, 427.29, 408.54, 368.26, $ 306.43, 334.68, 260.02, 255.42, 245.41, $ 818.88, 693.94, 520.17, 413.16, 312.61, $ 257.46, 219.20, 192.40, 161.00, 138.00, $ 107.16, 97.00, 74.00, 84.00, 63.00/ real fd01003(135) equivalence (fluxdata( 1, 10, 3),fd01003) data fd01003 / $ 743.26, 2703.30, 4217.60, 5352.10, 6052.00, $ 6559.20, 6846.50, 6992.80, 6982.70, 6589.40, $ 6135.90, 5823.20, 5785.30, 5596.50, 5515.60, $ 5298.70, 5162.70, 5035.20, 4999.20, 4598.50, $ 4516.80, 4385.50, 4297.50, 4068.20, 3980.10, $ 3721.50, 3727.30, 3576.50, 3392.00, 3350.60, $ 3192.70, 3074.20, 2916.70, 2955.60, 2741.30, $ 2730.40, 2660.60, 2555.80, 2503.20, 2309.60, $ 2300.90, 2143.40, 2124.60, 2134.50, 1987.60, $ 1869.90, 1964.70, 1884.40, 1735.70, 1662.50, $ 3299.60, 3148.40, 2966.50, 2798.30, 2627.90, $ 2551.00, 2460.30, 2248.40, 2208.90, 2137.50, $ 2014.30, 1886.90, 1819.50, 1684.60, 1631.40, $ 1615.40, 1508.90, 1400.60, 1363.10, 1345.60, $ 1219.10, 1223.90, 1108.80, 1084.20, 1037.10, $ 2016.10, 1906.00, 1659.80, 1647.00, 1519.60, $ 1386.70, 1295.40, 1159.70, 1158.10, 1079.70, $ 1005.90, 1012.40, 903.39, 872.66, 811.53, $ 782.48, 692.06, 676.03, 627.47, 610.49, $ 576.11, 532.88, 548.24, 478.98, 495.97, $ 1156.00, 961.53, 851.92, 717.59, 676.75, $ 622.30, 553.73, 534.60, 486.66, 403.29, $ 387.07, 389.94, 360.25, 332.04, 268.67, $ 262.02, 204.17, 230.21, 240.24, 193.68, $ 650.50, 519.65, 382.80, 318.48, 246.71, $ 194.91, 183.15, 137.51, 128.45, 90.00, $ 75.15, 81.45, 76.15, 40.22, 46.00/ real fd01103(135) equivalence (fluxdata( 1, 11, 3),fd01103) data fd01103 / $ 562.66, 2026.30, 3198.70, 3961.60, 4653.60, $ 5084.10, 5340.90, 5411.80, 5563.00, 5241.40, $ 4827.80, 4779.30, 4559.50, 4370.50, 4230.90, $ 4033.50, 3932.30, 3837.70, 3819.60, 3581.20, $ 3405.50, 3327.20, 3227.90, 3075.90, 2987.70, $ 2769.30, 2755.40, 2564.10, 2503.90, 2458.50, $ 2390.20, 2225.70, 2243.50, 2156.50, 2041.10, $ 1987.90, 1867.30, 1808.20, 1759.20, 1671.60, $ 1699.50, 1646.10, 1546.80, 1560.50, 1567.00, $ 1446.50, 1388.30, 1407.70, 1359.70, 1368.80, $ 2473.40, 2327.20, 2221.30, 2086.10, 2051.60, $ 1885.40, 1766.90, 1732.50, 1677.30, 1579.60, $ 1410.30, 1430.80, 1398.60, 1305.90, 1241.50, $ 1169.90, 1133.60, 1120.80, 1039.00, 1000.10, $ 957.48, 881.70, 878.32, 872.88, 814.10, $ 1486.50, 1382.70, 1350.10, 1197.00, 1106.30, $ 1057.20, 926.23, 964.05, 819.47, 813.92, $ 741.90, 696.31, 689.22, 658.50, 580.83, $ 537.60, 532.07, 522.40, 466.55, 447.49, $ 424.61, 395.39, 379.00, 370.30, 355.24, $ 812.26, 718.80, 651.36, 587.84, 522.22, $ 468.83, 408.40, 402.00, 348.81, 324.19, $ 301.08, 283.05, 258.67, 229.36, 192.49, $ 211.93, 159.02, 165.88, 156.87, 155.67, $ 458.81, 355.63, 303.19, 229.86, 170.21, $ 138.76, 110.48, 103.61, 74.50, 60.15, $ 69.00, 48.00, 46.15, 44.00, 47.15/ real fd01203(135) equivalence (fluxdata( 1, 12, 3),fd01203) data fd01203 / $ 370.77, 1457.80, 2336.20, 3106.00, 3622.10, $ 3879.50, 4191.70, 4260.20, 4175.20, 4078.80, $ 3688.10, 3551.60, 3519.90, 3324.00, 3280.50, $ 3158.40, 2952.20, 2897.10, 2864.20, 2699.20, $ 2537.40, 2470.50, 2421.70, 2392.20, 2230.00, $ 2107.60, 2074.60, 1938.10, 1924.50, 1844.50, $ 1840.40, 1712.10, 1598.50, 1631.10, 1530.30, $ 1475.30, 1496.70, 1424.90, 1275.50, 1264.40, $ 1322.40, 1210.50, 1140.60, 1207.50, 1128.80, $ 1207.70, 1096.10, 1057.40, 1039.30, 968.13, $ 1807.70, 1787.10, 1700.70, 1535.40, 1552.60, $ 1472.10, 1355.60, 1266.10, 1190.10, 1181.50, $ 1025.40, 1106.00, 1058.70, 949.28, 926.39, $ 917.99, 855.99, 800.31, 726.51, 746.74, $ 667.90, 712.12, 628.40, 604.32, 571.84, $ 1164.80, 1034.40, 965.83, 844.25, 839.71, $ 811.62, 703.79, 700.75, 650.01, 618.26, $ 528.25, 566.04, 492.76, 497.23, 440.93, $ 428.44, 353.92, 356.28, 337.25, 376.41, $ 340.13, 289.52, 301.08, 246.64, 245.46, $ 564.01, 537.19, 484.27, 394.47, 373.43, $ 347.19, 274.87, 281.65, 276.82, 218.76, $ 204.18, 202.52, 165.91, 170.57, 131.20, $ 146.85, 120.62, 118.71, 98.48, 92.06, $ 332.70, 256.30, 201.24, 159.13, 133.49, $ 110.31, 79.17, 59.93, 59.37, 44.42, $ 43.00, 31.00, 31.00, 28.00, 17.00/ real fd01303(135) equivalence (fluxdata( 1, 13, 3),fd01303) data fd01303 / $ 357.98, 1334.50, 2264.80, 3053.00, 3494.20, $ 3922.30, 4153.10, 4369.80, 4176.90, 4000.30, $ 3646.90, 3345.70, 3274.10, 3196.80, 3036.90, $ 2947.40, 2789.30, 2700.90, 2454.60, 2493.80, $ 2403.60, 2182.10, 2131.50, 2102.80, 1996.80, $ 1957.00, 1841.90, 1770.80, 1650.80, 1655.60, $ 1582.20, 1517.00, 1450.60, 1413.90, 1328.80, $ 1314.90, 1233.10, 1194.20, 1200.70, 1147.50, $ 1117.70, 1089.30, 1043.30, 995.80, 986.84, $ 927.40, 928.27, 867.17, 824.13, 829.57, $ 1533.50, 1466.70, 1423.00, 1295.30, 1237.00, $ 1134.30, 1080.40, 1080.60, 978.89, 934.48, $ 951.42, 882.75, 764.26, 735.02, 718.21, $ 715.41, 673.52, 668.33, 613.45, 593.76, $ 538.02, 504.25, 524.91, 528.97, 481.70, $ 948.24, 832.74, 773.44, 685.61, 611.84, $ 603.86, 529.21, 521.52, 495.94, 438.15, $ 444.45, 396.96, 378.84, 365.68, 331.50, $ 291.78, 287.28, 274.06, 236.51, 278.48, $ 256.74, 215.19, 205.71, 208.58, 179.66, $ 398.36, 397.01, 324.87, 295.44, 273.19, $ 265.28, 200.49, 175.35, 184.96, 167.26, $ 138.10, 146.58, 122.04, 120.57, 98.39, $ 99.02, 103.24, 82.10, 73.54, 71.08, $ 227.29, 149.20, 134.46, 109.57, 80.49, $ 56.55, 60.15, 47.00, 34.15, 26.00, $ 28.19, 18.15, 19.00, 20.00, 9.00/ real fd01403(135) equivalence (fluxdata( 1, 14, 3),fd01403) data fd01403 / $ 275.44, 1079.80, 1794.90, 2438.00, 2830.30, $ 3247.50, 3352.10, 3446.50, 3364.00, 3099.50, $ 2984.00, 2816.60, 2628.80, 2482.00, 2412.50, $ 2276.30, 2177.10, 2123.50, 1984.90, 1929.00, $ 1788.60, 1712.10, 1665.00, 1607.50, 1526.80, $ 1456.10, 1382.50, 1401.60, 1305.90, 1241.50, $ 1185.00, 1126.70, 1114.80, 1045.20, 1009.50, $ 1015.00, 945.50, 868.03, 843.66, 831.70, $ 874.01, 787.13, 737.41, 718.65, 699.48, $ 705.31, 740.90, 671.00, 625.18, 646.18, $ 1146.70, 1056.10, 1048.40, 948.77, 886.48, $ 828.27, 833.12, 750.62, 729.16, 703.34, $ 666.54, 641.71, 575.89, 558.40, 560.59, $ 533.73, 472.67, 422.00, 404.92, 415.52, $ 392.34, 390.25, 361.17, 345.75, 357.98, $ 655.40, 542.97, 526.43, 453.25, 452.91, $ 437.38, 410.35, 364.70, 351.23, 269.34, $ 260.25, 235.55, 232.04, 220.63, 213.85, $ 171.23, 201.53, 186.94, 209.96, 149.97, $ 168.53, 157.38, 163.45, 123.38, 138.04, $ 288.52, 255.51, 224.84, 237.01, 167.45, $ 136.20, 116.04, 123.95, 116.48, 102.73, $ 98.84, 78.18, 76.01, 70.61, 48.40, $ 54.00, 60.48, 43.60, 43.15, 34.18, $ 123.83, 125.43, 75.54, 66.00, 50.18, $ 53.42, 42.00, 29.00, 23.00, 17.00, $ 11.00, 12.00, 7.00, 11.15, 7.00/ real fd01503(135) equivalence (fluxdata( 1, 15, 3),fd01503) data fd01503 / $ 114.89, 463.85, 816.26, 1054.30, 1247.50, $ 1346.80, 1509.90, 1455.90, 1501.00, 1379.80, $ 1333.70, 1220.90, 1156.80, 1074.50, 1051.70, $ 996.61, 955.02, 859.75, 851.46, 850.73, $ 756.20, 729.87, 712.50, 661.55, 655.51, $ 644.07, 551.52, 526.58, 561.33, 496.46, $ 483.94, 478.22, 477.92, 468.28, 436.25, $ 395.22, 389.51, 390.56, 382.98, 332.44, $ 355.45, 310.58, 306.48, 264.78, 265.89, $ 270.06, 254.64, 247.68, 260.42, 260.19, $ 486.44, 433.93, 393.63, 398.05, 336.89, $ 356.47, 333.60, 296.70, 292.20, 283.28, $ 258.49, 245.13, 255.40, 232.99, 195.19, $ 169.34, 203.40, 200.92, 183.90, 160.97, $ 149.64, 122.89, 134.10, 135.94, 130.15, $ 224.95, 207.08, 194.95, 181.73, 158.94, $ 146.96, 122.73, 128.47, 124.73, 105.14, $ 113.13, 90.72, 101.25, 92.00, 85.47, $ 80.23, 74.49, 72.24, 74.47, 59.22, $ 49.00, 50.00, 44.47, 38.00, 58.00, $ 97.00, 79.00, 84.00, 69.25, 69.00, $ 57.00, 41.22, 44.22, 48.00, 40.22, $ 29.00, 35.25, 18.00, 18.00, 22.00, $ 25.00, 21.00, 17.00, 13.00, 12.00, $ 42.00, 32.00, 19.00, 23.00, 25.00, $ 15.00, 12.00, 8.00, 4.00, 6.00, $ 4.00, 2.00, 2.00, 4.00, 1.00/ real fd00104(135) equivalence (fluxdata( 1, 1, 4),fd00104) data fd00104 / $ 150.00, 741.55, 1420.00, 2066.80, 2532.00, $ 2883.40, 3193.20, 3124.80, 3208.70, 3052.20, $ 2937.10, 2727.00, 2761.30, 2595.30, 2467.40, $ 2348.90, 2283.60, 2099.50, 2155.50, 2073.10, $ 1905.00, 1673.90, 1629.60, 1522.50, 1414.30, $ 1384.10, 1308.30, 1285.60, 1235.90, 1217.40, $ 1151.40, 1089.40, 1000.80, 1058.80, 975.13, $ 923.92, 876.30, 898.17, 846.64, 815.17, $ 786.50, 797.96, 743.71, 753.09, 662.67, $ 609.63, 608.97, 610.38, 524.73, 598.42, $ 1078.20, 1047.60, 944.17, 815.51, 862.30, $ 802.30, 764.92, 673.58, 686.58, 569.08, $ 606.34, 548.75, 498.54, 497.25, 478.29, $ 463.83, 418.00, 365.29, 389.00, 383.88, $ 342.29, 327.29, 324.00, 318.00, 281.00, $ 496.29, 502.54, 428.00, 395.00, 359.00, $ 336.00, 306.00, 320.00, 253.00, 285.00, $ 260.00, 251.00, 229.00, 189.00, 205.00, $ 175.00, 158.00, 161.00, 132.00, 131.00, $ 137.00, 149.00, 106.00, 107.00, 103.00, $ 240.00, 177.00, 203.00, 177.00, 150.00, $ 144.00, 134.00, 102.00, 88.00, 96.00, $ 94.00, 69.00, 61.00, 61.00, 49.00, $ 51.00, 47.00, 39.00, 47.00, 42.00, $ 117.00, 116.00, 69.00, 60.00, 28.00, $ 39.00, 39.00, 35.00, 24.00, 16.00, $ 16.00, 19.00, 10.00, 18.00, 14.00/ real fd00204(135) equivalence (fluxdata( 1, 2, 4),fd00204) data fd00204 / $ 423.06, 2185.40, 4054.40, 5835.80, 7181.40, $ 8262.50, 9050.00, 9481.70, 9432.70, 9085.50, $ 8712.60, 8235.00, 7900.30, 7466.40, 7319.40, $ 6838.90, 6536.50, 6438.50, 6049.10, 5892.10, $ 5475.50, 5029.30, 4645.20, 4554.70, 4338.70, $ 3988.60, 3990.30, 3824.60, 3713.60, 3524.90, $ 3391.40, 3265.10, 3105.30, 2979.70, 2764.80, $ 2782.00, 2678.00, 2580.00, 2484.50, 2389.70, $ 2289.60, 2199.20, 2140.60, 2138.70, 2031.30, $ 1968.60, 1907.20, 1831.90, 1710.40, 1619.70, $ 3226.20, 3054.00, 2871.00, 2604.00, 2465.80, $ 2348.20, 2217.60, 2074.70, 1876.30, 1750.30, $ 1732.30, 1632.90, 1515.70, 1452.20, 1404.30, $ 1346.50, 1278.40, 1186.60, 1180.70, 1060.20, $ 1078.00, 980.63, 1014.50, 888.92, 889.54, $ 1525.70, 1463.30, 1365.00, 1200.00, 1153.00, $ 1022.00, 901.00, 817.00, 844.00, 772.00, $ 725.00, 654.00, 659.00, 610.00, 553.00, $ 519.00, 519.00, 490.00, 422.00, 424.00, $ 363.00, 398.00, 336.00, 339.00, 313.00, $ 702.00, 679.00, 569.00, 499.00, 451.00, $ 419.00, 337.00, 328.00, 311.00, 297.00, $ 243.00, 207.00, 163.00, 174.00, 164.00, $ 146.00, 152.00, 129.00, 114.00, 114.00, $ 410.00, 287.00, 216.00, 200.00, 148.00, $ 107.00, 85.00, 74.00, 78.00, 61.00, $ 58.00, 39.00, 47.00, 36.00, 30.00/ real fd00304(135) equivalence (fluxdata( 1, 3, 4),fd00304) data fd00304 / $ 681.80, 3503.90, 6490.70, 9154.60,11383.00, $ 13005.00,14526.00,15132.00,14783.00,14706.00, $ 14064.00,13074.00,12686.00,12162.00,11618.00, $ 11170.00,10723.00,10426.00, 9737.70, 9577.90, $ 8866.90, 8120.00, 7701.20, 7241.00, 7025.20, $ 6628.70, 6367.20, 6044.50, 5936.10, 5780.30, $ 5541.80, 5422.50, 5056.30, 4735.60, 4674.40, $ 4447.20, 4364.50, 4199.20, 4021.10, 3834.80, $ 3799.60, 3564.90, 3469.90, 3346.40, 3296.20, $ 3187.90, 3011.40, 2979.70, 2845.10, 2724.50, $ 5211.50, 4860.00, 4430.80, 4397.00, 4081.70, $ 3788.50, 3652.40, 3417.80, 3145.10, 3043.40, $ 2764.10, 2676.70, 2530.40, 2395.70, 2300.80, $ 2113.50, 1999.50, 1931.00, 1822.80, 1797.90, $ 1646.20, 1590.00, 1484.80, 1406.90, 1421.60, $ 2665.60, 2287.50, 2210.30, 2006.90, 1839.00, $ 1706.00, 1668.00, 1555.30, 1425.00, 1231.00, $ 1219.00, 1065.00, 1093.00, 982.00, 992.00, $ 827.00, 759.00, 783.00, 699.00, 673.00, $ 644.00, 613.00, 590.00, 586.00, 500.00, $ 1124.00, 1011.00, 912.00, 789.00, 733.00, $ 639.00, 590.00, 509.00, 552.00, 453.00, $ 380.00, 374.00, 359.00, 297.00, 292.00, $ 237.00, 238.00, 220.00, 208.00, 175.00, $ 634.00, 495.00, 361.00, 283.00, 255.00, $ 195.00, 168.00, 114.00, 123.00, 113.00, $ 80.00, 88.00, 46.00, 49.00, 51.00/ real fd00404(135) equivalence (fluxdata( 1, 4, 4),fd00404) data fd00404 / $ 994.60, 4599.60, 8725.70,11520.00,13938.00, $ 16272.00,17875.00,18693.00,19406.00,18955.00, $ 18208.00,17001.00,16668.00,16156.00,15456.00, $ 14842.00,14403.00,13928.00,13252.00,12560.00, $ 11971.00,11126.00,10364.00,10091.00, 9477.60, $ 8942.70, 8797.10, 8216.70, 8017.10, 7674.70, $ 7294.60, 6994.20, 6912.40, 6652.00, 6257.10, $ 6051.00, 5734.40, 5609.60, 5322.10, 5259.70, $ 5115.60, 4847.00, 4733.30, 4661.50, 4518.20, $ 4325.40, 4021.90, 3968.30, 3883.90, 3745.60, $ 7180.80, 6728.30, 6290.30, 5831.30, 5486.50, $ 5257.00, 4992.80, 4523.40, 4369.40, 4146.40, $ 3920.00, 3659.60, 3387.60, 3204.80, 3053.00, $ 2911.90, 2771.30, 2779.50, 2537.20, 2438.40, $ 2337.50, 2174.70, 2105.20, 1990.30, 1953.60, $ 3504.20, 3145.60, 3075.50, 2672.50, 2563.30, $ 2350.70, 2258.00, 2069.00, 1937.30, 1742.00, $ 1651.00, 1579.00, 1406.00, 1291.00, 1285.00, $ 1155.00, 1080.00, 1035.00, 999.00, 943.00, $ 877.00, 804.00, 758.00, 746.00, 733.00, $ 1663.00, 1417.00, 1281.00, 1153.00, 990.00, $ 904.00, 859.00, 770.00, 684.00, 609.00, $ 557.00, 509.00, 449.00, 415.00, 432.00, $ 378.00, 330.00, 329.00, 270.00, 239.00, $ 912.00, 626.00, 602.00, 441.00, 341.00, $ 252.00, 218.00, 188.00, 155.00, 146.00, $ 128.00, 108.00, 82.00, 58.00, 67.00/ real fd00504(135) equivalence (fluxdata( 1, 5, 4),fd00504) data fd00504 / $ 1269.50, 5717.20,10038.00,13326.00,15672.00, $ 18125.00,19647.00,20688.00,21306.00,21431.00, $ 20695.00,19587.00,19045.00,18741.00,18232.00, $ 17340.00,16694.00,16489.00,15969.00,15428.00, $ 14498.00,13416.00,12373.00,12076.00,11444.00, $ 11070.00,10427.00, 9951.50, 9624.50, 9302.40, $ 9029.60, 8561.10, 8301.80, 8183.20, 7684.30, $ 7305.10, 7002.50, 6804.80, 6508.40, 6449.30, $ 6179.70, 5933.10, 5723.40, 5461.60, 5444.00, $ 5261.40, 5045.40, 4875.60, 4719.60, 4607.70, $ 8663.10, 8195.00, 7731.10, 7317.00, 6861.20, $ 6408.60, 5941.60, 5650.50, 5385.40, 4970.50, $ 4761.70, 4676.60, 4295.70, 4053.90, 3776.70, $ 3667.90, 3402.50, 3218.90, 3210.50, 2935.70, $ 2937.40, 2709.40, 2608.20, 2390.30, 2323.70, $ 4465.60, 4065.20, 3750.20, 3516.20, 3213.60, $ 2986.00, 2698.40, 2489.00, 2349.00, 2222.30, $ 2065.00, 1933.00, 1808.00, 1743.00, 1590.00, $ 1438.00, 1415.00, 1314.00, 1330.00, 1229.00, $ 1089.00, 1045.00, 1024.00, 973.00, 939.00, $ 1948.00, 1787.00, 1541.00, 1404.00, 1287.00, $ 1170.00, 1035.00, 932.00, 890.00, 787.00, $ 688.00, 666.00, 617.00, 536.00, 484.00, $ 472.00, 482.00, 426.00, 373.00, 320.00, $ 1137.00, 901.00, 657.00, 534.00, 450.00, $ 346.00, 307.00, 259.00, 219.00, 183.00, $ 146.00, 155.00, 129.00, 112.00, 90.00/ real fd00604(135) equivalence (fluxdata( 1, 6, 4),fd00604) data fd00604 / $ 1496.60, 6614.40,11217.00,14248.00,16558.00, $ 18535.00,19624.00,20453.00,20762.00,21066.00, $ 20181.00,19161.00,19153.00,18787.00,18816.00, $ 18179.00,17955.00,16905.00,16721.00,16085.00, $ 15409.00,14076.00,13238.00,12930.00,12560.00, $ 11818.00,11633.00,11057.00,10743.00,10210.00, $ 9830.20, 9566.90, 9057.60, 8813.90, 8514.80, $ 8147.40, 7917.80, 7776.90, 7201.10, 7194.70, $ 6959.70, 6676.10, 6320.50, 6152.40, 5876.50, $ 5934.80, 5696.80, 5480.40, 5308.50, 5254.70, $ 9795.50, 9228.30, 8652.40, 8136.20, 7720.50, $ 7299.00, 6758.40, 6446.40, 6066.80, 5545.00, $ 5250.90, 5102.70, 4943.50, 4607.10, 4408.40, $ 4126.80, 3811.00, 3706.80, 3642.60, 3446.10, $ 3252.30, 3149.90, 2864.40, 2839.10, 2757.10, $ 5077.00, 4632.60, 4283.70, 4039.70, 3766.60, $ 3451.60, 3255.30, 2948.00, 2819.00, 2520.30, $ 2438.00, 2196.00, 2137.00, 1944.00, 1794.00, $ 1729.00, 1723.00, 1505.00, 1564.00, 1431.00, $ 1325.00, 1249.00, 1143.00, 1162.00, 1117.00, $ 2433.00, 2249.00, 1965.00, 1787.00, 1564.00, $ 1391.00, 1221.00, 1112.00, 986.00, 960.00, $ 849.00, 748.00, 694.00, 630.00, 620.00, $ 568.00, 503.00, 479.00, 467.00, 445.00, $ 1410.00, 1084.00, 852.00, 719.00, 554.00, $ 448.00, 379.00, 302.00, 277.00, 227.00, $ 212.00, 160.00, 148.00, 128.00, 112.00/ real fd00704(135) equivalence (fluxdata( 1, 7, 4),fd00704) data fd00704 / $ 1849.80, 7220.20,11617.00,14547.00,16571.00, $ 17889.00,18783.00,19105.00,19074.00,18867.00, $ 18072.00,16958.00,16137.00,16169.00,15578.00, $ 15418.00,14857.00,14799.00,14420.00,14215.00, $ 13560.00,12696.00,11720.00,11505.00,10958.00, $ 10827.00,10187.00, 9921.20, 9812.70, 9317.50, $ 9139.60, 8664.30, 8484.50, 8355.60, 7893.70, $ 7812.10, 7493.10, 7277.30, 7020.60, 6749.60, $ 6539.60, 6264.70, 6136.30, 5941.20, 5922.60, $ 5701.60, 5412.90, 5388.00, 5083.60, 5008.70, $ 9696.30, 8938.40, 8523.50, 7919.60, 7743.00, $ 7082.60, 6608.10, 6349.20, 5946.20, 5672.50, $ 5245.80, 5095.70, 4944.80, 4617.40, 4464.90, $ 4191.00, 3904.20, 3749.30, 3641.90, 3453.80, $ 3309.80, 3206.80, 2994.50, 2830.00, 2802.30, $ 5251.50, 4800.10, 4462.00, 4218.70, 3877.60, $ 3547.30, 3285.30, 3071.00, 2791.00, 2643.00, $ 2586.00, 2371.00, 2133.00, 2073.00, 1981.00, $ 1852.00, 1730.00, 1673.00, 1557.00, 1462.00, $ 1375.00, 1316.00, 1249.00, 1222.00, 1126.00, $ 2586.00, 2312.00, 2097.00, 1875.00, 1727.00, $ 1489.00, 1349.00, 1252.00, 1100.00, 1001.00, $ 919.00, 842.00, 760.00, 753.00, 696.00, $ 575.00, 603.00, 524.00, 481.00, 469.00, $ 1547.00, 1191.00, 946.00, 780.00, 627.00, $ 510.00, 447.00, 365.00, 330.00, 252.00, $ 268.00, 192.00, 210.00, 147.00, 138.00/ real fd00804(135) equivalence (fluxdata( 1, 8, 4),fd00804) data fd00804 / $ 2040.20, 7684.20,11987.00,14452.00,15925.00, $ 17289.00,17357.00,17212.00,17087.00,16704.00, $ 15513.00,13850.00,13351.00,12957.00,12470.00, $ 12265.00,11843.00,11197.00,10882.00,10692.00, $ 10278.00, 9427.90, 8917.20, 8559.80, 8208.80, $ 8091.30, 7598.30, 7550.00, 7203.20, 6906.10, $ 6847.30, 6539.20, 6225.40, 6099.30, 5828.30, $ 5742.60, 5562.20, 5106.70, 5192.40, 4800.10, $ 4856.40, 4429.20, 4461.20, 4248.90, 4151.70, $ 4053.80, 3973.00, 3923.10, 3640.50, 3752.60, $ 6918.10, 6657.30, 6291.50, 5789.70, 5418.90, $ 5082.30, 4959.90, 4643.70, 4423.50, 4122.50, $ 3953.80, 3662.00, 3534.20, 3448.50, 3290.80, $ 3060.50, 2897.60, 2808.70, 2748.70, 2662.00, $ 2535.70, 2314.60, 2221.50, 2177.80, 2109.50, $ 3739.10, 3604.40, 3324.60, 3193.20, 2843.00, $ 2718.60, 2503.50, 2241.10, 2016.50, 2056.40, $ 1838.10, 1807.40, 1699.20, 1545.10, 1430.00, $ 1376.00, 1338.00, 1242.00, 1214.00, 1163.00, $ 1053.20, 974.01, 934.00, 948.00, 826.49, $ 2071.00, 1784.00, 1564.00, 1482.00, 1332.00, $ 1164.00, 1098.00, 944.00, 898.00, 794.00, $ 728.00, 618.00, 638.00, 580.00, 562.00, $ 504.00, 428.00, 466.00, 418.00, 418.00, $ 1218.00, 1018.00, 834.00, 652.00, 548.00, $ 442.00, 428.00, 354.00, 300.00, 260.00, $ 210.00, 216.00, 134.00, 156.00, 146.00/ real fd00904(135) equivalence (fluxdata( 1, 9, 4),fd00904) data fd00904 / $ 1617.30, 6081.90, 9536.40,11770.00,13454.00, $ 14473.00,15100.00,15233.00,15299.00,15221.00, $ 14601.00,13672.00,13027.00,13057.00,12594.00, $ 12438.00,11994.00,11957.00,11685.00,11554.00, $ 11075.00,10448.00, 9773.70, 9507.80, 9088.00, $ 9010.50, 8554.70, 8346.90, 8233.60, 7889.80, $ 7802.90, 7308.60, 7208.20, 7128.30, 6710.00, $ 6649.50, 6421.00, 6275.20, 6062.80, 5786.70, $ 5639.60, 5406.70, 5317.10, 5112.60, 5120.40, $ 4931.10, 4741.40, 4702.00, 4451.30, 4305.40, $ 8467.60, 7834.40, 7435.90, 6961.00, 6849.90, $ 6259.00, 5862.60, 5679.20, 5299.20, 5037.60, $ 4710.90, 4581.70, 4475.40, 4156.20, 4006.30, $ 3797.20, 3570.00, 3416.50, 3297.70, 3158.30, $ 3038.70, 2918.90, 2745.50, 2611.70, 2587.90, $ 4841.10, 4457.90, 4168.60, 3904.50, 3608.00, $ 3337.50, 3085.60, 2870.70, 2625.80, 2489.50, $ 2446.40, 2248.00, 2027.60, 1973.40, 1883.80, $ 1764.10, 1659.40, 1604.00, 1494.40, 1401.00, $ 1316.50, 1268.70, 1197.80, 1176.50, 1078.00, $ 2500.60, 2235.70, 2035.40, 1825.60, 1690.70, $ 1445.20, 1318.10, 1226.70, 1085.30, 981.18, $ 905.94, 825.44, 751.23, 742.49, 691.94, $ 566.75, 597.44, 519.24, 477.82, 464.33, $ 1535.70, 1186.00, 943.66, 777.59, 623.79, $ 510.00, 445.34, 365.00, 330.00, 252.00, $ 268.00, 192.00, 210.00, 147.00, 138.00/ real fd01004(135) equivalence (fluxdata( 1, 10, 4),fd01004) data fd01004 / $ 1048.60, 4403.20, 7221.60, 8852.10,10326.00, $ 11458.00,12145.00,12587.00,13022.00,13135.00, $ 12612.00,11896.00,11955.00,11840.00,11764.00, $ 11500.00,11224.00,10534.00,10680.00,10185.00, $ 9805.10, 9102.60, 8650.20, 8523.40, 8271.60, $ 7853.90, 7651.40, 7404.50, 7145.00, 6762.60, $ 6635.60, 6486.40, 6083.50, 5999.10, 5771.80, $ 5602.10, 5428.00, 5298.20, 5038.10, 5003.90, $ 4738.20, 4623.20, 4421.60, 4315.30, 4034.60, $ 4169.20, 3993.30, 3904.70, 3778.80, 3691.90, $ 6979.90, 6582.20, 6191.40, 5851.40, 5582.80, $ 5345.90, 4895.20, 4721.70, 4498.70, 4086.10, $ 3907.90, 3833.50, 3734.00, 3467.00, 3329.70, $ 3146.20, 2899.70, 2859.40, 2823.70, 2671.60, $ 2533.10, 2446.50, 2216.30, 2187.10, 2162.20, $ 3997.90, 3694.00, 3392.30, 3245.90, 3036.70, $ 2793.10, 2668.80, 2422.80, 2337.10, 2086.30, $ 2026.00, 1841.50, 1814.30, 1637.50, 1509.40, $ 1479.10, 1495.80, 1281.60, 1338.10, 1227.00, $ 1148.20, 1086.30, 996.46, 1023.20, 965.93, $ 2165.20, 2012.50, 1745.50, 1614.70, 1438.00, $ 1247.00, 1121.30, 1013.10, 907.76, 874.97, $ 795.79, 699.77, 648.00, 589.58, 586.86, $ 537.43, 481.77, 448.53, 449.39, 423.20, $ 1358.00, 1052.90, 836.26, 696.81, 544.09, $ 442.24, 373.15, 300.32, 274.49, 224.57, $ 212.00, 158.39, 146.34, 128.00, 112.00/ real fd01104(135) equivalence (fluxdata( 1, 11, 4),fd01104) data fd01104 / $ 742.95, 3132.00, 5075.00, 6553.80, 7737.00, $ 8909.10, 9408.20, 9982.00,10231.00,10297.00, $ 9950.20, 9354.30, 9232.60, 8992.40, 8978.80, $ 8530.10, 8278.50, 8084.60, 7897.30, 7746.80, $ 7302.50, 6744.20, 6460.30, 6341.90, 6081.30, $ 5798.90, 5583.40, 5408.30, 5208.10, 5102.50, $ 4961.80, 4773.90, 4636.40, 4596.50, 4294.20, $ 4088.70, 4079.80, 3864.40, 3705.90, 3643.20, $ 3514.30, 3415.70, 3303.90, 3192.10, 3205.80, $ 3053.60, 2952.30, 2890.30, 2815.70, 2759.30, $ 5180.50, 4936.70, 4725.70, 4503.70, 4276.00, $ 4007.80, 3717.80, 3539.60, 3480.10, 3238.50, $ 3068.40, 3048.80, 2796.80, 2601.20, 2530.60, $ 2451.70, 2286.80, 2146.00, 2186.30, 2013.90, $ 2004.30, 1876.30, 1841.10, 1638.20, 1670.10, $ 3142.20, 2903.70, 2733.90, 2569.30, 2393.80, $ 2204.70, 2012.80, 1847.00, 1773.90, 1690.10, $ 1599.10, 1493.90, 1377.80, 1355.10, 1261.10, $ 1158.40, 1132.80, 1056.20, 1067.60, 982.37, $ 892.73, 848.34, 829.69, 805.28, 773.42, $ 1635.80, 1505.50, 1302.90, 1181.00, 1096.90, $ 1035.30, 891.20, 805.12, 785.69, 701.53, $ 609.84, 611.29, 555.41, 493.66, 436.43, $ 432.15, 449.70, 401.26, 341.81, 297.10, $ 1065.80, 850.58, 635.31, 517.77, 436.56, $ 328.99, 303.66, 257.30, 217.15, 181.30, $ 142.45, 154.15, 127.30, 112.00, 89.15/ real fd01204(135) equivalence (fluxdata( 1, 12, 4),fd01204) data fd01204 / $ 547.61, 2276.00, 3919.60, 5114.50, 5907.20, $ 6971.10, 7428.30, 7815.10, 8192.90, 7996.80, $ 7693.40, 7257.10, 7126.80, 7001.00, 6680.80, $ 6454.60, 6227.70, 6144.20, 5750.90, 5556.00, $ 5394.20, 5205.80, 4876.60, 4778.10, 4576.40, $ 4371.60, 4259.40, 4094.70, 4006.00, 3847.10, $ 3687.10, 3495.80, 3533.80, 3413.40, 3230.60, $ 3143.10, 2991.70, 2951.20, 2817.60, 2770.60, $ 2712.10, 2565.40, 2539.30, 2547.40, 2489.00, $ 2386.80, 2206.80, 2178.40, 2177.50, 2109.80, $ 4035.40, 3772.60, 3598.30, 3419.90, 3219.40, $ 3048.60, 2975.20, 2690.60, 2639.30, 2619.90, $ 2403.20, 2263.30, 2138.20, 2017.80, 1936.40, $ 1880.20, 1796.00, 1789.60, 1690.90, 1591.90, $ 1589.20, 1475.00, 1408.40, 1337.50, 1320.30, $ 2397.90, 2158.60, 2155.90, 1897.40, 1898.70, $ 1671.20, 1674.40, 1528.30, 1459.80, 1285.70, $ 1252.70, 1177.60, 1094.30, 976.34, 987.72, $ 899.82, 829.62, 800.86, 793.15, 762.06, $ 700.09, 642.44, 600.09, 586.48, 592.91, $ 1358.30, 1181.30, 1083.50, 994.97, 853.77, $ 779.89, 738.04, 676.46, 596.69, 537.86, $ 498.88, 461.12, 413.57, 388.23, 403.79, $ 349.15, 310.63, 303.72, 254.40, 225.21, $ 867.54, 604.17, 584.87, 429.18, 330.69, $ 246.67, 212.91, 187.15, 153.30, 146.00, $ 128.00, 108.00, 82.00, 57.20, 67.00/ real fd01304(135) equivalence (fluxdata( 1, 13, 4),fd01304) data fd01304 / $ 442.83, 2132.90, 3717.80, 5136.50, 6249.80, $ 7119.40, 7802.80, 8171.00, 8079.50, 8077.00, $ 7666.10, 7175.00, 6995.00, 6720.70, 6472.50, $ 6213.60, 5916.60, 5893.40, 5430.90, 5416.20, $ 5016.80, 4638.50, 4504.30, 4217.20, 4103.60, $ 3947.90, 3828.50, 3633.10, 3625.50, 3488.10, $ 3338.50, 3303.50, 3150.00, 2881.20, 2861.70, $ 2752.90, 2740.60, 2629.70, 2428.80, 2358.10, $ 2374.90, 2220.70, 2189.40, 2138.10, 2097.10, $ 2038.00, 1930.00, 1944.80, 1874.40, 1747.00, $ 3347.00, 3152.70, 2913.30, 2946.80, 2678.60, $ 2509.10, 2499.60, 2288.00, 2117.90, 2040.20, $ 1870.90, 1808.90, 1747.80, 1657.90, 1603.70, $ 1502.90, 1436.70, 1379.80, 1308.20, 1253.00, $ 1181.90, 1148.90, 1063.00, 1009.80, 1039.50, $ 1965.10, 1680.10, 1654.60, 1515.10, 1375.70, $ 1315.60, 1275.40, 1219.40, 1102.70, 968.93, $ 964.46, 855.51, 878.48, 778.54, 810.20, $ 674.01, 608.53, 635.47, 582.84, 557.28, $ 537.58, 521.66, 485.07, 492.17, 416.60, $ 927.80, 866.80, 789.63, 704.19, 656.90, $ 552.14, 512.67, 458.18, 492.52, 407.62, $ 347.01, 333.09, 331.72, 278.81, 271.03, $ 215.53, 221.22, 207.24, 200.39, 165.81, $ 600.46, 477.13, 343.31, 277.88, 250.86, $ 190.01, 165.61, 114.00, 122.15, 109.66, $ 80.00, 87.16, 46.00, 49.00, 51.00/ real fd01404(135) equivalence (fluxdata( 1, 14, 4),fd01404) data fd01404 / $ 347.91, 1653.70, 2916.60, 4231.80, 5129.30, $ 5867.10, 6438.30, 6639.30, 6614.50, 6440.40, $ 6247.00, 5867.90, 5643.00, 5323.70, 5228.70, $ 4894.50, 4747.80, 4754.50, 4304.30, 4272.90, $ 4000.30, 3706.40, 3458.80, 3358.70, 3244.50, $ 2991.80, 2973.90, 2894.30, 2804.40, 2655.80, $ 2584.90, 2511.10, 2383.20, 2268.30, 2104.60, $ 2123.80, 2060.70, 2000.20, 1906.80, 1834.60, $ 1759.10, 1725.20, 1683.70, 1666.60, 1561.30, $ 1551.10, 1502.70, 1433.80, 1382.20, 1282.90, $ 2572.30, 2406.50, 2291.60, 2087.70, 1996.90, $ 1857.40, 1777.80, 1714.30, 1545.60, 1448.10, $ 1421.70, 1367.70, 1269.10, 1200.50, 1191.50, $ 1121.70, 1055.90, 1000.00, 1023.30, 905.80, $ 920.01, 837.04, 863.83, 762.60, 776.94, $ 1316.80, 1280.30, 1193.10, 1045.10, 994.53, $ 886.09, 778.44, 718.51, 740.14, 689.43, $ 644.19, 596.96, 597.36, 542.53, 502.83, $ 473.35, 483.35, 450.95, 386.06, 396.08, $ 337.72, 366.86, 310.27, 302.80, 287.61, $ 654.40, 645.77, 529.93, 470.32, 427.87, $ 395.67, 313.85, 313.57, 298.10, 284.75, $ 235.87, 202.07, 156.16, 165.27, 159.87, $ 141.19, 147.94, 127.30, 114.00, 114.00, $ 406.73, 282.99, 211.96, 198.36, 147.19, $ 107.00, 84.17, 74.00, 78.00, 60.15, $ 58.00, 39.00, 47.00, 36.00, 30.00/ real fd01504(135) equivalence (fluxdata( 1, 15, 4),fd01504) data fd01504 / $ 138.75, 691.90, 1312.60, 1918.60, 2347.10, $ 2672.00, 2902.80, 2877.70, 2945.40, 2789.40, $ 2711.70, 2510.00, 2557.90, 2378.90, 2261.90, $ 2161.50, 2095.40, 1948.80, 1997.50, 1873.50, $ 1758.60, 1567.10, 1510.40, 1414.40, 1340.20, $ 1296.10, 1225.60, 1195.90, 1151.90, 1149.10, $ 1085.90, 1034.30, 953.97, 986.58, 936.26, $ 871.77, 835.00, 855.91, 797.20, 770.57, $ 748.33, 760.01, 701.40, 713.58, 631.26, $ 582.26, 575.70, 577.41, 499.54, 572.95, $ 1026.30, 1000.20, 892.00, 779.78, 823.95, $ 776.92, 737.31, 650.85, 657.38, 547.90, $ 583.63, 538.18, 481.44, 483.30, 459.60, $ 447.27, 410.97, 355.09, 375.21, 375.21, $ 337.02, 317.10, 312.64, 310.77, 276.20, $ 489.83, 489.28, 417.72, 387.66, 353.70, $ 328.14, 302.17, 313.83, 250.71, 281.93, $ 259.22, 246.43, 225.94, 185.18, 205.00, $ 173.48, 154.14, 158.68, 130.49, 129.45, $ 136.25, 145.21, 104.47, 106.22, 103.00, $ 238.48, 177.00, 203.00, 177.00, 150.00, $ 143.23, 134.00, 102.00, 87.23, 96.00, $ 94.00, 68.22, 61.00, 61.00, 49.00, $ 51.00, 47.00, 39.00, 47.00, 42.00, $ 117.00, 116.00, 69.00, 60.00, 28.00, $ 39.00, 39.00, 35.00, 24.00, 16.00, $ 16.00, 19.00, 10.00, 18.00, 14.00/ C search for #### to get to the other end. C####***************************************************** if (.not.called) then called = .true. C**** Fill Energies with the lower bound of the energy bin. Lenr(1) = 0.0 do ie = 2, NEnergies Lenr(ie) = Lenr(ie-1) + DEnr(ie-1) enddo C**** Fill Angles with the central angle. do it = 2,NAngles angles(it) = angles(it) + angles(it-1) enddo do it = 1,NAngles Angles(it) = Angles(it)*3.14159265/180.0 enddo C**** Fill DCos with the delta cosine for this angle. DCos(1) = 1.0-cos(0.5*(angles(1)+angles(2))) do it = 2,NAngles-1 DCos(it) = cos(0.5*(angles(it-1)+angles(it))) $ - cos(0.5*(angles(it)+angles(it+1))) enddo DCos(NAngles) = cos(0.5*(angles(NAngles)+angles(NAngles-1))) $ + 1.0 C**** Convert events per bin into fluxes. do in = 1, NLeptons do it = 1, NAngles do ie = 1, NEnergies FluxData(ie,it,in) = $ FluxData(ie,it,in)/DEnr(ie)/DCos(it) enddo enddo enddo C**** Smooth the energy and angle data do in = 1,NLeptons do ie = 1,NEnergies do it = 1,NAngles r1 = 0.0 r2 = 0.0 do i1 = -1,1 do i2 = -1,1 if ( (it+i1.ge.1).and.(it+i1.le.NAngles) $ .and.(ie+i2.ge.1).and.(ie+i2.le.NEnergies)) then if (i1.eq.0.and.i2.eq.0) then r3 = 1.0 else r3 = 0.125 endif r1 = r1 + r3*FluxData(ie+i2,it+i1,in) $ *dcos(it+i1)*denr(ie+i2) r2 = r2 + r3*dcos(it+i1)*denr(ie+i2) endif enddo enddo FluxData(ie,it,in) = r1/r2 enddo enddo enddo C**** Use the fluxes to determine the average energy for each bin. do ie = 1,NEnergies-1 r1 = 0.0 r2 = 0.0 do it = 1,NAngles do in = 1,NLeptons r1 = r1 + FluxData(ie,it,in) r2 = r2 + FluxData(ie+1,it,in) enddo enddo AEnr(ie) = (LEnr(ie)*r1 + LEnr(ie+1)*r2)/(r1+r2) enddo AEnr(NEnergies) = LEnr(NEnergies) + DEnr(NEnergies)/2.0 endif if (cs.ge.1.0) cs = 0.99 if (cs.le.-1.0) cs = -0.99 angle = acos(cs) call interpol2(aenr,angles,FluxData(1,1,id),NEnergies,NAngles, $ en,angle,FluxLeeKoh89,FluxError,linint,linint) if (FluxError.gt.FluxLeeKoh89*0.10) then C**** The estimated error on the flux is large compared to the quoted C systematic errors. C type *, 'Error on Lee and Koh flux is large:', C $ FluxLeeKoh89, FluxError endif C**** Convert to #/GeV/m^2/sec/sr FluxLeeKoh89 = FluxNormal*FluxLeeKoh89/2.0/3.14159265 if (FluxLeeKoh89.lt.0.0) FluxLeeKoh89 = 0.0 return end subroutine fluxinit(corner,flx,enr,denr,nenr) C**** Initializes the flux, energy and the second direivative of the energy. C**** This assumes that the values were read from a table that may not have C been photo-copied square with the page. C**** The number of flux and energy values. integer nenr C**** The corners of the table. C corner([enr,flx],[lowe,highe],[lowf,highf],[pos,val]) real corner(2,2,2,2) real d1(2), d2(2), a1(2), a2(2) C**** The flux values. real flx(nenr), enr(nenr), denr(nenr) C**** Get the basis vectors of the table. do i1 = 1,2 d1(i1) = corner(i1,2,1,1) - corner(i1,1,1,1) d2(i1) = corner(i1,1,2,1) - corner(i1,1,1,1) a1(i1) = corner(i1,2,1,2) - corner(i1,1,1,2) a2(i1) = corner(i1,1,2,2) - corner(i1,1,1,2) enddo C**** Set the normalization. This is the square of the length!! r1 = d1(1)**2 + d1(2)**2 r2 = d2(1)**2 + d2(2)**2 do i1 = 1,2 d1(i1) = d1(i1) / r1 d2(i1) = d2(i1) / r2 enddo C**** Convert the enr and flx. do i1 = 1,nenr r1 = d1(1)*(enr(i1)-corner(1,1,1,1)) $ + d1(2)*(flx(i1)-corner(2,1,1,1)) r2 = d2(1)*(enr(i1)-corner(1,1,1,1)) $ + d2(2)*(flx(i1)-corner(2,1,1,1)) enr(i1) = a1(1)*r1 + a2(1)*r2 + corner(1,1,1,2) flx(i1) = a1(2)*r1 + a2(2)*r2 + corner(2,1,1,2) enddo C**** Make a spline. call spline(enr,flx,nenr,1.0E+30,1.0E+30,denr) return end subroutine fluxtbl(energy,flx,enr,denr,nenr,flux) C*** Return the flux for an energy C The energy to return the flux for. real energy C**** The number of flux and energy values. integer nenr C**** The flux values. The flx values should be the log10 of the flux. real flx(nenr), enr(nenr), denr(nenr) C**** The flux value. real flux call bspline(enr,flx,denr,nenr,energy,flux) flux = 10**flux return end C******************************************************** C %W% modified on %G% C C This returns the honda flux calculated flux as a function of energy. C C This was read from Caspers thesis. C real function fluxhonda(ener,cs,id) implicit none integer i1, i2 real r1, r2, r3 c c ener - neutrino energy in GeV c cs - zenith cosine of the neutrino. c c id=1 for electron neutrinos c id=2 for muon neutrinos c id=3 for electron antineutrinos c id=4 for muon antineutrinos c C**** The energy to return the flux at real en, ener C**** The cosine of the angle to return the flux at. real cs C**** The neutrino type to return the data for. integer id C**** has this been called. logical called data called /.false./ C**** The nue flux data. integer nue_values parameter (nue_values=11) real nue_corner(2,2,2,2) data nue_corner /513.,70., 12.,70., 516.,383., 12.,383., $ 0.,1., 2000.,1., 0.,4., 2000.,4./ real nuel_enr(nue_values), nuel_flx(nue_values), nuel_denr(nue_values) data nuel_enr /513.,512.,507.,504.,459.,396.,376.,296.,209.,191.,24./ data nuel_flx /314.,379.,398.,393.,312.,247.,232.,185.,149.,143.,94./ real nueh_enr(nue_values), nueh_flx(nue_values), nueh_denr(nue_values) data nueh_enr /513.,511.,507.,504.,457.,398.,377.,298.,206.,192.,21./ data nueh_flx /314.,396.,410.,403.,319.,255.,239.,190.,151.,147.,96./ C**** The nueb flux data. integer nueb_values parameter (nueb_values=16) real nueb_corner(2,2,2,2) data nueb_corner /533.,59., 34.,53., 526.,370., 30.,364., $ 0.,1., 2000.,1., 0.,4., 2000.,4./ real nuebl_enr(nueb_values), nuebl_flx(nueb_values) real nuebl_denr(nueb_values) data nuebl_enr /528.,524.,521.,520.,519.,518.,516.,509.,455., $ 380.,306.,257.,186.,115.,59.,35./ data nuebl_flx /290.,362.,374.,379.,381.,379.,376.,349.,264., $ 198.,156.,133.,106.,83.,65.,59./ real nuebh_enr(nueb_values), nuebh_flx(nueb_values) real nuebh_denr(nueb_values) data nuebh_enr /528.,524.,522.,521.,519.,516.,514.,505.,455., $ 378.,306.,233.,150.,72.,46.,35./ data nuebh_flx /290.,362.,381.,387.,389.,386.,380.,354.,271., $ 202.,159.,127.,96.,71.,64.,61./ C**** The num flux data. integer num_values parameter (num_values=11) real num_corner(2,2,2,2) data num_corner /533.,53., 157.,53., 537.,366., 160.,366., $ 0.,1., 1500.,1., 0.,4., 1500.,4./ real numl_enr(num_values), numl_flx(num_values) real numl_denr(num_values) data numl_enr /534.,532.,529.,518.,500.,477.,415.,352.,267., $ 205.,147./ data numl_flx /366.,386.,400.,383.,352.,318.,258.,218.,177., $ 156.,140./ C data numl_flx /366.,386.,400.,383.,352.,318.,258.,218.,177., C $ 156.,146.,138./ real numh_enr(num_values), numh_flx(num_values) real numh_denr(num_values) data numh_enr /535.,533.,530.,527.,514.,481.,372.,315.,242., $ 175.,143./ data numh_flx /368.,406.,418.,416.,389.,332.,234.,203.,171., $ 150.,138./ C data numh_flx /368.,406.,418.,416.,389.,332.,234.,203.,171., C $ 150.,144.,140./ C**** The numb flux data. integer numb_values parameter (numb_values=12) real numb_corner(2,2,2,2) data numb_corner /535.,55., 34.,43., 534.,366., 34.,366., $ 0.,1., 2000.,1., 0.,4., 2000.,4./ real numbl_enr(numb_values), numbl_flx(numb_values) real numbl_denr(numb_values) data numbl_enr /531.,530.,525.,518.,480.,445.,371.,279., $ 192.,122.,56.,39./ data numbl_flx /364.,389.,400.,391.,324.,283.,228.,180., $ 146.,124.,107.,103./ real numbh_enr(numb_values), numbh_flx(numb_values) real numbh_denr(numb_values) data numbh_enr /531.,529.,525.,520.,512.,491.,445.,399., $ 285.,137.,83.,41./ data numbh_flx /364.,407.,418.,409.,390.,352.,292.,251., $ 187.,132.,117.,106./ if (.not.called) then called = .true. call fluxinit(nue_corner,nuel_flx,nuel_enr,nuel_denr,nue_values) call fluxinit(nue_corner,nueh_flx,nueh_enr,nueh_denr,nue_values) call fluxinit(nueb_corner,nuebl_flx,nuebl_enr,nuebl_denr,nueb_values) call fluxinit(nueb_corner,nuebh_flx,nuebh_enr,nuebh_denr,nueb_values) call fluxinit(num_corner,numl_flx,numl_enr,numl_denr,num_values) call fluxinit(num_corner,numh_flx,numh_enr,numh_denr,num_values) call fluxinit(numb_corner,numbl_flx,numbl_enr,numbl_denr,numb_values) call fluxinit(numb_corner,numbh_flx,numbh_enr,numbh_denr,numb_values) endif en = ener*1000.0 if (id.eq.1) then call fluxtbl(en,nuel_flx,nuel_enr,nuel_denr,nue_values,r1) call fluxtbl(en,nueh_flx,nueh_enr,nueh_denr,nue_values,r2) else if (id.eq.2) then call fluxtbl(en,numl_flx,numl_enr,numl_denr,num_values,r1) call fluxtbl(en,numh_flx,numh_enr,numh_denr,num_values,r2) else if (id.eq.3) then call fluxtbl(en,nuebl_flx,nuebl_enr,nuebl_denr,nueb_values,r1) call fluxtbl(en,nuebh_flx,nuebh_enr,nuebh_denr,nueb_values,r2) else if (id.eq.4) then call fluxtbl(en,numbl_flx,numbl_enr,numbl_denr,numb_values,r1) call fluxtbl(en,numbh_flx,numbh_enr,numbh_denr,numb_values,r2) endif fluxhonda = 0.5*(r1+r2) return end C******************************************************** C %W% modified on %G% C C This returns the honda flux calculated flux as a function of energy. C C This was read from Caspers thesis. C real function fluxlk(ener,cs,id) implicit none integer i1, i2 real r1, r2, r3 c c ener - neutrino energy in GeV c cs - zenith cosine of the neutrino. c c id=1 for electron neutrinos c id=2 for muon neutrinos c id=3 for electron antineutrinos c id=4 for muon antineutrinos c C**** The energy to return the flux at real en, ener C**** The cosine of the angle to return the flux at. real cs C**** The neutrino type to return the data for. integer id C**** has this been called. logical called data called /.false./ C**** The nue flux data. integer nue_values parameter (nue_values=12) real nue_corner(2,2,2,2) data nue_corner /513.,70., 12.,70., 516.,383., 12.,383., $ 0.,1., 2000.,1., 0.,4., 2000.,4./ real nue_flx(nue_values), nue_enr(nue_values), nue_denr(nue_values) data nue_flx /314.,356.,363.,360.,298.,241.,227.,176.,141., $ 137.,108.,83./ data nue_enr /513.,511.,507.,503.,458.,396.,377.,291.,202., $ 192.,106.,17./ C**** The nueb flux data. integer nueb_values parameter (nueb_values=17) real nueb_corner(2,2,2,2) data nueb_corner /533.,59., 34.,53., 526.,370., 30.,364., $ 0.,1., 2000.,1., 0.,4., 2000.,4./ real nueb_enr(nueb_values), nueb_flx(nueb_values) real nueb_denr(nueb_values) data nueb_enr /528.,525.,522.,520.,517.,514.,509.,455.,406., $ 357.,307.,257.,208.,158.,108.,59.,45./ data nueb_flx /290.,329.,345.,349.,349.,343.,333.,264.,221., $ 186.,161.,135.,114.,96.,80.,65.,61./ C**** The num flux data. integer num_values parameter (num_values=12) real num_corner(2,2,2,2) data num_corner /533.,53., 157.,53., 537.,366., 160.,366., $ 0.,1., 1500.,1., 0.,4., 1500.,4./ real num_enr(num_values), num_flx(num_values) real num_denr(num_values) data num_enr /535.,533.,530.,527.,522.,510.,461.,386.,287., $ 200.,167.,145./ data num_flx /331.,362.,372.,374.,368.,352.,295.,234.,182., $ 148.,137.,130./ C**** The numb flux data. integer numb_values parameter (numb_values=18) real numb_corner(2,2,2,2) data numb_corner /535.,55., 34.,43., 534.,366., 34.,366., $ 0.,1., 2000.,1., 0.,4., 2000.,4./ real numb_enr(numb_values), numb_flx(numb_values) real numb_denr(numb_values) data numb_enr /532.,529.,526.,524.,514.,491.,461.,433.,411.,349., $ 305.,260.,208.,168.,109.,89.,61.,39./ data numb_flx /336.,366.,374.,375.,362.,330.,296.,269.,250.,210., $ 188.,166.,147.,133.,115.,109.,101.,96./ if (.not.called) then called = .true. call fluxinit(nue_corner,nue_flx,nue_enr,nue_denr,nue_values) call fluxinit(nueb_corner,nueb_flx,nueb_enr,nueb_denr,nueb_values) call fluxinit(num_corner,num_flx,num_enr,num_denr,num_values) call fluxinit(numb_corner,numb_flx,numb_enr,numb_denr,numb_values) endif en = 1000.0*ener if (id.eq.1) then call fluxtbl(en,nue_flx,nue_enr,nue_denr,nue_values,r1) else if (id.eq.2) then call fluxtbl(en,num_flx,num_enr,num_denr,num_values,r1) else if (id.eq.3) then call fluxtbl(en,nueb_flx,nueb_enr,nueb_denr,nueb_values,r1) else if (id.eq.4) then call fluxtbl(en,numb_flx,numb_enr,numb_denr,numb_values,r1) endif fluxlk = r1 return end C******************************************************** C %W% modified on %G% C C This returns the bgs calculated flux as a function of energy. C C This was read from Caspers thesis. C real function fluxbgs(ener,cs,id) implicit none integer i1, i2 real r1, r2, r3 c c en - neutrino energy in GeV c cs - zenith cosine of the neutrino. c c id=1 for electron neutrinos c id=2 for muon neutrinos c id=3 for electron antineutrinos c id=4 for muon antineutrinos c C**** The energy to return the flux at real en, ener C**** The cosine of the angle to return the flux at. real cs C**** The neutrino type to return the data for. integer id C**** has this been called. logical called data called /.false./ C**** The nue flux data. integer nue_values parameter (nue_values=9) real nue_corner(2,2,2,2) data nue_corner /513.,70., 12.,70., 516.,383., 12.,383., $ 0.,1., 2000.,1., 0.,4., 2000.,4./ real nuel_enr(nue_values), nuel_flx(nue_values), nuel_denr(nue_values) data nuel_enr /439.,389.,339.,289.,238.,187.,137.,87.,39/ data nuel_flx /290.,246.,213.,186.,164.,146.,129.,114.,100./ real nueh_enr(nue_values), nueh_flx(nue_values), nueh_denr(nue_values) data nueh_enr /439.,389.,339.,289.,238.,187.,137.,87.,39./ data nueh_flx /303.,254.,219.,191.,168.,149.,131.,116.,102./ C**** The nueb flux data. integer nueb_values parameter (nueb_values=10) real nueb_corner(2,2,2,2) data nueb_corner /533.,59., 34.,53., 526.,370., 30.,364., $ 0.,1., 2000.,1., 0.,4., 2000.,4./ real nuebl_enr(nueb_values), nuebl_flx(nueb_values) real nuebl_denr(nueb_values) data nuebl_enr /455.,406.,356,306.,257.,207.,158.,107.,58.,38./ data nuebl_flx /271.,224.,189.,160.,136.,116.,98.,82.,68.,61./ real nuebh_enr(nueb_values), nuebh_flx(nueb_values) real nuebh_denr(nueb_values) data nuebh_enr /455.,406.,356,306.,257.,207.,158.,107.,58.,38./ data nuebh_flx /282.,232.,195.,166.,140.,119.,100.,85.,69.,64./ C**** The num flux data. integer num_values parameter (num_values=7) real num_corner(2,2,2,2) data num_corner /533.,53., 157.,53., 537.,366., 160.,366., $ 0.,1., 1500.,1., 0.,4., 1500.,4./ real numl_enr(num_values), numl_flx(num_values) real numl_denr(num_values) data numl_enr /461.,410.,359.,307.,257.,207.,157./ data numl_flx /305.,259.,226.,200.,177.,159.,143./ real numh_enr(num_values), numh_flx(num_values) real numh_denr(num_values) data numh_enr /461.,410.,359.,307.,257.,207.,157./ data numh_flx /315.,266.,231.,203.,180.,161.,144./ C**** The numb flux data. integer numb_values parameter (numb_values=9) real numb_corner(2,2,2,2) data numb_corner /535.,55., 34.,43., 534.,366., 34.,366., $ 0.,1., 2000.,1., 0.,4., 2000.,4./ real numbl_enr(numb_values), numbl_flx(numb_values) real numbl_denr(numb_values) data numbl_enr /460.,411.,360.,309.,259.,209.,160.,109.,59./ data numbl_flx /304.,258.,224.,196.,173.,154.,137.,120.,107./ real numbh_enr(numb_values), numbh_flx(numb_values) real numbh_denr(numb_values) data numbh_enr /460.,411.,360.,309.,259.,209.,160.,109.,59./ data numbh_flx /316.,265.,229.,200.,177.,157.,140.,122.,109./ if (.not.called) then called = .true. call fluxinit(nue_corner,nuel_flx,nuel_enr,nuel_denr,nue_values) call fluxinit(nue_corner,nueh_flx,nueh_enr,nueh_denr,nue_values) call fluxinit(nueb_corner,nuebl_flx,nuebl_enr,nuebl_denr,nueb_values) call fluxinit(nueb_corner,nuebh_flx,nuebh_enr,nuebh_denr,nueb_values) call fluxinit(num_corner,numl_flx,numl_enr,numl_denr,num_values) call fluxinit(num_corner,numh_flx,numh_enr,numh_denr,num_values) call fluxinit(numb_corner,numbl_flx,numbl_enr,numbl_denr,numb_values) call fluxinit(numb_corner,numbh_flx,numbh_enr,numbh_denr,numb_values) endif en = ener*1000.0 if (id.eq.1) then call fluxtbl(en,nuel_flx,nuel_enr,nuel_denr,nue_values,r1) call fluxtbl(en,nueh_flx,nueh_enr,nueh_denr,nue_values,r2) else if (id.eq.2) then call fluxtbl(en,numl_flx,numl_enr,numl_denr,num_values,r1) call fluxtbl(en,numh_flx,numh_enr,numh_denr,num_values,r2) else if (id.eq.3) then call fluxtbl(en,nuebl_flx,nuebl_enr,nuebl_denr,nueb_values,r1) call fluxtbl(en,nuebh_flx,nuebh_enr,nuebh_denr,nueb_values,r2) else if (id.eq.4) then call fluxtbl(en,numbl_flx,numbl_enr,numbl_denr,numb_values,r1) call fluxtbl(en,numbh_flx,numbh_enr,numbh_denr,numb_values,r2) endif fluxbgs = 0.5*(r1+r2) return end C**************************************************************8 C @(#)partnuc.f 1.8 modified on 1/28/93 C subroutine partnuc ( isetn,anuc, $ stpt, $ ei,pi,ui,chi,ni, $ eo,po,uo,cho, $ start,decp, $ imode,icont) integer i1, i2 integer isetn real anuc C**** The input energy, momentum, mass and charge real ei(20),pi(3,20),ui(20),chi(20) C**** The number of input particles. integer ni C**** The Number of output particles. integer no C**** The output energy, momentum, mass, and charge. real eo(20),po(3,20),uo(20),cho(20) C**** The starting point for the hadron. This is an output variable for C icont equal 0 and an input variable if icont is 1. real start(3) C**** The final position of the hadron. This is used to restart a new C hadron from the stopping point after a decay. real decp(3) C**** The starting point for each hadron in the stack. This should be C zero unless icont is 1 real stpt(3,20) C**** The density mode of the model integer imode C**** Flag if this hadron is being restarted integer icont real xtr(3) C**** The nuclear interaction parameters real pin(3), upin(3) common /nucint/uin,chint,ein,pin,upin C**** The nuclear center of mass parameters. real up4cms(3), beta(3) logical prot common /nuccms/rhon,pfermi,unucl,ecms2,up4cms,beta,prot common /nuchad/ihap,nel,ncx integer inot, itrans, idec, inel, iel, iabs, icx common /hadron/inot,itrans,idec,inel,iel,iabs,icx C**** isospin parameters real piso(4,4), chiso(4), uiso(4) common /nucnewprd/ piso, chiso, uiso C**** The mc step, and the nuclear maximum radius. real step, rmax parameter (step=.2, rmax=6.) C**** A flag that the routine is called. integer called data called/0/ if(called.eq.0)then called=1 call nucinit(anuc) end if C**** Make sure there are hadrons to track. if (ni.lt.1) return C**** Generate a starting position. call nucstp(start,icont,imode) i1=0 nx=ni do while (i1.lt.nx) i1=i1+1 if(i1.le.ni)then ihap=-1 nel=-1 ncx=-1 end if iin=0 uo(i1)=ui(i1) uin=ui(i1)*1000. ein=ei(i1)*1000. chint=chi(i1) pinss=0 do i2=1,3 if(i1.gt.ni)start(i2)=0. xtr(i2)=stpt(i2,i1)+start(i2) pin(i2)=pi(i2,i1)*1000. pinss=pinss+pin(i2)**2 end do jpar=-1 if(abs(uin-137.).lt.5.)jpar=0 !pion if(abs(uin-549.).lt.5.)jpar=1 !eta if(abs(uin-783.).lt.5.)jpar=2 !omega if(abs(uin-939.).lt.5.)jpar=100 !nucleon if(abs(uin-495.).lt.5) jpar=3 !kaon if(jpar.lt.0)go to 99 if(jpar.eq.100.and.ein.lt.1100.)go to 99 pinm=sqrt(pinss) do i2=1,3 upin(i2)=pin(i2)/pinm end do loop=0 200 continue !****start tracking*********** r=0 do i2=1,3 xtr(i2)=xtr(i2)+upin(i2)*step r=r+xtr(i2)**2 end do r=sqrt(r) C**** Check if the hadron is still inside the nucleus. if(imode.eq.1)then if(iin.eq.0.and.r.gt.rmax)then loop=loop+1 if(loop.gt.3)go to 99 az=rmax**2-xtr(1)**2-xtr(2)**2 if(az.lt.0.)go to 99 xtr(3)=-sqrt(az)-0.18+0.05*loop go to 200 end if if(r.le.rmax)iin=1 end if if(r.gt.rmax)then if(i1.le.ni)then itrans=itrans+1 if(ihap.lt.0)inot=inot+1 if(nel.gt.0)iel=iel+1 if(ncx.gt.0)icx=icx+1 end if go to 99 end if call nucfermi(r) ides=i1*10 if(jpar.eq.100)then call nucnuc(ides) else if((jpar.eq.1).or.(jpar.eq.2))then icont=1 call nucvmes(jpar,ides) else if (jpar.eq.3) then call nuckaon(ides,step) else if (jpar.eq.0) then call nucpion(ides) else type *, 'PARTNUC: bogus particle in partnuc' stop end if if(ides.eq.1)go to 200 if(ides.lt.0)then ia=abs(ides) do l=1,ia nx=nx+1 ei(nx)=piso(4,2*l)/1000. ui(nx)=uiso(2*l)/1000. chi(nx)=chiso(2*l) do l1=1,3 pi(l1,nx)=piso(l1,2*l)/1000. stpt(l1,nx)=xtr(l1) end do end do if(jpar.eq.100.and.ein.lt.1100.)then itrans=itrans+1 if(ihap.lt.0)inot=inot+1 if(nel.gt.0)iel=iel+1 if(ncx.gt.0)icx=icx+1 go to 99 end if go to 200 end if 99 continue do i2=1,3 decp(i2)=xtr(i2) po(i2,i1)=pin(i2)/1000. end do eo(i1)=ein/1000. cho(i1)=chint uo(i1)=uin/1000. enddo ni=nx return end subroutine nucfermi(r) common /nucdis/probmi(31),probdi(31),rhotab(30),pnorm common /nucint/uin,chint,ein,pin(3),upin(3) common /nuccms/ rhon,pfermi,unucl,ecms2,up4cms(3),beta(3),prot common /nucpart/prat data prat/0.5/ logical prot dimension rec(3),p4cms(3) parameter (toten2=931.**2) parameter (rbin=.2, rmin=0., rmax=6., nbin=(rmax-rmin)/rbin) c decide if interaction is on proton (prot=.true.) or neutron (.false.) if(ranf().lt.prat)then prot=.true. else prot=.false. end if C NUCLEAR DENSITY AT THIS VALUE OF R C INCLUDE 0.1 FACTOR is TO CHANGE FROM MB TO FMSQ (cms is in fm!) call nuchis(r-rmin,rbin,30,irlo,irhi,rrem) RHON=(RHOTAB(IRHI)*RREM+RHOTAB(IRLO)*(1.0-RREM))*0.1 RHONF=RHON/PNORM C FERMI MOMENTUM AT THIS VALUE OF R PFERMI=270.0*((RHONF*10.)**0.3333) IF(PFERMI.LE.0.0) PFERMI=1.0 AREC=PFERMI*ranf()**0.3333 call ranve(arec,rec,2.,-1.) unucl=sqrt(toten2-arec**2) C ENERGY AND 3 MOMENTUM PARTS OF CMS 4 MOMENTUM E4CMS=EIN+931. DO i2=1,3 P4CMS(i2)=PIN(i2)+REC(i2) END DO P4CMSM=SQRT(P4CMS(1)**2+P4CMS(2)**2+P4CMS(3)**2) DO i2=1,3 UP4CMS(i2)=P4CMS(i2)/P4CMSM BETA(i2)= -P4CMS(i2)/E4CMS END DO C SQUARE OF CMS ENERGY ECMS2=E4CMS**2-p4cmsm**2 return end subroutine nuchis(x,rbin,num,ilo,ihi,erem) ilo=(x)/rbin+1 ihi=ilo+1 erem=(x-float(ilo-1)*rbin)/rbin if(ilo.ge.num)then ilo=num ihi=num erem=1 end if if(ilo.lt.1)then ilo=1 ihi=2 erem=0. end if return end subroutine nucinit(anuc) common /nucdis/ probmi(31),probdi(31),rhotab(30),pnorm dimension probm(30),probd(30) C DOVER ET AL DISTRIBUTION DATA PROBD/ 1 0.0,0.2,4.7,20.2,67.6,186.2,384.2,802.4,1409.0,2285.8 1 ,3264.0,3913.1,4665.6,4901.0,4170.9,4050.0,2973.6,1976.8,1296.0,985.5 1 ,704.0,370.4,232.3,177.7,80.6,35.7,20.0,10.0,5.0,2.5/ C SET UP MATTER DISTRIBUTION IN NUCLEUS C UNITS ARE IN FERMIS PROBS=0.0 RBIN=0.2 RMIN=0.0 RMAX=6.0 NBIN=(RMAX-RMIN)/RBIN call nucrodis(rmin,rbin,nbin,probm,rhotab) CALL CFD(PROBMI,NBIN,PROBM) CALL CFD(PROBDI,NBIN,PROBD) DO I1=1,NBIN PROBS=PROBS+PROBM(I1) END DO PNORM=ANUC/PROBS DO i1=1,NBIN RHOTAB(i1)=PNORM*RHOTAB(i1) END DO return end subroutine nuckin(vin,pin,am,pm,pout,pn,eout) dimension vin(3),pout(3) common/nuccms/rhon,pfermi,unucl,ecms2,up4cms(3),beta(3),prot logical prot dimension p1in(3),p2in(3),pdum(3) parameter (bm2=939.**2) do i1=1,3 p1in(i1)=pin*vin(i1) p2in(i1)=-p1in(i1) end do e1=sqrt(pin**2+am**2) e2=sqrt(pin**2+bm2) call lloren(pout,eout,p1in,e1,beta) call lloren(pdum,edum,p2in,e2,beta) pn=sqrt(eout**2-am**2) pm=sqrt(edum**2-bm2) return end subroutine nucnuc(idec) common/nucint/uin,chint,ein,pin(3),upin(3) common/nuccms/rhon,pfermi,unucl,ecms2,up4cms(3),beta(3),prot C**** isospin parameters real piso(4,4), chiso(4), uiso(4) common /nucnewprd/ piso, chiso, uiso common/nuchad/ihap,nel(2) logical prot dimension xspp(158),xspn(158),xdpp(130),xdpn(130) data xspp/ $ 13., 26., 50., 90., 126., 175., 235., 300., 380., 480., $ 585., 710., 860.,1035.,1242.,1436.,1580.,1695.,1785.,1866., $ 1937.,2000.,2050.,2090.,2128.,2160.,2188.,2208.,2228.,2240., $ 2248.,2252.,2253.,2253.,2253.,2252.,2250.,2248.,2245.,2240., $ 2238.,2234.,2230.,2225.,2220.,2215.,2210.,2205.,2200.,2195., $ 2190.,2185.,2178.,2172.,2168.,2160.,2154.,2150.,2140.,2135., $ 2128.,2120.,2112.,2102.,2096.,2089.,2079.,2070.,2061.,2054., $ 2042.,2036.,2028.,2016.,2005.,1995.,1985.,1975.,1968.,1959., $ 1949.,1939.,1928.,1919.,1908.,1898.,1888.,1878.,1868.,1858., $ 1848.,1838.,1828.,1817.,1807.,1797.,1786.,1777.,1765.,1758., $ 1748.,1737.,1728.,1716.,1705.,1696.,1685.,1675.,1665.,1655., $ 1645.,1635.,1627.,1615.,1605.,1595.,1584.,1575.,1563.,1555., $ 1542.,1532.,1520.,1512.,1500.,1492.,1480.,1470.,1460.,1450., $ 1440.,1430.,1419.,1408.,1398.,1387.,1377.,1367.,1356.,1344., $ 1335.,1324.,1315.,1305.,1295.,1285.,1275.,1265.,1257.,1245., $ 1237.,1228.,1218.,1208.,1198.,1188.,1178.,1169./ data xspn/ $ 18., 28., 48., 75., 117., 159., 208., 270., 340., 440., $ 560., 720., 910.,1060.,1170.,1260.,1325.,1375.,1390.,1396., $ 1397.,1396.,1393.,1390.,1385.,1382.,1380.,1376.,1372.,1366., $ 1360.,1357.,1352.,1346.,1341.,1338.,1332.,1325.,1320.,1316., $ 1310.,1304.,1300.,1295.,1288.,1281.,1278.,1270.,1264.,1259., $ 1254.,1245.,1240.,1235.,1230.,1223.,1218.,1212.,1203.,1199., $ 1193.,1184.,1180.,1175.,1170.,1162.,1158.,1152.,1146.,1140., $ 1136.,1130.,1122.,1120.,1112.,1108.,1100.,1096.,1090.,1082., $ 1078.,1070.,1065.,1060.,1056.,1050.,1045.,1040.,1034.,1028., $ 1021.,1018.,1010.,1005.,1000., 995., 988., 980., 977., 970., $ 962., 958., 951., 945., 940., 935., 930., 922., 918., 910., $ 904., 900., 895., 889., 882., 878., 872., 865., 860., 855., $ 850., 842., 838., 832., 826., 820., 817., 810., 804., 800., $ 797., 790., 783., 780., 774., 768., 761., 758., 752., 744., $ 740., 735., 730., 722., 720., 715., 710., 705., 698., 694., $ 690., 683., 680., 675., 670., 662., 660., 653./ data xdpp/ $ 0., 1., 2., 3., 4., 5., 6., 7., 8., 8., $ 9., 9., 11., 16., 21., 38., 60., 90., 112., 130., $ 146., 160., 177., 190., 200., 215., 228., 240., 252., 265., $ 280., 292., 305., 320., 335., 349., 361., 379., 392., 405., $ 420., 435., 450., 460., 479., 490., 504., 520., 535., 550., $ 565., 580., 595., 610., 623., 640., 655., 670., 680., 698., $ 710., 726., 740., 756., 770., 788., 800., 820., 834., 850., $ 860., 880., 893., 910., 923., 940., 957., 970., 986.,1002., $ 1020.,1035.,1050.,1066.,1080.,1098.,1112.,1128.,1141.,1160., $ 1175.,1190.,1208.,1221.,1239.,1255.,1270.,1285.,1300.,1320., $ 1338.,1355.,1370.,1388.,1400.,1420.,1436.,1450.,1466.,1480., $ 1496.,1510.,1525.,1540.,1558.,1573.,1588.,1600.,1620.,1637., $ 1652.,1670.,1682.,1700.,1718.,1731.,1748.,1762.,1780.,1798./ data xdpn/ $ 0., 40., 80., 128., 170., 230., 300., 370., 450., 520., $ 560., 600., 630., 660., 690., 715., 740., 760., 785., 805., $ 828., 850., 870., 888., 908., 928., 943., 962., 980., 998., $ 1017.,1030.,1045.,1063.,1080.,1095.,1110.,1125.,1140.,1156., $ 1170.,1185.,1200.,1215.,1230.,1240.,1254.,1266.,1280.,1293., $ 1305.,1320.,1333.,1345.,1360.,1373.,1382.,1397.,1410.,1420., $ 1437.,1448.,1460.,1473.,1488.,1498.,1510.,1521.,1537.,1548., $ 1560.,1572.,1582.,1598.,1610.,1620.,1635.,1645.,1658.,1670., $ 1680.,1696.,1708.,1720.,1732.,1743.,1757.,1770.,1780.,1797., $ 1808.,1820.,1834.,1844.,1860.,1870.,1880.,1898.,1910.,1920., $ 1938.,1950.,1960.,1978.,1990.,2002.,2020.,2032.,2048.,2060., $ 2077.,2090.,2104.,2120.,2130.,2150.,2162.,2180.,2195.,2210., $ 2225.,2240.,2257.,2270.,2286.,2300.,2315.,2330.,2342.,2360./ parameter (step=0.2, fac=1e-2, amn=939., amn2=amn**2) idec=1 if(ecms2.lt.4070710.)go to 200 if(ecms2.le.(amn+unucl)**2)go to 200 pcmsm=sqrt((ecms2-(amn-unucl)**2)*(ecms2-(amn+unucl)**2)/(4*ecms2)) eineq=(ecms2-unucl**2-amn**2)/(2*unucl) emin=amn+360. if(eineq.lt.emin)go to 200 call nuchis(eineq-emin,20.,158,ilo,ihi,erem) call nuchis(eineq-amn-920.,20.,130,ilo1,ihi1,erem1) if(prot)then ka=1 else ka=0 end if ichint=chint if(ka-ichint.eq.0)then psp=xspp(ihi)*erem+xspp(ilo)*(1-erem) pdp=xdpp(ihi1)*erem1+xdpp(ilo1)*(1-erem1) else psp=xspn(ihi)*erem+xspn(ilo)*(1-erem) pdp=xdpn(ihi1)*erem1+xdpn(ilo1)*(1-erem1) end if if(ecms2.lt.4653520.)pdp=0. psp=psp*fac pdp=pdp*fac ptot=psp+pdp if(ptot.eq.0)go to 200 xr=ranf()+1.e-6 yr=ranf()*ptot ptot=ptot*rhon dist=-log(xr)/ptot if(step.lt.dist)go to 200 if(yr.lt.psp)then iqq=1 !single production else iqq=2 !double production end if call nucprd(iqq,eineq,ka,piso,chiso,uiso) p1=sqrt(piso(1,1)**2+piso(2,1)**2+piso(3,1)**2) if(p1.lt.pfermi)go to 200 p2=sqrt(piso(1,3)**2+piso(2,3)**2+piso(3,3)**2) if(p2.lt.pfermi)go to 200 idec=-iqq ihap=1 nel(iqq)=1 if(p1.gt.p2)then iqq=1 pp=p1 else iqq=3 pp=p2 end if ein=piso(4,iqq) chint=chiso(iqq) do i1=1,3 pin(i1)=piso(i1,iqq) upin(i1)=pin(i1)/pp end do 200 return end subroutine nucpion(ides) common /nucint/uin,chint,ein,pin(3),upin(3) common /nuccms/ rhon,pfermi,unucl,ecms2,up4cms(3),beta(3),prot C**** isospin parameters real piso(4,4), chiso(4), uiso(4) common /nucnewprd/ piso, chiso, uiso common /nuchad/ ihap,nel,ncx integer inot, itrans, idec, inel, iel, iabs, icx common /hadron/inot,itrans,idec,inel,iel,iabs,icx dimension xabs(21),xpeln(126),xpelp(126),xpelm(126),xpchx(126), $ xspp(117),xspn(117),xspm(117), $ dang(5,21,4) dimension angld(18),angldi(19),aa(5),b1(51),b2(51),b3(51) dimension pout1l(3),upoutc(3) logical prot,notuj dimension phs31(21),php31(21),php33(21) dimension phs11(21),php11(21),php13(21) dimension pep11(21),phd13(21),phd15(21) dimension gm1(4),gm3(4) data gm1/0.,0.66667,-0.4714,0.33333/ data gm3/1.,0.33333, 0.4714,0.66667/ dimension angdata(51,428) data phs11/ $ 0., 4.93, 6.51, 7.46, 8.08, 8.50, 8.79, 9.00, 9.17, 9.33, $ 9.49, 9.69, 9.93,10.23,10.61,11.06,11.62,12.28,13.05,13.93, $ 14.94/ data php11/ $ 0.00,-0.68,-1.49,-2.06,-2.29,-2.18,-1.78,-1.13,-0.26, 0.82, $ 2.12, 3.71, 5.67, 8.18,11.41,15.58,20.87,23.92,28.09,32.26, $ 36.43/ data php13/ $ 0., -0.15,-0.40,-0.68,-0.97,-1.26,-1.53,-1.79,-2.04,-2.28, $ -2.52,-2.78,-3.05,-3.34,-3.69,-4.08,-4.55,-5.10,-5.76,-6.54, $ -7.46/ data phs31/ $ 0.00,-2.85, -4.28, -5.80, -7.30,- 8.80,-10.23,-11.71,-13.16, $ -14.57,-15.93,-17.22,-18.44,-19.56,-20.59,-21.51,-22.30,-23.02, $ -23.61,-24.09,-24.46/ data php31/ $ 0.00,-0.22,-0.60,-1.07,-1.60,-2.17,-2.77,-3.39,-4.01,-4.63, $ -5.24,-5.84,-6.41,-6.96,-7.48,-7.96,-8.41,-9.16,-9.71,-10.25, $ -10.80/ data php33/ $ 0.00, 1.29, 3.95, 7.95, 13.62, 21.56, 32.53, 47.17, $ 66.10, 81.98, 97.51,109.47,118.42,125.19,130.44,134.63, $ 138.07,140.97,143.45,145.62,147.54/ data pep11/ $ 1. ,1. ,1. ,1. ,1. ,1. ,1. ,1. ,1. ,1. , $ 1. ,0.996,0.986,0.970,0.947,0.908,0.861,0.810,0.762,0.710, $ 0.660/ data phd13/ $ 0. , 0.00, 0.01, 0.04, 0.08, 0.15, 0.25, 0.38, 0.56, 0.78, $ 1.05, 1.38, 1.77, 2.24, 2.78, 3.41, 4.13, 4.94, 5.86, 6.89, $ 8.04/ data phd15/ $ 0. , 0.00, 0.02, 0.06, 0.12, 0.20, 0.30, 0.42, 0.57, 0.73, $ 0.91, 1.10, 1.31, 1.52, 1.73, 1.95, 2.16, 2.36, 2.54, 2.71, $ 2.85/ C PARTIAL AND TOTAL CROSS SECTIONS (*100 mb) c pi0-p elastic data xpeln/ $ 0., 90., 258., 745.,1575.,2760.,4240.,6190.,7900.,8930., $ 7430.,6480.,5540.,4633.,3725.,2985.,2490.,2160.,1908.,1743., $ 1565.,1465.,1380.,1300.,1260.,1228.,1200.,1200.,1205.,1235., $ 1238.,1140.,1050., 980., 925., 930., 930., 950., 980.,1000., $ 1040.,1095.,1170.,1280.,1413.,1568.,1580.,1545.,1513.,1495., $ 1445.,1410.,1380.,1350.,1320.,1285.,1280.,1270.,1270.,1280., $ 1295.,1320.,1340.,1370.,1390.,1405.,1393.,1360.,1340.,1310., $ 1280.,1250.,1220.,1190.,1180.,1163.,1150.,1150.,1150.,1140., $ 1125.,1125.,1120.,1120.,1110.,1110.,1100.,1090.,1080.,1050., $ 1018., 990., 980., 950., 930., 883., 880., 870., 860., 840., $ 835., 820., 810., 800., 790., 800., 780., 775., 770., 765., $ 765., 750., 740., 740., 740., 738., 735., 730., 725., 725., $ 725., 715., 710., 710., 710., 710./ c pi-p charge exchange data xpchx/ $ 390., 480., 620., 875.,1240.,1675.,2200.,3100.,4350.,4460., $ 4000.,3400.,2950.,2625.,2300.,2000.,1650.,1485.,1375.,1300., $ 1215.,1150.,1080.,1030., 975., 920., 870., 815., 765., 718., $ 675., 630., 595., 555., 515., 490., 470., 451., 450., 468., $ 500., 550., 625., 680., 675., 575., 500., 430., 375., 345., $ 300., 285., 265., 250., 240., 225., 210., 200., 195., 185., $ 178., 175., 170., 165., 160., 155., 152., 150., 149., 148., $ 145., 140., 135., 130., 125., 120., 118., 115., 110., 107., $ 104., 100., 99., 98., 95., 90., 85., 80., 78., 77., $ 75., 73., 72., 69., 67., 65., 63., 61., 58., 55., $ 52., 51., 50., 50., 50., 50., 50., 49., 48., 47., $ 46., 44., 42., 39., 37., 35., 34., 33., 32., 31., $ 29., 27., 25., 24., 24., 23./ c pi-p elastic data xpelm/ $ 125., 150., 175., 245., 380., 600., 970.,1500.,2140.,2310., $ 2295.,2070.,1795.,1550.,1360.,1230.,1130.,1070.,1050.,1070., $ 1120.,1175.,1235.,1300.,1400.,1500.,1600.,1700.,1835.,1970., $ 2050.,1915.,1770.,1650.,1570.,1520.,1510.,1525.,1550.,1600., $ 1685.,1800.,2000.,2230.,2475.,2635.,2510.,2300.,2140.,2000., $ 1870.,1750.,1670.,1585.,1505.,1440.,1395.,1340.,1299.,1260., $ 1215.,1175.,1140.,1099.,1060.,1040.,1010., 999., 990., 975., $ 960., 955., 945., 935., 925., 925., 935., 965., 985.,1000., $ 1015.,1030.,1060.,1080.,1095.,1100.,1095.,1090.,1070.,1035., $ 1000., 960., 905., 855., 820., 800., 785., 780., 775., 770., $ 765., 760., 759., 757., 756., 755., 750., 745., 740., 735., $ 730., 728., 725., 725., 724., 723., 722., 722., 722., 721., $ 720., 715., 710., 710., 710., 710./ c pi+p elastic data xpelp/ $ 180., 400., 990.,2170.,4000.,6580.,9680.,13920.,18000.,20000., $ 16550.,14200.,12250.,10320.,8400.,6725.,5510.,4725.,4130.,3690., $ 3230.,2885.,2600.,2300.,2090.,1875.,1675.,1500.,1340.,1200., $ 1100., 998., 920., 860., 820., 810., 810., 825., 850., 875., $ 900., 940., 975.,1000.,1030.,1075.,1130.,1200.,1275.,1330., $ 1350.,1335.,1330.,1330.,1345.,1355.,1380.,1400.,1460.,1500., $ 1555.,1625.,1700.,1800.,1875.,1920.,1925.,1890.,1830.,1790., $ 1725.,1690.,1640.,1600.,1550.,1505.,1475.,1430.,1400.,1365., $ 1335.,1300.,1280.,1250.,1225.,1205.,1195.,1175.,1150.,1135., $ 1105.,1095.,1080.,1060.,1030.,1020.,1005., 990., 980., 970., $ 960., 940., 930., 920., 900., 898., 890., 880., 870., 860., $ 840., 830., 820., 810., 800., 795., 785., 780., 775., 765., $ 760., 755., 750., 745., 740., 735./ c pi+p single pi production data xspp/ $ 0., 0., 1., 3., 5., 9., 13., 21., 30., 41., $ 55., 75., 98., 122., 153., 183., 218., 255., 293., 335., $ 383., 445., 530., 650., 780., 880., 990.,1082.,1170.,1251., $ 1321.,1380.,1425.,1460.,1490.,1512.,1520.,1500.,1445.,1395., $ 1330.,1330.,1388.,1450.,1521.,1595.,1690.,1755.,1842.,1930., $ 2012.,2090.,2145.,2180.,2180.,2160.,2155.,2170.,2195.,2220., $ 2222.,2220.,2205.,2178.,2140.,2090.,2030.,1990.,1955.,1925., $ 1900.,1890.,1862.,1850.,1838.,1830.,1820.,1822.,1823.,1828., $ 1833.,1840.,1850.,1859.,1870.,1883.,1900.,1910.,1928.,1943., $ 1960.,1980.,2000.,2018.,2038.,2058.,2080.,2098.,2119.,2139., $ 2158.,2180.,2198.,2215.,2235.,2252.,2270.,2278.,2286.,2295., $ 2300.,2305.,2313.,2319.,2321.,2325.,2330./ c pi0p single pi production data xspn/ $ 0., 0., 1., 8., 23., 42., 69., 100., 135., 175., $ 221., 270., 320., 372., 430., 492., 560., 640., 755.,1085., $ 1210.,1252.,1350.,1405.,1395.,1365.,1330.,1365.,1455.,1610., $ 1755.,1928.,2105.,2240.,2260.,2219.,2170.,2115.,2045.,1965., $ 1879.,1825.,1775.,1750.,1752.,1790.,1835.,1885.,1938.,1995., $ 2055.,2125.,2172.,2210.,2230.,2235.,2248.,2265.,2288.,2302., $ 2310.,2317.,2312.,2300.,2280.,2259.,2230.,2199.,2170.,2145., $ 2121.,2100.,2081.,2067.,2055.,2045.,2041.,2041.,2048.,2062., $ 2085.,2110.,2140.,2170.,2200.,2225.,2240.,2252.,2265.,2278., $ 2290.,2305.,2319.,2332.,2348.,2360.,2372.,2388.,2400.,2412., $ 2425.,2438.,2448.,2458.,2468.,2475.,2485.,2488.,2490.,2489., $ 2488.,2485.,2482.,2479.,2475.,2470.,2465./ c pi-p single pi production data xspm/ $ 0., 5., 10., 20., 39., 68., 110., 160., 230., 305., $ 382., 470., 548., 630., 712., 805., 905.,1021.,1230.,1820., $ 2035.,2060.,2170.,2160.,2040.,1840.,1670.,1635.,1740.,1965., $ 2200.,2435.,2740.,3020.,3030.,2920.,2815.,2730.,2639.,2530., $ 2420.,2315.,2190.,2060.,1992.,1979.,1985.,2008.,2045.,2085., $ 2128.,2160.,2205.,2241.,2275.,2308.,2340.,2358.,2378.,2392., $ 2400.,2410.,2420.,2422.,2425.,2425.,2425.,2410.,2380.,2358., $ 2335.,2310.,2295.,2282.,2272.,2265.,2260.,2265.,2279.,2302., $ 2335.,2375.,2425.,2471.,2512.,2545.,2580.,2590.,2602.,2612., $ 2622.,2630.,2643.,2650.,2659.,2665.,2670.,2679.,2685.,2692., $ 2698.,2700.,2703.,2705.,2702.,2701.,2700.,2692.,2688.,2679., $ 2671.,2660.,2651.,2640.,2628.,2613.,2600./ C PI DEUTERON ABSORPTION (in mb (without factor 100)) DATA XABS/ $ 2., 3., 5.,12.,18.,27.,37.,50.,60.,45., $ 30.,20., 10.,5.,3.,2.,2.,1.,1.,1.,0./ integer called data called/0/ parameter (upi=139.6, amn=939., amn2=amn**2, step=0.2 ) parameter (rhod=9./(2.*3.141*9.5**3) ,fac=1e-2) parameter (nangl =18) if(called.eq.0)then called=1 do i1=1,126 xpeln(i1)=xpeln(i1)*fac xpelp(i1)=xpelp(i1)*fac xpelm(i1)=xpelm(i1)*fac xpchx(i1)=xpchx(i1)*fac if(i1.le.117)then xspp(i1)=xspp(i1)*fac xspn(i1)=xspn(i1)*fac xspm(i1)=xspm(i1)*fac end if end do do i1=1,20 tl=i1*20. el=tl+upi pl=sqrt(el**2-upi**2) pc=pl/sqrt(1.+2*el/amn+(upi/amn)**2)/197.329 pk=pc**2 call nuchis(tl,20.,21,ilo,ihi,erem) s11=phs11(ihi)*erem+phs11(ilo)*(1.-erem) s31=phs31(ihi)*erem+phs31(ilo)*(1.-erem) p11=php11(ihi)*erem+php11(ilo)*(1.-erem) p13=php13(ihi)*erem+php13(ilo)*(1.-erem) p31=php31(ihi)*erem+php31(ilo)*(1.-erem) p33=php33(ihi)*erem+php33(ilo)*(1.-erem) ep11=pep11(ihi)*erem+pep11(ilo)*(1.-erem) d13=phd13(ihi)*erem+phd13(ilo)*(1.-erem) d15=phd15(ihi)*erem+phd15(ilo)*(1.-erem) w01= (sind(s31)**2+sind(p31-p33)**2) !*g3**2 w02= (sind(s11)**2-sind(s31-s11)**2-3/2.*sind(s31)**2 $ -ep11*(sind(p31-p11)**2-sind(p33-p11)**2) $ +sind(p31-p13)**2-sind(p33-p13)**2 $ +sind(s31-d13)**2+3/2.*sind(s31-d15)**2 $ -sind(d13)**2-3/2.*sind(d15)**2) !*g1*g3 w03=(-3/2.*sind(s11)**2+ep11*sind(p11-p13)**2+(ep11-1)**2/4. $ +sind(s11-d13)**2+3/2.*sind(s11-d15)**2 $ -3/2.*sind(d13-d15)**2+3/2.*sind(d13)**2 $ +9/4.*sind(d15)**2) !*g1**2 w11=2*( sind(s31)*sind(p31)*cosd(s31-p31) $ +2*sind(s31)*sind(p33)*cosd(s31-p33)) !*g3**2 w12=(ep11*(sind(p11)**2-sind(s31-p11)**2) $ +sind(p31)**2-sind(s11-p31)**2 $ +2*(sind(p33)**2+sind(p13)**2-sind(s31-p13)**2 $ -sind(s11-p33)**2) $ +3*(sind(s11)**2+sind(s31)**2)) $ +(-2*sind(p31-d13)**2+9/2.*sind(p31-d15)**2-5/2.*sind(p31)**2 $ +5*sind(p33-d13)**2-5*sind(p33)**2-3*sind(d13)**2 $ -9/2.*sind(d15)**2) !*g1*g3 w13=(ep11*(sind(p11)**2-sind(s11-p11)**2) $ +2*(sind(p13)**2-sind(s11-p13)**2)+3*sind(s11)**2 $ +ep11*(-2*sind(p11-d13)**2+9/2.*sind(p11-d15)**2 $ -5/2.*sind(p11)**2) $ +5*sind(p13-d13)**2-5*sind(p13)**2-3*sind(d13)**2 $ -9/2.*sind(d15)**2) !*g1**2 w21=3*(sind(p33)**2+2*sind(p31)*sind(p33)*cosd(p31-p33)) !*g3**2 w22= +3*(ep11*(sind(p11)**2-sind(p33-p11)**2) $ + 2*(sind(p13)**2+sind(p33)**2)+sind(p31)**2 $ - (sind(p33-p13)**2+sind(p31-p13)**2) $ -sind(s31-d13)**2-3/2.*sind(s31-d15)**2+5/2.*sind(s31)**2 $ +sind(d13)**2+3/2.*sind(d15)**2) !*g1*g3 w23= + 3*(2*sind(p13)**2+ep11*(sind(p11)**2-sind(p11-p13)**2) $ -sind(s11-d13)**2-3/2.*sind(s11-d15)**2+5/2.*sind(s11)**2 $ +6*sind(d13-d15)**2-4*sind(d13)**2-6*sind(d15)**2) !*g1**2 w32=(-15/2.*sind(p31-d15)**2+15/2.*sind(p31)**2-9*sind(p33-d13)**2 $ -6*sind(p33-d15)**2+15*sind(p33)**2+9*sind(d13)**2 $ +27/2.*sind(d15)**2) !*g1*g3 w33= +(15/2.*ep11*(-sind(p11-d15)**2+sind(p11)**2) $ -9*sind(p13-d13)**2-6*sind(p13-d15)**2+15*sind(p13)**2 $ +9*sind(d13)**2+27/2.*sind(d15)**2) !*g1**2 w43= 45/2.*(sind(d13)**2-sind(d13-d15)**2)+135/4.*sind(d15)**2 !*g1**2 do i2=1,4 g1=gm1(i2) g3=gm3(i2) i3=i1+1 dang(1,i3,i2)=(w01*g3**2+w02*g1*g3+w03*g1**2)/pk dang(2,i3,i2)=(w11*g3**2+w12*g1*g3+w13*g1**2)/pk dang(3,i3,i2)=(w21*g3**2+w22*g1*g3+w23*g1**2)/pk dang(4,i3,i2)=( w32*g1*g3+w33*g1**2)/pk dang(5,i3,i2)=( w43*g1**2)/pk end do end do open(33,status='old',form='unformatted',access='direct', $ organization='relative',recl=51,readonly,shared, $ file='sys$usrdevice:[gajewski.dat]nucang.dat') do i1=1,428 read(33,rec=i1)(angdata(i2,i1),i2=1,51) end do close(33) end if if(ides.eq.10)then notuj=.true. else notuj=.false. end if ides=1 C MAGNITUDE OF CMS MOMENTUM IF(ECMS2.LE.(UPI+UNUCL)**2) GO TO 200 PCMSM=SQRT((ECMS2-(UPI-UNUCL)**2)*(ECMS2-(UPI+UNUCL)**2)/(4.0*ECMS2)) C EQUIVALENT PION ENERGY FOR STATIONARY TARGET EINEQ=(ECMS2-UNUCL**2-UPI**2)/(2.0*UNUCL) IF(EINEQ.LT.UPI) GO TO 200 t=eineq-upi C ABSORPTION CROSS SECTION WEIGHTED BY RATIO OF LOCAL C NUCLEON DENSITY TO DEUTERON DENSITY.AT THIS STAGE RHON C CONTAINS 0.1 FACTOR FOR UNITS.THE RHOD FACTOR ADJUSTMENT C THROUGH PUTTING THE "DEUTERON RADIUS" AT 9.5 TAKES THIS INTO C ACCOUNT.PUTTING IN THE 0.1 FACTOR INTO RHOD IMPLIES THAT 9.5 C CORRESPONDS TO A SO CALLED "QUASI DEUTERON" RADIUS OF 4.4 FM. call nuchis(t,20.,21,ilo,ihi,erem) PPABS=XABS(ihi)*erem+xabs(ilo)*(1.-erem) call nuchis(t,20.,126,ilo,ihi,erem) call nuchis(t-180.,20.,117,ilo1,ihi1,erem1) ichint=chint if(ichint)1,2,3 1 continue !pi- if(prot)then ppel =(xpelm(ihi)*erem+xpelm(ilo)*(1-erem)) ppchx=(xpchx(ihi)*erem+xpchx(ilo)*(1-erem)) psp =(xspm(ihi1)*erem1+xspm(ilo1)*(1-erem1)) ka=2 else ppel =(xpelp(ihi)*erem+xpelp(ilo)*(1-erem)) psp =(xspp(ihi1)*erem1+xspp(ilo1)*(1-erem1)) ppchx=0. ka=1 end if go to 4 2 continue !pi0 ppel =(xpeln(ihi)*erem+xpeln(ilo)*(1-erem)) ppchx=(xpchx(ihi)*erem+xpchx(ilo)*(1-erem)) psp =(xspn(ihi1)*erem1+xspn(ilo1)*(1-erem1)) ppabs=0.7*ppabs ka=4 go to 4 3 continue !pi+ if(prot)then ppel =(xpelp(ihi)*erem+xpelp(ilo)*(1-erem)) ppchx=0. psp =(xspp(ihi1)*erem1+xspp(ilo1)*(1-erem1)) ka=1 else ppel =(xpelm(ihi)*erem+xpelm(ilo)*(1-erem)) ppchx=(xpchx(ihi)*erem+xpchx(ilo)*(1-erem)) psp =(xspm(ihi1)*erem1+xspm(ilo1)*(1-erem1)) ka=2 end if 4 continue if(ecms2.lt.1488400.)psp=0. PTOT=PPEL+PPCHX+PPABS+psp C********CHOOSE INTERACTION DISTANCE XR=ranf()+1.e-6 YR=ranf()*PTOT C********HERE WE NEED TO NORMALIZE PTOT=PTOT*RHON if(ptot.eq.0.)go to 200 DIST=-LOG(XR)/ptot C********IF NOTHING HAPPENS IF(STEP.LT.DIST) GO TO 200 C********IS IT ABSORBED BY DI NUCLEON? PSUM=PPABS IF(YR.Le.PSUM) THEN if(notuj)IABS=IABS+1 Uin=1.e-2 CHINT=0.0 ihap=1 ides=0 go to 200 END IF c*********does pion produce an additional pion ? psum=psum+psp if(yr.lt.psum)go to 300 C********* DOES PION SCATTER OFF FERMI NUCLEON? PSUM=PSUM+PPEL IF(YR.LT.PSUM) THEN IPATH=0 else C********* PION CHARGE EXCHANGE ON FERMI NUCLEON IPATH=1 ka=3 END IF C********* COME HERE FOR PI-P KINEMATICS WITH FERMI MOTION 104 CONTINUE if(t.le.400.)then do k=1,5 aa(k)=dang(k,ihi,ka)*erem+dang(k,ilo,ka)*(1-erem) end do DO K=1,18 angb=(k-1)*10.+5. cab=cosd(angb) ang=0 do k1=5,2,-1 ang=(ang+aa(k1))*cab end do ANGLD(K)=SINd(ANGB)*(aa(1)+ang) END DO CALL CFD(ANGLDI,NANGL,ANGLD) C DO SCATTERING IN CMS xXR=ranf() ANG=PRBIN(ANGLDI,NANGL,0.,10.,xXR) CANGL=COSd(ANG) else call nuchis(t-400.,20.,107,ilo2,ihi2,erem2) krec1=(ka-1)*107+ilo2 krec2=krec1-ilo2+ihi2 if(krec1.ne.krecsav)then krecsav=krec1 do k=1,51 b1(k)=angdata(k,krec1) b2(k)=angdata(k,krec2) end do c read(33,rec=krec1)b1 c read(33,rec=krec2)b2 do k=1,51 b3(k)=b1(k)*erem2+b2(k)*(1-erem2) end do end if xxr=ranf() call nuchis(xxr,0.02,51,ill,ihh,errm) cangl=b3(ill)*errm+b3(ihh)*(1-errm) end if PHI=-1 CALL CONE(UP4CMS,UPOUTC,CANGL,PHI) call nuckin(upoutc,pcmsm,upi,pout2lm,pout1l,pout1lm,eout1l) IF(POUT2LM.LT.PFERMI) GO TO 200 DO i2=1,3 PIN(i2)=POUT1L(i2) UPIN(i2)=PIN(i2)/POUT1LM END DO EIN=EOUT1L IF(IPATH.ne.0)THEN if(chint.eq.0.)then IF(ranf().LT.0.5) THEN CHINT=1.0 ELSE CHINT=-1.0 END IF else CHINT=0.0 end if ncx=1 else nel=1 END IF ihap=1 200 return 300 continue !pion production call nucpiprd(eineq,ka,piso,chiso,uiso) pout2lm=sqrt(piso(4,1)**2-amn2) IF(POUT2LM.LT.PFERMI) GO TO 200 pout1lm=sqrt(piso(1,3)**2+piso(2,3)**2+piso(3,3)**2) DO i2=1,3 PIN(i2)=piso(i2,3) UPIN(i2)=PIN(i2)/POUT1LM END DO EIN=piso(4,3) chint=chiso(3) ides=-1 ihap=1 if(notuj)inel=inel+1 go to 200 end subroutine nucpiprd(e,ka,piso,chiso,uiso) dimension piso(4,3),chiso(3),uiso(3) c c ka= 1 pi+ p, pi- n ??? I FUCKED THIS DOCUMENTATION UP - CDM c 2 pi+ n, pi- p c 3 pi0 p, pi0 n c common /nuccms/rhon,pfermi,unucl,ecms2,up4cms(3),beta(3),prot logical prot dimension fripn(117),fmxsp(117),pnmi(101) dimension pcfsl1(117),pcfsl2(117),pnfsl1(117),pnfsl2(117) dimension dldir(3),pdl(4),pdldec(4,3),rc(5) parameter (upi=139.6, amnucl=939.,upo=134.9) data fripn/ $ 3., 14., 39., 90., 181., 326., 540., 838.,1236.,1726., $ 2259.,2732.,3135.,3484.,3784.,4036.,4242.,4410.,4549.,4669., $ 4775.,4869.,4952.,5025.,5092.,5152.,5207.,5258.,5305.,5348., $ 5388.,5426.,5461.,5496.,5530.,5564.,5599.,5636.,5674.,5714., $ 5755.,5798.,5843.,5889.,5937.,5986.,6036.,6088.,6140.,6193., $ 6246.,6299.,6353.,6406.,6459.,6513.,6566.,6621.,6676.,6733., $ 6791.,6851.,6912.,6975.,7040.,7107.,7175.,7246.,7319.,7393., $ 7467.,7542.,7617.,7691.,7765.,7838.,7909.,7979.,8048.,8114., $ 8179.,8242.,8304.,8365.,8424.,8482.,8538.,8594.,8648.,8702., $ 8754.,8806.,8857.,8907.,8957.,9007.,9057.,9106.,9154.,9202., $ 9250.,9298.,9346.,9393.,9440.,9487.,9534.,9581.,9628.,9674., $ 9721.,9767.,9814.,9860.,9907.,9954.,10000./ data fmxsp/ $ 53., 106., 150., 192., 233., 275., 318., 360., 403., 447., $ 491., 536., 581., 627., 672., 718., 765., 811., 858., 905., $ 953.,1000.,1048.,1096.,1144.,1192.,1240.,1288.,1336.,1385., $ 1433.,1482.,1530.,1579.,1628.,1677.,1725.,1774.,1823.,1872., $ 1921.,1970.,2019.,2068.,2116.,2165.,2214.,2263.,2312.,2361., $ 2410.,2459.,2508.,2557.,2606.,2655.,2704.,2753.,2802.,2850., $ 2899.,2948.,2997.,3046.,3095.,3144.,3192.,3241.,3290.,3339., $ 3387.,3436.,3485.,3534.,3582.,3631.,3680.,3728.,3777.,3826., $ 3874.,3923.,3971.,4020.,4069.,4117.,4166.,4214.,4263.,4311., $ 4360.,4408.,4457.,4505.,4553.,4602.,4650.,4699.,4747.,4795., $ 4844.,4892.,4940.,4989.,5037.,5085.,5134.,5182.,5230.,5278., $ 5327.,5375.,5423.,5471.,5519.,5568.,5616./ data pnmi/ $ 1078.6,1134.,1149.,1159.,1166.,1173.,1178.,1183.,1188.,1192., $ 1195.,1199.,1203.,1206.,1208.,1211.,1214.,1217.,1220.,1222., $ 1225.,1227.,1230.,1233.,1236.,1238.,1241.,1244.,1247.,1251., $ 1254.,1257.,1261.,1265.,1269.,1273.,1277.,1282.,1286.,1291., $ 1297.,1303.,1309.,1316.,1324.,1333.,1342.,1353.,1366.,1380., $ 1395.,1413.,1434.,1458.,1486.,1519.,1551.,1580.,1606.,1629., $ 1651.,1671.,1691.,1710.,1729.,1748.,1766.,1784.,1801.,1817., $ 1832.,1846.,1860.,1873.,1886.,1898.,1910.,1923.,1935.,1948., $ 1960.,1974.,1987.,2002.,2016.,2031.,2047.,2062.,2079.,2095., $ 2112.,2129.,2146.,2163.,2180.,2197.,2215.,2232.,2249.,2265., $ 2282./ data pcfsl1/ $ 9000.,1800., 56.,1430.,4860.,6480.,7079.,7263.,7425.,7455., $ 7268.,7104.,6772.,6363.,5685.,4962.,4709.,3776.,3904.,5056., $ 5131.,4892.,4933.,4781.,4417.,3887.,3309.,3140.,3507.,4142., $ 4671.,5104.,5554.,5893.,5927.,5828.,5730.,5651.,5544.,5406., $ 5261.,5106.,4964.,4748.,4665.,4662.,4768.,4886.,5009.,5149., $ 5263.,5406.,5518.,5630.,5714.,5779.,5860.,5911.,5981.,6023., $ 6070.,6124.,6155.,6191.,6204.,6238.,6236.,6245.,6232.,6208., $ 6210.,6203.,6199.,6211.,6218.,6241.,6258.,6297.,6329.,6263., $ 6453.,6524.,6606.,6691.,6744.,6797.,6854.,6897.,6942.,6972., $ 7001.,7043.,7068.,7106.,7135.,7158.,7192.,7247.,7300.,7300., $ 7335.,7358.,7389.,7420.,7444.,7481.,7505.,7522.,7547.,7565., $ 7595.,7612.,7627.,7650.,7665.,7687.,7759./ data pcfsl2/ $ 11000.,6200.,4926.,5820.,8100.,9190.,9605.,9721.,9825.,9838., $ 9703.,9576.,9333.,9045.,8574.,8079.,7898.,7268.,7367.,8186., $ 8232.,8045.,8044.,7886.,7560.,7113.,6613.,6431.,6665.,7124., $ 7514.,7836.,8183.,8445.,8459.,8367.,8280.,8217.,8148.,8053., $ 7958.,7830.,7678.,7461.,7346.,7298.,7327.,7386.,7439.,7506., $ 7561.,7636.,7706.,7780.,7851.,7917.,7986.,8020.,8064.,8083., $ 8117.,8162.,8190.,8226.,8251.,8297.,8320.,8337.,8334.,8322., $ 8326.,8317.,8321.,8329.,8335.,8352.,8366.,8394.,8420.,8382., $ 8519.,8575.,8643.,8711.,8753.,8793.,8832.,8863.,8890.,8907., $ 8921.,8942.,8953.,8973.,8986.,8995.,9013.,9039.,9055.,9070., $ 9089.,9098.,9112.,9127.,9135.,9153.,9162.,9168.,9180.,9186., $ 9201.,9208.,9211.,9220.,9225.,9234.,9276./ data pnfsl1/ $ 7000., 0., 0., 0.,2146.,4013.,4700.,4934.,5134.,5181., $ 4979.,4820.,4484.,4062.,3366.,2619.,2392.,1426.,1499.,2559., $ 2658.,2496.,2642.,2676.,2588.,2389.,2236.,2300.,2621.,3042., $ 3394.,3685.,3978.,4207.,4253.,4214.,4169.,4118.,4022.,3911., $ 3783.,3702.,3702.,3672.,3724.,3804.,3953.,4069.,4200.,4335., $ 4442.,4564.,4647.,4723.,4763.,4782.,4821.,4855.,4907.,4945., $ 4976.,5004.,5018.,5029.,5022.,5022.,4994.,4989.,4972.,4950., $ 4950.,4949.,4939.,4947.,4951.,4966.,4975.,5002.,5021.,4964., $ 5096.,5140.,5188.,5241.,5274.,5310.,5352.,5385.,5421.,5447., $ 5474.,5511.,5533.,5569.,5595.,5617.,5647.,5696.,5749.,5738., $ 5768.,5789.,5816.,5842.,5865.,5896.,5917.,5933.,5953.,5970., $ 5994.,6008.,6023.,6043.,6055.,6074.,6127./ data pnfsl2/ $ 13000., 0., 0., 0.,4996.,7858.,8937.,9253.,9533.,9571., $ 9221.,8905.,8307.,7607.,6483.,5310.,4920.,3441.,3606.,5405., $ 5537.,5177.,5284.,5125.,4714.,4141.,3621.,3559.,4019.,4729., $ 5340.,5857.,6414.,6855.,6902.,6773.,6650.,6549.,6411.,6235., $ 6046.,5864.,5730.,5530.,5487.,5521.,5669.,5810.,5957.,6117., $ 6243.,6396.,6512.,6625.,6708.,6772.,6855.,6907.,6980.,7023., $ 7073.,7130.,7162.,7201.,7217.,7256.,7257.,7268.,7254.,7229., $ 7232.,7223.,7220.,7232.,7241.,7267.,7285.,7329.,7366.,7293., $ 7508.,7591.,7689.,7790.,7854.,7917.,7983.,8034.,8084.,8117., $ 8147.,8190.,8210.,8253.,8282.,8303.,8338.,8392.,8436.,8447., $ 8482.,8502.,8532.,8560.,8581.,8615.,8635.,8649.,8671.,8686., $ 8713.,8727.,8737.,8756.,8767.,8785.,8855./ t=e-upi w=sqrt(ecms2) call nuchis(t-180.,20.,117,ilo,ihi,erem) r1 =(fripn(ihi)*erem+fripn(ilo)*(1-erem))*1e-4 phsm=(fmxsp(ihi)*erem+fmxsp(ilo)*(1-erem))*100. 1 r=r1*ranf() call nuchis(r*100.,1.,101,ilo1,ihi1,erem1) amd=pnmi(ihi1)*erem1+pnmi(ilo1)*(1-erem1) ed=(amd**2+ecms2-upi**2)/(2*w) pd2=ed**2-amd**2 if(pd2.lt.0.)go to 1 pdlt=sqrt(pd2) phs=(w-ed)*ed*pdlt/w if(ranf().gt.phs/phsm)go to 1 if(ka.eq.1)then !pi+p,pi-n if(ranf().gt.0.75)then !backward 25% cdl=-0.9999995 else !isotropic 75% cdl=2*ranf()-1 end if else !pi+n,pi-p,pi0p,pi0n if(ranf().gt.0.80)then cdl=-0.9999995 !e>500 -backward 20% if(t.lt.500.)cdl=-cdl !e<500 -forward 20% else cdl=2*ranf()-1 !isotropic 80% end if end if call cone(up4cms,dldir,cdl,-1.) do i1=1,3 pdl(i1)=pdlt*dldir(i1) !delta momentum pdldec(i1,3)=-pdl(i1) !pion momentum (leading pi) end do pdl(4)=ed pdldec(4,3)=w-ed call twobiso(amd,amnucl,upi,pdl,pdldec) !delta decay isotropic 1=nuc do i1=1,3 !go back to lab call lloren(piso(1,i1),piso(4,i1),pdldec(1,i1),pdldec(4,i1),beta) end do uiso(1) = amnucl uiso(2) = upi uiso(3) = upi c ********* distribute charges ****** r=ranf() if(ka.eq.1)then rc(1)=0.1333 rc(2)=0.4 rc(3)=1. do k=1,3 if(r.le.rc(k))go to 101 end do k=3 101 continue if(prot)then !pi+p go to (102,103,104)k 102 chiso(1)=0 !pi+pi+n chiso(2)=1 chiso(3)=1 go to 105 103 chiso(1)=1 !pi+pi0p chiso(2)=0 uiso(2) = upo chiso(3)=1 go to 105 104 chiso(1)=1 !pi0pi+p chiso(2)=1 chiso(3)=0 uiso(3) = upo 105 continue else !pi-n go to (106,107,108)k 106 chiso(1)=1 !pi-pi-p chiso(2)=-1 chiso(3)=-1 go to 109 107 chiso(1)=0 !pi-pi0n chiso(2)=0 uiso(2) = upo chiso(3)=-1 go to 109 108 chiso(1)=0 !pi0pi-n chiso(2)=-1 chiso(3)=0 uiso(3) = upo 109 continue end if else if(ka.eq.2)then v1=(pcfsl1(ihi)*erem+pcfsl1(ilo)*(1-erem))*1e-4 v2=(pcfsl2(ihi)*erem+pcfsl2(ilo)*(1-erem))*1e-4 v3=(1-v1)*v2/3 v4=(1-v1)/3-v3 rc(1)=v1 rc(2)=rc(1)+v4 rc(3)=rc(2)+v3 rc(4)=rc(3)+v4*2 rc(5)=1 do k=1,5 if(r.le.rc(k))go to 201 end do k=5 201 continue if(prot)then !pi-p go to (202,203,204,205,206)k 202 chiso(1)=0 !pi+pi-n chiso(2)=-1 chiso(3)=1 go to 208 203 chiso(1)=0 !pi-pi+n chiso(2)=1 chiso(3)=-1 go to 208 204 chiso(1)=1 !pi0pi-p chiso(2)=-1 chiso(3)=0 uiso(3) = upo go to 208 205 chiso(1)=1 !pi-pi0p chiso(2)=0 uiso(2) = upo chiso(3)=-1 go to 208 206 chiso(1)=0 !pi0pi0n chiso(2)=0 uiso(2) = upo chiso(3)=0 uiso(3) = upo 208 continue else !pi+n go to (212,213,214,215,216)k 212 chiso(1)=1 !pi-pi+p chiso(2)=1 chiso(3)=-1 go to 218 213 chiso(1)=1 !pi+pi-p chiso(2)=-1 chiso(3)=1 go to 218 214 chiso(1)=0 !pi0pi+n chiso(2)=1 chiso(3)=0 uiso(3) = upo go to 218 215 chiso(1)=0 !pi+pi0n chiso(2)=0 uiso(2) = upo chiso(3)=1 go to 218 216 chiso(1)=1 !pi0pi0p chiso(2)=0 uiso(2) = upo chiso(3)=0 uiso(3) = upo 218 continue end if else v1=(pnfsl1(ihi)*erem+pnfsl1(ilo)*(1-erem))*1e-4 v2=(pnfsl2(ihi)*erem+pnfsl2(ilo)*(1-erem))*1e-4 v3=(1-v1)*v2/3 v4=(1-v1)-3*v3 rc(1)=v1/3 rc(2)=rc(1)+v4 rc(3)=rc(2)+2*rc(1) rc(4)=rc(3)+v3 rc(5)=1 do k=1,5 if(r.lt.rc(k))go to 301 end do k=5 301 continue if(prot)then !pi0p go to (302,303,304,305,306)k 302 chiso(1)=1 !pi+pi-p chiso(2)=-1 chiso(3)=1 go to 308 303 chiso(1)=1 !pi-pi+p chiso(2)=1 chiso(3)=-1 go to 308 304 chiso(1)=0 !pi+pi0n chiso(2)=0 uiso(2) = upo chiso(3)=1 go to 308 305 chiso(1)=0 !pi0pi+n chiso(2)=1 chiso(3)=0 uiso(3) = upo go to 308 306 chiso(1)=1 !pi0pi0p chiso(2)=0 uiso(2) = upo chiso(3)=0 uiso(3) = upo 308 continue else !pi0n go to (312,313,314,315,316)k 312 chiso(1)=0 !pi-pi+n chiso(2)=1 chiso(3)=-1 go to 318 313 chiso(1)=0 !pi+pi-n chiso(2)=-1 chiso(3)=1 go to 318 314 chiso(1)=1 !pi-pi0p chiso(2)=0 uiso(2) = upo chiso(3)=-1 go to 318 315 chiso(1)=1 !pi0pi-p chiso(2)=-1 chiso(3)=0 uiso(3) = upo go to 318 316 chiso(1)=0 !pi0pi0n chiso(2)=0 uiso(2) = upo chiso(3)=0 uiso(3) = upo 318 continue end if end if return end subroutine nucprd(no,e,ka,piso,chiso,uiso) dimension piso(4,4),chiso(4),uiso(4) c ka= 0 primary neutron c 1 primary proton common /nuccms/rhon,pfermi,unucl,ecms2,up4cms(3),beta(3),prot logical prot dimension frinn(161),fmxsm(161),dmin(101),fmxdn(130),fsln(176) data frinn/ $ 2., 7., 16., 30., 52., 86., 134., 201., 290., 406., $ 551., 727., 945.,1204.,1502.,1832.,2179.,2510.,2806.,3075., $ 3321.,3546.,3751.,3935.,4100.,4246.,4374.,4486.,4585.,4674., $ 4755.,4830.,4898.,4962.,5022.,5076.,5127.,5174.,5219.,5260., $ 5300.,5337.,5372.,5405.,5437.,5467.,5496.,5523.,5549.,5574., $ 5599.,5623.,5646.,5670.,5694.,5718.,5742.,5768.,5794.,5820., $ 5848.,5877.,5906.,5936.,5967.,5999.,6032.,6065.,6100.,6134., $ 6170.,6206.,6242.,6279.,6317.,6354.,6392.,6430.,6469.,6507., $ 6545.,6583.,6622.,6660.,6699.,6737.,6777.,6816.,6857.,6898., $ 6940.,6983.,7026.,7071.,7116.,7162.,7209.,7258.,7307.,7358., $ 7409.,7462.,7516.,7570.,7624.,7679.,7734.,7790.,7845.,7900., $ 7954.,8008.,8062.,8115.,8167.,8218.,8268.,8318.,8366.,8414., $ 8461.,8507.,8552.,8597.,8641.,8684.,8727.,8769.,8811.,8852., $ 8892.,8932.,8972.,9011.,9049.,9088.,9126.,9164.,9202.,9239., $ 9277.,9314.,9351.,9388.,9424.,9461.,9497.,9534.,9570.,9606., $ 9642.,9678.,9714.,9750.,9786.,9821.,9857.,9893.,9929.,9964., $ 10000./ data fmxsm/ $ 341., 598., 776., 923.,1052.,1168.,1276.,1377.,1472.,1563., $ 1651.,1735.,1816.,1896.,1973.,2048.,2122.,2194.,2265.,2335., $ 2404.,2471.,2538.,2604.,2669.,2733.,2797.,2860.,2922.,2984., $ 3045.,3106.,3167.,3227.,3286.,3345.,3404.,3462.,3520.,3578., $ 3635.,3692.,3749.,3806.,3862.,3918.,3974.,4030.,4085.,4140., $ 4195.,4250.,4305.,4359.,4413.,4468.,4522.,4575.,4629.,4683., $ 4736.,4789.,4842.,4895.,4948.,5001.,5054.,5106.,5158.,5211., $ 5263.,5315.,5367.,5419.,5471.,5523.,5574.,5626.,5678.,5729., $ 5780.,5832.,5883.,5934.,5985.,6036.,6087.,6138.,6189.,6240., $ 6290.,6341.,6392.,6442.,6493.,6543.,6594.,6644.,6694.,6745., $ 6795.,6845.,6895.,6945.,6995.,7045.,7095.,7145.,7195.,7245., $ 7295.,7344.,7394.,7444.,7493.,7543.,7593.,7642.,7692.,7741., $ 7791.,7840.,7889.,7939.,7988.,8038.,8087.,8136.,8185.,8235., $ 8284.,8333.,8382.,8431.,8480.,8529.,8578.,8627.,8676.,8725., $ 8774.,8823.,8872.,8921.,8970.,9019.,9068.,9116.,9165.,9214., $ 9263.,9312.,9360.,9409.,9458.,9506.,9555.,9604.,9652.,9701., $ 9749./ data dmin/ $ 1078.6,1133.,1148.,1158.,1166.,1172.,1178.,1183.,1187.,1191., $ 1195.,1198.,1202.,1205.,1208.,1211.,1213.,1216.,1219.,1221., $ 1224.,1226.,1229.,1231.,1234.,1236.,1239.,1242.,1245.,1248., $ 1251.,1255.,1258.,1262.,1265.,1269.,1273.,1277.,1282.,1286., $ 1291.,1296.,1302.,1308.,1315.,1323.,1331.,1341.,1351.,1363., $ 1376.,1391.,1408.,1427.,1449.,1475.,1505.,1538.,1568.,1594., $ 1618.,1640.,1660.,1680.,1699.,1718.,1736.,1754.,1772.,1789., $ 1805.,1820.,1835.,1849.,1862.,1875.,1887.,1899.,1911.,1923., $ 1935.,1947.,1960.,1973.,1986.,2000.,2014.,2029.,2044.,2059., $ 2075.,2091.,2107.,2124.,2140.,2157.,2174.,2190.,2207.,2224., $ 2240./ data fmxdn/ $ 2221.,2297.,2373.,2446.,2519.,2590.,2660.,2730.,2798.,2865., $ 2932.,2998.,3063.,3128.,3192.,3255.,3318.,3380.,3442.,3504., $ 3565.,3625.,3685.,3745.,3804.,3863.,3922.,3981.,4039.,4096., $ 4154.,4211.,4268.,4325.,4382.,4438.,4494.,4550.,4606.,4661., $ 4717.,4772.,4827.,4882.,4936.,4991.,5045.,5100.,5154.,5208., $ 5261.,5315.,5369.,5422.,5475.,5529.,5582.,5635.,5687.,5740., $ 5793.,5845.,5898.,5950.,6003.,6055.,6107.,6159.,6211.,6263., $ 6315.,6366.,6418.,6470.,6521.,6573.,6624.,6675.,6727.,6778., $ 6829.,6880.,6931.,6982.,7033.,7084.,7135.,7185.,7236.,7287., $ 7337.,7388.,7438.,7489.,7539.,7590.,7640.,7690.,7740.,7791., $ 7841.,7891.,7941.,7991.,8041.,8091.,8141.,8191.,8241.,8291., $ 8341.,8390.,8440.,8490.,8539.,8589.,8639.,8688.,8738.,8787., $ 8837.,8886.,8936.,8985.,9035.,9084.,9133.,9183.,9232.,9281./ data fsln/ $ 5050.,5050.,5050.,5050.,5050.,5050.,5050.,5050.,5050.,5050., $ 5050.,5050.,5050.,5050.,5050.,5050.,5050.,5050.,5050.,5050., $ 5050.,5050.,5050.,5050.,5050.,5050.,5050.,5050.,5050.,5050., $ 5050.,5050.,5050.,5050.,5050.,5050.,5050.,5050.,5050.,5050., $ 5050.,5050.,5050.,5050.,5050.,5050.,5050.,5050.,5050.,5047., $ 5047.,5043.,5040.,5038.,5033.,5031.,5030.,5030.,5035.,5048., $ 5061.,5106.,5162.,5237.,5285.,5323.,5356.,5379.,5403.,5428., $ 5443.,5463.,5483.,5497.,5515.,5531.,5550.,5565.,5582.,5602., $ 5620.,5636.,5658.,5672.,5688.,5701.,5718.,5733.,5747.,5761., $ 5771.,5794.,5807.,5821.,5836.,5851.,5866.,5879.,5893.,5905., $ 5919.,5933.,5946.,5959.,5968.,5978.,5992.,6005.,6015.,6026., $ 6035.,6051.,6061.,6075.,6087.,6096.,6109.,6118.,6126.,6136., $ 6149.,6160.,6168.,6181.,6191.,6199.,6213.,6221.,6230.,6241., $ 6249.,6258.,6265.,6274.,6281.,6290.,6300.,6306.,6318.,6325., $ 6335.,6339.,6348.,6357.,6362.,6374.,6381.,6387.,6394.,6389., $ 6416.,6417.,6422.,6427.,6431.,6436.,6439.,6445.,6451.,6455., $ 6462.,6462.,6467.,6473.,6476.,6480.,6485.,6489.,6495.,6499., $ 6500.,6507.,6510.,6515.,6518.,6525./ dimension dldir(3),pdl(4),pdldec(4,4) parameter (upi=139.6, amnucl=939., am2n2=4*amnucl**2) iraz=0 w=sqrt(ecms2) tt=e-amnucl if(prot)then ka1=1 ka2=0 ka3=1 ka4=-1 else ka1=0 ka2=1 ka3=-1 ka4=1 end if if(no.eq.1)then t=tt else t=((w-upi)**2-am2n2)/2/amnucl end if 1 call nuchis(t-300.,20.,161,ilo,ihi,erem) rf1=(frinn(ihi)*erem+frinn(ilo)*(1-erem))*1e-4 phsm=(fmxsm(ihi)*erem+fmxsm(ilo)*(1-erem))*100. 2 rf=rf1*ranf() call nuchis(rf*100,1.,101,ilo1,ihi1,erem1) amd1=dmin(ihi1)*erem1+dmin(ilo1)*(1-erem1) if(no.eq.1)then c ******** single production *********** ed=(amd1**2+ecms2-amnucl**2)/2/w pd2=ed**2-amd1**2 if(pd2.lt.0.)go to 2 pdlt=sqrt(pd2) phs=(w-ed)*ed*pdlt/w if(ranf().gt.phs/phsm)go to 2 if(tt.lt.500.)then aiso=1. else if(tt.lt.1000.)then aiso=0.75 else if(tt.lt.1300.)then aiso=0.50 else if(tt.lt.2500.)then aiso=0.25 else aiso=0 end if if(ranf().lt.aiso)then cdl=2*ranf()-1. else cdl=-.9999995 if(ranf().lt.0.5)cdl=-cdl end if call cone(up4cms,dldir,cdl,-1.0) do i1=1,3 pdl(i1)=pdlt*dldir(i1) pdldec(i1,3)=-pdl(i1) end do pdl(4)=ed pdldec(4,3)=w-ed call twobiso(amd1,amnucl,upi,pdl,pdldec) do i1=1,3 call lloren(piso(1,i1),piso(4,i1), 1 pdldec(1,i1),pdldec(4,i1),beta) end do uiso(1) = amnucl uiso(2) = upi uiso(3) = amd1 rpi=ranf() rnu=ranf() if((ka-ka1).eq.0)then !p-p n-n if(rpi.lt.0.75)then chiso(1)=ka1 chiso(2)=ka3 chiso(3)=ka2 else if(rpi.lt.0.9167)then chiso(1)=ka1 chiso(2)=0 chiso(3)=ka1 else chiso(1)=ka2 chiso(2)=ka3 chiso(3)=ka1 end if else !p-n n-p if(rpi.lt.0.66667)then chiso(2)=0 if(rnu.lt.0.5)then chiso(1)=ka chiso(3)=ka1 else chiso(1)=ka1 chiso(3)=ka end if else if(rnu.lt.0.5)then chiso(1)=1 chiso(2)=-1 chiso(3)=1 else chiso(1)=0 chiso(2)=1 chiso(3)=0 end if end if end if c ****************** end of single production **************** else if(iraz.eq.0)then !two deltas iraz=1 amd2=amd1 rf2=rf1 t=((w+amnucl-amd1)**2-am2n2)/2/amnucl go to 1 else ed=(amd1**2-amd2**2+ecms2)/2/w pd2=ed**2-amd1**2 if(pd2.lt.0)then iraz=0 rf1=rf2 go to 2 end if pdlt=sqrt(pd2) phs=(w-ed)*ed*pdlt/w call nuchis(tt-920.,20.,130,ilo1,ihi1,erem1) phsm=(fmxdn(ihi1)*erem1+fmxdn(ilo1)*(1-erem1))*100. if(ranf().gt.phs*rf1/(phsm*rf2))then iraz=0 rf1=rf2 go to 2 end if cdl=-.9999995 if(ranf().lt.0.5)cdl=-cdl call cone(up4cms,dldir,cdl,-1.0) do i1=1,3 pdl(i1)=pdlt*dldir(i1) end do pdl(4)=ed call twobiso(amd1,amnucl,upi,pdl,pdldec) do i1=1,3 pdl(i1)=-pdl(i1) end do pdl(4)=w-ed call twobiso(amd2,amnucl,upi,pdl,pdldec(1,3)) do i1=1,4 call lloren(piso(1,i1),piso(4,i1), 1 pdldec(1,i1),pdldec(4,i1),beta) end do uiso(1) = amnucl uiso(2) = upi uiso(3) = amnucl uiso(4) = upi rpi=ranf() rnu=ranf() if((ka-ka1).eq.0)then !p-p n-n if(rpi.lt.0.6)then chiso(1)=ka1 chiso(2)=ka3 if(rnu.lt.0.3333)then chiso(3)=ka1 chiso(4)=ka4 else chiso(4)=0 chiso(3)=ka2 end if else if(rpi.lt.0.8667)then chiso(1)=ka1 chiso(2)=0 if(rnu.lt.0.3333)then chiso(3)=ka2 chiso(4)=ka3 else chiso(3)=ka1 chiso(4)=0 end if else chiso(1)=ka2 chiso(2)=ka3 if(rnu.lt.0.3333)then chiso(3)=ka2 chiso(4)=ka3 else chiso(3)=ka1 chiso(4)=0 end if end if else !p-n n-p call nuchis(tt,20.,176,ilo,ihi,erem) rat=(fsln(ihi)*erem+fsln(ilo)*(1-erem))*1e-4 if(rpi.lt.rat)then chiso(1)=ka1 chiso(2)=ka3 chiso(3)=ka2 chiso(4)=ka4 else if(rpi.lt.(1.-rat)*0.6667)then chiso(1)=ka1 chiso(2)=0 if(rnu.lt.0.3333)then chiso(3)=ka1 chiso(4)=ka4 else chiso(3)=ka2 chiso(4)=0 end if else chiso(1)=ka2 chiso(2)=ka3 if(rnu.lt.0.3333)then chiso(3)=ka1 chiso(4)=ka4 else chiso(3)=ka2 chiso(4)=0 end if end if end if end if end if return end SUBROUTINE nucRODIS(RMIN,DR,NBIN,PROBM,ROT) DIMENSION ROT(NBIN),PROBM(NBIN) R=RMIN-DR DO i1=1,NBIN R=R+DR ROT(i1)=ROXY(R) PROBM(i1)=4*3.1416*((R+DR)**3-R**3)/3 END DO i2=NBIN-1 DO i1=1,i2 PROBM(i1)=PROBM(i1)*(ROT(i1)+ROT(i1+1))/2 END DO PROBM(NBIN)=PROBM(NBIN)*ROT(NBIN) RETURN END C******************************************************* C Find a starting point inside the nucleus for the hadron. subroutine nucstp(start,icont,mode) dimension start(3) common /nucdis/ probmi(31),probdi(31),rhotab(30),pnorm parameter ( rbin=.2, rmin=0, rmax=5.99, nbin=30) if(icont.eq.1)then do i1=1,3 start(i1)=0 end do else if(icont.eq.0)then xx=ranf() if(mode.eq.1)then !surphace mode r=rmax*sqrt(xx) phi=360*ranf() start(1)=r*cosd(phi) start(2)=r*sind(phi) start(3)=-rmax else if(mode.eq.2)then !volume mode r=prbin(probmi,nbin,rmin,rbin,xx) call ranve(r,start,2.,-1.) else !Dover mode r=prbin(probdi,nbin,rmin,rbin,xx) call ranve(r,start,2.,-1.) end if end if return end subroutine nucvmes(jpar,ides) common /nucint/uin,chint,ein,pin(3),upin(3) common /nuccms/ rhon,pfermi,unucl,ecms2,up4cms(3),beta(3),prot common /nuchad/ihap,nel,ncx integer inot, itrans, idec, inel, iel, iabs, icx common /hadron/inot,itrans,idec,inel,iel,iabs,icx logical prot real xeta(20),xome(20) C PARTIAL AND TOTAL CROSS SECTIONS C PI-P TO ETA+N CROSS SECTION (MB) AT 20*20MEV/C VALUES C OF THE CMS MOM. OF THE ETA DATA XETA/ $ 0.,.1,.25,.55,1.,1.25,1.4,1.6,1.7,1.75, $ 1.8,1.8,1.75,1.7,1.6,1.4,1.3,1.15,1.0,.9/ C PI-P TO OME+N CROSS SECTION (MB) AT 20*20MEV/C VALUES C OF THE CMS MOM. OF THE OME DATA XOME/ $ 0.,.1,.15,.28,.45,.65,.90,1.05,1.20,1.35, $ 1.5,1.65,1.8,1.95,2.1,2.25,2.4,2.55,2.7,2.85/ dimension pout1l(3),poutel(3),rv(3) parameter (upi=139.6, step=0.2) ides=1 IF(ECMS2.LE.(UPI+UNUCL)**2) GO TO 200 IF(ECMS2.LE.(uin+unucl)**2) GO TO 200 PCMSM2=SQRT((ECMS2-(UPI-UNUCL)**2)*(ECMS2-(UPI+UNUCL)**2)/(4.0*ECMS2)) PCMSM1=SQRT((ECMS2-(UIn-UNUCL)**2)*(ECMS2-(UIn+UNUCL)**2)/(4.0*ECMS2)) pinm=sqrt(pin(1)**2+pin(2)**2+pin(3)**2) call nuchis(pcmsm1,20.,20,ilo,ihi,prem) if(jpar.eq.1)then PINT=1.5/.71* $ (XETA(IHI)*PREM+XETA(ILO)*(1.-PREM))*RHON*(PCMSM2/PCMSM1)**2 PDEC=UIn/(PINM*230000.0) if(pcmsm1.lt.100.)then pela=.43*pcmsm1 else if(pcmsm1.gt.270.)then pela=156.-.42*pcmsm1 if(pela.lt.0.)pela=0. else pela=43. end if pela=pela*rhon PTOT=PDEC+PINT+pela else if (jpar.eq.2) then pint=0.5* $ (xome(ihi)*prem+xome(ilo)*(1.-prem))*RHON*(PCMSM2/PCMSM1)**2 pdec=uin/(20.*pinm) pela=0 ptot=pdec+pint else type *, 'Not a vector meson', jpar end if FINCH=0.6666*pint C RHON FACTOR ALREADY IN XR=ranf()+1.e-6 YR=ranf()*ptot DIST=-LOG(XR)/ptot C**********IFNOTHING HAPPENS IF(STEP.LT.DIST)GO TO 200 C**********IFSOMETHING HAPPENS c C**********DOESIT DECAY? FSUM=pDEC IF(YR.LT.FSUM)THEN ihap=1 IDEC=IDEC+1 GO TO 99 END IF C VECTOR MESON MUST HAVE INTERACTED call ranve(1.,rv,2.,-1.) C****************DOES VECTOR MESON ELASTICALLY SCATTER? FSUM=FSUM+pELA IF(YR.LT.FSUM)THEN call nuckin(rv,pcmsm1,uin,poutnlm,poutel,poutelm,eoutel) IF(POUTNLM.LT.PFERMI) go to 200 DO i2=1,3 PIN(i2)=POUTEL(i2) UPIN(i2)=PIN(i2)/POUTELM END DO EIN=EOUTEL ihap=1 nel=1 GO TO 200 END IF C****************VECTOR MESON MAKES A PION********* call nuckin(rv,pcmsm2,upi,pout2lm,pout1l,pout1lm,eout1l) IF(POUT2LM.LT.PFERMI)GO TO 200 ihap=1 INEL=INEL+1 C*****IS SCATTERING OFF P OR N? FSUM=FSUM+FINCH if(prot)then C*****PROTON IF(YR.LT.FSUM)THEN CHINT=1.0 ELSE CHINT=0.0 END IF ELSE C*****NEUTRON IF(YR.LT.FSUM) THEN CHINT=-1.0 ELSE CHINT=0.0 END IF END IF DO i2=1,3 PIN(i2)=POUT1L(i2) UPIN(i2)=PIN(i2)/POUT1LM END DO EIN=EOUT1L UIn=upi 99 ides=0 200 return end subroutine AZIO(COSINE,SINE) 5 r1=ranf() R1SQ=R1*R1 C XSQ r2=ranf() R2SQ=R2*R2 C YSQ SUM=R1SQ+R2SQ IF(SUM.GT.1.0)GOTO5 SUM=SUM*0.5 C (XSQ+YSQ)/2 COSINE=(SUM-R1SQ)/SUM C (YSQ-XSQ)/(XSQ+YSQ) SINE=(R1*R2)/SUM C (2*X*Y)/(XSQ+YSQ) r1=ranf() IF(R1.LT.0.5)GOTO10 SINE=-SINE 10 RETURN END C************************************************************** C Discribe the volume mode of the nucleus. The hadron is assumed C to originate from a nucleon inside the nucleus. REAL FUNCTION ROXY(R) parameter (w=-.05, c=2.61, z=.513, d=.102, g=2.76, e=.35) RO=(1+W*(R/C)**2)/(1+EXP((R-C)/Z)) IF(R.EQ.0)THEN DRO=1 ELSE GR=G*R DRO=SIN(GR)/GR END IF DRO=DRO*D*EXP(-(E*R)**2) ROXY=RO-DRO RETURN END SUBROUTINE TWOBiso(AMD,AM1,AM2,PD,P1) DIMENSION PD(4),P1(4,2),PTEM(4,2),dir(3) AMD2=AMD**2 A2M1=AM1**2 A2M2=AM2**2 E1=(AMD2+A2M1-A2M2)/AMD/2. E2=(AMD2+A2M2-A2M1)/AMD/2. P=E1**2-A2M1 P=SQRT(P) call azio(cs,ss) pdd=sqrt(pd(1)**2+pd(2)**2+pd(3)**2) do i1=1,3 dir(i1)=pd(i1)/pdd end do CALL cone(dir,ptem,cs,-1.0) do i1=1,3 ptem(i1,1)=ptem(i1,1)*p ptem(i1,2)=-ptem(i1,1) end do PTEM(4,1)=E1 PTEM(4,2)=E2 CALL LOREN(PD,PTEM,P1,2,-1) RETURN END C**************************************************** C Handle kaon nucleon interactions in the range 1.5-2Gev Center of Mass C Energy. This is only set up to handle K+N->m+b where m is a meson and C b is a baryon. C**** The charge of the kaon controls if it is a k+ k0 k0b or a k- C k+ > 0.9 C k0 > 0.0 C k0b > -0.9 C k- < -0.9 subroutine nuckaon(ides,step) implicit none C**** Take one step in the nucleus. integer i1, i2, i3 real r1, r2, r3 C**** The index of the incoming particle. On output this is: C 1 - the particle leaves the step. C 0 - the particle was absorbed. C -1 - the particle created a second particle. integer ides C**** The step size for this simulation in fermi. Usually this is .2 fm. real step C**** The data about the interaction particle real uin, chint, ein, pin(3), upin(3) common /nucint/uin,chint,ein,pin,upin C**** isospin parameters real piso(4,4), chiso(4), uiso(4) common /nucnewprd/ piso, chiso, uiso C*************************************************** C @(#)masses.cdk 1.2 modified on 12/30/92 C The particle masses C PROTON - AMP C NEUTRON - AMN C LAMBDA - AML C SIGMA - AMS C ELECTRON - AMEL C MUON - AMMU C PI 0 - AMPO C PI +/- - AMPC C ETA = AMETA C OMEGA = AMOM C RHO = AMRHO C K 0 = AMKO C K +- = AMKC C K* 0 = AMKSO C K* +- = AMKSC C*** The leptons real AMEL, AMMU C*** The baryons real AMP, AMN, AML, AMS C*** The mesons real AMPO, AMPC, AMETA, AMOMG, AMRHO C*** The strange mesons. real AMKO, AMKC, AMKSO, AMKSC COMMON/MASSES/AMEL,AMMU, $ AMP, AMN, AML, AMS, $ AMPO, AMPC, AMETA, AMRHO, AMOMG, $ AMKO, AMKC, AMKSO, AMKSC C**** The nuclear center of mass parameters. real up4cms(3), beta(3) logical prot real rhon, pfermi, unucl, ecms2 common /nuccms/rhon,pfermi,unucl,ecms2,up4cms,beta,prot C**** The center of mass energy real Ecm C**** The center of mass momentum of the Meson. real Pmes(4), PKaon C**** The mass of the meson produced. real Mmes C**** The charge of the meson produced. real Qmes C**** The center of mass momentum of the baryon. real Pbar(4) C**** The mass of the baryon produced. real Mbar C**** The charge of the baryon produced. real Qbar C**** The number of partcial waves in the expansion. integer nwaves parameter (nwaves=8) C**** The total partial wave coefficients for kaon+nuc -> kaon+nuc C note that <1,0|1,0> = <1,1|1,1> = <1,-1|1,-1> = knkn1 complex knkn0(nwaves), knkn1(nwaves) C**** The cross sections. integer ncross parameter (ncross=3) real cross(ncross) C**** The partial wave coefficients for the interaction. complex tab(nwaves,ncross) C**** The total cross section. real tcross C**** The minimum free path found. real free C**** The index of the minimum free path. integer ifree real ranf C**** The beta to go from the lab to the center of mass. real bcms(3) ides = 1 if (chint.eq.0) then C**** Make zero charge kaons into k0 not k0b chint = 0.1 endif C**** Find the center of mass energy from the energy squared found by C nucfermi. Ecm = sqrt(Ecms2)/1000.0 C**** Find the momentum of the kaon in the center of mass. do i1 = 1,3 Pmes(i1) = pin(i1)/1000.0 enddo Pmes(4) = ein/1000.0 do i1 = 1,3 bcms(i1) = -beta(i1) enddo call lloren(pmes,pmes(4),pmes,pmes(4),bcms) Pkaon = sqrt(Pmes(1)**2+Pmes(2)**2+Pmes(3)**2) C**** Find the partial wave coefficients for each isospin call nucknkn0(Ecm,knkn0) call nucknkn1(Ecm,knkn1) C**** Find the <11|11> scattering matrix C This is for: C K+ + p -> K+ + p C K0 + n -> K0 + n C K0bar + p -> K0bar + p C K- + n -> K- + n do i1 = 1,nwaves tab(i1,1) = knkn1(i1) enddo C**** Find the .5(<10|10>+<00|00>) cross section. C This is for: C K+ + n -> K+ + n C K0 + p -> K0 + p C K0bar + n -> K0bar + n C K- + p -> K- + p do i1 = 1,nwaves tab(i1,2) = 0.5*(knkn1(i1)+knkn0(i1)) enddo c**** Find the 0.5(<10|10>-<00|00>) cross section. C This is for K0+n -> K-+p and K-+p -> K0+n C K+ + n -> K0 + p C K0 + p -> K+ + n C K0bar + n -> K- + p C K- + p -> K0bar + n do i1 = 1,nwaves tab(i1,3) = 0.5*(knkn1(i1)-knkn0(i1)) enddo C**** Turn the partial wave amplitudes in to total cross sections. do i1 = 1,ncross call nuckcrs(PKaon,tab(1,i1),cross(i1)) enddo C**** Convert the cross sections into free paths and find the one that is C the shortest. free = 99999999.9 ifree = 0 do i1 = 1,ncross r1 = ranf() if (r1.gt.1.0E-7) then r1 = -log(r1)/cross(i1)/rhon else r1 = free + 1.0 endif if (r1.lt.free) then free = r1 ifree = i1 endif enddo if ((ifree.eq.0).or.(free.gt.step)) then ides = 1 return endif C**** Figure out the final products. if (ifree.eq.1) then if (chint.gt.0.9) then C**** This is a Kplus Qmes = 1.0 Mmes = amkc Qbar = 1.0 Mbar = amp else if (chint.gt.0) then C**** This is a K0 Qmes = 0.1 Mmes = amko Qbar = 0.0 Mbar = amn else if (chint.gt.-0.9) then C**** This is a K0bar Qmes = -0.1 Mmes = amko Qbar = 1.0 Mbar = amp else C**** This is a Kminus Qmes = -1.0 Mmes = amkc Qbar = 0.0 Mbar = amn endif else if (ifree.eq.2) then if (chint.gt.0.9) then C**** This is a Kplus Qmes = 1.0 Mmes = amkc Qbar = 0.0 Mbar = amn else if (chint.gt.0) then C**** This is a K0 Qmes = 0.1 Mmes = amko Qbar = 1.0 Mbar = amp else if (chint.gt.-0.9) then C**** This is a K0bar Qmes = -0.1 Mmes = amko Qbar = 0.0 Mbar = amn else C**** This is a Kminus Qmes = -1.0 Mmes = amkc Qbar = 1.0 Mbar = amp endif else if (ifree.eq.3) then if (chint.gt.0.9) then C**** This is a Kplus Qmes = 0.1 Mmes = amko Qbar = 1.0 Mbar = amp else if (chint.gt.0) then C**** This is a K0 Qmes = 1.0 Mmes = amkc Qbar = 0.0 Mbar = amn else if (chint.gt.-0.9) then C**** This is a K0bar Qmes = -1.0 Mmes = amkc Qbar = 1.0 Mbar = amp else C**** This is a Kminus Qmes = -0.1 Mmes = amko Qbar = 0.0 Mbar = amn endif else C**** No interaction this step. type *, 'INVALID CROSS SECTION IN NUCKAON.' stop endif C**** Find the direction of the meson after the scatter. Notice that C Pmes goes in a momentum and comes out a direction. call nuckdir(Pmes,Pkaon,tab,Pmes) C**** Convert Pmes back into a 4 momentum. Pkaon = ecm**2 - Mmes**2 - Mbar**2 if (Pkaon.lt.0.0) then ides = 1 stop endif Pkaon = sqrt(Pkaon)/2.0 do i1 = 1,3 PMes(i1) = PMes(i1)*PKaon enddo PMes(4) = sqrt(Mmes**2+PKaon**2) call lloren(Pmes,Pmes(4),Pmes,Pmes(4),beta) uin = Mmes*1000.0 ein = Pmes(4)*1000.0 chint = Qmes r1 = 0.0 do i1 = 1,3 pin(i1) = Pmes(i1)*1000.0 r1 = r1 + pin(i1)**2 enddo r1 = sqrt(r1) do i1 = 1,3 upin(i1) = pin(i1)/r1 enddo return end C**** Return the complex legendre coefficients for center of mass energy enr. subroutine nucclxint(enr,tab,energy,coeffs,nenr) implicit none integer i1 C**** The energy to get the coefficients for. real enr C**** The return variable for the coefficients. complex tab(8) C**** The fraction distance in the energy bin. real frac C**** The energy bin below the energy. integer low C**** The number of energy bins. integer nenr C**** The energy bins and the coefficients. real energy(nenr) complex coeffs(8,nenr) C**** Do a simple minded search for the correct energy bin. If this runs C too slow then here is where to speed it up. if (enr.le.energy(1)) then low = 1 frac = 0.0 else if (enr.ge.energy(nenr)) then low = nenr-1 frac = 1.0 else low = 1 do while (enr.gt.energy(low)) low = low + 1 enddo low = low - 1 frac = (enr-energy(low))/(energy(low+1)-energy(low)) endif C**** Do a simple linear interpolation between the bins. do i1 = 1,8 tab(i1) = (1.0-frac)*(coeffs(i1,low)) + frac*(coeffs(i1,low+1)) enddo return end subroutine nuckcrs(PKaon,tab,cros) implicit none integer i1 C**** The center of mass momentum. real PKaon C**** The partial wave ampitudes for the cross section. complex tab(*) C**** The return value for the cross section. real cros cros = 0.0 do i1 = 1,8 cros = cros + (2*(i1-1)+1)*tab(i1)*conjg(tab(i1)) enddo cros = cros/PKaon/PKaon return end subroutine nuckdir(PMes,PKaon,Tab,Pout) implicit none integer i1, i2 real r1, r2 C**** The 4 momentum of the kaon in the center of mass frame. real Pmes(4) C**** The momentum of the kaon in the center of mass frame. real PKaon C**** The partial wave amplitudes for the cross section. complex Tab(*) C**** The output momentum in the center of mass frame. real Pout(4) C**** The table used to invert the differential cross section. integer ncrs parameter (ncrs=20) real Dcrs(ncrs) real ranf C**** The cosine real css C**** Find the differential cross section at ncrs different grid points. do i1 = 1,ncrs r1 = i1*2.0/ncrs - 1.0 call nucdcrs(PKaon,tab,r1,Dcrs(i1)) enddo C**** Sum the cross section to get the total. Notice that this is not C normalized to the total cross section, but it doesn't matter since C we have already decided that this interaction is taking place and C are just generating the angular distribution. do i1 = 2,ncrs Dcrs(i1) = Dcrs(i1) + Dcrs(i1-1) enddo C**** Find the cosine r1 = 0.999*ranf()*Dcrs(Ncrs) i1 = 1 do while (r1.lt.Dcrs(i1)) i1 = i1 + 1 enddo C**** Find the fractional diffenence from the cosine point found and the C one wanted. r1 = r1 - Dcrs(i1) if (i1.eq.1) then r1 = r1/Dcrs(i1) else r1 = r1/(Dcrs(i1)-Dcrs(i1-1)) endif css = (i1+r1)*2.0/ncrs - 1.0 call cone(Pmes,Pout,css,-1.0) return end subroutine nucdcrs(PKaon,tab,dcos,cros) C**** Return the differential cross section as a function of cosine. implicit none integer i1 C**** The center of mass momentum. real PKaon C**** The partial wave amplitudes for the cross section. complex tab(*) C**** The cosine to return the differential cross section for. real dcos C**** The cross section. real cros C**** The wave function complex ff C**** The legendre polynomial real plgndr ff = (0.0,0.0) do i1 = 1,8 call nucplgndr(i1-1,dcos,plgndr) ff = ff + (2.0*(i1-1.0)+1.0)*tab(i1)*plgndr enddo ff = ff/PKaon cros = abs(ff)**2 return end C*************************************** C From Numerical Recipes ch 6.6 C subroutine NUCPLGNDR(L,X,plgndr) C**** Computes the associated legendre polynomial P(l)(x) where l is an c integer and -110 - A PARTICULAR CHANNEL IS CHOSEN C MODE=I*10+J WHERE I=1 FOR NUMU AND I=2 FOR NUEL C J=0 HADRONS ACCORDING TO BRANCHING RATIOS C J=1 NU+P=L+P+PI+/- C J=2 NU+P=L+N+PI0 C J=3 NU+N=L+N+PI+/- C J=4 NU+N=L+P+PI0 C C******************************************************************* C @(#)inter.cdk 1.1 modified on 12/29/92 C the interaction point. C real xint(3) common/inter/xint C*************************************************** C @(#)masses.cdk 1.2 modified on 12/30/92 C The particle masses C PROTON - AMP C NEUTRON - AMN C LAMBDA - AML C SIGMA - AMS C ELECTRON - AMEL C MUON - AMMU C PI 0 - AMPO C PI +/- - AMPC C ETA = AMETA C OMEGA = AMOM C RHO = AMRHO C K 0 = AMKO C K +- = AMKC C K* 0 = AMKSO C K* +- = AMKSC C*** The leptons real AMEL, AMMU C*** The baryons real AMP, AMN, AML, AMS C*** The mesons real AMPO, AMPC, AMETA, AMOMG, AMRHO C*** The strange mesons. real AMKO, AMKC, AMKSO, AMKSC COMMON/MASSES/AMEL,AMMU, $ AMP, AMN, AML, AMS, $ AMPO, AMPC, AMETA, AMRHO, AMOMG, $ AMKO, AMKC, AMKSO, AMKSC C******************************************************************** C @(#)prdec.cdk 1.1 modified on 12/29/92 C pass information about the initail particls and the desired products. C**** The amass and info about the interaction from spot. real amint, amlep, amd, amm(5) integer np(5), npar, kt COMMON/PRDEC/AMINT,AMLEP,AMD,AMM,NP,NPAR,KT C**************************************************************** C @(#)momentum.cdk 1.2 modified on 1/12/93 C Include the information about the primary particles to be tracked. C**** The number of momenta. integer nmom C**** The particle 4 momentum. real ppr(4,20) C**** The particle masses real ppm(20) C**** The particle charges real chh(20) C**** The particle id. integer pid(20) COMMON/MOM/ nmom,ppr,ppm,chh,pid C***** Gamma ray information real ppg(4,20) integer ngam common /gamm1/ ppg,ngam DIMENSION PD(4),PTEM(4,3),PNE(4),PLE(4),pp(4,2) c dimension to handle nuclear corrections dimension stpt(3,20),ei(20),pi(3,20),ui(20),chin(20) 1 ,eo(20),po(3,20),uo(20),cho(20) 2 ,start(3),decp(3) data anuc/16./,imode/2/ do 12 i=1,5 ppm(i)=0. do 12 j=1,4 12 ppr(j,i)=0. IF(MODE/10-1)1,2,3 1 IF(RANF(0).LT.0.286)GO TO 3 2 AMLEP=AMMU GO TO 4 3 AMLEP=AMEL 4 IF(MODE.LE.10)GO TO 5 GO TO(6,7,8,9),MOD(MODE,10) 5 R=RANF(0) IF(R.LT.0.54)GO TO 6 IF(R.LT.0.69)GO TO 7 IF(R.LT.0.93)GO TO 8 9 NC=0 MODA=72 AMINT=AMN AMPR1=AMP AMPR2=AMPO GO TO 10 8 NC=0 MODA=1 IF(RANF(0).LT..52)MODA=3 AMINT=AMN AMPR1=AMN AMPR2=AMPC GO TO 10 7 NC=1 MODA=2 AMINT=AMP AMPR1=AMN AMPR2=AMPO GO TO 10 6 NC=1 MODA=71 IF(RANF(0).LT..56)MODA=73 AMINT=AMP AMPR1=AMP AMPR2=AMPC 10 DO 11 I=1,3 11 PD(I)=0. PD(4)=AMINT IF(IFER.GT.0)CALL FERMID(NC,PD,AMINT) 20 ENE=0.4+RANF(0)*4.6 DSIG=0.692*ENE**(-2.8)*(1.-2.88*EXP(-2.47*ENE)) IF(RANF(0).GT.DSIG)GO TO 20 21 ST=RANF(0) IF(RANF(0).GT.1.-0.3*ST)GO TO 21 CT=SQRT(1.-ST**2) IF(RANF(0).GT.0.5)CT=-CT CALL RANVE(ENE,PTEM,CT,-1.) PTEM(4,1)=ENE CALL LOREN(PD,PTEM,PNE,1,1) DO 30 I=1,3 30 PNE(I)=PNE(I)/PNE(4) AQ=AMPR1+AMPR2 AL=(PNE(4)-AMLEP)*AMINT*2.+AMINT**2 AR=SQRT(AL) 23 AMDEL=AQ+0.6*RANF(0) IF(AMDEL.GT.AR)GO TO 23 DSIG=0.0036/((AMDEL-1.23)**2+0.0036) IF(RANF(0).GT.DSIG)GO TO 23 IQ=0 22 IQ=IQ+1 IF(IQ.GT.100)GO TO 23 QSQ=-ALOG(1.-(1.-EXP(-(AL-AMDEL**2)))*RANF(0)) ELEP=PNE(4)-(AMDEL**2+QSQ-AMINT**2)/AMINT/2. IF(ELEP.LT.AMLEP)GO TO 22 Q1=ELEP**2-AMLEP**2 IF(Q1.LT.0.)GO TO 22 PLEP=SQRT(Q1) EDEL=PNE(4)-ELEP+AMINT Q1=EDEL**2-AMDEL**2 IF(Q1.LT.0.)GO TO 22 PDEL=SQRT(Q1) CNEL=(2.*PNE(4)*ELEP-QSQ-AMLEP**2)/2./PNE(4)/PLEP IF(ABS(CNEL).GT.1.)GO TO 22 CALL CONE(PNE,PLE,CNEL,-1.) DO 24 I=1,3 A=PLE(I)*PLEP PTEM(I,2)=A 24 PTEM(I,1)=PNE(I)*PNE(4)-A PTEM(4,2)=ELEP PTEM(4,1)=EDEL CALL LOREN(PD,PTEM,PPR,2,-1) CALL TWOB(AMDEL,AMPR1,AMPR2,PPR,PTEM) c DO 25 I=1,4 c PPR(I,1)=PPR(I,2) c PPR(I,2)=PTEM(I,2) c 25 PPR(I,3)=PTEM(I,1) c************** make nuclear interaction of pion ******** if(nc.eq.-1)then cho(1)=mod(moda,10)-2 do 33 i=1,3 33 po(i,1)=ptem(i,2) eo(1)=ptem(4,2) go to 34 end if do 29 i=1,3 stpt(i,1)=0. 29 pi(i,1)=ptem(i,2) ei(1)=ptem(4,2) chin(1)=mod(moda,10)-2 ui(1)=ampc nin=1 call partnuc(isetn,anuc,stpt,ei,pi,ui,chin,nin 1 ,eo,po,uo,cho,start,decp,imode,icont) if(abs(uo(1)).lt.1.e-4)go to 27 if(abs(cho(1)).lt.0.5)then do 31 i=1,3 31 pd(i)=po(i,1) pd(4)=eo(1) call twob(ampo,0.,0.,pd,pp) do 32 i=1,2 32 call putgam(pp(1,i)) go to 27 end if 34 continue do 25 i=1,4 ppr(i,1)=ppr(i,2) 25 ppr(i,3)=ptem(i,1) do 26 i=1,3 26 ppr(i,2)=po(i,1) ppr(4,2)=eo(1) ppm(1)=amlep ppm(2)=ampc ppm(3)=ampr1 moda=(moda/10)*10+int(cho(1))+2 nmom=3 go to 100 27 do 28 i=1,4 ppr(i,1)=ppr(i,2) 28 ppr(i,2)=ptem(i,1) ppm(1)=amlep ppm(2)=ampr1 moda=moda/10 nmom=2 100 continue RETURN END C***************************************************** C %W% modified on %G% SUBROUTINE STMIU(key) C GENERATES MUON 4-MOMENTUM VECTOR PPR ACCORDING TO THE ENERGY AND C ANGULAR DISTRIBUTION FOR COSMIC MUONS C*************************************************** C @(#)masses.cdk 1.2 modified on 12/30/92 C The particle masses C PROTON - AMP C NEUTRON - AMN C LAMBDA - AML C SIGMA - AMS C ELECTRON - AMEL C MUON - AMMU C PI 0 - AMPO C PI +/- - AMPC C ETA = AMETA C OMEGA = AMOM C RHO = AMRHO C K 0 = AMKO C K +- = AMKC C K* 0 = AMKSO C K* +- = AMKSC C*** The leptons real AMEL, AMMU C*** The baryons real AMP, AMN, AML, AMS C*** The mesons real AMPO, AMPC, AMETA, AMOMG, AMRHO C*** The strange mesons. real AMKO, AMKC, AMKSO, AMKSC COMMON/MASSES/AMEL,AMMU, $ AMP, AMN, AML, AMS, $ AMPO, AMPC, AMETA, AMRHO, AMOMG, $ AMKO, AMKC, AMKSO, AMKSC C******************************************************************* C @(#)inter.cdk 1.1 modified on 12/29/92 C the interaction point. C real xint(3) common/inter/xint C**************************************************************** C @(#)momentum.cdk 1.2 modified on 1/12/93 C Include the information about the primary particles to be tracked. C**** The number of momenta. integer nmom C**** The particle 4 momentum. real ppr(4,20) C**** The particle masses real ppm(20) C**** The particle charges real chh(20) C**** The particle id. integer pid(20) COMMON/MOM/ nmom,ppr,ppm,chh,pid C***** Gamma ray information real ppg(4,20) integer ngam common /gamm1/ ppg,ngam C**** The common block with the detector wall positions in it. real HT(3) COMMON/GEO/HT C******************************************************************** C @(#)prdec.cdk 1.1 modified on 12/29/92 C pass information about the initail particls and the desired products. C**** The amass and info about the interaction from spot. real amint, amlep, amd, amm(5) integer np(5), npar, kt COMMON/PRDEC/AMINT,AMLEP,AMD,AMM,NP,NPAR,KT C************************************************************************ C @(#)fiducial.cdk 1.1 modified on 12/29/92 real FV common/fidv/FV real ranf C**** Flag this as a first call. integer called data called /0/ if (called.eq.0) then call hbook1(2000,'Generated Angular Distribution', $ 60, 0.0, 180.0, 0.0) endif called = called + 1 C******************************************************************** C SET THE MASS TO THAT OF THE MUON. C******************************************************************** AMLEP=AMMU C******************************************************************** C START TRACKING MUONS 4M BEFORE A TUBE PLANE TO ACCOUNT FOR C SHOWERING IN ROCK C******************************************************************* TOP=400.0 3 continue call cosmuimb(ppr(1,1),E,protonen) P=SQRT(E**2-AMMU**2) if (key.eq.-3) then C******************************************************************** C COSMIC MUONS C******************************************************************* 10 continue C**** Make a vertex. DO I=1,2 xint(i) = 5.0*ht(i)*(2.0*ranf() - 1.0) enddo xint(3) = ht(3) + Top call EnterFidu(xint,ppr,fv,r1,r2) if (r1.eq.r2) then C**** Did not entry the detector. goto 3 endif else if (key.eq.-2) then C******************************************************************** C STRAIGHT THRU MUONS C******************************************************************* C**** Generate a vertex for the central muons. DO I=1,2 4 XINT(I)=HT(I)*(2.0*Ranf()-1.0) CT=RGAUSS(XINT(I),100.) IF(HT(I)-ABS(CT).LT.FV)GOTO 4 ENDDO XINT(3)=HT(3) C**** Check that the exit point of the muon is in the bottom plane. DO I = 1,2 R = XINT(I) + PPR(I,1)*HT(3)*2 CT=RGAUSS(R,100.) IF (HT(I)-ABS(CT).LT.FV) GOTO 3 ENDDO endif C**** Back the vertex up to be 4 meters outside of the detector. DO I=1,3 XINT(I)=XINT(I)-TOP*PPR(I,1) enddo C**** Histogram the angular distribution of muons. r = PPR(3,1) r = acos(r) * 180.0 / 3.14159 call hfill(2000,r,0.0,1.0) C**** Make ppr a momentum NMOM = 1 PPR(1,1) = P * PPR(1,1) PPR(2,1) = P * PPR(2,1) PPR(3,1) = P * PPR(3,1) PPR(4,1) = E PPM(1) = AMMU if(ranf().gt.0.44)then chh(1)=1 else chh(1)=-1 end if RETURN END subroutine cosmuimb(mudir,muen,e0) c written by R. Svoboda, Aug.91 real mudir(3),muen,e0 parameter emin=0.2 !min muon energy (GeV) parameter emax=2.E+7 !max primary energy (GeV) parameter depth=1570. !mwe depth parameter density=2.6 !g/cm**3 call cosmu(depth,density,emin,emax,mudir,muen,e0,arate) return end C****************************************************************** C Generate cosmic ray muons. Written by Bob Svoboda Aug. 1991. subroutine cosmu(depth,density,emin,emax,mudir,emu,e0,arate) real mudir(3),muen parameter rad_earth=6.378E+06 parameter czbins=500 parameter e0bins=500 parameter emubins=500 parameter czmin=0.0872 real*8 cosz_prob(czbins),e0prob(e0bins),emuprob(emubins) real *8 prob,totflux,flux logical first data first/.true./ depth_rock=depth/density if(first) then dcosz=(1.-czmin)/czbins first=.false. totflux=0. do i=1,czbins cosz=float(i-1)*dcosz+dcosz/2.+czmin SINTH=SQRT(1.-COSZ**2) SINTHX=(1.-DEPTH_ROCK/RAD_EARTH)*SINTH COSTHX=SQRT(1.-SINTHX**2) hp=(depth+10)/cosz flux=(1.74E+6/(hp*costhx+400.))*hp**-1.53 flux=flux*(depth+75.)/(depth+50.+25./cosz) flux=flux*(exp(-0.0008*hp)) cosz_prob(i)=flux totflux=totflux+flux end do vrate=cosz_prob(czbins) do i=1,czbins cosz_prob(i)=cosz_prob(i)/totflux end do do i=2,czbins cosz_prob(i)=cosz_prob(i)+cosz_prob(i-1) end do arate=totflux*dcosz end if prob=ranf() do iz=czbins-1,1,-1 if(prob.ge.cosz_prob(iz)) then cosz=float(iz)*dcosz+ranf()*dcosz+czmin mudir(3)=cosz*-1. goto 1 end if end do mudir(3)=-1.*(ranf()*dcosz+czmin) 1 continue phi=ranf()*360. sth=sqrt(1.-mudir(3)**2) mudir(1)=cosd(phi)*sth mudir(2)=sind(phi)*sth slant_depth=depth_rock/cosz/1000. emumin=530.*(exp(0.36*slant_depth)-1.)*density+emin rle0min=alog10(emumin) rle0max=alog10(emax) drle0=(rle0max-rle0min)/e0bins de0p=10.**drle0-1. totprob=0. do i=e0bins,1,-1 rle0=float(i-1)*drle0+rle0min e0=10.**rle0 de0=e0*de0p e0=e0*(10.**(drle0/2.)) y=emumin/e0 rnmu=(14.5*(y**-.757)*(1.-y)**5.25)/emumin/cosz if(rnmu.lt.30.) then e0prob(i)=(1.-exp(-1.*rnmu))*rnmu*(e0**-2.71)*de0 else e0prob(i)=rnmu*(e0**-2.71)*de0 end if totprob=totprob+e0prob(i) end do e0prob(1)=e0prob(1)/totprob prob=ranf() if(prob.le.e0prob(1)) then rle0=rle0min+ranf()*drle0 goto 2 end if do i=2,e0bins e0prob(i)=e0prob(i)/totprob+e0prob(i-1) if(prob.le.e0prob(i)) then rle0=float(i-1)*drle0+rle0min+ranf()*drle0 goto 2 end if end do rle0=rle0max-ranf()*drle0 2 continue e0=10.**rle0 rlemumin=alog10(emumin) rlemumax=alog10(e0) drlemu=(rlemumax-rlemumin)/emubins demup=10.**drlemu-1. totprob=0. do i=emubins,1,-1 rlemu=float(i-1)*drlemu+rlemumin emu=10.**rlemu demu=emu*demup emu=emu*(10.**(drlemu/2.)) y=(emu/e0) rnmu=(14.5*(y**-.757)*(1.-y)**5.25)/emu/cosz if(rnmu.lt.30.) then emuprob(i)=(1.-exp(-1.*rnmu))*rnmu*demu else emuprob(i)=rnmu*demu end if totprob=totprob+emuprob(i) end do emuprob(1)=emuprob(1)/totprob prob=ranf() if(prob.le.emuprob(1)) then rlemu=rlemumin+ranf()*drlemu goto 3 end if do i=2,emubins emuprob(i)=emuprob(i)/totprob+emuprob(i-1) if(prob.le.emuprob(i)) then rlemu=float(i-1)*drlemu+rlemumin+ranf()*drlemu goto 3 end if end do rlemu=rlemumax-ranf()*drlemu 3 continue emu=10.**rlemu-emumin+emin return end C************************************************************* C @(#)proton.f 2.3 modified on 4/22/94 SUBROUTINE PROTON(IFER,MODE,MODA) implicit none C**** Flag if fermi momentum should be used. integer ifer C**** Two out of date flags. integer mode, moda integer i1, i2, i3 real r1 C This subroutine calculates the kinematics of the decay of a proton C or neutron into particles determined in np(). C C The final particles are in ppr(4,*) and the masses are in ppm(*). C**** The initial particle C np(1) = 0 - neutron C 1 - proton C**** The final particles. C np(2..npar) = 2 - neutrino C = +- 3 - electron C = +- 4 - muon C = 5 - pi zero C = +- 6 - pi +- C = 7 - eta C = 8 - rho 0 C = +- 9 - rho +- C = 10 - omega C = 11 - K zero C = +- 12 - K +) long -) short C = +- 13 - K +- C = 14 - K* zero C = +- 15 - K* +) long -) short C = +- 16 - K* +- C = 17 - gamma C******************************************************************* C @(#)inter.cdk 1.1 modified on 12/29/92 C the interaction point. C real xint(3) common/inter/xint C**************************************************************** C @(#)momentum.cdk 1.2 modified on 1/12/93 C Include the information about the primary particles to be tracked. C**** The number of momenta. integer nmom C**** The particle 4 momentum. real ppr(4,20) C**** The particle masses real ppm(20) C**** The particle charges real chh(20) C**** The particle id. integer pid(20) COMMON/MOM/ nmom,ppr,ppm,chh,pid C***** Gamma ray information real ppg(4,20) integer ngam common /gamm1/ ppg,ngam C**** The position the particle was created at in the nucleus. real start_point(3,20) common/protonstart/ start_point C******************************************************************** C @(#)prdec.cdk 1.1 modified on 12/29/92 C pass information about the initail particls and the desired products. C**** The amass and info about the interaction from spot. real amint, amlep, amd, amm(5) integer np(5), npar, kt COMMON/PRDEC/AMINT,AMLEP,AMD,AMM,NP,NPAR,KT C*************************************************** C @(#)masses.cdk 1.2 modified on 12/30/92 C The particle masses C PROTON - AMP C NEUTRON - AMN C LAMBDA - AML C SIGMA - AMS C ELECTRON - AMEL C MUON - AMMU C PI 0 - AMPO C PI +/- - AMPC C ETA = AMETA C OMEGA = AMOM C RHO = AMRHO C K 0 = AMKO C K +- = AMKC C K* 0 = AMKSO C K* +- = AMKSC C*** The leptons real AMEL, AMMU C*** The baryons real AMP, AMN, AML, AMS C*** The mesons real AMPO, AMPC, AMETA, AMOMG, AMRHO C*** The strange mesons. real AMKO, AMKC, AMKSO, AMKSC COMMON/MASSES/AMEL,AMMU, $ AMP, AMN, AML, AMS, $ AMPO, AMPC, AMETA, AMRHO, AMOMG, $ AMKO, AMKC, AMKSO, AMKSC c ***************************************************** c dimensions to handle inter-nuclear interactions c ***************************************************** C**** Flag if a new nuclear vertex should be made. integer icont C**** Flag the type of nuclear density to use integer imode parameter (imode=0) C**** The number of input hadrons for partnuc integer nin C**** the initial energy, momentum, mass, and charge. real stpt(3,20), ei(20), pi(3,20), ui(20), chin(20) C**** The number of output particles from partnuc. real no C**** The final energy, momentum, mass, and charge. real eo(20), po(3,20), uo(20), cho(20) C**** The nucleon type of decay. integer nc C**** The decay point of a hadron in the nucleus. real decp(3) real start(3) integer isetn parameter (isetn = 0) C**** The a of the oxygen nucleus. real anuc parameter (anuc=16.0) C**** The initial momentum and energy of the nucleon. real pnuc(4) C**** The number of tries to get a good decay. real ntry C**** A temporary momentum variable real ptmp(4) real ranf C**** Call partnuc once with no partciles. This makes sure the data blocks C are initialized properly. call partnuc( 0, anuc, 0, 0, 0, 0, 0, 0, $ 0, 0, 0, 0, 0, 0, 0, 0) ntry = 0 10 continue ntry = ntry + 1 if (ntry.gt.50) stop c**** initialize the momenta and the masses to zero for the primary particles do i1=1,20 ppm(i1)=0. do i2=1,4 ppr(i2,i1)=0. enddo chh(i1) = 0. enddo nmom = 0 C**** Set the nucleon initial momentum and energy. Place the energy C available to the decay in AMINT do i1 = 1,3 pnuc(i1) = 0.0 enddo if (np(1).eq.0) then pnuc(4) = amn nc = 0 else pnuc(4) = amp nc = 1 endif if (ifer.gt.0) then call fermid(nc,pnuc,AMINT) else AMINT = pnuc(4) nc = -1 endif C**** Fill ppm with the masses. nmom = 0 do i1 = 2,npar nmom = nmom + 1 pid(nmom) = np(i1) if (np(i1).eq.0) then C**** neutron ppm(nmom) = amn chh(nmom) = 0 else if (abs(np(i1)).eq.1) then C**** proton ppm(nmom) = amp if (np(i1).gt.0) then chh(nmom) = 1.0 else chh(nmom) = -1.0 endif else if (abs(np(i1)).eq.2) then C**** neutrino ppm(nmom) = 0.0 chh(nmom) = 0 else if (abs(np(i1)).eq.3) then C**** electron ppm(nmom) = amel if (np(i1).gt.0) then chh(nmom) = 1.0 else chh(nmom) = -1.0 endif else if (abs(np(i1)).eq.4) then C**** muon ppm(nmom) = ammu if (np(i1).gt.0) then chh(nmom) = 1.0 else chh(nmom) = -1.0 endif else if (abs(np(i1)).eq.5) then C**** pi zero ppm(nmom) = ampo chh(nmom) = 0 else if (abs(np(i1)).eq.6) then C**** charged pi ppm(nmom) = ampc if (np(i1).gt.0) then chh(nmom) = 1.0 else chh(nmom) = -1.0 endif else if (abs(np(i1)).eq.7) then C**** eta ppm(nmom) = ameta chh(nmom) = 0 else if (abs(np(i1)).eq.8) then C**** rho zero call ResonanceMass(amrho,0.1515,ppm(nmom)) chh(nmom) = 0 else if (abs(np(i1)).eq.9) then C**** charged rho call ResonanceMass(amrho,0.1515,ppm(nmom)) if (np(i1).gt.0) then chh(nmom) = 1.0 else chh(nmom) = -1.0 endif else if (abs(np(i1)).eq.10) then C**** omega ppm(nmom) = amomg chh(nmom) = 0 else if (abs(np(i1)).eq.11) then C**** K zero ppm(nmom) = amko chh(nmom) = 0 C**** Change the K zero into a long or a short. if (ranf().lt.0.5) then pid(nmom) = +12 else pid(nmom) = -12 endif else if (abs(np(i1)).eq.12) then C**** K long or short ppm(nmom) = amko chh(nmom) = 0 else if (abs(np(i1)).eq.13) then C**** charged K ppm(nmom) = amkc if (np(i1).gt.0) then chh(nmom) = 1.0 else chh(nmom) = -1.0 endif else if (abs(np(i1)).eq.14) then C**** K* zero call ResonanceMass(amkso,0.0505,ppm(nmom)) chh(nmom) = 0 C**** Change the K* zero into a long or a short. if (ranf().lt.0.5) then pid(nmom) = +15 else pid(nmom) = -15 endif else if (abs(np(i1)).eq.15) then C**** K* long or short call ResonanceMass(amkso,0.0505,ppm(nmom)) chh(nmom) = 0 else if (abs(np(i1)).eq.16) then C**** charged K* call ResonanceMass(amksc,0.0498,ppm(nmom)) if (np(i1).gt.0) then chh(nmom) = 1.0 else chh(nmom) = -1.0 endif else if (abs(np(i1)).eq.17) then C**** gamma ray. ppm(nmom) = 0 chh(nmom) = 1 endif enddo C**** Check that there is enough energy in the decay to produce the particles. r1 = AMINT do i1 = 1,nmom r1 = r1 - ppm(i1) enddo if (r1.lt.0.0) then goto 10 endif C**** Decay the nucleon. if (nmom.eq.2) then C**** This is a two body mode. call twob(AMINT,ppm(1),ppm(2),pnuc,ppr) else if (nmom.eq.3) then C**** This is a three body mode. call threeb(AMINT,ppm(1),ppm(2),ppm(3),pnuc,ppr) else type *, 'PROTON:: Only two and three body decays allowed.' stop endif C**** Write the decaying nucleon to the output. write(6,'('' $ INCOMING '',I3,F12.6,3F10.6,F10.1)'),NP(1),AMINT, $ pnuc(1),pnuc(2),pnuc(3), 0.0 C**** Write the decay products to the output. do i1 = 1,nmom write(6,'('' $ OUTGOING '',I3,F12.6,3F10.6,I4)'),pid(i1), ppr(4,i1), $ ppr(1,i1), ppr(2,i1), ppr(3,i1), 0 enddo C**** Find the position of the proton when it decayed. icont = 0 call nucstp(start_point(1,1),icont,imode) do i1 = 2,nmom do i2 = 1,3 start_point(i2,i1) = start_point(i2,1) enddo enddo C**** Track the hadrons out of the nucleus. call outinit() do while (nmom.gt.0) nmom = nmom - 1 i1 = abs(pid(nmom+1)) if (i1.eq.2 .or. i1.eq.3 .or. i1.eq.4. or. i1.eq.17) then C**** Particle is not a hadron. call outparticle(pid(nmom+1), ppm(nmom+1), $ chh(nmom+1), ppr(1,nmom+1), ppr(4,nmom+1)) else C**** Particle is a hadron so prepare for tracking inside the nucleus. do i1=1,3 start(i1)=0. stpt(i1,1)=start_point(i1,nmom+1) end do icont = 1 nin = 1 ei(nin) = ppr(4,nmom+1) pi(1,nin) = ppr(1,nmom+1) pi(2,nin) = ppr(2,nmom+1) pi(3,nin) = ppr(3,nmom+1) ui(nin) = ppm(nmom+1) chin(nin) = chh(nmom+1) C**** Track the hadrons in the nucleus and a trackable particle if (nc.ge.0 $ .and. (abs(pid(nmom+1)).eq.5 $ .or.abs(pid(nmom+1)).eq.6 $ .or.abs(pid(nmom+1)).eq.7 $ .or.abs(pid(nmom+1)).eq.10 $ .or.abs(pid(nmom+1)).eq.11 $ .or.abs(pid(nmom+1)).eq.12 $ .or.abs(pid(nmom+1)).eq.13 )) then call partnuc(isetn, anuc, stpt, ei, pi, ui, chin, nin, $ eo, po, uo, cho, start, decp, imode, icont) C**** nin is the number of output particles after partnuc returns C**** The particle changed id. Place the new particle on the C stack and track it from here. The new particle WILL be a pion. if (abs(uo(1)-ppm(nmom+1)).gt.0.01.and. uo(1).gt.1.0e-4) then if (abs(cho(1)).lt.0.5) then call addparticle(5,AMPO,cho(1),decp) else call addparticle(6,AMPC,cho(1),decp) endif do i1 = 1,3 ppr(i1,nmom) = po(i1,1) enddo ppr(4,nmom) = eo(1) endif else do i1 = 1,nin eo(i1) = ei(i1) uo(i1) = ui(i1) cho(i1) = chin(i1) do i2 = 1,3 po(i2,i1) = pi(i2,i1) enddo enddo endif C**** Loop over all of the output particles. do i1 = 1,nin if (abs(pid(nmom+1)).eq.7) then C**** Decay an eta. call etadecay(uo(1),po(1,1),eo(1),decp) else if (abs(pid(nmom+1)).eq.8) then C**** Decay a rho zero. call rhozerodecay(uo(1),po(1,1),eo(1),decp) else if (abs(pid(nmom+1)).eq.9) then C**** Decay a charged rho. call rhochargedecay(uo(1),po(1,1),eo(1),chh(nmom+1),decp) else if (abs(pid(nmom+1)).eq.10) then C**** Decay an omega. call omegadecay(uo(1),po(1,1),eo(1),decp) else if (abs(pid(nmom+1)).eq.14 $ .or.abs(pid(nmom+1)).eq.15) then C**** Decay a K* zero or long/short call Kstarzerodecay(uo(1), po(1,1),eo(1), pid(nmom+1),decp) else if (abs(pid(nmom+1)).eq.16) then C**** Decay a K* plus/minus call Kstarchargedecay(uo(1),po(1,1),eo(1), $ chh(nmom+1),decp) else if (uo(1).gt.1.0e-4) then C**** Move the particle into the output particle stack. call outparticle(pid(nmom+1),uo(1),cho(1),po(1,1),eo(1)) endif enddo endif enddo call outtoprimary() C**** If there has been a charge exchange in partnuc then make sure the C correct mass is attached to the particle. do i1 = 1,nmom if (abs(ppm(i1)-ampc).lt.0.01 $ .and. abs(abs(chh(i1))-1.0).lt.0.5) ppm(i1) = AMPC if (abs(ppm(i1)-ampo).lt.0.01 $ .and. abs(chh(i1)).lt.0.5) ppm(i1) = AMPO enddo return end SUBROUTINE ResonanceMass(Mass,Gamma,vmass) C**** Do a britt-wigner peak. implicit none real r1 integer i1 C**** The mass of the resonance. real mass C**** The width of the resonance. real gamma C**** The mass of the particle real vmass C**** The peak probablities. integer nbin parameter (nbin=30) real probi(nbin+1), prob(nbin) C**** The minimum x value, and the step size. real xmin, step parameter (xmin=0.0,step=0.067) C**** The routine has not been called logical not_called data not_called /.true./ real prbin real ranf if (not_called) then not_called = .false. r1 = -step/2.0 do i1 = 1,nbin r1 = r1 + step prob(i1)=1.0/((2*r1)**2+1.0) enddo call cfd(probi,nbin,prob) endif r1 = ranf() r1 = prbin(probi,nbin,xmin,step,r1) if (ranf().gt.0.5) then vmass = mass+r1*gamma else vmass = mass-r1*gamma endif return end subroutine addparticle(id,mass,chg,pos) C******************************************************** C Add a particle to momentum common block implicit none C**** The particle id integer id C**** The particle mass. real mass C**** The particle charge. real chg C**** The particle nuclear position. real pos(3) C**** The return of the starting position. real start_point(3,20) common/protonstart/ start_point C**************************************************************** C @(#)momentum.cdk 1.2 modified on 1/12/93 C Include the information about the primary particles to be tracked. C**** The number of momenta. integer nmom C**** The particle 4 momentum. real ppr(4,20) C**** The particle masses real ppm(20) C**** The particle charges real chh(20) C**** The particle id. integer pid(20) COMMON/MOM/ nmom,ppr,ppm,chh,pid C***** Gamma ray information real ppg(4,20) integer ngam common /gamm1/ ppg,ngam nmom = nmom + 1 pid(nmom) = id ppm(nmom) = mass chh(nmom) = chg start_point(1,nmom) = pos(1) start_point(2,nmom) = pos(2) start_point(3,nmom) = pos(3) return end subroutine outparticle(id,mass,chg,mom,enr) C******************************************************** C Add a particle to output stack implicit none integer i1, i2 C**** The particle id integer id C**** The particle mass. real mass C**** The particle charge. real chg C**** The momentum of the particle real mom(3) C**** The energy of the particle real enr C**************************************************************** C @(#)momentum.cdk 1.2 modified on 1/12/93 C Include the information about the primary particles to be tracked. C**** The number of momenta. integer nmom C**** The particle 4 momentum. real ppr(4,20) C**** The particle masses real ppm(20) C**** The particle charges real chh(20) C**** The particle id. integer pid(20) COMMON/MOM/ nmom,ppr,ppm,chh,pid C***** Gamma ray information real ppg(4,20) integer ngam common /gamm1/ ppg,ngam C**** the output particles integer nout real mout(20), pout(4,20), cout(20) integer iout(20) nout = nout + 1 iout(nout) = id mout(nout) = mass cout(nout) = chg do i1 = 1,3 pout(i1,nout) = mom(i1) enddo pout(4,nout) = enr return entry outinit() nout = 0 return entry outtoprimary() nmom = 0.0 do i1 = nout, 1, -1 if (iout(i1).eq.17) then call putgam(pout(1,i1)) else nmom = nmom + 1 ppm(nmom) = mout(i1) chh(nmom) = cout(i1) pid(nmom) = iout(i1) do i2 = 1,4 ppr(i2,nmom) = pout(i2,i1) enddo endif enddo return end C**** Decay an eta. subroutine etadecay(mass,pmom,enr,decp) implicit none integer i1 real r1, ranf C*************************************************** C @(#)masses.cdk 1.2 modified on 12/30/92 C The particle masses C PROTON - AMP C NEUTRON - AMN C LAMBDA - AML C SIGMA - AMS C ELECTRON - AMEL C MUON - AMMU C PI 0 - AMPO C PI +/- - AMPC C ETA = AMETA C OMEGA = AMOM C RHO = AMRHO C K 0 = AMKO C K +- = AMKC C K* 0 = AMKSO C K* +- = AMKSC C*** The leptons real AMEL, AMMU C*** The baryons real AMP, AMN, AML, AMS C*** The mesons real AMPO, AMPC, AMETA, AMOMG, AMRHO C*** The strange mesons. real AMKO, AMKC, AMKSO, AMKSC COMMON/MASSES/AMEL,AMMU, $ AMP, AMN, AML, AMS, $ AMPO, AMPC, AMETA, AMRHO, AMOMG, $ AMKO, AMKC, AMKSO, AMKSC C**************************************************************** C @(#)momentum.cdk 1.2 modified on 1/12/93 C Include the information about the primary particles to be tracked. C**** The number of momenta. integer nmom C**** The particle 4 momentum. real ppr(4,20) C**** The particle masses real ppm(20) C**** The particle charges real chh(20) C**** The particle id. integer pid(20) COMMON/MOM/ nmom,ppr,ppm,chh,pid C***** Gamma ray information real ppg(4,20) integer ngam common /gamm1/ ppg,ngam C**** The mass of the particle. real mass, mtmp C**** The momentum of the particle. real pmom(3), enr, ptmp(4) C**** The position in the nucleus of the decay. real decp(3) mtmp = mass do i1 = 1,3 ptmp(i1) = pmom(i1) enddo ptmp(4) = enr r1 = 99.3*ranf() if (r1.lt.38.9) then C gg call addparticle(17,0.0,0.0,decp) call addparticle(17,0.0,0.0,decp) call twob(mtmp,ppm(nmom-1),ppm(nmom),ptmp,ppr(1,nmom-1)) else if (r1.lt.70.8) then C p0p0p0 call addparticle(5,AMPO,0.0,decp) call addparticle(5,AMPO,0.0,decp) call addparticle(5,AMPO,0.0,decp) call threeb(mtmp,ppm(nmom-2),ppm(nmom-1),ppm(nmom), $ ptmp,ppr(1,nmom-2)) else if (r1.lt.94.4) then C p+p-p0 call addparticle(6,AMPC,1.0,decp) call addparticle(-6,AMPC,-1.0,decp) call addparticle(5,AMPO,0.0,decp) call threeb(mtmp,ppm(nmom-2),ppm(nmom-1),ppm(nmom), $ ptmp,ppr(1,nmom-2)) else C p+p-g call addparticle(6,AMPC,1.0,decp) call addparticle(-6,AMPC,-1.0,decp) call addparticle(17,0.0,0.0,decp) call threeb(mtmp,ppm(nmom-2),ppm(nmom-1),ppm(nmom), $ ptmp,ppr(1,nmom-2)) endif return end C**** Decay a rhozero subroutine rhozerodecay(mass,pmom,enr,decp) implicit none integer i1 real r1, ranf C*************************************************** C @(#)masses.cdk 1.2 modified on 12/30/92 C The particle masses C PROTON - AMP C NEUTRON - AMN C LAMBDA - AML C SIGMA - AMS C ELECTRON - AMEL C MUON - AMMU C PI 0 - AMPO C PI +/- - AMPC C ETA = AMETA C OMEGA = AMOM C RHO = AMRHO C K 0 = AMKO C K +- = AMKC C K* 0 = AMKSO C K* +- = AMKSC C*** The leptons real AMEL, AMMU C*** The baryons real AMP, AMN, AML, AMS C*** The mesons real AMPO, AMPC, AMETA, AMOMG, AMRHO C*** The strange mesons. real AMKO, AMKC, AMKSO, AMKSC COMMON/MASSES/AMEL,AMMU, $ AMP, AMN, AML, AMS, $ AMPO, AMPC, AMETA, AMRHO, AMOMG, $ AMKO, AMKC, AMKSO, AMKSC C**************************************************************** C @(#)momentum.cdk 1.2 modified on 1/12/93 C Include the information about the primary particles to be tracked. C**** The number of momenta. integer nmom C**** The particle 4 momentum. real ppr(4,20) C**** The particle masses real ppm(20) C**** The particle charges real chh(20) C**** The particle id. integer pid(20) COMMON/MOM/ nmom,ppr,ppm,chh,pid C***** Gamma ray information real ppg(4,20) integer ngam common /gamm1/ ppg,ngam C**** The mass of the particle. real mass, mtmp C**** The momentum of the particle. real pmom(3), enr, ptmp(4) C**** The position in the nucleus of the decay. real decp(3) mtmp = mass do i1 = 1,3 ptmp(i1) = pmom(i1) enddo ptmp(4) = enr C p+p- call addparticle(6,AMPC,1.0,decp) call addparticle(-6,AMPC,-1.0,decp) call twob(mtmp,ppm(nmom-1),ppm(nmom),ptmp,ppr(1,nmom-1)) return end C**** Decay a charged rho. subroutine rhochargedecay(mass,pmom,enr,charge,decp) implicit none integer i1 real r1, ranf C*************************************************** C @(#)masses.cdk 1.2 modified on 12/30/92 C The particle masses C PROTON - AMP C NEUTRON - AMN C LAMBDA - AML C SIGMA - AMS C ELECTRON - AMEL C MUON - AMMU C PI 0 - AMPO C PI +/- - AMPC C ETA = AMETA C OMEGA = AMOM C RHO = AMRHO C K 0 = AMKO C K +- = AMKC C K* 0 = AMKSO C K* +- = AMKSC C*** The leptons real AMEL, AMMU C*** The baryons real AMP, AMN, AML, AMS C*** The mesons real AMPO, AMPC, AMETA, AMOMG, AMRHO C*** The strange mesons. real AMKO, AMKC, AMKSO, AMKSC COMMON/MASSES/AMEL,AMMU, $ AMP, AMN, AML, AMS, $ AMPO, AMPC, AMETA, AMRHO, AMOMG, $ AMKO, AMKC, AMKSO, AMKSC C**************************************************************** C @(#)momentum.cdk 1.2 modified on 1/12/93 C Include the information about the primary particles to be tracked. C**** The number of momenta. integer nmom C**** The particle 4 momentum. real ppr(4,20) C**** The particle masses real ppm(20) C**** The particle charges real chh(20) C**** The particle id. integer pid(20) COMMON/MOM/ nmom,ppr,ppm,chh,pid C***** Gamma ray information real ppg(4,20) integer ngam common /gamm1/ ppg,ngam C**** The mass of the particle. real mass, mtmp C**** The momentum of the particle. real pmom(3), enr, ptmp(4) C**** The charge of the particle real charge, ctmp C**** The position in the nucleus of the decay. real decp(3) mtmp = mass ctmp = charge do i1 = 1,3 ptmp(i1) = pmom(i1) enddo ptmp(4) = enr C p+-p0 if (ctmp.gt.0.0) then call addparticle(6,AMPC,1.0,decp) else call addparticle(-6,AMPC,-1.0,decp) endif call addparticle(5,AMPO,0.0,decp) call twob(mtmp,ppm(nmom-1),ppm(nmom),ptmp,ppr(1,nmom-1)) return end subroutine omegadecay(mass,pmom,enr,decp) implicit none integer i1 real r1, ranf C*************************************************** C @(#)masses.cdk 1.2 modified on 12/30/92 C The particle masses C PROTON - AMP C NEUTRON - AMN C LAMBDA - AML C SIGMA - AMS C ELECTRON - AMEL C MUON - AMMU C PI 0 - AMPO C PI +/- - AMPC C ETA = AMETA C OMEGA = AMOM C RHO = AMRHO C K 0 = AMKO C K +- = AMKC C K* 0 = AMKSO C K* +- = AMKSC C*** The leptons real AMEL, AMMU C*** The baryons real AMP, AMN, AML, AMS C*** The mesons real AMPO, AMPC, AMETA, AMOMG, AMRHO C*** The strange mesons. real AMKO, AMKC, AMKSO, AMKSC COMMON/MASSES/AMEL,AMMU, $ AMP, AMN, AML, AMS, $ AMPO, AMPC, AMETA, AMRHO, AMOMG, $ AMKO, AMKC, AMKSO, AMKSC C**************************************************************** C @(#)momentum.cdk 1.2 modified on 1/12/93 C Include the information about the primary particles to be tracked. C**** The number of momenta. integer nmom C**** The particle 4 momentum. real ppr(4,20) C**** The particle masses real ppm(20) C**** The particle charges real chh(20) C**** The particle id. integer pid(20) COMMON/MOM/ nmom,ppr,ppm,chh,pid C***** Gamma ray information real ppg(4,20) integer ngam common /gamm1/ ppg,ngam C**** The mass of the particle. real mass, mtmp C**** The momentum of the particle. real pmom(3), enr, ptmp(4) C**** The position in the nucleus of the decay. real decp(3) mtmp = mass do i1 = 1,3 ptmp(i1) = pmom(i1) enddo ptmp(4) = enr r1 = 99.5*ranf() if (r1.lt.88.8) then C p+p-p0 call addparticle(+6,AMPC,1.0,decp) call addparticle(6,AMPC,-1.0,decp) call addparticle(5,AMPO,0.0,decp) call threeb(mtmp,ppm(nmom-2),ppm(nmom-1),ppm(nmom), $ ptmp,ppr(1,nmom-2)) else if (r1.lt.97.3) then C p0g call addparticle(5,AMPO,0.0,decp) call addparticle(17,0.0,0.0,decp) call twob(mtmp,ppm(nmom-1),ppm(nmom),ptmp,ppr(1,nmom-1)) else C p+p- call addparticle(6,AMPC,+1.0,decp) call addparticle(-6,AMPC,-1.0,decp) call twob(mtmp,ppm(nmom-1),ppm(nmom),ptmp,ppr(1,nmom-1)) endif return end subroutine Kstarzerodecay(mass,pmom,enr,id,decp) implicit none integer i1 real r1, ranf C*************************************************** C @(#)masses.cdk 1.2 modified on 12/30/92 C The particle masses C PROTON - AMP C NEUTRON - AMN C LAMBDA - AML C SIGMA - AMS C ELECTRON - AMEL C MUON - AMMU C PI 0 - AMPO C PI +/- - AMPC C ETA = AMETA C OMEGA = AMOM C RHO = AMRHO C K 0 = AMKO C K +- = AMKC C K* 0 = AMKSO C K* +- = AMKSC C*** The leptons real AMEL, AMMU C*** The baryons real AMP, AMN, AML, AMS C*** The mesons real AMPO, AMPC, AMETA, AMOMG, AMRHO C*** The strange mesons. real AMKO, AMKC, AMKSO, AMKSC COMMON/MASSES/AMEL,AMMU, $ AMP, AMN, AML, AMS, $ AMPO, AMPC, AMETA, AMRHO, AMOMG, $ AMKO, AMKC, AMKSO, AMKSC C**************************************************************** C @(#)momentum.cdk 1.2 modified on 1/12/93 C Include the information about the primary particles to be tracked. C**** The number of momenta. integer nmom C**** The particle 4 momentum. real ppr(4,20) C**** The particle masses real ppm(20) C**** The particle charges real chh(20) C**** The particle id. integer pid(20) COMMON/MOM/ nmom,ppr,ppm,chh,pid C***** Gamma ray information real ppg(4,20) integer ngam common /gamm1/ ppg,ngam C**** The mass of the particle. real mass, mtmp C**** The momentum of the particle. real pmom(3), enr, ptmp(4) C**** The id. integer id, tid C**** The position in the nucleus of the decay. real decp(3) mtmp = mass tid = id do i1 = 1,3 ptmp(i1) = pmom(i1) enddo ptmp(4) = enr C**** Decay a K* zero or Decay a K* long/short if (abs(tid).eq.14) stop if (ranf().lt.0.5) then C K0p0 if (tid.gt.0) then tid = 12 else tid = -12 endif call addparticle(tid,AMKO,0.0,decp) call addparticle(5,AMPO,0.0,decp) call twob(mtmp,ppm(nmom-1),ppm(nmom),ptmp,ppr(1,nmom-1)) else C K+p- call addparticle(+13,AMKC,+1.0,decp) call addparticle(5,AMPO,0.0,decp) call twob(mtmp,ppm(nmom-1),ppm(nmom),ptmp,ppr(1,nmom-1)) endif return end subroutine Kstarchargedecay(mass,pmom,enr,charge,decp) implicit none integer i1 real r1, ranf C*************************************************** C @(#)masses.cdk 1.2 modified on 12/30/92 C The particle masses C PROTON - AMP C NEUTRON - AMN C LAMBDA - AML C SIGMA - AMS C ELECTRON - AMEL C MUON - AMMU C PI 0 - AMPO C PI +/- - AMPC C ETA = AMETA C OMEGA = AMOM C RHO = AMRHO C K 0 = AMKO C K +- = AMKC C K* 0 = AMKSO C K* +- = AMKSC C*** The leptons real AMEL, AMMU C*** The baryons real AMP, AMN, AML, AMS C*** The mesons real AMPO, AMPC, AMETA, AMOMG, AMRHO C*** The strange mesons. real AMKO, AMKC, AMKSO, AMKSC COMMON/MASSES/AMEL,AMMU, $ AMP, AMN, AML, AMS, $ AMPO, AMPC, AMETA, AMRHO, AMOMG, $ AMKO, AMKC, AMKSO, AMKSC C**************************************************************** C @(#)momentum.cdk 1.2 modified on 1/12/93 C Include the information about the primary particles to be tracked. C**** The number of momenta. integer nmom C**** The particle 4 momentum. real ppr(4,20) C**** The particle masses real ppm(20) C**** The particle charges real chh(20) C**** The particle id. integer pid(20) COMMON/MOM/ nmom,ppr,ppm,chh,pid C***** Gamma ray information real ppg(4,20) integer ngam common /gamm1/ ppg,ngam C**** The mass of the particle. real mass, mtmp C**** The momentum of the particle. real pmom(3), enr, ptmp(4) C**** The charge of the particle real charge, ctmp C**** The position in the nucleus of the decay. real decp(3) mtmp = mass ctmp = charge do i1 = 1,3 ptmp(i1) = pmom(i1) enddo ptmp(4) = enr if (ranf().lt.0.5) then C K0p+- if (ctmp.gt.0) then i1 = +6 else i1 = -6 endif call addparticle(i1,AMPC,ctmp,decp) if (ranf().gt.0.5) then i1 = +12 else i1 = -12 endif call addparticle(i1,AMKO,0.0,decp) call twob(mtmp,ppm(nmom-1),ppm(nmom),ptmp,ppr(1,nmom-1)) else C K+-p0 if (ctmp.gt.0) then i1 = +13 else i1 = -13 endif call addparticle(i1,AMKC,ctmp,decp) call addparticle(5,AMPO,0.0,decp) call twob(mtmp,ppm(nmom-1),ppm(nmom),ptmp,ppr(1,nmom-1)) endif return end