C   12/08/87 805171157  MEMBER NAME  CHIEN5   (S)           FORTRAN77
CC    SUBROUTINE CHIEN5(ITR,PTR,XST,YST,ZST,ZVER,CHA,CHI2N,PCHI2,ICLUR)
      SUBROUTINE CHIEN5(ITR,PTR,ESHM,ZVER,CHA,CHI2N,PCHI2,ICLUR)
C
C   COPIED FROM F11HEL.ES(CHIEN5)
C   LAST MOD 4/1/88 ADDED IFIND INIT   E ELSEN
C
C   BIT 31 ICLUR = 0 BEI EINGABE --> PHI IMPACT FROM TRKBLK OPTIMIZATION
C   BIT 31 ICLUR = 1 BEI EINGABE --> PHI IMPACT FROM ID
C
C   BIT 30 ICLUR = 1 WRITE BLOCK + ENERGIE LIST
C
      IMPLICIT INTEGER*2 (H)
      LOGICAL TBIT
      REAL*8 XVA8(5),ZCO8(5),GUESS,CHI8,ZMIN
C
#include "cdata.for"
#include "cgeo1.for"
C
      COMMON /LINK/   IBLCHK,IREG,NBLK,NBLE,XI,YI,ZI,XF,YF,ZF,XSTART,
     *                YSTART,ZSTART,PSTART,TRKL(2,50),TRITER,EBITER,
     *                PMAG,NNEW,NENEW,NLIST(40),ENEW,ICHARG(40,20),
     +                NBLO,MEICL(50),NEICL(50),EBIT1,NBN1,EBLO1,NBL1
C
C                            CLDAT IS FILLED IN CLUSIN
      COMMON /CLDAT/ NUMBLO,NBLIST(40),ENLIST(40),IPACL,ECLCO,ECLUN,
     *               PIMP1,PIMP2
      DIMENSION ZCO(5), VERT(3), XVA(5)
      DATA ZINTV / 40./
      DATA PHCNST /1.499E-5/, TWOPI /6.283185/
C
      IPHI=0
      IF(TBIT(ICLUR,31)) IPHI=1
      IPRI=0
      IF(TBIT(ICLUR,30)) IPRI=1
      ICLUR=0
      IFIND = 0
C     ECLCO=0.
C     ECLUN=0.
C     ICLUST=1
C     CALL CLUSIN(ITR,ICLUST,IFIND)
      ECLCO=ESHM*1000.
      ECLUN=EBITER
      NUMBLO=0
CCC             IPACL GIVES LG DETECTOR PART -1,0,1 FOR -Z,BARREL,+Z
      IPACL=0
C                    FILL MEICL AND NEICL INTO NBLIST AND ENLIST
      DO 990 IM=1,NBLO
      IF(NEICL(IM).LE.0) GOTO 990
      NUMBLO=NUMBLO+1
      NBLIST(NUMBLO)=MEICL(IM)
      ENLIST(NUMBLO)=NEICL(IM)
  990 CONTINUE
C
      IF(NUMBLO.GE.1) IFIND=1
      IF(IFIND.EQ.0) GOTO 1170
C
      NBMX = MIN0 (NUMBLO, 9)
       IF(IPRI.EQ.1) WRITE (6,1013) ITR,NUMBLO,
     +                (NBLIST(LL),ENLIST(LL),LL=1,NBMX  )
 1013 FORMAT (  1X,'       NCLU,..',4X,2I4,3X, 9(I5,F6.0))
C
C                            CALCULATE CHI2 OF SHOWER PROFILE
C                            FILL LG IMPACT POINT VARIABLES
C                            FOR PHI SEE ABOVE
C                            FOR Z USE TRKBLK OPTIMIZED VALUE ZI
C
      ATID=ATAN2 (YSTART,XSTART)
C                                           MOD 13/08/87 E E
C     IF (ATFI.LE.0.) ATID=ATID+TWOPI
      IF (ATID.LE.0.) ATID=ATID+TWOPI
C                                           END MOD
      ATFI=ATAN2 (YI,XI)
      IF (ATFI.LE.0.) ATFI=ATFI+TWOPI
C
      IF(IPHI.EQ.0) PIMP1=ATFI
      IF(IPHI.GT.0) PIMP1=ATID
C
      PIMP2=ZI
C
C     IF (IPRINT.LT.50)
C    + WRITE (6,1017) ITR,PIMP1,PIMP2,ATFI,ZST
C
C                            CALC EFFECTIVE VERTEX IN X, Y
C
      PHARG= PHCNST * RLG * ABS(BKGAUS) / PTR
      IF(PHARG.GT.1.) GOTO 1180
      PHI0H=ASIN (PHARG)
      DIST= RLG  * TAN(PHI0H)
      XDIST=DIST*SIN( ATFI )
      YDIST=DIST*COS( ATFI )
      VERT(1)= + CHA*XDIST
      VERT(2)= - CHA*YDIST
C                            GET Z - VERTEX OF EVENT
CC    IPZV=IDATA(IBLN('ZVTX'))
CC    IF (IPZV.EQ.0) CALL ZVERTF
      VERT(3)=ZVER
CC    IF (IPRINT.LT.50)
CC   + WRITE (6,1017) ITR,PTR,PHI0H,DIST,X0,Y0,XDIST,YDIST,VERT,RLG
C1017 FORMAT (1X,' VTX 'I4,11F10.3)
C
C                            CALC CHI2 FOR THREE POINTS AROND ZSTART
      CHIMI=100000.
      Z1=ZI-2.*ZINTV
      DO 520 KF=1,5
      ZCO(KF)=Z1+(KF-1)*ZINTV
      PIMP2=ZCO(KF)
C
        CALL SHWCPR (VERT,CHI2)
C
      XVA(KF)=CHI2
      IF (KF.LT.2.OR.KF.GT.4) GOTO 520
      IF (CHI2.LT.CHIMI) CHIMI=CHI2
  520 CONTINUE
C                            MINIMUM OUTSIDE PRESENT RANGE OF Z
      IF (XVA(1).GT.CHIMI) GO TO 521
C                            OUT LEFT
      XVA(5)=XVA(4)
      XVA(4)=XVA(3)
      XVA(3)=XVA(2)
      XVA(2)=XVA(1)
      ZCO(5)=ZCO(4)
      ZCO(4)=ZCO(3)
      ZCO(3)=ZCO(2)
      ZCO(2)=ZCO(1)
      ZCO(1)=ZCO(1)-ZINTV
      PIMP2=ZCO(1)
        CALL SHWCPR (VERT,CHI2)
      XVA(1)=CHI2
      GO TO 530
C                            OUT RIGHT
  521 CONTINUE
      IF (XVA(5).GT.CHIMI) GO TO 530
      XVA(1)=XVA(2)
      XVA(2)=XVA(3)
      XVA(3)=XVA(4)
      XVA(4)=XVA(5)
      ZCO(1)=ZCO(2)
      ZCO(2)=ZCO(3)
      ZCO(3)=ZCO(4)
      ZCO(4)=ZCO(5)
      ZCO(5)=ZCO(5)+ZINTV
      PIMP2=ZCO(5)
        CALL SHWCPR (VERT,CHI2)
      XVA(5)=CHI2
  530 CONTINUE
C                            SOLVE FOR MINIMUM CHI2
      DO 540 I8=1,5
      ZCO8(I8)=ZCO(I8)/100.
  540 XVA8(I8)=XVA(I8)/100.
      GUESS=ZI/100.
      CALL REGN(ZCO8,XVA8,GUESS,ZMIN,CHI8)
C
      PIMP2=ZMIN*100.
C                            FINAL CALL TO 'SHWCPR'
        CALL SHWCPR (VERT,CHI22)
C
      CHI2N = CHI22 / NUMBLO
      PCHI2=PROB(CHI22,NUMBLO)
C
      RETURN
 1170 WRITE(6,1175)
 1175 FORMAT(1X,'     >>>>> IFIND = 0 <<<<<')
      ICLUR=2
      RETURN
 1180 WRITE(6,1185) PHARG,PHCNST,RLG,BKGAUS,PTR
 1185 FORMAT(1X,' ARGUMENT ARSIN.GT.1 <<<<<',F10.5,/,1X,4F20.10)
      CHI2N=-1.
      PCHI2=-1.
      ICLUR=2
      RETURN
      END
      SUBROUTINE REGN(X,Y,GUESS,ZMIN,CHI8)
      IMPLICIT REAL*8 (A-H,O-Z)
      DATA N /5/, ND /2/, IMAX/100/, XN/1.D-3/, IN/1/
C
C   NTH-ORDER REGRESSION
C   ND IST DER GRAD DER GLEICHUNG
C   MINIMALE DIMENSIONEN A(2ND+1), R(ND+1,ND+2), T(ND+2)
C                        C(ND), CB(ND)
C   DIMENSION (M) DER MATRIX = ND+1
C
C   + SUCHE DES MAXIMUMS DES GEFUNDENEN POLYNOMS, WENN IN=1
C         GUESS = SCHAETZUNG DES MAXIMUMS
C         IMAX = MAXIMALE ITERATIONSZAHL
C         XN = GENAUIGKEIT
C
      DIMENSION A(21), R(11,12), T(12), PKOF(11)
      DIMENSION AA(11,11), B(11,11), C(11), CB(11)
C   ANZAHL DER PUNKTE N --> DIMENSION X(N), Y(N)
      DIMENSION X(5),Y(5)
C
      DO 10 I=1,21
   10 A(I)=0.D0
      DO 20 I1=1,11
      T(I1)=0.D0
      PKOF(I1)=0.D0
*** PMF10/12/99      C(I)=0.D0
*     CB(I)=0.D0
* see chien52.F
      C(I1)=0.D0
      CB(I1)=0.D0
*** PMF(end)
      R(I1,12)=0.D0
      DO 20 I2=1,11
      AA(I1,I2)=0.D0
      B(I1,I2)=0.D0
   20 R(I1,I2)=0.D0
      T(12)=0.D0
      NDE=2*ND+1
      ND1=ND+1
      ND2=ND+2
C
      A(1)=N
      DO 50 I=1,N
      DO 30 J=2,NDE
   30 A(J)=A(J)+X(I)**(J-1)
      DO 40 K=1,ND1
      R(K,ND2)=T(K)+Y(I)*X(I)**(K-1)
   40 T(K)=T(K)+Y(I)*X(I)**(K-1)
      T(ND2)=T(ND2)+Y(I)**2
   50 CONTINUE
C
      DO 60 J=1,ND1
      DO 60 K=1,ND1
   60 R(J,K)=A(J+K-1)
C
C
C                          MATRIXINVERSION
      M=ND+1
      DO 90 J=1,M
      DO 80 I=1,M
   80 AA(J,I)=R(J,I)
   90 B(J,J)=1.D0
C
      DO 160 J=1,M
      DO 100 I=J,M
      IF(AA(I,J).LT.0.D0) GOTO 110
  100 IF(AA(I,J).GT.0.D0) GOTO 110
      WRITE(6,1001)
 1001 FORMAT(//,1X,' MATRIX SINGULAER')
      GOTO 400
  110 DO 120 K=1,M
      S=AA(J,K)
      AA(J,K)=AA(I,K)
      AA(I,K)=S
      S=B(J,K)
      B(J,K)=B(I,K)
      B(I,K)=S
  120 CONTINUE
      D=1.D0/AA(J,J)
      DO 130 K=1,M
      AA(J,K)=D*AA(J,K)
  130 B(J,K)=D*B(J,K)
      DO 150 L=1,M
      IF(L.EQ.J) GOTO 150
      D=-AA(L,J)
      DO 140 K=1,M
      AA(L,K)=AA(L,K)+D*AA(J,K)
  140 B(L,K)=B(L,K)+D*B(J,K)
  150 CONTINUE
  160 CONTINUE
C
C  BERECHNUNG DER KOEFFIZIENTEN DES POLYNOMS
C
      DO 200 J=1,M
      PKOF(J)=0.D0
      DO 200 I=1,M
  200 PKOF(J)=PKOF(J)+B(I,J)*R(I,ND2)
      DO 210 J=1,M
  210 JK=J-1
C
C
C                         MAXIMUMSUCHE, WENN IN=1
      IF(IN.NE.1) GOTO 400
C
C   1. UND 2. ABLEITUNG DER FUNKTION
C
      DO 300 I=1,ND
  300 C(I)=PKOF(I+1)*I
      NDM1=ND-1
      DO 310 I=1,NDM1
  310 CB(I)=C(I+1)*I
C
C   SUCHE NULLSTELLE DER 1. ABLEITUNG
C   NACH DEM NEWTONSCHEN NAEHERUNGSVERFAHREN
C
      XG=GUESS
      II=0
  320 S=1.D0
      F1=0.D0
      F0=0.D0
      II=II+1
      DO 330 I=1,ND
C CALCULATE VALUE OF FUNCTION
      F0=F0+C(I)*S
C CALCULATE VALUE OF DERIVATIVE
      F1=F1+CB(I)*S
      S=S*XG
  330 CONTINUE
C TEST FOR A ZERO DERIVATIVE, IF YES, STOP SEARCH, PRINT
      IF(F1.EQ.0.D0) GOTO 360
C GET NEW GUESS USING PREVIOUS GUESS
      S=XG-F0/F1
C IF NEW GUESS = LAST GUESS WITHIN XN STOP SEARCH, PRINT
      XS=DABS(XG-S)
      IF(XS.LT.XN) GOTO 370
C SAVE LAST GUESS
      XG=S
      IF(II.GE.IMAX) GOTO 370
      GOTO 320
C
C
  360 WRITE(6,3601) XG
 3601 FORMAT(//,1X,' DERIVATIVE = 0  AT  X =',F8.4)
      GOTO 400
C
  370 YG=PKOF(1)
      DO 380 J=2,ND1
  380 YG=YG+PKOF(J)*XG**(J-1)
      ZMIN=XG
      CHI8=YG
C
  400 RETURN
      END
