X-Git-Url: http://git.uio.no/git/?a=blobdiff_plain;ds=sidebyside;f=TFluka%2Fcrnkvp.f;h=999896019e504ca22f608ce6047c6857243da888;hb=7771752ec862f31222329412e915e79197b8cea3;hp=987769fac2783114b9781a15ce329ffae02b4b79;hpb=111f92a03e3a9ab9168323379c9fe4b1ee9884e8;p=u%2Fmrichter%2FAliRoot.git diff --git a/TFluka/crnkvp.f b/TFluka/crnkvp.f index 987769fac27..999896019e5 100644 --- 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 ) @@ -56,8 +56,8 @@ * IF ( LEMAGN ) * & CALL FLABRT ( 'CRNKVP', ' STOP:LEMAGN-NOT-YET-IMPLEMENTED' ) * No change of lattice check implemented for the moment: - IF ( LT1TRK .NE. LT2TRK ) CALL FLABRT ( 'CRNKVP', - & ' STOP:LT1TRK.NE.LT2TRK-NOT-YET-IMPLEMENTED' ) +* IF ( LT1TRK .NE. LT2TRK ) CALL FLABRT ( 'CRNKVP', +* & ' STOP:LT1TRK.NE.LT2TRK-NOT-YET-IMPLEMENTED' ) DEDXCK = ZERZER MMAT = MEDIUM (MREG) IF ( JTRACK .GE. -6 ) THEN @@ -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,14 +403,31 @@ 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 DO 2100 ISPR = 1, MKBMX1