C*************************************************
C   FITTING NO TAMENO SUBROUTINE (ASTROC ASM)    *
C   16-CH MODE NI HENKOU CHUUU                   *
C   'P01.ASTROB.FORT77(FITSUB)' WOHENKOU         *
C*************************************************
      SUBROUTINE RDBIN(NBORI,IBINU,BUF)
C--------------------------------------------------
C     READ BIN DATA
C--------------------------------------------------
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION IBINU(16),BUF(16)
      CHARACTER BUF*1
C------INITIALIZATION OF BIN DATA------------------
      DO 1 I=1,16
1      IBINU(I)=1
C------READ BIN DATA ------------------------------
      READ(5,'(16A1)') (BUF(I),I=1,NBORI)
C------INITIALIZATION -----------------------------
      MATOME=0
      IS=999
C------MATOME CHECK -------------------------------
      DO 10 I=1,NBORI
        IF(BUF(I).EQ.'<') THEN
          MATOME=1
          nadd=1
          IS=I
        ELSEIF(BUF(I).EQ.'>') THEN
          NADD=NADD+1
          MATOME=0
          DO 20 J=IS,I
20          IBINU(J)=NADD
          IS=999
        ELSE
          IF(MATOME.EQ.1) NADD=NADD+1
          IF(LGE(BUF(I),'0').AND.LLE(BUF(I),'9'))
     &              READ(BUF(I),'(I1)') IBINU(I)
        ENDIF
10    CONTINUE
CE    PRINT *,'IBINU= ',IBINU
      WRITE(6,'('' IBINU = '',2(8I1,1X))') IBINU
C------RETURN -------------------------------------
      RETURN
      END
C**********************************************************************
      SUBROUTINE GETJOB(JDISK,NOFIT,iremode)
C---------------------------------------------------------------------
C*    <GETJOB>                                                        *
C*    THE FOLLOWING CONVERGENCE CRITERIA ARE USED                     *
C*      MAXSTP IS THE MAX ALLOWED SIMPLEX STEPS                       *
C*      STMIN IF THE 1 SIGMA VARIATION AMONG SIMPLEX PTS IS LT STMIN, *
C*        THE SIMPLEX WILL STOP                                       *
C*      XSQMIN IF THE REDUCED CHI-SQ IS LT XSQMIN, THE SIMPLEX STOPS  *
C*    NTFOR IS NUMBER OF FORMULAS.                                    *
C*    ARRAY TFORPR STORE THE SPECTRAL FORMULA                         *
C*      TFORPR(I,1) IS TYPE                                           *
C*      TFORPR(I,2) IS A SCALE FACTOR                                 *
C*      TFORPR(I,3) IS AN INDEX (EG TEMPERATURE, LINE POSITION, ETC)  *
C*      TFORPR(I,4) IS A SECOND INDEX                                 *
C*      TFORPR(I,5) IS STARTING EFFECTIVE ENERGY FOR FORMULA          *
C*      TFORPR(I,6) IS ENDING ENERGY                                  *
C*      TFORPR(I,7) IS A THIRD INDEX                                  *
C*      TFORPR(I,8) IS A FOURTH INDEX                                 *
C*    NPARA IS THE NUMBER OF FREE PARAMETERS FOR SIMPLEX TO FIT. NOTE *
C*      THAT THE CODE WILL INCREASE NPARA BY 1 TO INCLUDE THE OVERALL *
C*      SCALE FACTOR, TFORSC                                          *
C*    BOUND AND MAPFOR GIVE THE SIMPLEX PARAMTERS                     *
C*      BOUND(I,1) IS THE INITIAL GUESS                               *
C*      BOUND(I,2) IS THE LOWER RANGE                                 *
C*      BOUND(I,3) IS THE UPPER RANGE                                 *
C*      MAPFOR(I,1) IS THE NUMBER OF PLACES IN TFORPR THAT THE        *
C*        PARAMETER IS USED                                           *
C*      MAPFOR(I,2) AND MPAFOR(I,3) ARE THE INDEXES OF WHERE THE      *
C*        PARAMETER IS USED IN TFORPR                                 *
C---------------------------------------------------------------------
      IMPLICIT REAL*8 (A-H,O-Z)
      character cstat*10
      COMMON /FORMU/TFORPR(16,8),TFORSC
      COMMON /NFORMU/NTFOR,NABS
C     COMMON /RESOL/NSAMP,EBINS(257),RARR(16,256),CFWSD
ce    COMMON /RESOL/NSAMP,EBINS(513),RARR(16,512),CFWSD
      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 /MAP/MAPFOR(16,11)
      COMMON /BOND/ BOUND(16,3),NPARA
ce    COMMON /GRAPH/ XX(2),YY(2),EE(2),CC(2),XF,YF
      DIMENSION JDISK(12)
      DATA MAXFOR,MAXPAR,MAXTYP/16,16,50/
C--------READ CHANNEL AND DISK NO. -----------------------------------
CE    READ(5,'(13I5)',END=99) NBORI,JDISK
      READ(5,'(/12I5//)',END=99) JDISK
      nbori=16
C--------READ BIN DATA -----------------------------------------------
      CALL RDBIN(NBORI,IBINU,CIBINU)
C--------READ CONVERSION PARAMETERS-----------------------------------
ce    READ(5,'(I5,4E10.3,I3)',END=94)MAXSTP,STMIN,XSQMIN,E1,E2,NOFIT
      READ(5,'(///I5,2E10.3,2I3/)',END=94)MAXSTP,STMIN,XSQMIN,
     &     iremode,NOFIT
CE-------SET THE ENERGY SCALE OF FIGURES -----------------------------
*     EE(1)=0.4
*     EE(2)=40.
*     IF(E1.GT.0) EE(1)=E1
*     IF(E2.GT.0) EE(2)=E2
C--------CHECK THE BIN NO. -------------------------------------------
      NON=0
      DO 20 I=1,NBORI
20    NON=NON+IBINU(I)
      IF(NON.EQ.0)GO TO 92
C--------CHECK CONVERSION PARAMETERS ---------------------------------
      IF(MAXSTP.LT.1.OR.MAXSTP.GT.900)GO TO 92
      IF(STMIN.LE.0)GO TO 92
      IF(XSQMIN.LE.0)GO TO 92
C-----READ IN TRIAL FORMULA FOR SIMPLEX IF REQUESTED------------------
      READ(5,'(//I5/)',END=94)NTFOR
      IF(NTFOR.LT.1.OR.NTFOR.GT.MAXFOR)GO TO 92
      TFORSC=1.
      NABS=0
      DO 11 I=1,NTFOR
         READ(5,'(I5,6E10.3,E7.3)',END=94)ITYPE,(TFORPR(I,J),J=2,8)
         IF(ITYPE.EQ.0.OR.IABS(ITYPE).GT.MAXTYP)GO TO 92
         IF(TFORPR(I,2).EQ.0.)GO TO 92
         TFORPR(I,1)=ITYPE
         IF(ITYPE.LT.0) NABS=NABS+1
11    CONTINUE
C-----READ FREE PARAMETERS -------------------------------------------
      READ(5,'(///I5/)',END=94)NPARA
      IF(NPARA.LT.1.OR.NPARA.GT.MAXPAR)GO TO 92
      DO 40 I=1,NPARA
      READ(5,401,END=94)(BOUND(I,J),J=1,3),(MAPFOR(I,J),J=1,11)
401   FORMAT(3E10.3,I5,15I3)
      IF(MAPFOR(I,1).LT.1)GO TO 92
      MM=MAPFOR(I,1)
      DO 41 J=1,MM
         IF(MAPFOR(I,2*J).LT.1.OR.MAPFOR(I,2*J).GT.NTFOR)GO TO 92
         IF(MAPFOR(I,2*J+1).LT.2.OR.MAPFOR(I,2*J+1).GT.8)GO TO 92
41    CONTINUE
      IF(BOUND(I,2).GE.BOUND(I,3))GO TO 92
      IF(BOUND(I,1).LE.BOUND(I,2).OR.BOUND(I,1).GE.BOUND(I,3))GO TO 92
40    CONTINUE
      RETURN
C-----ERROR CHECK ----------------------------------------------------
92    WRITE(6,'(//,''*ILLEGAL INPUT DATA DETECTED'')')
      WRITE(6,'(//,''  NTFOR, NPARA ='',2I5)') NTFOR,NPARA
      DO 91 I=1,NPARA
91    WRITE(6,98) (BOUND(I,J),J=1,3),(MAPFOR(I,J),J=1,11)
98    FORMAT(1P,3E10.3,0P,I5,15I3)
      STOP
94    WRITE(6,'('' UNEXPECTED EOF ON INPUT'')')
      STOP
99    WRITE(6,'('' EOD DETECTED '')')
      JDISK(1)=0
      RETURN
      END
C**********************************************************************
      SUBROUTINE SETDAT(IDISK,CMESG)
C----------------------------------------------------------------------
C*    <SETDAT>                                                        *
C*    IDISK; ADDRESS NO. OF THE FITTING DATA                          *
C*    SET OBSERVED DATA INTO LABELLED COMMON /OBSDAT/                 *
C*    GET DATA (BG SUBTRACTED) FROM DISK FILE #33                     *
C----------------------------------------------------------------------
      IMPLICIT REAL*8 (A-H,O-Z)
      CHARACTER CMEMO*135,CHEAD*10,CMESG*101,C1*1,CIBINU*1
      COMMON /OBSDAT/OBSU(16),VAR(16),EN1(16),EN2(16),
     *               IBINU(16),CIBINU(16)
      COMMON /NOBSDAT/NDUSE
      DIMENSION BUFF(17)
C-------INITIALIZATION-------------------------------------------------
      NUM=0
      REWIND 33
C-------SEARCH THE DATA------------------------------------------------
10    CONTINUE
      READ(33,'(A1)',END=999) C1
      IF(C1.EQ.' '.OR.C1.EQ.'-') GOTO 10
      NUM=NUM+1
      if (num.lt.idisk) goto 10
C-------READ DATA -----------------------------------------------------
      BACKSPACE 33
      READ(33,'(A10,I5,A135,F10.0)') CHEAD,NBIN,CMEMO,BUFF(1)
      READ(33,'(16F10.0)') (BUFF(I),I=2,NBIN+1)
      READ(33,'(16F10.0)') (OBSU(I),I=1,NBIN)
      READ(33,'(16F10.0)') (VAR(I),I=1,NBIN)
C------MAKR MESSAGE---------------------------
      CMESG=CHEAD//CMEMO(1:91)
C------MAKR DATA -----------------------------
      NDUSE=0
      I=1
      A=0
      B=0
      C=0
      DO 1 WHILE(I.LE.NBIN)
      IF(IBINU(I).GT.0) THEN
         JJ=IBINU(I)
         DO 2 J=1,JJ
         D=BUFF(I+1)-BUFF(I)
         A=A+OBSU(I)
         B=B+(VAR(I))**2
         C=C+D
2        I=I+1
         NDUSE=NDUSE+1
         OBSU(NDUSE)=A/C
         VAR(NDUSE)=B/C/C
         EN2(NDUSE)=BUFF(I)
         EN1(NDUSE)=EN2(NDUSE)-C
         A=0
         B=0
         C=0
      ELSE
         I=I+1
      ENDIF
1     CONTINUE
      DO 3 J=1,NDUSE
3     BUFF(J)=SQRT(VAR(J))
      DO 31 J=NDUSE+1,16
      EN1(J)=0
      EN2(J)=0
      OBSU(J)=0
      BUFF(J)=0
31    VAR(J)=0
C------RETURN --------------------------------
      RETURN
C------FOR DEBUG -----------------------------
c      WRITE(6,'(//,40X,''<< SPIN SUPERPOSED SPECTRUM '',
c     *    ''(CTS/SEC/KEV) >>'',T127//,5X,A10,'' ( '',A100,'')'')')
c     *    CHEAD,CMEMO(1:100)
c      WRITE(6,'(//,'' '',4(''  CH     E(KEV)      CTS    ERR  ''))')
c      DO 4 IY=1,32
c      IF(MOD(IY,8).EQ.1) WRITE(6,'(1H )')
c4     WRITE(6,101) (J+IY,EN1(J+IY),EN2(J+IY),
c     *               OBSU(J+IY),BUFF(J+IY),J=0,96,32)
c101   FORMAT(1H ,4(I4,') ',F5.2,'-',F5.2,F7.2,' +',F5.2,2X))
c      RETURN
C---------------------------------------------
999   WRITE(6,'(//,''  *FITTING DATA NOT FOUND; FILE NO.='',I5)') IDISK
      WRITE(CMESG,'(100X)')
      RETURN
      END
C**********************************************************************
      SUBROUTINE SETRES
C----------------------------------------------------------------------
C     <SETRES>
C     SET RESOLUTION MATRIX AND EFFICIENCY IN COMMON /RESOL/
C     READ IN MATRIX FROM #34 FOR ASM DETECTORS
C----------------------------------------------------------------------
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /RESOL/EBINS(513),RARR(16,512),CFWSD
      COMMON /NRESOL/NSAMP
C     COMMON /RESOL/NSAMP,EBINS(257),RARR(16,256),CFWSD
      COMMON /OBSDAT/OBSU(16),VAR(16),EN1(16),EN2(16),
     *               IBINU(16),CIBINU(16)
      COMMON /NOBSDAT/NDUSE
      CHARACTER CIBINU*1
      DIMENSION BUFF(512,512)
C     DIMENSION BUFF(256,256)
C-------- FOR DISCONTINUETY AT L-EDGE OF XENON
      DATA OFFSET,ELEDGE/0.046,4.81/
C-------- SIMULATION WIDTH FOR LINE -------
      CFWSD=1.0
C-------- REWIND FT34F001 -------
      REWIND 34
C------- SET ORDER OF MATRIX ----
      READ(34,'(6X,I5,25X,F6.1//////////)')NSAMP,EUPTO
C     READ(34,'(5X,I5,25X,F6.1/////)')NSAMP,EUPTO
      PRINT *,'NSAMP =',NSAMP,'  ENERGY RANGE ',EUPTO
C------- CLEAR MATRIX------------
 1001 DO 1000 I1=1,NSAMP
 1101   DO 1100 I11=1,16
          RARR(I11,I1)=0
 1100   CONTINUE
 1000 CONTINUE
C------- SET EBINS --------------
        EBINS(1)=0
        DEBIN=EUPTO/FLOAT(NSAMP)
 1201 DO 1200 I12=1,NSAMP
        EBINS(I12+1)=FLOAT(I12)*DEBIN
 1200 CONTINUE
C------- SET  512*512 MATRIX-----
      READ(34,'(13(1X,E9.3))')BUFF
C------- SET RESPONSE MATRIX-----
 2001 DO 2000 I2=1,NDUSE
        E10=EN1(I2)
        E20=EN2(I2)
 2101   DO 2100 I21=1,NSAMP
          ES1=EBINS(I21)
          ES2=EBINS(I21+1)
C------- DISCONTINUETY SET ------
          OFS=0
          IF((ES1+ES2)/2..LT.ELEDGE)OFS=OFFSET
          E1=E10-OFS
          E2=E20-OFS
C------- CHECK THE OUTPUT ENERGY AND SUMUP THE RESPONSE---
          IF(ES1.LT.E1.AND.ES2.LT.E1)GO TO 2100
          IF(ES1.LT.E1.AND.ES2.GT.E1)THEN
            FRAC=(ES2-E1)/(ES2-ES1)
 2201       DO 2200 I22=1,NSAMP
              RARR(I2,I22)=RARR(I2,I22)+BUFF(I21,I22)*FRAC
 2200       CONTINUE
          ELSEIF(ES1.GT.E1.AND.ES2.LT.E2)THEN
 2301       DO 2300 I23=1,NSAMP
              RARR(I2,I23)=RARR(I2,I23)+BUFF(I21,I23)
 2300       CONTINUE
          ELSEIF(ES1.LT.E2.AND.ES2.GT.E2)THEN
            FRAC=(E2-ES1)/(ES2-ES1)
 2401       DO 2400 I24=1,NSAMP
              RARR(I2,I24)=RARR(I2,I24)+BUFF(I21,I24)*FRAC
 2400       CONTINUE
          ENDIF
 2100   CONTINUE
C------- CHENGE TO /KEV----------
        DE=E2-E1
 2501   DO 2500 I25=1,NSAMP
          RARR(I2,I25)=RARR(I2,I25)/DE
 2500   CONTINUE
 2000 CONTINUE
      RETURN
C------- DEBUG ------------------
c      I3N=512/10+1
c        WRITE(6,'(1H ,'' EBINS(1-512) '')')
c        WRITE(6,600)EBINS
c        WRITE(6,'(1H ,'' BUFF(1-512,1-10) '')')
c 3001 DO 3000 I3=1,10
c        WRITE(6,600)(BUFF(II1,I3),II1=1,512)
c 600    FORMAT(1H ,10E10.3)
c 3000 CONTINUE
c        WRITE(6,'(1H ,'' EN1 AND EN2 '')')
c        WRITE(6,610)EN1,EN2
c 610    FORMAT(1H ,16F8.3)
c 3101 DO 3100 I31=1,16
c        WRITE(6,620)(RARR(I31,II2),II2=1,10)
c 620    FORMAT(1H ,10E10.3)
c 3100 CONTINUE
c      RETURN
C--------------------------------
      END
C**********************************************************************
      SUBROUTINE GETFOR(NPARA,VERT,YSPEC)
C----------------------------------------------------------------------
C     <GETFOR>
C     THE PURPOSE OF GETFOR IS TO LOAD A FORMULA FROM THE SIMPLEX IN
C     TRIAL SPECTRUM FORMULA AREA,  FOLD THE SPECTRAL FORMULA
C     WITH THE RESPONSE MATRIX INTO COUNTS WHICH ARE STORED IN SPEC
C----------------------------------------------------------------------
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /MAP/   MAPFOR(16,11)
      COMMON /FORMU/TFORPR(16,8),TFORSC
      COMMON /NFORMU/NTFOR,NABS
C     COMMON /RESOL/NSAMP,EBINS(257),RARR(16,256),CFWSD
      COMMON /RESOL/EBINS(513),RARR(16,512),CFWSD
      COMMON /NRESOL/NSAMP
      COMMON /OBSDAT/OBSU(16),VAR(16),EN1(16),EN2(16),
     *               IBINU(16),CIBINU(16)
      COMMON /NOBSDAT/NDUSE
      CHARACTER CIBINU*1
      DIMENSION YSPEC(16),VERT(16)
C-------------SET FREE PARAMETERS--------------------------------------
      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)
          TFORPR(IDIM,JDIM)=VERT(I)
          IF(TFORPR(IDIM,1).NE.9)GO TO 11
          IF(JDIM.NE.4)GO TO 11
          RANGE=8.*CFWSD*TFORPR(IDIM,4)
          TFORPR(IDIM,5)=TFORPR(IDIM,3)-RANGE
          TFORPR(IDIM,6)=TFORPR(IDIM,3)+RANGE
11      CONTINUE
10    CONTINUE
C-------------CLEAR SIMULATIED SPECTRA---------------------------------
      DO 24 K=1,NDUSE
24    YSPEC(K)=0.
C-------------SIMULATION ----------------------------------------------
      DO 20 I=1,NTFOR-NABS
        ITY=TFORPR(I,1)
        DO 21 J=1,NSAMP
C        -----COMPONENTS ----------------------------------------------
          E1=EBINS(J)
          E2=EBINS(J+1)
          E3=(E1+E2)/2
          IF(E2.GT.TFORPR(I,5).AND.E1.LT.TFORPR(I,6)) THEN
            IF(E1.LT.TFORPR(I,5))E1=TFORPR(I,5)
            IF(E2.GT.TFORPR(I,6))E2=TFORPR(I,6)
            CALL SPECTS(TFORPR(I,3),TFORPR(I,4),ITY,TFORPR(I,2),E1,E2,
     *        TFORPR(I,5),TFORPR(I,6),TFORPR(I,7),TFORPR(I,8),SPH)
            SPEC=SPH
C        -----ABSORPTION ----------------------------------------------
            IF(NABS.GT.0) THEN
              DO 22 K=NTFOR-NABS+1,NTFOR
                IF(E3.GE.TFORPR(K,5).AND.E3.LE.TFORPR(K,6))THEN
                  JTY=ABS(TFORPR(K,1))
                  CALL PHIV(TFORPR(K,3),TFORPR(K,4),JTY,TFORPR(K,2),E3,
     *              TFORPR(K,5),TFORPR(K,6),TFORPR(K,7),
     *              TFORPR(K,8),ABSOP)
                  SPEC=SPEC*ABSOP
                ENDIF
22            CONTINUE
            ENDIF
C        -----CONVOLUTION ---------------------------------------------
            DO 23 K=1,NDUSE
 23         YSPEC(K)=YSPEC(K)+SPEC*RARR(K,J)
          ENDIF
21      CONTINUE
20    CONTINUE
C---------RETURN ------------------------------------------------------
      RETURN
      END
C**********************************************************************
      SUBROUTINE FORGET(NPARA,VERT,XSPEC)
C----------------------------------------------------------------------
C*    <FORGET>                                                        *
C*    SET BEST FIT LINEAR PARAMETERS IN VERT                          *
C----------------------------------------------------------------------
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /MAP/   MAPFOR(16,11)
      COMMON /FORMU/TFORPR(16,8),TFORSC
      COMMON /NFORMU/NTFOR,NABS
C     COMMON /RESOL/NSAMP,EBINS(257),RARR(16,256),CFWSD
      COMMON /RESOL/EBINS(513),RARR(16,512),CFWSD
      COMMON /NRESOL/NSAMP
      COMMON /OBSDAT/OBSU(16),VAR(16),EN1(16),EN2(16),
     *               IBINU(16),CIBINU(16)
      COMMON /NOBSDAT/NDUSE
      CHARACTER CIBINU*1
      DIMENSION XSPEC(16,16),C(16),VERT(16)
C--------------SET FREE PARAMETERS-------------------------------------
      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)
          TFORPR(IDIM,JDIM)=VERT(I)
          IF(TFORPR(IDIM,1).NE.9)GO TO 11
          IF(JDIM.NE.4)GO TO 11
          RANGE=5.*CFWSD*TFORPR(IDIM,4)
          TFORPR(IDIM,5)=TFORPR(IDIM,3)-RANGE
          TFORPR(IDIM,6)=TFORPR(IDIM,3)+RANGE
11      CONTINUE
10    CONTINUE
C--------------SIMULATION START ---------------------------------------
      DO 20 I=1,NTFOR-NABS
C--------------CLEAR OUTPUT SPECTRUM-----------------------------------
        DO 24 K=1,NDUSE
24      XSPEC(K,I)=0.
C--------------SIMULATION ---------------------------------------------
        ITY=TFORPR(I,1)
        DO 21 J=1,NSAMP
          E1=EBINS(J)
          E2=EBINS(J+1)
          E3=(E1+E2)/2
          IF(E2.GT.TFORPR(I,5).AND.E1.LT.TFORPR(I,6)) THEN
            IF(E1.LT.TFORPR(I,5))E1=TFORPR(I,5)
            IF(E2.GT.TFORPR(I,6))E2=TFORPR(I,6)
            CALL SPECTS(TFORPR(I,3),TFORPR(I,4),ITY,TFORPR(I,2),E1,E2,
     *        TFORPR(I,5),TFORPR(I,6),TFORPR(I,7),TFORPR(I,8),SPH)
            SPEC=SPH
C--------------ABSORPTION ---------------------------------------------
            IF(NABS.GT.0) THEN
              DO 22 K=NTFOR-NABS+1,NTFOR
                IF(E3.GE.TFORPR(K,5).AND.E3.LE.TFORPR(K,6)) THEN
                  JTY=ABS(TFORPR(K,1))
                  CALL PHIV(TFORPR(K,3),TFORPR(K,4),JTY,TFORPR(K,2),E3,
     *              TFORPR(K,5),TFORPR(K,6),TFORPR(K,7),
     *              TFORPR(K,8),ABSOP)
                  SPEC=SPEC*ABSOP
                ENDIF
22            CONTINUE
            ENDIF
C--------------CONVOLUTION---------------------------------------------
            DO 23 K=1,NDUSE
 23         XSPEC(K,I)=XSPEC(K,I)+SPEC*RARR(K,J)
          ENDIF
21      CONTINUE
20    CONTINUE
C--------------SCALE DETERMINATION-------------------------------------
      CALL LINFIT(XSPEC,NTFOR-NABS,C)
C     WRITE(6,'(30X,''   LINFIT;'',10F8.3)') (C(K),K=1,NTFOR-
C    *    NABS)
C--------------CHECGE THE SCALE ---------------------------------------
      DO 26 I=1,NTFOR-NABS
        DO 27 J=1,NDUSE
27      XSPEC(J,I)=XSPEC(J,I)*C(I)
        TFORPR(I,2)=TFORPR(I,2)*C(I)
26    CONTINUE
C--------------CHECGE THE SCALE PARAMETERS-----------------------------
      DO 25 I=1,NPARA
        NUM=MAPFOR(I,1)
        DO 25 J=1,NUM
          IDIM=MAPFOR(I,2*J)
          JDIM=MAPFOR(I,2*J+1)
          IF(IDIM.LE.NTFOR-NABS.AND.JDIM.EQ.2)
     &            VERT(I)=TFORPR(IDIM,JDIM)
25    CONTINUE
C--------------RETURN -------------------------------------------------
      RETURN
      END
C
C**********************************************************************
      SUBROUTINE LINFIT(F,M1,C)
C----------------------------------------------------------------------
C     <LINFIT>
C     SET BEST FIT LINEAR PARAMETERS
C----------------------------------------------------------------------
      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 F(16,16),B(120),C(16),Z(16)
      dimension indx(16),a(16,16)
C----------------------------------------------------------------------
      L=0
      DO 10 I=1,M1
        DO 20 J=1,I
          W=0.0
          DO 30 K=1,NDUSE
            W=W+F(K,I)*F(K,J)/VAR(K)
   30     CONTINUE
          L=L+1
          B(L)=W
   20   CONTINUE
        W=0.
        DO 40 K=1,NDUSE
          W=W+F(K,I)*OBSU(K)/VAR(K)
   40   CONTINUE
        Z(I)=W
   10 CONTINUE
      DLSXP=0.0
CE    CALL DLSX(B,M1,Z,DLSXP,1,ILL)
      CALL DLSX2(B,M1,Z,1,ILL,INDX,A)
CE    IF(ILL.NE.0) WRITE(6,'(//,''*LSX CODE(LINFIT)='',I5)') ILL
      DO 50 I=1,M1
50    C(I)=Z(I)
      RETURN
      END
