[u/mrichter/AliRoot.git] / GEANT321 / fluka / fkerup.F

*
* $Id$
*
* $Log$
* Revision 1.1.1.1  1995/10/24 10:20:06  cernlib
* Geant
*
*
#include "geant321/pilot.h"
*CMZ :  3.21/02 29/03/94  15.41.45  by  S.Giani
*-- Author :
*=== erup =============================================================*
*                                                                      *
      SUBROUTINE FKERUP (JFISS)
 
#include "geant321/dblprc.inc"
#include "geant321/dimpar.inc"
#include "geant321/iounit.inc"
*
*----------------------------------------------------------------------*
*                                                                      *
*     Created  on   15 may 1990     by     Alfredo & Paola Sala        *
*                                              INFN - Milan            *
*     Last change  on   10-apr-93   by     Alfredo Ferrari, INFN-Milan *
*                                                                      *
*     Derived from the ERUP routine of EVAP-V, HERMES, KFA-Julich      *
*                                                                      *
*----------------------------------------------------------------------*
*
C*****MODIFIED TO OBTAIN APR,ZPR AFTER CAS + EVAP (8-68,T.W.A.)
#include "geant321/eva1.inc"
#include "geant321/forcn.inc"
#include "geant321/inpflg.inc"
#include "geant321/hetc5.inc"
#include "geant321/hetc7.inc"
#include "geant321/hettp.inc"
#include "geant321/higfis.inc"
*     COMMON / AZ /    LOWAZ
      LOGICAL LOPPAR
      DIMENSION  FPART (6)
C     -------------------------------------- CHECK PARAMETER
      FISINH=.FALSE.
*  +-------------------------------------------------------------------*
*  |  Check the excitation energy
      IF ( EX .LE. ZERZER ) THEN
*  |  No excitation energy:
         IF ( JFISS .LE. 0 ) THEN
            DO 201 I=1,6
               NPART(I)=0
  201       CONTINUE
            HEVSUM = ZERZER
         END IF
*        UU = ZERZER
         UU = EX
         RETURN
*  |
*  +-------------------------------------------------------------------*
*  |  Positive excitation energy:
      ELSE
*  |  Try evaporation
         M2 = NINT (APR)
         M3 = NINT (ZPR)
 8801    CONTINUE
         CALL FKDRES (M2,M3,EX,UU,EREC,LOPPAR,JFISS)
         FPARTT = ZERZER
*  |  +----------------------------------------------------------------*
*  |  |  No previous evaporation for this event
         IF ( JFISS .LE. 0 ) THEN
            DO 801 I=1,6
               FPART(I) = NPART(I)
               FPARTT   = FPARTT + FPART (I)
  801       CONTINUE
*  |  |
*  |  +----------------------------------------------------------------*
*  |  |  Other evaporation trials already performed for this event
         ELSE
            DO 802 I=1,6
               FPART(I) = NPART(I)-NPARTF(I,JFISS-1)
               FPARTT   = FPARTT + FPART (I)
  802       CONTINUE
         END IF
*  |  |
*  |  +----------------------------------------------------------------*
*  |  +----------------------------------------------------------------*
*  |  |  No particle evaporated and pairing corrections accounted for
         IF ( FPARTT + FKEY .LT. ANGLGB ) THEN
            IF ( .NOT. LOPPAR ) GO TO 8802
            FKEY = ONEONE
            GO TO 8801
         END IF
*  |  |
*  |  +----------------------------------------------------------------*
 8802    CONTINUE
         FKEY = ZERZER
         ZPR  = ZPR - FPART(2) - FPART(3) - TWOTWO * ( FPART(5)
     &        + FPART(6)) - FPART(4)
         APR  = APR - FPART(1) - FPART(2) - TWOTWO * FPART(3)
     &        - THRTHR * ( FPART(4) + FPART(5) ) - FOUFOU * FPART(6)
         IF (IANG .GT. 0) THEN
         ELSE
            DO 440 K=1,6
               NP = NPART(K)
               IF ( JFISS .GT. 0 ) THEN
                  NP0 = NPARTF(K,JFISS-1) + 1
               ELSE
                  NP0 = 1
               END IF
               DO 410 J=NP0,NP
                  CALL RACO(COSEVP(1,J,K),COSEVP(2,J,K),COSEVP(3,J,K))
  410          CONTINUE
  440       CONTINUE
         END IF
      END IF
*  |
*  +-------------------------------------------------------------------*
      RETURN
*=== End of subroutine Erup ===========================================*
      END
Commit	Line	Data
fe4da5cc	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