[u/mrichter/AliRoot.git] / TFluka / cmpips.f

*$ CREATE CMPIPS.FOR
*COPY CMPIPS
*                                                                      *
*=== Cmpips ===========================================================*
*                                                                      *
      SUBROUTINE CMPIPS ( NALLD0, STEPID, STEPTT, STEP )

      INCLUDE '(DBLPRC)'
      INCLUDE '(DIMPAR)'
      INCLUDE '(IOUNIT)'
*
*----------------------------------------------------------------------*
*                                                                      *
*     Copyright (C) 2005-2006:                Alfredo Ferrari          *
*     All rights reserved                                              *
*                                                                      *
*                                                                      *
*     CoMpute Primary Ionization PoSitions:                            *
*                                                                      *
*     Created  on  11 november 2005  by       Alfredo Ferrari          *
*                                               INFN - Milan           *
*                                                                      *
*     Last change  on  05-oct-06     by  Alfredo Ferrari               *
*                                                                      *
*                                                                      *
*     Input variables:                                                 *
*                                                                      *
*----------------------------------------------------------------------*
*
      INCLUDE '(ALLDLT)'
      INCLUDE '(TRACKR)'
*
      LOGICAL LBGSTP
      DIMENSION CUMTTR (0:MXTRCK), RNDVEC (MXALLD), INDVEC (MXALLD)
*
      SAVE NSTART, CUMTTR
*
D     IF ( ABS ( CTRACK - STEP ) .GT. CSNNRM * CTRACK )
D    &   CALL FLABRT ( 'CMPIPS', 'STEP!=CTRACK' )
      LBGSTP = STEPTT .LT. AZRZRZ
*  +-------------------------------------------------------------------*
*  |  Beginning of a step:
      IF ( LBGSTP ) THEN
         NSTART = 1
         CUMTTR (0) = ZERZER
         DO 1000 I = 1, NTRACK
            CUMTTR (I) = CUMTTR (I-1) + TTRACK (I)
 1000    CONTINUE
         CRVCRR = STEP / CUMTTR (NTRACK)
      END IF
*  |
*  +-------------------------------------------------------------------*
      NRNGEN = NALLDL - NALLD0
      IF ( NRNGEN .LE. 0 ) RETURN
      CALL FLRNLP ( RNDVEC, NRNGEN )
*  The previous line can be substituted by:
*     DO 1400 I = 1, NRNGEN
*        RNDVEC (I) = FLRNDM (RNDPOI)
*1400 CONTINUE
      CALL RORDIN ( RNDVEC, INDVEC, NRNGEN )
*  +-------------------------------------------------------------------*
*  |  Loop on primary electrons:
      DO 5000 I = 1, NRNGEN
         TTRACR = ( STEPTT + RNDVEC (I) * STEPID ) / CRVCRR
         NSTAR0 = NSTART
         DO 3000 J = NSTAR0, NTRACK
            IF ( TTRACR .LT. CUMTTR (J) ) THEN
               NSTART = J
               REDUC  = ( CUMTTR (J) - TTRACR ) / TTRACK (J)
               GO TO 4000
            END IF
 3000    CONTINUE
         CALL FLABRT ( 'CMPIPS', '3000-CONTINUE' )
 4000    CONTINUE
         IF ( REDUC .LT. ZERZER .OR. REDUC .GT. ONEONE )
     &      CALL FLABRT ( 'CMPIPS', 'INVALID REDUC' )
         K = I + NALLD0
         XALLDL (K) = REDUC * ( XTRACK (NSTART) - XTRACK (NSTART-1) )
     &              + XTRACK (NSTART-1)
         YALLDL (K) = REDUC * ( YTRACK (NSTART) - YTRACK (NSTART-1) )
     &              + YTRACK (NSTART-1)
         ZALLDL (K) = REDUC * ( ZTRACK (NSTART) - ZTRACK (NSTART-1) )
     &              + ZTRACK (NSTART-1)
 5000 CONTINUE
*  |
*  +-------------------------------------------------------------------*
      RETURN
*=== End of subroutine Cmpips =========================================*
      END
Commit	Line	Data
da6f1a87	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	D IF ( ABS ( CTRACK - STEP ) .GT. CSNNRM * CTRACK )
	39	D & CALL FLABRT ( 'CMPIPS', 'STEP!=CTRACK' )
	40	LBGSTP = STEPTT .LT. AZRZRZ
	41	* +-------------------------------------------------------------------*
	42	* \| Beginning of a step:
	43	IF ( LBGSTP ) THEN
	44	NSTART = 1
	45	CUMTTR (0) = ZERZER
	46	DO 1000 I = 1, NTRACK
	47	CUMTTR (I) = CUMTTR (I-1) + TTRACK (I)
	48	1000 CONTINUE
	49	CRVCRR = STEP / CUMTTR (NTRACK)
	50	END IF
	51	* \|
	52	* +-------------------------------------------------------------------*
	53	NRNGEN = NALLDL - NALLD0
	54	IF ( NRNGEN .LE. 0 ) RETURN
	55	CALL FLRNLP ( RNDVEC, NRNGEN )
	56	* The previous line can be substituted by:
	57	* DO 1400 I = 1, NRNGEN
	58	* RNDVEC (I) = FLRNDM (RNDPOI)
	59	*1400 CONTINUE
	60	CALL RORDIN ( RNDVEC, INDVEC, NRNGEN )
	61	* +-------------------------------------------------------------------*
	62	* \| Loop on primary electrons:
	63	DO 5000 I = 1, NRNGEN
	64	TTRACR = ( STEPTT + RNDVEC (I) * STEPID ) / CRVCRR
65	NSTAR0 = NSTART
66	DO 3000 J = NSTAR0, NTRACK
67	IF ( TTRACR .LT. CUMTTR (J) ) THEN
68	NSTART = J
69	REDUC = ( CUMTTR (J) - TTRACR ) / TTRACK (J)
70	GO TO 4000
71	END IF
72	3000 CONTINUE
73	CALL FLABRT ( 'CMPIPS', '3000-CONTINUE' )
74	4000 CONTINUE
75	IF ( REDUC .LT. ZERZER .OR. REDUC .GT. ONEONE )
76	& CALL FLABRT ( 'CMPIPS', 'INVALID REDUC' )
77	K = I + NALLD0
78	XALLDL (K) = REDUC * ( XTRACK (NSTART) - XTRACK (NSTART-1) )
79	& + XTRACK (NSTART-1)
80	YALLDL (K) = REDUC * ( YTRACK (NSTART) - YTRACK (NSTART-1) )
81	& + YTRACK (NSTART-1)
82	ZALLDL (K) = REDUC * ( ZTRACK (NSTART) - ZTRACK (NSTART-1) )
83	& + ZTRACK (NSTART-1)
84	5000 CONTINUE
85	* \|
86	* +-------------------------------------------------------------------*
87	RETURN
88	=== End of subroutine Cmpips =========================================
89	END
90