C   12/08/87 708121047  MEMBER NAME  TRKBSE   (S)           FORTRAN77
      SUBROUTINE TRKBSE(IPN,IALGN,EBISE)
C
C
C   COPIED FROM F11HEL.ES(TRKBSE)
C
C   UEBERNOMMEN VON  F11MEI.SHOWS(TRKBLK)
C
C             CALCULATING IMPACT POINT ON LG SURFACE
C             SUM UP ENERGIY IN BLOCKS STRUCK BY TRACK
C
C                                                 16/01/1985
C
      IMPLICIT INTEGER*2 (H)
C
#include "cdata.for"
#include "cgeo1.for"
C
C     COMMON /LINK/   IBLCHK,IREG,NBLK,NBLE,XI,YI,ZI,XF,YF,ZF,XSTART,
C    *                YSTART,ZSTART,PSTART,TRKL(2,50),TRITER,EBITER,
C    *                PMAG,NNEW,NENEW,NLIST(40),ENEW,ICHARG(40,20),
C    +                NBLO,MEICL(50),NEICL(50)
      COMMON /LISE/   IBLCSE,NBSK,NBSE,XSI,YSI,ZSI,XSF,YSF,ZSF,XSTAST,
     *                YSTAST,ZSTAST,PSTAST,TRSE(3,50),TRISE
      DIMENSION IRSE(3,50)
      EQUIVALENCE(IRSE(1,1),TRSE(1,1))
      DIMENSION ALIST(3,50),BLIST(3,50),TSURF(3,12)
      DIMENSION POS1(25),POS2(25)
      DIMENSION X(3),V(3)
      EQUIVALENCE (XSI,X(1)),(YSI,X(2)),(ZSI,X(3))
      EQUIVALENCE (UI,V(1)),(VI,V(2)),(WI,V(3))
      DATA PI/3.14159/, TWOPI/6.283185/
      DATA SIGX,SIGY,SIGZ,SIGP /160.,160.,160.,.08/
      DATA POS1,POS2 /5*0.,5*1.,5*-1.,5*2.,5*-2.,0.,-2.,-1.,1.,2.,0.,
     *-2.,-1.,1.,2.,0.,-2.,-1.,1.,2.,0.,-2.,-1.,1.,2.,0.,-2.,-1.,1.,2./
C
      DATA ICALL/0/
      IF(ICALL.NE.0) GO TO 9999
      ICALL=1
      ZLGEFM=ZLGMI+BLZ
      ZLGEFP=ZLGPL-BLZ
      RBARSQ=RLG**2
      OUTRSQ=OUTR2**2
      RMAG=RCOIL+0.5*DRCOIL
      RMAGSQ=RMAG**2
      DEPENH=0.5*DEPEND
      TSURF( 1, 1)=0.
      TSURF( 1, 2)=   BLXY
      TSURF( 1, 3)=2.*BLXY
      TSURF( 1, 4)=TSURF( 1, 3)+50.
      TSURF( 1, 5)=3.*BLXY
      TSURF( 1, 6)=TSURF( 1, 5)+50.
      TSURF( 1, 7)=4.*BLXY
      TSURF( 1, 8)=TSURF( 1, 7)+50.
      TSURF( 1, 9)=5.*BLXY
      TSURF( 1,10)=TSURF( 1, 9)+50.
      TSURF( 1,11)=6.*BLXY
      TSURF( 1,12)=TSURF( 1,11)+50.
      TSURF( 2, 1)=2.*BLXY+50.
      TSURF( 2, 2)=2.*BLXY
      TSURF( 2, 3)=   BLXY
      TSURF( 2, 4)=0.
      TSURF( 2, 5)=0.
      TSURF( 2, 6)=0.
      TSURF( 2, 7)=0.
      TSURF( 2, 8)=0.
      TSURF( 2, 9)=0.
      TSURF( 2,10)=0.
      TSURF( 2,11)=0.
      TSURF( 2,12)=0.
      TSURF( 3, 1)=6.*BLXY+50.
      TSURF( 3, 2)=6.*BLXY+50.
      TSURF( 3, 3)=6.*BLXY
      TSURF( 3, 4)=   BLXY
      TSURF( 3, 5)=5.*BLXY
      TSURF( 3, 6)=   BLXY
      TSURF( 3, 7)=5.*BLXY
      TSURF( 3, 8)=   BLXY
      TSURF( 3, 9)=4.*BLXY
      TSURF( 3,10)=   BLXY
      TSURF( 3,11)=2.*BLXY
      TSURF( 3,12)=   BLXY
C
 9999 DO 40 ICLR=1,50
      IRSE(1,ICLR)=-1
      TRSE(2,ICLR)=0.
      TRSE(3,ICLR)=0.
   40 CONTINUE
C
      IPNH0=2*IALGN+5
      NWO=IDATA(IALGN)
      MXH=2*(IALGN+NWO)
C
C     DON'T EXTRAPOLATE PATHOLOGICAL TRACKS
C
      IF(IDATA(IPN+24).LT.6.OR.IDATA(IPN+33).LT.6) GOTO 1
C
C     GET R-Z FIT PARAMETERS.
C
      Z0=ADATA(IPN+31)
      ZSL=ADATA(IPN+30)
      OODEM=1./SQRT(1.+ZSL**2)
      WI=    ZSL*OODEM
C
C     FIND RADIUS AND CENTER OF GYRATION IN X,Y PLANE.
C
      ITYPE=IDATA(IPN+18)
      IF(ITYPE.NE.1) GO TO 2
C
C     CIRCLE FIT.
C     GET INITIAL POINT AND DIRECTION IN CASE WE USE THE STRAIGHT
C     LINE APPROXIMATION.
C

      AC=ADATA(IPN+21)
      X0=ADATA(IPN+20)*COS(AC)
      Y0=ADATA(IPN+20)*SIN(AC)
      R0SQ=X0**2+Y0**2
      R0=SQRT(R0SQ)
      A0=AC-PI/2.
      DOT=ADATA(IPN+8)*COS(A0)+ADATA(IPN+9)*SIN(A0)
      IF(DOT.LT.0.) A0=A0+PI
      CROSS=0.
C
      CURV=ADATA(IPN+19)
      IF(CURV.LT.1.E-6) GO TO 3
      R=1./CURV
      D0=R+ADATA(IPN+20)
      ALPHA=ADATA(IPN+21)
      XC=D0*COS(ALPHA)
      YC=D0*SIN(ALPHA)
      AL0=ATAN2((Y0-YC),(X0-XC))
      GO TO 4
    2 CONTINUE
      IF(ITYPE.NE.2) GO TO 1
C
C     PARABOLA FIT.
C
      A0=ADATA(IPN+19)
      X0=ADATA(IPN+20)
      Y0=ADATA(IPN+21)
      CURV=2.*ADATA(IPN+22)
      IF(ABS(CURV).GT.1.E-6) GO TO 76
      ANG=A0+PI/2.
      PERP=X0*COS(ANG)+Y0*SIN(ANG)
      X0=PERP*COS(ANG)
      Y0=PERP*SIN(ANG)
      R0SQ=X0**2+Y0**2
      R0=SQRT(R0SQ)
      GO TO 3
   76 CONTINUE
      R=1./CURV
      ANG=A0+PI/2.
      XC=X0+R*COS(ANG)
      YC=Y0+R*SIN(ANG)
      R=ABS(R)
      AL0=ATAN2(-YC,-XC)
      X0=XC+R*COS(AL0)
      Y0=YC+R*SIN(AL0)
      A0=AL0-PI/2.
      DOT=ADATA(IPN+8)*COS(A0)+ADATA(IPN+9)*SIN(A0)
      IF(DOT.LT.0.) A0=A0+PI
      GO TO 4
    3 CONTINUE
C
C     STRAIGHT LINE CASE.
C
      UI=COS(A0)*OODEM
      VI=SIN(A0)*OODEM
      AR0=0.
      IF(R0.GT.0.1) AR0=ATAN2(Y0,X0)
      CSD=COS(A0-AR0)
      SDSQ=1.-CSD**2
      RADIA=RBARSQ-SDSQ*R0SQ
      IF(RADIA.LT.0.0) GOTO 351
      XYPATH=SQRT(RADIA)-R0*CSD
      PATH=XYPATH/OODEM
      ZBIMPC=Z0+WI*PATH
      IF(ZBIMPC.LT.ZLGEFM) GO TO 5
      IF(ZBIMPC.GT.ZLGEFP) GO TO 7
C
C     HITS BARREL.
C
      IREG=0
      XSI=X0+UI*PATH
      YSI=Y0+VI*PATH
      ZSI=ZBIMPC
      GO TO 6
    5 CONTINUE
      IREG=-1
      ZPATH=ZENDMI-Z0
      ZSI=ZENDMI
      GO TO 75
    7 CONTINUE
      IREG=1
      ZPATH=ZENDPL-Z0
      ZSI=ZENDPL
   75 CONTINUE
      PATH=ZPATH/WI
      XSI=X0+UI*PATH
      YSI=Y0+VI*PATH
      GO TO 6
    4 CONTINUE
C
C     CIRCULAR ORBITS.
C
      CROSS=(X0-XC)*ADATA(IPN+9)-(Y0-YC)*ADATA(IPN+8)
      RCSQ=XC**2+YC**2
      RC=SQRT(RCSQ)
      RMAX=RC+R
      IF(RMAX.LT.(RMAG+100.)) GO TO 8
      DEL=R-RC
      IF(ABS(DEL).LT.1.E-1) DEL=0.
      COSL=(2.*RC*DEL+DEL**2-RMAGSQ)/(2.*RC*RMAG)
      AL=ARCOS(COSL)
      IF(CROSS.LT.0.) AL=-AL
      AIN=AL0+AL
      XSI=RMAG*COS(AIN)
      YSI=RMAG*SIN(AIN)
      XYPATH=SQRT((XSI-X0)**2+(YSI-Y0)**2)
      APATH=2.*ARSIN(0.5*XYPATH/R)
      IF(CROSS.LT.0.) APATH=-APATH
      ZPATH=ZSL*R*ABS(APATH)
      ZSI=Z0+ZPATH
      IF((ZSI.LT.ZLGEFM).OR.(ZSI.GT.ZLGEFP)) GO TO 8
C
C     INTERSECTS COIL.
C
      IREG=0
      AI=A0+APATH
      UI=COS(AI)*OODEM
      VI=SIN(AI)*OODEM
C
C     TRANSPORT FROM COIL TO BARREL.
C
      BTERM=(UI*XSI+VI*YSI)/OODEM
      XYPATH=SQRT(RBARSQ-RMAGSQ+BTERM**2)-BTERM
      PATH=XYPATH/OODEM
      XSI=XSI+UI*PATH
      YSI=YSI+VI*PATH
      ZSI=ZSI+WI*PATH
      GO TO 6
    8 CONTINUE
      IF(ABS(WI).LT.0.1) GO TO 29
      IF(WI.GT.0.) GO TO 9
      IREG=-1
      ZSI=ZENDMI
      GO TO 10
    9 CONTINUE
      IREG=1
      ZSI=ZENDPL
   10 CONTINUE
      ZPATH=ZSI-Z0
      APATH=ZPATH/(ZSL*R)
      IF(CROSS.LT.0.) APATH=-APATH
      AIN=AL0+APATH
      XSI=XC+R*COS(AIN)
      YSI=YC+R*SIN(AIN)
      AI=A0+APATH
      UI=COS(AI)*OODEM
      VI=SIN(AI)*OODEM
C
    6 CONTINUE
      PTRANS=ABS(0.0299792458*BKGAUS/CURV)
      PLONGI=PTRANS*ZSL
      ECHPRT=SQRT(PTRANS**2+PLONGI**2+139.57**2)
      IF(ECHPRT.GT.15000.) ECHPRT=6000.
      PMAG=SQRT(ECHPRT**2-139.57**2)
      PTRANS=PMAG/SQRT(1.+ZSL**2)
      PLONGI=PTRANS*ZSL
C
C
C     TRANSPORT PARTICLES THROUGH LEAD GLASS.
C
C
      XSHIFT = 40.
      YSHIFT = 40.
      ZSHIFT = 40.
      PSHIFT = .02
      XSTAST = XSI
      YSTAST = YSI
      ZSTAST = ZSI
      PSTAST = ATAN2(XSI,YSI)
      IF(PSTAST.LT.0) PSTAST = PSTAST + TWOPI
      IFINE = 0
C
CCC37 QUAMAX = 0.
      ITMAX = 1
      ITER = 1
      ITSEL = 0
      X1=XSI
      Y1=YSI
      Z1=ZSI
      PH1 = ATAN2(XSI,YSI)
      IF(PH1.LT.0) PH1=PH1+TWOPI
CCC34 CONTINUE
      NSURF=0
      IF(IREG.NE.0) GO TO 11
C
C     HITS BARREL.
C
      XSI=RLG*SIN(PH1 + POS2(ITER)*PSHIFT)
      YSI=RLG*COS(PH1 + POS2(ITER)*PSHIFT)
      ZSI=Z1 + POS1(ITER)*ZSHIFT
      PHI=ATAN2(XSI,YSI)
      IF(PHI.LT.0.) PHI=PHI+TWOPI
      WEIGHT = DGAUS2(ZSI,PHI,ZSTAST,PSTAST,SIGZ,SIGP)
      BTERM=(UI*XSI+VI*YSI)/OODEM
      XYPATH=SQRT(OUTRSQ-RBARSQ+BTERM**2)-BTERM
      PATH=XYPATH/OODEM
      XSF=XSI+UI*PATH
      YSF=YSI+VI*PATH
      ZSF=ZSI+WI*PATH
      DPHI=ARSIN((XSI*YSF-XSF*YSI)/(RLG*OUTR2))
      IF(ABS(DPHI).LT.1.E-3) GO TO 20
      PHII=TWOPI+ATAN2(YSI,XSI)
      PHIF=PHII+DPHI
      IBI=84.*PHII/TWOPI
      IBF=84.*PHIF/TWOPI
      NSURF=0
      NBCR=IABS(IBF-IBI)
      IF(NBCR.LT.1) GO TO 20
      PHIMI=TWOPI*(IBI+0.5)/84.
      PHIMF=TWOPI*(IBF+0.5)/84.
      STEP=(PHIMF-PHIMI)/NBCR
      PHIN=PHIMI+0.5*STEP-PI/2.
   21 CONTINUE
      UN=COS(PHIN)
      VN=SIN(PHIN)
      DRIFTN=-(UN*XSI+VN*YSI)
      DOT=UN*UI+VN*VI
      DRIFT=DRIFTN/DOT
      IF(NSURF.GE.48) GOTO 20
      NSURF=NSURF+1
      ALIST(1,NSURF)=XSI+UI*DRIFT
      ALIST(2,NSURF)=YSI+VI*DRIFT
      ALIST(3,NSURF)=ZSI+WI*DRIFT
      IF(NSURF.GE.NBCR) GO TO 20
      PHIN=PHIN+STEP
      GO TO 21
   20 CONTINUE
      IF(ABS(WI).LT.1.E-3) GO TO 22
      IBI=(ZSI+50.*BLZ)/BLZ
      IBF=(ZSF+50.*BLZ)/BLZ
      NBCR=IABS(IBF-IBI)
      IF(NBCR.LT.1) GO TO 22
      ZMI=(IBI+0.5)*BLZ-50.*BLZ
      ZMF=(IBF+0.5)*BLZ-50.*BLZ
      STEP=(ZMF-ZMI)/NBCR
      ZS=ZMI+0.5*STEP
      ISTEP=0
   23 CONTINUE
      DRIFTN=ZS-ZSI
      DRIFT=DRIFTN/WI
      ISTEP=ISTEP+1
      IF(NSURF.GE.48) GOTO 22
      NSURF=NSURF+1
      ALIST(1,NSURF)=XSI+UI*DRIFT
      ALIST(2,NSURF)=YSI+VI*DRIFT
      ALIST(3,NSURF)=ZS
      IF(ISTEP.GE.NBCR) GO TO 22
      ZS=ZS+STEP
      GO TO 23
   22 CONTINUE
      IF(NSURF.GE.48) GOTO 18
      NSURF=NSURF+1
      ALIST(1,NSURF)=XSI
      ALIST(2,NSURF)=YSI
      ALIST(3,NSURF)=ZSI
      IF(NSURF.GE.48) GOTO 18
      NSURF=NSURF+1
      ALIST(1,NSURF)=XSF
      ALIST(2,NSURF)=YSF
      ALIST(3,NSURF)=ZSF
      GO TO 18
   11 CONTINUE
C
C     HITS ENDCAP.
C
      XSI=X1+POS1(ITER)*XSHIFT
      YSI=Y1+POS2(ITER)*YSHIFT
      ZSI=Z1
      WEIGHT = DGAUS2(XSI,YSI,XSTAST,YSTAST,SIGX,SIGY)
      ZSF=ZSI+IREG*DEPEND
      ZM=0.5*(ZSI+ZSF)
      IDIM=0
      NSURF=0
   12 CONTINUE
      IDIM=IDIM+1
      JDIM=3-IDIM
      TRANS=V(IDIM)
      IF(ABS(TRANS).LT.1.0E-3) GO TO 13
      KTR=0
   14 CONTINUE
      KTR=KTR+1
      IF(KTR.GT.23) GO TO 13
      JTR=13-KTR
      IF(KTR.GE.12) JTR=KTR-11
      SIGN=-1.
      IF(KTR.GE.12) SIGN=1.
      TDRIFT=SIGN*TSURF(1,JTR)-X(IDIM)
      DRIFT=TDRIFT/TRANS
      ZS=ZSI+WI*DRIFT
      IF(ABS(ZS-ZM).GT.DEPENH) GO TO 14
      YS=X(JDIM)+V(JDIM)*DRIFT
      AYS=ABS(YS)
      IF((AYS.LT.TSURF(2,JTR)).OR.(AYS.GT.TSURF(3,JTR))) GOTO 14
      NSURF=NSURF+1
      ALIST(IDIM,NSURF)=SIGN*TSURF(1,JTR)
      ALIST(JDIM,NSURF)=YS
      ALIST(   3,NSURF)=ZS
      GO TO 14
   13 CONTINUE
      IF(IDIM.LT.2) GO TO 12
      NSURF=NSURF+1
      ALIST(1,NSURF)=XSI
      ALIST(2,NSURF)=YSI
      ALIST(3,NSURF)=ZSI
      DRIFT=(ZSF-ZSI)/WI
      XSF=XSI+UI*DRIFT
      YSF=YSI+VI*DRIFT
      NSURF=NSURF+1
      ALIST(1,NSURF)=XSF
      ALIST(2,NSURF)=YSF
      ALIST(3,NSURF)=ZSF
C
C     BARREL AND END CAP TRACKS MERGE HERE.
C
   18 CONTINUE
C
C     ORDER.
C
      DO 15 I=1,NSURF
      AMINW=1.0E8
      DO 16 J=1,NSURF
      IF(IREG.EQ.0) CW=ALIST(1,J)**2+ALIST(2,J)**2
      IF(IREG.NE.0) CW=ABS(ALIST(3,J))
      IF(CW.GT.AMINW) GO TO 16
      AMINW=CW
      K=J
   16 CONTINUE
      DO 17 J=1,3
      BLIST(J,I)=ALIST(J,K)
      ALIST(J,K)=2.0E8
   17 CONTINUE
   15 CONTINUE
C
C     COUNT REAL BLOCKS HIT AND COMPUTE PATH LENGTHS.
C
      NBSK=0
      DO 19 I=2,NSURF
      XB=0.5*(BLIST(1,(I-1))+BLIST(1,I))
      YB=0.5*(BLIST(2,(I-1))+BLIST(2,I))
      ZB=0.5*(BLIST(3,(I-1))+BLIST(3,I))
      IBLK=NUMBLC(XB,YB,ZB,IREG)
      IF(IBLK.LT.0) GO TO 19
      NBSK=NBSK+1
      DX=BLIST(1,I)-BLIST(1,(I-1))
      DY=BLIST(2,I)-BLIST(2,(I-1))
      DZ=BLIST(3,I)-BLIST(3,(I-1))
      IF(ABS(DX).LT.1.0E-3) DX=1.0E-3
      IF(ABS(DY).LT.1.0E-3) DY=1.0E-3
      IF(ABS(DZ).LT.1.0E-3) DZ=1.0E-3
      DL=SQRT(DX**2+DY**2+DZ**2)
      IRSE(1,NBSK)=IBLK
      TRSE(2,NBSK)=DL
   19 CONTINUE
   29 CONTINUE
C
      QUANT = 0.
      TRISE = 0.
      EBISE = -1.
      NBSE = 0
      IF(NBSK.LT.1) GOTO 35
C
C     TOTAL TRACKLENGTH FOR THIS ITERATION
C
      DO 88 ILOP=1,NBSK
      TRISE = TRISE + TRSE(2,ILOP)
   88 CONTINUE
      IF(TRISE.LT..00001) GOTO 1
C
C     CALCULATE QUANT
C
      KBLK=0
   25 CONTINUE
      KBLK=KBLK+1
      IF(KBLK.GT.NBSK) GO TO 26
      IBLK=IRSE(1,KBLK)
      EBL=0.
      IPNH=IPNH0
   27 CONTINUE
      IPNH=IPNH+2
      IF(IPNH.GT.MXH) GO TO 28
      JBLK=HDATA(IPNH)
      IF(JBLK.NE.IBLK) GO TO 27
      NBSE = NBSE + 1
      EBL=HDATA(IPNH+1)
      EBISE = EBISE + EBL
      IRSE(3,KBLK)=HDATA(IPNH+1)
   28 QUANT = QUANT + (EBL/ECHPRT)*(TRSE(2,KBLK)/TRISE)
      GOTO 25
   26 QUANT = WEIGHT*QUANT*FLOAT(NBSE)/FLOAT(NBSK)
C
   35 IBLCSE = 0
      IF(NBSK.LT.1) IBLCSE = 1
      IF(NBSK.GE.1.AND.EBISE.LT.1.) IBLCSE = 2
      NBL1=IRSE(1,1)
      NBL2=IRSE(1,2)
      RETURN
  351 IBLCSE=4
      RETURN
    1 IBLCSE = 3
      RETURN
      END
