Updated misalignment macros (Raffaele)

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

diff --git a/TFluka/crnkvp.f b/TFluka/crnkvp.f
index 55d78842d40aec10ee80c930f6ae83069a972a6e..e5ca1d2dd6c5eda632efda4692b1b7f1da59bf2b 100644 (file)
--- a/TFluka/crnkvp.f
+++ b/TFluka/crnkvp.f
@@ -35,12 +35,12 @@
 *----------------------------------------------------------------------*
 *
       INCLUDE '(FHEAVY)'
-      INCLUDE '(MAPA)'
+      INCLUDE '(FLKMAT)'
       INCLUDE '(MULBOU)'
       INCLUDE '(OPPHCM)'
       INCLUDE '(OPPHST)'
       INCLUDE '(PAPROP)'
-      INCLUDE '(STARS)'
+      INCLUDE '(SUMCOU)'
       INCLUDE '(TRACKR)'
 *
       PARAMETER ( CSNPRN = 100.D+00 * CSNNRM )
@@ -108,8 +108,8 @@
 *  Take a three sigma clearance:
       NEMPHO = NEMPHO + 10 + 3 * NINT ( SQRT ( CTRACK * SIGMCK ) )
       NEMPHO = MIN ( NEMPHO, MOSTCK )
-D     IF ( LSTOPP .GT. MOSTCK - NEMPHO ) WRITE (77,*)
-D    &   ' ###CRNKVP:LSTOPP:',LSTOPP,NEMPHO
+*D     IF ( LSTOPP .GT. MOSTCK - NEMPHO ) WRITE (77,*)
+*D    &   ' ###CRNKVP:LSTOPP:',LSTOPP,NEMPHO
 *  +-------------------------------------------------------------------*
 *  |  Empty the stack if too full: compute and save the normal in case
 *  |  it is required
@@ -148,15 +148,16 @@ D    &   ' ###CRNKVP:LSTOPP:',LSTOPP,NEMPHO
 *  +-------------------------------------------------------------------*
 *  +-------------------------------------------------------------------*
 *  |  Stacking loop for Cerenkov photons:
+      NPROD = 0
  1000 CONTINUE
-D        IF ( SIGMCK .LT. ZERZER ) WRITE (77,*)
-D    &      ' ^^^CRNKVP:SIGMCK,BTNFCR',SIGMCK,BTNFCR
+*D        IF ( SIGMCK .LT. ZERZER ) WRITE (77,*)
+*D    &      ' ^^^CRNKVP:SIGMCK,BTNFCR',SIGMCK,BTNFCR
 *D        IF ( DEDXCR .LT. AZRZRZ ) WRITE (77,*)' ###CRNKVP:',
 *D    &  'MMAT,JTRACK,DEDXCR,NTRKCR,DTRACK(NTRKCR),CTRACK,TRNRSD,DTRCKT',
 *D    &   MMAT,JTRACK,DEDXCR,NTRKCR,DTRACK(NTRKCR),CTRACK,TRNRSD,DTRCKT
 *  |  Empty the stack if too full:
-D        IF ( LSTOPP .EQ. MOSTCK ) WRITE (77,*)
-D    &      ' ###CRNKVP:LSTOPP:',LSTOPP
+*D        IF ( LSTOPP .EQ. MOSTCK ) WRITE (77,*)
+*D    &      ' ###CRNKVP:LSTOPP:',LSTOPP
 *  |  +----------------------------------------------------------------*
 *  |  |  Empty the stack if too full: compute and save the normal in
 *  |  |  case it is required
@@ -174,8 +175,8 @@ D    &      ' ###CRNKVP:LSTOPP:',LSTOPP
 *  |  +----------------------------------------------------------------*
 *  |  |  Sub-step loop:
  1500    CONTINUE
-D           IF ( NTRKCR .GT. NTRACK ) WRITE (77,*)
-D    &         ' ^^^CRNKVP:NTRKCR,NTRACK',NTRKCR,NTRACK
+*D           IF ( NTRKCR .GT. NTRACK ) WRITE (77,*)
+*D    &         ' ^^^CRNKVP:NTRKCR,NTRACK',NTRKCR,NTRACK
 *  |  |  +-------------------------------------------------------------*
 *  |  |  |  The production point is inside the current sub-step:
             IF ( DSTPRD .LE. TRNRSD ) THEN
@@ -240,9 +241,9 @@ D    &         ' ^^^CRNKVP:NTRKCR,NTRACK',NTRKCR,NTRACK
          BTNFLD = BTNFCR
          BTNFCR = ( BETNCR - ONEONE ) * ( BETNCR + ONEONE ) / BETNCR**2
          FREJE  = BTNFCR / BTNFLD
-D        IF ( FREJE .GT. ONEPLS ) WRITE (77,*) ' ^^^CRNKVP:',
-D    &       'FREJE,BETNCR,BETNLD,DEDXCR,PTRKCR,ETRKCR,PTRACK,ETRACK',
-D    &        FREJE,BETNCR,BETNLD,DEDXCR,PTRKCR,ETRKCR,PTRACK,ETRACK
+*D        IF ( FREJE .GT. ONEPLS ) WRITE (77,*) ' ^^^CRNKVP:',
+*D    &       'FREJE,BETNCR,BETNLD,DEDXCR,PTRKCR,ETRKCR,PTRACK,ETRACK',
+*D    &        FREJE,BETNCR,BETNLD,DEDXCR,PTRKCR,ETRKCR,PTRACK,ETRACK
 *  |  Update the macroscopic sigma: beta can only decrease
          SIGMCK = SIGMCK * FREJE
          RNDREJ = FLRNDM (RNDREJ)
@@ -267,9 +268,9 @@ D    &        FREJE,BETNCR,BETNLD,DEDXCR,PTRKCR,ETRKCR,PTRACK,ETRACK
 *  |  Compute the quantum efficiency for this emitted energy:
          OPSENS = FOPTSN ( WVLSMP, OMGSMP )
          FREJE  = BTNFSM / BTNFCR * OPSENS / OPSNMX
-D        IF ( FREJE .GT. ONEPLS ) WRITE (77,*)
-D    &      ' ^^^CRNKVP:FREJE,RFISMP,RMXCER(MMAT),OPSENS,MMAT',
-D    &                  FREJE,RFISMP,RMXCER(MMAT),OPSENS,MMAT
+*D        IF ( FREJE .GT. ONEPLS ) WRITE (77,*)
+*D    &      ' ^^^CRNKVP:FREJE,RFISMP,RMXCER(MMAT),OPSENS,MMAT',
+*D    &                  FREJE,RFISMP,RMXCER(MMAT),OPSENS,MMAT
          RNDREJ = FLRNDM (RNDREJ)
 *dbgD        WRITE (77,*) ' CRNKVP:BTNFSM,BTNFCR,RNDREJ',
 *dbgD    &                         BTNFSM,BTNFCR,RNDREJ
@@ -299,9 +300,9 @@ D    &                  FREJE,RFISMP,RMXCER(MMAT),OPSENS,MMAT
 *  |  |
 *  |  +----------------------------------------------------------------*
          SRNRSD = TUVWCR * TRNRSD / CRVCRR / TTRACK (NTRKCR)
-D        IF ( SRNRSD .LT. ZERZER .OR. SRNRSD .GT. TUVWCR )
-D    &      WRITE (77,*)' ^^^CRNKVP:SRNRSD,TUVWCR,NTRKCR',
-D    &                              SRNRSD,TUVWCR,NTRKCR
+*D        IF ( SRNRSD .LT. ZERZER .OR. SRNRSD .GT. TUVWCR )
+*D    &      WRITE (77,*)' ^^^CRNKVP:SRNRSD,TUVWCR,NTRKCR',
+*D    &                              SRNRSD,TUVWCR,NTRKCR
          XTRKCR = XTRACK (NTRKCR) - UTRKCR * SRNRSD
          YTRKCR = YTRACK (NTRKCR) - VTRKCR * SRNRSD
          ZTRKCR = ZTRACK (NTRKCR) - WTRKCR * SRNRSD
@@ -320,7 +321,7 @@ D    &                              SRNRSD,TUVWCR,NTRKCR
                      GO TO 2010
                   END IF
  2000          CONTINUE
-D              CALL FLABRT ( 'CRNKVP', 'STOP:CRNKVP-NO-VALID-LATTICE' )
+*D              CALL FLABRT ( 'CRNKVP', 'STOP:CRNKVP-NO-VALID-LATTICE' )
  2010          CONTINUE
             END IF
          END IF
@@ -402,16 +403,33 @@ D              CALL FLABRT ( 'CRNKVP', 'STOP:CRNKVP-NO-VALID-LATTICE' )
             WRITE (LUNERR,'(A,1PG23.15,A)')
      &           ' *** Crnkvp: bad polarization',
      &              SCADOT, ' ***'
-D           WRITE (77,'(A,1PG23.15)')
-D    &            ' ^^^Crnkvp: bad polarization',
-D    &              SCADOT
+*D           WRITE (77,'(A,1PG23.15)')
+*D    &            ' ^^^Crnkvp: bad polarization',
+*D    &              SCADOT
          END IF
          WTOPPH (LSTOPP) = WTRACK
          AGOPPH (LSTOPP) = ATRKCR
          CMPOPP (LSTOPP) = ZERZER
          LOOPPH (LSTOPP) = LTRACK + 1
+*
+*
+*        Hook to TFluka
+*
+         PXCR =  EPHSMP * TXOPPH (LSTOPP)
+         PYCR =  EPHSMP * TYOPPH (LSTOPP)
+         PZCR =  EPHSMP * TZOPPH (LSTOPP)
+         POX  = TXPOPP(LSTOPP)
+         POY  = TYPOPP(LSTOPP)
+         POZ  = TZPOPP(LSTOPP)
+         CALL pshckp(PXCR, PYCR, PZCR, EPHSMP, XTRKCR, 
+     &        YTRKCR , ZTRKCR, ATRKCR, POX, POY, POZ, WTRACK, ITFL)
+         NPROD = NPROD + 1
+         CALL ustckv(NPROD, MREG, XTRKCR, YTRKCR, ZTRKCR)
+*
+*
+*
 *  |  !!!!!! Here Stuprf should be used !!!!!!
-         LOUOPP (LSTOPP) = LLOUSE
+         LOUOPP (LSTOPP) = ITFL
          DO 2100 ISPR = 1, MKBMX1
             SPAROK (ISPR,LSTOPP) = SPAUSR (ISPR)
  2100    CONTINUE