*-- Author : Stephen Burke
SUBROUTINE FFOUT(JTR,NPS,NRS)
*-----------------------------------------Updates 22/11/93-------
**: FFOUT.......SB. New parameters in call.
**: FFOUT.......SB. New monitoring histograms.
**: FFOUT.......SB. Fix FTPR bug.
*-----------------------------------------Updates 27/07/93-------
**: FFOUT 30907 SB. Changes to monitoring histograms.
**: FFOUT 30907 RP. Farm changes.
*-----------------------------------------Updates 03/03/93-------
**: FFOUT 30907 SB. Module mask in LS 6 bits of word 20 of FTKR.
**: FFOUT 30907 SB. New monitoring histograms.
*-----------------------------------------Updates 30/11/92-------
**: FFOUT 30907 SB. Call new track rejection routine FFKILL.
**: FFOUT 30907 SB. New monitoring histograms.
*-----------------------------------------Updates 06/08/92-------
**: FFOUT 30907 SB. New monitoring histograms.
*-----------------------------------------Updates 03/06/92-------
**: FFOUT 30907 SB. Empty banks made here instead of in FFFIT.
**: FFOUT 30907 SB. Protect against large chi-squared.
**: FFOUT 30907 SB. Vertex fit stuff removed.
*-----------------------------------------Updates 02/06/92-------
**: FFOUT 30907 SB. Protect against divide by 0.
*-----------------------------------------Updates 28/04/92-------
**: FFOUT 30907 SB. FTKX now added to E-list in FTREC for debug.
*-----------------------------------------Updates 13/02/92-------
**: FFOUT 30205.SB. Bug fix (NDF now correct if LRISV is .TRUE.)
**: FFOUT 30205.SB. ERRLOG error numbers changed.
*-----------------------------------------Updates 07/02/92-------
**: FFOUT 30205.SB. Remove unused FKMEAS sequence.
*-----------------------------------------Updates 24/01/92-------
**: FFOUT 30205.SB. Count failures.
**: FFOUT 30205.SB. Better handling of errors with missing banks.
**: FFOUT 30205.SB. ERRLOG message format changed.
**: FFOUT 30205.SB. Add some new histograms, with new numbering.
*-----------------------------------------Updates----------------
**********************************************************************
* *
* Create output banks for the Kalman filtered tracks *
* *
**********************************************************************
LOGICAL BKOPEN,BKERR,FFKILL,LGOOD
SAVE BKOPEN,BKERR,JROW,NFRPE,NFRRE,NPHIT,NRHIT
DIMENSION VEC(21),IVEC(21),IFP(2),NP(2),NHPS(3,2),NHPO(3,3)
EQUIVALENCE (VEC,IVEC)
*KEEP,FKNPL.
CHARACTER*5 CKDBG
PARAMETER (CKDBG='FKDBG')
PARAMETER (NPL=72)
LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
&, SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
&, RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
COMMON /H1WORK/
* /FKPROJ/
& SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
&, SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
&, SSMT(5,NPL),CSMT(5,5,NPL)
&, SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
&, DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
&, QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
&, RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
&, CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
&, CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
&, TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
&, LTRPL(NPL),LTRPLD(NPL)
*KEEP,FFSTEE.
PARAMETER (NFT=72)
LOGICAL LRISV,LWMAP,LGRAPH,LTRUTH
REAL DSX,DSY,DSQOP,DSTTH,DSPHI,PMCUT,PCUT,CHPCUT
&, QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
COMMON /FFSTEE/ DSX,DSY,DSQOP,DSTTH,DSPHI
&, PMCUT,IDIAG,JPLRSV,LRISV,LWMAP(NFT),JPLMAX
&, IRP(NPL),JPLFT(NPL),JFTPL(NFT)
&, LUNGKS,IWKGKS,IDGKS,LUNHB,LUNGKM,IWKGKM,IDGKM
&, LGRAPH,LTRUTH,IHFF,IHFK,ISRJCT,PCUT,CHPCUT
&, QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
*KEEP,FFSCAL.
* Counters
PARAMETER (NSCAL=145)
COMMON /FFSCAL/ NPFAIL,NRFAIL,NXFAIL,NFFAIL,NMFAIL,NBFAIL,NTFAIL
&, NWFAIL,NNSPLT,NNMISS,NNMISP
&, NQFAIL,NAFAIL,NOFAIL,NIFAIL
&, NTRIN,NTROUT,NPRSEG(0:7,0:7),N23SEG(0:7,0:7)
*KEEP,FFWBI.
* Work bank indices (note that INDKTR is *NOT* a work bank index!)
PARAMETER (NWBI=10)
COMMON /FFWBI/ INDRSX(2),INDX(2),INDKX(2),INDPUR
&, INDKTR,INDKTX,INDTPR
*KEEP,FFGEO.
COMMON /FFGEO/ INDG1(2),INDLC(2),IDIGI(NPL)
*KEEP,FKFLAG.
LOGICAL LPRO,LFIL,LSMT,LMES,LRAD,LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
COMMON /FKFLAG/ LPRO(NPL),LFIL(NPL),LSMT(NPL),LMES(NPL)
&, LRAD(NPL),LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
*KEEP,FKCONS.
DOUBLE PRECISION ZPL,DZPL,RADL
COMMON /FKCONS/ ZPL(NPL),DZPL(NPL),RADL(NPL)
*KEEP,FKMEAS.
DOUBLE PRECISION WMES,CMES,HMES
COMMON /FKMEAS/ WMES(2,NPL),CMES(2,2,NPL),HMES(2,2,NPL),MES(NPL)
*KEEP,FKSMTH.
*KEEP,FKRSID.
*KEEP,FTHIST.
* indices of filter farm histos
COMMON/FTHIST/IHP(100)
*KEEP,FKPIDP.
DOUBLE PRECISION PI,TWOPI,PIBY2
PARAMETER (PI=3.141592653589793238)
PARAMETER (TWOPI=PI*2.0D0,PIBY2=PI/2.0D0)
*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/
*KEEP,BOSMDL.
C ------BOSMDL
LOGICAL BEGJOB,ENDRUN,BEGRUN,REVENT,ENDJOB,OTHDAT
COMMON/BOSMDL/BEGJOB,ENDRUN,BEGRUN,REVENT,ENDJOB,OTHDAT,
+ LCCRUN,NCCRUN,NEVENT,
+ IHA,IBS,IDB,IDATEL,LUP,ISN,JSN
SAVE /BOSMDL/
C ------
*KEEP,FTFUNCT.
* Statement functions for RADIAL Chamber data access.
* Using Channel Number J
* Module, Wedge-pair and Z-plane numbers...
IRMOD(J) = J/288
IRWDP(J) = (J-IRMOD(J)*288)/12
IRZPL(J) = J-IRMOD(J)*288-IRWDP(J)*12
* Statement function for obtaining WEDGE numbers(0-47) of
* wires at plus and minus ends of Cell numbers
IRWPL(J) = (IRWDP(J)/2)*4 + (MOD(IRWDP(J),2))
IRWMI(J) = MOD(IRWPL(J) + 34,48)
* Statement function for obtaining IOS wire number (1-36)
IRIOSW(J) = IRMOD(J)*12 + IRZPL(J) + 1
* Statement functions for PLANAR Chamber data access.
* Using Channel Number J
* Module, orientation, W-cell and Z-plane numbers...
IPMOD(J) = J/384
IPORI(J) = (J-IPMOD(J)*384)/128
IPWCL(J) = (J-IPMOD(J)*384-IPORI(J)*128)/4
IPZPL(J) = (J-IPMOD(J)*384-IPORI(J)*128-IPWCL(J)*4)
* IPSMD in range 0:8 Planar module number.
IPSMD(J) = IPMOD(J)*3 + IPORI(J)
*
* IOS wire number (runs from 0 to 36)
IPIOSW(J) = IPSMD(J)*4 + IPZPL(J) + 1
* SB plane numbers (1-72) from cell number
IPSBW(J) = 24*IPMOD(J) + 4*IPORI(J) + IPZPL(J) + 1
IRSBW(J) = 24*IRMOD(J) + IRZPL(J) + 13
* Module, orientation, wire and (typical) cell number from plane
* number in the range 1-72 (planars, radials and combined)
IPMSB(J) = (J - 1)/24
IPOSB(J) = (J - 24*IPMSB(J) - 1)/4
IPZSB(J) = J - 24*IPMSB(J) - 4*IPOSB(J) - 1
IPCLSB(J) = 384*IPMSB(J) + 128*IPOSB(J) + IPZSB(J)
IRMSB(J) = (J - 1)/24
IRZSB(J) = J - 24*IRMSB(J) - 13
IRCLSB(J) = 288*IRMSB(J) + IRZSB(J)
IRADSB(J) = (J - 24*((J-1)/24) - 1)/12
ICELSB(J) = IRADSB(J)*IRCLSB(J) + (1 - IRADSB(J))*IPCLSB(J)
*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.
DATA BKOPEN/.TRUE./,BKERR/.FALSE./
**********************************************************************
NPS = 0
NRS = 0
* If work bank creation failed we junk all the tracks for this event
IF (BKERR) THEN
IF (JTR.LE.0) BKERR = .FALSE.
RETURN
ENDIF
IF (BKOPEN) THEN
JROW = 1
* Zero work bank indices
INDTPR = 0
INDKTX = 0
INDKX(1) = 0
INDKX(2) = 0
* Work banks for pointer lists ...
NFRPE = IW(INDLC(1)+2)
CALL WBANK(IW,INDKX(1),2*NFRPE+2,*2000)
CALL VZERO(IW(INDKX(1)+1),2*NFRPE+2)
IW(INDKX(1)+1) = 2
IW(INDKX(1)+2) = NFRPE
NFRRE = IW(INDLC(2)+2)
CALL WBANK(IW,INDKX(2),2*NFRRE+2,*2000)
CALL VZERO(IW(INDKX(2)+1),2*NFRRE+2)
IW(INDKX(2)+1) = 2
IW(INDKX(2)+2) = NFRRE
BKOPEN = .FALSE.
NTGOOD = 0
NPHIT = 0
NRHIT = 0
ENDIF
IF (JTR.LE.0) THEN
* Close banks ...
BKOPEN = .TRUE.
IF (JROW.GT.1) THEN
INDKTR = IADFIN('FTKR',0)
INFTKX = IADFIN('FTKX',0)
INDTPR = IADFIN('FTPR',0)
IF (INDKTR.LE.0 .OR. INFTKX.LE.0 .OR.
& INDTPR.LE.0) GOTO 2000
ELSE
* Banks are made even if there are no tracks
INDKTR = NBANK('FTKR',0,2)
IF (INDKTR.LE.0) GOTO 2000
IW(INDKTR+1) = 21
IW(INDKTR+2) = 0
CALL WBANK(IW,INDKTX,2,*2000)
IW(INDKTX+1) = 1
IW(INDKTX+2) = 0
CALL BKFRW(IW,'FTKX',0,IW,INDKTX,*2000)
CALL WBANK(IW,INDTPR,2,*2000)
IW(INDTPR+1) = 4
IW(INDTPR+2) = 0
CALL BKFRW(IW,'FTPR',0,IW,INDTPR,*2000)
ENDIF
* Pack work banks into named banks...
CALL BKFRW(IW,'FTPX',0,IW,INDKX(1),*2000)
CALL BKFRW(IW,'FTRX',0,IW,INDKX(2),*2000)
* Add banks to the E list ...
CALL BLIST(IW,'E+','FTKR')
CALL BLIST(IW,'E+','FTPR')
CALL BLIST(IW,'E+','FTPX')
CALL BLIST(IW,'E+','FTRX')
* Fill monitoring histograms
CALL SHS(1,0,FLOAT(NTGOOD))
IF (NTGOOD.GT.0) THEN
IF (NFRPE.GT.0) CALL SHS(15,0,FLOAT(NPHIT)/FLOAT(NFRPE))
IF (NFRRE.GT.0) CALL SHS(16,0,FLOAT(NRHIT)/FLOAT(NFRRE))
ENDIF
IF (MOD(NEVENT,10).NE.0) GOTO 9000
DO 50 JDIG=1,IW(INDKX(1)+2)
ICELL = IBTAB(INDLC(1),1,JDIG)
IF (IBTAB(INDKX(1),1,JDIG).NE.0) GOTO 50
CALL SHD(73,0,IPWCL(ICELL)+0.5,IPIOSW(ICELL)-0.5)
50 CONTINUE
DO 60 JDIG=1,IW(INDKX(2)+2)
ICELL = IBTAB(INDLC(2),1,JDIG)
IF (IBTAB(INDKX(2),1,JDIG).NE.0) GOTO 60
IF (IAND(IBTAB(INDLC(2),6,JDIG),1).EQ.0) THEN
CALL SHD(74,0,IRWPL(ICELL)+0.5,IRIOSW(ICELL)-0.5)
ELSE
CALL SHD(74,0,IRWMI(ICELL)+0.5,IRIOSW(ICELL)-0.5)
ENDIF
60 CONTINUE
GOTO 9000
ENDIF
*
* Loop over planes to find chisq and first digi
*
CHISQ = 0.
NDF = 0
J1 = 0
IMAP = 0
CALL VZERO(IFP,2)
CALL VZERO(NP,2)
CALL VZERO(NHPS,6)
CALL VZERO(NHPO,9)
DO 100 JPL=1,JPLMAX
IF (LMES(JPL)) THEN
ISMOD = (JPLFT(JPL) + 23)/24
IORI = MOD((JPLFT(JPL)-1)/4,3) + 1
CALL SBIT1(IMAP,ISMOD+3*(2-IRP(JPL)))
NHPS(ISMOD,IRP(JPL)) = NHPS(ISMOD,IRP(JPL)) + 1
IF (IRP(JPL).EQ.1)
& NHPO(IORI,ISMOD) = NHPO(IORI,ISMOD) + 1
CHISQ = CHISQ + CHISMT(JPL)
NDF = NDF + MES(JPL)
NP(IRP(JPL)) = NP(IRP(JPL)) + 1
IF (J1.EQ.0) J1 = JPL
J2 = JPL
IF (IFP(IRP(JPL)).EQ.0 .AND.
& IBTAB(INDKX(IRP(JPL)),1,ABS(IDIGI(JPL))).EQ.0)
& IFP(IRP(JPL)) = ABS(IDIGI(JPL))
ENDIF
100 CONTINUE
* Get secondary/tertiary segment flag from NHPO
IMAPST = 0
IMAPRR = 0
DO 400 JSM=1,3
IF (NHPS(JSM,1).GT.0) THEN
DO 450 JORI=1,3
IF (NHPO(JORI,JSM).EQ.0) THEN
CALL SBIT1(IMAPST,JSM+9)
ELSEIF (NHPO(JORI,JSM).LT.3) THEN
CALL SBIT1(IMAPST,JSM+6)
ENDIF
450 CONTINUE
ENDIF
IQRR = (NHPS(JSM,2) - 4)/2
IF (IQRR.LT.0) IQRR = 0
IF (IQRR.GT.3) IQRR = 3
IMAPRR = IMAPRR + IQRR*(4**(JSM+2))
400 CONTINUE
IF (LRISV) NDF = NDF - 5
IF (NP(1)+NP(2).LE.0) THEN
CALL ERRLOG(331,'W:FFOUT: Track with no measurements')
NFFAIL = NFFAIL + 1
RETURN
ENDIF
* PROB isn't very accurate for small probabilities
IF (CHISQ/FLOAT(NDF).LT.20.) THEN
CHP = PROB(CHISQ,NDF)
ELSE
CHP = 1.0E-10
ENDIF
IF (CHP.LT.CHPCUT .OR. CHISQ.GT.100.*FLOAT(NDF)) THEN
NXFAIL = NXFAIL + 1
RETURN
ENDIF
* Kill off bad tracks
IF (FFKILL(J1,J2)) RETURN
* Convert start vector to output format ...
CALL FKITOE(ZPL(J1),SSMT(1,J1),CSMT(1,1,J1),VEC)
*
* Fill monitoring histograms
*
JPS = IMAP/8
JRS = IMAP - JPS*8
NPRSEG(JPS,JRS) = NPRSEG(JPS,JRS) + 1
JP3 = IMAPST/512
JP2 = IMAPST/64 - JP3*8
N23SEG(JP2,JP3) = N23SEG(JP2,JP3) + 1
NPS = JBIT(IMAP,4) + JBIT(IMAP,5) + JBIT(IMAP,6)
NRS = JBIT(IMAP,1) + JBIT(IMAP,2) + JBIT(IMAP,3)
IF (NPS.GE.1 .OR. NRS.GE.2) THEN
LGOOD = .TRUE.
NTGOOD = NTGOOD + 1
ELSE
LGOOD = .FALSE.
GOTO 1000
ENDIF
NPHIT = NPHIT + NP(1)
NRHIT = NRHIT + NP(2)
CALL SHS(2,0,FLOAT(NP(1)))
CALL SHS(3,0,FLOAT(NP(2)))
IF (IDB.GT.1) CALL SHD(64,0,VEC(3),FLOAT(NP(1)+NP(2)))
CALL FFHTHS(J1,J2,NPS,IMAP)
CALL SHS(7,0,VEC(2))
CALL SHS(8,0,VEC(3))
CALL SHS(9,0,SNGL(SSMT(3,J2)))
IF (SSMT(3,J2).NE.0.0D0) THEN
CALL SHS(10,0,-LOG10(ABS(SNGL(SSMT(3,J2)))))
ELSE
CALL SHS(10,0,3.)
ENDIF
CALL SHS(11,0,SQRT(VEC(4)**2+VEC(5)**2))
CALL SHS(12,0,ATAN2(VEC(5),VEC(4)))
IF (NHPS(1,1).GT.0) CALL SHS(17,0,FLOAT(NHPS(1,1)))
IF (NHPS(2,1).GT.0) CALL SHS(17,0,FLOAT(NHPS(2,1))+12)
IF (NHPS(3,1).GT.0) CALL SHS(17,0,FLOAT(NHPS(3,1))+24)
IF (NHPS(1,2).GT.0) CALL SHS(18,0,FLOAT(NHPS(1,2)))
IF (NHPS(2,2).GT.0) CALL SHS(18,0,FLOAT(NHPS(2,2))+12)
IF (NHPS(3,2).GT.0) CALL SHS(18,0,FLOAT(NHPS(3,2))+24)
CALL SHS(19,0,FLOAT(IMAP))
CALL SHS(20,0,FLOAT(IMAPST/64))
CALL SHS(51,0,CHISQ/FLOAT(NDF))
CALL SHS(52,0,CHP)
IF (VEC(1).NE.0.0) THEN
CALL SHS(53,0,VEC(8)/ABS(VEC(1)))
ELSE
CALL SHS(53,0,0.)
ENDIF
CALL SHS(54,0,VEC(10))
CALL SHS(55,0,SQRT(ABS(VEC(11)**2+VEC(12)**2)))
IF (IDB.GT.1) THEN
CALL SHS(56,0,SNGL(ZPL(J2))-VEC(6))
CALL SHD(59,0,VEC(4),VEC(5))
CALL SHD(63,0,FLOAT(NP(1)),FLOAT(NP(2)))
ENDIF
1000 CONTINUE
* ... fill in the other entries ...
IVEC(17) = NDF
VEC(18) = CHISQ
IVEC(19) = 2*JROW
IVEC(20) = 65536*(NP(1) + 256*NP(2)) + IMAPST + IMAP
IVEC(21) = JROW
* ... and fill another row in the banks
INDKTR = IADROW('FTKR',0,21,VEC)
INFTKX = IADROW('FTKX',0,1,JTR)
* Convert end vector to output format ...
CALL FKITOE(ZPL(J2),SSMT(1,J2),CSMT(1,1,J2),VEC)
IF (LGOOD) THEN
IF (IDB.GT.1) THEN
CALL SHD(60,0,VEC(4),VEC(5))
CALL SHS(61,0,SQRT(VEC(4)**2+VEC(5)**2))
CALL SHS(62,0,ATAN2(VEC(5),VEC(4)))
ENDIF
ENDIF
IVEC(19) = -1
IVEC(20) = 65536*(NP(1) + 256*NP(2)) + IMAPRR + IMAP
INDKTR = IADROW('FTKR',0,21,VEC)
JROW = JROW + 1
* Fill FTPR row
IVEC(1) = NP(2)
IVEC(2) = IFP(2)
IVEC(3) = NP(1)
IVEC(4) = IFP(1)
* Now fill appropriate rows of FTRX and FTPX banks
DO 200 JPL=JPLMAX,1,-1
IF (LMES(JPL)) THEN
JDIG = ABS(IDIGI(JPL))
IF (IBTAB(INDKX(IRP(JPL)),1,JDIG).NE.0) THEN
IVEC(5-2*IRP(JPL)) = IVEC(5-2*IRP(JPL)) - 1
CALL ERRLOG(332,'W:FFOUT: Digi used twice')
ELSE
IF (IDIGI(JPL).GE.0) THEN
IW(INDCR(INDKX(IRP(JPL)),2,JDIG)) = 0
ELSE
IW(INDCR(INDKX(IRP(JPL)),2,JDIG)) = 1
ENDIF
IW(INDCR(INDKX(IRP(JPL)),1,JDIG)) = IFP(IRP(JPL))
IFP(IRP(JPL)) = JDIG
ICELL = IBTAB(INDLC(IRP(JPL)),1,JDIG)
IF (LGOOD .AND. MOD(NEVENT,10).EQ.0) THEN
IF (NPS.GE.2) THEN
IF (IRP(JPL).EQ.1) THEN
CALL SHD(71,0,IPWCL(ICELL)+0.5,IPIOSW(ICELL)-0.5)
ELSEIF (IAND(IBTAB(INDLC(2),6,JDIG),1).EQ.0) THEN
CALL SHD(72,0,IRWPL(ICELL)+0.5,IRIOSW(ICELL)-0.5)
ELSE
CALL SHD(72,0,IRWMI(ICELL)+0.5,IRIOSW(ICELL)-0.5)
ENDIF
ENDIF
IF (IRP(JPL).EQ.1) THEN
CALL SHD(85,0,IPWCL(ICELL)+0.5,IPIOSW(ICELL)-0.5)
ELSEIF (IAND(IBTAB(INDLC(2),6,JDIG),1).EQ.0) THEN
CALL SHD(86,0,IRWPL(ICELL)+0.5,IRIOSW(ICELL)-0.5)
ELSE
CALL SHD(86,0,IRWMI(ICELL)+0.5,IRIOSW(ICELL)-0.5)
ENDIF
ENDIF
ENDIF
ENDIF
200 CONTINUE
* Fill pointering bank
INDTPR = IADROW('FTPR',0,4,IVEC)
RETURN
2000 CONTINUE
CALL ERRLOG(333,'S:FFOUT: Error while using work bank')
INFTUR = NLINK('FTUR',0)
IF (INFTUR.GT.0) NWFAIL = NWFAIL + IW(INFTUR+2)
IF (JTR.LE.0) THEN
* If we run out of space all banks are deleted
IF (NLINK('FTKR',0).GT.0) CALL NDROP('FTKR',0)
IF (NLINK('FTKX',0).GT.0) CALL NDROP('FTKX',0)
IF (NLINK('FTPR',0).GT.0) CALL NDROP('FTPR',0)
IF (NLINK('FTPX',0).GT.0) CALL NDROP('FTPX',0)
IF (NLINK('FTRX',0).GT.0) CALL NDROP('FTRX',0)
ELSE
* Set flag to ignore all tracks
BKERR = .TRUE.
ENDIF
9000 CONTINUE
*
* Drop all work banks
*
IF (JROW.LE.1) THEN
CALL WDROP(IW,INDTPR)
CALL WDROP(IW,INDKTX)
ENDIF
CALL WDROP(IW,INDKX(1))
CALL WDROP(IW,INDKX(2))
RETURN
END
*