      PROGRAM MUON
*
*             Calculate cosmic ray flux and throw event for
*     a generic underground detector
*
*
*     Contact:  Alfred Tang (Kansas State University)
*               atang@phys.ksu.edu
*               1/10/2007
*
*     Parameters:
*     ==========
*     nph            number of grid points along phi
*     ncz            number of grid points along cos(theta)
*     iph            number of search grid points along phi
*     jcz            number of search grid points along cos(theta)
*
*     Specification:-
*     =============
*     This code uses MUSIC to compute transport from a generic mountain
*     surface whose toplogy is specified by the data files labxyz.dat and
*     border.dat to a generic underground lab centered at the origin.
*     As an example, an upright cylindrical detector is assumed.  For other
*     detector geometry, a section of the code needs to be modified.
*     The neutron rate output is left there for historical reason.
*     Do not take this neutron rate too seriously.
*
*     Program Notes:-
*     =============
*     border.dat     input file containing the border of the hill profile
*     labxyz.dat     input file containing the lattice points of the hill
*                    profile
*     edbs.dat       output file containing the average outputs
*     edist.dat      output file containing raw data for post-processing
*
*     The matrix elements ha(nph,ncz,i) with i=1,2 stores slant
*     depth in cm.
*
*     base = the offset corresponding to the center of the detector
*            above sealevel in meters
*     h0 = height of the tank in cm
*     r0 = radius of the tank in cm
*     hi = height of the inner region in cm
*     ri = radius of the inner region in cm
*     rm = log10(muon rest mass)
*     rho = rock density

      implicit real*8 (a-h,o-z)
      parameter (pi=3.1415926535897932384626433)
      parameter (rho=2.65)
      parameter (base=0.)
      parameter (rm=-0.97469413)
*     The parameters of an upright cylindrical detector
      parameter (h0=245.8)
      parameter (r0=115.)
      parameter (hi=230.)
      parameter (ri=100.)
      parameter (hhc=350.)
      parameter (rrc=350.)

      integer ncz,nph,i,j,m,n,iph,jcz,il,iu,jl,ju,ih,istart,found,i1,i2
      integer p,m0
      parameter (nph=100)
      parameter (ncz=100)
      parameter (iph=40)
      parameter (jcz=40)
      double precision ha(nph,ncz,3),ctm(nph,2)
      integer nb(nph,2)
      DOUBLE PRECISION CTMIN, CTMAX,lmin,lmax,fac
      common/le/lmin,lmax
      PARAMETER (CTMAX = 1.0)  
      real*4 rcz,rp,rq,rh,rr

      nthrows=10000

      call initialize_music
      iranlux=1
      iranlux1=1
      call rluxgo(3,iranlux,0,0)
      call rmarin(iranlux1,0,0)

      x0=0.
      y0=0.
      z0=0.
      ttime0=0.
      kmu=0
      eemu=0.
      rmu=0.
      xmu=0.
      ymu=0.
      zmu=0.
      themu=0.
      phimu=0.
      weight=0.
      total_wt=0.
      total_rate=0.
      total_rate2=0.
      theta=0.
      the=0.
      phi=0.
      ph=0.
      ih=0
      icount=0
      a=r0**2*pi+2.*pi*r0*h0
      dhi=(h0-hi)/2.
      rmin=1.e20

      open(unit=10,file='border.dat',
     *form='formatted',status='old')
      open(unit=11,file='labxyz.dat',
     *form='formatted',status='old')
      open(unit=12,file='edist.dat',
     *form='formatted')
      open(unit=13,file='edbs.dat',
     *form='formatted')
      read(11,*) omega1,omega2,omega3,omega4
      omega=omega1+omega2+omega3+omega4
      read(11,*) ctmin
      write(12,*) omega

      do 19 i=1,nph
         nb(i,1)=0
         nb(i,2)=0
         ctm(i,1)=0.
         ctm(i,2)=0.
 19   continue

 20   read(10,*,end=21)phi,cz
      i=int(phi/2./pi*nph)+1
      j=int((cz-ctmin)/(1.-ctmin)*ncz)+1
      nb(i,1)=nb(i,1)+j
      nb(i,2)=nb(i,2)+1
      ctm(i,1)=ctm(i,1)+cz
      ctm(i,2)=ctm(i,2)+1.
      goto 20
 21   close(10)

      found=0
      ilast=1
      do 22 i=1,nph
         if(nb(i,2).ne.0) then
            nb(i,1)=nb(i,1)/nb(i,2)
            ctm(i,1)=ctm(i,1)/ctm(i,2)
            ilast=i
         endif
      if(found.ne.1.and.nb(i,2).ne.0) then
         istart=i
         found=1
      endif
 22   continue

      i1=istart
      do 23 i=1,nph
         if(nb(i,2).ne.0) i1=i
         if(i.le.istart) then
            i1=ilast
            i0=ilast-nph
            i2=istart
            nb(i,1)=(i-i0)/(i2-i0)*(nb(i2,1)-nb(i1,1))+nb(i1,1)
            ctm(i,1)=(i-i0)/(i2-i0)*(ctm(i2,1)-ctm(i1,1))+ctm(i1,1)
         else
         if(nb(i,2).eq.0) then
            j=i
 24         j=j+1
            if(nb(j,2).eq.0.and.j.lt.nph) goto 24
            if(i.eq.nph) i2=i+istart
            if(i.lt.nph) i2=j
            nb(i,1)=(i-i1)/(i2-i1)*(nb(i2,1)-nb(i1,1))+nb(i1,1)
            ctm(i,1)=(i-i1)/(i2-i1)*(ctm(i2,1)-ctm(i1,1))+ctm(i1,1)
         endif
         endif
 23   continue

      do 3 i=1,nph
         do 4 j=1,ncz
            ha(i,j,1)=0.
            ha(i,j,2)=0.
            ha(i,j,3)=0.
 4       continue
 3    continue

 12   read (11,*,end=13) x0,y0,z0
      z0=z0-base
      if(z0.lt.0.) z0=0.
      r=dsqrt(x0**2+y0**2+z0**2)
      cx=x0/r
      cy=y0/r
      cz=z0/r
      IF(cx.NE.0.) THEN
         phi=datan(cy/cx)
         IF(cx.LT.0.) phi=pi+phi
      END IF
      IF(cx.EQ.0.) THEN
         phi=pi/2.
         IF(cy.LT.0.) phi=pi*3./2.
      END IF
      IF(phi.GT.pi*2.) phi=-pi*2.+phi
      IF(phi.LT.0.) phi=phi+pi*2.
      i=int(phi/2./pi*nph)+1
      j=int((cz-ctmin)/(1.-ctmin)*ncz)+1
      ha(i,j,1)=ha(i,j,1)+r
      ha(i,j,2)=ha(i,j,2)+r
      ha(i,j,3)=ha(i,j,3)+1.
      go to 12
 13   close(11)

      do 1 i=1,nph
         do 2 j=1,ncz
            if(ha(i,j,3).ne.0.) then
               ha(i,j,1)=ha(i,j,1)/ha(i,j,3)
               ha(i,j,2)=ha(i,j,2)/ha(i,j,3)
               if(ha(i,j,1).lt.rmin) rmin=ha(i,j,1)
            endif
            if(ha(i,j,3).gt.1.) ih=ih+1
 2       continue
 1    continue
      print*,'number of overlapped lattice points: ',ih
      print*,'rmin (cm): ',rmin
      print*,'suggested low muon energy threshold (GeV): ',
     $ 500.*(exp(.35*rmin/100000.*2.65)-1.)

      print*,'Processing lattice sites ......'

      do 5 i=1,nph
         do 6 j=1,ncz
            if(j.ge.nb(i,1)) then
            test=0.
            tempmax=0.
            il=i-iph
            ju=j+jcz
            do 7 m0=1,2*iph+1
               m=m0-1+il
               p=m
               if(m.lt.1) p=nph+m
               if(m.gt.nph) p=m-nph
               do 8 n=nb(p,1),ju
                  if(n.le.ncz) then
                  ph1=i*2.*pi/nph
                  th1=j*.5*pi/ncz
                  ph2=p*2.*pi/nph
                  th2=n*.5*pi/ncz
                  if(ha(p,n,3).gt.test) test=ha(p,n,3)
                   temp=dsin(th1)*dcos(ph1)*dsin(th2)*dcos(ph2)
     $                  +dsin(th1)*dsin(ph1)*dsin(th2)*dsin(ph2)
     $                  +dcos(th1)*dcos(th2)
                   if(temp.ge.tempmax.and.ha(p,n,3).ne.0.) then
                      tempmax=temp
                      ha(i,j,1)=ha(p,n,2)
                   endif
                   endif
 8             continue
 7          continue
            if(test.eq.0.) then
               print*,"error: grid too small"
               if(m.eq.0) print*,i,j,m0,n0,m,n,p
               stop
            endif
            endif
 6       continue
 5    continue
      print*,'Begin simulation ....................'

      DO N = 1,NTHROWS
      call ranlux(rp,1)
      PHI = rp*2.*pi
      i=int(phi/2./pi*nph)+1
      call ranlux(rcz,1)
      cz = ctm(i,1) + rcz*(CTMAX-ctm(i,1))
      j=int((cz-ctmin)/(1.-ctmin)*ncz)+1
      theta=dacos(cz)
* Begin: simulate the effective area of the upright cylindrical detector
      call ranlux(rq,1)
      q=rq*pi
      call ranlux(rh,1)
      h=rh*hi+dhi
      call ranlux(rr,1)
      r=rr*ri
      dh=h0-h
      del=(r0-r)/dtan(theta)
      if(del.lt.dh) then
         xi=pi-q-dasin(r*dsin(q)/r0)
         r0r=dsin(theta)*dcos(q-pi/2.)*dcos(pi/2.-xi)
     $       +dsin(theta)*dsin(q-pi/2.)*dsin(pi/2.-xi)
      else
         r0r=dcos(theta)
      endif
* End
       call muon_cosmic_flux_surface
     $        (emu0,cz,weight,flux)
       r=ha(i,j,1)
* Resume muon transport
       cz0=cz
       cx0=dsin(theta)*dcos(phi)
       cy0=dsin(theta)*dsin(phi)
       x=r*cx0
       y=r*cy0
       z=r*cz0
       cx=-cx0
       cy=-cy0
       cz=-cz0
       emu=emu0
       ttime=ttime0
       depth=r
       call muon_transport(x,y,z,cx,cy,cz,emu,depth,ttime)
       theta=dacos(cz)
       IF(cx.NE.0.) THEN
          phi=datan(cy/cx)
          IF(cx.LT.0.) phi=pi+phi
       END IF
       IF(cx.EQ.0.) THEN
          phi=pi/2.
          IF(cy.LT.0.) phi=pi*3./2.
       END IF
       IF(phi.GT.pi*2.) phi=-pi*2.+phi
       IF(phi.LT.0.) phi=phi+pi*2.
       the = theta * 180. / pi
       ph = phi * 180. / pi

       if(emu.gt.0.) then
          kmu=kmu+1
          write(12,*)emu,flux,theta,phi
          eemu=eemu+emu*weight
          total_wt=total_wt+weight
          total_rate=total_rate+r0r
          total_rate2=total_rate2+weight*r0r
          xmu=xmu+x
          ymu=ymu+y
          zmu=zmu+z
          themu=themu+the
          phimu=phimu+ph
          rmu=sqrt(x*x+y*y)+rmu
       end if

      icount=icount+1
      IF (MOD(icount,nthrows/5).EQ.0)
     $ WRITE(6,*) 'PROCESSED ',icount,' THROWS.'

      ENDDO

      if(kmu.gt.0) then
         spmu=1.*kmu/nthrows
         eemu=eemu/total_wt
         xmu=xmu/kmu
         ymu=ymu/kmu
         zmu=zmu/kmu
         themu=themu/kmu
         phimu=phimu/kmu
         rmu=rmu/kmu
      end if

      total_wt=total_wt/nthrows*omega
      fac=(lmax-lmin)/(lmax-rm)
      total_rate=total_rate*total_wt/nthrows*a*fac
      total_rate2=total_rate2/nthrows*omega*a*spmu*fac
      ave_neutron=total_wt*rho*4.14e-6*eemu**.74

      print*,'nph, ncz, iph, jcz: ',nph,ncz,iph,jcz
      print*,'number of overlapped lattice sites: ',ih
      print*,'zenth angle cut, ctmin-->deg: ',ctmin,' -->',
     $ int(dacos(ctmin)*180./pi)
      print*,'omega: ',omega
      print*,'energy range: ',10.**lmin,' --> ',10.**lmax
      print*,'nthrows:  ',nthrows
      print*,'fake survival probability:  ',spmu
      print*,'ave energy in GeV: ',eemu
      print*,'ave intensity in mu/cm-sq/s: ',total_wt
      print*,'muon rate (Hz)--method 1            :',total_rate
      print*,'muon rate (Hz)--method 2 (preferred): ',total_rate2
      print*,'x,y,z in cm',xmu,ymu,zmu
      print*,'lateral displacement in cm',rmu
      print*,'theta in degrees',themu
      print*,'phi in degrees',phimu
      print*,'fake neutron intensity in n/cm^3/s',ave_neutron

      write(13,*)'nph, ncz, iph, jcz: ',nph,ncz,iph,jcz
      write(13,*)'number of overlapped lattice sites: ',ih
      write(13,*)'zenth angle cut, ctmin-->deg: ',ctmin,' -->',
     $ int(dacos(ctmin)*180./pi)
      write(13,*)'omega: ',omega
      write(13,*)'energy range: ',10.**lmin,' --> ',10.**lmax
      write(13,*)'nthrows:  ',nthrows
      write(13,*)'fake survival probability:  ',spmu
      write(13,*)'ave energy in GeV: ',eemu
      write(13,*)'ave intensity in mu/cm-sq/s: ',total_wt
      write(13,*)'muon rate (Hz)--method 1            : ',total_rate
      write(13,*)'muon rate (Hz)--method 2 (preferred): ',total_rate2
      write(13,*)'x,y,z in cm',xmu,ymu,zmu
      write(13,*)'lateral displacement in cm',rmu
      write(13,*)'theta in degrees',themu
      write(13,*)'phi in degrees',phimu
      write(13,*)'fake neutron intensity in n/cm^3/s',ave_neutron

      close(12)
      close(13)
      stop

      END
