This commit was generated by cvs2svn to compensate for changes in r2,
[u/mrichter/AliRoot.git] / 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