**********************************************************************
C*    <SFITASM>                                                       *
C*    PROGRAM TO PERFORM CHI-SQUARED FITTING FOR GINGA ASM DATA       *
C*    USING SIMPLEX TECHNIQUE INTRODUCED BY E.FENIMORE OF LANL        *
C*    MODIFIED BY T.OHASHI IN 1983 MAY-JUNE                           *
C*    MODIFIED BY S.KITAMOTO IN 1987 MAY                              *
C*    MODIFIED BY S.KITAMOTO IN 1988 JULY                             *
C*    MODIFIED BY W.EGOSHI IN 1994 OCT 3 FOR UNIX VERSION             *
C**********************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      CHARACTER FNAME(45)*10,CMEMO*101,C(50)*80,CSTAT*10
      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 /COND/  STMIN,XSQMIN,CSTAT
      COMMON /NCOND/  MAXSTP,NITER
      COMMON /FORMU/TFORPR(16,8),TFORSC
      COMMON /NFORMU/NTFOR,NABS
      COMMON /MAP/MAPFOR(16,11)
      DIMENSION BUFF(16),EBUF(17),VERT(16),XSPEC(16,16),JDISK(12),
     *      EX(16),BUF1(16),VERTI(16),BUF2(16),BUF3(16)
      DATA (FNAME(I),I=1,20)/'POWER LAW ','LIANG TC  ','TB CLASSCL',
     *          'BLACK BODY','TB REL GNT','TB E-E    ','EXPONENT  ',
     *          'SEG POWER ','GAUSSIAN  ','GAL ABSORP','FEI ABSORP',
     *          'FE-VAR ABS','FEXXVI ABS','FEXXV ABS ','EXP CUTOFF',
     *          'DIFFUSE BK',' ','DISK BB ',' ',' '/
      DATA FNAME(45)/'M&M ABS.  '/
ce const
      integer MXROW
      parameter (MXROW=16)
      character CHI*11
      parameter (CHI='\\gx\\u2\\d')
ce var
      logical exflag
      character fname1*60,fname2*60
      real y(MXROW,20)
      integer iery(15),nvec,ncmd,ier
      character cmd(65)*130

C--------- READ SOURCE NAME --------------------------------------------
 1000 continue
      write(*,*) 'Please input source file name !'
      read(*,'(a)') fname1
      write(*,*)
ce    write(fname1,'(''spec/'',a)') fname0
      inquire(file=fname1,exist=exflag)
      if (.not.exflag) then
         write(*,*) 'File cannot be found! Input once again!'
         write(*,*)
         goto 1000
      endif
      open(33,file=fname1,status='old')
C--------- SET PARAMETERS ----------------------------------------------
 1010 continue
      write(*,*) 'Please input parameter file name !'
      read(*,'(a)') fname2
      write(*,*)
      inquire(file=fname2,exist=exflag)
      if (.not.exflag) then
         write(*,*) 'File cannot be found! Input once again!'
         write(*,*)
         goto 1010
      endif
      open(5,file=fname2,status='old')
      CALL GETJOB(JDISK,NOFIT,iremode)
      close(5)
      IF(JDISK(1).EQ.0)GO TO 999
C--------- SET PARAMETERS FOR SIMPLEX ----------------------------------
      DO 10 I=1,NPARA
10    VERTI(I)=BOUND(I,1)
C--------- LOOP FOR DATA SEAQUENCES ------------------------------------
      DO 100 ITRY=1,12
C--------- DATA END CHECK ----------------------------------------------
        IF(JDISK(ITRY).LE.0) GOTO 998
C--------- SET DATA ----------------------------------------------------
        CALL SETDAT(JDISK(ITRY),CMEMO)
C--------- SET RESPONCE FUNCTIONS --------------------------------------
*        open(34,file=
*     &       '/export/home/kitamoto/Asm/program/osf/response/asm.rsp',
*     &       status='old')
        open(34,file=
     &       '/home/kitamoto/Asm/Asm/analysus_tool/response/asm.rsp',
     &       status='old')

        write(*,*)
        write(*,*) 'Now reading response file !!'
        CALL SETRES
        close(34)
C--------- SET PARAMETERS FOR SIMPLEX ----------------------------------
        DO 11 I=1,NPARA
11      BOUND(I,1)=VERTI(I)
C--------- CLEAR COMENTS -----------------------------------------------
        DO 8 I=1,50
8       WRITE(C(I),'(80X)')
CE-------- MAKE AND WRITE COMENTS --------------------------------------
        WRITE(6,600) CMEMO(1:62),CMEMO(70:101),(CIBINU(I),I=1,16)
600     FORMAT(//,13X,'<< SIMPLEX + LINEAR-LSQ FIT FOR GINGA ASM',
     &   ' SPECTRUM >>'//,
     &   '<ANALYSED DATA>'/,2X,A62/,2X,A32/,2X,2(8A1,1X)//,
     &   '<TRIAL FORMULA>'/,9X,'   TYPE   ',1X,'  SCALE   ',1X,
     &   '1-ST INDEX',1X,'2-ND INDEX',1X,'START(KEV)',1X,'STOP(KEV) ',
     &   1X,'3-RD INDEX')
        WRITE(C(1),'(20X,''<< SIMPLEX + LINEAR-LSQ FIT FOR'',
     &      '' GINGA ASM SPECTRUM'','' >>'')')
        WRITE(C(2),'(''<DATA>'')')
        WRITE(C(3),'(1X,A26)')CMEMO(1:26)
        WRITE(C(4),'(2X,A34)')CMEMO(29:62)
        WRITE(C(5),'(2X,A32)')CMEMO(70:101)
        WRITE(C(6),'(1X,2(8A1,1X))') (CIBINU(I),I=1,16)
        C(7)=' '
        WRITE(C(8),'(''<TRIAL FORMULA>'')')
        WRITE(C(9),'(10X,''   TYPE   '',1X,''  SCALE   '',1X,
     &       ''1-ST INDEX'',1X,''2-ND INDEX'')')
        WRITE(C(10),'(22X,''START(KEV)'',1X,''STOP(KEV) '',1X,
     &       ''3-RD INDEX'')')
        IC=10
        DO 6 I=1,NTFOR
          ITYPE=TFORPR(I,1)
          WRITE(6,'(I3,1H),I4,1X,A10,6(1X,F9.3))')
     &              I,ITYPE,FNAME(IABS(ITYPE)),(TFORPR(I,J),J=2,7)
          IC=IC+1
          WRITE(C(IC),'(I3,1H),I4,1X,A10,3(1X,F9.3))')
     &              I,ITYPE,FNAME(IABS(ITYPE)),(TFORPR(I,J),J=2,4)
          IC=IC+1
          WRITE(C(IC),'(22X,3(1X,F9.3))') (TFORPR(I,J),J=5,7)
 6     continue
CE
        WRITE(6,'(/,''<CONV. CONDITIONS>''/,2X,''MAX STEP ='',I5,
     &    ''  XSQ-VARIATION ='',F6.3,''%  REDUCED VALUE ='',F6.3)')
     &    MAXSTP,STMIN,XSQMIN
        IC=IC+1
        C(IC)=' '
        IC=IC+1
        WRITE(C(IC),'(''<CONV. CONDITIONS>'')')
        IC=IC+1
        WRITE(C(IC),'(2X,''MAX STEP ='',I5)') MAXSTP
        IC=IC+1
        WRITE(C(IC),'(2X,a8,''-VARIATION ='',F6.3,''%'')') CHI,STMIN
        IC=IC+1
        WRITE(C(IC),'(2X,''REDUCED VALUE ='',F6.3)') XSQMIN
CE
        WRITE(6,'(/,''<FREE PARAMETERS; NO. ='',I3,'' >'')')NPARA
        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,''  INITIAL;'',3X,13F8.3)') (BOUND(I,1),I=1,NPARA)
        WRITE(6,'(2X,''    LOWER;'',3X,13F8.3)') (BOUND(I,2),I=1,NPARA)
        WRITE(6,'(2X,''    UPPER;'',3X,13F8.3)') (BOUND(I,3),I=1,NPARA)
        IC=IC+1
        C(IC)=' '
        IC=IC+1
        WRITE(C(IC),'(''<FREE PARAMETERS; NO. ='',I3,'' >'')')NPARA
        IC=IC+1
        WRITE(C(IC),'(2X,''FORMULA;'',13I8)') (MAPFOR(I,2),I=1,NPARA)
        IC=IC+1
        WRITE(C(IC),'(2X,''INDEX;   '',13I8)')(MAPFOR(I,3),I=1,NPARA)
        IC=IC+1
        WRITE(C(IC),'(2X,''PLACE#;  '',13I8)')(MAPFOR(I,1),I=1,NPARA)
        IC=IC+1
        WRITE(C(IC),'(2X,''INITIAL;  '',3X,13F8.3)')
     &                                         (BOUND(I,1),I=1,NPARA)
        IC=IC+1
        WRITE(C(IC),'(2X,''LOWER;  '',3X,13F8.3)')
     &                                         (BOUND(I,2),I=1,NPARA)
        IC=IC+1
        WRITE(C(IC),'(2X,''UPPER;  '',3X,13F8.3)') 
     &                                         (BOUND(I,3),I=1,NPARA)
C--------- CALL SIMPLEX ------------------------------------------------
        IF(NOFIT.NE.1)THEN
          STMIN=STMIN*6
          CALL SIMPLX(VERT,CHIMIN)
CE-------- MAKE AND WRITE THE RESULTS OF THE SIMPLEX -------------------
          IC=IC+1
          IF(VERT(1).LT.10000)
     &      WRITE(C(IC),'(2X,''SIMPLEX; '',3X,13F8.3)')
     &         (VERT(I),I=1,NPARA)
          IF(VERT(1).GE.10000)
     &      WRITE(C(IC),'(2X,''SIMPLEX; '',3X,F8.2,12F8.3)')
     &         (VERT(I),I=1,NPARA)
          RXSQ=CHIMIN/(NDUSE-NPARA)
          IC=IC+1
          WRITE(C(IC),'(4X,a8,''='',F8.3,''   RED. '',a8,''='',F7.3)')
     &                 CHI,CHIMIN,CHI,RXSQ
          IC=IC+1
          WRITE(C(IC),'(4X,''('',I4,'' DATA ;'',I3,'' PARAMETERS )'')')
     &                 NDUSE,NPARA
          IC=IC+1
          WRITE(C(IC),'(7X,A10,''IN'',I3,'' STEPS'')') CSTAT,NITER
C--------- CALL FIT ----------------------------------------------------
          STMIN=STMIN/6
          DO 9 I=1,NPARA
9         BOUND(I,1)=VERT(I)
CE        CALL FIT(VERT,EX,CHIMIN)
          CALL FITING(VERT,EX,CHIMIN)
CE-------- MAKE AND WRITE THE RESULTS OF THE FIT -----------------------
          IC=IC+1
          WRITE(C(IC),'(2X,''FINAL;    '',3X,13E15.7)') 
     &         (VERT(I),I=1,NPARA)
          IC=IC+1
          WRITE(C(IC),'(2X,''90%ERROR;'',2X,13E15.7)')(EX(I),I=1,NPARA)
          RXSQ=CHIMIN/(NDUSE-NPARA)
          IC=IC+1
          WRITE(C(IC),'(4X,a8,''='',F8.3,''   RED. '',a8,''='',F7.3)')
     &         CHI,CHIMIN,CHI,RXSQ
          IC=IC+1
          WRITE(C(IC),'(4X,''('',I4,'' DATA ;'',I3,'' PARAMETERS )'')')
     &         NDUSE,NPARA
          IC=IC+1
          WRITE(C(IC),'(7X,A10,''IN'',I3,'' STEPS'')') CSTAT,NITER
C--------- PLOT THE COMMENTS -------------------------------------------
        ELSE
          CALL SETVER(VERT)
        ENDIF
CE-------- PLOT THE OBSERVED DATA --------------------------------------
        DO 1 J=1,NDUSE
          EBUF(J)=EN1(J)
          BUFF(J)=SQRT(VAR(J))
1       CONTINUE
        EBUF(NDUSE+1)=EN2(NDUSE)
ce
        iery(1)=1
        iery(2)=1
        do 50 i5=1, nduse
           y(i5,1) = (ebuf(i5)+ebuf(i5+1)) / 2.0
           y(i5,2) = y(i5,1) - ebuf(i5)
           y(i5,3) = obsu(i5)
           y(i5,4) = buff(i5)
 50     continue
C--------- SIMULATION OF BEST FIT MODEL SPECTRUM -----------------------
        CALL GETFOR(NPARA,VERT,BUFF)
C--------- SET THE RESIDUALS -------------------------------------------
        DO 3 I=1,NDUSE
          VAR(I)=SQRT(VAR(I))
        BUF2(I)=(OBSU(I)-BUFF(I))
        BUF3(I)=(OBSU(I)-BUFF(I))/BUFF(I)
 3      BUF1(I)=BUF2(I)/VAR(I)
ce
        iery(3)=0
        do 51 i5=1, nduse
           y(i5,5) = buff(i5)
 51     continue
C--------- SIMULATION OF EACH COMPONENTS OF BEST FIT MODEL--------------
        CALL FORGET(NPARA,VERT,XSPEC)
C--------- PLOT  EACH COMPONENTS OF BEST FIT MODEL----------------------
        DO 4 I=1,NTFOR-NABS
          iery(3+I)=0
          DO 5 J=1,NDUSE
ce
c&&          BUFF(J)=XSPEC(J,I)
          y(J,5+I)=XSPEC(J,I)
 5        continue
 4      continue
C--------- LP OUT & PLOT   THE RESULTS OF THE FITTING -----------------
        WRITE(6,602)
602     FORMAT(/,'     ENERGY(KEV)   DATA   ERR    FIT  ',
     &      ' RESID MODEL1 MODEL2 MODEL3 (D-M)/M ')
        DO 12 I=1,16
*          IF(MOD(I,10).EQ.1) WRITE(6,'(1X)')
12      WRITE(6,601) I,EN1(I),EN2(I),OBSU(I),VAR(I),BUFF(I),BUF1(I),
     &      (XSPEC(I,K),K=1,3),BUF3(I)
 601    format(I3,10(E14.6, 1x))
*601     FORMAT(I3,') ',F5.2,'-',F5.2,F7.3,'+',F6.3, E14.6, 1x, 5F7.3)
        write(*,*)
ce
        ncomp=NTFOR-NABS
        iery(3+ncomp+1)=1
        do 52 i5=1, nduse
           if(iremode.eq.1) then
              y(i5,5+ncomp+1) = buf2(i5)
              y(i5,5+ncomp+2) = var(i5)
           else
              y(i5,5+ncomp+1) = buf2(i5)/y(i5,4)
              y(i5,5+ncomp+2) = var(i5)/y(i5,4)
           endif
 52     continue

        cmd(1)='LAB X ENERGY (KEV)'
        cmd(2)='LAB Y COUNTS/SEC/KEV'
        write(cmd(3),'(''LINE ST 3 '',10(i2,1x))') (3+i,i=1,ncomp)
        cmd(4)='WIN 1'
        write(cmd(5),'(''YAX 2 3 '',10(i2,1x))') (3+i,i=1,ncomp)
        cmd(6)='LOC 0.5 0.302 1 0.9'
        cmd(7)='LAB NX OFF'
        cmd(8)='LOG Y ON'
        cmd(9)='WIN 2'
        write(cmd(10),'(''YAX '',i2)') 3+ncomp+1
        cmd(11)='LOC 0.5 0.1 1 0.39'
        cmd(12)='LAB 1 POS 1.E-3, 0 " " LI 0 100 LS 2 JUS Lef'
        cmd(13)='WIN ALL'
        cmd(14)='LOG X ON 1 2'
        cmd(15)='R X 1 20'
        write(cmd(16),'(''LAB 2 VPOS 0.05 0.94 CS 1 J L "'',a80,
     &       '' "'')') C(1)
        do 53 i5=1,IC-1
           write(cmd(16+i5),'(''LAB '',i2,'' VPOS 0.1 '',f5.2,
     &          '' CS 0.7 J L "'',a80,'' "'')') i5+2,0.93-0.02*i5,
     &          C(i5+1)
 53     continue
        nvec=3+ncomp+1
        ncmd=16+IC-1
C**        call plt(y,iery,MXROW,nduse,nvec,cmd,ncmd,ier)
CC--------- NEXT DATA --------------------------------------------------
 100  CONTINUE
 998  CONTINUE
C--------- CLOSE THE NLP -----------------------------------------------
 999  CONTINUE
C--------- END ---------------------------------------------------------
      close(33)
      STOP
      END
