dpm25lepto.f

Go to the documentation of this file.

C****************************************************************
      SUBROUTINE kkevle(NHKKH1,EPN,PPN,KKMAT,IREJ)
*
      IMPLICIT DOUBLE PRECISION (a-h,o-z)
      common/intnez/ndz,nzd
*KEEP,HKKEVT.
c     INCLUDE (HKKEVT)
      parameter(nmxhkk= 89998)
c     PARAMETER (NMXHKK=25000)
      COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
     +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
     +(4,nmxhkk)
C
C                       WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
C                       PROJECTILE FRAME, THE CHAINS ARE CREATED ON
C                       THE POSITIONS OF THE PROJECTILE NUCLEONS
C                       IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
C                       TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
C                       COMPLETELY CONSISTENT. THE TIMES IN THE
C                       PROJECTILE FRAME HOWEVER ARE OBTAINED BY
C                       LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
C
C  Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
C
C NMXHKK: maximum numbers of entries (partons/particles) that can be
C    stored in the commonblock.
C
C NHKK: the actual number of entries stored in current event. These are
C    found in the first NHKK positions of the respective arrays below.
C    Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
C    entry.
C
C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
C    = 0 : null entry.
C    = 1 : an existing entry, which has not decayed or fragmented.
C        This is the main class of entries which represents the
C        "final state" given by the generator.
C    = 2 : an entry which has decayed or fragmented and therefore
C        is not appearing in the final state, but is retained for
C        event history information.
C    = 3 : a documentation line, defined separately from the event
C        history. (incoming reacting
C        particles, etc.)
C    = 4 - 10 : undefined, but reserved for future standards.
C    = 11 - 20 : at the disposal of each model builder for constructs
C        specific to his program, but equivalent to a null line in the
C        context of any other program. One example is the cone defining
C        vector of HERWIG, another cluster or event axes of the JETSET
C        analysis routines.
C    = 21 - : at the disposal of users, in particular for event tracking
C        in the detector.
C
C IDHKK(IHKK) : particle identity, according to the Particle Data Group
C    standard.
C
C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
C    The value is 0 for initial entries.
C
C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
C    one mother exist, in which case the value 0 is used. In cluster
C    fragmentation models, the two mothers would correspond to the q
C    and qbar which join to form a cluster. In string fragmentation,
C    the two mothers of a particle produced in the fragmentation would
C    be the two endpoints of the string (with the range in between
C    implied).
C
C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
C    entry has not decayed, this is 0.
C
C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
C    entry has not decayed, this is 0. It is assumed that the daughters
C    of a particle (or cluster or string) are stored sequentially, so
C    that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
C    daughters. Even in cases where only one daughter is defined (e.g.
C    K0 -> K0S) both values should be defined, to make for a uniform
C    approach in terms of loop constructions.
C
C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
C
C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
C
C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
C
C PHKK(4,IHKK) : energy, in GeV.
C
C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
C    to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
C
C VHKK(1,IHKK) : production vertex x position, in mm.
C
C VHKK(2,IHKK) : production vertex y position, in mm.
C
C VHKK(3,IHKK) : production vertex z position, in mm.
C
C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
C********************************************************************
*KEEP,INTMX.
      parameter(intmx=2488,intmd=252)
*KEEP,DXQX.
C     INCLUDE (XQXQ)
* NOTE: INTMX set via INCLUDE(INTMX)
      COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
     +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
     *                ,xpsu(248),xtsu(248)
     *                ,xpsut(248),xtsut(248)
*KEEP,INTNEW.
      COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
     +ixpv,ixps,ixtv,ixts, intvv1(248),
     +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
     +intss1(intmx),intss2(intmx),
     +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
     +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
 
C  /INTNEW/
C       NVV    :   NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
C       NSV    :   NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
C       NVS    :   NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
C       NSS    :   NUMBER OF INTERACTING SEA-SEA SYSTEMS
C       IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
C                     SYSTEMS FROM PROJECTILE/TARGET NUCLEI
C       IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
C                     FROM PROJECTILE/TARGET NUCLEI
C-------------------
*KEEP,IFROTO.
      COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
     +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
     +jhkknt
     +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
     +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
     &                mhkkhh(intmx),
     +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
*KEEP,LOZUO.
      LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
      COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
     +intlo(intmx),inloss(intmx)
C  /LOZUO/
C      /
C INLOSS :  .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
C                         REJECTED IN KKEVT
C------------------
*KEEP,DIQI.
      COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
     +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
     +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
     +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
*KEEP,SHMAKL.
C     INCLUDE (SHMAKL)
* NOTE: INTMX set via INCLUDE(INTMX)
      common/shmakl/jssh(intmx),jtsh(intmx),inter1(intmx),inter2(intmx)
*KEEP,NUCC.
      COMMON /nucc/   it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
*KEEP,RPTSHM.
      COMMON /rptshm/ rproj,rtarg,bimpac
*KEEP,NSHMAK.
      COMMON /nshmak/ nnshma,npshma,ntshma,nshmac
*KEEP,ZENTRA.
      COMMON /zentra/ icentr
*KEEP,NUCIMP.
      COMMON /nucimp/ prmom(5,248),tamom(5,248), prmfep,prmfen,tamfep,
     +tamfen, prefep,prefen,taefep,taefen, prepot(210),taepot(210),
     +prebin,taebin,fermod,etacou
*KEEP,DROPPT.
      LOGICAL intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada, ipadis,
     +ishmal,lpauli
      COMMON /droppt/ intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada,
     +ipadis,ishmal,lpauli
*KEEP,NNCMS.
      COMMON /nncms/  gamcm,bgcm,umoj,pcmj,eprojj,pprojj
      COMMON /nuccms/ gacms,bgcms,galab,bglab,blab,umo,pcm,eproj,pproj
*KEEP,NUCPOS.
      COMMON /nucpos/invvp(248),invvt(248),invsp(248),invst(248), nuvv,
     +nuvs,nusv,nuss,insvp(248),insvt(248),inssp(248),insst(248), isveap
     +(248),isveat(248),isseap(248),isseat(248), ivseap(248),ivseat
     +(248), islosp(248),islost(248),inoop(248),inoot(248),nuoo
*KEEP,TAUFO.
      COMMON /taufo/  taufor,ktauge,itauve,incmod
      COMMON /evappp/ievap
      COMMON /neutyy/neutyp,neudec
*KEEP,RTAR.
      COMMON /rtar/ rtarnu
*KEEP,INNU.
      COMMON /innu/inudec
*KEEP,HADTHR.
      COMMON /hadthr/ ehadth,inthad
*KEEP,DINPDA.
      COMMON /dinpda/ imps(6,6),imve(6,6),ib08(6,21),ib10(6,21), ia08
     +(6,21),ia10(6,21), a1,b1,b2,b3,lt,le,bet,as,b8,ame,diq,isu
*KEEP,FERMI.
      COMMON /fermi/ pquar(4,248),paquar(4,248), tquar(4,248),taquar
     +(4,248)
*KEEP,KETMAS.
      COMMON /ketmas/ am8(2),am10(2),ib88(2),ib1010(2),amch1n,amch2n
*KEEP,DPAR.
C     /DPAR/   CONTAINS PARTICLE PROPERTIES
C        ANAME  = LITERAL NAME OF THE PARTICLE
C        AAM    = PARTICLE MASS IN GEV
C        GA     = DECAY WIDTH
C        TAU    = LIFE TIME OF INSTABLE PARTICLES
C        IICH   = ELECTRIC CHARGE OF THE PARTICLE
C        IIBAR  = BARYON NUMBER
C        K1,K1  = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
C
      CHARACTER*8  aname
      COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
     +iibar(210),k1(210),k2(210)
C------------------
*KEEP,DPRIN.
      COMMON /dprin/  ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
*KEEP,NUCKOO.
      COMMON /nuckoo/ pkoo(3,intmx),tkoo(3,intmx),ppoo(3,intmx),
     +tpoo(3,intmx)
*KEEP,REJEC.
      COMMON /rejec/ irco1,irco2,irco3,irco4,irco5, irss11,irss12,
     +irss13,irss14, irsv11,irsv12,irsv13,irsv14, irvs11,irvs12,irvs13,
     +irvs14, irvv11,irvv12,irvv13,irvv14
*KEEP,PROJK.
      COMMON /projk/ iprojk
*KEEP,TANUIN.
      COMMON /tanuin/ tasuma,tasubi,tabi,tamasu,tama,taimma
*KEND.
      COMMON /diffra/ isingd,idiftp,ioudif,iflagd
*
      LOGICAL lseadi
      COMMON /seadiq/ lseadi
      COMMON /evflag/numev
      COMMON /diquax/idiqua
C
C-----------------------------------------------------------------------
C     PARAMETER (INTMX=2488)
      COMMON /abrjt/xjq1(intmx),xjaq1(intmx),xjq2(intmx),xjaq2(intmx),
     *        ijjq1(intmx),ijjaq1(intmx),ijjq2(intmx),ijjaq2(intmx),
     *        amjch1(intmx),amjch2(intmx),gamjh1(intmx),gamjh2(intmx),
     *        bgjh1(intmx),bgjh2(intmx),thejh1(intmx),thejh2(intmx),
     *        bgxjh1(intmx),bgyjh1(intmx),bgzjh1(intmx),
     *        bgxjh2(intmx),bgyjh2(intmx),bgzjh2(intmx),
     *  pjeta1(intmx,4),pjeta2(intmx,4),pjetb1(intmx,4),pjetb2(intmx,4)
     * ,jhkkph(intmx),jhkkth(intmx),jhkkex(intmx),jhkke1(intmx)
      COMMON /abrsof/xsq1(intmx),xsaq1(intmx),xsq2(intmx),xsaq2(intmx),
     *        ijsq1(intmx),ijsaq1(intmx),ijsq2(intmx),ijsaq2(intmx),
     *        amcch1(intmx),amcch2(intmx),gamch1(intmx),gamch2(intmx),
     *        bgch1(intmx),bgch2(intmx),thech1(intmx),thech2(intmx),
     *        bgxch1(intmx),bgych1(intmx),bgzch1(intmx),
     *        bgxch2(intmx),bgych2(intmx),bgzch2(intmx),
     *        nch1(intmx),nch2(intmx),ijch1(intmx),ijch2(intmx),
     *  psofa1(intmx,4),psofa2(intmx,4),psofb1(intmx,4),psofb2(intmx,4)
     * ,jhkkpz(intmx),jhkktz(intmx),jhkksx(intmx),jhkks1(intmx)
      COMMON /nucjtn/nonuj1,nonujt,nonus1,nonust
      COMMON /xsvthr/ xsthr,xvthr,xdthr,xssthr
      COMMON /minij/iminij,nomje,nomjer,nrejev,nomjt,nomjtr
      INTEGER nlu,klu,lst,mdcy,mdme,kfdp
      REAL plu,vlu,cut,parl,x,y,w2,q2,u,brat,elab
      common/lujets/nlu,klu(4000,5),plu(4000,5),vlu(4000,5)
      COMMON /leptou/cut(14),lst(40),parl(30),x,y,w2,q2,u
      common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
      COMMON /neurej/ noneur
      DATA iniqel /0/
C*******************************************************************"
C
C     KINEMATICS
C
C********************************************************************
C
      irej = 0
*
      aam(26)=aam(23)
C
      kproj=1
      IF(ijproj.NE.0) kproj=ijproj
      ktarg=1
      atnuc=it
      itn=it-itz
      apnuc=ip
      ipn=ip-ipz
      amproj =aam(kproj)
      amtar =aam(ktarg)
*                             nucleon-nucleon cms
C     IBPROJ=1
      eprojj=epn
      pprojj= sqrt((epn-amproj)*(epn+amproj))
      umoj= sqrt(amproj**2 + amtar**2 + 2.*amtar*eprojj)
      gamcm = (eprojj+amtar)/umoj
      bgcm=pprojj/umoj
      ecm=umoj
      pcmj=gamcm*pprojj - bgcm*eprojj
C
      IF(ipev.GE.1) print 1000,ip,ipz,it,itz,ijproj,ibproj, eproj,pproj,
     +amproj,amtar,umo,gamcm,bgcm
 1000 FORMAT(' ENTRY KKEVNU'/ '    IP,IPZ,IT,ITZ,IJPROJ,IBPROJ',6i5/
     +'    EPROJ,PPROJ,AMPROJ,AMTAR,UMO,GAMCM,BGCM'/10e12.3)
 
C
C****                            CHANGE PARAMETERS FROM COMMON \INPDAT\
      as=0.5
      b8=0.4
C                                CHAIN PT BIGGER THAN PARTICLE PT
      n9483=0
*  entry after rejection of an event because of kinematical reasons
*  several trials are made to realize a sampled Glauber event
   10 CONTINUE
      ndz=0
      nzd=0
      n9483=n9483+1
      IF (mod(n9483,200).EQ.0) THEN
        WRITE(6,'(A,I5,A,I5,A)') ' KKEVT: Glauber event',numev,
     +  ' rejected after', n9483, ' trials'
        WRITE(6, 1010) nn,np,nt
        WRITE(6,1020) irco1,irco2,irco3,irco4,irco5, irss11,irss12,
     +  irss13,irss14, irsv11,irsv12,irsv13,irsv14, irvs11,irvs12,
     +  irvs13,irvs14, irvv11,irvv12,irvv13,irvv14
        n9483=1
        go to 20
      ELSEIF(n9483.GT.1) THEN
                                                                 goto 30
      ENDIF
 1010 FORMAT (5x,' N9483 LOOP - NN, NP, NT',5i10)
 1020 FORMAT (5x,' N9483 LOOP - REJECTION COUNTERS ',/,5i8/2(8i8/))
C
C***************************************************************
C
C     SAMPLE NUMBERS OF COLLISION A LA SHMAKOV---------------
C
C
C                 This is done here for a h-A event to obtain
C                the positions of the nucleons of A
C
C
C     TOTAL NUMBER OF INTERACTIONS = NN
C     NUMBER OF INTERACTING NUCLEONS
C                  FROM PROJECTILE = NP
C                  FROM TARGET = NT
C
   20 CONTINUE
   22 CONTINUE
      CALL shmako(ip,it,bimp,nn,np,nt,jssh,jtsh,pproj,kkmat)
      bimpac=bimp
      nshmac=nshmac+1
      nnshma=nn
      npshma=np
      ntshma=nt
*  entry for repeated trial to realize a sampled Glauber event
   30 CONTINUE
      IF (ipev.GE.2) THEN
        WRITE(6, 1040) ip,ipz,it,itz,eproj,pproj,nn,np,nt
 1040 FORMAT ('   752 FORM ',4i10,2f10.3,5i10)
        WRITE (6,'(/A,2I5,1PE10.2,3I5)') ' KKEVT: IP,IT,BIMP,NN,NP,NT ',
     +  ip,it,bimp,nn,np,nt
        WRITE (6,'(/2A)')
     +  ' KKEVT: JSSH(KKK),JTSH(KKK),INTER1(KKK),INTER2(KKK),',
     +  ' PKOO(3,KKK),TKOO(3,KKK)'
        itum=max(it,ip)
        DO 40 kkk=1,itum
          WRITE (6,'(4I5,6(1PE11.3))') jssh(kkk),jtsh(kkk),inter1(kkk),
     +    inter2(kkk), pkoo(1,kkk),pkoo(2,kkk),pkoo(3,kkk), tkoo(1,kkk),
     +    tkoo(2,kkk),tkoo(3,kkk)
 
   40   CONTINUE
      ENDIF
C
C-----------------------------------------------------------------------
C                  STORE PROJECTILE HADRON/NUCLEONS INTO /HKKEVT/
C                            - PROJECTILE CENTRE AT ORIGIN IN SPACE
C                            - TARGET SHIFTED IN X DIRECTION BY
C                                             IMPACT PARAMETER 'BIMP'
C
C                            - SAMPLING OF NUCLEON TYPES
C                            - CONSISTENCY CHECK
C                              FOR SAMPLED P/N NUMBERS
C                            - INTERACTING PROJECTILES ISTHKK=11
C                              NONINTERACTING ...      ISTHKK=13
C                            - FERMI MOMENTA IN CORRESP. REST SYSTEM
C-----------
      nhkk=0
C
      ncpp=0
      ncpn=0
C                      DEFINE FERMI MOMENTA/ENERGIES FOR PROJECTILE
C
      pxfe=0.0
      pyfe=0.0
      pzfe=0.0
      DO 50 kkk=1,ip
        nhkk=nhkk+1
C       IF (JSSH(KKK).GT.0) THEN
          isthkk(nhkk)=11
C       ELSE
C         ISTHKK(NHKK)=13
C       ENDIF
C*
          kproj=ijproj
          phkk(1,nhkk)=0.
          phkk(2,nhkk)=0.
          phkk(3,nhkk)=0.
          phkk(4,nhkk)=aam(kproj)
          phkk(5,nhkk)=aam(kproj)
C
        kkproj(kkk)=kproj
        idhkk(nhkk)=mpdgha(kproj)
        jmohkk(1,nhkk)=0
        jmohkk(2,nhkk)=0
        jdahkk(1,nhkk)=0
        jdahkk(2,nhkk)=0
C
        phkk(5,nhkk)=aam(kproj)
        vhkk(1,nhkk)=pkoo(1,kkk)*1.e-12
        vhkk(2,nhkk)=pkoo(2,kkk)*1.e-12
        vhkk(3,nhkk)=pkoo(3,kkk)*1.e-12
        vhkk(4,nhkk)=0.
        whkk(1,nhkk)=pkoo(1,kkk)*1.e-12
        whkk(2,nhkk)=pkoo(2,kkk)*1.e-12
        whkk(3,nhkk)=pkoo(3,kkk)*1.e-12
        whkk(4,nhkk)=0.
        jhkknp(kkk)=nhkk
C
        IF (iphkk.GE.2) WRITE(6,1050) nhkk,isthkk(nhkk),idhkk(nhkk),
     +  jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
     +  (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
 
 1050 FORMAT (i6,i4,5i6,9e10.2)
C
   50 CONTINUE
C
C-----------------------------------------------------------------------
C                  STORE TARGET HADRON/NUCLEONS INTO /HKKEVT/
C                            - PROJECTILE CENTRE AT ORIGIN IN SPACE
C                            - TARGET SHIFTED IN X DIRECTION BY
C                                             IMPACT PARAMETER 'BIMP'
C
C                            - SAMPLING OF NUCLEON TYPES
C                            - CONSISTENCY CHECK
C                              FOR SAMPLED P/N NUMBERS
C                            - INTERACTING TARGETS     ISTHKK=12
C                              NONINTERACTING ...      ISTHKK=14
C-----------
C---------------------
      nhadri=0
      nctp=0
      nctn=0
C
      txfe=0.0
      tyfe=0.0
      tzfe=0.0
      DO 70 kkk=1,it
        nhkk=nhkk+1
C       IF (JTSH(KKK).GT.0) THEN
C         ISTHKK(NHKK)=12
C         NHADRI=NHADRI+1
C         IF (NHADRI.EQ.1) IHTAWW=NHKK
C         IF (EPN.LE.EHADTW) THEN
C           IF (NHADRI.GT.1) ISTHKK(NHKK)=14
C         ENDIF
C       ELSE
          isthkk(nhkk)=14
C       ENDIF
        IF(it.GE.2)THEN
        frtneu=float(itn)/atnuc
        samtes=rndm(v)
        IF(samtes.LT.frtneu.AND.nctn.LT.itn) THEN
          ktarg=8
          nctn=nctn + 1
        ELSEIF(samtes.GE.frpneu.AND.nctp.LT.itz) THEN
          ktarg=1
          nctp=nctp + 1
        ELSEIF(nctn.LT.itn) THEN
          ktarg=8
          nctn=nctn + 1
        ELSEIF(nctp.LT.itz) THEN
          ktarg=1
          nctp=nctp + 1
        ENDIF
C
        IF(ktarg.EQ.1) THEN
          pferm = tamfep
        ELSE
          pferm = tamfen
        ENDIF
        CALL fer4m(pferm,fpx,fpy,fpz,fe,ktarg)
        txfe=txfe + fpx
        tyfe=tyfe + fpy
        tzfe=tzfe + fpz
        phkk(1,nhkk)=fpx
        phkk(2,nhkk)=fpy
        phkk(3,nhkk)=fpz
        phkk(4,nhkk)=fe
        phkk(5,nhkk)=aam(ktarg)
        ELSE
        phkk(1,nhkk)=0. 
        phkk(2,nhkk)=0. 
        phkk(3,nhkk)=0. 
        phkk(4,nhkk)=aam(ktarg)
        phkk(5,nhkk)=aam(ktarg)
        ENDIF
C
        kktarg(kkk)=ktarg
        idhkk(nhkk)=mpdgha(ktarg)
        jmohkk(1,nhkk)=0
        jmohkk(2,nhkk)=0
        jdahkk(1,nhkk)=0
        jdahkk(2,nhkk)=0
        vhkk(1,nhkk)=(tkoo(1,kkk)+bimp)*1.e-12
        vhkk(2,nhkk)=tkoo(2,kkk)*1.e-12
        vhkk(3,nhkk)=tkoo(3,kkk)*1.e-12
        vhkk(4,nhkk)=0.
        whkk(1,nhkk)=(tkoo(1,kkk)+bimp)*1.e-12
        whkk(2,nhkk)=tkoo(2,kkk)*1.e-12
        whkk(3,nhkk)=tkoo(3,kkk)*1.e-12
        whkk(4,nhkk)=0.
        jhkknt(kkk)=nhkk
C
        IF (iphkk.GE.2) WRITE(6,1050) nhkk,isthkk(nhkk),idhkk(nhkk),
     +  jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
     +  (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
 
C
   70 CONTINUE
C                          balance Sampled Fermi momenta
      IF(it.GE.2) THEN
        tasuma=itz*aam(1) + (it-itz)*aam(8)
        tasubi=0.0
        tamasu=0.0
        txfe=txfe/it
        tyfe=tyfe/it
        tzfe=tzfe/it
        DO 80 kkk=1,it
          ihkk=kkk + ip
          phkk(1,ihkk)=phkk(1,ihkk) - txfe
          phkk(2,ihkk)=phkk(2,ihkk) - tyfe
          phkk(3,ihkk)=phkk(3,ihkk) - tzfe
          phkk(4,ihkk)=sqrt(phkk(5,ihkk)** 2+ phkk(1,ihkk)** 2+ phkk
     +    (2,ihkk)** 2+ phkk(3,ihkk)**2)
          itsec=mcihad(idhkk(ihkk))
          tasubi=tasubi + phkk(4,ihkk) - phkk(5,ihkk) - taepot(itsec)
          tamasu=tamasu + phkk(4,ihkk) - taepot(itsec)
        IF (iphkk.GE.2) WRITE(6,1050) ihkk,isthkk(ihkk),idhkk(ihkk),
     +  jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
     +  (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
   80   CONTINUE
C***         definition of initial state
        tabi=-ebind(it,itz)
        tama=(it-itz)*aam(8) + itz*aam(1) + tabi
        taimma=tama - tamasu
      ENDIF
C
      IF(ipev.GT.2) THEN
        WRITE(6,'(/A/5X,A/5X,4(1PE11.3))') ' KKEVT: FERMI MOMENTA',
     +  'PRMFEP,PRMFEN, TAMFEP,TAMFEN', prmfep,prmfen, tamfep,tamfen
 
      ENDIF
C-----------------------------------------------------------------------
      iflagd = 0
C-----------------------------------------------------------------------
C
      IF (ipev.GE.6) THEN
        itum=max0(ip,it,nn)
        WRITE(6,'(A,I10)')' KKEVT ITUM loop limit',itum
        WRITE(6,'(A,2A)') ' KKEVT (AFTER XKSAMP):',
     +  ' JSSH, JSSHS, JTSH, JTSHS, INTER1, INTER2',
     +  ' PKOO(1),PKOO(2),PKOO(3), TKOO(1),TKOO(2),TKOO(3)'
        DO 100 kkk=1,itum
          WRITE (6,'(6I5,6(1PE11.3))') jssh(kkk),jsshs(kkk),jtsh(kkk),
     +    jtshs(kkk), inter1(kkk),inter2(kkk), pkoo(1,kkk),pkoo(2,kkk),
     +    pkoo(3,kkk), tkoo(1,kkk),tkoo(2,kkk),tkoo(3,kkk)
 
 
  100   CONTINUE
      ENDIF
C-----------------------------------------------------------------------
C                 TRANSFORM MOMENTA OF INTERACTING NUCLEONS
C                 (INCLUDING FERMI MOMENTA FROM NUCLEUS REST FRAMES)
C                 INTO NUCLEON-NUCLEON CMS (DEFINED WITHOUT FERMI MOM.
      IF(ipev.GE.2)WRITE(6,'(A)')' KKEVT before NUCMOM'
      DO 7745 ihkk=1,nhkk
        IF (iphkk.GE.2) WRITE(6,1050) ihkk,isthkk(ihkk),idhkk(ihkk),
     +  jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
     +  (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
 7745 CONTINUE
      CALL nucmom
      IF(ipev.GE.2)THEN
    DO iki=1,200
    WRITE(6,'(A)')' KKEVNU after NUCMOM'
    ENDDO
      ENDIF
      nonust=0
      nonujt=0
      nomje=0
      nomjer=0
C
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
C
      nhkkh1=nhkk
C-----------------------------------------------------------
C
C
C                              Select target nucleon
C
C-----------------------------------------------------------
       ltyp=neutyp
C      IF(LTYP.EQ.1.OR.LTYP.EQ.3.OR.LTYP.EQ.5)NUCTYP=2112
C      IF(LTYP.EQ.2.OR.LTYP.EQ.4.OR.LTYP.EQ.6)NUCTYP=2212
C            Neutrino energy is EPN in lab
  202      CONTINUE
       ikta=it*rndm(v)+2.
      IF(ipev.GE.2)THEN
    WRITE(6,*)' NEUTYP,NUCTYP,IKTA,IDHKK(IKTA)',
     *              neutyp,nuctyp,ikta,idhkk(ikta)
      ENDIF
      IF(idhkk(ikta).EQ.2112) itar=2 
      IF(idhkk(ikta).EQ.2212) itar=1
      inu=neutyp
      isthkk(ikta)=12
      elab=epn
      cut(10)=elab+1.
      cut(11)=0.
      cut(12)=elab+1.
      cut(13)=0.
      cut(14)=3.1314
      lst(22)=itar
      lst(17)=1
C     LST(19)=-1
      lst(8)=0
* GRID SUITABLE FOR FIXED TARGET < 300 GEV
      lst(19)=1
      plu(1,1)=0.
      plu(1,2)=0.
      plu(1,3)=elab
      plu(1,4)=elab
      plu(1,5)=0.
      plu(2,1)=phkk(1,ikta)
      plu(2,2)=phkk(2,ikta)
      plu(2,3)=phkk(3,ikta)
      plu(2,4)=phkk(4,ikta)
      plu(2,5)=phkk(5,ikta)
C          Call one lepto event
      IF(iniqel.EQ.0)CALL linit(0,inu,elab,0.,2)
      iniqel=iniqel+1
      plu(1,1)=0.
      plu(1,2)=0.
      plu(1,3)=elab
      plu(1,4)=elab
      plu(1,5)=0.
      plu(2,1)=phkk(1,ikta)
      plu(2,2)=phkk(2,ikta)
      plu(2,3)=phkk(3,ikta)
      plu(2,4)=phkk(4,ikta)
      plu(2,5)=phkk(5,ikta)
      lst(22)=itar
      CALL lepto
C                     event in lab frame
      CALL lframe(3,1)
      IF(lst(21).NE.0)THEN
        CALL lulist(1)
        WRITE(6,*)' event rejected '
        go to 10
      ENDIF
      IF(iniqel.LE.100)WRITE(6,*)' Event ',iniqel
      IF(iniqel.LE.100)CALL lulist(1)
C                        Write events to file lepto.evt
      iiii=0
      DO 205 iii=1,nlu
        IF(klu(iii,1).EQ.1.OR.iii.LE.2) THEN
          iiii=iiii+1
          WRITE(29,'(3I6,5F10.3)')iiii,klu(iii,1),klu(iii,2),
     *   (plu(iii,kk),kk=1,5)
        ENDIF
  205 CONTINUE
      iiii=-1
      WRITE(29,'(I6)')iiii
C                              ADD particle to HKKEVT COMMON     
      DO 206 iii=4,nlu
    IF(klu(iii,1).EQ.1)THEN
       nhkk=nhkk+1
       isthkk(nhkk)=1
       idhkk(nhkk)=klu(iii,2)
       jmohkk(1,nhkk)=ikta
       jmohkk(2,nhkk)=0
       jdahkk(1,nhkk)=0
       jdahkk(2,nhkk)=0
       phkk(1,nhkk)=plu(iii,1)
       phkk(2,nhkk)=plu(iii,2)
       phkk(3,nhkk)=plu(iii,3)
       phkk(4,nhkk)=plu(iii,4)
           nrhkk=mcihad(idhkk(nhkk))
       IF(nrhkk.EQ.1.OR.nrhkk.EQ.8)THEN
        IF(nrhkk.EQ.1)THEN
         IF(phkk(4,nhkk).LE.taefep+aam(nrhkk))THEN
           WRITE(6,*)' Pauli Blocking of p',phkk(4,nhkk),taefep
         ENDIF
        ENDIF
        IF(nrhkk.EQ.8)THEN
         IF(phkk(4,nhkk).LE.taefen+aam(nrhkk))THEN
           WRITE(6,*)' Pauli Blocking of n',phkk(4,nhkk),taefen
         ENDIF
        ENDIF
        IF(phkk(4,nhkk)-aam(nrhkk).LE.taepot(nrhkk))THEN
         isthkk(nhkk)=16
        ENDIF
       ENDIF
       phkk(5,nhkk)=aam(nrhkk)
       vhkk(1,nhkk)=vhkk(1,ikta)
       vhkk(2,nhkk)=vhkk(2,ikta)
       vhkk(3,nhkk)=vhkk(3,ikta)
       vhkk(4,nhkk)=vhkk(4,ikta)
       whkk(1,nhkk)=whkk(1,ikta)
       whkk(2,nhkk)=whkk(2,ikta)
       whkk(3,nhkk)=whkk(3,ikta)
       whkk(4,nhkk)=whkk(4,ikta)
     ENDIF
  206 CONTINUE
  201 CONTINUE
C
C                                  Transform into cms
    DO 111 i=nhkkh1+1,nhkk
      pznn=phkk(3,i)
      enn=phkk(4,i)
      phkk(3,i)=gacms*pznn-bgcms*enn
      phkk(4,i)=gacms*enn-bgcms*pznn
  111   CONTINUE
C-----------------------------------------------------------------------
C
C
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
        IF (ipev.GE.1) THEN
C   DO IKI=1,200
        WRITE(6,'(/A/)') ' KKEVT: FINAL LIST OF ENTRIES TO /HKKEVT/'
C   ENDDO
          DO 121 ihkk=1,nhkk
          WRITE(6,1050) ihkk,isthkk(ihkk),idhkk(ihkk),jmohkk(1,ihkk),
     +    jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),(phkk
     +    (khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
 
  121     CONTINUE
        ENDIF
C
C
  110 CONTINUE
C
C
C
      RETURN
      END