GEANT321/fluka/erup.F

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