*CMZU: 3.06/00 28/12/94 17.39.21 by Matthias Korn *CMZ : 3.05/02 08/11/94 15.07.49 by Vladimir Shekelyan *CMZ : 3.04/01 01/10/94 21.10.29 by Stephan Egli *CMZU: 3.01/02 23/03/94 17.59.14 by Stephan Egli *CMZ : 3.01/01 22/03/94 17.24.46 by Stephan Egli *CMZU: 3.01/00 05/03/94 20.57.42 by Stephan Egli *CMZU: 3.00/01 12/11/93 16.44.27 by Stephan Egli *-- Author : Stephan Egli PROGRAM SIMH1 ************************************************************************ * Main program for purely simulation jobs. Use the following flags * * to extract the proper version: * * * * Flag H1GEAONLY: only the H1GEA module is run (e.g. for external * * productions. * * no flags: H1GEA + digi + trigger modules * ************************************************************************ * *KEEP,CJOBNR. COMMON/CJOBNR/JOBNR,LAB SAVE /CJOBNR/ *KEND. *KEEP,BCS. INTEGER NHROW,NHCOL,NHLEN PARAMETER (NHROW = 2, NHCOL = 1, NHLEN=2) INTEGER NBOSIW PARAMETER (NBOSIW=1000000) INTEGER IW(NBOSIW) REAL RW(NBOSIW) COMMON /BCS/ IW EQUIVALENCE (RW(1),IW(1)) SAVE /BCS/ *KEND. CHARACTER*8 INBOS * * initialize BOS * CALL BNAMES(2000) CALL BOS(IW,NBOSIW) * * * read i/o commands and steering banks CALL FPARMR(5) CALL BREADC * * check for input file: * 35 IF(IFRST('BOSINPUT',0).NE.0)THEN INBOS='BOSINPUT' ELSE INBOS=' ' ENDIF * initialize random number generator * get next job number JOBNR=MDB('/JOB') CALL H1RNIN(JOBNR+1) * ---- event processing loop ------------------------------------------ * 10 CALL FSEQR(INBOS,IRET) IF(IRET.LT.0) GOTO 100 IF(INBOS.EQ.' ')CALL INLGEN * ----------- tracking module ---------------- CALL H1GEA * select run number (call has no effect, if no RUNR bank available) CALL NEWRUN(IEND) IF(IEND.EQ.1)CALL FSEQE * ----------- digi modules ------------------- c CALL CDIGI CALL FDIGI c CALL ADIGI c CALL PDIGI c CALL BDIGI c CALL SDIGI c CALL IDIGI c CALL MDIGI c CALL JHITS c CALL JDIGI c CALL LDIGI * -------------- trigger modules ----------------- c CALL MWTRES c CALL ARTRES c CALL DCTRES c CALL BCTRES c CALL SPTRES c CALL MUTRES c CALL LUTRES * trigger elements c CALL CTCELE * central trigger logic c CALL CTCLOG CALL FSEQW('BOSOUTPUT') GOTO 10 * * perform final book keeping 100 IND=MDB('/END') CALL FPARM('CLOSE ALL') STOP END *CMZ : 3.06/36 23/02/96 17.36.31 by Vladimir Shekelyan *CMZ : 3.06/35 08/02/96 20.15.42 by Vladimir Shekelyan *CMZ : 3.06/34 07/02/96 22.39.33 by Vladimir Shekelyan *CMZ : 3.06/25 28/09/95 21.07.06 by Vladimir Shekelyan *CMZ : 3.06/24 12/09/95 21.52.07 by Vladimir Shekelyan *CMZ : 3.06/22 04/08/95 23.50.55 by Vladimir Shekelyan *CMZ : 3.06/16 09/05/95 03.33.20 by Vladimir Shekelyan *CMZ : 3.06/15 28/04/95 23.25.47 by Vladimir Shekelyan *CMZ : 3.06/13 03/04/95 23.35.33 by Vladimir Shekelyan *CMZ : 3.06/12 30/03/95 13.27.54 by Vladimir Shekelyan *CMZ : 3.06/11 27/02/95 21.31.39 by Vladimir Shekelyan *CMZ : 3.06/08 19/02/95 13.35.50 by Vladimir Shekelyan *CMZ : 3.06/07 09/02/95 21.37.37 by Vladimir Shekelyan *CMZ : 3.06/06 02/02/95 16.29.21 by Vladimir Shekelyan *CMZU: 3.06/00 12/01/95 16.48.47 by Matthias Korn *CMZ : 3.05/07 06/01/95 16.34.14 by Vladimir Shekelyan *CMZ : 3.05/06 15/12/94 19.45.35 by Vladimir Shekelyan *CMZ : 3.05/05 05/12/94 20.11.29 by Vladimir Shekelyan *CMZ : 3.05/04 20/11/94 22.31.23 by Vladimir Shekelyan *CMZ : 3.05/02 08/11/94 15.12.54 by Vladimir Shekelyan *CMZ : 3.05/00 04/11/94 10.36.07 by Stephan Egli *CMZ : 3.04/01 29/09/94 18.13.58 by Stephan Egli *CMZU: 3.03/00 12/05/94 09.07.38 by Stephan Egli *CMZU: 3.01/00 24/02/94 10.13.05 by Stephan Egli *CMZU: 3.00/03 16/12/93 17.38.26 by Vladimir Shekelyan *CMZU: 3.00/00 12/10/93 17.03.25 by Stephan Egli *CMZU: 2.14/02 25/08/93 18.00.57 by Vladimir Shekelyan *CMZU: 2.14/00 12/07/93 16.32.54 by Stephan Egli *CMZU: 2.13/00 20/05/93 18.22.29 by Stephan Egli *CMZU: 2.12/03 10/05/93 18.03.52 by Stephan Egli *CMZU: 2.12/00 11/03/93 13.51.50 by Stephan Egli *CMZ : 2.11/03 28/02/93 14.46.14 by Stephan Egli *CMZ : 2.11/01 28/02/93 11.33.27 by Stephan Egli *CMZU: 2.10/13 13/02/93 10.51.07 by Stephan Egli *CMZ : 2.10/12 12/02/93 18.23.22 by Stephan Egli *CMZU: 2.10/00 16/12/92 08.22.23 by Stephan Egli *CMZU: 2.08/04 16/09/92 12.35.48 by Stephan Egli *CMZ : 2.07/00 26/03/92 14.05.19 by Stephan Egli *CMZU: 2.06/01 02/01/92 20.17.59 by Stephan Egli *CMZU: 2.00/03 22/04/91 15.47.05 by Stephan Egli *CMZ : 2.00/00 10/02/91 09.08.49 by Stephan Egli *CMZ : 1.08/01 16/01/91 14.30.50 by Stephan Egli *-- Author : Stephan Egli SUBROUTINE H1GEA *#********************************************************************** *# * *# SUBROUTINE H1GEA * *# * *# PURPOSE: Perform GEANT simulation for one event. * *# * *# Main steering routine of module 'H1GEA' * *# * *# Changed by M. Korn 02.12.94: merge A.F.'s changes of version * *# 3.03/11 to actual version 3.05/04 in * *# order to allow for use of GEANT 3.21: * *# Changed by A.F. 24.08.94: Make use of seq's GCFLAK and LGCBNK for * *# common GCFLAG and GCBANK-size respectively * *#********************************************************************** *KEEP,BCS. INTEGER NHROW,NHCOL,NHLEN PARAMETER (NHROW = 2, NHCOL = 1, NHLEN=2) INTEGER NBOSIW PARAMETER (NBOSIW=1000000) INTEGER IW(NBOSIW) REAL RW(NBOSIW) COMMON /BCS/ IW EQUIVALENCE (RW(1),IW(1)) SAVE /BCS/ *KEEP,BOSMDL. C ------BOSMDL LOGICAL BEGJOB,ENDRUN,BEGRUN,REVENT,ENDJOB,OTHDAT COMMON/BOSMDL/BEGJOB,ENDRUN,BEGRUN,REVENT,ENDJOB,OTHDAT, + LCCRUN,NCCRUN,NEVENT, + IHA,IBS,IDB,IDATEL,LUP,ISN,JSN SAVE /BOSMDL/ C ------ *KEEP,GCTIME. COMMON/GCTIME/TIMINT,TIMEND,ITIME,IGDATE,IGTIME INTEGER ITIME,IGDATE,IGTIME REAL TIMINT,TIMEND C *KEEP,H1OSGO. COMMON /H1OSGO/ LCONFG,IGEAND(13),RGEANC(16),IGEANP(12) *KEND. * "reduced GCFLAG COMMON to avoid clash of NEVENT variables from * BOS and GEANT COMMON/GCFLAG/IDEBUG,IDEMIN,IDEMAX,ITEST,IDRUN,IDEVT,IEORUN + ,IEOTRI,IEVENT,ISWIT(10),IFINIT(20) CHARACTER*8 VERSQQ LOGICAL FIRST,POSITR,FIRSTP PARAMETER (NG=1500000) COMMON/GCBANK/Q(NG) LOGICAL graph /.FALSE./ DATA FIRST/.TRUE./,FIRSTP/.TRUE./ * *KEEP,STFUNCT. * index of element before row number IROW INDR(IND,IROW)=IND+2+IW(IND+1)*(IROW-1) * index of L'th element of row number IROW INDCR(IND,L,IROW)=INDR(IND,IROW) + L * L'th integer element of the IROW'th row of bank with index IND IBTAB(IND,L,IROW)=IW(INDCR(IND,L,IROW)) * L'th real element of the IROW'th row of bank with index IND RBTAB(IND,L,IROW)=RW(INDCR(IND,L,IROW)) *KEEP,VERSQQ. VERSQQ = ' 3.06/36' IVERSQ = 30636 *KEND. * random number handling requested (negative IVERSQ) CALL MODULS('H1GEA',-IVERSQ,'GTR GVX STRBSVXB') CALL MODDEF(30441) IF(BEGJOB)THEN * *KEEP,DATEQQ. IDATQQ = 980710 *KEEP,TIMEQQ. ITIMQQ = 1126 *KEND. WRITE(6,1000)IDATQQ,ITIMQQ 1000 FORMAT( +'1**********************************************************'/ +' ****** ', *KEEP,QFTITLE,N=40. + 40H* H1SIM 3.06/36 23/02/96 17.47.42 *KEND. +,' ******'/ +' ****** Compiled at date ',I6,' and time ',I4,' ******'/ +' **********************************************************') NAHEAD=NAMIND('HEAD') NAHEAR=NAMIND('HEAR') ENDIF * overwrite HEAD bank with correct field value (even before geometry * definition !). For new data overwrite HEAR bank. IF(REVENT.OR.BEGRUN)THEN INHEAR=IW(NAHEAR) CALL UGTBNK('FIEL',INFIEL) IF(INHEAR.NE.0)THEN * create HEAR bank with new length INHEAR=NBANK('HEAR',0,22) * put in correct field value IF(INFIEL.EQ.0)THEN IW(INHEAR+ 6)=11600 ELSE IW(INHEAR+ 6)=NINT(1000.*RW(INFIEL+1)) ENDIF * for REVENT also add the information about e+/e- beams (influences * e-magnets in simulation) IF(REVENT)THEN * calculate POSITR flag only once: IF(FIRSTP)THEN FIRSTP=.FALSE. * check GTR banks and find first lepton, assume positron as default POSITR=.TRUE. INDGTR=IW(NAMIND('GTR ')) IF(INDGTR.GT.0)THEN NTR=IW(INDGTR+2) DO 5 ITR=1,NTR IPDG=IBTAB(INDGTR,7,ITR) IF(IABS(IPDG).EQ.11)THEN POSITR=IPDG.EQ.-11 GOTO 6 ENDIF 5 CONTINUE 6 CONTINUE ENDIF IF(POSITR)THEN WRITE(6,*)' Positron magnet setup used.' ELSE WRITE(6,*)' Electron magnet setup used.' ENDIF LL=LUNLOG() IF(LL.GT.0)THEN IF(POSITR)THEN WRITE(LL,'(A)')'Magnet setup: Positron' ELSE WRITE(LL,'(A)')'Magnet setup: Electron' ENDIF ENDIF ENDIF * and add POSITR flag to HEAR bank IF(POSITR)IW(14)=IBSET(IW(14),16) ENDIF ELSE INHEAD=IW(NAHEAD) IF(INFIEL.EQ.0)THEN IW(INHEAD+10)=11600 ELSE IW(INHEAD+10)=NINT(1000.*RW(INFIEL+1)) ENDIF ENDIF ENDIF * initialize setup only at first event (not at BEGRUN, because the * information about beam polarity and therefor magnet polarity is only * available at first event) IF(REVENT) THEN * prevent second initialisation if run number changes IF(FIRST)THEN FIRST=.FALSE. * create or modify steering banks using the OTTO bank CALL OTTOST * unpack steering information from banks OSGO and OSGD CALL UH1GEA CALL GZEBRA(NG) * "user" initialization CALL GUINIT c--------------------------------------- if(graph) then * set up workstation CALL IGINIT(-1000000) c CALL IGINIT(0) CALL IOPKS(0) CALL IOPWK(1,1,1) CALL IGRNG(20.,20.) CALL IACWK(1) * initialise drawing package CALL GDINIT endif c--------------------------------------- CALL TIMEL(TIMINT) ENDIF END IF if(graph) then CALL GINTER endif * overwrite first word in HEAD bank with information about * configuration setup (LCONFG=1,2,... coming from OSGO bank) IF(REVENT.OR.BEGRUN)THEN INHEAD=IW(NAHEAD) IF(INHEAD.GT.0)IW(INHEAD+1)=1+LCONFG ENDIF IF(REVENT) THEN IEVENT=IEVENT + 1 * create SIPA bank containing relevant simulation parameters CALL USIPA * turn GTR/GVX banks into STR/SVX banks CALL USTSV * initialize event partition CALL GTRIGI * process event (trigger) CALL GTRIG * clear event partition CALL GTRIGC END IF IF(ENDJOB) THEN * "user" termination CALL GULAST END IF CALL MODULF CALL MODDEF(0) RETURN END *CMZ : 2.04/00 10/09/91 07.49.14 by Stephan Egli *CMZ : 2.01/01 24/05/91 11.12.03 by Stephan Egli *CMZU: 2.00/06 10/05/91 13.37.18 by Stephan Egli *CMZU: 2.00/03 23/04/91 16.01.53 by Stephan Egli *CMZU: 2.00/02 02/04/91 18.04.33 by Wolfgang Hildesheim *CMZ : 2.00/00 10/02/91 09.08.52 by Stephan Egli *CMZ : 1.08/01 29/01/91 17.13.50 by Stephan Egli *-- Author : SUBROUTINE GUINIT * *#********************************************************************** *# * *# SUBROUTINE GUINIT * *# * *# PURPOSE: Initialize GEANT module. * *# * *# CALLED BY : Subroutine H1GEA * *# * *# CHANGED BY: P.VERRECCHIA AT: 10/02/89 * *# REASON : INITIALIZATION OF BOS HISTOGRAMS * *# CHANGED BY: S.EGLI AT: 9.3.89 * *# REASON : REMOVE CALL TVBGN (NOW IN H1GEA), GDINIT ALWAYS DONE * *# CHANGED BY: G.D.PATEL AT: 27/3/89 * *# REASON : CALL GDINIT CONDITIONAL ON GDRAW, PROBABLY NOT NECESSARY * *# CHANGED BY: G.Bernardi AT: 17/11/89 * *# REASON : WITH ALGORIX, CHANGE CUTS AND TRACK.PARA. IN FORWRD * *# KRYOSTAT(3507) AND DEAD ARGON (317) IN FRONT OF E.M. STACKS* *# TO 200 MEV FOR E,GAMMA * *# Changed by S.Egli at 9.3.90 * *# Reason: Call to GBHSTA,UHINIT,ACHFCP,ACHPCP removed. Uhinit function* *# now in UBINIT;ACHFCP,ACHPCP now in AGEOM * *# Write out of constant ZEBRA structures possible with ISWIT(9) * *# Changed by S.Egli at 2.5.90: Writing GCNUM common when writing ZEBRA* *# datastructures no longer needed. * *# Changed by P.Staroba at 28.1.91 : Adaption for ARCET* *#********************************************************************** * *KEEP,GCBANK. INTEGER IQ,LQ,NZEBRA,IXSTOR,IXDIV,IXCONS,LMAIN,LR1,JCG INTEGER KWBANK,KWWORK,IWS REAL GVERSN,ZVERSN,FENDQ,WS,Q C PARAMETER (KWBANK=1300000,KWWORK=5200) COMMON/GCBANK/NZEBRA,GVERSN,ZVERSN,IXSTOR,IXDIV,IXCONS,FENDQ(16) + ,LMAIN,LR1,WS(KWBANK-24) DIMENSION IQ(KWBANK-30),Q(KWBANK-30),LQ(KWBANK-22),IWS(KWBANK-24) EQUIVALENCE (Q(1),IQ(1),LQ(9)),(LQ(1),LMAIN),(IWS(1),WS(1)) EQUIVALENCE (JCG,JGSTAT) INTEGER JDIGI ,JDRAW ,JHEAD ,JHITS ,JKINE ,JMATE ,JPART + ,JROTM ,JRUNG ,JSET ,JSTAK ,JGSTAT,JTMED ,JTRACK,JVERTX + ,JVOLUM,JXYZ ,JGPAR ,JGPAR2,JSKLT C COMMON/GCLINK/JDIGI ,JDRAW ,JHEAD ,JHITS ,JKINE ,JMATE ,JPART + ,JROTM ,JRUNG ,JSET ,JSTAK ,JGSTAT,JTMED ,JTRACK,JVERTX + ,JVOLUM,JXYZ ,JGPAR ,JGPAR2,JSKLT C *KEEP,GCNUM. COMMON/GCNUM/NMATE ,NVOLUM,NROTM,NTMED,NTMULT,NTRACK,NPART + ,NSTMAX,NVERTX,NHEAD,NBIT COMMON /GCNUMX/ NALIVE,NTMSTO C INTEGER NMATE ,NVOLUM,NROTM,NTMED,NTMULT,NTRACK,NPART + ,NSTMAX,NVERTX,NHEAD,NBIT ,NALIVE,NTMSTO C *KEEP,GCFLAG. COMMON/GCFLAG/IDEBUG,IDEMIN,IDEMAX,ITEST,IDRUN,IDEVT,IEORUN + ,IEOTRI,IEVENT,ISWIT(10),IFINIT(20),NEVENT,NRNDM(2) COMMON/GCFLAX/BATCH, NOLOG LOGICAL BATCH, NOLOG C INTEGER IDEBUG,IDEMIN,IDEMAX,ITEST,IDRUN,IDEVT,IEORUN + ,IEOTRI,IEVENT,ISWIT,IFINIT,NEVENT,NRNDM C *KEEP,H1DETC. PARAMETER (NSUBDE=8) COMMON /H1DETC/ NAMSUB(NSUBDE),ISGRAN(NSUBDE),ISRBNK(NSUBDE), 1 ISDSBK(NSUBDE),ISTRKB(NSUBDE),ISTRKM(NSUBDE), 1 SKECUT(NSUBDE+2) *KEEP,GCOPTI. COMMON/GCOPTI/ IOPTIM C INTEGER IOPTIM *KEND. LOGICAL BTEST * * ----------------------------------------------------------------- * * Initialize GEANT * CALL GINIT * * get debug flags and physics cuts and parameters from bank OSGO * CALL GH1GO * overwrite default value for automatic volume sorting IF(BTEST(ISWIT(9),7))THEN IOPTIM=0 ELSE IOPTIM=2 ENDIF * * Initialize GEANT/ZBOOK data structures * CALL GZINIT * * read complete setup either from file or create it * IF(BTEST(ISWIT(9),6))THEN CALL GOPEN(13,'I',0,IER) CALL GGET(13,'INIT',-1,IDENT,IER) CALL GCLOSE(13,IER) * don't forget to fill GCNUM COMMON block NMATE=IQ(JMATE-2) NVOLUM=IQ(JVOLUM-2) NROTM=IQ(JROTM-2) NTMED=IQ(JTMED-2) * Initialisation for GFLASH ** CALL GFLASH CALL H1FAST * Initialize mapping functions IF(ISGRAN(3).NE.0.OR.ISGRAN(4).NE.0.OR.ISGRAN(5).NE.0.OR. 1 ISGRAN(6).NE.0)CALL AUGEOF * Initialize LUMI commons IF(ISGRAN(8).NE.0)CALL LSTRT ELSE * Particle table definition and energy loss initialization. CALL GPART * Initialisation for GFLASH ** CALL GFLASH CALL H1FAST * Geometry and materials description. CALL GUGEOM ENDIF * * prepare cross section and energy loss tables. * CALL GPHYSI * * dump geometry data to file ? c IF(BTEST(ISWIT(9),5))THEN c CALL GOPEN(13,'O',0,IER) c CALL GSAVE(13,'INIT',-1,0,IER) c CALL GCLOSE(13,IER) c ENDIF * some debug options: IF (BTEST(ISWIT(9),2)) THEN CALL GPMATE(0) CALL GPTMED(0) ENDIF IF (BTEST(ISWIT(9),3)) THEN CALL GPVOLU(0) ENDIF IF (BTEST(ISWIT(9),4)) THEN CALL GPROTM(0) CALL GPSETS('* ','* ') ENDIF * RETURN END c--------------------------------------------------------------------------- *CMZU: 3.01/00 28/02/94 07.10.43 by Stephan Egli *CMZU: 2.08/04 16/09/92 15.26.04 by Stephan Egli *CMZU: 2.05/00 01/11/91 16.31.24 by Stephan Egli *CMZ : 2.00/00 10/02/91 09.09.28 by Stephan Egli *CMZ : 1.08/02 06/02/91 17.15.18 by Stephan Egli *-- Author : SUBROUTINE FGEOM * *#********************************************************************** *# * *# SUBROUTINE FGEOM * *# * *# PURPOSE: Define Forward Tracker Materials Media and Geometry * *# * *# CALLED BY : UGEOM * *# * *# INPUT : BOS BANKS FGMX,FGLM,FGME,FGRO,FGDR,FGDP,FGDM,FGAM * *# * *# OUTPUT : COMMON /FTROTM/ NFROT(0:LFROT) filled & GEOMETRY defined * *# * *# AUTHOR : Girish D. Patel * *# * *# CHANGED BY: Girish D. Patel AT: 17/8/89 * *# REASON : CALL TO UDFPAR INSERTED (FGTP bank used) * *# CHANGED BY: Girish D. Patel AT: 14/3/90 * *# REASON : GSORD call for FPSZ commented, not valid in coarse option * *#********************************************************************** * * *KEEP,BCS. INTEGER NHROW,NHCOL,NHLEN PARAMETER (NHROW = 2, NHCOL = 1, NHLEN=2) INTEGER NBOSIW PARAMETER (NBOSIW=1000000) INTEGER IW(NBOSIW) REAL RW(NBOSIW) COMMON /BCS/ IW EQUIVALENCE (RW(1),IW(1)) SAVE /BCS/ *KEND. * *KEEP,FROTM. PARAMETER (LFROTM = 10 ) COMMON /FROTM/ NFROT(0:LFROTM) *KEND. * * FORWARD TRACKER IS DETECTOR NUMBER 2 NFDET = 2 * * DEFINE FORWARD TRACKING MATERIAL CONSTANTS FROM FGMA BOS BANK * * CALL UGTBNK( 'FGMA', INDB ) * IF( INDB.LE.0 ) THEN * WRITE(6,*) ' ** SUBR. UGEOFT ** FGMA BANK NOT FOUND ==> STOP ' * STOP * ELSE * CALL UDFMAT( INDB ) * ENDIF * * DEFINE FORWARD TRACKING MATERIAL MIXTURES FROM FGMX BOS BANK * CALL UGTBNK( 'FGMX', INDB ) IF( INDB.LE.0 ) THEN WRITE(6,*) ' ** SUBR. UGEOFT ** FGMX BANK NOT FOUND ==> STOP ' STOP ELSE CALL UDFMIX( INDB ) ENDIF * CALL UGTBNK( 'FGLM', INDB ) IF( INDB.LE.0 ) THEN WRITE(6,*) ' ** SUBR. UGEOFT ** FGLM BANK NOT FOUND ==> STOP ' STOP ELSE CALL UDFLMX( INDB ) ENDIF * * DEFINE FORWARD TRACKING MEDIA PARAMETERS FROM FGME BOS BANK * CALL UGTBNK( 'FGME', INDB ) IF( INDB.LE.0 ) THEN WRITE(6,*) ' ** SUBR. UGEOFT ** FGME BANK NOT FOUND ==> STOP ' STOP ELSE CALL UDFMED( INDB ) ENDIF * * DEFINE SPECIAL TRACKING MEDIA PARAMETERS FROM FGTP BOS BANK * CALL UGTBNK( 'FGTP', INDB ) IF( INDB.LE.0 ) THEN WRITE(6,*) ' ** SUBR. FGEOM ** FGTP BANK NOT FOUND ==> ', + 'Default values will be used' ELSE CALL UDFPAR( INDB ) ENDIF * * DEFINE GEANT ROTATION MATRICES FOR FORWARD TRACKER FROM FGRO BOS BANK * CALL UGTBNK( 'FGRO', INDB ) IF( INDB.LE.0 ) THEN WRITE(6,*) ' ** SUBR. UGEOFT ** FGRO BANK NOT FOUND ==> STOP ' STOP ELSE CALL UDFROT( INDB, NFROT, LFROTM ) ENDIF * *======================================================================= * NOW DEFINE DETECTORS *======================================================================= * * DEFINE GEOMETRY OF PLANAR SET UP FROM FGDP BOS BANK * CALL UGTBNK( 'FGDP' , INDB ) IF( INDB.LE.0 ) THEN WRITE(6,*) ' ** SUBR. UGEOFT ** FGDP BANK NOT FOUND ==> STOP ' STOP ELSE CALL UDFVOL( INDB, NFROT, LFROTM ) ENDIF * * DEFINE ACTIVE VOLUME STRUCTURE for PLANARS * CALL FPGEOM * * DEFINE GEOMETRY OF MWPC SET UP FROM FGDM BOS BANK * c CALL UGTBNK( 'FGDM' , INDB ) c IF( INDB.LE.0 ) THEN c WRITE(6,*) ' ** SUBR. UGEOFT ** FGDM BANK NOT FOUND ==> STOP ' c STOP c ELSE c CALL UDFVOL( INDB, NFROT, LFROTM ) c ENDIF * * DEFINE GEOMETRY OF RADIAL SET UP FROM FGDR BOS BANK * CALL UGTBNK( 'FGDR' , INDB ) IF( INDB.LE.0 ) THEN WRITE(6,*) ' ** SUBR. UGEOFT ** FGDR BANK NOT FOUND ==> STOP ' STOP ELSE CALL UDFVOL( INDB, NFROT, LFROTM ) ENDIF * * DEFINE ACTIVE VOLUME STRUCTURE for RADIALS * CALL FRGEOM * * DEFINE ACTIVE VOLUME STRUCTURE for NEW PLANARS * CALL FQGEOM * * PERFORM ORDERING OF VOLUMES FOR SPEEDING SEARCH * CALL GSORD('FRAD',3) *GDP CALL GSORD('FPSZ',1) CALL GSORD('FWPC',3) CALL GSORD('FPLN',3) CALL GSORD('FWDT',3) * * DEFINE SENSITIVE DETECTOR VOLUMES * CALL FDET * * CALL BDROP(IW,'FGMAFGMXFGLMFGMEFGTPFGROFGDPFGDMFGDRFGAMFGAP') * CALL BDROP(IW,'FGARFGATFGDR') 99 RETURN END c--------------------------------------------------------------------------- *CMZU: 2.13/00 19/03/93 15.04.15 by Stephen Burke *CMZ : 2.00/00 10/02/91 09.09.28 by Stephan Egli *CMZ : 1.08/02 06/02/91 13.38.38 by Stephan Egli *-- Author : SUBROUTINE FQGEOM *#********************************************************************** *# * *# VERSION: 21/07/98 Girish D. Patel * *# * *# PURPOSE: Define NEW Active PLANAR Chamber Geometry * *# * *# CALLED BY : FGEOM * *# * *# INPUT : BOS BANK FGAQ * *# * *# OUTPUT : * *# * *# AUTHOR : Girish D. Patel * *# * *#********************************************************************** * *KEEP,BCS. INTEGER NHROW,NHCOL,NHLEN PARAMETER (NHROW = 2, NHCOL = 1, NHLEN=2) INTEGER NBOSIW PARAMETER (NBOSIW=1000000) INTEGER IW(NBOSIW) REAL RW(NBOSIW) COMMON /BCS/ IW EQUIVALENCE (RW(1),IW(1)) SAVE /BCS/ *KEND. * *KEEP,FROTM. PARAMETER (LFROTM = 10 ) COMMON /FROTM/ NFROT(0:LFROTM) *KEND. * *KEEP,H1DETC. PARAMETER (NSUBDE=8) COMMON /H1DETC/ NAMSUB(NSUBDE),ISGRAN(NSUBDE),ISRBNK(NSUBDE), 1 ISDSBK(NSUBDE),ISTRKB(NSUBDE),ISTRKM(NSUBDE), 1 SKECUT(NSUBDE+2) *KEND. * DIMENSION PFQSW(3),ALEN(20) DIMENSION PFQSC(3),PFQSB(3) * CALL UGTBNK( 'FGAQ', INDB ) IF(INDB.LE.0) THEN WRITE(6,*) ' ** SUBR. FQGEOM ** FGAQ BANK NOT FOUND ==> STOP ' STOP ELSE * Number of cells across a planar chamber in w NCELL = IW(INDB+4) * Number of wires in a planar chamber in z NZ = IW(INDB+5) * Halfwidth of a planar cell in w, -0.04 to allow for G10 cathode PFQSW(1) = RW(INDB+8)/2.0 - 0.04 * Halflength of a planar cell in y, defined later since they vary PFQSW(2) = 0.0 * Halfdepth of a planar cell in z, wire spacing*no. wires in z PFQSW(3) = RW(INDB+6)*FLOAT(IW(INDB+5))/2.0 CALL UCOPY(RW(INDB+9),ALEN(1),NCELL/2) ENDIF * Halfwidth of a planar cathode in w PFQSC(1) = 0.04 * Halflength of a planar cathode in y, defined later since they vary PFQSC(2) = 0.0 * Halfdepth of a planar cathode in z, PFQSW(3) + 0.3 (dead area) PFQSC(3) = PFQSW(3) + 0.3 * Halfwidth of a planar pin block in w PFQSB(1) = PFQSW(1) * Halflength of a planar cathode in y PFQSB(2) = 0.5 * Halfdepth of a planar cathode in z, PFQSW(3) + 0.3 (dead area) PFQSB(3) = PFQSW(3) + 0.3 * * DEFINE GEOMETRY FOR PLANAR CHAMBERS * XPOS = RW(INDB+7) - RW(INDB+8) * DO 10 I = 1 , NCELL/2 JJ = I * x,y position of centre of a planar cell XPOS = XPOS + RW(INDB+8) YPOS = 0.0 * central 'broken' cells are displaced about beam hole IF(I.GT.8) YPOS = RW(INDB + 14+I) * Halflength of a planar cell in y PFQSW(2) = ALEN(I)/2.0 * x,y position of centre of a planar cathode XPOSS = XPOS - RW(INDB+8)/2. YPOSS = 0.0 * Halflength of a planar cathode in y PFQSC(2) = ALEN(I)/2.0 + 1.0 IF(I.EQ.9) THEN PFQSC(2) = ALEN(I)/2.0 + RW(INDB +14+I) + 1.0 ELSE IF(I.EQ.10.OR.I.EQ.11) THEN YLEN = ( RW(INDB + 14+I ) + ALEN(I)/2.0 ) - & ( RW(INDB + 14+I-1) - ALEN(I-1)/2.0 ) PFQSC(2) = YLEN/2.0 + 1.0 YPOSS = ( RW(INDB + 14+I-1) - ALEN(I-1)/2.0 ) + YLEN/2.0 ELSE IF(I.EQ.12.OR.I.EQ.13) THEN JJ = I + 1 YLEN = ( RW(INDB + 14+I ) + ALEN(I)/2.0 ) - & ( RW(INDB + 14+I+1) - ALEN(I+1)/2.0 ) PFQSC(2) = YLEN/2.0 + 1.0 XPOSS = XPOS + RW(INDB+8)/2. YPOSS = ( RW(INDB + 14+I+1) - ALEN(I+1)/2.0 ) + YLEN/2.0 ELSE IF(I.EQ.14) THEN JJ = 12 PFQSC(2) = ALEN(11)/2.0 + 1.0 XPOSS = 0.0 YPOSS = RW(INDB + 14+11) ENDIF * position sensitive volumes CALL GSPOSP('FQSW',I,'FQS0',XPOS,YPOS,0.,0,'ONLY',PFQSW,3) CALL GSPOSP('FQSW',29-I,'FQS0',-XPOS,-YPOS,0.,0,'ONLY', & PFQSW,3) * position noryl pin support blocks YPOSU = YPOS + ALEN(I)/2.0 + 0.5 YPOSB = -YPOSU IF(I.GT.8) YPOSB = YPOS - ALEN(I)/2.0 - 0.5 CALL GSPOSP('FQSB',I,'FQS0',XPOS,YPOSU,0.,0,'ONLY', & PFQSB,3) CALL GSPOSP('FQSB',I+28,'FQS0',XPOS,YPOSB,0.,0,'ONLY', & PFQSB,3) CALL GSPOSP('FQSB',29-I,'FQS0',-XPOS,-YPOSU,0.,0,'ONLY', & PFQSB,3) CALL GSPOSP('FQSB',29-I+28,'FQS0',-XPOS,-YPOSB,0.,0,'ONLY', & PFQSB,3) * position cathode planes CALL GSPOSP('FQSC',JJ,'FQS0',XPOSS,YPOSS,0.,0,'ONLY', & PFQSC,3) CALL GSPOSP('FQSC',29-JJ,'FQS0',-XPOSS,-YPOSS,0.,0,'ONLY', & PFQSC,3) c WRITE(6,'(A13,I3,5F8.2)') ' **FQGEOM W**', c & I,XPOS,YPOS,PFQSW c WRITE(6,'(A13,I3,6F8.2)') ' **FQGEOM B**', c & I,XPOS,YPOSU,YPOSB,PFQSB c WRITE(6,'(A13,I3,5F8.2)') ' **FQGEOM C**', c & I,XPOSS,YPOSS,PFQSC 10 CONTINUE * IF(ISGRAN(2) .EQ. 1) THEN * DIVIDE EACH PLANE CELL IN W (FPSW) INTO 4 IN Z (FPSZ) CALL GSDVN('FQSZ','FQSW',NZ,3) * * DEFINE GEOMETRY FOR MEDIUM GRANULARITY OPTION * ELSE IF(ISGRAN(2) .EQ. 3) THEN * NO DIVISION IN Z OF THE CELLS, EACH BOX IS THEREFORE NZ TIMES AS WIDE * ELSE WRITE(6,*) ' ILLEGAL FORWARD TRACKER GRANULARITY, ISGRAN= ', & ISGRAN, ' PROGRAM STOPPED IN FQGEOM ' STOP ENDIF * RETURN END *CMZU: 2.13/00 09/12/92 16.54.33 by Girish D. Patel *CMZ : 2.00/00 10/02/91 09.09.28 by Stephan Egli *CMZ : 1.08/02 06/02/91 13.38.38 by Stephan Egli *-- Author : SUBROUTINE FDET *#********************************************************************** *# * *# VERSION: 02/03/90 Steve Maxfield * *# * *# PURPOSE: Sensitive Volume and Hit structure definition * *# * *# CALLED BY : FGEOM * *# * *# INPUT : * *# * *# OUTPUT : GEANT Hit and Volume structures * *# * *# AUTHOR : Steve Maxfield, Girish D. Patel * *# * *# CHANGED BY: GDP, PR AT: 9/5/89 * *# REASON : * MODIFIED FOR APOLLO * *# Changed by: S.Egli at 1.4.90: all GSDETH calls removed. * *# CHANGED BY: G. D. Patel AT: 4/12/92 * *# REASON : * Planar geometry structure modified, FPSW => FPSZ * *#********************************************************************** * * *KEEP,GCFLAG. COMMON/GCFLAG/IDEBUG,IDEMIN,IDEMAX,ITEST,IDRUN,IDEVT,IEORUN + ,IEOTRI,IEVENT,ISWIT(10),IFINIT(20),NEVENT,NRNDM(2) COMMON/GCFLAX/BATCH, NOLOG LOGICAL BATCH, NOLOG C INTEGER IDEBUG,IDEMIN,IDEMAX,ITEST,IDRUN,IDEVT,IEORUN + ,IEOTRI,IEVENT,ISWIT,IFINIT,NEVENT,NRNDM C *KEND. * *KEEP,H1DETC. PARAMETER (NSUBDE=8) COMMON /H1DETC/ NAMSUB(NSUBDE),ISGRAN(NSUBDE),ISRBNK(NSUBDE), 1 ISDSBK(NSUBDE),ISTRKB(NSUBDE),ISTRKM(NSUBDE), 1 SKECUT(NSUBDE+2) *KEND. * INTEGER NWHI INTEGER NWDI * DATA NWHI /100/ DATA NWDI /0/ * * ALLOCATE SENSITIVE DETECTOR VOLUMES TO SETS AND DEFINE HIT VARIABLES * * RADIALS.... I2 = 201 IF (ISGRAN(2) .EQ. 1) THEN CALL GSDETV('FRSD','FRSZ',I2,NWHI,NWDI,ISETR,IDETR) ELSE IF(ISGRAN(2) .EQ. 3) THEN CALL GSDETV('FRSD','FRS0',I2,NWHI,NWDI,ISETR,IDETR) ELSE WRITE(6,*)' ** FDET ** ERROR - GRANULARITY UNDEFINED, STOP' STOP ENDIF IF(ISWIT(2).EQ.1) WRITE(6,*) ' ** FDET ** ISETR = ',ISETR &,' IDETR = ',IDETR * * PLANARS.... I2 = 202 IF (ISGRAN(2) .EQ. 1 ) THEN CALL GSDETV('FPSD','FPSZ',I2,NWHI,NWDI,ISETP,IDETP) ELSE IF(ISGRAN(2) .EQ. 3) THEN CALL GSDETV('FPSD','FPSW',I2,NWHI,NWDI,ISETP,IDETP) ELSE WRITE(6,*)' ** FDET ** ERROR - GRANULARITY UNDEFINED, STOP' STOP ENDIF IF(ISWIT(2).EQ.1) WRITE(6,*) ' ** FDET ** ISETP = ',ISETP &,' IDETP = ',IDETP * NEW PLANARS.... I2 = 203 IF (ISGRAN(2) .EQ. 1 ) THEN CALL GSDETV('FQSD','FQSZ',I2,NWHI,NWDI,ISETP,IDETP) ELSE IF(ISGRAN(2) .EQ. 3) THEN CALL GSDETV('FQSD','FQSW',I2,NWHI,NWDI,ISETP,IDETP) ELSE WRITE(6,*)' ** FDET ** ERROR - GRANULARITY UNDEFINED, STOP' STOP ENDIF IF(ISWIT(2).EQ.1) WRITE(6,*) ' ** FDET ** ISETP = ',ISETP &,' IDETP = ',IDETP * MWPCS.... c I2=203 c CALL GSDETV('FMWP','FMAC',I2,NWHI,NWDI,ISETM,IDETM) * CALL GSDETH('FMWP','FMAC',NHITSN,NAMESH,NBITSH,ORIG,FACT) c IF(ISWIT(2).EQ.1) WRITE(6,*) ' ** FDET ** ISETM = ',ISETM c &,' IDETP = ',IDETP * * TR... c I2 = 204 c CALL GSDETV('FTSD','FTRD',I2,NWHI,NWDI,ISETT,IDETT) * CALL GSDETH('FTSD','FTRD',NHITSN,NAMESH,NBITSH,ORIG,FACT) c IF(ISWIT(2).EQ.1) WRITE(6,*) ' ** FDET ** ISETT = ',ISETT c &,' IDETT = ',IDETT * RETURN END *CMZU: 2.13/00 09/12/92 16.54.33 by Girish D. Patel *CMZ : 2.00/00 10/02/91 09.09.28 by Stephan Egli *CMZ : 1.08/02 06/02/91 13.38.39 by Stephan Egli *-- Author : SUBROUTINE FQHIT *#********************************************************************** *# * *# VERSION: 22/07/98 Steve Maxfield * *# * *# PURPOSE: fill NEW PLANAR CHAMBERS response and GEANT HIT banks * *# * *# CALLED BY : GEDEPO * *# * *# INPUT : GEANT track data * *# * *# OUTPUT : FRQF bank OR FRQT bank * *# ==== ==== * *# AUTHOR : Steve Maxfield * *# * *# CHANGED BY: * *# REASON : * *#********************************************************************** *# * *# FORMAT OF FRQF BANK 2I,(14F,4I) Bank Number = 0 * *# ====== == ==== ==== * *# BANK FRQF Forward New Planar Response (Fast-form) * *# CONTAINS ALL TRACKPOINTS OF ALL TRACKS * *# * *# word# type Content * *# 1 I NCOL = 18 * *# 2 I Number of track points * *# ---------------------------------------------------------------- * *# Col * *# 1 R X in Attrib * *# 2 R Y in Attrib * *# 3 R Z in Attrib * *# 4 R PX/P in Attrib * *# 5 R PY/P in Attrib * *# 6 R PZ/P in Attrib * *# 7 R P in Attrib * *# * *# 8 R X out Attrib * *# 9 R Y out Attrib * *# 10 R Z out Attrib * *# 11 R PX/P out Attrib * *# 12 R PY/P out Attrib * *# 13 R PZ/P out Attrib * *# 14 R P out Attrib * *# * *# 15 I PARTICLE TYPE Attrib * *# 16 I (Partial) Cell Number Attrib * *# 17 I TRACKING HISTORY WORD Attrib * *# 18 I TRACK NUMBER Reln * *# ---------------------------------------------------------------- * *# (GEANT units: cms. GeV) * *#********************************************************************** *# * *# FORMAT OF FRQT BANK 2I,(I,7F,2I) Bank Number = 0 * *# ====== == ==== ==== * *# BANK FRQT Forward New Planar Response Track-based * *# Contains all hits in Planars for all tracks * *# * *# word# type Content * *# 1 I NCOLS = 10 * *# 2 I NROWS = Number of hits * *# ---------------------------------------------------------------- * *# Col * *# 1 I Cell Number Attrib * *# 2 R Xin Attrib * *# 3 R Yin Attrib * *# 4 R Zin Attrib * *# 5 R Xout Attrib * *# 6 R Yout Attrib * *# 7 R Zout Attrib * *# 8 R Energy Loss (GeV) Attrib * *# 9 I Tracking History word Attrib * *# 10 I TRACK NUMBER Reln * *# ---------------------------------------------------------------- * *# (GEANT units: cms. GeV) * *#********************************************************************** * *KEEP,GCKINE. COMMON/GCKINE/IKINE,PKINE(10),ITRA,ISTAK,IVERT,IPART,ITRTYP + ,NAPART(5),AMASS,CHARGE,TLIFE,VERT(3),PVERT(4),IPAOLD C INTEGER IKINE,ITRA,ISTAK,IVERT,IPART,ITRTYP,NAPART,IPAOLD REAL PKINE,AMASS,CHARGE,TLIFE,VERT,PVERT C *KEEP,GCTRAK. INTEGER NMEC,LMEC,NAMEC,NSTEP ,MAXNST,IGNEXT,INWVOL,ISTOP,MAXMEC + ,IGAUTO,IEKBIN,ILOSL, IMULL,INGOTO,NLDOWN,NLEVIN,NLVSAV,ISTORY REAL VECT,GETOT,GEKIN,VOUT,DESTEP,DESTEL,SAFETY,SLENG ,STEP + ,SNEXT,SFIELD,TOFG ,GEKRAT,UPWGHT PARAMETER (MAXMEC=30) COMMON/GCTRAK/VECT(7),GETOT,GEKIN,VOUT(7),NMEC,LMEC(MAXMEC) + ,NAMEC(MAXMEC),NSTEP ,MAXNST,DESTEP,DESTEL,SAFETY,SLENG + ,STEP ,SNEXT ,SFIELD,TOFG ,GEKRAT,UPWGHT,IGNEXT,INWVOL + ,ISTOP ,IGAUTO,IEKBIN, ILOSL, IMULL,INGOTO,NLDOWN,NLEVIN + ,NLVSAV,ISTORY C *KEEP,GCSETS. COMMON/GCSETS/IHSET,IHDET,ISET,IDET,IDTYPE,NVNAME,NUMBV(20) C INTEGER IHSET,IHDET,ISET,IDET,IDTYPE,NVNAME,NUMBV C *KEEP,H1DETC. PARAMETER (NSUBDE=8) COMMON /H1DETC/ NAMSUB(NSUBDE),ISGRAN(NSUBDE),ISRBNK(NSUBDE), 1 ISDSBK(NSUBDE),ISTRKB(NSUBDE),ISTRKM(NSUBDE), 1 SKECUT(NSUBDE+2) *KEEP,OTRHIS. COMMON/OTRHIS/ITRHIS *KEEP,BCS. INTEGER NHROW,NHCOL,NHLEN PARAMETER (NHROW = 2, NHCOL = 1, NHLEN=2) INTEGER NBOSIW PARAMETER (NBOSIW=1000000) INTEGER IW(NBOSIW) REAL RW(NBOSIW) COMMON /BCS/ IW EQUIVALENCE (RW(1),IW(1)) SAVE /BCS/ *KEND. PARAMETER (NCL=18) PARAMETER (NCL2=10) PARAMETER (NBN=0) DIMENSION IKADD(NCL),BKADD(NCL) EQUIVALENCE (IKADD(1),BKADD(1)) LOGICAL FIRST DATA FIRST/.TRUE./ * Branch according to granularity flag... IF(ISGRAN(2) .EQ. 3) THEN * Coarse detector geometry create FRPF banks IF(FIRST)THEN FIRST=.FALSE. CALL BKFMT ('FRQF','2I,(14F,4I)') ENDIF * IF(INWVOL.EQ.1) THEN * Entrance to volume. Store first 7-vector... DO 10 I=1,7 10 BKADD(I) = VECT(I) ELSEIF(INWVOL.EQ.2.OR.ISTOP.GT.0) THEN * Exit volume at boundary or particle stops... DO 11 I=1,7 11 BKADD(I+7) = VECT(I) IKADD(15) = IGEAPD(IPART) * use word 17 to keep the (partial) cell number... * Determine Cell number - drift cells are numbered * as follows:- * * cell number determined by supermodule number (1-3) NUMBV(1) * w-coordinate (1-28) NUMBV(2) * ...the cell number will be completed when the z plane number (0 - * is added in the Digitisation step * write(6,*) 'FQHIT',(numbv(I),I=1,3) IKADD(16) = 168 * (NUMBV(1)-1) . + 6 * (NUMBV(2)-1) IKADD(17) = ITRHIS IKADD(18) = ITRA * Track segment now complete. Add row to table... KND=IADROW('FRQF',NBN,NCL,BKADD) IF(IW(KND+2).EQ.1)CALL BLIST(IW,'E+','FRQF') ENDIF ELSEIF(ISGRAN(2) .EQ. 1) THEN * Fine detector geometry - create FRPT banks... IF(FIRST)THEN FIRST=.FALSE. CALL BKFMT ('FRQT','2I,(I,7F,2I)') ENDIF * IF(INWVOL.EQ.1) THEN XIN = VECT(1) YIN = VECT(2) ZIN = VECT(3) ENLOSS = 0.0 * ELSEIF (INWVOL.EQ.2) THEN XOUT = VECT(1) YOUT = VECT(2) ZOUT = VECT(3) * Add last bit of Energy ENLOSS=ENLOSS+DESTEP * Add information to the bank * Determine Cell number - drift cells are numbered * as follows:- * * cell number determined by supermodule number (1-3) NUMBV(1) * orientation number (1-1) NUMBV(2) * w-coordinate (1-28) NUMBV(3) * z-plane (1-6) NUMBV(4) IKADD( 1) = 168 * (NUMBV(1)-1) . + 6 * (NUMBV(3)-1) . + (NUMBV(4)-1) BKADD( 2) = XIN BKADD( 3) = YIN BKADD( 4) = ZIN BKADD( 5) = XOUT BKADD( 6) = YOUT BKADD( 7) = ZOUT BKADD( 8) = ENLOSS IKADD( 9) = ITRHIS IKADD(10) = ITRA * KND=IADROW('FRQT',NBN,NCL2,BKADD) IF(IW(KND+2).EQ.1)CALL BLIST(IW,'E+','FRQT') ENDIF * * ADD UP ENERGY LOSS * ENLOSS=ENLOSS+DESTEP ELSE * Undefined geometry - STOP WRITE(6,*) ' FQHIT - Undefined FTD geometry!!' STOP ENDIF RETURN END *CMZU: 3.06/35 28/12/95 08.47.04 by Vladimir Andreev *CMZ : 3.06/25 28/09/95 20.48.57 by Vladimir Shekelyan *CMZU: 3.05/02 01/11/94 13.15.55 by Benno List *CMZU: 3.00/03 06/12/93 15.35.51 by Vladimir Shekelyan *CMZU: 2.14/02 10/08/93 20.45.44 by Vladimir Shekelyan *CMZU: 2.10/13 15/12/92 17.27.25 by Alexander Fedotov *CMZU: 2.08/04 11/06/92 11.58.39 by Christian Pichler *CMZU: 2.06/04 10/01/92 10.37.08 by Jozef Ferencei *CMZU: 2.04/00 11/07/91 19.26.42 by Joerg Gayler *CMZ : 2.01/00 08/07/91 19.01.14 by Pavel Staroba *CMZU: 2.00/06 15/05/91 17.39.03 by Stephan Egli *CMZU: 2.00/03 25/04/91 12.34.03 by Stephan Egli *CMZ : 2.00/02 05/04/91 11.39.35 by Stephan Egli *CMZ : 2.00/00 10/02/91 09.08.52 by Stephan Egli *CMZ : 1.08/02 06/02/91 14.35.14 by Stephan Egli *-- Author : SUBROUTINE GEDEPO ************************************************************************ * Main steering routine for hit production. Depending on the current * * subdetector,IDTYPE and granularity the necessary hit routine is * * selected. * * Input: IDTYPE: COMMON/GCSETS/ * * ISGRAN(1..8): COMMON/H1DETC/ * * CHARGE: COMMON/GCKINE/ * * DESTEP: COMMON/GCTRAK/ * * ICURSU: COMMON/CCURSU/ * * * * The array EN has the following meaning: * * EN(1) visible had energy + fluctation * * EN(2) visible em energy + fluctation * * EN(3) invisible energy no fluctuation (break-up) * * EN(4) total em energy no fluctuation * * EN(5) total had energy no fluctuation * * EN(6) visible had energy no fluctuation * * * * Author: Stephan Egli 10.3.90 * * Changed by: P.Staroba 28.1.91 Reason : Adaption for ARCET * * Changed by: W. Hildesheim 7.4.91 Reason : no calib. ene's in IRHT * * H1DEDX stuff obsoleted, use IFLASH(1,I)=0 instead * * Changed by: W.H./S.E. passive E not in visible E, only in Eemtot * * CHANGED BY: H.KAUFMANN AT: 30/1/91 * * REASON : VERTEX- AND BACKWARD SILICON DETECTORS IMPLEMENTED * * Changed by: J.Gayler 11.7.91 Reason : allow for M>7 in ARCET * * Changed by: J.Ferencei at: 10/01/92 * * Reason : ACSOFT part (as determined by P.Reimer) of the energy * * inside the BEMC WLS stored for detailed granularity * * Changed by: C.Pichler at: 27/05/92 * * Reason : ACSOFT correction removed and put to subroutine BDEPO * * Changed by: A.Fedotov 13.12.92 Reason: call JHIT for proton tagger * * Changed by: V.Shekelyan at: 29.07.93 * * Reason : upgrade 1995 * * Changed by: P.Biddulph 27.10.94 Reason: call JHIT for FToF * ************************************************************************ *KEEP,GCKINE. COMMON/GCKINE/IKINE,PKINE(10),ITRA,ISTAK,IVERT,IPART,ITRTYP + ,NAPART(5),AMASS,CHARGE,TLIFE,VERT(3),PVERT(4),IPAOLD C INTEGER IKINE,ITRA,ISTAK,IVERT,IPART,ITRTYP,NAPART,IPAOLD REAL PKINE,AMASS,CHARGE,TLIFE,VERT,PVERT C *KEEP,GCTRAK. INTEGER NMEC,LMEC,NAMEC,NSTEP ,MAXNST,IGNEXT,INWVOL,ISTOP,MAXMEC + ,IGAUTO,IEKBIN,ILOSL, IMULL,INGOTO,NLDOWN,NLEVIN,NLVSAV,ISTORY REAL VECT,GETOT,GEKIN,VOUT,DESTEP,DESTEL,SAFETY,SLENG ,STEP + ,SNEXT,SFIELD,TOFG ,GEKRAT,UPWGHT PARAMETER (MAXMEC=30) COMMON/GCTRAK/VECT(7),GETOT,GEKIN,VOUT(7),NMEC,LMEC(MAXMEC) + ,NAMEC(MAXMEC),NSTEP ,MAXNST,DESTEP,DESTEL,SAFETY,SLENG + ,STEP ,SNEXT ,SFIELD,TOFG ,GEKRAT,UPWGHT,IGNEXT,INWVOL + ,ISTOP ,IGAUTO,IEKBIN, ILOSL, IMULL,INGOTO,NLDOWN,NLEVIN + ,NLVSAV,ISTORY C *KEEP,GCSETS. COMMON/GCSETS/IHSET,IHDET,ISET,IDET,IDTYPE,NVNAME,NUMBV(20) C INTEGER IHSET,IHDET,ISET,IDET,IDTYPE,NVNAME,NUMBV C *KEEP,H1DETC. PARAMETER (NSUBDE=8) COMMON /H1DETC/ NAMSUB(NSUBDE),ISGRAN(NSUBDE),ISRBNK(NSUBDE), 1 ISDSBK(NSUBDE),ISTRKB(NSUBDE),ISTRKM(NSUBDE), 1 SKECUT(NSUBDE+2) *KEEP,CCURSU. COMMON/CCURSU/ICURSU,IPRESU,ISGRAC,ISRBNC,ISDSBC,ISTRBC,ISTRKC, 1 SKECUC *KEEP,GCFLAG. COMMON/GCFLAG/IDEBUG,IDEMIN,IDEMAX,ITEST,IDRUN,IDEVT,IEORUN + ,IEOTRI,IEVENT,ISWIT(10),IFINIT(20),NEVENT,NRNDM(2) COMMON/GCFLAX/BATCH, NOLOG LOGICAL BATCH, NOLOG C INTEGER IDEBUG,IDEMIN,IDEMAX,ITEST,IDRUN,IDEVT,IEORUN + ,IEOTRI,IEVENT,ISWIT,IFINIT,NEVENT,NRNDM C *KEEP,GCTMED. COMMON/GCTMED/NUMED,NATMED(5),ISVOL,IFIELD,FIELDM,TMAXFD,STEMAX + ,DEEMAX,EPSIL,STMIN,CFIELD,PREC,IUPD,ISTPAR,NUMOLD C INTEGER NUMED,NATMED,ISVOL,IFIELD,IUPD,ISTPAR,NUMOLD REAL FIELDM,TMAXFD,STEMAX,DEEMAX,EPSIL,STMIN,CFIELD,PREC C *KEEP,GCMATE. COMMON/GCMATE/NMAT,NAMATE(5),A,Z,DENS,RADL,ABSL C INTEGER NMAT,NAMATE REAL A,Z,DENS,RADL,ABSL C *KEEP,GCBANK. INTEGER IQ,LQ,NZEBRA,IXSTOR,IXDIV,IXCONS,LMAIN,LR1,JCG INTEGER KWBANK,KWWORK,IWS REAL GVERSN,ZVERSN,FENDQ,WS,Q C PARAMETER (KWBANK=1300000,KWWORK=5200) COMMON/GCBANK/NZEBRA,GVERSN,ZVERSN,IXSTOR,IXDIV,IXCONS,FENDQ(16) + ,LMAIN,LR1,WS(KWBANK-24) DIMENSION IQ(KWBANK-30),Q(KWBANK-30),LQ(KWBANK-22),IWS(KWBANK-24) EQUIVALENCE (Q(1),IQ(1),LQ(9)),(LQ(1),LMAIN),(IWS(1),WS(1)) EQUIVALENCE (JCG,JGSTAT) INTEGER JDIGI ,JDRAW ,JHEAD ,JHITS ,JKINE ,JMATE ,JPART + ,JROTM ,JRUNG ,JSET ,JSTAK ,JGSTAT,JTMED ,JTRACK,JVERTX + ,JVOLUM,JXYZ ,JGPAR ,JGPAR2,JSKLT C COMMON/GCLINK/JDIGI ,JDRAW ,JHEAD ,JHITS ,JKINE ,JMATE ,JPART + ,JROTM ,JRUNG ,JSET ,JSTAK ,JGSTAT,JTMED ,JTRACK,JVERTX + ,JVOLUM,JXYZ ,JGPAR ,JGPAR2,JSKLT C *KEEP,GCJLOC. COMMON/GCJLOC/NJLOC(2),JTM,JMA,JLOSS,JPROB,JMIXT,JPHOT,JANNI + ,JCOMP,JBREM,JPAIR,JDRAY,JPFIS,JMUNU,JRAYL + ,JMULOF,JCOEF,JRANG C INTEGER NJLOC ,JTM,JMA,JLOSS,JPROB,JMIXT,JPHOT,JANNI + ,JCOMP,JBREM,JPAIR,JDRAY,JPFIS,JMUNU,JRAYL + ,JMULOF,JCOEF,JRANG C *KEEP,H1OSGO. COMMON /H1OSGO/ LCONFG,IGEAND(13),RGEANC(16),IGEANP(12) *KEND. LOGICAL BTEST DIMENSION MNLIJK(6),EN(6),VSPOT(6) * ============================================== * sum of DESTEP (calorimeters and dead material) * ============================================== IF(DESTEP.EQ.0.) GO TO 5 * for particles leaving iron (ICURSU=9) dE/dx is not defined IF(ICURSU.EQ.9) GO TO 5 * map to channel number CALL GENMAP(1,VECT,MNLIJK,ISGRAC) * apply Birk's law for BEMC SCSN-38 scintillator and for LAr * if requested by steering DESVIS=DESTEP IF(BTEST(ISWIT(9),8))THEN IF (ABS(CHARGE) .GT. 0.1)THEN IF(NUMED.EQ.503.OR.(NUMED.GE.511.AND.NUMED.LE.516))THEN RKB=Q(LQ(JTM)+28)/DENS IF (ABS(CHARGE).GE.2.) RKB=RKB*7.2/12.6 DEDXCM=1000.*Q(JLOSS+IEKBIN) DESVIS=DESTEP/(1.+RKB*DEDXCM) ELSE IF(NMAT.EQ.310)THEN RKB=Q(LQ(LQ(JTMED-310))+28)/DENS IF (ABS(CHARGE).GE.2.) RKB=RKB*7.2/12.6 DEDXCM=1000.*Q(JLOSS+IEKBIN) DESVIS=DESTEP/(1.+RKB*DEDXCM) ENDIF ENDIF ENDIF * distinguish between absorber material and sensitive material in detailled * tracking (no Evis for passive) and distinction of em and had energies N=MNLIJK(2) IF(ITRTYP.LT.3)THEN * electromagnetic energy EN(1)=0. IF(N.GE.4) THEN EN(2)=0. ELSE EN(2)=DESVIS ENDIF EN(3)=0. EN(4)=DESTEP EN(5)=0. EN(6)=0. ELSE * hadronic energy IF(N.GE.4) THEN EN(1)=0. EN(6)=0. ELSE EN(1)=DESVIS EN(6)=DESVIS ENDIF EN(2)=0. EN(3)=0. EN(4)=0. EN(5)=DESTEP ENDIF * reset to "active" number except for IRON IF(N.GE.4.AND.MNLIJK(1).NE.10)MNLIJK(2)=N-4 * deposit dE/dx in bank CALL SPODEP(1,VECT,EN,MNLIJK) * ======================== * other cases (tracks,...) * ======================== 5 CONTINUE * IF(IDTYPE.EQ.0) RETURN * tracker hits after 100 ns are ignored IF(ICURSU.LE.2)THEN IF(TOFG.GT.1.E-7)RETURN ENDIF GOTO(10,20,30,40,50,60,70,80),ICURSU WRITE(6,*)' ***GEDEPO***: invalid subdetector:',ICURSU STOP * ******************** CENT ****************** 10 IF(CHARGE.EQ.0.)RETURN GOTO(11,12,13,14,14,14,14,15,16),IDTYPE-100 WRITE(6,900)IDTYPE STOP 11 IF(ISGRAN(1).EQ.3)THEN CALL CJHITF ELSE CALL CJHITS ENDIF RETURN 12 CALL USRHIT('CRYT') RETURN 13 CALL USRHIT('CRZT') RETURN 14 CALL USRHIC('CRMT',IDTYPE-104) RETURN 15 CALL USRHIT('CRVT') RETURN 16 CALL USRHIT('BRST') RETURN * ******************** FWDT ****************** 20 IF(CHARGE.EQ.0.)RETURN c GOTO(21,22,23,24),IDTYPE-200 GOTO(21,22,23),IDTYPE-200 WRITE(6,900)IDTYPE STOP 21 CALL FRHIT RETURN 22 CALL FPHIT RETURN 23 CALL FQHIT RETURN c23 ICHAM=2*NUMBV(NVNAME-1)+NUMBV(NVNAME)-3 c CALL USRHIC('FRMT',ICHAM) c RETURN c24 CALL FTHIT c RETURN * ******************** CALO ****************** 30 CONTINUE RETURN * ******************** PLUG ****************** 40 CONTINUE RETURN * ******************** BEMC ****************** 50 CONTINUE IF(LCONFG.LE.1) THEN *......................................... configuration of 1992 GOTO (51,52,53,51)IDTYPE-500 WRITE(6,900)IDTYPE 51 CONTINUE RETURN 52 IF(CHARGE.NE.0..AND.INWVOL.EQ.1)CALL BTHIT RETURN 53 IF(CHARGE.NE.0.)CALL USRHIC('BRMT',NUMBV(NVNAME)-1) RETURN ELSE *......................................... upgrade 1995 *>> GOTO (151,151,151,151,154)IDTYPE-500 *>> add BToF for 1995 GOTO (151,70,151,151,154)IDTYPE-500 WRITE(6,900)IDTYPE 151 CONTINUE RETURN 154 IF(CHARGE.NE.0.)CALL HDHIT RETURN ENDIF * ******************** IRON ****************** 60 IF(CHARGE.EQ.0.)RETURN IF(INWVOL.EQ.1)THEN VSPOT(1)=VECT(1) VSPOT(2)=VECT(2) VSPOT(3)=VECT(3) ELSE IF(INWVOL.EQ.2.OR.ISTOP.NE.0)THEN VSPOT(4)=VECT(1) VSPOT(5)=VECT(2) VSPOT(6)=VECT(3) IF(ISRBNK(6).EQ.1) THEN CALL IDEPO(VSPOT,VECT(7)) ENDIF ENDIF RETURN * ******************** FWFE ****************** 70 IF(IDTYPE.EQ.1001.OR.IDTYPE.EQ.1101.OR.IDTYPE.EQ.1005 + .OR.IDTYPE.EQ.502) THEN * proton tagger or Roman pots or FToF (P.Biddulph) * or BToF for 1995 (V.Shekelyan) CALL JHIT RETURN ELSE * forward muon spectrometer IF(CHARGE.EQ.0.) RETURN GOTO(71,72),IDTYPE-700 WRITE(6,900)IDTYPE STOP 71 CALL MTPHIT('MRTT') RETURN 72 CALL MTPHIT('MRPT') RETURN ENDIF * ******************** LUMI ****************** 80 GOTO(81,82,83,84),IDTYPE-800 WRITE(6,900)IDTYPE STOP 81 IFOK=-200 CALL LEHIT(VECT(7),-VECT(1),VECT(2),IFOK) RETURN 82 CALL LPHIT(VECT(7),-VECT(1),VECT(2)) RETURN 83 CALL LVHIT RETURN 84 IFOK=0 c************************************************************ c please note I commented this to get rid of an unresolved to c test the new code. This is NOT for export back into CMZ!! c Girish. c************************************************************ c CALL LE1HIT(VECT(7),-VECT(1),VECT(2),IFOK) RETURN 900 FORMAT(' ***GEDEPO*** illegal IDTYPE:',I5) END c--------------------------------------------------------------------------- SUBROUTINE GINTER CHARACTER*6 NAME CHARACTER*4 VNAME CALL GDRAWC('FWDT',2,0.0,10.0,10.0,0.1,0.1) CALL GDSCAL(su,sv) write(6,*) ' GINTER entered....type name of GEANT drawing routine' 10 read(5,'(A6)') NAME IF(NAME.EQ.'STOP') STOP IF(NAME.EQ.'GDRAWC') THEN WRITE(6,*) 'Enter VNAME,IAXIS,CUTVAL,U0,V0,SU,SV' READ(5,'(A4,1x,I1,1x,5F5.1)') vname,iaxis,cutval,u0,v0,su,sv c CALL ICLRWK(0,1) CALL GDRAWC(vname,iaxis,cutval,u0,v0,su,sv) CALL GDSCAL(su,sv) GO TO 10 ENDIF IF(NAME.EQ.'GDRAWX') THEN WRITE(6,*) 'Enter VNAME,CUTTHE,CUTPHI,CUTVAL,TH,PHI,U0,V0,SU,SV' READ(5,'(A4,1x,9F6.2)') vname,cutthe,cutphi,cutval, & theta,phi,u0,v0,su,sv CALL ICLRWK(0,1) CALL GDRAWX(vname,cutthe,cutphi,cutval,theta,phi,u0,v0,su,sv) CALL GDSCAL(su,sv) GO TO 10 ENDIF IF(NAME.EQ.'CLEAR') CALL ICLRWK(0,1) GO TO 10 RETURN END