C***********************************************************************
      SUBROUTINE SIMPLX(VERMIN,CHIMIN)
C-----------------------------------------------------------------------
C     <SIMPLX>
C     THE PURPOSE OF SIMPLX IS TO IMPLEMENT THE SIMPLEX FUNCTION
C     MINIMIZATION
C     XSQR(I) IS THE FUNCTION TO BE MINIMIZED. IT MUST RETURN THE
C              FUNCTION EVALUATED AT THE I'TH VERTEX OF THE SIMPLEX
C              MATRIX VERTP.
C     NPARA IS THE NUMBER OF VARIABLES OF XSQR.
C     VERTP IS THE SIMPLEX MATRIX OF NPARA+1 VERTICIES(ROWS) BY NPARA
C              VARIABLES(COLUMNS) OF XSQR. VERTP CONTAINS THE INITIAL
C              SIMPLEX UPON ENTRY AND IS RETURNED WITH THE FINAL
C              SIMPLEX.
C     YVERT IS THE VECTOR OF XSQR EVALUATED AT THE NPARA+1 VERTICIES
C              AND IS RETURNED WITH THE FINAL EVALUATIONS.
C     IBEST IS RETURNED WITH THE ROW SUBSCRIPT OF VERTP THAT CONTAINS
C              THE MINIMUM SIMPLEX VERTEX.
C     STMIN IS THE MINIMUM PER CENT STANDARD DEVIATION THAT THE YVERT
C              VECTOR IS ALLOWED TO HAVE.
C     XSQMIN IS THE MINIMUM REDUCED CHI-SQ THAT YVERT IS ALLOWED TO
C              HAVE, IT IS AM ALTERNATE CONVERGENCE CRITERION
C-----------------------------------------------------------------------
      IMPLICIT REAL*8 (A-H,O-Z)
      CHARACTER*10 CSTAT
      COMMON /BOND/ BOUND(16,3),NPARA
      COMMON /VERTEX/ VERTP(20,16),YVERT(16)
      COMMON /OBSDAT/OBSU(16),VAR(16),EN1(16),EN2(16),
     *               IBINU(16),CIBINU(16)
      COMMON /NOBSDAT/NDUSE
      CHARACTER CIBINU*1
      COMMON /COND/STMIN,XSQMIN,CSTAT
      COMMON /NCOND/MAXSTP,NUMSTP
      COMMON /MAP/   MAPFOR(16,11)
      COMMON /FORMU/TFORPR(16,8),TFORSC
      COMMON /NFORMU/NTFOR,NABS
      DIMENSION VERMIN(16),XSPEC(16,16)
      CHARACTER SIMLAB(5)*10
      DATA SIMLAB/'REFLECTION','FAILED EXP','EXPANSION ',
     * 'CONTRACT  ','M CONTRACT'/
C-----------------------------------------------------------------------
      WRITE(6,503) NDUSE,NPARA
503   FORMAT(/,'<SIMPLEX MINIMIZATION :',I4,' DATA WITH',I4,
     *  ' PARAMETERS>'/,
     *  '       STEP        XSQ     SDEV   NEW-XSQ   ',
     * 'NEW PARAMETERS')
      NEVAL=0
      IREFL=0
      IFLEXP=0
      IEXP=0
      ICONT=0
      MCONT=0
      DO 2 I=1,NPARA
2     VERMIN(I)=BOUND(I,1)
      CALL FORGET(NPARA,VERMIN,XSPEC)

      DO 3 I=1,NPARA
      NUM=MAPFOR(I,1)
      DO 3 J=1,NUM
      IDIM=MAPFOR(I,2*J)
      JDIM=MAPFOR(I,2*J+1)
      IF(IDIM.LE.NTFOR-NABS.AND.JDIM.EQ.2) THEN
        BOUND(I,1)=VERMIN(I)
        BOUND(I,3)=ABS(VERMIN(I))*5
        IF(VERMIN(I).GE.0) THEN
           BOUND(I,2)=VERMIN(I)/10
        ELSE
           BOUND(I,2)=VERMIN(I)*2
        ENDIF
       ENDIF
C      IF(IDIM.LE.NTFOR.AND.JDIM.EQ.2.AND.NSIM.NE.0) THEN
C       BOUND(I,1)=VERMIN(I)
C       BOUND(I,3)=ABS(VERMIN(I))*5
C       IF(VERMIN(I).GE.0) THEN
C          BOUND(I,2)=VERMIN(I)/10
C       ELSE
C          BOUND(I,2)=VERMIN(I)*2
C       ENDIF
C     ENDIF
3     CONTINUE

C
C     DEFINE SOME CONVENIENT VARIABLES.
      IVERT=NPARA+1
      IVERT1=IVERT+1
      IVERT2=IVERT+2
      IVERT3=IVERT+3
C
C     INITIALIZE THE VERTP ARRAY AND THE YVERT VECTOR.
C
      IHIT=0
      DO 10 I=1,IVERT
      DO 11 J=1,NPARA
      VERTP(I,J)=BOUND(J,1)
      IF(I.EQ.J+1)VERTP(I,J)=BOUND(J,1)+.1*(BOUND(J,3)-BOUND(J,2))
      IF(I.EQ.J+1.AND.VERTP(I,J).GT.BOUND(J,3))VERTP(I,J)=BOUND(J,1)-
     $ .1*(BOUND(J,3)-BOUND(J,2))
11    CONTINUE
      CALL SXSQR(IHIT,I)
      IF(IHIT.EQ.1) THEN
         WRITE(6,'(1H0,'' HIT AT START OF SUB SIMPLX'')')
         STOP
      ENDIF
10    CONTINUE
C
C     MAIN LOOP.
C
      NUMSTP=0
C
C     FIND BEST (ILOW) AND WORST (IHIGH) VERTICES
C
1     IHIT=0
      RMIN=1.E25
      RMAX=-1.E25
      DO 25 I=1,IVERT
      IF(YVERT(I).GT.RMIN)GO TO 26
      RMIN=YVERT(I)
      ILOW=I
26    IF(YVERT(I).LT.RMAX)GO TO 25
      RMAX=YVERT(I)
      IHIGH=I
25    CONTINUE
      IF(IHIGH.EQ.ILOW)THEN
         WRITE(6,'(1H ,'' *ABNORMAL END ; NPARA='',I5,''  IHIGH=ILOW='',
     *         I5,'' ; YVERT LIST '')') NPARA,IHIGH
         WRITE(6,'(1H ,10E12.4)') (YVERT(K),K=1,NPARA)
         STOP
      ENDIF
C
C     FIND CENTROID OF SIMPLEX
C
      DO 20 I=1,NPARA
      VERTP(IVERT1,I)=0.
      DO 21 J=1,IVERT
      IF(J.EQ.IHIGH)GO TO 21
      VERTP(IVERT1,I)=VERTP(IVERT1,I)+VERTP(J,I)
21    CONTINUE
      VERTP(IVERT1,I)=VERTP(IVERT1,I)/NPARA
20    CONTINUE
C     NOTE THAT YVERT(IVERT1) IS NEVER USED SO IT IS NOT CALCULATED
      CALL VECADD(NPARA,IVERT2,2.0,IVERT1,-1.0,IHIGH)
      CALL SXSQR(IHIT,IVERT2)
      IF(YVERT(IVERT2).LT.YVERT(ILOW))GO TO 40
      DO 30 I=1,IVERT
      IF(I.EQ.IHIGH)GO TO 30
      IF(YVERT(IVERT2).LE.YVERT(I))GO TO 35
30    CONTINUE
      GO TO 60
C
C     SIMPLE REFLECTION.
C
35    CALL MOVE(IHIGH,IVERT2)
      NEWPT=IVERT2
      ISTYPE=1
      GO TO 90
C
C     EXPANSION.
C
40    CALL VECADD(NPARA,IVERT3,3.0,IVERT2,-2.0,IVERT1)
      CALL SXSQR(IHIT,IVERT3)
      IF(YVERT(IVERT3).LT.YVERT(ILOW))GO TO 50
C
C     FAILED EXPANSION.
C
      NEWPT=IVERT2
      CALL MOVE(IHIGH,IVERT2)
      ISTYPE=2
      GO TO 90
C
C     SUCCESSFUL EXPANSION.
C
50    CALL MOVE(IHIGH,IVERT3)
      NEWPT=IVERT3
      ISTYPE=3
      GO TO 90
C
C     CONTRACTION.
C
60    IF(YVERT(IVERT2).LE.YVERT(IHIGH))CALL MOVE(IHIGH,IVERT2)
65    CALL VECADD(NPARA,IVERT3,0.5,IHIGH,0.5,IVERT1)
      CALL SXSQR(IHIT,IVERT3)
      IF(YVERT(IVERT3).GT.YVERT(IHIGH))GO TO 70
C
C     SUCCESSFUL CONTRACTION.
C
      NEWPT=IVERT3
      CALL MOVE(IHIGH,IVERT3)
      ISTYPE=4
      GO TO 90
C
C     FAILED CONTRACTION, PERFORM 'MASSIVE CONTRACTION'.
C
70    DO 80 I=1,IVERT
      CALL VECADD(NPARA,I,0.5,I,0.5,ILOW)
      CALL SXSQR(IHIT,I)
80    CONTINUE
      NEWPT=ILOW
      ISTYPE=5
C
C     DO STATISTICS
C
90    NUMSTP=NUMSTP+1
      IF(ISTYPE.EQ.1)IREFL=IREFL+1
      IF(ISTYPE.EQ.2)IFLEXP=IFLEXP+1
      IF(ISTYPE.EQ.3)IEXP=IEXP+1
      IF(ISTYPE.EQ.4)ICONT=ICONT+1
      IF(ISTYPE.EQ.5)MCONT=MCONT+1
C
C     TEST FOR CONVERGENCE.
C
77    AVE=0.0
      DO 85 I=1,IVERT
      AVE=AVE+YVERT(I)
85    CONTINUE
      AVE=AVE/IVERT
      STSTEP=0.0
      DO 86 I=1,IVERT
      STSTEP=STSTEP+(YVERT(I)-AVE)**2
86    CONTINUE
      STSTEP=100.*SQRT(STSTEP/(IVERT-1))/AVE
      IF(MOD(NUMSTP,10).EQ.0) WRITE(6,502) NUMSTP,SIMLAB(ISTYPE),
     *   YVERT(ILOW),STSTEP,YVERT(NEWPT),(VERTP(NEWPT,I),I=1,NPARA)
502   FORMAT(1X,I3,1X,A10,F9.3,F8.3,F9.3,12F7.2,
     *       5(/,41X,12F8.3))
      REXSQ=YVERT(ILOW)/(NDUSE-NPARA)
      IF(NUMSTP.GE.MAXSTP) THEN
CE       CSTAT=10HTERMINATE
         CSTAT='TERMINATE'
         WRITE(6,'(/,34(1H*),1X,A10,34(1H*))') CSTAT
      ELSE
         IF(STSTEP.GE.STMIN.AND.REXSQ.GE.XSQMIN) GOTO 1
CE       CSTAT=10HCONVERGED
         CSTAT='CONVERGED'
         WRITE(6,'(/,34(1H*),1X,A10,34(1H*))') CSTAT
      ENDIF
         WRITE(6,'(/,2X,
     *       ''STSTEP='',F6.3,'' XSQ='',F8.3,'' REXSQ='',F6.3,/
     *   ''    ( STMIN='',F6.2,''   XSQMIN='',F6.2,2H ))')STSTEP,
     *     YVERT(ILOW),REXSQ,STMIN,XSQMIN
      DO 4 I=1,NPARA
4     VERMIN(I)=VERTP(ILOW,I)
      CHIMIN=YVERT(ILOW)
      WRITE(6,'(/,2X,''*VALUES OF FREE PARAMETERS;'')')
      WRITE(6,'(2X,''  FORMULA;'',13I8)')(MAPFOR(I,2),I=1,NPARA)
      WRITE(6,'(2X,''    INDEX;'',13I8)')(MAPFOR(I,3),I=1,NPARA)
      WRITE(6,'(2X,''   PLACE#;'',13I8)')(MAPFOR(I,1),I=1,NPARA)
      WRITE(6,'(2X,''    FINAL;'',3X,13e15.7)')
     *                                     (VERTP(ILOW,I),I=1,NPARA)
      WRITE(6,130)IREFL,IFLEXP,IEXP,ICONT,MCONT,NUMSTP
130   FORMAT(/,'  NO. OF REFLECTION',I3,' / FAILED EXPANSION',
     *   I3,' / EXPANSION',I3,' / ',/,'  CONTRACTION',I3,
     *' / MASS CONTRACTION',I3,' / NO. OF STEPS',I4)
      RETURN
      END
C**********************************************************************
C*    <VECADD>                                                        *
C*    PERFORMS VECTOR ADDITION ON THE ROWS OF MATRIX VERTP.           *
C*    VERTP(I1,I)=A*VERTP(I2,I)+B*VERTP(I3,I) FOR ALL 1<I<N.          *
C**********************************************************************
      SUBROUTINE VECADD(N,I1,A,I2,B,I3)
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*4 A,B
      COMMON /VERTEX/ VERTP(20,16),YVERT(16)
      DO 10 I=1,N
      VERTP(I1,I)=A*VERTP(I2,I)+B*VERTP(I3,I)
10    CONTINUE
      RETURN
      END
C**********************************************************************
C*    <MOVE>                                                          *
C*    MOVES THE ROW I2 TO I1                                          *
C**********************************************************************
      SUBROUTINE MOVE(I1,I2)
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /BOND/ BOUND(16,3),NPARA
      COMMON /VERTEX/ VERTP(20,16),YVERT(16)
      DO 10 I=1,NPARA
      VERTP(I1,I)=VERTP(I2,I)
10    CONTINUE
      YVERT(I1)=YVERT(I2)
      RETURN
      END
C**********************************************************************
C*    <SXSQR>                                                         *
C*    THE PURPOSE OF SXSQR IS TO GIVE THE CHI-SQUARED FUNCTION        *
C*    GIVEN BY THE VARIABLES IN THE I'TH VERTEX OF THE SIMPLEX ARRAY  *
C*    VERTP                                                           *
C**********************************************************************
      SUBROUTINE SXSQR(IHIT,JVERT)
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /OBSDAT/OBSU(16),VAR(16),EN1(16),EN2(16),
     *               IBINU(16),CIBINU(16)
      COMMON /NOBSDAT/NDUSE
      CHARACTER CIBINU*1
      COMMON /BOND/  BOUND(16,3),NPARA
      COMMON /VERTEX/ VERTP(20,16),YVERT(16)
      COMMON /FORMU/TFORPR(16,8),TFORSC
      COMMON /NFORMU/NTFOR,NABS
      COMMON /MAP/ MAPFOR(16,11)
      DIMENSION BUFF(16),VERT(16)
C
C     IF ANY VARIABLE IS OUTSIDE THE LIMITS IMPOSED BY THE 'BOUND'
C     ARRAY, RETURN A VERY LARGE VALUE.
C
      DO 20 J=1,NPARA
      IF(VERTP(JVERT,J).LT.BOUND(J,2).OR.VERTP(JVERT,J).GT.
     *    BOUND(J,3)) THEN
         IHIT=1
         YVERT(JVERT)=1.E10
         WRITE(6,'(5X,''* HIT ;'',I4,''-TH PARAMETER OUT OF'',I4,/,
     *         5X,''  VALUE='',F8.3,''   BOUND='',2F8.3)')
     *         J, NPARA, VERTP(JVERT,J),BOUND(J,2),BOUND(J,3)
         RETURN
      ENDIF
20    CONTINUE
C
C     FEED THE PARAMETERS FROM VERTP THROUGH MAPFOR TO THE TFORPR ARRAY
C     THEN FIND CTS AS A FOLDED SPECTRUM
C
      DO 21 I=1,NPARA
21    VERT(I)=VERTP(JVERT,I)
      CALL GETFOR(NPARA,VERT,BUFF)
C
C     FIND SCALING FACTOR THAT MINIMIZES X-SQ
C
      SUMD=0.
      SUMN=0.
      DO 28 I=1,NDUSE
      IF(VAR(I).LE.0)GO TO 28
      SUMD=SUMD+(BUFF(I)*BUFF(I))/VAR(I)
      SUMN=SUMN+(BUFF(I)*OBSU(I))/VAR(I)
 28    CONTINUE
      IF(SUMD.NE.0)SC=SUMN/SUMD
      DO 27 J=1,NDUSE
      BUFF(J)=BUFF(J)*SC
27    CONTINUE
      DO 29 I=1,NPARA
      NUM=MAPFOR(I,1)
      DO 29 J=1,NUM
      IDIM=MAPFOR(I,2*J)
      JDIM=MAPFOR(I,2*J+1)
      IF(IDIM.LE.NTFOR-NABS.AND.JDIM.EQ.2) VERTP(JVERT,I)=VERTP(JVERT,I)
     *    *SC
C     IF(IDIM.EQ.NTFOR.AND.JDIM.EQ.2.AND.NSIM.NE.0)
C    *                                VERTP(JVERT,I)=VERTP(JVERT,I)*SC
29    CONTINUE
C
C     CALCULATE THE X-SQUARED.
C
25    YVERT(JVERT)=0.0
      DO 40 J=1,NDUSE
      IF(VAR(J).EQ.0)GO TO 40
      YVERT(JVERT)=YVERT(JVERT)+((BUFF(J)-OBSU(J))**2/VAR(J))
40    CONTINUE
      RETURN
      END
C***********************************************************************
      SUBROUTINE FITING(VERMIN,EX,CHIMIN)
C-----------------------------------------------------------------------
      IMPLICIT REAL*8 (A-H,O-Z)
      CHARACTER * 10 CSTAT
      COMMON /OBSDAT/OBSU(16),VAR(16),EN1(16),EN2(16),
     *               IBINU(16),CIBINU(16)
      COMMON /NOBSDAT/NDUSE
      CHARACTER CIBINU*1
      COMMON /COND/ STMIN,XSQMIN,CSTAT
      COMMON /NCOND/ MAXSTP,NITER
      COMMON /BOND/ BOUND(16,3),NPARA
      COMMON /MAP/MAPFOR(16,11)
      DIMENSION VERT(16),DEL(16),XDEL(16),VERMIN(16),XSPEC(16,16),
     *    EX(16),KAETA(16)
C-----------------------------------------------------------------------
      WRITE(6,'(/,''<PROCESS OF X-SQUARE MINIMIZATION :'',
     *    I4,'' DATA WITH '',I3,'' PARAMETERS>'')') NDUSE,NPARA
      DO 1 I=1,NPARA
      VERT(I)=BOUND(I,1)
 1    DEL(I)=(BOUND(I,3)-BOUND(I,2))*0.01

      CALL FORGET(NPARA,VERT,XSPEC)
      CALL XSQR(NPARA,VERT,CHISQ0)

      P=0.001
      NITER=0
      WRITE(6,'(2X,''ITER='',I3,''    XSQ='',F10.3,''   VERT;'',
     *    12F8.3)') NITER,CHISQ0,(VERT(I),I=1,NPARA),P

2     CALL NEW(NPARA,VERT,DEL,XDEL,P,ILL)

      IF(ILL.EQ.20000) THEN
         CSTAT='TERMINATE'
         WRITE(6,'(/,34(''*''),1X,A10,34(''*'')/)') CSTAT
         GOTO 999
      ENDIF
      ICHK=0
      DO 5 I=1,NPARA
      IF(ABS(DEL(I)).GE.ABS(XDEL(I))) THEN
         DEL(I)=XDEL(I)*0.10
         if(del(i).lt.1.d-9)goto 5
         ICHK=ICHK+1
      ENDIF
5     CONTINUE

      IF(ICHK.NE.0) GOTO 2
      NITER=NITER+1
      WRITE(6,'(31X,''XDEL;'',12F8.3)') (XDEL(J),J=1,NPARA)
      IF(NITER.GT.MAXSTP) GOTO 999
      DO 3 I=1,NPARA
      VERT(I)=VERT(I)+XDEL(I)
      KAETA(I)=1
C     RESTRICT PARAMETERS TO BE POSITIVE (83.06.16)
      IF(VERT(I).LE.0) THEN
         VERT(I)=VERT(I)-XDEL(I)
         KAETA(I)=0
      ENDIF
3     CONTINUE
      CALL FORGET(NPARA,VERT,XSPEC)
      CALL XSQR(NPARA,VERT,CHISQ1)
      WRITE(6,'(2X,''ITER='',I3,''    XSQ='',  F10.3,''   VERT;'',
     *   12F8.3)') NITER,CHISQ1,(VERT(I),I=1,NPARA),P
      IF(CHISQ1/(NDUSE-NPARA).LT.XSQMIN) GOTO 1000
      IF(ABS(CHISQ0/CHISQ1-1)*100.LT.STMIN) GOTO 1000
      IF(CHISQ1.LE.CHISQ0) THEN
         DO 4 I=1,NPARA
4        DEL(I)=XDEL(I)*0.10
         P=P/10
         CHISQ0=CHISQ1
      ELSE
         DO 6 I=1,NPARA
         IF(KAETA(I).EQ.1) VERT(I)=VERT(I)-XDEL(I)
6        CONTINUE
         P=P*10
      ENDIF
      GOTO 2
1000  CSTAT='CONVERGED'
      WRITE(6,'(/,34(''*''),1X,A10,34(''*'')/)') CSTAT
999   DO 7 I=1,NPARA
7     VERMIN(I)=VERT(I)
      CHIMIN=CHISQ1
      CHIR=CHIMIN/(NDUSE-NPARA)
      WRITE(6,'(2X,''*NO. OF STEP ='',I4,'' (MAXSTP='',I4,'' )''/,
     *    ''   XSQ='',F8.3,''  PREV.XSQ='',F8.3,''  XSQR='',F7.3,/,
     *    ''   (STMIN='',F6.3,''  XSQMIN='',F7.3,'' )'')')
     *    NITER,MAXSTP,CHISQ1,CHISQ0,CHIR,STMIN,XSQMIN
      WRITE(6,'(/,2X,''*VALUES OF FREE PARAMETERS;'')')
      WRITE(6,'(2X,''  FORMULA;'',13I8)')(MAPFOR(I,2),I=1,NPARA)
      WRITE(6,'(2X,''    INDEX;'',13I8)')(MAPFOR(I,3),I=1,NPARA)
      WRITE(6,'(2X,''   PLACE#;'',13I8)')(MAPFOR(I,1),I=1,NPARA)
      WRITE(6,'(2X,''    FINAL;'',3X,13e15.7)')(VERT(I),I=1,NPARA)
      IF(NITER.GE.MAXSTP) RETURN
      CALL ESTERR(NPARA,EX,P)
      WRITE(6,'(2X,''90% ERROR;'',3X,13e15.7)')(EX(I),I=1,NPARA)
      RETURN
      END
C**********************************************************************
C*    <NEW>                                                           *
C*       CALCULATES XDEL (DIFFERENCES BETWEEM NEW AND OLD ITERATION)  *
C*       NPARA IS NUMBER OF PARAMETERS, P IS 'GENSUI KEISU'           *
C**********************************************************************
      SUBROUTINE NEW (NPARA,VERT,DEL,XDEL,P,ILL)
      IMPLICIT REAL*8 (A-H,O-Z)
CE    COMMON /ESTER/B(820)
      COMMON /ESTER/B(820),BSAVE(820)
      COMMON /OBSDAT/OBSU(16),VAR(16),EN1(16),EN2(16),
     *               IBINU(16),CIBINU(16)
      COMMON /NOBSDAT/NDUSE
      CHARACTER CIBINU*1
      DIMENSION A(16,16),ZANSA(16),Z(16),DEL(16),VERT(16),XDEL(16)
C
C   MAKE A NORMAL EQUATION B*DEL+Z=0
C


      CALL MATRXA(NPARA,VERT,DEL,A,ZANSA)

      L=0
      DO 15 I=1,NPARA
         DO 20 J=1,I
            W=0
            DO 25 K=1,NDUSE
   25       W=W+A(K,I)*A(K,J)
            L=L+1
CE 20    B(L)=W
         B(L)=W
   20    BSAVE(L)=W
         W=0
         DO 50 K=1,NDUSE
   50    W=W+A(K,I)*ZANSA(K)
         IF(W.EQ.0) THEN
            ILL=20000
            PRINT *,' ILL=20000 IN SUBROUTINE NEW '
            PRINT *,'   W=SUM(A(K,I)*ZANSA(K))=0. '
            PRINT *,'   PARAMETER - ',I
            PRINT *,'     VERT(I) - ',VERT(I)
            PRINT *,'     DEL(I)  - ',DEL(I)
            RETURN
         ENDIF
         Z(I)=-W
   15 CONTINUE
      K=0
      DO 40 I=1,NPARA
       K=K+I
CE40  B(K)=B(K)*(P+1.)
      B(K)=B(K)*(P+1.)
 40   BSAVE(K)=B(K)
C
C  SOLVE NORMAL EQUATION
C
       DLSXP=0.0
CE    CALL DLSX(B, NPARA, Z, DLSXP, 1, ILL)
      CALL DLSX2(B, NPARA, Z, ILL)
      IF(ILL.NE.0) THEN
          WRITE(6,'(1H0,10X,''*LSX CODE(NEW)='',I5)') ILL
          L=0
          DO 30 I=1,NPARA
          L1=L+1
          L=L+I
30        WRITE(6,'(14X ,12F10.3)') (B(J),J=L1,L)
          WRITE(6,'(1H0,13X ,12F10.3)') (Z(I),I=1,NPARA)
          DO 59 I=1,NPARA
59        Z(I)=0
      ENDIF
      DO 60 I=1,NPARA
   60 XDEL(I)=Z(I)
      RETURN
      END
C**********************************************************************
C*    <XSQR>                                                          *
C*    THE PURPOSE OF XSQR IS TO GIVE THE CHI-SQUARED FUNCTION         *
C*    GIVEN BY THE VARIABLES IN THE I'TH VERTEX OF THE SIMPLEX ARRAY  *
C*    VERTP                                                           *
C**********************************************************************
      SUBROUTINE XSQR(NPARA,VERT,CHISQ)
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /OBSDAT/OBSU(16),VAR(16),EN1(16),EN2(16),
     *               IBINU(16),CIBINU(16)
      COMMON /NOBSDAT/NDUSE
      CHARACTER CIBINU*1
      DIMENSION BUFF(16),VERT(16)
C
C     FEED THE PARAMETERS FROM VERTP THROUGH MAPFOR TO THE TFORPR ARRAY
C     THEN FIND CTS AS A FOLDED SPECTRUM
C
      CALL GETFOR(NPARA,VERT,BUFF)
C
C     FIND SCALING FACTOR THAT MINIMIZES X-SQ
C
      SUMD=0.
      SUMN=0.
      DO 28 I=1,NDUSE
      IF(VAR(I).LE.0)GO TO 28
      SUMD=SUMD+(BUFF(I)*BUFF(I))/VAR(I)
      SUMN=SUMN+(BUFF(I)*OBSU(I))/VAR(I)
 28   CONTINUE
      IF(SUMD.NE.0)SC=SUMN/SUMD
      DO 27 J=1,NDUSE
      BUFF(J)=BUFF(J)*SC
 27    CONTINUE
C
C     CALCULATE THE X-SQUARED.
C
25    CHISQ=0
      DO 40 J=1,NDUSE
      IF(VAR(J).EQ.0)GO TO 40
      CHISQ=CHISQ+((BUFF(J)-OBSU(J))**2/VAR(J))
40    CONTINUE
      RETURN
      END
      SUBROUTINE MATRXA(NPARA,VERTP,DEL,A,ZANSA)
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /OBSDAT/OBSU(16),VAR(16),EN1(16),EN2(16),
     *               IBINU(16),CIBINU(16)
      COMMON /NOBSDAT/NDUSE
      CHARACTER CIBINU*1
      DIMENSION A(16,16),ZANSA(16),VERTP(16),VERTQ(16),DEL(16),
     *         SPEC(16),SPEC0(16)
      CALL GETFOR(NPARA,VERTP,SPEC0)
      DO 9 I=1,NDUSE
9     ZANSA(I)=(OBSU(I)-SPEC0(I))/SQRT(VAR(I))
      DO 10 J=1,NPARA
      DO 11 K=1,NPARA
      VERTQ(K)=VERTP(K)
      IF(K.EQ.J)VERTQ(K)=VERTP(K)+DEL(K)
11    CONTINUE
      CALL GETFOR(NPARA,VERTQ,SPEC)
      DO 10 K=1,NDUSE
10    A(K,J)=-(SPEC(K)-SPEC0(K))/DEL(J)/SQRT(VAR(K))
      RETURN
      END
      SUBROUTINE ESTERR(N,EX,P)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C  A SUB PROGRAM THAT CALUCULATES ERRORS OF FIT PARAMETERS
C
C        ERROR CORESPONDS TO CHI-SQUARE MINIMUM + 2.7
C
CE    COMMON /ESTER/ B(820)
      COMMON /ESTER/ B(820),BSAVE(820)
      DIMENSION EX(16),Y(16)
      J=0
CE--- DO 1 I=1,N
*     J=J+I
C1    B(J)=B(J)/(1+P) ==> CHANGED IN '83 JULY T.OHASHI
*1    B(J)=B(J)*(1+P)
CE---
      DO 10 I=1,N
       DO 20 J=1,N
   20   Y(J)=0.
       Y(I)=2.7
       DLSXP=0.0
ce
       l=0
       do 30 i3=1,n
          do 40 i4=1,i3
             l=l+1
             B(l)=BSAVE(l)
 40       continue
 30    continue
CE     CALL DLSX(B, N, Y, DLSXP, 2, ILL)
       CALL DLSX2(B, N, Y, ILL)
       IF(ILL .NE. 0) WRITE(6,'(/,''*LSX CODE(ESTERR)='',I5)') ILL
       IF(Y(I).LT.0.) GOTO 100
       EX(I)=SQRT(Y(I))
   10 CONTINUE
      RETURN
  100 WRITE(6,699)
  699 FORMAT(/,20X,'TOO LARGE ERROR')
      RETURN
      END
C*************************************
      SUBROUTINE SETVER(VERT)
C--------------------------------------
C  SET VERT FROM TFORPR
C--------------------------------------
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /MAP/   MAPFOR(16,11)
      COMMON /BOND/ BOUND(16,3),NPARA
      COMMON /FORMU/TFORPR(16,8),TFORSC
      COMMON /NFORMU/NTFOR,NABS
      DIMENSION VERT(16)
C-------------SET VERT ------------------------------------------------
      DO 10 I=1,NPARA
        NUM=MAPFOR(I,1)
        DO 11 J=1,NUM
          IDIM=MAPFOR(I,2*J)
          JDIM=MAPFOR(I,2*J+1)
          VERT(I)=TFORPR(IDIM,JDIM)
11      CONTINUE
10    CONTINUE
      RETURN
      END
