+++ /dev/null
-*
-* $Id$
-*
-* $Log$
-* Revision 1.1.1.1 1995/10/24 10:19:56 cernlib
-* Geant
-*
-*
-#include "geant321/pilot.h"
-*CMZ : 3.21/02 02/07/94 17.46.10 by S.Giani
-*-- Author :
- SUBROUTINE FERHAV ( KP, EPROJ, PPROJ, TXX, TYY, TZZ )
-
-#include "geant321/dblprc.inc"
-#include "geant321/dimpar.inc"
-#include "geant321/iounit.inc"
-#include "geant321/balanc.inc"
-#include "geant321/finlsp.inc"
-#include "geant321/hadflg.inc"
-#include "geant321/nucdat.inc"
-#include "geant321/qquark.inc"
-#include "geant321/part3.inc"
-#include "geant321/resnuc.inc"
- COMMON /FKABLT/ AM(110), GAA(110), TAU(110), ICH(110), IBAR(110),
- & K1(110), K2(110)
- COMMON / FKNUCF / DELEFT, EKRECL, V0EXTR, ITTA, ITJ, LVMASS
- LOGICAL LVMASS, LSMPAN
- COMMON / FKEVNT / LNUCRI, LHADRI
- LOGICAL LNUCRI, LHADRI
- REAL FRNDM(3)
- SAVE ONEDUM, ZERDUM
- DATA ONEDUM / 1.D+00 /
- DATA ZERDUM / 0.D+00 /
- AMPROJ = AM (KP)
- AMTAR = AM (ITTA)
- ECHCK = EPROJ + EFRM - V0WELL (ITJ) - EKRECL - EBNDNG (ITJ)
- PXCHCK = PXFRM + PPROJ * TXX
- PYCHCK = PYFRM + PPROJ * TYY
- PZCHCK = PZFRM + PPROJ * TZZ
- UMIN2 = ( AMPROJ + AMTAR )**2
- P2CHCK = PXCHCK**2 + PYCHCK**2 + PZCHCK**2
- UMO2 = ECHCK**2 - P2CHCK
- IF ( ABS ( UMO2 - UMIN2 ) .GT. TWOTWO * ANGLGB * UMO2 ) THEN
- EPROJX = HLFHLF * ( UMO2 - AMPROJ**2 - AMTAR**2 ) / AMTAR
- IF ( EPROJX .LT. AMPROJ ) THEN
- WRITE (LUNERR,*)' Ferhav: trouble with pseudo-masses!!',
- & EPROJX,AMPROJ,LVMASS
- EPROJX = AMPROJ
- PPROJX = ZERZER
- LRESMP = .TRUE.
- RETURN
- ELSE
- PPROJX = SQRT ( ( EPROJX - AMPROJ ) * ( EPROJX + AMPROJ ) )
- END IF
- ETOTX = EPROJX + AMTAR
- AMTRMX = HLFHLF * ( UMO2 - AMPROJ**2 - AMTAR**2 ) / AMPROJ
- AMSQMX = AMTRMX**2
- PTOSCA = PXCHCK * TXX + PYCHCK * TYY + PZCHCK * TZZ
- PXTART = PXCHCK - PTOSCA * TXX
- PYTART = PYCHCK - PTOSCA * TYY
- PZTART = PZCHCK - PTOSCA * TZZ
- PTRASQ = PXTART**2 + PYTART**2 + PZTART**2
- AMTRSQ = AMTAR**2 + PTRASQ
- IF ( AMTRSQ .GT. AMSQMX ) THEN
- PPCHCK = SQRT (P2CHCK)
- PTOOLD = PTOSCA
- PTRASQ = ( AMTRMX - AMTAR ) * ( AMTRMX + AMTAR )
-****** AMTRSQ = AMTRMX + PTRASQ
-****** PTOSCA = SIGN (ONEONE,PTOOLD) * SQRT ( P2CHCK - PTRASQ )
- AMTRSQ = AMSQMX
- PTOSCA = SQRT ( P2CHCK - PTRASQ )
- ALPTUU = ( PTOSCA * SQRT ( ( PPCHCK - PTOOLD ) * ( PPCHCK
- & + PTOOLD ) / ( PPCHCK - PTOSCA ) / ( PPCHCK + PTOSCA
- & ) ) - PTOOLD ) / PPCHCK
- FNORM = SQRT ( ONEONE + ALPTUU**2 + TWOTWO * ALPTUU
- & * PTOOLD / PPCHCK )
- ALPTUU = ALPTUU / PPCHCK
- TXXX = ( TXX + ALPTUU * PXCHCK ) / FNORM
- TYYY = ( TYY + ALPTUU * PYCHCK ) / FNORM
- TZZZ = ( TZZ + ALPTUU * PZCHCK ) / FNORM
- UMOTR2 = UMO2 + PTRASQ
- UMOTR = SQRT (UMOTR2)
- AMTRAN = AMTRMX
- PPARSQ = PTOSCA**2
- PPARTT = PTOSCA
- GAMCMS = ECHCK / UMOTR
- ETACMS = PPARTT / UMOTR
- EPRCMS = AMPROJ
- PPRCMS = ZERZER
- ELSE
- TXXX = TXX
- TYYY = TYY
- TZZZ = TZZ
- PTOOLD = PTOSCA
- UMOTR2 = UMO2 + PTRASQ
- UMOTR = SQRT (UMOTR2)
- PPARTT = PTOSCA
- GAMCMS = ECHCK / UMOTR
- ETACMS = PPARTT / UMOTR
- EPRCMS = HLFHLF * ( UMOTR2 + AMPROJ**2 - AMTRSQ ) / UMOTR
- PPRCMS = SQRT ( ( EPRCMS - AMPROJ ) * ( EPRCMS + AMPROJ ) )
- END IF
- EPRLAB = GAMCMS * EPRCMS + ETACMS * PPRCMS
- ETRLAB = ECHCK - EPRLAB
- PPRLAB = SQRT ( ( EPRLAB - AMPROJ ) * ( EPRLAB + AMPROJ ) )
- PXTARG = PXCHCK - PPRLAB * TXXX
- PYTARG = PYCHCK - PPRLAB * TYYY
- PZTARG = PZCHCK - PPRLAB * TZZZ
- GAM = ETRLAB / AMTAR
- BGX = PXTARG / AMTAR
- BGY = PYTARG / AMTAR
- BGZ = PZTARG / AMTAR
- PPHELP = ( BGX * TXXX + BGY * TYYY + BGZ * TZZZ ) * PPRLAB
- ETAPCM = EPRLAB - PPHELP / ( GAM + ONEONE )
- PXPROJ = PPRLAB * TXXX - BGX * ETAPCM
- PYPROJ = PPRLAB * TYYY - BGY * ETAPCM
- PZPROJ = PPRLAB * TZZZ - BGZ * ETAPCM
- UUOLD = PXPROJ / PPROJX
- VVOLD = PYPROJ / PPROJX
- WWOLD = PZPROJ / PPROJX
- SINT02 = UUOLD**2 + VVOLD**2
- IF ( SINT02 .LE. ANGLSQ ) THEN
- LSMPAN = .TRUE.
- SINTH0 = ZERZER
- COSPH0 = ONEONE
- SINPH0 = ZERZER
- ELSE
- LSMPAN = .FALSE.
- SINTH0 = SQRT (SINT02)
- COSPH0 = UUOLD / SINTH0
- SINPH0 = VVOLD / SINTH0
- END IF
- ELSE
- UMO2 = UMIN2
- EPROJX = AMPROJ
- PPROJX = ZERZER
- ETOTX = AMPROJ + AMTAR
- LSMPAN = .FALSE.
- CALL POLI ( COSTH0, SINTH0 )
- CALL SFECFE ( SINPH0, COSPH0 )
- UUOLD = SINTH0 * COSPH0
- VVOLD = SINTH0 * SINPH0
- WWOLD = COSTH0
- AAFACT = ECHCK + ETOTX
- BBFACT = PPROJX - PZCHCK
- DDENOM = ETOTX * AAFACT - PPROJX * BBFACT
- GAM = ( ECHCK * AAFACT + PPROJX * BBFACT ) / DDENOM
- BGZ = - BBFACT * AAFACT / DDENOM
- BGX = PXCHCK * ( GAM + ONEONE ) / AAFACT
- BGY = PYCHCK * ( GAM + ONEONE ) / AAFACT
- END IF
- PLABS = PPROJX
- ELABS = EPROJX
- IF ( PLABS .LT. 1.D-04 ) THEN
- WRITE (LUNERR,*)' Ferhav: kp,plabs,elabs,pprox,y,z,pfrmix,y,z'
- & ,KP,PLABS,ELABS,PPROJ*TXX,PPROJ*TYY,PPROJ*TZZ,PXFRM,PYFRM,
- & PZFRM
- WRITE (LUNERR,*)' Lvmass,Am(kp),Eproj:',LVMASS,AM(KP),EPROJ
- ELSE IF ( PLABS .GT. 1.D+01 ) THEN
- WRITE (LUNERR,*)' Ferhav: kp,plabs,elabs,pprox,y,z,pfrmix,y,z'
- & ,KP,PLABS,ELABS,PPROJ*TXX,PPROJ*TYY,PPROJ*TZZ,PXFRM,PYFRM,
- & PZFRM
- WRITE (LUNERR,*)' Lvmass,Am(kp),Eproj:',LVMASS,AM(KP),EPROJ
- END IF
- ISSU = 0
- DO 100 IQ = 1,3
- ISSU = ISSU + MQUARK (IQ,KP) / 3
- 100 CONTINUE
- IF ( LVMASS ) THEN
- LHADRI = .TRUE.
- CALL HADRIN ( KP, PLABS, ELABS, ZERDUM, ZERDUM, ONEDUM, ITTA )
- IOLDHD = 0
- ELSE IF ( PLABS .GT. 7.D+00 ) THEN
- LHADRI = .FALSE.
- CALL HINHEV ( KP, PLABS, ELABS, ITTA )
- ELSE
- LHADRI = .TRUE.
- CALL HADRIV ( KP, PLABS, ELABS, ZERDUM, ZERDUM, ONEDUM, ITTA )
- END IF
- DO 2000 I=1,IR
- ECMS = ELR (I)
- PCMSX = PLR (I) * CXR (I)
- PCMSY = PLR (I) * CYR (I)
- PCMSZ = PLR (I) * CZR (I)
- IF ( LSMPAN ) THEN
- PCMSX = PLR (I) * CXR (I)
- PCMSY = PLR (I) * CYR (I)
- PCMSZ = WWOLD * PLR (I) * CZR (I)
- ELSE
- PLRX = CXR (I) * COSPH0 * WWOLD - CYR (I) * SINPH0
- & + CZR (I) * UUOLD
- PLRY = CXR (I) * SINPH0 * WWOLD + CYR (I) * COSPH0
- & + CZR (I) * VVOLD
- PLRZ = - CXR (I) * SINTH0 + CZR (I) * WWOLD
- PCMSX = PLRX * PLR (I)
- PCMSY = PLRY * PLR (I)
- PCMSZ = PLRZ * PLR (I)
- END IF
- CALL ALTRA ( GAM, BGX, BGY, BGZ, PCMSX, PCMSY, PCMSZ,
- & ECMS, PLR (I), PLRX, PLRY, PLRZ, ELR (I) )
- CXR (I) = PLRX / PLR (I)
- CYR (I) = PLRY / PLR (I)
- CZR (I) = PLRZ / PLR (I)
- DO 200 IQ = 1,3
- ISSU = ISSU - MQUARK (IQ,KPTOIP(ITR(I))) / 3
- 200 CONTINUE
-2000 CONTINUE
- IF ( ISSU .NE. 0 ) THEN
- WRITE (LUNOUT,*)' *** Strangeness non conservation in Hadriv',
- & ISSU,KP,ITTA,' ***'
- WRITE (LUNERR,*)' *** Strangeness non conservation in Hadriv',
- & ISSU,KP,ITTA,' ***'
- LRESMP = .TRUE.
- END IF
- V0WELL (ITJ) = V0WELL (ITJ) - V0EXTR
- RETURN
- ENTRY FERSET
- FERM = PFRMMX (ITJ)
- CALL GRNDM(FRNDM,3)
- P2 = MAX ( FRNDM (1), FRNDM (2), FRNDM (3) )
- IF ( IBTAR .LE. 1 ) THEN
- FERM = ZERZER
- END IF
- P2=FERM*P2
- P2SQ = P2 * P2
- IATEMP = IBTAR - 1
- ATEMP = DBLE ( IBTAR ) - ONEONE
- IF ( ITJ .EQ. 1 ) THEN
- IZTEMP = ICHTAR - 1
- ELSE
- IZTEMP = ICHTAR
- END IF
- ZTEMP = DBLE ( IZTEMP )
- DELCTR = ( DBLE (ICHTAR) - ZTEMP ) * AMELEC
- DELEFT = AMMTAR - AMNTAR - DELCTR
- AMMRES = AMUAMU * ATEMP + 1.D-03 * FKENER ( ATEMP, ZTEMP )
- AMNRES = AMMRES - ZTEMP * AMELEC + ELBNDE ( IZTEMP )
- AMTMSQ = AMMRES * AMMRES
- EKRECL = SQRT ( AMTMSQ + P2SQ ) - AMMRES
- CALL POLI ( POLC, POLS )
- CALL COSI ( SFE, CFE )
- PXFRM = CFE * POLS * P2
- PYFRM = SFE * POLS * P2
- PZFRM = POLC * P2
- EFRM = SQRT ( AMNUSQ (ITJ) + P2SQ )
- EKFER = EFRM - AMNUCL (ITJ)
- TVEUZ = V0WELL (ITJ) - EFRM + EBNDNG (ITJ) + AMMTAR - AMMRES
- & - DELCTR
- IF ( TVEUZ .LT. ZERZER ) THEN
- V0EXTR = - TVEUZ + TENTEN * TVEPSI
- TVEUZ = TVEUZ + V0EXTR
- V0WELL (ITJ) = V0WELL (ITJ) + V0EXTR
- ELSE
- V0EXTR = ZERZER
- END IF
- RETURN
- END
git://git.uio.no / u / mrichter / AliRoot.git / blobdiff