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 *  +-------------------------------------------------------------------*
  40 *  |  Beginning of a step:
  41       IF ( LBGSTP ) THEN
  42          NSTART = 1
  43          CUMTTR (0) = ZERZER
  44          DO 1000 I = 1, NTRACK
  45             CUMTTR (I) = CUMTTR (I-1) + TTRACK (I)
  46  1000    CONTINUE
  47          CRVCRR = STEP / CUMTTR (NTRACK)
  48       END IF
  49 *  |
  50 *  +-------------------------------------------------------------------*
  51       NRNGEN = MIN ( NALLDL, MXALLD ) - NALLD0
  52       IF ( NRNGEN .LE. 0 ) RETURN
  53       CALL FLRNLP ( RNDVEC, NRNGEN )
  54 *  The previous line can be substituted by:
  55 *     DO 1400 I = 1, NRNGEN
  56 *        RNDVEC (I) = FLRNDM (RNDPOI)
  57 *1400 CONTINUE
  58       CALL RORDIN ( RNDVEC, INDVEC, NRNGEN )
  59 *  +-------------------------------------------------------------------*
  60 *  |  Loop on primary electrons:
  61       DO 5000 I = 1, NRNGEN
  62          TTRACR = ( STEPTT + RNDVEC (I) * STEPID ) / CRVCRR
  63          NSTAR0 = NSTART
  64          DO 3000 J = NSTAR0, NTRACK
  65             IF ( TTRACR .LT. CUMTTR (J) ) THEN
  66                NSTART = J
  67                REDUC  = ( CUMTTR (J) - TTRACR ) / TTRACK (J)
  68                GO TO 4000
  69             END IF
  70  3000    CONTINUE
  71          CALL FLABRT ( 'CMPIPS', '3000-CONTINUE' )
  72  4000    CONTINUE
  73          IF ( REDUC .LT. ZERZER .OR. REDUC .GT. ONEONE )
  74      &      CALL FLABRT ( 'CMPIPS', 'INVALID REDUC' )
  75          K = I + NALLD0
  76          XALLDL (K) = REDUC * ( XTRACK (NSTART) - XTRACK (NSTART-1) )
  77      &              + XTRACK (NSTART-1)
  78          YALLDL (K) = REDUC * ( YTRACK (NSTART) - YTRACK (NSTART-1) )
  79      &              + YTRACK (NSTART-1)
  80          ZALLDL (K) = REDUC * ( ZTRACK (NSTART) - ZTRACK (NSTART-1) )
  81      &              + ZTRACK (NSTART-1)
  82  5000 CONTINUE
  83 *  |
  84 *  +-------------------------------------------------------------------*
  85       RETURN
  86 *=== End of subroutine Cmpips =========================================*
  87       END
  88