Protections against nprim = 0
[u/mrichter/AliRoot.git] / TFluka / cmpips.f
1 *$ CREATE CMPIPS.FOR
2 *COPY CMPIPS
3 *                                                                      *
4 *=== Cmpips ===========================================================*
5 *                                                                      *
6       SUBROUTINE CMPIPS ( NALLD0, STEPID, STEPTT, STEP )
7
8       INCLUDE '(DBLPRC)'
9       INCLUDE '(DIMPAR)'
10       INCLUDE '(IOUNIT)'
11 *
12 *----------------------------------------------------------------------*
13 *                                                                      *
14 *     Copyright (C) 2005-2006:                Alfredo Ferrari          *
15 *     All rights reserved                                              *
16 *                                                                      *
17 *                                                                      *
18 *     CoMpute Primary Ionization PoSitions:                            *
19 *                                                                      *
20 *     Created  on  11 november 2005  by       Alfredo Ferrari          *
21 *                                               INFN - Milan           *
22 *                                                                      *
23 *     Last change  on  05-oct-06     by  Alfredo Ferrari               *
24 *                                                                      *
25 *                                                                      *
26 *     Input variables:                                                 *
27 *                                                                      *
28 *----------------------------------------------------------------------*
29 *
30       INCLUDE '(ALLDLT)'
31       INCLUDE '(TRACKR)'
32 *
33       LOGICAL LBGSTP
34       DIMENSION CUMTTR (0:MXTRCK), RNDVEC (MXALLD), INDVEC (MXALLD)
35 *
36       SAVE NSTART, CUMTTR
37 *
38       LBGSTP = STEPTT .LT. AZRZRZ
39       if (ntrack .eq. 0) THEN
40 *         WRITE(6,*) "Warning ntrack = 0", NALLD0, STEPID, STEPTT, STEP
41          RETURN
42       ENDIF
43 *  +-------------------------------------------------------------------*
44 *  |  Beginning of a step:
45       IF ( LBGSTP ) THEN
46          NSTART = 1
47          CUMTTR (0) = ZERZER
48          DO 1000 I = 1, NTRACK
49             CUMTTR (I) = CUMTTR (I-1) + TTRACK (I)
50  1000    CONTINUE
51          CRVCRR = STEP / CUMTTR (NTRACK)
52       END IF
53 *  |
54 *  +-------------------------------------------------------------------*
55       NRNGEN = MIN ( NALLDL, MXALLD ) - NALLD0
56       IF ( NRNGEN .LE. 0 ) RETURN
57       CALL FLRNLP ( RNDVEC, NRNGEN )
58 *  The previous line can be substituted by:
59 *     DO 1400 I = 1, NRNGEN
60 *        RNDVEC (I) = FLRNDM (RNDPOI)
61 *1400 CONTINUE
62       CALL RORDIN ( RNDVEC, INDVEC, NRNGEN )
63 *  +-------------------------------------------------------------------*
64 *  |  Loop on primary electrons:
65       DO 5000 I = 1, NRNGEN
66          TTRACR = ( STEPTT + RNDVEC (I) * STEPID ) / CRVCRR
67          NSTAR0 = NSTART
68          DO 3000 J = NSTAR0, NTRACK
69             IF ( TTRACR .LT. CUMTTR (J) ) THEN
70                NSTART = J
71                REDUC  = ( CUMTTR (J) - TTRACR ) / TTRACK (J)
72                GO TO 4000
73             END IF
74  3000    CONTINUE
75          CALL FLABRT ( 'CMPIPS', '3000-CONTINUE' )
76  4000    CONTINUE
77          IF ( REDUC .LT. ZERZER .OR. REDUC .GT. ONEONE )
78      &      CALL FLABRT ( 'CMPIPS', 'INVALID REDUC' )
79          K = I + NALLD0
80          XALLDL (K) = REDUC * ( XTRACK (NSTART) - XTRACK (NSTART-1) )
81      &              + XTRACK (NSTART-1)
82          YALLDL (K) = REDUC * ( YTRACK (NSTART) - YTRACK (NSTART-1) )
83      &              + YTRACK (NSTART-1)
84          ZALLDL (K) = REDUC * ( ZTRACK (NSTART) - ZTRACK (NSTART-1) )
85      &              + ZTRACK (NSTART-1)
86  5000 CONTINUE
87 *  |
88 *  +-------------------------------------------------------------------*
89       RETURN
90 *=== End of subroutine Cmpips =========================================*
91       END
92