* #include "geant321/pilot.h" C. SUBROUTINE SETMAT C. Adapted from GFTMAT(IMATE,IPATT,CHMECA,KDIM,TKIN,VALUE,PCUT,IXST) C. C. ****************************************************************** C. * * C. * Scale cross sections tabulated in JMATE banks for: * C. * material IMATE, particle IPATT, mecanism name CHMECA * C. * * C. * * C. * The CHMECAnism name can be : * C. * 'HADF' 'INEF' 'ELAF' 'FISF' 'CAPF' * C. * 'HADG' 'INEG' 'ELAG' 'FISG' 'CAPG' * C. * 'LOSS' 'PHOT' 'ANNI' 'COMP' 'BREM' * C. * 'PAIR' 'DRAY' 'PFIS' 'RAYL' 'HADG' * C. * 'MUNU' 'RANG' 'STEP' * C. * * C. * IMATE Geant material number * C. * IPATT Geant particle number * C. * CHMECA Geant mechanism name of the bank to be fetched * C. * SCALEF scale factor to be applied * C. * IXST flag = 1 if scaling took place , =0 otherwise * C. * * C. * Authors R.Holzmann 15/6/2001 * C. * * C. ****************************************************************** C. #include "geant321/gcbank.inc" #include "geant321/gcnum.inc" #include "geant321/gconst.inc" #include "geant321/gcunit.inc" #include "geant321/gcmulo.inc" #include "geant321/gsecti.inc" #include "geant321/gcflag.inc" #include "geant321/gctrak.inc" #include "geant321/gcmate.inc" #include "geant321/gctmed.inc" #include "geant321/gfkdis.inc" #include "geant321/gcking.inc" #include "geant321/gckine.inc" * LOGICAL CERKOV, LOOP CHARACTER*20 CHMECA, CHMAT, CHPAR #include "geant321/gcnmec.inc" * * ------------------------------------------------------------------ * call kugeti(IMATE) if (IMATE.lt.0) return call kugeti(IPATT) if (IPATT.le.0) return call kugetc(CHMECA,NLEN) if (NLEN.ne.4) return call kugetr(SCALEF) if (imate.eq.0) then loop = .true. imate = 1 else loop = .false. endif IXST = 0 IMECA = 0 DO 10 KMECA=1,NMECA IF(CHMECA.EQ.CHNMEC(KMECA)) THEN IMECA = KMECA ENDIF 10 CONTINUE IF(IMECA.EQ.0) THEN WRITE(CHMAIL,'('' *** SETMAT: Mechanism '',A, ' + //' ''not implemented'')') CHMECA CALL GMAIL(0,0) GOTO 999 ENDIF * IF(JMATE.LE.0) GO TO 999 IF(IMATE.LE.0) GO TO 999 1 IF(IMATE.GT.NMATE) GO TO 110 JMA = LQ(JMATE-IMATE) IF(JMA.LE.0) GO TO 110 A = Q(JMA+6) Z = Q(JMA+7) c IF(Z.LT.1.) GO TO 999 DENS = Q(JMA+8) RADL = Q(JMA+9) NLM = Q(JMA+11) JPROB = LQ(JMA-4) AZRO = Q(JPROB+8) AHEFF = A IF(NLM .GT.1) THEN JMIXT = LQ(JMA-5) JMI1 = LQ(JMIXT-1) AHEFF = Q(JMI1+1) ENDIF * IF(JTMED.LE.0) GO TO 999 IF(NTMED.LE.0) GO TO 999 JBANK = JTMED DO 40 ITM = 1,NTMED JTM = LQ(JTMED-ITM) IF(JTM.LE.0) GO TO 40 JTMN = 0 IMAT = Q(JTM+6) IF(IMAT.EQ.IMATE) THEN JTMN = LQ(JTM) IF(JTMN.NE.0) JBANK = JTMN GO TO 50 ENDIF 40 CONTINUE 50 CONTINUE CUTHAD = Q(JBANK+ 4) ILOSS = Q(JBANK+21) IMULS = Q(JBANK+22) IFIELD = Q(JTM + 8) FIELDM = Q(JTM + 9) TMAXFD = Q(JTM + 10) STEMAX = Q(JTM + 11) DEEMAX = Q(JTM + 12) STMIN = Q(JTM + 14) * IF(JPART.LE.0) GO TO 999 IF(IPATT.LE.0) GO TO 999 IF(IPATT.GT.NPART) GO TO 110 JPA = LQ(JPART-IPATT) IF(JPA.LE.0) GO TO 110 ITYPE = Q(JPA+6) AMASS = Q(JPA+7) CHARGE = Q(JPA+8) * * *** Find the correct pointer * JBANK = 0 ISHIF = 0 RMASS = 1. * * *** Photons * IF (ITYPE.EQ.1) THEN IF (CHMECA(1:4).EQ.'PHOT') JBANK = LQ(JMA- 6) IF (CHMECA(1:4).EQ.'COMP') JBANK = LQ(JMA- 8) IF (CHMECA(1:4).EQ.'PAIR') JBANK = LQ(JMA-10) IF (CHMECA(1:4).EQ.'PFIS') JBANK = LQ(JMA-12) IF (CHMECA(1:4).EQ.'RAYL') JBANK = LQ(JMA-13) * * *** Electrons / positons * ELSE IF (ITYPE.EQ.2) THEN IF (CHMECA(1:4).EQ.'LOSS') THEN JBANK = LQ(JMA- 1) IF (CHARGE.GT.0.) ISHIF = NEK1 ELSE IF (CHMECA(1:4).EQ.'RANG') THEN JBANK = LQ(JMA- 15) IF (CHARGE.GT.0.) ISHIF = NEK1 ELSE IF (CHMECA(1:4).EQ.'STEP') THEN JBANK = LQ(JTM- 1) ELSE IF ((CHMECA(1:4).EQ.'ANNI').AND.(CHARGE.GT.0.)) THEN JBANK = LQ(JMA- 7) ELSE IF (CHMECA(1:4).EQ.'BREM') THEN JBANK = LQ(JMA- 9) ELSE IF (CHMECA(1:4).EQ.'DRAY') THEN JBANK = LQ(JMA-11) IF (CHARGE.GT.0.) ISHIF = NEK1 ENDIF * * *** Neutral hadrons (***F for FLUKA cross sections * ***G for GHEISHA cross sections * LOWN and N*** for MICAP cross sections) * ELSE IF (ITYPE.EQ.3) THEN IF((CHMECA(1:4).EQ.'HADF').OR.(CHMECA(1:4).EQ.'INEF') + .OR.(CHMECA(1:4).EQ.'ELAF') .OR.(CHMECA(1:4).EQ.'FISF') + .OR.(CHMECA(1:4).EQ.'CAPF')) THEN JBANK = -3 ELSE IF((CHMECA(1:4).EQ.'HADG').OR.(CHMECA(1:4).EQ.'INEG') + .OR.(CHMECA(1:4).EQ. 'ELAG').OR.(CHMECA(1:4).EQ.'FISG') + .OR.(CHMECA(1:4).EQ.'CAPG')) THEN JBANK = -4 ELSE IF(IMECA.GE.IBLOWN.AND.IPATT.EQ.13) THEN IF (IFINIT(7) .EQ. 0) CALL GMORIN JBANK = -5 ENDIF K0OLD = K0FLAG * * *** Charged hadrons (***F for FLUKA cross sections * ***G for GHEISHA cross sections) * *** Heavy ions * ELSE IF (ITYPE.EQ.4.OR.ITYPE.EQ.8) THEN RMASS = PMASS/AMASS IF (CHMECA(1:4).EQ.'LOSS') THEN JBANK = LQ(JMA- 3) ELSE IF (CHMECA(1:4).EQ.'RANG') THEN JBANK = LQ(JMA- 16) + NEK1 ELSE IF (CHMECA(1:4).EQ.'STEP') THEN JBANK = -1 ELSE IF (CHMECA(1:4).EQ.'DRAY') THEN JBANK = -2 ELSE IF(((CHMECA(1:4).EQ.'HADF').OR.(CHMECA(1:4).EQ.'INEF') + .OR.(CHMECA(1:4).EQ. 'ELAF').OR.(CHMECA(1:4).EQ.'FISF') + .OR.(CHMECA(1:4).EQ.'CAPF')).AND.ITYPE.NE.8) THEN JBANK = -3 ELSE IF(((CHMECA(1:4).EQ.'HADG').OR.(CHMECA(1:4).EQ.'INEG') + .OR.(CHMECA(1:4).EQ. 'ELAG').OR.(CHMECA(1:4).EQ.'FISG') + .OR.(CHMECA(1:4).EQ.'CAPG')).AND.ITYPE.NE.8) THEN JBANK = -4 ENDIF K0OLD = K0FLAG * * *** Muons * ELSE IF (ITYPE.EQ.5) THEN IF (CHMECA(1:4).EQ.'LOSS') THEN JBANK = LQ(JMA- 2) ELSE IF (CHMECA(1:4).EQ.'RANG') THEN JBANK = LQ(JMA- 16) ELSE IF (CHMECA(1:4).EQ.'STEP') THEN JBANK = LQ(JTM- 2) ELSE IF (CHMECA(1:4).EQ.'MUNU') THEN JBANK = LQ(JMA- 14) ELSE IF (CHMECA(1:4).EQ.'BREM') THEN JBANK = LQ(JMA- 9) ISHIF = 2*NEK1 ELSE IF (CHMECA(1:4).EQ.'PAIR') THEN JBANK = LQ(JMA- 10) ISHIF = NEK1 ELSE IF (CHMECA(1:4).EQ.'DRAY') THEN JBANK = LQ(JMA-11) ISHIF = 2*NEK1 ENDIF * * *** Geantinos * ELSEIF (ITYPE.EQ.6) THEN WRITE(CHMAIL,10000) CALL GMAIL(0,0) JBANK = 0 * * *** Cerenkov * ELSEIF (ITYPE.EQ.7) THEN IF (CHMECA(1:4).EQ.'LABS') THEN * * *** Not implemented yet! JBANK=0 ENDIF * ENDIF CERKOV=.FALSE. IF(CHARGE.NE.0.AND.ITCKOV.NE.0) THEN IF(IQ(JTM-2).GE.3) THEN IF(LQ(JTM-3).NE.0.AND.LQ(LQ(JTM-3)-3).NE.0) THEN * * *** In this tracking medium Cerenkov photons are generated and * *** tracked. Set to 1 the corresponding flag and calculate the * *** relevant pointers. * CERKOV = .TRUE. JTCKOV = LQ(JTM-3) JABSCO = LQ(JTCKOV-1) JEFFIC = LQ(JTCKOV-2) JINDEX = LQ(JTCKOV-3) JCURIN = LQ(JTCKOV-4) NPCKOV = Q(JTCKOV+1) ENDIF ENDIF ENDIF IF(JBANK.LE.0) GO TO 999 IXST = 1 * * JBANK = JBANK + ISHIF call gfmate(IMATE,CHMAT,R1,R2,R3,R4,R5,R6,I1) call gfpart(IPATT,CHPAR,I1,R1,R2,R3,R4,I2) write(6,*) "Rescale mfp of proc. ",CHMECA(1:4), + " in med. ",CHMAT(1:12), + " for part. ",CHPAR(1:8)," by ",SCALEF DO 100 IKB = 1,NEK1 * loop over bin numbers in table JMATE and rescale * * Retrieve value from bank JMATE VALUE = Q(JBANK+IKB) c write(6,*) IKB, VALUE IF ((CHMECA(1:4).EQ.'PHOT').AND.(EKP.GE.0.05 )) VALUE = BIG IF ((CHMECA(1:4).EQ.'MUNU').AND.(EKP.LT.0.05 )) VALUE = BIG IF (VALUE.NE.BIG) VALUE = VALUE*SCALEF Q(JBANK+IKB) = VALUE 100 CONTINUE * if (loop) then if (IMATE.eq.NMATE) goto 999 IMATE= IMATE+1 goto 1 ! dirty, dirty! endif GO TO 999 110 WRITE(CHMAIL,10100) IMATE ,IPATT CALL GMAIL(0,0) * 10000 FORMAT(' ***** SETMAT: No processes active for geantinos') 10100 FORMAT(' ***** SETMAT error : material',I4, + ' or particle',I4,' not defined' ) 999 RETURN END