GEANT321/fluka/fkerup.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1995/10/24 10:20:06  cernlib
   6 * Geant
   7 *
   8 *
   9 #include "geant321/pilot.h"
  10 *CMZ :  3.21/02 29/03/94  15.41.45  by  S.Giani
  11 *-- Author :
  12 *=== erup =============================================================*
  13 *                                                                      *
  14       SUBROUTINE FKERUP (JFISS)
  15
  16 #include "geant321/dblprc.inc"
  17 #include "geant321/dimpar.inc"
  18 #include "geant321/iounit.inc"
  19 *
  20 *----------------------------------------------------------------------*
  21 *                                                                      *
  22 *     Created  on   15 may 1990     by     Alfredo & Paola Sala        *
  23 *                                              INFN - Milan            *
  24 *     Last change  on   10-apr-93   by     Alfredo Ferrari, INFN-Milan *
  25 *                                                                      *
  26 *     Derived from the ERUP routine of EVAP-V, HERMES, KFA-Julich      *
  27 *                                                                      *
  28 *----------------------------------------------------------------------*
  29 *
  30 C*****MODIFIED TO OBTAIN APR,ZPR AFTER CAS + EVAP (8-68,T.W.A.)
  31 #include "geant321/eva1.inc"
  32 #include "geant321/forcn.inc"
  33 #include "geant321/inpflg.inc"
  34 #include "geant321/hetc5.inc"
  35 #include "geant321/hetc7.inc"
  36 #include "geant321/hettp.inc"
  37 #include "geant321/higfis.inc"
  38 *     COMMON / AZ /    LOWAZ
  39       LOGICAL LOPPAR
  40       DIMENSION  FPART (6)
  41 C     -------------------------------------- CHECK PARAMETER
  42       FISINH=.FALSE.
  43 *  +-------------------------------------------------------------------*
  44 *  |  Check the excitation energy
  45       IF ( EX .LE. ZERZER ) THEN
  46 *  |  No excitation energy:
  47          IF ( JFISS .LE. 0 ) THEN
  48             DO 201 I=1,6
  49                NPART(I)=0
  50   201       CONTINUE
  51             HEVSUM = ZERZER
  52          END IF
  53 *        UU = ZERZER
  54          UU = EX
  55          RETURN
  56 *  |
  57 *  +-------------------------------------------------------------------*
  58 *  |  Positive excitation energy:
  59       ELSE
  60 *  |  Try evaporation
  61          M2 = NINT (APR)
  62          M3 = NINT (ZPR)
  63  8801    CONTINUE
  64          CALL FKDRES (M2,M3,EX,UU,EREC,LOPPAR,JFISS)
  65          FPARTT = ZERZER
  66 *  |  +----------------------------------------------------------------*
  67 *  |  |  No previous evaporation for this event
  68          IF ( JFISS .LE. 0 ) THEN
  69             DO 801 I=1,6
  70                FPART(I) = NPART(I)
  71                FPARTT   = FPARTT + FPART (I)
  72   801       CONTINUE
  73 *  |  |
  74 *  |  +----------------------------------------------------------------*
  75 *  |  |  Other evaporation trials already performed for this event
  76          ELSE
  77             DO 802 I=1,6
  78                FPART(I) = NPART(I)-NPARTF(I,JFISS-1)
  79                FPARTT   = FPARTT + FPART (I)
  80   802       CONTINUE
  81          END IF
  82 *  |  |
  83 *  |  +----------------------------------------------------------------*
  84 *  |  +----------------------------------------------------------------*
  85 *  |  |  No particle evaporated and pairing corrections accounted for
  86          IF ( FPARTT + FKEY .LT. ANGLGB ) THEN
  87             IF ( .NOT. LOPPAR ) GO TO 8802
  88             FKEY = ONEONE
  89             GO TO 8801
  90          END IF
  91 *  |  |
  92 *  |  +----------------------------------------------------------------*
  93  8802    CONTINUE
  94          FKEY = ZERZER
  95          ZPR  = ZPR - FPART(2) - FPART(3) - TWOTWO * ( FPART(5)
  96      &        + FPART(6)) - FPART(4)
  97          APR  = APR - FPART(1) - FPART(2) - TWOTWO * FPART(3)
  98      &        - THRTHR * ( FPART(4) + FPART(5) ) - FOUFOU * FPART(6)
  99          IF (IANG .GT. 0) THEN
 100          ELSE
 101             DO 440 K=1,6
 102                NP = NPART(K)
 103                IF ( JFISS .GT. 0 ) THEN
 104                   NP0 = NPARTF(K,JFISS-1) + 1
 105                ELSE
 106                   NP0 = 1
 107                END IF
 108                DO 410 J=NP0,NP
 109                   CALL RACO(COSEVP(1,J,K),COSEVP(2,J,K),COSEVP(3,J,K))
 110   410          CONTINUE
 111   440       CONTINUE
 112          END IF
 113       END IF
 114 *  |
 115 *  +-------------------------------------------------------------------*
 116       RETURN
 117 *=== End of subroutine Erup ===========================================*
 118       END