source: branches/start/MagicSoft/Simulation/Corsika/Mmcs/vapor.f@ 9223

      SUBROUTINE VAPOR(MAPROJ,INEW,JFIN,ITYP,PFRX,PFRY)
 
C-----------------------------------------------------------------------
C  (E)VAPOR(ATION OF NUCLEONS AND ALPHA PARTICLES FROM FRAGMENT)
C
C  TREATES THE REMAINING UNFRAGMENTED NUCLEUS
C  EVAPORATION FOLLOWING CAMPI APPROXIMATION
C  SEE: X. CAMPI AND J. HUEFNER, PHYS.REV. C24 (1981) 2199
C  AND  J.J. GAIMARD, THESE UNIVERSITE PARIS 7, (1990)
C  THIS SUBROUTINE IS CALLED FROM SDPM AND VSTORE
C
C  ARGUMENTS INPUT:
C   MAPROJ       = NUMBER OF NUCLEONS OF PROJECTILE
C   INEW         = PARTICLE TYPE OF SPECTATOR FRAGMENT
C  ARGUMENTS OUTPUT:
C   JFIN         = NUMBER OF FRAGMENTS
C   ITYP(1:JFIN) = NATURE (PARTICLE CODE) OF FRAGMENTS (GEANT)
C   PFRX(1:JFIN) = TRANSVERSE MOMENTUM OF FRAGMENTS IN X-DIRECTION
C   PFRY(1:JFIN) = TRANSVERSE MOMENTUM OF FRAGMENTS IN Y-DIRECTION
C
C  DESIGN  : D. HECK    IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------
 
      IMPLICIT NONE
*KEEP,CONST.
      COMMON /CONST/   PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,DPMFLG.
      COMMON /DPMFLG/  NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM
      INTEGER          NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,
     *                 STEPFC,NRRUN,NSHOW,PATAPE,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,
     *                 CETAPE,
     *                 SHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,
     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE
     *                ,GHEISH,GHESIG
      COMMON /RUNPAC/  DSN,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB
      REAL             STEPFC
      INTEGER          NRRUN,NSHOW,PATAPE,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 SHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE
      INTEGER          CETAPE
      CHARACTER*79     DSN
      CHARACTER*20     HOST,USER
 
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE
     *                ,GHEISH,GHESIG
*KEND.
 
      DOUBLE PRECISION PFR(60),PFRX(60),PFRY(60)
      DOUBLE PRECISION AFIN,AGLH,APRF,BGLH,EEX,PHIFR,RANNOR,SPFRX,SPFRY
      INTEGER          ITYP(60),IARM,INEW,ITYPRM,INRM,IS,IZRM,JC,JFIN,
     *                 K,L,LS,MAPROJ,MF,NFIN,NINTA,NNUC,NPRF,NSTEP
      EXTERNAL         RANNOR
C-----------------------------------------------------------------------
 
      IF (DEBUG) WRITE(MDEBUG,*) 'VAPOR : MAPROJ,INEW = ',MAPROJ,INEW
 
      ITYPRM = INEW
      NPRF   = INEW/100
      NINTA  = MAPROJ - NPRF
      IF ( NINTA .EQ. 0 ) THEN
C  NO NUCLEON HAS INTERACTED
        JFIN    = 1
        PFR(1)  = 0.D0
        ITYP(1) = INEW
        IF (DEBUG) WRITE(MDEBUG,*) 'VAPOR : JFIN,NINTA= ',JFIN,NINTA
        RETURN
      ENDIF
 
C  EXCITATION ENERGY EEX OF PREFRAGMENT
C  SEE: J.J. GAIMARD, THESE UNIVERSITE PARIS 7, (1990), CHPT. 4.2
      EEX = 0.D0
      CALL RMMAR(RD,2*NINTA,1)
      DO  22  L = 1,NINTA
        IF ( RD(NINTA+L) .LT. RD(L) ) RD(L) = 1. - RD(L)
        EEX = EEX + RD(L)
 22   CONTINUE
C  DEPTH OF WOODS-SAXON POTENTIAL TO FERMI SURFACE IS 0.040 GEV
      IF (DEBUG) WRITE(MDEBUG,*)'VAPOR : EEX = ',SNGL(EEX*0.04D0),' GEV'
C  EVAPORATION: EACH EVAPORATION STEP NEEDS ABOUT 0.020 GEV, THEREFORE
C  NSTEP IS EEX * 0.04/0.02 = EEX * 2.
      NSTEP = INT(EEX*2.D0)
 
      IF ( NSTEP .LE. 0 ) THEN
C  EXCITATION ENERGY TOO SMALL, NO EVAPORATION
        JFIN = 1
        PFR(1)  = 0.D0
        ITYP(1) = INEW
        IF (DEBUG) WRITE(MDEBUG,*) 'VAPOR : JFIN,EEX = ',JFIN,SNGL(EEX)
        RETURN
      ENDIF
 
C  AFIN IS ATOMIC NUMBER OF FINAL NUCLEUS
      APRF = FLOAT(NPRF)
      AFIN = APRF - 1.6D0 * FLOAT(NSTEP)
      NFIN = MAX( INT(AFIN+0.5D0), 0 )
C  CORRESPONDS TO DEFINITION; FRAGMENTATION-EVAPORATION
C  CONVOLUTION EMU07 /MODEL ABRASION EVAPORATION (JNC FZK APRIL 94)
C  NNUC IS NUMBER OF EVAPORATING NUCLEONS
      NNUC = NPRF - NFIN
      IF (DEBUG) WRITE(MDEBUG,*) 'VAPOR : NFIN,NNUC = ',NFIN,NNUC
      JC = 0
 
      IF     ( NNUC .LE. 0 ) THEN
C  NO EVAPORATION
        JFIN = 1
        PFR(1)  = 0.D0
        ITYP(1) = INEW
        RETURN
 
      ELSEIF ( NNUC .GE. 4 ) THEN
C  EVAPORATION WITH FORMATION OF ALPHA PARTICLES POSSIBLE
C  IARM, IZRM, INRM ARE NUMBER OF NUCLEONS, PROTONS, NEUTRONS OF
C  REMAINDER
        DO  31  LS = 1,NSTEP
          IARM = ITYPRM/100
          IF ( IARM .LE. 0 ) GOTO 100
          IZRM = MOD(ITYPRM,100)
          INRM = IARM - IZRM
          JC = JC + 1
          CALL RMMAR(RD,2,1)
          IF ( RD(1).LT.0.2 .AND. IZRM.GE.2 .AND. INRM.GE.2 ) THEN
            ITYP(JC) = 402
            NNUC   = NNUC - 4
            ITYPRM = ITYPRM - 402
          ELSE
            IF ( RD(2)*(IZRM+INRM) .LT. IZRM ) THEN
              ITYP(JC) = 14
              ITYPRM   = ITYPRM - 101
            ELSE
              ITYP(JC) = 13
              ITYPRM   = ITYPRM - 100
            ENDIF
            NNUC = NNUC - 1
          ENDIF
          IF ( NNUC .LE. 0 ) GOTO 50
 31     CONTINUE
      ENDIF
 
      IF ( NNUC .LT. 4 ) THEN
C  EVAPORATION WITHOUT FORMATION OF ALPHA PARTICLES
        CALL RMMAR(RD,NNUC,1)
        DO  32  IS = 1,NNUC
          IARM = ITYPRM/100
          IF ( IARM .LE. 0 ) GOTO 100
          IZRM = MOD(ITYPRM,100)
          JC = JC + 1
          IF ( RD(IS)*IARM .LT. IZRM ) THEN
            ITYP(JC) = 14
            ITYPRM   = ITYPRM - 101
          ELSE
            ITYP(JC) = 13
            ITYPRM   = ITYPRM - 100
          ENDIF
 32     CONTINUE
      ENDIF
 
 50   CONTINUE
      JC = JC + 1
      IF     ( ITYPRM .GT. 101 ) THEN
        ITYP(JC) = ITYPRM
      ELSEIF ( ITYPRM .EQ. 101 ) THEN
        ITYP(JC) = 14
      ELSEIF ( ITYPRM .EQ. 100 ) THEN
        ITYP(JC) = 13
      ELSE
        JC = JC - 1
        IF ( ITYPRM .NE. 0 ) WRITE(MONIOU,*)
     *                  'VAPOR : ILLEGAL PARTICLE ITYPRM =',ITYPRM
      ENDIF
 
 100  JFIN = JC
      IF (DEBUG) WRITE(MDEBUG,*) 'VAPOR : NO   ITYP           PFR'
      IF     ( NFRAGM .EQ. 2 ) THEN
C  EVAPORATION WITH PT AFTER PARAMETRIZED JACEE DATA
        DO  150  MF = 1,JFIN
          PFR(MF) = RANNOR(0.088D0,0.044D0)
          IF (DEBUG) WRITE(MDEBUG,*) MF,ITYP(MF),SNGL(PFR(MF))
 150    CONTINUE
      ELSEIF ( NFRAGM .EQ. 3 ) THEN
C  EVAPORATION WITH PT AFTER GOLDHABER'S MODEL (PHYS.LETT.53B(1974)306)
        DO  160  MF = 1,JFIN
          K = MAX( 1, ITYP(MF)/100 )
          BGLH  = K * (MAPROJ - K) / FLOAT(MAPROJ-1)
C  THE VALUE 0.103 [GEV] IS SIGMA(0)=P(FERMI)/SQRT(5.)
*         AGLH = 0.103D0 * SQRT( BGLH )
C  THE VALUE 0.090 [GEV] IS EXPERIMENTALLY DETERMINED SIGMA(0)
          AGLH = 0.090D0 * SQRT( BGLH )
          PFR(MF) = RANNOR(0.D0,AGLH)
          IF (DEBUG) WRITE(MDEBUG,*) MF,ITYP(MF),SNGL(PFR(MF))
 160    CONTINUE
      ELSE
C  EVAPORATION WITHOUT TRANSVERSE MOMENTUM
        DO  165  MF = 1,JFIN
          PFR(MF) = 0.D0
          IF (DEBUG) WRITE(MDEBUG,*) MF,ITYP(MF),SNGL(PFR(MF))
 165    CONTINUE
      ENDIF
C  CALCULATE RESIDUAL TRANSVERSE MOMENTUM
      SPFRX = 0.D0
      SPFRY = 0.D0
      CALL RMMAR(RD,JFIN,1)
      DO  170  MF = 1,JFIN
        PHIFR = PI * RD(MF)
        PFRX(MF) = PFR(MF) * COS(PHIFR)
        PFRY(MF) = PFR(MF) * SIN(PHIFR)
        SPFRY = SPFRY + PFRY(MF)
        SPFRX = SPFRX + PFRX(MF)
 170  CONTINUE
C  CORRECT ALL TRANSVERSE MOMENTA FOR MOMENTUM CONSERVATION
      SPFRX = SPFRX / JFIN
      SPFRY = SPFRY / JFIN
      DO  180  MF = 1,JFIN
        PFRX(MF) = PFRX(MF) - SPFRX
        PFRY(MF) = PFRY(MF) - SPFRY
 180  CONTINUE
 
      IF (DEBUG) WRITE(MDEBUG,*) 'VAPOR : NINTA,JFIN= ',NINTA,JFIN
      RETURN
      END