+PATCH,$CORR. +DECK,CORR1. Updates version: 2.02/00 to 2.03/00 +REP,*TITLE*,TITLE,0-1. &TITLE. BCTRAK 2.03/00 07/04/95 19.46.07 +REP,$VERSION,V2_02,1-4. *CMZU: 2.02/03 07/03/95 17.10.44 by F.-H.Heinsius *CMZU: 2.02/02 27/02/95 15.30.38 by F.-H.Heinsius *CMZU: 2.02/01 23/01/95 20.48.02 by Christian Voelcker *CMZU: 2.02/00 12/12/94 17.19.16 by F.-H.Heinsius *-- Author : F.-H.Heinsius 12/12/94 * *::> VERSION 2.02/03 07/03/95 17.10.44 * * SMART was overwriting memory in case of 1 PED events. * This is a rare but severe bug, because following events might be * affected (FHH). * *::> VERSION 2.02/02 27/02/95 15.30.38 * * Do not fill TTKS word 53 in DBCSTO (is used by TAXI). Save link to * LTBEL bank in case everything else is wiped. Cleanup declared but * unsused variables. (FHH) * *::> VERSION 2.02/01 23/01/95 20.48.01 * * *> DOLBY-C and SMART are now optionally called from GTRACK * if the user has set the appropriate keywords in the GLOB card. * Therefore, a new routine BSMSTO has been created to store * SMART results in the TTKS bank. (CHV) * *> Fixed Bug in BCTRAK handling of 'RTRK': DST Tapes from 1990 data * may not contain the 2282 Rawdata and the compressed Table 'TBEL' * is wiped out by 'RTRK'. Save in that case the 'TBEL' bank. (FHH) * *::> VERSION 2.02/00 12/12/94 17.19.16 +ADD,$VERSION,V2_03,*. &DECK,V2_03. *CMZU: 2.03/00 07/04/95 19.46.07 by Christian Voelcker *-- Author : Christian Voelcker 07/04/95 * *::> VERSION 2.03/00 07/04/95 19.46.07 * default values for EPEDBC, ECLUBC are now like in dst production: * ECLUBC = 4.0 * EPEDBC = 10.0 * unless one specifies 'DSTP 0' in the user card. * correct wrong setting of splitoff flags in TTKS word 3: * If the 'particle' is identified as a splitoff, then * the bit 32 is set (that means on most platforms the value is * negative) * +REP,BCPHYS,BCINIT,1-51. *CMZU: 2.03/00 06/04/95 15.50.56 by Christian Voelcker *CMZU: 2.02/00 12/12/94 17.19.06 by F.-H.Heinsius *CMZU: 2.00/05 01/02/93 11.54.08 by F.-H. Heinsius *CMZU: 2.00/00 02/11/92 12.21.30 by F.-H. Heinsius *CMZ : 1.44/00 21/10/92 17.22.33 by F.-H. Heinsius *CMZU: 1.43/00 20/06/91 16.09.11 by F.-H. Heinsius *CMZ : 20/06/91 11.10.43 by F.-H. Heinsius * create dummy 'CLGE' bank for gain corrections from lightpulser * set ECLUBC and EPEDBC to 20 MeV (old value 10 MeV) *CMZU: 1.41/01 24/01/91 15.28.59 by F.-H. Heinsius * get version number from CMZ *CMZ : 1.41/00 19/12/90 23.17.24 by F.-H. Heinsius *CMZ : 1.40/08 04/12/90 14.16.20 by Gunter Folger *CMZ : 1.40/05 04/10/90 11.40.13 by F.-H. HEINSIUS *-- Author : F.-H. HEINSIUS 04/10/90 SUBROUTINE BCINIT ************************************************************************ *** * *** SUBROUTINE BCINIT * *** * *** One time initialization of Constants * *** (incl. Calibration const., bank formats) * *** * *** Created: 20-JUL-1988 F.-H. Heinsius * *** Updated: 24-NOV-1988 F.-H. Heinsius: Add calibration Const. * *** Updated: 11-FEB-1989 F.-H.Heinsius: Pedestal real. * *** Updated: 13-JUL-1989 F.-H. Heinsius: New bank CBTF for FERA * *** thresholds (Ped subtr.) * *** Updated: 06-OCT-1989 F.-H. Heinsius: Check BLOCK DATA * *** Updated: 08-NOV-1989 F.-H. Heinsius: Include SAVE of COMMONs * *** Updated: 04-MAR-1990 F.-H. Heinsius: Change MAXLBC * *** Updated: 11-MAY-1990 F.-H. Heinsius: BCVRTX added. * *** Updated: 13-JUN-1990 F.-H. Heinsius: IVERBC filled (version#) * *** Updated: 22-JUN-1990 F.-H. Heinsius: New MINFBC * *** Updated: 26-OCT-1990 F.-H. Heinsius Init CBBADX common * *** Updated: 19-DEC-1990 F.-H. Heinsius Init VRZOBC(1:2) * *** * *** Arguments: (INPUT,OUTPUT,INPUT/OUTPUT) * *** Expected input: none * *** * *** Final output: COMMON /BCCUTS/,/BCFORM/,/BCSTAT/ * *** banks CBEF,CBEL,CBPF,CBPL (if not existing before) * *** CBTF,CLGE * *** * *** ==>Called by : * *** ==>Calling : * *** * ************************************************************************ &SEQ,CBLINK. &SEQ,CBUNIT. &SEQ,CBLDST. +REP,BCPHYS,BCINIT,58. * for SAVE statement only: +REP,BCPHYS,BCINIT,73-77. CPAM CHARACTER*60 CTIT CPAM INTEGER BCVRSN *** Calibration constants (only for Monte Carlo !!!) *** written to ZEBRA banks. +REP,BCPHYS,BCINIT,87-91. ** Save all BC... COMMON blocks SAVE /BCCUTS/,/BCENER/,/BCFORM/,/BCNBRS/,/BCLOOK/,/BCFLAG/, & /BCSTAT/,/BCVRTX/,/BCBADX/,/BCBCPC/ ** Calibration of Monte Carlo Data (preliminary) +REP,BCPHYS,BCINIT,99. ** Initialize Common /BCCUTS/ +REP,BCPHYS,BCINIT,123-128. * default values are now like in dst production. IF(LDSTCB) THEN EXTLBC = 1.0 ECLUBC = 4.0 EPEDBC = 10.0 ECLSBC = 4.0 ELSE EXTLBC = 1.0 ECLUBC = 20.0 EPEDBC = 20.0 ECLSBC = 4.0 ENDIF ** Initialize Common /BCSTAT/ +REP,BCPHYS,BCINIT,134-138. CPAM WRITE(CTIT,1000) CPAM 1000 FORMAT( CPAM +SEQ,QFTITLE,N=60. CPAM &) CPAM IVERBC = BCVRSN(CTIT,60) +REP,BCPHYS,BCINIT,146-148. ** Initialize Common /BCVRTX/, set default vertex (for MC). ** set both barrel half's z-Alignment to 0 ** set shower penetration length to 9 cm. (from MC studies by Nigel Hessey) +REP,BCPHYS,BCINIT,157. ** fill common /CBBADX/ with default constants (no bad xtals): +REP,BCPHYS,BCINIT,163. ** Show version +REP,BCPHYS,BCINIT,192. 1010 FORMAT(1X, +REP,BCPHYS,BCINIT,198-200. 1020 FORMAT(' CMZ run on ',I6,' at ',I4,'.') ** Check whether BLOCK DATA BCBLCK is filled. +REP,BCPHYS,BCINIT,210-212. ** Initialize Banks for Calibration constants of barrel ** only if they are not yet existing! (all banks real) ** Fill with constants to be used for MC-data +REP,BCPHYS,BCINIT,220. 10 CONTINUE +REP,BCPHYS,BCINIT,229. 20 CONTINUE +REP,BCPHYS,BCINIT,247-248. 30 CONTINUE 40 CONTINUE +REP,BCPHYS,BCINIT,257-261. 50 CONTINUE 60 CONTINUE END IF ** create default bank for lightpulser gain corrections +REP,BCPHYS,BCINIT,267-270. 70 CONTINUE END IF ** Calls to MZFORM for formats of TBEN and TBTK banks /BCFORM/ +REP,BCPHYS,BCTRAK,1-33. *CMZU: 2.02/02 24/02/95 18.04.11 by F.-H.Heinsius *CMZU: 2.02/01 17/01/95 12.37.31 by F.-H.Heinsius *CMZU: 2.01/00 15/07/94 10.04.06 by Christian Voelcker *CMZ : 2.00/06 15/12/92 17.13.35 by Michael Doser *CMZ : 1.40/05 04/10/90 11.40.13 by F.-H. HEINSIUS *-- Author : F.-H. HEINSIUS 04/10/90 SUBROUTINE BCTRAK(IERR) ************************************************************************ *** * *** SUBROUTINE BCTRAK * *** * *** Entry routine to crystal data reconstruction software * *** * *** * *** Created: 20-JUL-1988 F.-H. Heinsius * *** Updated: 9-FEB-1989 F.-H.Heinsius: Added calls to USEVNT() * *** Modified:18-APR-1989 G.Folger : added checking of logical * *** flags to control which routines are called. Also allow * *** to redo any part of analysis. * *** Updated: 10-JUL-1989 F.-H. Heinsius: Major change: * *** new control flow, put parts of BCALCE in. * *** Updated: 25-JAN-1990 F.-H. Heinsius: Include statistics * *** Modified: 7-FEB-1990 G.Folger : return the error code IERR * *** Modified: 15-Dec-1992 M.Doser: implement Xtal retracking * *** Modified: 17-Jan-1995 FHH: Do not wipe TBEL bank if no RBCL * *** banks exist and 'DECL' is selected * *** * *** * *** Arguments: (INPUT,OUTPUT,INPUT/OUTPUT) * *** Expected input: * *** * *** Final output: * *** * *** ==>Called by : CBPHYS * *** ==>Calling : BCDECF, BCDECL, BCALCE, BCLUST, BCPEDS, USEVNT * *** * ************************************************************************ +REP,BCPHYS,BCTRAK,52-60. ** retracking: wipe the full BCTRAK bank (except TBEL, if needed) IF (RTRKBC) THEN IF (DECLBC.AND.(LRBCL.EQ.0).AND.(LTBEL.NE.0)) THEN * the RBCL bank is not written to DST Tape for pre 1991 data; * from 1991 on we have written zero suppressed 2282 data. LTBEL=0 CALL MZCOPY(IXTBEL,LQ(LHTBC-5), IXHRAW,LTBEL,1,'S') END IF CALL MZWIPE(IXHTBC) END IF ** create top bank for all Xtal reconstruction IF (LHTBC.EQ.0) THEN CALL MZBOOK(IXHTBC,LHTBC,LEVHD,-3,'HTBC',5,5,1,2,0) IQ(LHTBC+1) = IVERBC * save link to TBEL bank, in case RBCL bank is missing. IQ(LHTBC-5) = LTBEL +REP,BCPHYS,BCTRAK,66-71. ** Are there no energies calculated? IF (LTBEN.EQ.0) THEN ** YES -> decode ADCs, calculate energies ** Get the FERA data from raw-data +REP,BCPHYS,BCTRAK,85. ** Get the LeCroy 2282 data from raw-data +REP,BCPHYS,BCTRAK,99-106. ** Calculate calibrated energies from ADC data ** and fill COMMON /BCENER/ from TBEN bank IF (ALCEBC) THEN CALL BCALCE ELSE ** If no energy calulation: ** Clear array containing xtal energies (for safety) +REP,BCPHYS,BCTRAK,115. ** NO -> fill COMMON /BCENER/ from TBEN bank +REP,BCPHYS,BCTRAK,121-125. ** then fill COMMON /BCENER/ from TBEN bank * (ENERBC array EQUIVALENCEd to ENERQ) DO 130 I=2,IQ(LTBEN-1),2 ENERQ( IQ(LTBEN+I) ) = Q(LTBEN+I+1) 130 CONTINUE +REP,BCPHYS,BCTRAK,133. ** Find clusters +REP,BCPHYS,BCTRAK,141. ** Find PEDs +REP,BCPHYS,BCTRAK,149. ** do statistics +REP,BCPHYS,BCTRAK,167. 999 RETURN +REP,BCPHYS,BCTTKS,1-35. *CMZU: 2.02/02 27/02/95 15.29.02 by F.-H.Heinsius *CMZU: 2.00/00 22/11/92 13.17.52 by F.-H. Heinsius *CMZU: 1.43/02 10/07/91 12.25.06 by F.-H. Heinsius *CMZ : 1.43/01 05/07/91 11.47.50 by F.-H. Heinsius *CMZ : 05/07/91 11.13.40 by F.-H. Heinsius * fix bug in dPx,dPy,dPz calculation *CMZ : 1.40/08 04/12/90 14.20.27 by Gunter Folger * adapt to GTRAK version 1.20/00 onwards *CMZ : 1.40/05 04/10/90 11.40.19 by F.-H. HEINSIUS *-- Author : F.-H. HEINSIUS 04/10/90 SUBROUTINE BCTTKS(JTTKS,DE) ************************************************************************ *** * *** SUBROUTINE BCTTKS (JTTKS,DE) * *** * *** This subroutine calculates the errors of the direction * *** cosines, direction angles and energy and fills these * *** values in the TTKS bank pointed to * *** by the link JTTKS. * *** DE is the relative energy resolution multiplied by 4th root E * *** e.g. 0.03 for sigE/E = 0.03 / sqrt(sqrt(1000)) * *** * *** Created: 13-SEP-1990 F.-H. Heinsius * *** * *** Arguments: (INPUT,OUTPUT,INPUT/OUTPUT) * *** Expected input: * *** DE = relative energy resolution multiplied by 4th root E * *** 0.03 for data, 0.02 for Monte Carlo * *** IQ(JTTKS+11,15,39,40) * *** Final output: * *** IQ(JTBTK+19,20,21,22,23,42-47) * *** * *** ==>Called by : user for old DST's * *** ==>Calling : * *** * ************************************************************************ +REP,BCPHYS,BCTTKS,69. REAL RPHI(3,2,2),RTHE(3,2,2), E +REP,BCPHYS,BCTTKS,83-90. ** not for JDC-data IF (IQ(JTTKS+2).EQ.1) RETURN ** calculate errors of direction cosines and energy IF (LTBTK.NE.0) THEN IF(BTEST(IQ(LTBTK),3)) THEN ** for RG method +REP,BCPHYS,BCTTKS,136-139. 100 CONTINUE ** Error of energy ** dE/E = DE / (E[GeV])**(1/4) +REP,BCPHYS,BCTTKS,160. ** dZ = sqrt (1 - z**2) dTHETA +REP,BCPHYS,BCTTKS,170-180. ** dY = sqrt (y**2 z**2/(1-z**2) dTHE**2 + x**2 dPHI**2) DY = SQRT ( (Y * DTHE)**2 * Z1 + & (X *DPHI)**2 ) ** dX = sqrt (x**2 z**2/(1-z**2) dTHE**2 + y**2 dPHI**2) DX = SQRT ( (X * DTHE)**2 * Z1 + & (Y *DPHI)**2 ) ** Error of momentum +REP,BCPHYS,BSMART,1-37. *CMZU: 2.02/03 07/03/95 16.59.27 by F.-H.Heinsius * fix array out of bounds bug for 1-PED events. *CMZU: 2.02/02 27/02/95 15.29.55 by F.-H.Heinsius *CMZU: 1.43/08 12/03/92 11.20.35 by Juergen Salk *-- Author : Juergen Salk 12/03/92 SUBROUTINE BSMART(IPCODE,NREAL,NAMBI,NSOFF) ************************************************************************ * subroutine bsmart: Finds out split-offs and flags the PEDs * * Version 1.00 12-Dec-91 * * Author: Juergen Salk * ************************************************************************ * * * This is the main subroutine of SMART. * * The routine decides whether a PED is a split-off * * or not (with respect to the showermass and the * * topology of the parent cluster). * * If you use BSMART, do not forget to run BCTRAK !!! * * * * Called by: USER * * Subroutine calls: BCNXTP,BCOSC2 * * * * Expected input: Nothing * * Final output: * * ipcode(TBTK id) = 0, if PED is definitely due to a real photon * * = 1, if PED is definitely a split-off * * = 2, if PED is ambiguous (i.e. dubious) * * nreal = Number of correct PEDs (ipcode = 0) * * nambi = Number of ambiguous PEDs (ipcode = 2) * * nsoff = Number of split-off PEDs (ipcode = 1) * ************************************************************************ C Commons &SEQ,CBLINK. C C Variable declaration C INTEGER I,ITBTK,JTBTK,IPNXT,ICLNXT,IPCODE(50),NREAL,NAMBI,NSOFF, & NXTAL,NPPCL(50),NPCLU +REP,BCPHYS,BSMART,44-47. C Parameters for SMART cuts (MC results) C -------------------------------------- C C --> for ordinary clusters: +REP,BCPHYS,BSMART,62. C --> for pseudo-clusters: +REP,BCPHYS,BSMART,79-84. C New event: reset all values C DO 10 I=1,50 IPCODE(I) = 0 NPPCL(I) = 0 10 CONTINUE +REP,BCPHYS,BSMART,99-104. C First count number of peds in the clusters. nppcl(i) is the C number of peds in the cluster with TBCL-id i. C JTBTK = LTBTK IF (JTBTK .NE. 0) JTBTK = LQ(LTBTK-1) 20 IF (JTBTK .NE. 0) THEN +REP,BCPHYS,BSMART,110-118. C Now we loop over all peds and calculate SMART cuts. C JTBTK = LTBTK IF (JTBTK .NE. 0) JTBTK = LQ(LTBTK-1) 100 IF (JTBTK .NE. 0) THEN NPCLU = NPPCL(IQ(JTBTK+3)) C C Single peds are considered later, we take next ped. +REP,BCPHYS,BSMART,129. C MC shows, that it is reasonable to consider only peds with extal<=50MeV. +REP,BCPHYS,BSMART,167-174. C Ok! We have calculated the cuts according to the topology of the clusters. C C C We will now determine the ipcode of the ped. C IF (RMASS .LT. SMLOW) THEN C C --> This ped is definitely a split-off +REP,BCPHYS,BSMART,186. C --> This ped is dubious +REP,BCPHYS,BSMART,196-211. 110 JTBTK = LQ(JTBTK) GOTO 100 END IF C C Ok, we just finished clusters with 2 or more peds. C C ------------------------------------------------------------------- C C Now we look for 1-ped-clusters. C JTBTK = LTBTK IF (JTBTK .NE. 0) JTBTK = LQ(LTBTK-1) 200 IF (JTBTK .NE. 0) THEN C C If this is not a single ped, we take the next one ! +REP,BCPHYS,BSMART,221-241. C MC shows, that it is reasonable to do the following preselection C IF ((EXTAL .LE. 30.) .AND. (NXTAL .LT. 6)) THEN C C Look for the closest ped C CALL BCNXTP(IQ(JTBTK-5),IPNXT,ICLNXT,COANGL) C C Continue on error (only one PED in event) FHH 7.3.95 C IF (IPNXT.EQ.0) GOTO 210 C C Pointer to ped ipnxt C ITBTK = LQ(LTBTK-IQ(LTBTK-2)-IPNXT) NPCLU = NPPCL(IQ(ITBTK+3)) C Now npclu is the number of (real) peds in the closest cluster! C C Now we calculate invariant showermass of the resulting pseudo-cluster C CALL BCOSC2(IQ(JTBTK+3),ICLNXT,ECLU,RX,RY,RZ,RMASS) C C Now we calculate the SMART cuts. +REP,BCPHYS,BSMART,278-286. C Ok! We have calculated the cuts according to the topology of the clusters. C C C We will now determine the ipcode of the ped. C IF (RMASS .LE. SMLOW) THEN C C --> This ped is definitely a split-off +REP,BCPHYS,BSMART,298. C --> This ped is dubious +REP,BCPHYS,BSMART,308-313. 210 JTBTK = LQ(JTBTK) GOTO 200 END IF C C WOW! Now we are ready to go on with the further analysis. +REP,BCPHYS,BCNPED,1-32. *CMZU: 2.02/02 27/02/95 15.27.25 by F.-H.Heinsius *CMZU: 2.00/06 24/02/93 12.08.51 by Unknown *CMZU: 2.00/00 13/11/92 19.05.26 by F.-H. Heinsius *-- Author : R. Glantz 04/11/92 SUBROUTINE BCNPED(NUMPED,INRBS,IMXTL,IPHI,ITHE,RENPED,REN, & RX,RY,RZ) ************************************************************************ *** * *** SUBROUTINE BCNPED * *** * *** The subroutine determines the direction cosines for the * *** given PED NUMPED. The refined gravity method is used. * *** Note that this is enabled with flag 'PDRG' * *** * *** cubic ansatz for parametrization: 1 1 1 * *** 2 2 2 etc. * *** 3 3 3 * *** * *** * *** Created: 23-MAY-1991 Rainer Glantz * *** Updated: 2-SEP-1991 rainer glantz * *** Updated: 13-May-1993 FHH * *** Fix small bug in BCNPED concerning xtal type 11. * *** * *** Arguments: (INPUT,OUTPUT,INPUT/OUTPUT) * *** Final output : REAL*4 RX ,RY ,RZ direction cosines of * *** cluster * *** * *** Called by : Subroutine BCPEDS * *** * *** CALLING : SUBROUTINE BCOSXT(IPHI,ITHE,RIX,RIY,RIZ) * *** * ************************************************************************ +REP,BCPHYS,BCNPED,50-58. INTEGER I,IPHIX,ITHEX,IXTLM,IPHIM,ITYPM,JPHI, & IDTH,IDPH,IPARZ,IPARR,IPARQ,IEI,ITHEM,IPHCT REAL RE, & RIX,RIY,RIZ,RIG,RP,RT,RENX,RPARZ,RPARR,RPARQ ** pointer to parametrization for list of neighbours +REP,BCPHYS,BCNPED,104. 25 CONTINUE +REP,BCPHYS,BCNPED,193. 30 CONTINUE +REP,BCPHYS,BCNPED,278. 40 CONTINUE +REP,BCPHYS,BCNPED,346. 50 CONTINUE +REP,BCPHYS,BCNPED,407. 60 CONTINUE +REP,BCPHYS,BCNPED,423. 999 RETURN +REP,BCPHYS,DBCSTO,1-2. *CMZU: 2.03/00 15/03/95 20.41.31 by Christian Voelcker *CMZU: 2.02/02 24/02/95 18.08.24 by F.-H.Heinsius *CMZU: 2.00/04 22/01/93 15.39.06 by F.-H. Heinsius *-- Author : +ADD,BCPHYS,DBCSTO,34. C Modified by F.-H. Heinsius, 24-2-1995: Do not fill word 53 (used for TAXI) C Modified by C. Voelcker, 6-3-1995: Fill the word 3 (splitoff flags) +REP,BCPHYS,DBCSTO,48-51. INTEGER QUALTY PARAMETER (QUALTY= 52) INTEGER JTTKS C C------------------------------------------------------------------------------- +REP,BCPHYS,DBCSTO,76-78. JTTKS=LGTRAK(I) IQ(JTTKS + QUALTY) = GTTYPE(I) IF(GTTYPE(I).GT.0) THEN CALL SBIT1(IQ(JTTKS+3),32) ! mark as splitoff CALL SBIT1(IQ(JTTKS+3),1) ! set dolby-c flag ENDIF 100 CONTINUE +ADD,BCPHYS,BSMSTO,*. &DECK,BSMSTO. *CMZU: 2.03/00 15/03/95 20.46.39 by Christian Voelcker *CMZU: 2.02/01 17/01/95 15.23.26 by Christian Voelcker *-- Author : Christian Voelcker 12/01/95 SUBROUTINE BSMSTO(IPCODE) IMPLICIT NONE **************************************************** * * Creation date: January, 12th 1995 * * References: none * * Description: write the Dolby-C results into the TTKS bank as follows * * TTKS word 3 = negative, if the ped is found to be a splitoff. * set bit 2 if it is definitely an electromagnetic splitoff * identified by SMART * TTKS word 54 = SMART return code for this PED. * 0 if PED is definitely due to a real photon * 1 if PED is definitely a split-off * 2 if PED is ambiguous (i.e. dubious) * * TTKS word 55 we cannot fill. No information on parent PED is given * from SMART. * IEHDCB(12) should contain the number of *good* gammas, but we need to * know the total number of splitoffs before (DOLBYC, etc.). * * Input Parameter: IPCODE(50) array for all PEDs in the TBTK (!!!) bank * which should be filled in calling BSMART * IPCODE(I) = 0 for good gammas * IPCODE(I) = 1 definitely splitoff * IPCODE(I) = 2 ambiguous * * Modifications: 15/03/95 Christian Voelcker * set bit 32 in JTTKS+3 * **************************************************** * &SEQ,CBLINK. INTEGER IPCODE(50) INTEGER I INTEGER NPED INTEGER JTTKS INTEGER ITBTK ! TBTK id * * only loop over all unmatched PEDs, if any.. NPED = IQ(LTTKS+3) IF (NPED.EQ.0) RETURN DO I=1, NPED JTTKS = LQ(LTTKS-IQ(LTTKS-2)-IQ(LTTKS+2)-I) ITBTK = IQ(JTTKS+7) IQ(JTTKS+54) = IPCODE(ITBTK) * is this a splitoff candidate? IF(IPCODE(ITBTK).GT.0) THEN CALL SBIT1(IQ(JTTKS+3),32) ! mark as splitoff CALL SBIT1(IQ(JTTKS+3),2) ! set smart flag ENDIF ENDDO RETURN END