*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 : 10/11/98 14.43.18 by Girish D. Patel *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 : Girish D. Patel 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 *CMZ : 10/11/98 14.37.51 by Girish D. Patel *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 : Girish D. Patel 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 * * Following lines commented to remove the MWPC detectors in upgraded FTD * * 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 *CMZ : 20/01/99 12.23.23 by Girish D. Patel *-- Author : Girish D. Patel 10/11/98 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 * c write(6,*) 'FQHIT',(numbv(I),I=1,3) IKADD(16) = 224 * (NUMBV(1)-1) . + 8 * (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-8) NUMBV(4) IKADD( 1) = 224 * (NUMBV(1)-1) . + 8 * (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 *CMZ : 11/11/98 12.40.01 by Girish D. Patel *-- Author : Girish D. Patel 11/11/98 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/ *KEEP,FROTM. PARAMETER (LFROTM = 10 ) COMMON /FROTM/ NFROT(0:LFROTM) *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: 03/08/98 13.56.05 by Stephen Burke *CMZ : 3.06/24 12/09/95 21.46.24 by Vladimir Shekelyan *CMZU: 3.01/00 09/03/94 15.02.36 by Stephan Egli *CMZU: 3.00/05 08/02/94 15.48.15 by Stephan Egli *CMZU: 2.13/00 20/05/93 18.23.11 by Stephan Egli *CMZU: 2.10/00 07/12/92 19.26.58 by Stephan Egli *CMZU: 2.00/01 19/02/91 15.00.52 by Stephan Egli *-- Author : Stephan Egli 19/02/91 SUBROUTINE FDIGI ************************************************************************ * Digitize hit data for forward tracker. * ************************************************************************ *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 ------ *KEND. CHARACTER*8 VERSQQ *KEEP,VERSQQ. VERSQQ = ' 3.07/24' IVERSQ = 30724 *KEND. CALL MODULS('FDIGI',IVERSQ,'FRPTFRPFFRQTFRQFFRRTFRRFFRMTFRTT') CALL MODDEF(30433) IF(BEGRUN)THEN CALL FRIDIG CALL FQIDIG CALL FPIDIG ENDIF IF(REVENT)THEN CALL FRDIGI CALL FQDIGI CALL FPDIGI CALL FMDIGI CALL FMPME ENDIF CALL MODULF CALL MODDEF(0) RETURN END *CMZU: 03/08/98 13.56.29 by Stephen Burke *-- Author : Stephen Burke 03/08/98 SUBROUTINE FDQSME(DRIFT,IFLAG0,IFLAG1,IFLAG2,DSMEA) *#**************************************************************** *# * *# PURPOSE: Compute Smeared drift length (in new planars) * *# * *# INPUT: DRIFT - drift length to wire in cms * *# end of wire in units of total wire length* *# IFLAG - FLAG containing hit "quality" inf* *# * *# OUTPUT: DSMEA Smeared drift time * *# Depends on IFLAG * *# * *#**************************************************************** *# * *# CHANGED BY: AT: * *# * *# REASON : * *# * *#**************************************************************** *KEEP,FQDGPR. COMMON /FQDGPR/ TTSEP1,TTSEP2,MAXINT,ERRD0,ERRD1,ERRD2,ERRD3 &, DELCHG,DQUANT,FADBIN *KEEP,FQDGST. LOGICAL LSMEAR,LNOISE COMMON /FQDGST/ LSMEAR,LNOISE *KEND. *#**************************************************************** IF (.NOT.LSMEAR) THEN DSMEA = DRIFT RETURN ENDIF * Resolution vs. drift distance curve DELTA = SQRT(ERRD0 + DRIFT*ERRD1 + EXP(-ERRD3*DRIFT)*ERRD2) * Scale up the resolution for close previous hits (arbitrary) ISEPL = IFLAG0/256 IF (ISEPL.LT.10 .AND. ISEPL.GT.0) THEN IPEAK = IFLAG0 - 256*ISEPL IPLAST = IFLAG1/256 * Just in case ... IF (IPEAK.EQ.0) IPEAK = 1 FRAC = 10.*IPLAST/FLOAT(ISEPL*IPEAK) IF (FRAC.GT.1.) DELTA = DELTA*FRAC ENDIF * Error can't be bigger than 2-track resolution IF (DELTA.GT.TTSEP1) DELTA = TTSEP1 * Allow -ve fluctuations (across T0 boundary) CALL H1NORR(GAUSS) DSMEA = DRIFT + DELTA*GAUSS RETURN END *CMZU: 03/08/98 13.56.29 by Stephen Burke *-- Author : Stephen Burke 03/08/98 SUBROUTINE FQDIGI *#***************************************************************** *# * *# PURPOSE: Digitisation of hits in New Forward Planars. * *# * *# CALLED BY: H1DIGI * *# * *#***************************************************************** *KEEP,FQDGDB. COMMON /FQDGDB/ IFQDEB(5) *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 ------ *KEND. LOGICAL IQDEB *#**************************************************************** * Check debug range IQDEB = IFQDEB(1) .EQ. 1 + .AND. NEVENT .LE. IFQDEB(5) + .AND. NEVENT .GE. IFQDEB(4) * Check for existence of FRQF banks. If they exist then * create FRQH bank from them directly INFRQF = NLINK('FRQF',0) IF (IW(INFRQF).GT.0) THEN * Generate noise bank ... (not used yet) * CALL FRQNCR CALL FRQHCC IF (IQDEB) THEN CALL FPFRQF CALL FPFRQH ENDIF ELSE * Create FRPH bank from FRPT banks ... * Generate noise bank ... (not used yet) * CALL FRQNCR CALL FRQHCR IF (IQDEB) THEN CALL FPFRQT CALL FPFRQH ENDIF ENDIF * Now digitise the hits creating FRQE bank CALL FRQECR CALL FRQXCR IF (IQDEB) CALL FPFRQE IF (IQDEB) CALL FPFRQX * Now drop the intermediate HIT bank CALL BDROP(IW,'FRQH') RETURN END *CMZ : 20/01/99 14.09.57 by Girish D. Patel *-- Author : Stephen Burke 03/08/98 SUBROUTINE FQDRF(XP,YP,ZP,ICELL,FDRIFT,IFSGN) *#********************************************************************** *# * *# PURPOSE: COMPUTE DRIFT DISTANCE OF HIT IN NEW PLANARS AT * *# XP, YP, ZP (mean of track entry and exit points for now ) * *# * *# CALLED BY : FRQHCC, FRQHCR * *# * *# INPUT : BOS BANK FGAQ, XP,YP,ZP (cms) * *# * *# OUTPUT : FDRIFT (cms) if in cell ELSE -2000. * *# IFSGN drift sign 0/1 * *# * *# IFSGN changed so that 0 / 1 = positive / negative drift to agree * *# with the convention used in reconstruction. * *# IFSGN is -1 if the track is outside the sensitive volume * *# * *#********************************************************************** *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. DIMENSION IPKMOD(0:671) DIMENSION IPKWCL(0:671) DIMENSION IPKZPL(0:671) DIMENSION PSTART(0:2), STAGGE(0:2) DIMENSION PAOFF(0:27), PALEN(0:27) PARAMETER(TWOPI=6.283185) LOGICAL FIRST DATA FIRST/.TRUE./ *#********************************************************************** * Initialise drift distance to large negative number FDRIFT = -2000. IFSGN = 0 * Unpack FGAQ bank if first call... IF (FIRST) THEN DO 1 JJ=0,671 KMOD = JJ/224 KWCL = (JJ-KMOD*224)/8 KZPL = (JJ-KMOD*224-KWCL*8) IPKMOD(JJ) = KMOD IPKWCL(JJ) = KWCL IPKZPL(JJ) = KZPL 1 CONTINUE * Access FGAQ bank CALL UGTBNK('FGAQ',INFGAQ) IF (INFGAQ.LE.0) THEN WRITE(6,*)' ***FQDRF >> FGAQ BANK NOT FOUND' RETURN ENDIF * Get basic planar parameters ... NMOD = IW(INFGAQ+3) NPLANE = IW(INFGAQ+5) ZSEP = RW(INFGAQ+6) WZER = RW(INFGAQ+7) WSEP = RW(INFGAQ+8) * Half-lengths of wires ... KIND = INFGAQ + 8 DO 6 JL=1,14 PALEN(JL-1) = RW(KIND+JL)/2.0 PALEN(28-JL)= RW(KIND+JL)/2.0 6 CONTINUE * Offsets of wire centres ... KIND = INFGAQ + 22 DO 7 JO=1,6 PAOFF(7+JO) = RW(KIND+JO) PAOFF(13+JO) = - RW(KIND+JO) 7 CONTINUE DO 8 JO=0,7 PAOFF(JO) = 0.0 8 CONTINUE DO 9 JO=20,27 PAOFF(JO) = 0.0 9 CONTINUE KIND = INFGAQ + IW(INFGAQ+1) + 1 DO 2 KMOD=0,NMOD-1 PSTART(KMOD) = RW(KIND+4) STAGGE(KMOD) = RW(KIND+5) KIND = KIND + IW(KIND+1) + 1 2 CONTINUE CALL UGTRUN('FDQR',INFDQR) IF (INFDQR.LE.0) THEN WRITE(6,*)' ***FQDRF >> FDQR BANK NOT FOUND' RETURN ENDIF * Get TAN of Lorenz angle TLOREN = TAN(RW(INFDQR+23)*TWOPI/360.) FIRST = .FALSE. ENDIF * End unpacking * Unpack the module number and the celnum in W KPMOD = IPKMOD(ICELL) KWCL = IPKWCL(ICELL) KZPL = IPKZPL(ICELL) * Determine the W-coordinate of the wire in this cell IF (KWCL.LE.13) THEN WWIRE = WZER + KWCL *WSEP + STAGGE(KPMOD)*( (-1)**KZPL ) ELSE WWIRE = WZER + (KWCL-6)*WSEP + STAGGE(KPMOD)*( (-1)**KZPL ) ENDIF * Rotate x,y coordinates of hit into W,V frame: * W is the drift coordinate and V the coordinate along the wires. WHIT = XP*COS(PSTART(KPMOD)) + YP*SIN(PSTART(KPMOD)) VTRUE = -XP*SIN(PSTART(KPMOD)) + YP*COS(PSTART(KPMOD)) FDRIFT = WHIT - WWIRE VCORR = VTRUE - FDRIFT*TLOREN IF (FDRIFT.LT.0) IFSGN = 1 * V at 'top' and 'bottom' of cell PVMIN = PAOFF(KWCL) - PALEN(KWCL) PVMAX = PAOFF(KWCL) + PALEN(KWCL) * Check original V (for interpolated hits in coarse granularity, * the track can leave and re-enter the drift volume!!) IF (VTRUE.LT.PVMIN .OR. VTRUE.GT.PVMAX) IFSGN = -1 * Check if electrons reach wire IF (VCORR.LT.PVMIN .OR. VCORR.GT.PVMAX) IFSGN = -1 FDRIFT = ABS(FDRIFT) RETURN END *CMZ : 20/01/99 14.46.40 by Girish D. Patel *-- Author : Stephen Burke 03/08/98 SUBROUTINE FQIDIG ******************************************************************* *# * *# PURPOSE: Initialise COMMONS for Forward Planar digitisation * *# * *#***************************************************************** *# * *# CHANGED BY: AT: * *# * *# REASON : * *# * *#***************************************************************** *KEEP,FQDGPR. COMMON /FQDGPR/ TTSEP1,TTSEP2,MAXINT,ERRD0,ERRD1,ERRD2,ERRD3 &, DELCHG,DQUANT,FADBIN *KEEP,FQDGST. LOGICAL LSMEAR,LNOISE COMMON /FQDGST/ LSMEAR,LNOISE *KEEP,FQDGDB. COMMON /FQDGDB/ IFQDEB(5) *KEEP,FQDGDG. COMMON /FQDGDG/ IDRFAC,QFAC,IQSAT *KEEP,FQDGEF. COMMON /FQDGEF/ EFFQ(0:7,0:2),EFFQ8(0:2),PHMC(6),PWMC1(5) &, PWMC2(5),PWMC3(5),PWMC4(5),PWMC5(5) *KEEP,FQMAXN. * Maximum number of noise hits for new planars PARAMETER (MXNHTQ=5) *KEEP,FQTRNP. * Forward new planar track-related noise + shifted data parameters PARAMETER (MAXSGQ=5) LOGICAL LFDQX COMMON /FQTRNP/ QTRNP1(MXNHTQ),QTRNP2(MXNHTQ),QTRNDD(2,MAXSGQ) &, QPNEGD,LFDQX,SIGSHF,SGNSHF,SIGNOI,SGNNOI &, ANGNOI,PRBNOI,OFFNOI *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. DIMENSION P1(MXNHTQ),P2(MXNHTQ),D(MAXSGQ-1),PD(MAXSGQ-2) *------------------------------------------------------------------ * * Initialisation - access parameter banks * CALL UGTRUN('FDQR',INFDQR) IF (INFDQR.LE.0) THEN WRITE(6,*) ' ***FQIDIG >> FDQR BANK NOT FOUND' CALL H1STOP ENDIF IF (IW(INFDQR+3).LT.980801) THEN WRITE(6,*) ' ***FQIDIG >> WRONG VERSION OF FDQR BANK' CALL H1STOP ENDIF LSMEAR = (IW(INFDQR + 4).NE.0) LNOISE = (IW(INFDQR + 5).NE.0) IFQDEB(1) = IW(INFDQR + 6) IFQDEB(2) = IW(INFDQR + 7) IFQDEB(3) = IW(INFDQR + 8) IFQDEB(4) = IW(INFDQR + 9) IFQDEB(5) = IW(INFDQR + 10) QFAC = RW(INFDQR + 11) IQSAT = IW(INFDQR + 12) DRFVEL = RW(INFDQR + 13) TTSEP1 = RW(INFDQR + 14) TTSEP2 = RW(INFDQR + 15) MAXINT = IW(INFDQR + 16) ERRD0 = RW(INFDQR + 17) ERRD1 = RW(INFDQR + 18) ERRD2 = RW(INFDQR + 19) ERRD3 = RW(INFDQR + 20) DELCHG = RW(INFDQR + 21) DQUANT = RW(INFDQR + 22) EFFQ(0,0) = RW(INFDQR + 24) EFFQ(1,0) = RW(INFDQR + 25) EFFQ(2,0) = RW(INFDQR + 26) EFFQ(3,0) = RW(INFDQR + 27) EFFQ(4,0) = RW(INFDQR + 28) EFFQ(5,0) = RW(INFDQR + 29) EFFQ(6,0) = RW(INFDQR + 30) EFFQ(7,0) = RW(INFDQR + 31) EFFQ8(0) = RW(INFDQR + 32) EFFQ8(1) = RW(INFDQR + 33) EFFQ8(2) = RW(INFDQR + 34) P1(1) = RW(INFDQR + 35) P1(2) = RW(INFDQR + 36) P1(3) = RW(INFDQR + 37) P1(4) = RW(INFDQR + 38) P1(5) = RW(INFDQR + 39) P2(1) = RW(INFDQR + 40) P2(2) = RW(INFDQR + 41) P2(3) = RW(INFDQR + 42) P2(4) = RW(INFDQR + 43) P2(5) = RW(INFDQR + 44) D(1) = RW(INFDQR + 45) D(2) = RW(INFDQR + 46) D(3) = RW(INFDQR + 47) D(4) = RW(INFDQR + 48) PD(1) = RW(INFDQR + 49) PD(2) = RW(INFDQR + 50) PD(3) = RW(INFDQR + 51) QPNEGD = RW(INFDQR + 52) * 1/(Size of an FADC bin in cm) FADBIN = 1.0/(0.00096*DRFVEL) * Re-scale resolution parameters ERRD0 = ERRD0*ERRD0 ERRD1 = ERRD1*ERRD1 ERRD2 = ERRD2*ERRD2 ERRD3 = 2./ERRD3 * Cumulate the track-related noise probabilities PCUM1 = 0. PCUM2 = 0. DO 100 J=1,MXNHTQ PCUM1 = PCUM1 + P1(J) PCUM2 = PCUM2 + P2(J) QTRNP1(J) = PCUM1 QTRNP2(J) = PCUM2 100 CONTINUE * Cumulate the track-related noise drift distribution QTRNDD(1,1) = 0. QTRNDD(2,1) = 0. DO 200 JSEG=2,MAXSGQ-1 QTRNDD(1,JSEG) = QTRNDD(1,JSEG-1) + PD(JSEG-1) QTRNDD(2,JSEG) = D(JSEG-1) 200 CONTINUE QTRNDD(1,MAXSGQ) = 1. QTRNDD(2,MAXSGQ) = D(MAXSGQ-1) CALL UGTRUN('FDQH',INFDQH) IF (INFDQH.LE.0) THEN WRITE(6,*) ' ***FQIDIG >> FDQH BANK NOT FOUND' CALL H1STOP ENDIF IF (IW(INFDQH+3).LT.980801) THEN WRITE(6,*) ' ***FQIDIG >> WRONG VERSION OF FDQH BANK' CALL H1STOP ENDIF PHMC(1) = RW(INFDQH + 4) PHMC(2) = RW(INFDQH + 5) PHMC(3) = RW(INFDQH + 6) PHMC(4) = RW(INFDQH + 7) PHMC(5) = RW(INFDQH + 8) PHMC(6) = RW(INFDQH + 9) PWMC1(1) = RW(INFDQH + 10) PWMC1(2) = RW(INFDQH + 11) PWMC1(3) = RW(INFDQH + 12) PWMC1(4) = RW(INFDQH + 13) PWMC1(5) = RW(INFDQH + 14) PWMC2(1) = RW(INFDQH + 15) PWMC2(2) = RW(INFDQH + 16) PWMC2(3) = RW(INFDQH + 17) PWMC2(4) = RW(INFDQH + 18) PWMC2(5) = RW(INFDQH + 19) PWMC3(1) = RW(INFDQH + 20) PWMC3(2) = RW(INFDQH + 21) PWMC3(3) = RW(INFDQH + 22) PWMC3(4) = RW(INFDQH + 23) PWMC3(5) = RW(INFDQH + 24) PWMC4(1) = RW(INFDQH + 25) PWMC4(2) = RW(INFDQH + 26) PWMC4(3) = RW(INFDQH + 27) PWMC4(4) = RW(INFDQH + 28) PWMC4(5) = RW(INFDQH + 29) PWMC5(1) = RW(INFDQH + 30) PWMC5(2) = RW(INFDQH + 31) PWMC5(3) = RW(INFDQH + 32) PWMC5(4) = RW(INFDQH + 33) PWMC5(5) = RW(INFDQH + 34) CALL UGTRUN('FDEF',INFDEF) IF (INFDEF.LE.0) THEN WRITE(6,*) ' ***FQIDIG >> FDEF BANK NOT FOUND' CALL H1STOP ENDIF IF (IW(INFDEF+3).LT.980801) THEN WRITE(6,*) ' ***FQIDIG >> WRONG VERSION OF FDEF BANK' CALL H1STOP ENDIF RDFAC0 = RW(INFDEF + 10) RDFAC1 = RW(INFDEF + 11) RDFAC2 = RW(INFDEF + 12) * Apply run-dependent efficiency factors DO 500 JWIRE=0,5 EFFQ(JWIRE,2) = EFFQ(JWIRE,0)*RDFAC2 EFFQ(JWIRE,1) = EFFQ(JWIRE,0)*RDFAC1 EFFQ(JWIRE,0) = EFFQ(JWIRE,0)*RDFAC0 500 CONTINUE LFDQX = .FALSE. SIGSHF = 0. SGNSHF = 0. SIGNOI = 0. SGNNOI = 0. ANGNOI = 0. PRBNOI = 0. OFFNOI = 0. * Look for FDQX bank - shifted data parameters, may not be present CALL UGTRUN('FDQX',INFDQX) IF (INFDQX.LE.0) RETURN IF (IW(INFDQX+3).LT.980801) THEN WRITE(6,*) ' ***FQIDIG >> WRONG VERSION OF FDQX BANK' CALL H1STOP ENDIF LFDQX = .TRUE. SIGSHF = RW(INFDQX+4) SGNSHF = RW(INFDQX+5) SIGNOI = RW(INFDQX+6) SGNNOI = RW(INFDQX+7) ANGNOI = RW(INFDQX+8) PRBNOI = RW(INFDQX+9) OFFNOI = RW(INFDQX+10) RETURN END *CMZU: 03/08/98 13.56.29 by Stephen Burke *-- Author : Stephen Burke 03/08/98 SUBROUTINE FQQSME(QPLUS,IFLAG0,IFLAG1,IFLAG2,QPSME) *#**************************************************************** *# * *# PURPOSE: Compute Smeared Charge (Energy) * *# * *# INPUT: QPLUS - deposited charge (actually Energy in eV) * *# IFLAG - FLAG containing hit "quality" inf* *# * *# OUTPUT: QPSME Smeared charge * *# Depends on IFLAG * *# * *#**************************************************************** *# * *# CHANGED BY: AT: * *# * *# REASON : * *# * *# * *#**************************************************************** *KEEP,FQDGPR. COMMON /FQDGPR/ TTSEP1,TTSEP2,MAXINT,ERRD0,ERRD1,ERRD2,ERRD3 &, DELCHG,DQUANT,FADBIN *KEEP,FQDGDG. COMMON /FQDGDG/ IDRFAC,QFAC,IQSAT *KEEP,FQDGST. LOGICAL LSMEAR,LNOISE COMMON /FQDGST/ LSMEAR,LNOISE *KEND. *#**************************************************************** QPSME = QPLUS*QFAC * NB There is no adjustment for a preceding pulse IF (LSMEAR) THEN CALL H1NORR(GAUSS1) CALL H1NORR(GAUSS2) QPSME = QPLUS*(1.0 + DELCHG*GAUSS1)*QFAC + DQUANT*GAUSS2 ENDIF IF (QPSME.LT.0.) QPSME = 0. RETURN END *CMZU: 03/08/98 13.56.29 by Stephen Burke *-- Author : Stephen Burke 03/08/98 SUBROUTINE FRQECR *#********************************************************************** *# * *# VERSION: 29/07/98 Steve Burke * *# * *# PURPOSE: Create EVENT response bank FRQE * *# * *# 1) Sort hits from FRQH bank by cell number(wire) * *# 2) Sort hits on one wire by drift distance * *# 3) Simulate QT * *# * *# CALLED BY : FQDIGI * *# * *# CALLS : FQQTSM * *# * *# INPUT : BOS BANK FRQH * *# * *# OUTPUT : FRQE bank * *# * *#********************************************************************** *# * *# AUTHOR : S. BURKE * *# * *# CHANGED BY: AT: * *# REASON : * *# * *#********************************************************************** *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. * Common for work bank index COMMON /CFSORT/ ISORT * Temp common for pointer arrays (extended for FRQX 29/7/98) PARAMETER (MAXHIT=3000) COMMON /H1WORK/ IFRRX(3,MAXHIT),IFRPX(3,MAXHIT),NFRRX,NFRPX &, IFRQX(3,MAXHIT),NFRQX *#********************************************************************** * Zero pointer table CALL VZERO(IFRQX,MAXHIT*3) NFRQX = 0 * Locate FRQH Bank INFRQH = NLINK('FRQH',0) IF (INFRQH.LE.0) THEN C WRITE(6,*) 'FRQH BANK NOT FOUND' RETURN ENDIF * Number of Hits INUM = IW(INFRQH+2) IF (INUM.LE.0) GOTO 100 * Truncate and warn if INUM exceeds MAXHIT IF (INUM.GT.MAXHIT) THEN CALL ERRLOG(205,'W:FRQECR: More than 3000 hits - rest ignored') INUM = MAXHIT ENDIF NFRQX = INUM * Format event response bank CALL BKFMT('FRQE','B16') * Create work bank for indices of channel numbers ISORT = 0 CALL WBANK(IW,ISORT,INUM,*100) * Length of data block ... IB = IW(INFRQH+1) * Position one data block length before first block ... IA = INFRQH + 3 - IB * Loop to insert indices of cell numbers DO 30 I=1,INUM IW(ISORT+I) = IA + I*IB 30 CONTINUE * Sort by cell number ... * RW(IW(ISORT+J)) is now the cell number and, in general, * RW(IW(ISORT+J) + IATTRIB - 1) is now IATTRIB'th attribute of * row JROW = (IW(ISORT+J) - INSTR)/IW(INFRQH+3) + 1 * in the FRQH bank. CALL SORTIL(IW,IW(ISORT+1),INUM) *============================================================== * Initialise digi counter KDIGI = 0 * Loop on all wires I = 0 40 IF (I.EQ.INUM) GOTO 90 * Next wire number I = I + 1 IJ = I 50 CONTINUE IF (IJ.LT.INUM) THEN IF (IW(IW(ISORT+IJ+1)).EQ.IW(IW(ISORT+I))) THEN IJ = IJ + 1 GOTO 50 ENDIF ENDIF * I ... IJ are for same wire IBASE = I - 1 N = IJ - IBASE * Inline sort within one wire * Sort is based on drift distance * Drift distance is 2 words on from celnum in FRQH data blocks ISRT = ISORT + IBASE M = N 51 CONTINUE M = M/2 IF (M.GT.0) THEN DO 53 J=1,N-M L = J * Compare elements with indices 'L' and 'L+M' 52 CONTINUE IF (RW(IW(ISRT+L+M)+2).LT.RW(IW(ISRT+L)+2)) THEN * exchange the two index values LL = IW(ISRT+L+M) IW(ISRT+L+M) = IW(ISRT+L) IW(ISRT+L ) = LL L = L - M IF (L.GT.0) GOTO 52 ENDIF 53 CONTINUE GOTO 51 ENDIF * * Hits on this wire are J=I,IJ, now sorted in order of increasing * drift distance. Now simulate the QT and extend the FRQE bank * CALL FQQTSM(INFRQH,KDIGI,I,IJ) * Make transition to next wire I = IJ GOTO 40 *============================================================== * Finished 90 CONTINUE * Close bank IFRQE = IADFIN('FRQE',0) CALL BLIST(IW,'E+','FRQE') 100 CONTINUE * Drop work bank CALL WDROP(IW,ISORT) RETURN END *CMZ : 20/01/99 14.59.43 by Girish D. Patel *-- Author : Stephen Burke 03/08/98 SUBROUTINE FRQHCC *#********************************************************************** *# * *# VERSION: 30/07/98 Steve Burke * *# * *# PURPOSE: Create FRQH hit bank from FRQF bank * *# * *# CALLED BY : FQDIGI * *# * *# CALLS : FRQHEX * *# * *# INPUT : FRQF banks * *# * *# OUTPUT : FRQH bank * *# ==== * *# AUTHOR : Steve Burke * *# * *#********************************************************************** *# * *# FORMAT OF FRQH BANK 2I,(I,2F,4I) Bank Number = 0 * *# ====== == ==== ==== * *# BANK FRQH Forward Response new planar (Q) Hit bank * *# Contains all hits in chambers * *# IND+1 = NCOLS = 7 * *# IND+2 = NROWS * *# ---------------------------------------------------------------- * *# Col * *# 1 I = CELNUM Attrib * *# 2 R = EDEP Attrib * *# 3 R = DRIFT DISTANCE Attrib * *# 4 I = HITTYP Attrib * *# 5 I = Drift 'sign' 0/1 Attrib * *# 6 I = Trk History word Attrib * *# 7 I = Trk Number Reln * *# ---------------------------------------------------------------- * *# HITTYP = 1 for track; 2 for noise * *# (GEANT units: cms GeV) * *# * *#********************************************************************** *# * *# CHANGED BY: AT: * *# * *# REASON : * *# * *#********************************************************************** *KEEP,FQDGEF. COMMON /FQDGEF/ EFFQ(0:7,0:2),EFFQ8(0:2),PHMC(6),PWMC1(5) &, PWMC2(5),PWMC3(5),PWMC4(5),PWMC5(5) *KEEP,FQDGST. LOGICAL LSMEAR,LNOISE COMMON /FQDGST/ LSMEAR,LNOISE *KEEP,FQMAXN. * Maximum number of noise hits for new planars PARAMETER (MXNHTQ=5) *KEEP,FQTRNP. * Forward new planar track-related noise + shifted data parameters PARAMETER (MAXSGQ=5) LOGICAL LFDQX COMMON /FQTRNP/ QTRNP1(MXNHTQ),QTRNP2(MXNHTQ),QTRNDD(2,MAXSGQ) &, QPNEGD,LFDQX,SIGSHF,SGNSHF,SIGNOI,SGNNOI &, ANGNOI,PRBNOI,OFFNOI *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. PARAMETER (IHTTRK=1) PARAMETER (IHTNOI=2) PARAMETER (NCL =7) PARAMETER (NBN =0) DIMENSION IKADD(NCL),BKADD(NCL) EQUIVALENCE (IKADD(1),BKADD(1)) * Cut in Deltap/p between entrance and exit. Ignore hits produced * by stopping and spiralling tracks... PARAMETER (DPRCUT=0.5) * Precision with which cell boundary (in z) is required. This * should be >= the parameter EPSIL for the tracking medium as * in the FGME bank... PARAMETER (SMALL=0.0101) * Minimum energy deposit (50MeV) for a hit (avoids hits with zero * energy loss and hence un-reconstructible radii) PARAMETER(FELMIN= 5.0E-8) DIMENSION ZPLA(24) DIMENSION KQMOD(24) PARAMETER (NWMAX=8) DIMENSION DRIFT(NWMAX),IDSIGN(NWMAX) LOGICAL LMASK LOGICAL LMHIT LOGICAL FIRST LOGICAL DONE DATA FIRST/.TRUE./ *#********************************************************************** * Initialise geometry on first call... IF (FIRST) THEN CALL BKFMT('FRQH','2I,(I,2F,4I)') * Access FGAQ bank CALL UGTBNK('FGAQ',INFGAQ) IF (INFGAQ.LE.0) THEN WRITE(6,*) ' FRQHCC Error - FGAQ Bank not found' RETURN ENDIF * Get basic planar parameters NMODQ = IW(INFGAQ+3) WSEPQ = RW(INFGAQ+6) KIND = INFGAQ + IW(INFGAQ+1) + 1 * N.B. ZPLA(K) gives location of the cell boundary in z * FURTHEST from the interaction point !!! DO 1 KMOD=0,NMODQ-1 ZST = RW(KIND+3) DO 2 KZP=1,8 KK = KZP + KMOD*8 ZPLA (KK) = ZST + KZP*WSEPQ KQMOD(KK) = KMOD 2 CONTINUE KIND = KIND + IW(KIND+1) + 1 1 CONTINUE FIRST = .FALSE. ENDIF *----------------------------------------------------------------------- * Access FRQF bank INFRQF = NLINK('FRQF',0) IF (INFRQF.EQ.0) RETURN * If bank exists access relevant information ... IBLEN = IW(INFRQF+1) IBLKS = IW(INFRQF+2) DO 11 J=1,IBLKS * Pointers to entrance and exit data blocks ... IPT0 = INFRQF + 2 + (J-1)*IBLEN IPT1 = IPT0 + 7 * and to subsidiary data ... IPTD = IPT0 + 14 * Check momentum loss. Stopping tracks, spiraling tracks etc. * cause problems. We can't be bothered with this so skip if * Deltap/p > 50%. RDRP = ABS(RW(IPT0+7) - RW(IPT1+7))/RW(IPT0+7) IF (RDRP.GT.DPRCUT) GOTO 11 * Allow for coherent loss of 8-wire groups ICLNUM = IW(IPTD+2) IF (H1RN(J-1).GT.EFFQ8(ICLNUM/224)) THEN CALL FQHMC(MASK) IF (MASK.EQ.0) GOTO 11 LMASK = .TRUE. ELSE LMASK = .FALSE. ENDIF IF (LFDQX) THEN * Allow for correlated shifts SHIFT = -SIGSHF*LOG(1. - MIN(H1RN(J-17),0.999999)) IF (H1RN(J-18).GT.SGNSHF) SHIFT = -SHIFT ELSE SHIFT = 0. ENDIF * Trouble if track is going backwards? Reverse pointers * if Z1 less than Z0 IF (RW(IPT1+3).LT.RW(IPT0+3)) THEN IPDM = IPT0 IPT0 = IPT1 IPT1 = IPDM ENDIF X0 = RW(IPT0+1) Y0 = RW(IPT0+2) Z0 = RW(IPT0+3) VX0 = RW(IPT0+4) VY0 = RW(IPT0+5) VZ0 = RW(IPT0+6) X1 = RW(IPT1+1) Y1 = RW(IPT1+2) Z1 = RW(IPT1+3) VX1 = RW(IPT1+4) VY1 = RW(IPT1+5) VZ1 = RW(IPT1+6) P0 = RW(IPT0+7) * Ignore vertical tracks IF (VZ0.EQ.0.) GOTO 11 * Particle type, History word, Cell number and track number ... * S.E. PDG code translated to Geant code IR0 = IPDGEA(IW(IPTD+1)) ITRHIS = IW(IPTD+3) ITRK = IW(IPTD+4) VT0 = SQRT(1.0 - VZ0*VZ0) IF (VT0.EQ.0. .OR. (X1.EQ.X0 .AND. Y1.EQ.Y0)) THEN VXT0 = 0. VYT0 = 0. CU = 0. ELSE VXT0 = VX0/VT0 VYT0 = VY0/VT0 * Compute curvature of track ... CU = -2.0*(VYT0*(X1 - X0) - VXT0*(Y1 - Y0))/ + ((X1 - X0)**2 + (Y1 - Y0)**2) ENDIF * P0 needs to be signed by the charge, which (I think) is opposite to * the sign of the curvature *for forward-going tracks* P0 = SIGN(P0,-CU) AFAC = CU*VT0/(2.0*VZ0) * Propagate the track from X0,Y0,Z0 in Steps of z. * The z-step is one cell depth in z, allowing however for * the possibility that the 1st and last point are interior * to a z-cell. * Locate the first z-cell boundary to propagate to ... KZBEG = 24 DO 20 KZ=1,24 DIST = ZPLA(KZ) - Z0 IF (DIST.GT.SMALL) THEN KZBEG = KZ GO TO 21 ENDIF 20 CONTINUE 21 CONTINUE * First plane to go to is at ZPLA(KZBEG) KZP = KZBEG - 1 ZIN = Z0 XIN = X0 YIN = Y0 NWIRE = 0 * Loop over intermediate drift cells ... 100 CONTINUE KZP = MIN(KZP+1,24) ZOUT = ZPLA(KZP) * Last point? IF (ZOUT.GT.Z1 .OR. ABS(ZOUT-Z1).LT.SMALL + .OR. KZP.EQ.24) THEN ZOUT = Z1 DONE = .TRUE. ELSE DONE = .FALSE. ENDIF * Propagate track along helix to exit point of drift cell DIST = ZOUT - Z0 SPSI = SIN(AFAC*DIST) CPSI = COS(AFAC*DIST) * modified by S.E. at 30.3.90 to avoid division by zero IF (CU.EQ.0.)THEN BFAC = VT0*DIST/VZ0 ELSE BFAC = 2.0*SPSI/CU ENDIF XOUT = X0 + BFAC*(VXT0*CPSI - VYT0*SPSI) YOUT = Y0 + BFAC*(VYT0*CPSI + VXT0*SPSI) * Complete CELL number ... ICELNM = ICLNUM + MOD(KZP-1,8) * Compute drift distance ZP = ZPLA(KZP) - 0.5*WSEPQ XP = XIN + (XOUT - XIN)*(ZP - ZIN)/(ZOUT - ZIN) YP = YIN + (YOUT - YIN)*(ZP - ZIN)/(ZOUT - ZIN) CALL FQDRF(XP,YP,ZP,ICELNM,DRIF,IFSGN) DRIF = DRIF + SHIFT IF (IFSGN.GE.0) THEN * Collect drift and sign for each wire IF (NWIRE.LT.NWMAX) THEN NWIRE = NWIRE + 1 IF (NWIRE.EQ.1) ICELL = ICELNM DRIFT(NWIRE) = DRIF IDSIGN(NWIRE) = IFSGN ENDIF * Compute energy loss ... CALL FDEDXL(XIN,YIN,ZIN,XOUT,YOUT,ZOUT,P0,IR0,FELOSS) * Only make hit if sufficient energy loss in drift cell, * and allow for inefficiency IF (FELOSS.GT.FELMIN) THEN IWR = MOD(ICELNM,8) IF (LMASK) THEN LMHIT = JBIT(MASK,IWR+1).EQ.1 ELSE LMHIT = H1RN(J).LE.EFFQ(IWR,ICELNM/224) ENDIF IF (LMHIT) THEN * Add hit to bank ... IKADD(1) = ICELNM BKADD(2) = FELOSS BKADD(3) = DRIF IKADD(4) = IHTTRK IKADD(5) = IFSGN IKADD(6) = ITRHIS IKADD(7) = ITRK KND = IADROW('FRQH',NBN,NCL,BKADD) ENDIF ENDIF ELSEIF (NWIRE.GT.0) THEN * Track went outside cell, so add noise for the wires so far IF (LNOISE) CALL FRQHEX(ICELL,NWIRE,DRIFT,IDSIGN,ITRK) NWIRE = 0 ENDIF * Done with this step - go on to next IF (DONE) THEN * Add track-related noise IF (NWIRE.GT.0 .AND. LNOISE) & CALL FRQHEX(ICELL,NWIRE,DRIFT,IDSIGN,ITRK) GOTO 200 ENDIF XIN = XOUT YIN = YOUT ZIN = ZOUT GOTO 100 200 CONTINUE 11 CONTINUE * Now access NOISE hit banks and fill hits ... * No noise is generated at the moment. We may well generate * different categories of noise kept in FRQN's with different * bank numbers. IFRQN = NAMIND('FRQN') INFRQN = IFRQN + 1 40 CONTINUE INFRQN = IW(INFRQN-1) * If bank exists access relevant information ... IF (INFRQN.NE.0 .AND. LNOISE) THEN * Number of hits in bank INUM = IW(INFRQN+2) * Track number zero for noise? ITRK = 0 * History word zero for noise? ITRHIS = 0 * Loop through hits in this bank INDST = INFRQN + 2 DO 41 JJHIT=1,INUM * Information from noise response bank ... * N.B. Noise bank must contain full CELNUM ICLNUM = IW(INDST + 1) XD = RW(INDST + 2) YD = RW(INDST + 3) ZD = RW(INDST + 4) EDEP = RW(INDST + 5) * Only make hit if sufficient energy loss in drift cell ... IF (EDEP.GT.FELMIN) THEN * Compute drift distance CALL FQDRF(XD,YD,ZD,ICLNUM,DRIF,IFSGN) IF (IFSGN.GE.0) THEN * Extend FRQH bank ... IKADD(1) = ICLNUM BKADD(2) = EDEP BKADD(3) = DRIF IKADD(4) = IHTNOI IKADD(5) = IFSGN IKADD(6) = ITRHIS IKADD(7) = ITRK KND = IADROW('FRQH',NBN,NCL,BKADD) ENDIF ENDIF INDST = INDST + IW(INFRQN+1) 41 CONTINUE * End loop through hits this bank - go to next bank GOTO 40 ENDIF * Close bank KND = IADFIN('FRQH',NBN) RETURN END *CMZ : 20/01/99 15.03.05 by Girish D. Patel *-- Author : Stephen Burke 03/08/98 SUBROUTINE FRQHCR *#********************************************************************** *# * *# VERSION: 30/07/98 Steve Burke * *# * *# Create hit bank FRQH,0 from fine granularity input * *# * *# CALLED BY: FQDIGI * *# * *# INPUTS: * *# FRQT banks * *# FRQN banks (noise) * *# OUTPUT: * *# One bank FRQH,0 containing Hits from above banks * *# * *# CALLS TO: FQDRF * *# * *# NB: There is also an FRQT bank in the database (with radial QT * *# parameters), so beware of clashes! Fine granularity * *# simulation should not be used for standard MC production. * *# * *#********************************************************************** *# * *# FORMAT OF FRQH BANK 2I,(I,2F,4I) Bank Number = 0 * *# ====== == ==== ==== * *# BANK FRQH Forward Response new planar (Q) Hit bank * *# Contains all hits in chambers * *# IND+1 = NCOLS = 7 * *# IND+2 = NROWS * *# ---------------------------------------------------------------- * *# Col * *# 1 I = CELNUM Attrib * *# 2 R = EDEP Attrib * *# 3 R = DRIFT DISTANCE Attrib * *# 4 I = HITTYP Attrib * *# 5 I = Drift 'sign' 0/1 Attrib * *# 6 I = Trk History word Attrib * *# 7 I = Trk Number Reln * *# ---------------------------------------------------------------- * *# HITTYP = 1 for track; 2 for noise * *# (GEANT units: cms GeV) * *# * *#********************************************************************** *# * *# CHANGED BY: AT: * *# * *# REASON : * *# * *#********************************************************************** *KEEP,FQDGEF. COMMON /FQDGEF/ EFFQ(0:7,0:2),EFFQ8(0:2),PHMC(6),PWMC1(5) &, PWMC2(5),PWMC3(5),PWMC4(5),PWMC5(5) *KEEP,FQDGST. LOGICAL LSMEAR,LNOISE COMMON /FQDGST/ LSMEAR,LNOISE *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. PARAMETER (IHTTRK=1) PARAMETER (IHTNOI=2) PARAMETER (NCL =7) PARAMETER (NBN =0) * Minimum energy deposit (50eV) for a hit (avoids hits with zero * energy loss and hence un-reconstructible radii) PARAMETER (FELMIN=5.0E-8) DIMENSION IKADD(NCL),BKADD(NCL) EQUIVALENCE (IKADD(1),BKADD(1)) *#********************************************************************** * Locate FRQT bank ... INFRQT = NLINK('FRQT',NBN) * Locate FRQN bank ... (noise in new planars) INFRQN = IW(NAMIND('FRQN')) * Check to see if any information ... IF (INFRQT.LE.0 .AND. INFRQN.LE.0) RETURN * Hits Exist ... CALL BKFMT ('FRQH','2I,(I,2F,4I)') * Now create banks * First search through FRQT bank ... IF (INFRQT.GT.0) THEN * Number of hits in bank INUM = IW(INFRQT+2) * Loop through hits in this bank INDST = INFRQT + 2 DO 11 JJHIT=1,INUM * Information from track response bank ... ICLNUM = IW(INDST + 1) EDEP = RW(INDST + 8) * Only make hit if above minimum energy deposition, and allow * for inefficiency IF (EDEP.GT.FELMIN .AND. & H1RN(JJHIT).LE.EFFQ(MOD(ICLNUM,8),ICLNUM/224)) THEN XIN = RW(INDST + 2) YIN = RW(INDST + 3) ZIN = RW(INDST + 4) XOUT = RW(INDST + 5) YOUT = RW(INDST + 6) ZOUT = RW(INDST + 7) ITRHIS = IW(INDST + 9) ITRK = IW(INDST + 10) * Compute drift distance XP = 0.5*(XIN + XOUT) YP = 0.5*(YIN + YOUT) ZP = 0.5*(ZIN + ZOUT) CALL FQDRF(XP,YP,ZP,ICLNUM,DRIF,IFSGN) IF (IFSGN.GE.0) THEN * Add hit to bank ... IKADD(1) = ICLNUM BKADD(2) = EDEP BKADD(3) = DRIF IKADD(4) = IHTTRK IKADD(5) = IFSGN IKADD(6) = ITRHIS IKADD(7) = ITRK KND = IADROW('FRQH',NBN,NCL,BKADD) ENDIF ENDIF INDST = INDST + IW(INFRQT+1) 11 CONTINUE ENDIF IFRQN = NAMIND('FRQN') INFRQN = IFRQN + 1 40 CONTINUE INFRQN = IW(INFRQN-1) * If bank exists access relevant information ... IF (INFRQN.GT.0 .AND. LNOISE) THEN * Number of hits in bank INUM = IW(INFRQN+2) * Track number zero for noise? ITRK = 0 * History word zero for noise? ITRHIS = 0 * Loop through hits in this bank INDST = INFRQT + 2 DO 41 JJHIT=1,INUM * Information from noise response bank ... * N.B. Noise bank must contain full CELNUM ICLNUM = IW(INDST + 1) XD = RW(INDST + 2) YD = RW(INDST + 3) ZD = RW(INDST + 4) EDEP = RW(INDST + 5) IF (EDEP.GT.FELMIN) THEN * Compute drift distance CALL FQDRF(XD,YD,ZD,ICLNUM,DRIF,IFSGN) IF (IFSGN.GE.0) THEN * Extend FRQH bank ... IKADD(1) = ICLNUM BKADD(2) = EDEP BKADD(3) = DRIF IKADD(4) = IHTNOI IKADD(5) = IFSGN IKADD(6) = ITRHIS IKADD(7) = ITRK KND = IADROW('FRQH',NBN,NCL,BKADD) ENDIF ENDIF INDST = INDST + IW(INFRQN+1) 41 CONTINUE * End loop through hits this bank - go to next bank GOTO 40 ENDIF * Finished IFRQH = IADFIN('FRQH',NBN) RETURN END *CMZU: 03/08/98 13.56.29 by Stephen Burke *-- Author : Stephen Burke 03/08/98 SUBROUTINE FRQXCR *#********************************************************************** *# * *# VERSION: 30/07/98 Steve Burke * *# * *# Create table of pointers, parallel to FRQH hit bank * *# pointing into FRQE * *# * *# CALLED BY: FQDIGI * *# * *#********************************************************************** *# * *# FORMAT OF FRQX BANK B16 Bank Number = 0 * *# ====== == ==== ==== * *# Bank FRQX Forward Response new planar (Q) X-ref bank * *# Contains relations to FRQE and STR banks * *# PARALLEL to FRQH bank * *# * *# word# type Content * *# 1 I = NCOLS = 3 * *# 2 I = NROWS = Number of hits * *# ---------------------------------------------------------------- * *# Col * *# 1 I = IFLAG Attrib * *# 2 I = Trk Number (STR) Reln * *# 3 I = IFRQE Reln * *# ----------------------------------------------------------------- * *# IFLAG = Bit 0 set if drift sign posive * *# Bit 8 set if hit from track * *# Bit 9 set if hit from noise * *# Bit10 set if hit from TR * *# Trk Num Pointer into STR bank * *# IFRQE Pointer into FRQE bank * *# * *#********************************************************************** *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. * Temp common for pointer arrays (extended for FRQX 29/7/98) PARAMETER (MAXHIT=3000) COMMON /H1WORK/ IFRRX(3,MAXHIT),IFRPX(3,MAXHIT),NFRRX,NFRPX &, IFRQX(3,MAXHIT),NFRQX PARAMETER (NBN=0) PARAMETER (NCOL=3) *#********************************************************************** IF (NFRQX.NE.0) THEN CALL BKFMT('FRQX','B16') IND = IADNRW('FRQX',NBN,NCOL,NFRQX,IFRQX) IND = IADFIN('FRQX',NBN) CALL BLIST(IW,'E+','FRQX') ENDIF RETURN END *CMZ : 20/01/99 15.04.09 by Girish D. Patel *-- Author : Stephen Burke 03/08/98 SUBROUTINE FRQHEX(ICLNUM,NWIRE,DRIFT,IDSIGN,ITRK) *#********************************************************************** *# * *# PURPOSE: Extend FRQH hit bank by adding track-related noise hits * *# * *# CALLED BY : FRQHCC, once per track per module * *# * *# INPUT : ICLNUM - cell number (for wire 0) * *# NWIRE - number of wires * *# DRIFT - absolute drift to each wire * *# IDSIGN - drift sign for each wire * *# ITRK - track number * *# * *# OUTPUT : FRQH bank rows * *# ==== * *# * *# AUTHOR : Stephen Burke * *# * *# MODIFICATIONS: * *# * *#********************************************************************** *# * *# FORMAT OF FRQH BANK 2I,(I,2F,4I) Bank Number = 0 * *# ====== == ==== ==== * *# * *# BANK FRQH Forward Response new planar (Q) Hit bank * *# Contains all hits in new Planars * *# * *# IND+1 = NCOLS = 7 * *# IND+2 = NROWS * *# ---------------------------------------------------------------- * *# Col * *# 1 I = CELNUM Attrib * *# 2 R = EDEP Attrib * *# 3 R = DRIFT DISTANCE Attrib * *# 4 I = HITTYP Attrib * *# 5 I = Drift 'sign' 0/1 Attrib * *# 6 I = Trk History word Attrib * *# 7 I = Trk Number Reln * *# ---------------------------------------------------------------- * *# HITTYP = 2 for noise * *# (GEANT units: cms GeV) * *# * *# Word 6 is set to zero, and word 7 to the 'parent' track number * *# * *#********************************************************************** *KEEP,FQMAXN. * Maximum number of noise hits for new planars PARAMETER (MXNHTQ=5) *KEND. PARAMETER (NWMAX=8) DIMENSION DRIFT(NWMAX),IDSIGN(NWMAX),DRIFTN(MXNHTQ,NWMAX) PARAMETER (IHTNOI=2,ITRHIS=0,NCL=7,NBN=0) DIMENSION IKADD(NCL),BKADD(NCL) EQUIVALENCE (IKADD(1),BKADD(1)) * Minimum energy deposit (50MeV) for a hit (avoids hits with zero * energy loss and hence un-reconstructible radii) PARAMETER (FELMIN=5.0E-8) * Parameters for noise pseudo-track (6 mm, 100 MeV electron) PARAMETER (DIST=0.6,PMOM=-0.1,IPDG=11) *#********************************************************************** * Just in case ... IF (NWIRE.GT.NWMAX) NWIRE = NWMAX * Generate noise hits CALL FQGTRN(NWIRE,DRIFT,DRIFTN) DO 200 JWIRE=1,NWIRE DO 100 JHIT=1,MXNHTQ * Negative drift means no hit IF (DRIFTN(JHIT,JWIRE).LT.0.) GOTO 100 * Compute energy loss (totally arbitrary) CALL FDEDXL(DIST,0.,0.,0.,0.,0.,PMOM,IPDGEA(IPDG),FELOSS) IF (FELOSS.LE.FELMIN) GOTO 100 * Add row to FRQH bank IKADD(1) = ICLNUM + JWIRE - 1 BKADD(2) = FELOSS BKADD(3) = DRIFTN(JHIT,JWIRE) IKADD(4) = IHTNOI IKADD(5) = IDSIGN(JWIRE) IKADD(6) = ITRHIS IKADD(7) = ITRK KND = IADROW('FRQH',NBN,NCL,BKADD) 100 CONTINUE 200 CONTINUE RETURN END *CMZ : 20/01/99 15.05.03 by Girish D. Patel *-- Author : Stephen Burke 03/08/98 SUBROUTINE FQGTRN(NWIRE,DD,DDN) *#********************************************************************** *# * *# PURPOSE: Generate track-related noise for the new planars * *# * *# CALLED BY : FRQHEX * *# * *# INPUT : NWIRE - number of wires * *# DD - absolute drifts to each of the wires * *# * *# OUTPUT : DDN - drifts for noise hits * *# * *# AUTHOR : Steve Burke * *# * *# CHANGED BY: AT: * *# * *# REASON : * *# * *#********************************************************************** *KEEP,FQMAXN. * Maximum number of noise hits for new planars PARAMETER (MXNHTQ=5) *KEEP,FQTRNP. * Forward new planar track-related noise + shifted data parameters PARAMETER (MAXSGQ=5) LOGICAL LFDQX COMMON /FQTRNP/ QTRNP1(MXNHTQ),QTRNP2(MXNHTQ),QTRNDD(2,MAXSGQ) &, QPNEGD,LFDQX,SIGSHF,SGNSHF,SIGNOI,SGNNOI &, ANGNOI,PRBNOI,OFFNOI *KEND. * Maximum drift for noise hits - slightly unphysical PARAMETER (DMAX=3.2,NWMAX=8) DIMENSION DD(NWMAX),DDN(MXNHTQ,NWMAX) INTEGER FCBDD LOGICAL LFIRST *#********************************************************************** * Just in case ... IF (NWIRE.GT.NWMAX) NWIRE = NWMAX SHIFT = 0. NSHFT = 0 IF (LFDQX .AND. H1RN(NWIRE+2).LE.PRBNOI) THEN SHIFT = -SIGNOI*LOG(1. - MIN(H1RN(NWIRE),0.999999)) * Choose a drift sign IF (H1RN(NWIRE+1).LE.SGNNOI) SHIFT = -SHIFT CALL H1NORR(GAUSS) ANGLE = ANGNOI*GAUSS NSHFT = 1 ENDIF LFIRST = .TRUE. DO 200 JWIRE=1,NWIRE IF (LFIRST) THEN * QTRNP1 is the probability distribution for the first wire with hits ... NHIT = FCBDD(QTRNP1,MXNHTQ) IF (NHIT.GT.0) LFIRST = .FALSE. ELSE * ... and QTRNP2 for subsequent wires NHIT = FCBDD(QTRNP2,MXNHTQ) ENDIF DO 100 JHIT=1,MXNHTQ * Negative drift means no hit DDN(JHIT,JWIRE) = -1.0 IF (JHIT.GT.NHIT+NSHFT) THEN GOTO 100 ELSEIF (JHIT.GT.NSHFT) THEN * Choose a drift from the distribution in QTRNDD DN = FCVPWL(QTRNDD,MAXSGQ) IF (LFDQX) DN = DN + OFFNOI * Choose a drift sign IF (H1RN(JHIT).LE.QPNEGD) DN = -DN ELSE DN = SHIFT + ANGLE*FLOAT(JWIRE-1) ENDIF * Disallow unphysical drifts TEST = DD(JWIRE) + DN IF (TEST.LT.0. .OR. TEST.GT.DMAX) TEST = DD(JWIRE) - DN IF (TEST.GE.0. .AND. TEST.LE.DMAX) DDN(JHIT,JWIRE) = TEST 100 CONTINUE 200 CONTINUE RETURN END *CMZU: 03/08/98 13.56.29 by Stephen Burke *-- Author : Stephen Burke 03/08/98 SUBROUTINE FQQTSM(INFRQH,KDIGI,JFIRST,JLAST) *#********************************************************************** *# * *# PURPOSE: Simulate the new planar QT code, and fill the EVENT * *# response bank FRQE * *# * *# CALLED BY : FRQECR * *# * *# INPUT: INFRQH - index of FRQH bank * *# KDIGI - last digi number * *# JFIRST - pointer to first hit on wire * *# JLAST - pointer to last hit on wire * *# ISORT - pointer to work bank with sorted FRQH indices * *# (in /CFSORT/) * *# * *# OUTPUT : FRQE bank rows for this wire * *# IFRQX - array holding FRQX bank rows (in /H1WORK/) * *# * *#********************************************************************** *# * *# FORMAT OF FRQE BANK B16 Bank Number = 0 * *# ====== == ==== ==== * *# * *# Bank FRQE Forward Response new planar (Q) Event bank * *# Contains digitisations for new planar drift chambers* *# * *# word# type Content * *# 1 I NCOLS = 6 (= Number of attrributes) * *# 2 I NROWS (= Num of digis) * *# ---------------------------------------------------------------- * *# Col * *# 1 I Cell Number Attrib * *# 2 I Drift Attrib * *# 3 I Q Attrib * *# 4 I FLAG0 Attrib * *# 5 I FLAG1 Attrib * *# 6 I FLAG2 Attrib * *# ---------------------------------------------------------------- * *# * *# NOTES: * Digitisations consist of more than one hit in general * *# * Drift times refer to the first hit to arrive at the wire * *# and are given in 10 micron units * *# * Q is evaluated from energy deposition in the cell. * *# The default unit is eV. In FRQH the energy is * *# given in GeV. The conversion to eV is done in two * *# steps. GeV -> keV is 'hard-wired' in this routine and * *# an additional scale factor, QFAC, is then applied. * *# QFAC is taken from the FDQR bank and so can be * *# steered. Its default value is 1000. * *# * *# * IFLAG0 Bits 0-7 Peak height (non-linear) * *# Bits 8-15 Separation in FADC bins from * *# previous digi in cluster (measured * *# between the centres of the hits) * *# * IFLAG1 Bits 0-7 Re-linearised pedestal (set to 100) * *# Bits 8-15 Peak height of previous hit * *# * IFLAG2 Bits 0-6 Number of FADC bins from start of * *# cluster to end of this hit * *# Bits 7-10 Length of the leading edge in FADC * *# bins * *# Bits 11-14 Number of previous hits in this * *# cluster * *# Bit 15 Raw data kept flag (always zero) * *# * *#********************************************************************** *KEEP,FQDGPR. COMMON /FQDGPR/ TTSEP1,TTSEP2,MAXINT,ERRD0,ERRD1,ERRD2,ERRD3 &, DELCHG,DQUANT,FADBIN *KEEP,FQDGDG. COMMON /FQDGDG/ IDRFAC,QFAC,IQSAT *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. * Temp common for pointer arrays (extended for FRQX 29/7/98) PARAMETER (MAXHIT=3000) COMMON /H1WORK/ IFRRX(3,MAXHIT),IFRPX(3,MAXHIT),NFRRX,NFRPX &, IFRQX(3,MAXHIT),NFRQX COMMON /CFSORT/ ISORT PARAMETER (NBN=0,NCL=6) INTEGER IKADD(NCL) * Max of 64 hits per cluster (previous hit stops at 15) PARAMETER (MAXQT=64) DIMENSION JDIGI(0:MAXQT) * Minimum allowed Q (arbitrary) PARAMETER (QMIN=10.) * Nominal length of the leading edge is 3 bins PARAMETER (LLEDGE=3) * Q for a maximum count of 1024: 1024*12/2 = 6144 (highly arbitrary!) PARAMETER (QMAX=6144.) PARAMETER (GVTOKV=1000000.) *#********************************************************************** * Main loop over clusters - set cell number, first drift and previous drift ICELL = IW(IW(ISORT+JFIRST)) DCLUS = RW(IW(ISORT+JFIRST)+2) DLAST = -1. JCLUS = JFIRST 100 CONTINUE * Find hit cluster (from JDIGI(0) to JCLUS-1) and collect into digis NHIT = 0 JDIGI(0) = JCLUS 200 CONTINUE JCLUS = JCLUS + 1 * Have we fallen off the end of the wire? IF (JCLUS.LE.JLAST) THEN DPREV = DCLUS DCLUS = RW(IW(ISORT+JCLUS)+2) * The minimum cluster separation is taken as being the same as * the integration interval IF ((DCLUS-DPREV)*FADBIN.LE.MAXINT) THEN * The two-track separation should probably depend on Q; this is a bodge * Model is a linear rise from TTSEP1 to TTSEP2 PROB = (DCLUS - DPREV - TTSEP1)/(TTSEP2 - TTSEP1) IF (H1RN(JCLUS).LT.PROB) THEN * Start a new digi (else merged with the previous one) NHIT = NHIT + 1 * The QT has a maximum number of hits per cluster IF (NHIT.LE.MAXQT) JDIGI(NHIT) = JCLUS ENDIF GOTO 200 ENDIF ENDIF IF (NHIT.LT.MAXQT) THEN * We need a pointer to the next hit after this cluster JDIGI(NHIT+1) = JCLUS ELSE * We got more than the allowed number of hits NHIT = MAXQT - 1 ENDIF * Loop over digis in cluster - initialise last DOS sum and first drift IPLAST = 0 DSTART = RW(IW(ISORT+JDIGI(0))+2) DO 500 IHIT=0,NHIT * Increment digi counter KDIGI = KDIGI + 1 * Add up the charges in this digi, and fill the FRQX rows DRIFT = 0. QPLUS = 0. DO 300 JHIT=JDIGI(IHIT),JDIGI(IHIT+1)-1 CHARGE = GVTOKV*RW(IW(ISORT+JHIT)+1) DRIFT = DRIFT + CHARGE*RW(IW(ISORT+JHIT)+2) QPLUS = QPLUS + CHARGE * Type of hit + drift sign IHTTYP = IW(IW(ISORT+JHIT)+3) ISGN = IW(IW(ISORT+JHIT)+4) * Row number in FRQH JROW = (IW(ISORT+JHIT) - INFRQH - 2)/IW(INFRQH+1) + 1 IFRQX(1,JROW) = IBSET(IFRQX(1,JROW),IHTTYP+7) + ISGN IFRQX(2,JROW) = IW(IW(ISORT+JHIT)+6) IFRQX(3,JROW) = KDIGI 300 CONTINUE * Drift is charge-weighted average (rough guess) DRIFT = DRIFT/QPLUS * Now for the QT flags: DOS sum (peak height) (rather arbitrary) IPEAK = 255.*QPLUS*QFAC/QMAX IF (IPEAK.GT.255) IPEAK = 255 * Distance to previous hit - set to zero for first hit (?) IF (DLAST.LT.0.) THEN ISEPL = 0 ELSE ISEPL = (DRIFT - DLAST)*FADBIN + 0.499 IF (ISEPL.GT.255) ISEPL = 255 ENDIF DLAST = DRIFT * Relinearised pedestal - arbitrary IPED = 100 * Number of bins from start of cluster to end of leading edge of this hit DSTOP = RW(IW(ISORT+JDIGI(IHIT+1)-1)+2) LHIT = LLEDGE + ((DSTOP - DSTART)*FADBIN + 0.499) IF (LHIT.GT.127) LHIT = 127 * Number of adjacent bins above threshold * Set to 2 + number of hits in digi (a bit silly, but what else?) * Should just be length of leading edge? NADJ = LLEDGE + JDIGI(IHIT+1) - JDIGI(IHIT) - 1 IF (NADJ.GT.15) LHIT = 15 * Hit counter sticks at 15 IIHIT = MIN(IHIT,15) * Pack pulse shape info IFLAG0 = 0 IFLAG1 = 0 IFLAG2 = 0 CALL MVBITS(IPEAK,0,7,IFLAG0,0) CALL MVBITS(ISEPL,0,7,IFLAG0,8) CALL MVBITS(IPED,0,7,IFLAG1,0) CALL MVBITS(IPLAST,0,7,IFLAG1,8) CALL MVBITS(LHIT,0,6,IFLAG2,0) CALL MVBITS(NADJ,0,3,IFLAG2,7) CALL MVBITS(IIHIT,0,3,IFLAG2,11) * No raw data kept! * CALL SBIT0(IFLAG2,16) * Remember last peak height IPLAST = IPEAK * Compute smeared drift (first hit) CALL FDQSME(DRIFT,IFLAG0,IFLAG1,IFLAG2,DSMEA) * Compute smeared charge CALL FQQSME(QPLUS,IFLAG0,IFLAG1,IFLAG2,QPSME) IF (QPSME.LT.QMIN) THEN * Abandon digi KDIGI = KDIGI - 1 DO 400 JHIT=JDIGI(IHIT),JDIGI(IHIT+1)-1 JROW = (IW(ISORT+JHIT) - INFRQH - 2)/IW(INFRQH+1) + 1 IFRQX(3,JROW) = 0 400 CONTINUE ELSE * Prepare input array of FRQE bank (NB T0 = 1000) IKADD(1) = ICELL IKADD(2) = ABS(1000. + DSMEA*FADBIN*50.0) IKADD(3) = MIN(IFIX(QPSME),IQSAT) IKADD(4) = IFLAG0 IKADD(5) = IFLAG1 IKADD(6) = IFLAG2 * Extend FRQE bank INFRQE = IADROW('FRQE',NBN,NCL,IKADD) ENDIF 500 CONTINUE * Allow for hits with no digi! DO 600 JHIT=JDIGI(NHIT+1),JCLUS-1 IHTTYP = IW(IW(ISORT+JHIT)+3) ISGN = IW(IW(ISORT+JHIT)+4) JROW = (IW(ISORT+JHIT) - INFRQH - 2)/IW(INFRQH+1) + 1 IFRQX(1,JROW) = IBSET(IFRQX(1,JROW),IHTTYP+7) + ISGN IFRQX(2,JROW) = IW(IW(ISORT+JHIT)+6) IFRQX(3,JROW) = 0 600 CONTINUE * Go on to next cluster, if any IF (JCLUS.LE.JLAST) GOTO 100 RETURN END *CMZU: 03/08/98 13.56.29 by Stephen Burke *-- Author : Stephen Burke 03/08/98 SUBROUTINE FQHMC(MASK) *#********************************************************************** *# * *# PURPOSE: Choose which hits are present in a "missing" new planar * *# cluster. * *# * *# CALLED BY : FRQHCC * *# * *# CALLS : FCBDD * *# * *# INPUT : Hit probabilities from FQDGEF * *# * *# OUTPUT : Hit mask (one bit per wire) * *# * *# AUTHOR : Steve Burke * *# * *#********************************************************************** *# * *# CHANGED BY: * *# * *# REASON : * *# * *#********************************************************************** INTEGER FCBDD *KEEP,FQDGEF. COMMON /FQDGEF/ EFFQ(0:7,0:2),EFFQ8(0:2),PHMC(6),PWMC1(5) &, PWMC2(5),PWMC3(5),PWMC4(5),PWMC5(5) *KEND. *#********************************************************************** * How many hits are there? NHIT = FCBDD(PHMC,6) IF (NHIT.LE.0) THEN * Zero hits MASK = 0 ELSEIF (NHIT.EQ.1) THEN * One hit MASK = 0 CALL SBIT1(MASK,FCBDD(PWMC1,5)+1) ELSEIF (NHIT.EQ.2) THEN * Two hits MASK = 0 IWR1 = FCBDD(PWMC1,5) 10 CONTINUE IWR2 = FCBDD(PWMC2,5) IF (IWR2.EQ.IWR1) GOTO 10 CALL SBIT1(MASK,IWR1+1) CALL SBIT1(MASK,IWR2+1) ELSEIF (NHIT.EQ.3) THEN * Three hits MASK = 0 IWR1 = FCBDD(PWMC1,5) 20 CONTINUE IWR2 = FCBDD(PWMC2,5) IF (IWR2.EQ.IWR1) GOTO 20 30 CONTINUE IWR3 = FCBDD(PWMC3,5) IF (IWR3.EQ.IWR1 .OR. IWR3.EQ.IWR2) GOTO 30 CALL SBIT1(MASK,IWR1+1) CALL SBIT1(MASK,IWR2+1) CALL SBIT1(MASK,IWR3+1) ELSEIF (NHIT.EQ.4) THEN * Four hits MASK = 63 IWR5 = FCBDD(PWMC5,5) 40 CONTINUE IWR4 = FCBDD(PWMC4,5) IF (IWR4.EQ.IWR5) GOTO 40 CALL SBIT0(MASK,IWR5+1) CALL SBIT0(MASK,IWR4+1) ELSEIF (NHIT.EQ.5) THEN * Five hits MASK = 63 CALL SBIT0(MASK,FCBDD(PWMC5,5)+1) ELSE * Six hits MASK = 63 ENDIF RETURN END *CMZ : 10/11/98 14.49.49 by Girish D. Patel *CMZU: 3.07/18 31/01/98 18.13.53 by V.Solochenko *CMZ : 3.07/00 20/02/97 15.16.06 by Hanna Mahlke-Krueger *CMZU: 3.06/37 27/02/96 16.26.57 by Olaf Duenger *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 * * Changed by: O.Duenger 27.02.96 Reason: call JHIT for Neutron Counter* * Changed by: H. Mahlke-Krueger 01.08.96 * * Reason: call JHIT for interior of Roman Pots * * Changed by: V.Solochenko 31.01.98 Reason: call JHIT for FTS * ************************************************************************ *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 GOTO(21,22,23),IDTYPE-200 WRITE(6,900)IDTYPE STOP 21 CALL FRHIT RETURN 22 CALL FPHIT RETURN 23 CALL FQHIT 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.1102 + .OR.IDTYPE.EQ.1005.OR.IDTYPE.EQ.1009 + .OR.IDTYPE.EQ.502.OR.IDTYPE.EQ.1221) THEN * proton tagger or FToF (P.Biddulph) * or Roman pots (H. Mahlke-Krueger) * or BToF for 1995 (V.Shekelyan) * or neutron counter (O.Duenger) * or FTS (V.Solochenko) 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 CALL LE1HIT(VECT(7),-VECT(1),VECT(2),IFOK) RETURN 900 FORMAT(' ***GEDEPO*** illegal IDTYPE:',I5) END *CMZ : 17/11/98 13.07.59 by Girish D. Patel *CMZU: 2.14/02 10/08/93 20.45.43 by Vladimir Shekelyan *CMZU: 2.10/13 13/12/92 20.40.54 by Alexander Fedotov *CMZU: 2.08/04 16/09/92 15.23.26 by Stephan Egli *CMZ : 2.07/00 26/03/92 08.10.40 by Stephan Egli *CMZU: 2.05/02 11/12/91 18.18.49 by Stephan Egli *CMZU: 2.05/00 01/11/91 16.31.18 by Stephan Egli *CMZU: 2.03/00 26/06/91 18.56.01 by Stephan Egli *CMZ : 2.00/00 10/02/91 09.08.52 by Stephan Egli *CMZ : 1.08/02 06/02/91 17.24.01 by Stephan Egli *-- Author : SUBROUTINE GUGEOM *#********************************************************************** *# * *# SUBROUTINE GUGEOM * *# * *# PURPOSE: Define H1 detector geometry and constants * *# * *# CALLED BY : GUINIT * *# * *# AUTHOR : Girish D. Patel * *# * *# CHANGED BY: GIRISH D. PATEL AT: 5/8/89 * *# REASON : CALL TO UDFPAR INSERTED * *# * *# CHANGED BY: S.EGLI AT: 14/12/89 * *# REASON : ORDER THE BEAM PIPE VOLUMES WITH A GSORD CALL * *# * *# CHANGED BY: S.EGLI AT: 09/03/90 * *# REASON : draw stuff removed * *# CHANGED BY: A.Fedotov AT: 01/12/92 (14/07/92) * *# REASON : Geometry definition from OGDJ added * *# CHANGED BY: A.Fedotov AT: 13/12/92 (07/09/92) * *# REASON : Call of JGEOM in muon branch added * * changed by V.Shekelyan at 28.07.93 * * reason: For upgrade 1995 (LCONFG=2) use OGVM,OGVB instead of OGDM,OGDB *#********************************************************************** * *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,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,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,H1OSGO. COMMON /H1OSGO/ LCONFG,IGEAND(13),RGEANC(16),IGEANP(12) *KEND. * *KEEP,HROTM. PARAMETER ( LHROTM = 17 ) COMMON /HROTM/ NHROT(0:LHROTM) *KEND. * * DEFINE H1 GENERAL MATERIAL CONSTANTS FROM OGMA BOS BANK * CALL UGTBNK( 'OGMA', INDB ) IF( INDB.LE.0 ) THEN WRITE(6,*) ' ** SUBR. GUGEOM ** OGMA BANK NOT FOUND ==> STOP ' STOP ELSE CALL UDFMAT( INDB ) ENDIF * * DEFINE H1 GENERAL TRACKING MEDIA PARAMETERS FROM OGME BOS BANK * CALL UGTBNK( 'OGME', INDB ) IF( INDB.LE.0 ) THEN WRITE(6,*) ' ** SUBR. GUGEOM ** OGME BANK NOT FOUND ==> STOP ' STOP ELSE CALL UDFMED( INDB ) ENDIF * * DEFINE H1 SPECIAL TRACKING MEDIA PARAMETERS FROM OGTP BOS BANK * * CALL UGTBNK( 'OGTP', INDB ) * IF( INDB.LE.0 ) THEN * WRITE(6,*) ' ** SUBR. GUGEOM ** OGTP BANK NOT FOUND ==> ', * + 'Default values will be used' * ELSE * CALL UDFPAR( INDB ) * ENDIF * * * DEFINE GEANT ROTATION MATRICES FROM OGRO BOS BANK * CALL UGTBNK( 'OGRO', INDB ) IF( INDB.LE.0 ) THEN WRITE(6,*) ' ** SUBR. GUGEOM ** OGRO BANK NOT FOUND ==> STOP ' STOP ELSE CALL UDFROT( INDB, NHROT, LHROTM ) ENDIF * * DEFINE GEOMETRY OF THE SET UP FROM OGDM BOS BANK * for upgrade 1995 OGVM bank is used * IF(LCONFG.LE.1)THEN CALL UGTBNK( 'OGDM' , INDB ) ELSE CALL UGTBNK( 'OGVM' , INDB ) ENDIF IF( INDB.LE.0 ) THEN STOP ELSE CALL UDFVOL( INDB, NHROT, LHROTM ) ENDIF * * DEFINE GEOMETRY OF BEAM PIPE SET UP FROM OGDB BOS BANK * for upgrade 1995 OGVB bank is used * IF(LCONFG.LE.1)THEN CALL UGTBNK( 'OGDB' , INDB ) ELSE CALL UGTBNK( 'OGVB' , INDB ) ENDIF IF( INDB.LE.0 ) THEN WRITE(6,*)' ** SUBR.GUGEOM ** OGDB(OGVB) BANK NOT FOUND => STOP' STOP ELSE CALL UDFVOL( INDB, NHROT, LHROTM ) ENDIF * * ORDER THE VOLUMES OF THE BEAM * CALL GSORD('BEAM',3) * * DEFINE GEOMETRY OF FORW. BEAMLINE (IN PLUG,FWFE) FROM OGDJ BOS BANK * c CALL UGTBNK( 'OGDJ' , INDB ) c IF( INDB.LE.0 ) THEN c WRITE(6,*) ' ** SUBR. GUGEOM ** OGDJ BANK NOT FOUND ==> STOP ' c STOP c ELSE c CALL UDFVOL( INDB, NHROT, LHROTM ) c ENDIF * * DEFINE GEOMETRY OF COIL SET UP FROM OGDC BOS BANK * CALL UGTBNK( 'OGDC' , INDB ) IF( INDB.LE.0 ) THEN WRITE(6,*) ' ** SUBR. GUGEOM ** OGDC BANK NOT FOUND ==> STOP ' STOP ELSE IF(ISGRAN(3).NE.0) CALL UDFVOL( INDB, NHROT, LHROTM ) ENDIF * * Central Tracking * IF (ISGRAN(1).NE.0)THEN WRITE(6,900)'CENT',ISGRAN(1) CALL CGEOM ENDIF * * Forward Tracking * IF (ISGRAN(2).NE.0)THEN WRITE(6,900)'FWDT',ISGRAN(2) CALL FGEOM ENDIF * * Liquid Argon Calorimeter * IF (ISGRAN(3).NE.0)THEN WRITE(6,900)'CALO',ISGRAN(3) CALL AGEOM ENDIF * * Plug Calorimeter * IF (ISGRAN(4).NE.0)THEN WRITE(6,900)'PLUG',ISGRAN(4) CALL PGEOM ENDIF * * Backward Electromagnetic Calorimeter * IF (ISGRAN(5).NE.0)THEN IF(LCONFG.LE.1) THEN WRITE(6,900)'BEMC',ISGRAN(5) CALL BGEOM ELSE *.........upgrade 1995 (SPACal,BDC) WRITE(6,900)'SPAC',ISGRAN(5) CALL SGEOM ENDIF ENDIF * * Instrumented Iron * IF (ISGRAN(6).NE.0)THEN WRITE(6,900)'IRON',ISGRAN(6) CALL IGEOM ENDIF * * Forward Muons * and the rest of Forward beam line with p tagger (z = 1177-2442) * IF (ISGRAN(7).NE.0)THEN WRITE(6,900)'MUON',ISGRAN(7) CALL MGEOM CALL JGEOM ENDIF * * Luminosity (proton beam line to -50 meters) * IF (ISGRAN(8).NE.0)THEN WRITE(6,900)'LUMI',ISGRAN(8) CALL LGEOM ENDIF * * Optimisation of geometry definition * * * Close geometry banks. Mandatory system routine. * CALL GGCLOS * CALL BDROP(IW,'OGMAOGMEOGTPOGROOGDMOGDBOGDJOGDC') * 900 FORMAT(' Creating geometry for subdetector ',A4, + ' with granularity flag ',I1) RETURN END *CMZU: 03/08/98 14.03.51 by Stephen Burke *CMZ : 4.06/28 06/12/96 13.44.27 by Vladimir Shekelyan *CMZU: 4.05/02 26/01/95 15.18.17 by Martine Charlet *CMZ : 4.04/05 10/11/94 20.59.30 by Vladimir Shekelyan *CMZU: 4.04/04 01/11/94 13.40.07 by Benno List *CMZU: 4.02/02 23/03/94 12.58.49 by Stephan Egli *CMZU: 4.00/08 08/12/93 16.31.48 by Stephan Egli *CMZU: 4.00/05 22/11/93 14.12.19 by Stephan Egli *CMZU: 3.04/06 13/08/93 09.34.07 by Vladimir Shekelyan *CMZ : 3.01/06 16/09/92 15.57.31 by Stephan Egli *CMZ : 2.09/01 30/03/92 15.11.43 by Michael Colombo *CMZ : 2.08/01 26/03/92 12.05.10 by Stephan Egli *CMZ : 2.07/00 17/12/91 11.29.18 by Stephan Egli *CMZ : 2.03/05 09/09/91 19.19.48 by Stephan Egli *CMZU: 2.03/00 13/06/91 14.04.01 by Michael Kuhlen *CMZU: 2.02/00 07/06/91 14.17.54 by M. Erdmann *CMZ : 2.00/00 10/02/91 09.25.00 by Stephan Egli *CMZ : 1.08/02 05/02/91 11.03.13 by Stephan Egli *-- Author : SUBROUTINE H1PRNT(NAME,NR) ********************************************************************* * * PRINTOUT OF H1 SIMULATION BANK * ============================== * * BANKS INCLUDED UP TO NOW ARE: * * ARHT, AEHT, ARDT, AEDT, ARWT, AEWT, AS , ARCE, AECE, ARCX * * BRMT, BRCT, BRTT, BS , BRME, BRCE, BRTE, BRCX * * CRJT, CRJF, CRYT, CRZT, CRMT, CS , CRJE, CRME, CRYE, CRZE, * CRYX, CRZX * * FRPT, FRPF, FRRT, FRRF, FRMT, FRTT, FS , FRME, FRPE, FRRE, * FRPN, FRRN, FRPH, FRRH, FRPX, FRRX, * FRQT, FRQF, FRQE, FRQN, FRQH, FRQX * * GTR , GVX , GEVC * * IRHT, IS , IL , IRSE, IRTE, IRWE * * JSPT, JSRP, JSFT, JRHT, JRDT, JRDE * * LRET, LRPT, LRVT, LS , LREE, LRPE * * MS , ML * * PRDT, PS , PRDE, PRDX * * SHD , STR , SVX * * MODS, MODI, MODO * * ExEG, ExSG, ExNG, ExFR, ExFX (x=A,B,P,I,W) * * RCLX, ECLX, ECLC * * SRCT, SRCE, SRCX * * 04.04.1990 RALF GERHARDS * * CHANGED 05.04.1990 RG ADD BANKS GHD AND GKI * CHANGED 12.04.1990 RG ADD BANK LRTE * CHANGED 26.04.1990 RG ADD BANKS TRIP, TRAK, CACE, CCEG, * MUON, LTL1, TTSE * CHANGED 02.05.1990 RG ADD BANK HEAD * CALL P.SCHLEPER'S MYPRNT IF BANK * IS NOT KNOWN TO CURRENT BANK LIST * CHANGED 01.07.1990 SE FORWARD MUON BANKS ADDED * MRPE, MRTE, MRPX, MRTX * MRPN, MRPT, MRTN, MRTT * CHANGED 05.07.1990 RG BUG FIXED IN FUNCTION PDGNAM, GOT * SOMETIMES WRONG PARTICLE NAMES * FOR L.AR. BANKS SCALE AND GAIN * FACTORS TAKEN INTO ACCOUNT * CHANGED 05.09.1990 SE MODUL STEERING BANKS MODS/I/O ADDED * CHANGED 16.05.1991 MK perf. energ. (ARHT,PRDT,BRCT,ARWT) * CHANGED 07.06.1991 ME ADD PRINT GEVC BANK * CHANGED 11.06.1991 MK protection against old bank formats * CHANGED 13.06.1991 MK print more bits in ITRHIS * CHANGED 20.08.1991 MK add calibr. energy and cluster banks * CHANGED 12.12.1991 PL new format GTR, GKI, GHD * CHANGED 28.02.1992 PL new printout GTR and GHD * CHANGED 30.03.1992 MCo both parents in GTR * CHANGED 12.08.1993 VSh upgrade 1995: SRCT (Spacal) * CHANGED 24.10.1994 VSh add SRCE,SRCX banks * BL print GHD bank with >1 row, * add JSPT,JSRP,JRHT,JRDT,JRDE banks * CHANGED 1.11.1994 BL add JSFT bank * CHANGED 29.12.1995 GG new printout GKI * CHANGED 29.07.1998 SB add FxQx banks for new planar chambers ********************************************************************* *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 (ISCALA=50,ISCALD=500,NBMAX=124) CHARACTER*4 NAME, BKNAME(NBMAX), CHAINT CHARACTER*10 PTYP(8), PDGNAM*13, VTYP(5) INTEGER BKFORM(NBMAX), ID1(10) COMMON /COTEMP/ID, ID2, ID1 INTEGER IBIT(14) C C.... OUTPUT UNIT C DATA LUN/6/ C DATA BKNAME/'SHD ','STR ','SVX ','GTR ','GVX ','GKI ','GHD ', * 'HEAD','GEVC', * 'CRJT','CRJF','CRYT','CRZT','CRMT','CS ', * 'CRJE','CRME','CRYE','CRZE','CRYX','CRZX','CRJX','CRMX', * 'FRPT','FRPF','FRRT','FRRF','FRMT','FRTT','FS ', * 'FRME','FRPE','FRRE','FRPN','FRRN','FRPH','FRRH', * 'FRPX','FRRX','FRMX', * 'FRQT','FRQF','FRQE','FRQN','FRQH','FRQX', * 'ARHT','AEHT','ARDT','AEDT','ARWT','AEWT','AS ', * 'AECE','AEDE','ARCE','ARDE','ARCX','ATES','ATBE', * 'BRMT','BRCT','BRTT','BS ', * 'BRME','BRCE','BRTE','BRMX','BRCX','BRTX', * 'IRHT','IS ','IL ', * 'IRSE','IRTE','IRWE','IRSX','IRTX','IRWX', * 'JSPT','JSRP','JSFT','JRHT','JRDT','JRDE', * 'LRET','LRPT','LRVT','LS ', * 'LREE','LRPE','LRTE','LREX','LRPX','LRVX', * 'MS ','ML ','MRPE','MRTE','MRPX','MRTX', * 'MRPN','MRPT','MRTN','MRTT', * 'PRDT','PS ','PRDE','PRDX', * 'TRIP','TRAK','CACE','CCEG','MUON', * 'TTSE','LTL1','TEL1', * 'MODS','MODI','MODO','MODC', * 'SRCT','SRCE','SRCX'/ DATA BKFORM/ 1 , 2 , 3 , 4 , 5 ,100 ,100 , * 100 ,100 , * 6 , 7 , 8 , 8 , 9 , 19 , * -23 ,-24 ,-25 ,-23 ,-32 ,-32 ,-32 ,-32 , * 10 , 11 , 6 , 7 , 9 , 10 , 19 , * -24 ,-25 ,-25 , 26 , 26 , 27 , 28 , * -29 ,-29 ,-99 , * 10 , 11 ,-25 , 26 , 27 ,-29 , * -12 ,-12 ,-12 ,-12 ,-12 ,-12 , 19 , * -20 ,-99 ,-20 ,-99 ,-32 ,-43 , -45 , * 9 ,-14 , 15 , 19 , * -24 ,-21 ,-22 ,-99 ,-32 ,-99 , * -16 , 19 , 19 , * -30 ,-31 ,-30 ,-99 ,-99 ,-99 , * 19 , 46 , 46 ,-47 ,-47 ,-48 , * -17 ,-17 ,-18 , 19 , * -21 ,-21 ,-34 ,-99 ,-99 ,-99 , * 19 , 19 ,-25 ,-25 ,-29 ,-29 , * 26 , 10 , 26 , 10 , * -13 , 19 ,-21 ,-32 , * 35 , 35 , 36 , 36 , 37 , * 38 ,-34 , 44 , * 39 , 40 , 40 ,41 , * -42 ,-20 ,-32/ C DATA PTYP /' undecayed',' reserved','decay/frag',' document.', * ' reserved',' undefined','beam part.','rad. gamma'/ C DATA VTYP /' primary',' decay',' bremsstr.', * 'conversion',' else'/ C C.... STATEMENT FUNCTIONS C C.... INDEX OF ELEMENT BEFORE ROW NUMBER IROW INDR(IND,IROW)=IND+2+IW(IND+1)*(IROW-1) C.... INDEX OF L-TH ELEMENT OF ROW NUMBER IROW INDCR(IND,L,IROW)=INDR(IND,IROW)+L C.... L-TH INTEGER ELEMENT OF THE IROW-TH ROW IN BANK WITH INDEX IND IBTAB(IND,L,IROW)=IW(INDCR(IND,L,IROW)) C.... L-TH REAL ELEMENT OF THE IROW-TH ROW IN BANK WITH INDEX IND RBTAB(IND,L,IROW)=RW(INDCR(IND,L,IROW)) C C.... STATEMENT FUNCTIONS FOR IRON HIT BANK DECODING C FX(I)=FLOAT(I)/20.-600. FY(I)=FLOAT(I)/20.-600. FZ(I)=FLOAT(I)/20.-500. C C.... STATEMENT FUNCTIONS FOR LUMI HIT BANK DECODING C FL(I)=FLOAT(I)*0.001-10. C C.... INITIALIZE LUND COMMONS WITH PARTICLE NAMES C C.... END OF INITIALISATION C C first deal with calibrated energy banks etc. IF( NAME.EQ.'EAEG' .OR. NAME.EQ.'EASG' .OR. NAME.EQ.'EANG' .OR. & NAME.EQ.'EAFR' .OR. NAME.EQ.'EAFX' .OR. & NAME.EQ.'EBEG' .OR. NAME.EQ.'EBSG' .OR. NAME.EQ.'EBNG' .OR. & NAME.EQ.'EBFR' .OR. NAME.EQ.'EBFX' .OR. & NAME.EQ.'EPEG' .OR. NAME.EQ.'EPSG' .OR. NAME.EQ.'EPNG' .OR. & NAME.EQ.'EPFR' .OR. NAME.EQ.'EPFX' .OR. & NAME.EQ.'EIEG' .OR. NAME.EQ.'EISG' .OR. NAME.EQ.'EING' .OR. & NAME.EQ.'EIFR' .OR. NAME.EQ.'EIFX' .OR. & NAME.EQ.'EWEG' .OR. NAME.EQ.'EWSG' .OR. NAME.EQ.'EWNG' .OR. & NAME.EQ.'EWFR' .OR. NAME.EQ.'EWFX') THEN CALL PREXEG(NAME,NR) RETURN ELSEIF( NAME.EQ.'RCLX' .OR. NAME.EQ.'ECLX' ) THEN CALL PRRCLX(NAME,NR) RETURN ELSEIF( NAME.EQ.'ECLC' ) THEN CALL PRECLC(NAME,NR) RETURN ENDIF C.... SEARCH FOR REQUIRED BANK C IBKFMT = 0 DO 10 I = 1, NBMAX IF(NAME.NE.BKNAME(I)) GOTO 10 IBKFMT = BKFORM(I) GOTO 20 10 CONTINUE GOTO 9010 C 20 CONTINUE C C.... FETCH REQUIRED BANK C.... COPY TO WORK BANK IF FORMAT 'B16' C IND = NLINK(NAME,NR) IF(IND.EQ.0) GOTO 9000 C IF(IBKFMT.LT.0) THEN ID=0 CALL BKTOW(IW,NAME,NR,IW,ID,*9000) NROW = IW(ID+2) NCOL = IW(ID+1) NLEN = IW(ID) WRITE(LUN,1300) NAME, NR, NLEN, NCOL, NROW ELSE C C....... SPECIAL FORMATS (WITHOUT MINIHEADER) C IF(IBKFMT.GE.100) THEN WRITE(LUN,1900) NAME, NR GOTO 500 ELSE NCOL = IW(IND+1) NROW = IW(IND+2) NLEN = IW(IND) WRITE(LUN,1300) NAME, NR, NLEN, NCOL, NROW END IF END IF C C.... CHECK ON BANK LENGTH C NTEST=NCOL*NROW+2 IF(NTEST.NE.NLEN .AND. NTEST.NE.NLEN-1) THEN WRITE(LUN,1500) WRITE(LUN,1400) END IF C C.... PRINTOUT C GOTO (101,102,103,104,105,106,107,108,109,110,111,112,113, * 114,115,116,117,118,119,120,121,122,123,124,125,126, * 127,128,129,130,131,132,133,134,135,136,137,138,139, * 140,141,142,143,144,145,146,147,148) * IABS(IBKFMT) C WRITE(LUN,1200) NAME WRITE(LUN,1400) RETURN C C.... 'SHD ' C 101 WRITE(LUN,1400) WRITE(LUN,10101) (CHAINT(IBTAB(IND,1,I)), * RBTAB(IND,2,I), I=1,NROW) 10101 FORMAT(/,((7X,'MODULE NAME ',A4,' VERSION NUMBER ', * F6.4,/)),1H+) GOTO 200 C C.... 'STR ' C 102 WRITE(LUN,1400) WRITE(LUN,10201) WRITE(LUN,10202) (I,RBTAB(IND,1,I), RBTAB(IND,2,I), * RBTAB(IND,3,I), RBTAB(IND,4,I), * PDGNAM(IBTAB(IND,5,I)), IDUAL(IBTAB(IND,6,I),7), * IBTAB(IND,7,I), IBTAB(IND,8,I), IBTAB(IND,9,I), * I=1, NROW) 10201 FORMAT(9X,' MOMENTUM (GEV) ENERGY ', * ' PARTICLE TYPE ITRHIS LINK TO LINK TO ', * ' LINK TO ',/, * 9X,' PX PY PZ (GEV) ', * ' LMIBPAFC PARENT,STR PARENT,GTR ', * ' VERTEX,SVX',/,1X,130('-'),/) 10202 FORMAT((3X,I3,2X,4(1X,F10.3),2X,A13,2X,I8,3(I10,2X))) GOTO 200 C C.... 'SVX ' C 103 WRITE(LUN,1400) WRITE(LUN,10301) WRITE(LUN,10302) (I,RBTAB(IND,1,I), RBTAB(IND,2,I), * RBTAB(IND,3,I), * VTYP(IBTAB(IND,4,I)), (1.0E+09*RBTAB(IND,5,I)), * IDUAL(IBTAB(IND,6,I),7), IBTAB(IND,7,I), I=1 ,NROW) 10301 FORMAT(9X,' VERTEX COORDINATES (CM) VERTEX', * ' TIME OF ITRHIS LINK TO ',/, * 9X,' X Y Z TYPE ', * ' FLIGHT (NS) LMIBPAFC PARENT,STR',/, * 1X,130('-'),/) 10302 FORMAT((3X,I3,2X,3(1X,F10.3),1X,A,1X,F10.3,5X,I8,5X,I6)) GOTO 200 C C.... 'GTR ' C 104 WRITE(LUN,1400) WRITE(LUN,10401) DO 10410 I = 1, NROW IPATYP = ABS( 1+IBTAB(IND,8,I) ) IF( IPATYP-1 .GT. 3 .AND. IPATYP .LE. 10 ) IPATYP = 5 IF( IPATYP-1 .GT. 10 .AND. IPATYP .LE. 200 ) IPATYP = 6 IF( IPATYP-1 .EQ. 201 ) IPATYP = 7 IF( IPATYP-1 .EQ. 202 ) IPATYP = 8 IMOTH1 = IBTAB(IND,9,I)-(IBTAB(IND,9,I)/10000)*10000 IMOTH2 = IBTAB(IND,9,I)/10000 WRITE(LUN,10402) I, PDGNAM(IBTAB(IND,7,I)), PTYP(IPATYP), * IMOTH1, IMOTH2, RBTAB(IND,1,I), RBTAB(IND,2,I), * RBTAB(IND,3,I), RBTAB(IND,4,I), RBTAB(IND,5,I), * RBTAB(IND,6,I), IBTAB(IND,10,I) 10410 CONTINUE 10401 FORMAT(2X,' PARTICLE PARTICLE PARENT ', * ' MOMENTUM (GEV) ENERGY ', * ' MASS CHARGE LINK TO ',/, * 2X,' TYPE FLAG PARTICLE ', * ' PX PY PZ (GEV) ', * ' (GEV) VERTEX,GVX ',/,1X,130('-'),/) 10402 FORMAT((1X, I3, 2X, A12, A10, 2(1X,I3), 4(1X,F9.3), * 2(1X,F10.4), 2X, I5)) GOTO 200 C C.... 'GVX ' C 105 WRITE(LUN,1400) WRITE(LUN,10501) WRITE(LUN,10502) (I,RBTAB(IND,1,I), RBTAB(IND,2,I), * RBTAB(IND,3,I), VTYP(IBTAB(IND,4,I)), * (1.0E+09*RBTAB(IND, 5,I)), I=1, NROW) 10501 FORMAT(9X,' VERTEX COORDINATES (CM) VERTEX', * ' TIME OF ',/, * 9X,' X Y Z TYPE', * ' FLIGHT (NS)',/,1X,130('-'),/) 10502 FORMAT((3X,I3,2X,3(1X,F10.3),1X,A10,1X,F10.3)) GOTO 200 C C.... 'CRJT', 'FRRT' C 106 WRITE(LUN,1400) WRITE(LUN,10601) WRITE(LUN,10602) (I,IBTAB(IND,1,I), RBTAB(IND,2,I), * RBTAB(IND,3,I), * RBTAB(IND,4,I), RBTAB(IND,5,I), RBTAB(IND,6,I), * RBTAB(IND,7,I), RBTAB(IND,8,I), IDUAL(IBTAB(IND,9,I),7), * IBTAB(IND,10,I), I=1, NROW) 10601 FORMAT(1H0,8X,' CHANNEL ENTRY POINT (CM) ', * ' EXIT POINT (CM) DRIFT ', * ' ITRHIS TRACK ',/, * 9X,' NUMBER X Y Z ', * ' X Y Z LENGTH (CM)', * ' LMIBPAFC NUMBER,STR',/,1X,130('-'),/) 10602 FORMAT((2X,I4,3X,I7,3X,7(1X,F10.3),4X,I8,2X,I8)) GOTO 200 C C.... 'CRJF', 'FRRF' C 107 WRITE(LUN,1400) WRITE(LUN,10701) WRITE(LUN,10702) (I,RBTAB(IND,1,I), RBTAB(IND,2,I), * RBTAB(IND,3,I), * RBTAB(IND,4,I), RBTAB(IND,5,I), RBTAB(IND,6,I), * RBTAB(IND,7,I), RBTAB(IND,8,I), RBTAB(IND,9,I), * RBTAB(IND,10,I), RBTAB(IND,11,I), RBTAB(IND,12,I), * RBTAB(IND,13,I), RBTAB(IND,14,I), * PDGNAM(IBTAB(IND,15,I)), * IDUAL(IBTAB(IND,16,I),7), IBTAB(IND,17,I), I=1, NROW) 10701 FORMAT(7X,' ENTRY POINT (CM) ', * ' ENTRY MOMENTUM (GEV) ', * ' EXIT POINT (CM) ', * ' EXIT MOMENTUM (GEV) ', * ' PARTICLE ITRHIS TRACK',/, * 7X,' X Y Z ', * ' PX/P PY/P PZ/P P ', * ' X Y Z ', * ' PX/P PY/P PZ/P P ', * ' type LMIBPAFC NO.',/,1X,130('-'),/) 10702 FORMAT((2X,I4,14(F7.2),1X,A13,I8,I5)) GOTO 200 C C.... 'CRYT', 'CRZT' C 108 WRITE(LUN,1400) WRITE(LUN,10801) WRITE(LUN,10802) (I,RBTAB(IND,1,I), RBTAB(IND,2,I), * RBTAB(IND,3,I), * RBTAB(IND,4,I), RBTAB(IND,5,I), RBTAB(IND,6,I), * IDUAL(IBTAB(IND,7,I),7), IBTAB(IND,8,I), I=1, NROW) 10801 FORMAT(9X,' ENTRY POINT (CM) ', * ' EXIT POINT (CM) ', * ' ITRHIS TRACK ',/, * 9X,' X Y Z ', * ' X Y Z ', * ' LMIBPAFC NUMBER,STR',/,1X,130('-'),/) 10802 FORMAT((2X,I4,2X,6(1X,F10.3),2X,I8,6X,I5)) GOTO 200 C C.... 'CRMT', 'FRMT', 'BRMT' C 109 WRITE(LUN,1400) WRITE(LUN,10901) WRITE(LUN,10902) (I,IBTAB(IND,1,I), RBTAB(IND,2,I), * RBTAB(IND,3,I), * RBTAB(IND,4,I), RBTAB(IND,5,I), RBTAB(IND,6,I), * RBTAB(IND,7,I), IDUAL(IBTAB(IND,8,I),7), IBTAB(IND,9,I), * I=1, NROW) 10901 FORMAT(9X,' CHAMBER ENTRY POINT (CM) ', * ' EXIT POINT (CM) ', * ' ITRHIS TRACK ',/, * 9X,' NUMBER X Y Z ', * ' X Y Z ', * ' LMIBPAFC NUMBER,STR',/,1X,130('-'),/) 10902 FORMAT((2X,I4,3X,I7,3X,6(1X,F10.3),1X,I8,5X,I5)) GOTO 200 C C.... 'FRPT', 'FRTT', 'MRPT', 'MRTT' C 110 WRITE(LUN,1400) WRITE(LUN,11001) WRITE(LUN,11002) (I, IBTAB(IND,1,I), RBTAB(IND,2,I), * RBTAB(IND,3,I), * RBTAB(IND,4,I), RBTAB(IND,5,I),RBTAB(IND,6,I), * RBTAB(IND,7,I), (RBTAB(IND,8,I)*1000.), * IDUAL(IBTAB(IND,9,I),7), * IBTAB(IND,10,I), I=1, NROW) 11001 FORMAT(9X,' CELL ENTRY POINT (CM) ', * ' EXIT POINT (CM) ENERGY ', * ' ITRHIS TRACK ',/, * 9X,' NUMBER X Y Z ', * ' X Y Z LOSS (MEV) ', * ' LMIBPAFC NUMBER,STR',/,1X,130('-'),/) 11002 FORMAT((2X,I4,3X,I8,2X,6(1X,F10.3),1X,F10.5,5X,I8,2X,I8)) GOTO 200 C C.... 'FRPF' C 111 WRITE(LUN,1400) WRITE(LUN,11101) WRITE(LUN,11102) (I, RBTAB(IND,1,I), RBTAB(IND,2,I), * RBTAB(IND,3,I), * RBTAB(IND,4,I), RBTAB(IND,5,I), RBTAB(IND,6,I), * RBTAB(IND,7,I), RBTAB(IND,8,I), RBTAB(IND,9,I), * RBTAB(IND,10,I), RBTAB(IND,11,I), RBTAB(IND,12,I), * RBTAB(IND,13,I), RBTAB(IND,14,I), * PDGNAM(IBTAB(IND,15,I)), * IBTAB(IND,16,I), IDUAL(IBTAB(IND,17,I),7), IBTAB(IND,18,I), * I=1, NROW) 11101 FORMAT(7X,' ENTRY POINT (CM) ', * ' ENTRY MOMENTUM (GEV) ', * ' EXIT POINT (CM) ', * ' EXIT MOMENTUM (GEV) ', * ' PARTICLE CELL ITRHIS TRACK',/, * 7X,' X Y Z ', * ' PX/P PY/P PZ/P P ', * ' X Y Z ', * ' PX/P PY/P PZ/P P ', * ' TYPE NUMB LMIBPAFC NO.',/, * 1X,130('-'),/) 11102 FORMAT((2X,I4,3F7.2,3F6.2,4F7.2,3F6.2,F7.2,1X,A13,I5,1X,I8,I5)) GOTO 200 C C.... 'ARHT' ('AEHT'), 'ARDT' ('AEDT'), 'ARWT' ('AEWT') C FETCH PARALLEL BANKS C 112 CONTINUE ID2=0 IF(NAME.EQ.'ARHT')THEN CALL BKTOW(IW,'AEHT',0,IW,ID2,*9020) WRITE(LUN,1800) 'AEHT' ELSE IF(NAME.EQ.'ARDT') THEN CALL BKTOW(IW,'AEDT',0,IW,ID2,*9020) WRITE(LUN,1800) 'AEDT' ELSE IF(NAME.EQ.'ARWT') THEN CALL BKTOW(IW,'AEWT',0,IW,ID2,*9020) WRITE(LUN,1800) 'AEWT' ENDIF C IF(NAME.EQ.'AEHT') THEN WRITE(LUN,1800) 'AEHT' GOTO 200 ELSE IF(NAME.EQ.'AEDT') THEN WRITE(LUN,1800) 'AEDT' GOTO 200 ELSE IF(NAME.EQ.'AEWT') THEN WRITE(LUN,1800) 'AEWT' GOTO 200 ENDIF C WRITE(LUN,1400) WRITE(LUN,11201) DO 11200 I = 1, NROW ITRHIS = IBTAB(ID,3,I) CALL IDUAL1( ITRHIS, 14, 1, IBIT ) IENER = IFRB16(IBTAB(ID,2,I)) IENERE = IFRB16(IBTAB(ID2,1,I)) IF( NCOL.GE.6 ) THEN IEINV = IFRB16(IBTAB(ID,5,I))*ISCALD IEEM = IFRB16(IBTAB(ID,6,I))*ISCALD ELSE IEINV = 0 IEEM = 0 ENDIF IF(NAME.EQ.'ARWT') THEN IENER = IENER*ISCALD IENERE = IENERE*ISCALD CALL NWSOFT(IBTAB(ID,1,I),MM,NN,LL,II,JJ,KK,IFL) WRITE(LUN,11202) I, IBTAB(ID,1,I), MM, NN, LL, II, * JJ, KK, FLOAT(IENER)/1.E3, * IBIT,IBTAB(ID,4,I),FLOAT(IENERE)/1.E3, * FLOAT(IEINV)/1.E3, FLOAT(IEEM)/1.E3 ELSE IENER = IENER*ISCALA IENERE = IENERE*ISCALA IF( NCOL.GE.8 ) THEN IEHAD = IFRB16(IBTAB(ID,7,I))*ISCALD IEHVIS = IFRB16(IBTAB(ID,8,I))*ISCALD ELSE IEHAD = 0 IEHVIS= 0 ENDIF CALL NBSOFT(IBTAB(ID,1,I),MM,NN,LL,II,JJ,KK,IFL) WRITE(LUN,11202) I, IBTAB(ID,1,I), MM, NN, LL, II, * JJ, KK, FLOAT(IENER)/1.E3, * IBIT,IBTAB(ID,4,I),FLOAT(IENERE)/1.E3, * FLOAT(IEINV)/1.E3, FLOAT(IEEM)/1.E3, * FLOAT(IEHAD)/1.E3, FLOAT(IEHVIS)/1.E3 END IF 11200 CONTINUE 11201 FORMAT(6X,' CHANNEL NUMBER ENERGY', * ' ITRHIS TRACK ', * 'ELECTROMAGNETIC PERFECT ENERGIES (MeV)',/, * 6X,' CONT MM NN LL II JJ KK (MEV) ', * ' LMIBPAFC NUMBER ', * 'ENERGY (MEV) ', * ' Einv',' Eem',' Ehad',' Ehavis' * /,1X,130('-'),/) 11202 FORMAT((2X,I4,I7,1X,6I4,3X,F7.2,1X,3X,14I1,I7,3X,F10.2,6x,4F9.1)) C C.... DROP WORK BANK C CALL WDROP(IW,ID2) GOTO 200 C C.... 'PRDT' C 113 WRITE(LUN,1400) WRITE(LUN,11301) DO 1023 I = 1, NROW ITRHIS = IBTAB(ID,3,I) CALL IDUAL1( ITRHIS, 14, 1, IBIT ) IF( NCOL.GE.8 ) THEN IEINV = IFRB16(IBTAB(ID,5,I))*ISCALD IEEM = IFRB16(IBTAB(ID,6,I))*ISCALD IEHAD = IFRB16(IBTAB(ID,7,I))*ISCALD IEHVIS= IFRB16(IBTAB(ID,8,I))*ISCALD ELSE IEINV = 0 IEEM = 0 IEHAD = 0 IEHVIS= 0 ENDIF WRITE(LUN,11302) I,IBTAB(ID,1,I), IFRB16(IBTAB(ID,2,I)), * IBIT, IBTAB(ID,4,I), * FLOAT( IEINV )/1000., * FLOAT( IEEM )/1000., * FLOAT( IEHAD )/1000., * FLOAT( IEHVIS)/1000. 1023 CONTINUE 11301 FORMAT(1H0,8X,' CHAMBER ENERGY', * ' ITRHIS TRACK ', * ' perfect energies (MeV) ',/, * 9X,' NUMBER LMIBPAFC NUMBER ', * ' Einv',' Eem',' Ehad',' Ehavis',/, * 1X,130('-'),/) 11302 FORMAT((2X,I4,3X,I7,4X,I7,3X,3X,14I1,3X,I7,3X,4F9.1)) GOTO 200 C C.... 'BRCT' C 114 WRITE(LUN,1400) WRITE(LUN,11401) DO 1024 I = 1, NROW ITRHIS = IBTAB(ID,16,I) CALL IDUAL1( ITRHIS, 14, 1, IBIT ) WRITE(LUN,11402) I, IBTAB(ID,1,I), IFRB16(IBTAB(ID,2,I)), * IFRB16(IBTAB(ID,3,I)),IFRB16(IBTAB(ID,4,I)), * IFRB16(IBTAB(ID,5,I)),IFRB16(IBTAB(ID,6,I)), * IFRB16(IBTAB(ID,7,I)),IFRB16(IBTAB(ID,8,I)), * IFRB16(IBTAB(ID,9,I)), * IBTAB(ID,10,I)-1000, IBTAB(ID,11,I)-1000, * IBTAB(ID,12,I)-3000, IBTAB(ID,13,I)-1000, * IBTAB(ID,14,I)-1000, IBTAB(ID,15,I)-3000, * IBIT, IBTAB(ID,17,I) 1024 CONTINUE 11401 FORMAT(6X,' STACK ', * ' ENERG. FR. 6 WAVEL SHIFT (MEV)', * ' ENERGIES CENT. OF GRAV. (MM)', * ' C.O.G. HADRONS ', * ' ITRHIS TRACK',/, * 6X,'NUMBER ', * ' 1 2 3 4 5 6 ', * ' TOTAL HADR. X+XOFF Y+YOFF Z+ZOFF', * ' X+XOFF Y+YOFF Z+ZOFF', * ' LMIBPAFC NO.',/, * 1X,130('-'),/) 11402 FORMAT((1X,I4,I5,1X,6I5,3X,I5,I6,3X,6I7,3X,14I1,I4)) IF( NCOL.GE.21 ) THEN WRITE(LUN,11403) WRITE(LUN,11404)(I, * FLOAT( IFRB16(IBTAB(ID,18,I))*ISCALD )/1000., * FLOAT( IFRB16(IBTAB(ID,19,I))*ISCALD )/1000., * FLOAT( IFRB16(IBTAB(ID,20,I))*ISCALD )/1000., * FLOAT( IFRB16(IBTAB(ID,21,I))*ISCALD )/1000., * I=1,NROW ) ENDIF 11403 FORMAT(1H0,4X, * ' perfect energies (MeV) ',/, * 5X,' Einv',' Eem',' Ehad',' Ehavis',/, * 1X,130('-'),/) 11404 FORMAT((1X,I4,4F9.1)) GOTO 200 C C.... 'BRTT' C 115 WRITE(LUN,1400) WRITE(LUN,11501) WRITE(LUN,11502) (I, RBTAB(IND,1,I), RBTAB(IND,2,I), * RBTAB(IND,3,I), * RBTAB(IND,4,I), RBTAB(IND,5,I), RBTAB(IND,6,I), * RBTAB(IND,7,I), (1.0E+09*RBTAB(IND,8,I)), * IDUAL(IBTAB(IND,9,I),7), * IBTAB(IND,10,I), I=1, NROW) 11501 FORMAT(9X,' COORDINATES (CM) ', * ' MOMENTUM (GEV) ', * ' TIME OF ITRHIS TRACK ',/, * 9X,' X Y Z ', * ' PX/P PY/P PZ/P P ', * ' FLIGHT (NS) LMIBPAFC NUMBER ',/,1X,130('-'),/) 11502 FORMAT((2X,I4,3X,8(F10.3,1X),4X,2I8)) GOTO 200 C C.... 'IRHT' C 116 WRITE(LUN,1400) WRITE(LUN,11601) 11601 FORMAT(9X,' ENTRY POINT ( CM ) ', * ' EXIT POINT ( CM ) MOMENTUM ', * 'PARTICLE TYPE ITRHIS TRACK ',/, * 9X,' X Y Z ', * ' X Y Z (MEV) ', * ' LMIBPAFC NUMBER ',/,1X,130('-'),/) WRITE(LUN,11602) (I, FX(IBTAB(ID,1,I)), FY(IBTAB(ID,2,I)), * FZ(IBTAB(ID,3,I)), FX(IBTAB(ID,4,I)), FY(IBTAB(ID,5,I)), * FZ(IBTAB(ID,6,I)), IBTAB(ID,7,I), * PDGNAM(IBTAB(ID,8,I)-10000), IDUAL(IBTAB(ID,9,I),7), * IBTAB(ID,10,I), I=1, NROW) 11602 FORMAT((2X,I4,3X,6(F10.2,1X),I10,2X,A13,2X,2I8)) GOTO 200 C C.... 'LRET', 'LRPT' C 117 WRITE(LUN,1400) WRITE(LUN,11701) WRITE(LUN,11702) (I, FL(IBTAB(ID,1,I)), FL(IBTAB(ID,2,I)), * IBTAB(ID,3,I), PDGNAM(IBTAB(ID,4,I)-10000), * IDUAL(IBTAB(ID, 5,I),7), IBTAB(ID, 6,I), I=1, NROW) 11701 FORMAT(9X,' ENTRY POINT ( CM ) MOMENTUM ', * ' PARTICLE TYPE ITRHIS TRACK ',/, * 9X,' X Y (MEV) ', * ' LMIBPAFC NUMBER ',/,1X,130('-'),/) 11702 FORMAT((2X,I4,3X,2(F10.3,1X),I10,4X,A13,2X,2I8)) GOTO 200 C C.... 'LRVT' C 118 WRITE(LUN,1400) WRITE(LUN,11801) WRITE(LUN,11802) (I, IBTAB(ID,1,I), IBTAB(ID,2,I), * IDUAL(IBTAB(ID,3,I),7), IBTAB(ID,4,I), I=1, NROW) 11801 FORMAT(9X,' NUMBER OF RANGE ', * ' ITRHIS TRACK ',/, * 9X,' MINIHITS (MM) ', * ' LMIBPAFC NUMBER ',/,1X,130('-'),/) 11802 FORMAT((2X,I4,3X,I6,5X,I8,5X,2I8)) GOTO 200 C C.... STARTING AND LEAVING BANKS AT SUBDETECTOR BOUNDARIES C 119 WRITE(LUN,1400) WRITE(LUN,11901) WRITE(LUN,11902) (I, RBTAB(IND,1,I), RBTAB(IND,2,I), * RBTAB(IND,3,I), PDGNAM(IBTAB(IND,4,I)), RBTAB(IND,5,I), * RBTAB(IND,6,I), RBTAB(IND,7,I), (1.0E+09*RBTAB(IND,8,I)), * IDUAL(IBTAB(IND,9,I),7), IBTAB(IND,10,I), I=1, NROW) 11901 FORMAT(9X,' MOMENTUM (GEV) PARTICLE ', * 'TYPE COORD. AT ENTRY/EXIT POINT (CM) TIME OF ', * ' ITRHIS TRACK ',/, * 9X,' PX PY PZ ', * ' X Y Z FLIGHT (NS)', * ' LMIBPAFC NUMBER ',/,1X,130('-'),/) 11902 FORMAT((2X,I4,2X,3(1X,F10.3),1X,A13,3(1X,F10.3), * 3X,F10.3,5X,2I8)) GOTO 200 C C.... 'ARCE' ('AECE', 'ARDE', 'AEDE'), 'SRCE' C FETCH PARALLEL BANKS C 120 CONTINUE CALL VZERO(ID1,10) IF(NAME.EQ.'ARCE') THEN CALL BKTOW(IW,'AECE',0,IW,ID1(1),*12006) WRITE(LUN,1800) 'AECE' C DO 12000 I = 1, 4 C CALL BKTOW(IW,'ARDE',I,IW,ID1(I+1),*9020) C CALL BKTOW(IW,'AEDE',I,IW,ID1(I+5),*9020) 12000 CONTINUE C WRITE(LUN,1800) 'ARDE' C WRITE(LUN,1800) 'AEDE' ELSE IF(NAME.NE.'SRCE') THEN WRITE(LUN,1800) NAME GOTO 200 ENDIF C WRITE(LUN,1400) WRITE(LUN,12002) ISUM1 = 0 ISUM2 = 0 DO 12001 I = 1, NROW IENER = IFRB16(IBTAB(ID,2,I)) IENERE = IFRB16(IBTAB(ID1(1),1,I)) IENER = IENER*ISCALA IENERE = IENERE*ISCALA IF(NAME.EQ.'SRCE') THEN IENER = IFRB16(IBTAB(ID,2,I)) IENERE = 0. IENER = IENER*ISCALA IENERE = 0. CALL NSSOFT(IBTAB(ID,1,I),NN,LL,II,JJ,IFL) MM = 9 KK = 0 ENDIF ISUM1 = ISUM1 + IENER ISUM2 = ISUM2 + IENERE WRITE(LUN,12003) I, IBTAB(ID,1,I), MM, NN, LL, II, * JJ, KK, FLOAT(IENER)*1.E-3, FLOAT(IENERE)*1.E-3 12001 CONTINUE WRITE(LUN,12004) FLOAT(ISUM1)*1.E-3, FLOAT(ISUM2)*1.E-3 12002 FORMAT(9X,' CHANNEL NUMBER ENERGY ', * 10X,'ELECTROMAGNETIC ',/, * 9X,' CONT MM NN LL II JJ KK (MEV) ', * 10X,'ENERGY (MEV) ',/,1X,130('-'),/) 12003 FORMAT((2X,I4,3X,I7,1X,6I4,2X,F10.2,12X,F10.2)) 12004 FORMAT(1H0,'TOTAL ENERGY',30X,F10.2,12X,F10.2) C C.... DROP WORK BANK C DO 12005 I = 1, 1 CALL WDROP(IW,ID1(I)) 12005 CONTINUE GOTO 200 C 12006 CONTINUE WRITE(LUN,1400) WRITE(LUN,12007) WRITE(LUN,12008) (I,IBTAB(ID,1,I), IBTAB(ID,2,I), * I=1, NROW) 12007 FORMAT(9X,' CHANNEL ENERGY ',18X,' CHANNEL ENERGY ', * 18X,' CHANNEL ENERGY ',/, * 9X,' NUMBER DEPOSIT ',18X,' NUMBER DEPOSIT ', * 18X,' NUMBER DEPOSIT ',/, * 1X,130('-'),/) 12008 FORMAT((1X,3(I6,2X,2(I8,2X),10X))) GOTO 200 C C.... 'BRCE' 'PRDE', 'LREE', 'LRPE' C 121 CONTINUE IF(NAME.EQ.'PRDE')THEN ISFAC=10 ELSE ISFAC=1000 ENDIF WRITE(LUN,1400) WRITE(LUN,12101) WRITE(LUN,12102) (I, IBTAB(ID,1,I), IFRB16(IBTAB(ID,2,I))*ISFAC, * I=1, NROW) 12101 FORMAT(9X,' CHANNEL ENERGY ',18X,' CHANNEL ENERGY ', * 18X,' CHANNEL ENERGY ',/, * 9X,' NUMBER (KEV) ',18X,' NUMBER (KEV) ', * 18X,' NUMBER (KEV) ',/, * 1X,130('-'),/) 12102 FORMAT((1X,3(I6,2X,2(I8,2X),10X))) GOTO 200 C C.... 'BRTE' C 122 CONTINUE WRITE(LUN,1400) WRITE(LUN,12201) WRITE(LUN,12202) (I, IBTAB(ID,1,I), IBTAB(ID,2,I), I=1, NROW) 12201 FORMAT(9X,' CHANNEL TOF HIT ',18X,' CHANNEL TOF HIT ', * 18X,' CHANNEL TOF HIT ',/, * 9X,' NUMBER ',18X,' NUMBER ', * 18X,' NUMBER ',/, * 1X,130('-'),/) 12202 FORMAT((1X,3(I6,2X,2(I8,2X),10X))) GOTO 200 C C.... 'CRJE', 'CRZE' C 123 CONTINUE WRITE(LUN,1400) WRITE(LUN,12301) WRITE(LUN,12302) (I, IBTAB(ID,1,I), FLOAT(IBTAB(ID,2,I))/100., * IBTAB(ID,3,I), IBTAB(ID,4,I), IBTAB(ID,5,I), * IBTAB(ID,6,I), I=1, NROW) 12301 FORMAT(9X,' WIRE DRIFT CHARGE ', * ' FLAG 1 FLAG 2 ',/, * 9X,' NUMBER LENGTH (MM) + SIDE - SIDE ', * ' ',/,1X,130('-'),/) 12302 FORMAT((2X,I4,3X,I8,3X,F8.2,2X,4(I8,2X))) GOTO 200 C C.... 'CRME', 'FRME', 'BRME' C 124 CONTINUE WRITE(LUN,1400) WRITE(LUN,12401) WRITE(LUN,12402) (I, IBTAB(ID,1,I), I=1, NROW) 12401 FORMAT(9X,' CHANNEL ',18X,' CHANNEL ',18X,' CHANNEL ', * 18X,' CHANNEL ',/, * 9X,' NUMBER ',18X,' NUMBER ',18X,' NUMBER ', * 18X,' NUMBER ',/,1X,130('-'),/) 12402 FORMAT((1X,4(I6,2X,I8,12X))) GOTO 200 C C.... 'CRYE', 'FRPE', 'FRRE', 'MRPE', 'MRTE' C 125 CONTINUE ICONV = 40 IF(NAME.EQ.'CRYE') ICONV = 200 WRITE(LUN,1400) WRITE(LUN,12501) WRITE(LUN,12502) (I, IBTAB(ID,1,I), IBTAB(ID,2,I)*ICONV, * IBTAB(ID,3,I), IBTAB(ID,4,I), IBTAB(ID,5,I), * IBTAB(ID,6,I), I=1, NROW) 12501 FORMAT(9X,' WIRE DRIFT TIME CHARGE ', * ' FLAG 1 FLAG 2 ',/, * 9X,' NUMBER (PS) + SIDE - SIDE ', * ' ',/,1X,130('-'),/) 12502 FORMAT((2X,I4,3X,6(I8,2X))) GOTO 200 C C.... 'FRPN', 'FRRN', 'MRPN', 'MRTN' C 126 CONTINUE WRITE(LUN,1400) WRITE(LUN,12601) WRITE(LUN,12602) (I, IBTAB(IND,1,I), RBTAB(ID,2,I), * IBTAB(IND,3,I), IBTAB(IND,4,I), * RBTAB(IND,5,I), I=1, NROW) 12601 FORMAT(1H0,8X,' CELL ', * ' COORDINATES OF NOISE HITS ENERGY ',/, * 9X,' NUMBER ', * ' X Y Z DEPOSIT ',/, * 1X,130('-'),/) 12602 FORMAT((2X,I4,3X,I8,4F10.3)) GOTO 200 C C.... 'FRPH' C 127 CONTINUE WRITE(LUN,1400) WRITE(LUN,12701) WRITE(LUN,12702) (I, IBTAB(IND,1,I), RBTAB(IND,2,I), * RBTAB(IND,3,I), IBTAB(IND,4,I), IBTAB(IND,5,I), * IDUAL(IBTAB(IND,6,I),7), IBTAB(IND,7,I), I=1, NROW) 12701 FORMAT(1H0,8X,' CELL ENERGY DRIFT TYPE OF ', * ' DRIFT ITRHIS LINK TO ',/, * 9X,' NUMBER DEPOSIT DISTANCE HIT ', * ' SIGN LMIBPAFC PARENT,STR',/, * 1X,130('-'),/) 12702 FORMAT((2X,I4,3X,I8,2F10.3,2X,4(I8,2X))) GOTO 200 C C.... 'FRRH' C 128 CONTINUE WRITE(LUN,1400) WRITE(LUN,12801) WRITE(LUN,12802) (I, IBTAB(IND,1,I), RBTAB(IND,2,I), * RBTAB(IND,3,I), RBTAB(IND,4,I), IBTAB(IND,5,I), * IBTAB(IND,6,I), IDUAL(IBTAB(IND,7,I),7), * IBTAB(IND,8,1), I=1, NROW) 12801 FORMAT(1H0,8X,' CELL ENERGY DRIFT TYPE OF ', * ' DRIFT ITRHIS LINK TO ',/, * 9X,' NUMBER DEPOSIT DISTANCE HIT ', * ' SIGN LMIBPAFC PARENT,STR',/, * 1X,130('-'),/) 12802 FORMAT((2X,I4,3X,I8,3F10.3,2X,4(I8,2X))) GOTO 200 C C.... 'FRPX', 'FRRX', 'MRPX', 'MRTX' C 129 CONTINUE WRITE(LUN,1400) WRITE(LUN,12901) WRITE(LUN,12902) (I, IDUAL(IBTAB(ID,1,I),9), IBTAB(ID,2,I), * IBTAB(ID,3,I), I=1, NROW) 12901 FORMAT(9X,' FLAG LINK TO LINK TO ', * 18X,' FLAG LINK TO LINK TO ',/, * 9X,' STR BANK FR_E BANK ', * 18X,' STR BANK FR_E BANK ',/, * 1X,130('-'),/) 12902 FORMAT((1X,2(I6,3X,I10,I8,3X,I8,13X))) GOTO 200 C C.... 'IRSE', 'IRWE' C 130 CONTINUE WRITE(LUN,1400) WRITE(LUN,13001) WRITE(LUN,13002) (I, IBTAB(ID,1,I), IBTAB(ID,2,I), I=1, NROW) 13001 FORMAT(9X,' MODULE CHANNEL ',18X,' MODULE CHANNEL ', * 18X,' MODULE CHANNEL ',/, * 9X,' NUMBER NUMBER ',18X,' NUMBER NUMBER ', * 18X,' NUMBER NUMBER ',/, * 1X,130('-'),/) 13002 FORMAT((1X,3(I6,2X,2(I8,3X),9X))) GOTO 200 C C.... 'IRTE' C 131 CONTINUE WRITE(LUN,1400) WRITE(LUN,13101) WRITE(LUN,13102) (I, IBTAB(ID,1,I), IBTAB(ID,2,I), I=1, NROW) 13101 FORMAT(9X,' CHANNEL CHARGE ',18X,' CHANNEL CHARGE ', * 18X,' CHANNEL CHARGE ',/, * 9X,' (TOWER) STREAMERS ',18X,' (TOWER) STREAMERS ', * 18X,' (TOWER) STREAMERS ',/, * 1X,130('-'),/) 13102 FORMAT((1X,3(I6,2X,2(I8,3X),9X))) GOTO 200 C C.... 'ARCX', 'BRCX', 'CRYX', 'CRZX', 'PRDX', 'SRCX' C 132 CONTINUE WRITE(LUN,1400) WRITE(LUN,13201) WRITE(LUN,13202) (I, IBTAB(ID,1,I), IBTAB(ID,2,I), I=1, NROW) 13201 FORMAT(9X,' LINK TO LINK TO ', * 18X,' LINK TO LINK TO ', * 18X,' LINK TO LINK TO ',/, * 9X,' STR BANK _R_E BANK ', * 18X,' STR BANK _R_E BANK ', * 18X,' STR BANK _R_E BANK ',/, * 1X,130('-'),/) 13202 FORMAT((1X,3(I6,2X,2(I8,3X),9X))) GOTO 200 C C....no longer used C 133 CONTINUE GOTO 200 C C.... 'LRTE', 'LTL1' C 134 CONTINUE WRITE(LUN,1400) WRITE(LUN,13401) WRITE(LUN,13402) (I, IBTAB(ID,1,I), IBTAB(ID,2,I), I=1, NROW) 13401 FORMAT(9X,' DETECTOR VETO CODE ',18X,' DETECTOR VETO CODE ', * 18X,' DETECTOR VETO CODE ',/, * 9X,' NUMBER ',18X,' NUMBER ', * 18X,' NUMBER ',/, * 1X,130('-'),/) 13402 FORMAT((1X,3(I6,2X,2(I8,2X),9X))) GOTO 200 C C.... 'TRAK' ('TRIP') C FETCH PARALLEL BANKS C 135 CONTINUE IF(NAME.EQ.'TRAK') THEN IND1 = NLINK('TRIP',NR) IF(IND1.EQ.0) GOTO 9020 WRITE(LUN,1800) 'TRIP' ELSE WRITE(LUN,1800) NAME GOTO 200 ENDIF C WRITE(LUN,1400) WRITE(LUN,13502) WRITE(LUN,13503) (I, RBTAB(IND,1,I), RBTAB(IND,2,I), * RBTAB(IND,3,I), RBTAB(IND,4,I), RBTAB(IND,5,I), * RBTAB(IND,6,I), RBTAB(IND,7,I), IBTAB(IND,8,I), * IBTAB(IND,9,I), IBTAB(IND,10,I), IBTAB(IND,11,I), * IBTAB(IND1,1,I), I=1, NROW) 13502 FORMAT(9X,' MOMENTUM (GEV) ENERGY ', * ' CHARGE CLOSEST DISTANCE ', * ' PARTICLE VERTEX POINTERS LINK TO ', * 9X,' PX PY PZ (GEV) ', * ' R-PHI Z ', * ' TYPE NUMBER STR BANK ',/, * 1X,130('-'),/) 13503 FORMAT((3X,I3,2X,4(1X,F10.3),3(1X,F10.4),2X,I6,4X,I6, * 3X,2I4,1X,I8)) GOTO 200 C C.... 'CACE' ('CCEG') C FETCH PARALLEL BANKS C 136 CONTINUE IF(NAME.EQ.'CACE') THEN IND1 = NLINK('CCEG',0) IF(IND1.EQ.0) GOTO 13603 WRITE(LUN,1800) 'CCEG' ELSE WRITE(LUN,1800) NAME GOTO 200 ENDIF C WRITE(LUN,1400) WRITE(LUN,13601) WRITE(LUN,13602) (I, IBTAB(IND,1,I), RBTAB(IND,2,I), * RBTAB(IND1,1,I), RBTAB(IND1,2,I), RBTAB(IND1,3,I), * RBTAB(IND1,4,I), I=1, NROW) 13601 FORMAT(9X,' TOWER ENERGY ', * ' CENTROID CENTROID CENTROID CENTROID ',/, * 9X,' NUMBER DEPOSIT ', * ' X Y Z VOLUME ',/, * 1X,130('-'),/) 13602 FORMAT((2X,I4,3X,I8,5F10.3)) GOTO 200 C 13603 CONTINUE WRITE(LUN,1400) WRITE(LUN,13604) WRITE(LUN,13605) (I, IBTAB(IND,1,I), RBTAB(IND,2,I), I=1, NROW) 13604 FORMAT(9X,' TOWER ENERGY ',18X,' TOWER ENERGY ', * 10X,' TOWER ENERGY ',/, * 9X,' NUMBER DEPOSIT ',18X,' NUMBER DEPOSIT ', * 10X,' NUMBER DEPOSIT ',/, * 1X,130('-'),/) 13605 FORMAT((1X,3(I6,2X,I8,1X,F10.3,12X))) GOTO 200 C C.... 'MUON' C 137 CONTINUE WRITE(LUN,1400) WRITE(LUN,13701) WRITE(LUN,13702) (I, RBTAB(IND,1,I), RBTAB(IND,2,I), * IBTAB(IND,3,I), IBTAB(IND,4,I), IBTAB(IND,5,I), * I=1, NROW) 13701 FORMAT(9X,' SMEARED SIGMA ', * ' NUMBER NUMBER LINK TO ',/, * 9X,' MOMENTUM (1/P) ', * ' OF WIRES OF STRIPS STR BANK ',/, * 1X,130('-'),/) 13702 FORMAT((2X,I4,1X,2F10.3,3I10)) GOTO 200 C C.... 'TTSE' C 138 CONTINUE WRITE(LUN,1400) WRITE(LUN,13801) WRITE(LUN,13802) (RBTAB(IND,1,I),I=1, NROW) 13801 FORMAT(9X,'ENERGIES IN DIFFERENT CALORIMETERS (GEV) ',/, * 9X,'TRANSVERSE MISSING FORWARD FORWARD ', * ' CENTRAL BEMC PLUG FORWARD ', * ' BARREL BACKWARD TOTAL',/, * 9X,' LAR BARREL LAR ', * 'BARREL LAR ', * ' ',/, * 1X,130('-'),/) 13802 FORMAT((8X,11(F10.3,1X))) GOTO 200 C C.... 'MODS' C 139 CONTINUE WRITE(LUN,1400) WRITE(LUN,13901) WRITE(LUN,13902) (CHAINT(IBTAB(IND,1,I)),CHAINT(IBTAB(IND,2,I)), * IBTAB(IND,3,I)/1.E4,IBTAB(IND,4,I),I=1, NROW) 13901 FORMAT(9X,'MODULE NAME VERSION NR JOB NR',/, * 1X,130('-'),/) 13902 FORMAT((9X,2A4,6X,F7.4,4X,I8)) GOTO 200 C C.... 'MODI', 'MODO' C 140 CONTINUE WRITE(LUN,1400) WRITE(LUN,14001) WRITE(LUN,14002) (CHAINT(IBTAB(IND,1,I)),IBTAB(IND,2,I),I=1, NROW) 14001 FORMAT(9X,4('NAME LINK TO MODULE '),/, * 1X,130('-'),/) 14002 FORMAT((9X,4(A4,8X,I2,9X))) GOTO 200 C C.... 'MODC' C 141 CONTINUE WRITE(LUN,1400) WRITE(LUN,14101) WRITE(LUN,14102) (CHAINT(IBTAB(IND,1,I)),IBTAB(IND,2,I), 1 IBTAB(IND,3,I),I=1, NROW) 14101 FORMAT(9X,4('NAME VERSION LINK TO MODULE '),/, * 1X,130('-'),/) 14102 FORMAT((9X,4(A4,3X,I9,2X,I2,11X))) GOTO 200 C C.... 'SRCT' (Spacal hit bank) C 142 WRITE(LUN,1400) WRITE(LUN,14201) DO 14200 I = 1, NROW ITRHIS = 0 CALL IDUAL1( ITRHIS, 14, 1, IBIT ) IENER = IFRB16(IBTAB(ID,2,I))*ISCALA IEINV = IFRB16(IBTAB(ID,3,I))*ISCALD IEEM = IFRB16(IBTAB(ID,4,I))*ISCALD IEHAD = IFRB16(IBTAB(ID,5,I))*ISCALD IEHVIS = IFRB16(IBTAB(ID,6,I))*ISCALD WRITE(LUN,14202) I, IBTAB(ID,1,I), * FLOAT(IENER)/1.E3, * IBIT,IBTAB(ID,7,I), * FLOAT(IEINV)/1.E3, FLOAT(IEEM)/1.E3, * FLOAT(IEHAD)/1.E3, FLOAT(IEHVIS)/1.E3 14200 CONTINUE 14201 FORMAT(6X,' CHAN E(MeV) ITRHIS TRACK', * ' Einv Eem Ehad Ehavis' * /,1X,130('-'),/) 14202 FORMAT((2X,I4,I6,F9.1,2X,14I1,I7,4F9.1)) GOTO 200 143 CONTINUE WRITE(LUN,1400) CALL PRATES(ID) GOTO 200 144 CONTINUE WRITE(LUN,1400) write(6,*)'to print the TEL1 banks, please call directly' write(6,*)'PRTEL1(ITYPE), ITYPE=0 for online version' write(6,*)' ITYPE=1 for offline version' * next call works differently now... * CALL PRTEL1(IND) GOTO 200 145 CONTINUE WRITE(LUN,1400) * look for ATBX bank for combined printout of banks INXX=NLINK('ATBX',NR) ID2=0 IF(INXX.NE.0)THEN CALL BKTOW(IW,'ATBX',NR,IW,ID2,*9000) ENDIF CALL PRATBE(ID,ID2) IF(ID2.NE.0)CALL WDROP(IW,ID2) GOTO 200 C C.... 'JSRP', 'JSFT' C 146 WRITE(LUN,1400) WRITE(LUN,14601) WRITE(LUN,14602) (I, RBTAB(IND,1,I), RBTAB(IND,2,I), * RBTAB(IND,3,I), PDGNAM(IBTAB(IND,4,I)), RBTAB(IND,5,I), * RBTAB(IND,6,I), RBTAB(IND,7,I), (1.0E+09*RBTAB(IND,8,I)), * IBTAB(IND,9,I), I=1, NROW) 14601 FORMAT(9X,' MOMENTUM (GEV) PARTICLE ', * 'TYPE COORD. AT ENTRY/EXIT POINT (CM) TIME OF ', * ' TRACK ',/, * 9X,' PX PY PZ ', * ' X Y Z FLIGHT (NS)', * ' NUMBER ',/,1X,130('-'),/) 14602 FORMAT((2X,I4,2X,3(1X,F10.3),1X,A13,3(1X,F10.3), * 3X,F10.3,5X,I8)) GOTO 200 C C.... 'JRHT' ('JRDT') C FETCH PARALLEL BANKS C 147 CONTINUE IF(NAME.EQ.'JRHT') THEN IND1 = NLINK('JRDT',NR) IF(IND1.EQ.0) GOTO 14703 CALL BKTOW(IW,'JRDT',NR,IW,ID2,*9000) WRITE(LUN,1800) 'JRDT' ELSE WRITE(LUN,1800) NAME GOTO 200 ENDIF C WRITE(LUN,1400) WRITE(LUN,14701) WRITE(LUN,14702) (I,IDUAL(IBTAB(ID,1,I),6), * IDUAL(IBTAB(ID2,1,I),6), IBTAB(ID,2,I), I=1, NROW) WRITE(LUN,1400) CALL WDROP(IW,ID2) 14701 FORMAT(9X,' CHANNELS CHANNELS PARTICLE '/, * 9X,' HIT SIGNAL IN JSPT',/, * 1X,130('-'),/) 14702 FORMAT((I5,6X,I7,3X,I7,4X,I8)) GOTO 200 C 14703 CONTINUE WRITE(LUN,1400) WRITE(LUN,14704) WRITE(LUN,14705) (I, IDUAL(IBTAB(ID,1,I),6), * IBTAB(ID,2,I), I=1, NROW) WRITE(LUN,1400) 14704 FORMAT(9X,' CHANNELS PARTICLE '/, * 9X,' HIT IN JSPT',/, * 1X,130('-'),/) 14705 FORMAT((I5,6X,I7,4X,I8)) GOTO 200 C C.... 'JRDE' C 148 CONTINUE WRITE(LUN,1400) WRITE(LUN,14801) WRITE(LUN,14802) (I, IBTAB(ID,1,I), IBTAB(ID,2,I), I=1, NROW) 14801 FORMAT(9X,' CHANNEL HITS ',/,1X,130('-'),/) 14802 FORMAT(2X,I4,3X,I8,3X,I8) GOTO 200 C C.... PRINT BANKS WITHOUT MINIHEADER C C.... 'GKI ', 'GHD ', 'HEAD' C 500 CONTINUE IF(NAME.EQ.'GKI ') THEN WRITE(LUN,1400) IF( IW(IND) .GE. 29 ) THEN WRITE(LUN,511) IW(IND+1) 511 FORMAT(9X,' IRAD = ',I13,' initial/final radiation') WRITE(LUN,512) RW(IND+3), RW(IND+4) 512 FORMAT(9X,' GENPL = ',E13.6,' incident lepton momentum',/, * 9X,' GENPP = ',E13.6,' incident proton momentum') WRITE(LUN,513) RW(IND+5), RW(IND+6), RW(IND+7) 513 FORMAT(9X,' GENX = ',E13.6,' Bjorken X value ',/, * 9X,' GENY = ',E13.6,' Bjorken Y value ',/, * 9X,' GENQ2 = ',E13.6,' Q**2 value ') WRITE(LUN,514) RW(IND+8), RW(IND+9) 514 FORMAT(9X,' GENNU = ',E13.6,' nu = P.q/m_proton ',/, * 9X,' GENW = ',E13.6,' W value ') WRITE(LUN,515) RW(IND+10), RW(IND+11) 515 FORMAT(9X,' X1 = ',E13.6,' x in PDF lepton side',/, * 9X,' X2 = ',E13.6,' x in PDF proton side') WRITE(LUN,516) RW(IND+12), RW(IND+13) 516 FORMAT(9X,' SCALE1 = ',E13.6,' Q2 in PDF lepton side',/, * 9X,' SCALE2 = ',E13.6,' Q2 in PDF proton side') WRITE(LUN,517) IW(IND+14), IW(IND+15) 517 FORMAT(9X,' PDFID1 = ',I13,' PDF id. lepton side',/, * 9X,' PDFID2 = ',I13,' PDF id. proton side') WRITE(LUN,518) RW(IND+16), RW(IND+17) 518 FORMAT(9X,' XPDF1 = ',E13.6,' value of PDF lepton side',/, * 9X,' XPDF2 = ',E13.6,' value of PDF proton side') WRITE(LUN,519) RW(IND+18), RW(IND+19) 519 FORMAT(9X,' KTI1 = ',E13.6,' intr. k_t lepton side',/, * 9X,' KTI2 = ',E13.6,' intr. k_t proton side') WRITE(LUN,520) RW(IND+20), RW(IND+21) 520 FORMAT(9X,' WTX1 = ',E13.6,' event weight 1. variable',/, * 9X,' WTX2 = ',E13.6,' event weight 2. variable') WRITE(LUN,521) RW(IND+22), RW(IND+23) 521 FORMAT(9X,' SIGMT = ',E13.6,' total cross section',/, * 9X,' DSIGMT = ',E13.6,' error of cross section') WRITE(LUN,522) RW(IND+24), RW(IND+25) 522 FORMAT(9X,' SIGMS = ',E13.6,' subpr. cross section',/, * 9X,' DSIGMS = ',E13.6,' error of cross section') WRITE(LUN,523) RW(IND+26) 523 FORMAT(9X,' WTX3 = ',E13.6,' event weight mixing ') IF( IW(IND) .GE. 31 ) THEN WRITE(LUN,524) RW(IND+30), RW(IND+31) 524 FORMAT(9X,' PT2HAT = ',E13.6,' DIS + photoprod. ',/, * 9X,' SHAT = ',E13.6,' DIS + photoprod. ') ENDIF IF( IW(IND) .GE. 34 ) THEN WRITE(LUN,525) RW(IND+32), RW(IND+33), RW(IND+34) 525 FORMAT(9X,' XP = ',E13.6,' DIS + photoprod. ',/, * 9X,' ZP = ',E13.6,' DIS + photoprod. ',/, * 9X,' PHI = ',E13.6,' DIS + photoprod. ') ENDIF ELSE WRITE(LUN,501) 501 FORMAT(9X,' PHYSICS HARD GAMMA BEAM MOMENTA (GEV/C) ', * ' X Y Q**2 NU ', * ' W ',/, * 9X,' FLAG RADIATION LEPTON PROTON ', * ' (GEV/C)**2 (GEV) ', * ' (GEV) ',/,1X,130('-'),/) WRITE(LUN,502) IW(IND+1), IW(IND+2), (RW(IND+I), I=3, 9) 502 FORMAT(9X,I5,5X,' IRAD =',I2,1X,7(1X,E11.4)) END IF WRITE(LUN,1400) ELSE IF(NAME.EQ.'GHD ') THEN WRITE(LUN,1400) J = IND DO 180, I = 1, IW (IND) / 6 WRITE(LUN,503) CHAINT(IW(J+1)), CHAINT(IW(J+2)), * CHAINT(IW(J+3)), CHAINT(IW(J+4)), * CHAINT(IW(J+5)), CHAINT(IW(J+6)) J = J + 6 180 CONTINUE 503 FORMAT(/,6X,'GENERATOR NAME ',2A4,' VERSION NUMBER ', * 2A4,' CMZ Version ',2A4) WRITE(LUN,1400) ELSE IF(NAME.EQ.'GEVC') THEN CALL PRGEVC ELSE IF(NAME.EQ.'HEAD') THEN WRITE(LUN,1400) WRITE(LUN,504) WRITE(LUN,505) (IW(IND+I), I=1, 13) 504 FORMAT(9X,'VERS NRUN NEVT WEIGHT ', * ' U-TIME RUNTYPE BRERROR DETSTAT ', * ' L1-CLASS L2-CLASS L3-CLASS L4-CLASS L5-CLASS', * /,1X,130('-'),/) 505 FORMAT(9X,I4,I7,I7,I4,9I10) WRITE(LUN,1400) END IF RETURN C C.... CONTINUE HERE WITH NEW BANKS C 200 CONTINUE IF(IBKFMT.LT.0) CALL WDROP(IW,ID) WRITE(LUN,1400) RETURN C 9000 CONTINUE WRITE(LUN,1100) NAME, NR GOTO 200 9010 CONTINUE WRITE(LUN,1600) NAME WRITE(LUN,1400) IDUMMY = MYPRNT(NAME,NR,0) RETURN 9020 CONTINUE WRITE(LUN,1700) GOTO 200 1100 FORMAT(//,' +++++ H1PRNT. BANK ++ ',A,',',I2,' ++ DOES NOT ', * 'EXIST ON INPUT FILE. ') 1200 FORMAT('0+++++ H1PRNT. PRINT FORMAT FOR BANK ++ ',A,' ++ ', * 'IS NOT YET SPECIFIED. ') 1300 FORMAT(//,' +++++ ',A,',',I2, * ' BANK LENGTH ',I5, * ' NUMBER OF COLUMNS ',I5, * ' NUMBER OF ROWS ',I5) 1400 FORMAT(1H0,130('-')) 1500 FORMAT('0+++++ H1PRNT. BANK LENGTH DOES NOT MATCH ', * 'MINI HEADER.',/) 1600 FORMAT(//,' +++++ H1PRNT. BANK ++ ',A,' ++ NOT FOUND IN ', * 'CURRENT BANK LIST.',/, * ' +++++ H1PRNT. CALL MYPRNT INSTEAD.',//) 1700 FORMAT('0+++++ H1PRNT. NO PARALLEL BANK FOUND.') 1800 FORMAT('0+++++ ',A4,', 0 IS A PARALLEL BANK.') 1900 FORMAT(//,' +++++ ',A,',',I2,' NO MINIHEADER.') END *CMZU: 03/08/98 14.41.58 by Stephen Burke *-- Author : Stephen Burke 03/08/98 SUBROUTINE FPFRQE *#********************************************************************** *# * *# VERSION: 30/07/98 Steve Burke * *# * *# Print FRQE BANK * *# Created BY SJM 02/03/90 * *# * *#********************************************************************** *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. COMMON/FPF3WW/IND * Locate FRQE Banks.. IBK = 0 IND = NLINK('FRQE',IBK) IF (IND .EQ. 0) THEN WRITE(6,*) 'FRQE', IBK,' BANK NOT FOUND ' RETURN ENDIF IND=0 CALL BKTOW(IW,'FRQE',IBK,IW,IND,*900) * Compute number of responses... INUM = IW(IND+2) IF(INUM.LE.0) GOTO 999 WRITE(6,100) IBK,INUM WRITE(6,110) INDST = IND+2 DO 11 JJHIT = 1,INUM * Information from FRQE response bank... ICLNUM= IW(INDST + 1) IDRF = IW(INDST + 2) IQPL = IW(INDST + 3) IQMI = IW(INDST + 4) IFRFLA= IW(INDST + 5) IFRFLB= IW(INDST + 6) ISEPR = 0 ISEPL = 0 IHITS = 0 ILEN = 0 CALL MVBITS(IFRFLB, 0,4,ISEPL,0) CALL MVBITS(IFRFLB, 4,4,ISEPR,0) CALL MVBITS(IFRFLB, 8,4,ILEN,0) CALL MVBITS(IFRFLB,12,4,IHITS,0) INDST = INDST + IW(IND+1) WRITE(6,200)JJHIT,ICLNUM,IDRF,IQPL,IQMI, + IFRFLA,IFRFLB, + ISEPL,ISEPR,ILEN,IHITS 11 CONTINUE 100 FORMAT(' ',72('-'),/,5X, 'FRQE ',I2,' WITH',I5,' HITS') 110 FORMAT(' Row Cell Drift Qplus', + ' Qminus Flag1 Flag2', + ' ? ? ? ?') 200 FORMAT(2I6,3I10,2(3X,I8),4I4) 999 CONTINUE CALL WDROP(IW,IND) RETURN 900 CONTINUE WRITE(6,*) ' *****ERROR IN W BANK CREATION FPFRQE' RETURN END *CMZU: 03/08/98 14.41.58 by Stephen Burke *-- Author : Stephen Burke 03/08/98 SUBROUTINE FPFRQF *#********************************************************************** *# * *# VERSION: 30/07/98 Steve Burke * *# * *# Print FRQF BANK * *# Created BY SJM 02/03/90 * *# * *#********************************************************************** *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. * Locate FRQF Bank... IND = NLINK('FRQF',0) IF (IND .EQ. 0) THEN WRITE(6,*) ' **FPFRQF>> FRQF BANK NOT FOUND ' RETURN ENDIF * Compute number of responses... INUM = IW(IND+2) IF(INUM.LE.0) GOTO 999 WRITE(6,100) INUM WRITE(6,110) INDST = IND+2 DO 11 JJHIT = 1,INUM * XIN = RW(INDST + 1) YIN = RW(INDST + 2) ZIN = RW(INDST + 3) PXIN = RW(INDST + 4) PYIN = RW(INDST + 5) PZIN = RW(INDST + 6) PPIN = RW(INDST + 7) XOUT = RW(INDST + 8) YOUT = RW(INDST + 9) ZOUT = RW(INDST +10) PXOUT = RW(INDST +11) PYOUT = RW(INDST +12) PZOUT = RW(INDST +13) PPOUT = RW(INDST +14) IPART = IW(INDST +15) ITRHIS = IW(INDST +16) ICELL = IW(INDST +17) ITRKNM = IW(INDST +18) WRITE(6,200)JJHIT,XIN ,YIN ,ZIN ,PXIN ,PYIN ,PZIN ,PPIN, + XOUT,YOUT,ZOUT,PXOUT,PYOUT,PZOUT,PPOUT, + IPART,ITRHIS,ICELL,ITRKNM INDST = INDST + IW(IND+1) 11 CONTINUE 100 FORMAT(' ',72('-'),/,5X, 'FRQF WITH',I5,' HITS') 110 FORMAT(' ',' Row',' x',' y',' z',' Px/P', + ' Py/P',' Pz/P',' P',' Typ', + ' His',' Cell',' Trk') 200 FORMAT(1X,I4,7(1X,F6.2),/,5X,7(1X,F6.2),2I4,I6,I4) 999 CONTINUE RETURN END *CMZU: 03/08/98 14.41.58 by Stephen Burke *-- Author : Stephen Burke 03/08/98 SUBROUTINE FPFRQH *#********************************************************************** *# * *# VERSION: 30/07/98 Steve Burke * *# * *# Print FRQH BANK * *# Created BY SJM 02/03/90 * *# * *#********************************************************************** *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. * Conversion GeV -> keV PARAMETER(GEVKEV=1000000.) * Locate FRQH Bank... IND = NLINK('FRQH',0) IF (IND .EQ. 0) THEN WRITE(6,*) 'FRQH BANK NOT FOUND ' RETURN ENDIF * Compute number of responses... INUM = IW(IND+2) IF(INUM.LE.0) GOTO 999 WRITE(6,100) INUM WRITE(6,110) INDST = IND+2 DO 11 JJHIT = 1,INUM * Information from FRPH bank ICLNUM = IW(INDST + 1) EDEP = GEVKEV*RW(INDST + 2) DRIF = RW(INDST + 3) IHTTYP = IW(INDST + 4) ISIGN = IW(INDST + 5) ITRHIS = IW(INDST + 6) ITRKNM = IW(INDST + 7) WRITE(6,200)JJHIT,ICLNUM,EDEP,DRIF, + IHTTYP,ISIGN,ITRHIS,ITRKNM INDST = INDST + IW(IND+1) 11 CONTINUE 100 FORMAT(' ',72('-'),/,5X, 'FRQH WITH',I5,' HITS') 110 FORMAT(' Row',' Cell', + ' Edep-keV Drif', + ' HTyp Sgn His Trk') 200 FORMAT(I5,I6,2F10.4,4I5) 999 CONTINUE RETURN END *CMZU: 03/08/98 14.41.58 by Stephen Burke *-- Author : Stephen Burke 03/08/98 SUBROUTINE FPFRQT *#********************************************************************** *# * *# VERSION: 30/07/98 Steve Burke * *# * *# Print FRQT BANK * *# Created BY SJM 02/03/90 * *# * *#********************************************************************** *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(NBN=0) * Locate FRQT banks... IND =NLINK('FRQT',NBN) IF(IND.NE.0) THEN * Number of hits in bank INUM=IW(IND+2) WRITE(6,100) NBN,INUM * Loop through hits in this bank INDST = IND+2 WRITE(6,110) DO 11 JJHIT = 1,INUM * Information from track response bank... ICLNUM= IW(INDST + 1) XIN = RW(INDST + 2) YIN = RW(INDST + 3) ZIN = RW(INDST + 4) XOUT = RW(INDST + 5) YOUT = RW(INDST + 6) ZOUT = RW(INDST + 7) EDEP = 1000000.*RW(INDST + 8) ITRHIS= IW(INDST + 9) ITRKNM= IW(INDST +10) WRITE(6,200)JJHIT,ICLNUM,XIN,YIN,ZIN,XOUT,YOUT,ZOUT, + EDEP,ITRHIS,ITRKNM INDST = INDST + IW(IND+1) 11 CONTINUE END IF 100 FORMAT(' ',72('-'),/,5X, 'FRQT BANK ',I3,' with',I5,' Hits') 110 FORMAT(' Row Cell Xin Yin Zin', + ' Xout Yout Zout E-keV His', + ' Trk') 200 FORMAT(2I5,7F7.2,2I4) RETURN END *CMZU: 03/08/98 14.41.58 by Stephen Burke *-- Author : Stephen Burke 03/08/98 SUBROUTINE FPFRQX *#********************************************************************** *# * *# VERSION: 30/07/98 Steve Burke * *# * *# Print FRQX BANK * *# Created BY SJM 02/03/90 * *# * *#********************************************************************** *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. COMMON/FPF5WW/IND *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)) *KEND. * Locate FRQX Bank... IBK = 0 IND = NLINK('FRQX',IBK) IF (IND .EQ. 0) THEN WRITE(6,*) 'FRQX', IBK,' BANK NOT FOUND ' RETURN ENDIF IND=0 CALL BKTOW(IW,'FRQX',IBK,IW,IND,*900) * Compute number of responses... INUM = IW(IND+2) IF(INUM.LE.0) GOTO 999 WRITE(6,100) IBK,INUM WRITE(6,*) ' Row',' IFlag', + ' Trk', + ' IFRQE' DO 11 K = 1,INUM WRITE(6,'(1X,I4,3(2X,I6))') + K,(IBTAB(IND,J,K), J=1,3) 11 CONTINUE 100 FORMAT(' ',72('-'),/,5X, 'FRQX ',I2,' WITH',I5,' HITS') 999 CONTINUE CALL WDROP(IW,IND) RETURN 900 CONTINUE WRITE(6,*) ' *****ERROR IN W BANK CREATION FPFRQX' RETURN END *CMZU: 03/08/98 14.42.18 by Stephen Burke *-- Author : Stephen Burke 03/08/98 SUBROUTINE UTQCRB ********************************************************************** * * * Create unpacked versions of the digi pointer and hit relation * * banks for use by UTQSTR * * * * Banks created are: FTPY, FTQY, FTRY, CTJY, CVYY, CVZY, * * FRPY, FRQY, FRRY, CRJY, CRYY, CRZY and STRX * * * * See the DDL for details * * * * Updated 31/7/98 to allow for the new planar chambers * * * ********************************************************************** PARAMETER (NSUBDT=6,NCDP=2,NCXR=5) DIMENSION IFLG(NSUBDT),ISTR(NSUBDT),IHIT(NSUBDT) CHARACTER*4 DPNAME(NSUBDT),XRNAME(NSUBDT) CHARACTER*4 DPNAMY(NSUBDT),XRNAMY(NSUBDT) LOGICAL LFIRST SAVE IFLG,ISTR,IHIT,DPNAME,XRNAME,DPNAMY,XRNAMY,LFIRST COMMON /IUSTRY/ INDDP(NSUBDT),INDXR(NSUBDT) DATA IFLG/1,1,1,0,0,0/,ISTR/2,2,2,1,1,1/,IHIT/3,3,3,2,2,2/ DATA DPNAME/'FTPX','FTQX','FTRX','CTJX','CRYE','CRZE'/ DATA DPNAMY/'FTPY','FTQY','FTRY','CTJY','CVYY','CVZY'/ DATA XRNAME/'FRPX','FRQX','FRRX','CRJX','CRYX','CRZX'/ DATA XRNAMY/'FRPY','FRQY','FRRY','CRJY','CRYY','CRZY'/ DATA LFIRST/.TRUE./ *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,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)) *KEND. ********************************************************************** IF (LFIRST) THEN LFIRST = .FALSE. * Define the bank formats (just in case they get written out) CALL BKFMT('STRX','I') DO JS=1,NSUBDT CALL BKFMT(DPNAMY(JS),'I') CALL BKFMT(XRNAMY(JS),'I') END DO ENDIF * Zero work bank indices CALL VZERO(INDDP,NSUBDT) CALL VZERO(INDXR,NSUBDT) INSTR = NLINK('STR ',0) IF (INSTR.GT.0) THEN * Create the STRX bank and add to R list NSTR = IW(INSTR+2) INSTRX = NBANK('STRX',0,2+NSUBDT*NSTR) IF (INSTRX.LE.0) GOTO 9000 CALL VZERO(IW(INSTRX+1),2+NSUBDT*NSTR) CALL BLIST(IW,'R+','STRX') IW(INSTRX+1) = NSUBDT IW(INSTRX+2) = NSTR ELSE NSTR = 0 ENDIF * * Main loop over subdetectors * DO 100 JS=1,NSUBDT * Get rid of any pre-existing banks CALL BDROP(IW,DPNAMY(JS)) CALL BDROP(IW,XRNAMY(JS)) * Do nothing if the banks don't exist IF (NLINK(DPNAME(JS),0).LE.0 .OR. & NLINK(XRNAME(JS),0).LE.0) GOTO 100 * Unpack banks (all B16) CALL BKTOW(IW,DPNAME(JS),0,IW,INDDP(JS),*9000) CALL BKTOW(IW,XRNAME(JS),0,IW,INDXR(JS),*9000) NDP = IW(INDDP(JS)+2) NXR = IW(INDXR(JS)+2) * Create the new banks and add to R list INDDPY = NBANK(DPNAMY(JS),0,2+NCDP*NDP) IF (INDDPY.LE.0) GOTO 9000 CALL BLIST(IW,'R+',DPNAMY(JS)) INDXRY = NBANK(XRNAMY(JS),0,2+NCXR*NXR) IF (INDXRY.LE.0) GOTO 9000 CALL BLIST(IW,'R+',XRNAMY(JS)) CALL VZERO(IW(INDDPY+1),2+NCDP*NDP) CALL VZERO(IW(INDXRY+1),2+NCXR*NXR) IW(INDDPY+1) = NCDP IW(INDDPY+2) = NDP IW(INDXRY+1) = NCXR IW(INDXRY+2) = NXR * Loop over the cross-reference banks in reverse order DO JXR=NXR,1,-1 IF (IFLG(JS).GT.0) THEN * True hits only (this flag only exists for radials and planars) IFLAG = IBTAB(INDXR(JS),IFLG(JS),JXR) ELSE IFLAG = 0 ENDIF IF (IFLAG.LT.512) THEN JDP = IBTAB(INDXR(JS),IHIT(JS),JXR) JSTR = IBTAB(INDXR(JS),ISTR(JS),JXR) * Fill in the various pointers IF (JDP.GT.0 .AND. JDP.LE.NDP) THEN JXX = IBTAB(INDDPY,2,JDP) IW(INDCR(INDDPY,2,JDP)) = JXR IW(INDCR(INDXRY,1,JXR)) = JSTR IW(INDCR(INDXRY,2,JXR)) = JDP IW(INDCR(INDXRY,3,JXR)) = JXX IW(INDCR(INDXRY,5,JXR)) = IFLAG ENDIF IF (JSTR.GT.0 .AND. JSTR.LE.NSTR) THEN JXY = IBTAB(INSTRX,JS,JSTR) IW(INDCR(INSTRX,JS,JSTR)) = JXR IW(INDCR(INDXRY,4,JXR)) = JXY ENDIF ENDIF END DO * Finally copy the "pointer to next digi" (meaningless for z-chambers) DO JDP=1,NDP IW(INDCR(INDDPY,1,JDP)) = IBTAB(INDDP(JS),1,JDP) END DO 100 CONTINUE 900 CONTINUE * * Must make sure all work banks are dropped!!! * DO JS=1,NSUBDT CALL WDROP(IW,INDDP(JS)) CALL WDROP(IW,INDXR(JS)) END DO RETURN 9000 CONTINUE CALL ERRLOG(1201,'S:UTQCRB: Error in bank creation') GOTO 900 END *CMZU: 03/08/98 14.42.18 by Stephen Burke *-- Author : Stephen Burke 03/08/98 SUBROUTINE UTQSTR(JDIGP,JDIGQ,JDIGR,JDIGJ,JCVPR,JSTR,NHIT,NPOSS) ********************************************************************** * * * Find the best candidate for the 'true' track, given a list * * of digis. * * * * Note that UTQCRB must be called once per event before this * * routine can be used. * * * * The arguments are pointers into the circular lists of digis, or * * for the z-chambers to the "pointering" bank: * * * * JDIGP --> FTPX (foward planars) * * JDIGQ --> FTQX (foward new planars) * * JDIGR --> FTRX (forward radials) * * JDIGJ --> CTJX (CJC) * * JCVPR --> CVPR (CIZ + COZ) * * * * The return values are: * * * * JSTR - The 'true' track (STR) number * * NHIT - The number of hits from track JSTR in the digi list(s) * * NPOSS - The total number of hits from track JSTR * * * * Thus NHIT/NPOSS is some sort of "hit-finding efficiency". * * * * Zero or negative pointers are ignored; the return value JSTR is * * the STR index of the "best" track (the one contributing most hits) * * for those subdetectors with pointers > 0. * * * * Pointers which are negative on entry will exclude that subdetector * * from having its hits counted in NPOSS * * * * If the FT unpacked banks (FPLC/FPG1, FQLC/FQG1 and FRLC/FRG1) * * exist, NPOSS does not include hits on dead wires (which may have * * been simulated and then killed in reconstruction). These banks * * can be generated by calling F{P/Q/R}LOCO and FTCORG (in H1REC). * * No similar banks currently exist for the CTD (to my knowledge). * * Note that these banks are also created by the FRCART routine, * * used e.g. in the event display. * * * * Note that H1SIM must be run with the secondary momentum cut * * (SKECUT) set to zero for each track to have a unique STR number; * * the default is for all secondaries to have the same number as * * the parent. * * * * The following values are returned as error codes: * * * * JSTR = 0 - track/digi cross-reference bank not found * * = -1 - digi pointer bank not found * * = -2 - digi pointer invalid * * = -3 - digi pointer list not circular * * * * NHIT and NPOSS are zero in this case. * * * ********************************************************************** PARAMETER (NSUBDT=6,IWCHNK=1000) DIMENSION JDIG(NSUBDT),NNDIG(NSUBDT) DIMENSION INDDP(NSUBDT),INDXR(NSUBDT),INDLC(3),INDG1(3) LOGICAL LDWBK(NSUBDT),LCIRC(NSUBDT) CHARACTER*4 DPNAME(NSUBDT),DPNAMY(NSUBDT),XRNAMY(NSUBDT) CHARACTER*4 LCNAME(3),G1NAME(3) SAVE DPNAME,DPNAMY,XRNAMY,LCNAME,G1NAME,LCIRC COMMON /IUSTRZ/ INDDPX(NSUBDT),INCVPR,INDTRU DATA DPNAME/'FTPX','FTQX','FTRX','CTJX','CVYX','CVZX'/ DATA DPNAMY/'FTPY','FTQY','FTRY','CTJY','CVYY','CVZY'/ DATA XRNAMY/'FRPY','FRQY','FRRY','CRJY','CRYY','CRZY'/ DATA LCIRC/.TRUE.,.TRUE.,.TRUE.,.TRUE.,.FALSE.,.FALSE./ DATA LCNAME/'FPLC','FQLC','FRLC'/ DATA G1NAME/'FPG1','FQG1','FRG1'/ *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,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)) *KEND. ********************************************************************** JSTR = -1 NHIT = 0 NPOSS = 0 * Zero work bank indices CALL VZERO(INDDPX,NSUBDT) INCVPR = 0 INDTRU = 0 * Copy pointers JDIG(1) = JDIGP JDIG(2) = JDIGQ JDIG(3) = JDIGR JDIG(4) = JDIGJ JDIG(5) = JCVPR JDIG(6) = JCVPR CALL VZERO(NNDIG,NSUBDT) * Unpack the CVPR and z-chamber digi pointer banks if necessary IF (JCVPR.GT.0) THEN IF (NLINK('CVPR',0).LE.0) RETURN CALL BKTOW(IW,'CVPR',0,IW,INCVPR,*9000) JDIG(5) = IBTAB(INCVPR,2,JCVPR) JDIG(6) = IBTAB(INCVPR,4,JCVPR) NNDIG(5) = IBTAB(INCVPR,1,JCVPR) NNDIG(6) = IBTAB(INCVPR,3,JCVPR) * Check that pointer banks exist and unpack (all B16) DO JS=5,6 IF (JDIG(JS).GT.0) THEN IF (NLINK(DPNAME(JS),0).LE.0) GOTO 900 CALL BKTOW(IW,DPNAME(JS),0,IW,INDDPX(JS),*9000) ENDIF END DO ENDIF JSTR = 0 * Get indices for unpacked banks DO JS=1,NSUBDT IF (JDIG(JS).GT.0) THEN INDDP(JS) = NLINK(DPNAMY(JS),0) INDXR(JS) = NLINK(XRNAMY(JS),0) IF (INDDP(JS).LE.0 .OR. INDXR(JS).LE.0) GOTO 900 ELSEIF (JDIG(JS).EQ.0) THEN INDXR(JS) = NLINK(XRNAMY(JS),0) ENDIF IF (JS.LE.3) THEN * See if FT unpacked banks exist INDLC(JS) = NLINK(LCNAME(JS),0) INDG1(JS) = NLINK(G1NAME(JS),0) LDWBK(JS) = INDLC(JS).GT.0 .AND. INDG1(JS).GT.0 ELSE * No dead wire info for CT (?) LDWBK(JS) = .FALSE. ENDIF END DO * Create work bank to store true track numbers CALL WBANK(IW,INDTRU,IWCHNK,*9000) CALL VZERO(IW(INDTRU+1),IWCHNK) * * Main loop over subdetectors * DO 500 JS=1,NSUBDT IF (JDIG(JS).LE.0) GOTO 500 * Get the starting digi pointer IF (LCIRC(JS)) THEN IDIG = JDIG(JS) ELSE IDIG = IBTAB(INDDPX(JS),2,JDIG(JS)) ENDIF NDIG = IW(INDDP(JS)+2) * Loop over digis looking for a corresponding hit ... INUM = 0 100 CONTINUE INUM = INUM + 1 IF (INUM.GT.NDIG) THEN * Pointer list can't be circular JSTR = -3 GOTO 900 ELSEIF (IDIG.LE.0 .OR. IDIG.GT.NDIG) THEN * Pointer is invalid JSTR = -2 GOTO 900 ENDIF JHIT = IBTAB(INDDP(JS),2,IDIG) IF (JHIT.LE.0) GOTO 400 200 CONTINUE * We have a match, so see if this track has been seen before KSTR = IBTAB(INDXR(JS),1,JHIT) IFOUND = 0 NSTR = 0 300 CONTINUE NSTR = NSTR + 1 IMAX = IW(INDTRU) IF (2*NSTR.GE.IMAX) THEN * Extend work bank (probably won't happen, but ...) CALL WBANK(IW,INDTRU,2*IMAX,*9000) CALL VZERO(IW(INDTRU+IMAX+1),IMAX) ENDIF IF (KSTR.EQ.IW(INDTRU+2*NSTR-1)) THEN IFOUND = NSTR ELSEIF (IW(INDTRU+2*NSTR-1).GT.0) THEN GOTO 300 ENDIF IF (IFOUND.EQ.0) THEN * New track number, so store it ... IW(INDTRU+2*NSTR-1) = KSTR IW(INDTRU+2*NSTR) = 1 ELSE * ... or increment the counter IW(INDTRU+2*NSTR) = IW(INDTRU+2*NSTR) + 1 ENDIF * Now see if there's another hit for this digi (can happen!) JHIT = IBTAB(INDXR(JS),3,JHIT) IF (JHIT.GT.0) GOTO 200 400 CONTINUE * Get the next digi pointer, and see if we're back where we started IF (LCIRC(JS)) THEN IDIG = IBTAB(INDDP(JS),1,IDIG) IF (IDIG.NE.JDIG(JS)) GOTO 100 ELSEIF (INUM.LT.NNDIG(JS)) THEN IDIG = IBTAB(INDDPX(JS),2,JDIG(JS)+INUM) GOTO 100 ENDIF 500 CONTINUE * * Now search through the list of tracks to find the best * NHIT = 0 NSTR = 0 600 CONTINUE NSTR = NSTR + 1 IF (IW(INDTRU+2*NSTR).GT.NHIT) THEN NHIT = IW(INDTRU+2*NSTR) JSTR = IW(INDTRU+2*NSTR-1) ENDIF IF (IW(INDTRU+2*NSTR-1).GT.0) GOTO 600 * * Finally, count the total number of hits on the "best" track * NPOSS = 0 INSTRX = NLINK('STRX',0) IF (INSTRX.LE.0 .OR. JSTR.LE.0) GOTO 900 DO 800 JS=1,NSUBDT * Only mask out a subdetector if the pointer is negative IF (JDIG(JS).LT.0 .OR. INDXR(JS).LE.0) GOTO 800 * Get first hit for this track JHIT = IBTAB(INSTRX,JS,JSTR) IF (JHIT.LE.0) GOTO 800 700 CONTINUE * Don't count a hit with no digi as findable IDIG = IBTAB(INDXR(JS),2,JHIT) IF (IDIG.GT.0) THEN IDEAD = 0 IF (LDWBK(JS)) THEN * Check dead wire map (FT only, and only if unpacked banks exist) * NB A wedge-pair can be half dead, but it's a pain to check! ICELL = IBTAB(INDLC(JS),1,IDIG) IDEAD = IBTAB(INDG1(JS),1,ICELL+1) ENDIF IF (IDEAD.EQ.0) NPOSS = NPOSS + 1 ENDIF * Get next hit for this track JHIT = IBTAB(INDXR(JS),4,JHIT) IF (JHIT.GT.0) GOTO 700 800 CONTINUE 900 CONTINUE * * Must make sure all work banks are dropped!!! * CALL WDROP(IW,INDTRU) CALL WDROP(IW,INCVPR) DO JS=1,NSUBDT CALL WDROP(IW,INDDPX(JS)) END DO RETURN 9000 CONTINUE CALL ERRLOG(1301,'S:UTQSTR: Error in bank creation') GOTO 900 END