C===========================================================================
C Copyright (C) 1995-2010 European Southern Observatory (ESO)
C
C This program is free software; you can redistribute it and/or 
C modify it under the terms of the GNU General Public License as 
C published by the Free Software Foundation; either version 2 of 
C the License, or (at your option) any later version.
C
C This program is distributed in the hope that it will be useful,
C but WITHOUT ANY WARRANTY; without even the implied warranty of
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public 
C License along with this program; if not, write to the Free 
C Software Foundation, Inc., 675 Massachusetts Ave, Cambridge, 
C MA 02139, USA.
C
C Correspondence concerning ESO-MIDAS should be addressed as follows:
C       Internet e-mail: midas@eso.org
C       Postal address: European Southern Observatory
C                       Data Management Division 
C                       Karl-Schwarzschild-Strasse 2
C                       D 85748 Garching bei Muenchen 
C                       GERMANY
C===========================================================================
C
C.VERSION
C 
C 100701	last modif  KB
C 

C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
      SUBROUTINE GetIDN(TblNam,inum,iok)
C
C     Reads the highest IDnumer in a table  "TblNam"
C     iok=0 if ok
C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
        implicit none
        character*(*)TblNam
        integer iok,inum

        include 'MID_REL_INCL:fit_var.inc'
        integer TabID,ist,icol
        integer i,j,k1,k2,n,in,i1,i2,i3
        logical inull,isel

        INTEGER MADRID(1)
        INCLUDE 'MID_INCLUDE:ST_DEF.INC'

        COMMON/VMR/MADRID

        INCLUDE 'MID_INCLUDE:ST_DAT.INC'

        i1=1                    !doesn't stop on errors
        i2=0
        i3=0
        call STECNT('PUT',i1,i2,i3)

        call TBTOPN(TblNam,F_IO_MODE,TabID,ist)   !open
        if (ist.ne.0) then
           iok=1
           return
        end if 

        call TBLSER(TabID,'ID',icol,ist)

        call TBCSRT(TabID,1,icol,1,ist)  ! sort

        call TBIGET(TabID,I,J,K1,k2,n,ist)      !n. of written rows

        do j=n,1,-1
           call TBSGET(TabID,j,isel,ist)   ! checks selection
           call TBERDI(TabID,j,icol,in,inull,ist)
           if (ist.ne.0) then
              iok=1
              return
           end if
           if (.not.inull.and.isel) then
              inum=in
              CALL TBTCLO(TabID,ist)
              i1=0              !doesn't stop on errors
              i2=2
              i3=1
              call STECNT('PUT',i1,i2,i3)
              return
           end if
        end do

        CALL TBTCLO(TabID,ist)
        i1=0                    !doesn't stop on errors
        i2=2
        i3=1
        call STECNT('PUT',i1,i2,i3)
        return

        end



C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
      SUBROUTINE SavRes(TblNam,iok)
C
C     Saves the results on the output table "TblNam"
C     iok=0 if ok
C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
        character*(*)TblNam
        integer iok

        include 'MID_REL_INCL:fit_var.inc'

        integer j,i1,i2,i3,i,k1,k2,n
        integer TabID,ist
        integer icol(25)
        integer itot

        logical inull

        INTEGER MADRID(1)
        INCLUDE 'MID_INCLUDE:ST_DEF.INC'

        COMMON/VMR/MADRID

        INCLUDE 'MID_INCLUDE:ST_DAT.INC'

C!!!!!!!
C       Creates/opens the table and reads the column numbers
C!!!!!!!
        i1=1                    !doesn't stop on errors
        i2=0
        i3=0
        call STECNT('PUT',i1,i2,i3)

        call TBTOPN(TblNam,F_IO_MODE,TabID,ist)   !open

      if (ist.ne.0) then      !not found, creates
        call TBTINI(TblNam,F_TRANS,F_O_MODE,21,1,TabID,ist)
        call TBCINI(TabID,D_C_FORMAT,14,'A14',' ','Element',icol(1),i)
        call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','LamCen',icol(2),i)
        call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','Dlam',icol(3),i)
        call TBCINI(TabID,D_R8_FORMAT,1,'F9.7',' ','Redshift',icol(22)
     1       ,i)
        call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','ColDen',icol(4),i)
        call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','DCol',icol(5),i)
        call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','B',icol(6),i)
        call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','DB',icol(7),i)
        call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','BTur',icol(8),i)
        call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','DBtur',icol(9),i)
        call TBCINI(TabID,D_R8_FORMAT,1,'F7.0',' ','Temperature',
     1       icol(23),i)
        call TBCINI(TabID,D_R8_FORMAT,1,'F8.2',' ','Eq_Width',icol(10),
     1       i)
        call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','chi2',icol(11),i)
        call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','Prob',
     1       icol(12) ,i)
        call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','Dlam_p',icol(13),i)
        call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','Dlam_n',icol(14),i)
        call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','DCol_p',icol(15),i)
        call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','DCol_n',icol(16),i)
        call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','DB_p',icol(17),i)
        call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','DB_n',icol(18),i)
        call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','DBTur_p',icol(19)
     1       ,i)
        call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','DBTur_n',icol(20),
     1       i)
        call TBCINI(TabID,D_I4_FORMAT,1,'I5',' ','ID',icol(21),i)

      else 

        call TBLSER(TabID,'Element',icol(1),ist)
        call TBLSER(TabID,'LamCen',icol(2),ist)
        call TBLSER(TabID,'DLam',icol(3),ist)
        call TBLSER(TabID,'Redshift',icol(22),ist)
        if (icol(22).eq.-1) then
           call TBCINI(TabID,D_R8_FORMAT,1,'F9.7',' ',
     1       'Redshift',icol(22),i)
        end if
        call TBLSER(TabID,'ColDen',icol(4),ist)
        call TBLSER(TabID,'DCol',icol(5),ist)
        call TBLSER(TabID,'B',icol(6),ist)
        call TBLSER(TabID,'DB',icol(7),ist)
        call TBLSER(TabID,'BTur',icol(8),ist)
        call TBLSER(TabID,'DBTur',icol(9),ist)
        call TBLSER(TabID,'Temperature',icol(23),ist)
        if (icol(23).eq.-1) then
           call TBCINI(TabID,D_R8_FORMAT,1,'F7.0',' ',
     1       'Temperature',icol(23),i)
        end if
        call TBLSER(TabID,'Eq_Width',icol(10),ist)
        call TBLSER(TabID,'chi2',icol(11),ist)
        call TBLSER(TabID,'Prob',icol(12),ist)
        call TBLSER(TabID,'Dlam_p',icol(13),ist)
        call TBLSER(TabID,'Dlam_n',icol(14),ist)
        call TBLSER(TabID,'DCol_p',icol(15),ist)
        call TBLSER(TabID,'DCol_n',icol(16),ist)
        call TBLSER(TabID,'DB_p',icol(17),ist)
        call TBLSER(TabID,'DB_n',icol(18),ist)
        call TBLSER(TabID,'DBtur_p',icol(19),ist)
        call TBLSER(TabID,'DBtur_n',icol(20),ist)
        call TBLSER(TabID,'ID',icol(21),ist)

        call TBIGET(TabID,I,J,K1,k2,n,ist)      !n. of written rows
        itot=0
        do j=1,n
           call TBERDI(TabID,j,icol(21),i,inull,ist)
           if (.not.inull) itot=itot+1
        end do
      end if  

C!!!!!!!
C       Writes the variables
C!!!!!!!
      IF (NROWS.GT.0) THEN
        do j=itot+1,itot+nrows
           call TBEWRC(TabID,j,icol(1),ElmtNm(j-itot),ist)
           call TBEWRR(TabID,j,icol(2),LamCen(j-itot),ist)
           call TBEWRR(TabID,j,icol(3),ErLaPa(j-itot),ist)
           call TBEWRR(TabID,j,icol(22),Redshi(j-itot),ist)
           call TBEWRR(TabID,j,icol(4),NHfit(j-itot),ist)
           call TBEWRR(TabID,j,icol(5),ErNnPa(j-itot),ist)
           call TBEWRR(TabID,j,icol(6),BDopp(j-itot),ist)
           call TBEWRR(TabID,j,icol(7),ErBbPa(j-itot),ist)
           call TBEWRR(TabID,j,icol(8),BTur(j-itot),ist)
           call TBEWRR(TabID,j,icol(9),ErBtPa(j-itot),ist)
           call TBEWRR(TabID,j,icol(23),Temper(j-itot),ist)
           call TBEWRR(TabID,j,icol(10),w(j-itot),ist)
           call TBEWRR(TabID,j,icol(11),chi,ist)
           call TBEWRR(TabID,j,icol(12),prob,ist)
           call TBEWRR(TabID,j,icol(13),ErLaPo(j-itot),ist)
           call TBEWRR(TabID,j,icol(14),ErLaNe(j-itot),ist)
           call TBEWRR(TabID,j,icol(15),ErNnPo(j-itot),ist)
           call TBEWRR(TabID,j,icol(16),ErNnNe(j-itot),ist)
           call TBEWRR(TabID,j,icol(17),ErBbPo(j-itot),ist)
           call TBEWRR(TabID,j,icol(18),ErBbNe(j-itot),ist)
           call TBEWRR(TabID,j,icol(19),ErBtPo(j-itot),ist)
           call TBEWRR(TabID,j,icol(20),ErBtNe(j-itot),ist)
           call TBEWRI(TabID,j,icol(21),IDnum,ist)
        end do

      END IF

        CALL TBTCLO(TabID,ist)

        i1=0                    !doesn't stop on errors
        i2=2
        i3=1
        call STECNT('PUT',i1,i2,i3)

        return
        end



C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
      SUBROUTINE FitWin(nconv,iflag)
C     
C     Calcola la finestra su cui eseguire il fit,
C     e salva la porzione corrispondente dello spettro
C     sul file 'fdummy.spe'
C     
C     
C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
      
      IMPLICIT NONE
      integer nconv,iflag
      
      INCLUDE 'MID_REL_INCL:fit_var.inc'
      integer ind_low,ind_up,old_up
      integer ij,ik,is
      
      real xmin,xmax,var
      real fwhmth               ! threshold in FWHM!!!!!
      
      INTEGER MADRID(1)
      INCLUDE 'MID_INCLUDE:ST_DEF.INC'
      
      COMMON/VMR/MADRID
      
      INCLUDE 'MID_INCLUDE:ST_DAT.INC'

      fwhmth=8.
      iflag=0                   ! default: no error
      nconv=0
      old_up=1
      
c!!!!!!!
C     Apre file fdummy.spe
C!!!!!!!
      open(10,file='fdummy.spe',status='old',iostat=is) !
      close(10,status='DELETE')
      
      open(10,file='fdummy.spe',status='new',iostat=is) !
      if (is.ne.0) then
         call ErrMsg('Error in opening fdummy.spe')
         iflag=-1
         return
      end if
      
      
      do ij = 1,NINTFT
C!!!!!!!
C     Cerca gli indici del primo ed ultimo punto della finestra ij-esima
C!!!!!!!
         xmin=FITMIN(ij)
         xmax=FITMAX(ij)
         
         do ik=1,NPUNTI
            if (XLAMBD(ik).gt.xmin) goto 100
         end do
 100     ind_low=ik             ! indice inferiore
         
         do ik=ind_low,NPUNTI
            if (XLAMBD(ik).gt.xmax) goto 200
         end do
 200     ind_up=ik              ! indice superiore
         
         xmin = FITMIN(ij) - fwhmth * FWHM(ind_low)
         xmax = FITMAX(ij) + fwhmth * FWHM(ind_up)
         
         do ik=1,NPUNTI
            if (XLAMBD(ik).gt.xmin) goto 300
         end do
 300     ind_low=ik             ! indice inferiore
         
         do ik=ind_low,NPUNTI
            if (XLAMBD(ik).gt.xmax) goto 400
         end do
 400     ind_up=ik              ! indice superiore
      
   
         if (ind_low.lt.old_up) then
            ind_low = old_up + 1
         end if
c         old_up = ind_low
         old_up = ind_up
         
         if (ind_low.lt.ind_up) then
            do ik = ind_low,ind_up
               var=SIGNOI(ik)*SIGNOI(ik)
               write(10,'(5G20.12)')XLAMBD(ik),PIXSIZ(ik),SPECTR(ik),
     +              var,FWHM(ik)
c               write(10,'(5G20.12)')XLAMBD(ik),SPECTR(ik),var,FWHM(ik)
               nconv = nconv +1
            end do
            if (nconv.gt.NMXWRK) then
               iflag=-1
               return
            end if
         end if
      end do
      
      close(10)
      
      
      return
      end
      
      

C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
        SUBROUTINE SMINUI(TblNam,nrun,IER)
C
C     
C       Saves the MINUIT INSTRUCTIONS on a table.
C     nrun is the IDNumber of the run. If nrun=1 a new table
C     is created.
C     On error in creating the table,  ier=1
C     otherwise ier=0
C
C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&

        implicit none

        character*(*) TblNam
        integer ier,nrun

        include 'MID_REL_INCL:fit_var.inc'

        integer j,i1,i2,i3,i4,nlines
        integer TabID,ist
        integer icol(2)
C
        INTEGER MADRID(1)
        INCLUDE 'MID_INCLUDE:ST_DEF.INC'

        COMMON/VMR/MADRID

        INCLUDE 'MID_INCLUDE:ST_DAT.INC'

        i1=1                    !doesn't stop at errors..
        i2=0
        i3=0
        call STECNT('PUT',i1,i2,i3)

        if (nrun.lt.1) then
           ier=-1
           return
        end if

        if (nrun.gt.1) then
           call TBTOPN(TblNam,F_IO_MODE,TabID,ist) !open
           if (ist .ne. 0 ) then ! if it doesn't exist, create
              call TBTINI(TblNam,F_TRANS,F_O_MODE,1,10,TabID,ist)
              if (ist .ne. 0 ) then
                 ier=1
                 return
              end if   
              call TBCINI(TabID,D_C_FORMAT,50,'A50',' ','MINUIT'
     1             ,icol(1),ist)
              call TBCINI(TabID,D_I4_FORMAT,1,'i9',' ','ID',
     1             icol(2),ist)
           end if
        end if
        if (nrun.eq.1) then
           call TBTINI(TblNam,F_TRANS,F_O_MODE,1,10,TabID,ist)
           if (ist .ne. 0 ) then
              ier=1
              return
           end if
           call TBCINI(TabID,D_C_FORMAT,50,'A50',' ','MINUIT',icol(1)
     1          ,ist)
           call TBCINI(TabID,D_I4_FORMAT,1,'i9',' ','ID',icol(2)
     1          ,ist)
        end if
        
        call TBIGET(TabID,i1,nlines,i3,i4,i2,ist) !n. of written lines

        do j=1+nlines,NMINCM+nlines
           call TBEWRC(TabID,j,icol(1),MINCOM(j-nlines),ist)
           call TBEWRI(TabID,j,icol(2),nrun,ist)
        end do
        
        CALL TBTCLO(TabID,ist)
        
        i1=0                    !reset standard values..
        i2=2
        i3=1
        call STECNT('PUT',i1,i2,i3)
        
        return
        end








C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
        SUBROUTINE RMINUI(TblNam,nrun,IER)
C
C     
C       Reads the MINUIT INSTRUCTIONS from a table.
C     Onerror in reading the table,  ier=1
C     otherwise ier=0
C
C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
        implicit none

        character*(*) TblNam
        integer ier,nrun

        include 'MID_REL_INCL:fit_var.inc'

        logical inull,isel
        integer i,j,i1,i2,i3,i4,ntest,in
        integer TabID,ist
        integer icol(2)
        character*50 ctest

        INTEGER MADRID(1)
        INCLUDE 'MID_INCLUDE:ST_DEF.INC'

        COMMON/VMR/MADRID

        INCLUDE 'MID_INCLUDE:ST_DAT.INC'

        if (nrun.lt.1) then
           ier=-1
           return
        end if

        do i=1,NMXLIN
           MINCOM(i)=' '
        end do
        NMINCM=0
        if (TblNam.eq.'SCRATCH') return

        i1=1                    !doesn't stop at errors..
        i2=0
        i3=0
        call STECNT('PUT',i1,i2,i3)

        call TBTOPN(TblNam,F_IO_MODE,TabID,ist)   !open
        if (ist .ne. 0 ) then       ! if it doesn't exist, return err
           call seterr('ON')
           ier=1
           return
        end if
        call TBLSER(TabID,'MINUIT',icol(1),ist)
        call TBLSER(TabID,'ID',icol(2),ist)
        call TBIGET(TabID,i1,i2,i3,i4,ntest,ist)

        
        i=0
        do j=1,ntest
           call TBSGET(TabID,j,isel,ist)   ! checks selection
           call TBERDI(TabID,j,icol(2),in,inull,ist)
           if (ist.ne.0) then
              ier=1
              return
           end if
           if (.not.inull.and.isel) then
              if (in.eq.nrun) then
                 call TBERDC(TabID,j,icol(1),ctest,inull,ist)
                 i = i +1 
                 CALL FT_EOS(ctest,50,MINCOM(i),ist)
              end if
           end if
        end do

        NMINCM=i
        
        CALL TBTCLO(TabID,ist)

        i1=0                    !reset standard values..
        i2=2
        i3=1
        call STECNT('PUT',i1,i2,i3)

        return
        end





C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
        SUBROUTINE SINTVL(TblNam,nrun,IER)
C
C     
C       Saves the intervals for the fit on a table.
C     Onerror in creating the table,  ier=1
C     otherwise ier=0
C
C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
        implicit none

        character*(*) TblNam
        integer ier,nrun

        include 'MID_REL_INCL:fit_var.inc'

        integer j,i1,i2,i3,i4,nlines
        integer TabID,ist
        integer icol(3)

C        include 'MID_REL_INCL:fit_mid.inc'
        INTEGER MADRID(1)
        INCLUDE 'MID_INCLUDE:ST_DEF.INC'

        COMMON/VMR/MADRID

        INCLUDE 'MID_INCLUDE:ST_DAT.INC'

        i1=1                    !reset standard values..
        i2=0
        i3=0
        call STECNT('PUT',i1,i2,i3)

        if (nrun.lt.1) then
           ier=-1
           return
        end if

C
C     opens or creates...
C
        if (nrun.gt.1) then
           call TBTOPN(TblNam,F_IO_MODE,TabID,ist) !open
           if (ist .ne. 0 ) then ! if it doesn't exist, create
              call TBTINI(TblNam,F_TRANS,F_O_MODE,2,10,TabID,ist)
              if (ist .ne. 0 ) then
                 ier=1
                 return
              end if
              call TBCINI(TabID,D_R8_FORMAT,1,'F8.2',' ','FITMIN'
     1             ,icol(1),ist)
              call TBCINI(TabID,D_R8_FORMAT,1,'F8.2',' ','FITMAX'
     1             ,icol(2),ist)
              call TBCINI(TabID,D_I4_FORMAT,1,'i9',' ','ID',
     1             icol(3),ist)
           end if
        end if

        if (nrun.eq.1) then
           call TBTINI(TblNam,F_TRANS,F_O_MODE,1,10,TabID,ist)
           if (ist .ne. 0 ) then
              ier=1
              return
           end if
           call TBCINI(TabID,D_R8_FORMAT,1,'F8.2',' ','FITMIN'
     1          ,icol(1),ist)
           call TBCINI(TabID,D_R8_FORMAT,1,'F8.2',' ','FITMAX'
     1          ,icol(2),ist)
           call TBCINI(TabID,D_I4_FORMAT,1,'i9',' ','ID',
     1             icol(3),ist)
        end if

        call TBIGET(TabID,i1,nlines,i3,i4,i2,ist) !n. of written lines

c
c     writes..
c
        do j=1+nlines,NINTFT+nlines
           call TBEWRD(TabID,j,icol(1),FITMIN(j-nlines),ist)
           call TBEWRD(TabID,j,icol(2),FITMAX(j-nlines),ist)
           call TBEWRI(TabID,j,icol(3),nrun,ist)
        end do

        CALL TBTCLO(TabID,ist)

        i1=0                    !reset standard values..
        i2=2
        i3=1
        call STECNT('PUT',i1,i2,i3)

        return
        end








C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
        SUBROUTINE RINTVL(TblNam,nrun,IER)
C
C     
C       Reads the intervals for the fit from a table.
C     Onerror in reading the table,  ier=1
C     otherwise ier=0
C
C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
        implicit none

        character*(*) TblNam
        integer ier,nrun

        include 'MID_REL_INCL:fit_var.inc'

        logical inull,isel
        integer i,j,i1,i2,i3,i4,ntest
        integer TabID,ist,in
        integer icol(3)

C        include 'MID_REL_INCL:fit_mid.inc'
        INTEGER MADRID(1)
        INCLUDE 'MID_INCLUDE:ST_DEF.INC'

        COMMON/VMR/MADRID

        INCLUDE 'MID_INCLUDE:ST_DAT.INC'

        if (nrun.lt.1) then
           ier=-1
           return
        end if

        do i=1,NMXLIN
           FITMIN(i)=0.
           FITMAX(i)=0.
        end do
        NINTFT=0
        if (TblNam.eq.'SCRATCH') return

        call seterr('OFF')

        call TBTOPN(TblNam,F_IO_MODE,TabID,ist)   !open
        if (ist .ne. 0 ) then       ! if it doesn't exist, return err
           call seterr('ON')
           ier=1
           return
        end if
        call TBLSER(TabID,'FITMIN',icol(1),ist)
        call TBLSER(TabID,'FITMAX',icol(2),ist)
        call TBLSER(TabID,'ID',icol(3),ist)
        call TBIGET(TabID,i1,i2,i3,i4,ntest,ist)

        
        i=0
        do j=1,ntest
           call TBSGET(TabID,j,isel,ist)   ! checks selection
           call TBERDI(TabID,j,icol(3),in,inull,ist)
           if (ist.ne.0) then
              ier=1
              return
           end if
           if (.not.inull.and.isel) then
              if (in.eq.nrun) then
                 i = i +1 
                 call TBERDD(TabID,j,icol(1),FITMIN(i),inull,ist)
                 call TBERDD(TabID,j,icol(2),FITMAX(i),inull,ist)
                 if (ist.ne.0) then
                    ier=1
                    return
                 end if
              end if
           end if
        end do

        NINTFT=i
        
        CALL TBTCLO(TabID,ist)

        call seterr('ON')

        return
        end



C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
        SUBROUTINE F_TBLR(TblNam,nrun,ier)
C
C     
C       Reads the "lypar" table and store the values in the 
C       COMMON variables
C       On error then ier =-1
C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
        implicit none

        character*(*) TblNam
        integer ier,nrun
        

        include 'MID_REL_INCL:fit_var.inc'

        logical inull,isel
        integer i,j,k,itest
        integer TabID,ist
        integer icol(COLTBL)
        integer i1,i2,i3

        CHARACTER*14  ctest
 
C        include 'MID_REL_INCL:fit_mid.inc'
        INTEGER MADRID(1)
        INCLUDE 'MID_INCLUDE:ST_DEF.INC'

        COMMON/VMR/MADRID

        INCLUDE 'MID_INCLUDE:ST_DAT.INC'

        ier = 0
C!!!!!!!
C       reset  the variables to defaults
C!!!!!!!
        do i=1,NMXLIN
           ElmtNm(i)=' '
           LamIni(i)=0.
           BIni(i)=0.
           BtuIni(i)=0.
           NIni(i)=0.
           CPAR(1,i)=' '
           CPAR(2,i)=' '
           CPAR(3,i)=' '
           CPAR(4,i)=' '
           LamMin(i)=0.
           LamMax(i)=0.
           BMin(i)=0.
           BMax(i)=0.
           BtuMin(i)=0.
           BtuMax(i)=0.
           NMin(i)=0.
           NMax(i)=0.
           LamSte(i)=0.005
           BSte(i)=0.01
           BtuSte(i)=0.01
           NSte(i)=0.01
           CoefL(i)=0.
           CoefB(i)=0.
           CoefN(i)=0.
           CoefBT(i)=0.
           Class(i)=' '
           grID(i)=0
           AtmLam(i)=0.
           AtmFos(i)=0.
           AtmGam(i)=0.
           AtmMas(i)=0.
        end do
        NROWS=0

        if (TblNam.eq.'SCRATCH') return


C!!!!!!!
C       Opens the tables and reads the column numbers
C!!!!!!!

        i1=1                    !doesn't stop at errors..
        i2=0
        i3=0
        call STECNT('PUT',i1,i2,i3)

        call TBTOPN(TblNam,F_IO_MODE,TabID,ist)   !open
        if (ist .ne. 0 ) then       ! if it doesn't exist, create
           ier=-1
           return
        end if

        call TBIGET(TabID,I,J,K,k,nrows,ist)      !n. of rows


        call TBLSER(TabID,'Element',icol(1),ist)
        call TBLSER(TabID,'L_ini',icol(2),ist)
        call TBLSER(TabID,'P_l',icol(3),ist)
        call TBLSER(TabID,'N_ini',icol(4),ist)
        call TBLSER(TabID,'P_n',icol(5),ist)
        call TBLSER(TabID,'b_ini',icol(6),ist)
        call TBLSER(TabID,'P_b',icol(7),ist)
        call TBLSER(TabID,'bt_ini',icol(8),ist)
        call TBLSER(TabID,'P_bt',icol(9),ist)
        call TBLSER(TabID,'L_min',icol(10),ist)
        call TBLSER(TabID,'L_max',icol(11),ist)
        call TBLSER(TabID,'N_min',icol(12),ist)
        call TBLSER(TabID,'N_max',icol(13),ist)
        call TBLSER(TabID,'b_min',icol(14),ist)
        call TBLSER(TabID,'b_max',icol(15),ist)
        call TBLSER(TabID,'bt_min',icol(16),ist)
        call TBLSER(TabID,'bt_max',icol(17),ist)
        call TBLSER(TabID,'L_step',icol(18),ist)
        call TBLSER(TabID,'n_step',icol(19),ist)
        call TBLSER(TabID,'b_step',icol(20),ist)
        call TBLSER(TabID,'bt_step',icol(21),ist)
        call TBLSER(TabID,'Coef_l',icol(22),ist)
        call TBLSER(TabID,'Coef_n',icol(23),ist)
        call TBLSER(TabID,'Coef_b',icol(24),ist)
        call TBLSER(TabID,'Coef_bt',icol(25),ist)
        call TBLSER(TabID,'Class',icol(26),ist)
        call TBLSER(TabID,'grp',icol(27),ist)
        call TBLSER(TabID,'atm_lam',icol(28),ist)
        call TBLSER(TabID,'atm_fos',icol(29),ist)
        call TBLSER(TabID,'atm_gam',icol(30),ist)
        call TBLSER(TabID,'atm_mas',icol(31),ist)
        call TBLSER(TabID,'ID',icol(32),ist)

   
C!!!!!!!
C       Reads the variables
C for char. elements we read the table elements into ctest,
C and get the end of the string,
C and then convert to a clean (blank terminated) Fortran char. string
C - not needed for Class(i), it's a single char.
C 
C!!!!!!!

        i=0
        do j=1,nrows
           call TBSGET(TabID,j,isel,ist)   ! checks selection
           call TBERDI(TabID,j,icol(32),itest,inull,ist)
           if (.not.inull.and.isel) then
            if (itest.eq.nrun) then  
             i = i +1 
             call TBERDC(TabID,j,icol(1),ctest,inull,ist)
             call FT_EOS(ctest,14,ElmtNm(i),ist)
             call TBERDD(TabID,j,icol(2),LamIni(i),inull,ist)
             call TBERDC(TabID,j,icol(3),ctest,inull,ist)
             call FT_EOS(ctest,4,CPar(1,i),ist)
             call TBERDD(TabID,j,icol(4),NIni(i),inull,ist)
             call TBERDC(TabID,j,icol(5),ctest,inull,ist)
             call FT_EOS(ctest,4,CPar(2,i),ist)
             call TBERDD(TabID,j,icol(6),BIni(i),inull,ist)
             call TBERDC(TabID,j,icol(7),ctest,inull,ist)
             call FT_EOS(ctest,4,CPar(3,i),ist)
             call TBERDD(TabID,j,icol(8),BtuIni(i),inull,ist)
             call TBERDC(TabID,j,icol(9),ctest,inull,ist)
             call FT_EOS(ctest,4,CPar(4,i),ist)
             call TBERDD(TabID,j,icol(10),LamMin(i),inull,ist)
             call TBERDD(TabID,j,icol(11),LamMax(i),inull,ist)
             call TBERDD(TabID,j,icol(12),NMin(i),inull,ist)
             call TBERDD(TabID,j,icol(13),NMax(i),inull,ist)
             call TBERDD(TabID,j,icol(14),BMin(i),inull,ist)
             call TBERDD(TabID,j,icol(15),BMax(i),inull,ist)
             call TBERDD(TabID,j,icol(16),BtuMin(i),inull,ist)
             call TBERDD(TabID,j,icol(17),BtuMax(i),inull,ist)
             call TBERDD(TabID,j,icol(18),LamSte(i),inull,ist)
             call TBERDD(TabID,j,icol(19),NSte(i),inull,ist)
             call TBERDD(TabID,j,icol(20),BSte(i),inull,ist)
             call TBERDD(TabID,j,icol(21),BtuSte(i),inull,ist)
             call TBERDD(TabID,j,icol(22),CoefL(i),inull,ist)
             call TBERDD(TabID,j,icol(23),CoefN(i),inull,ist)
             call TBERDD(TabID,j,icol(24),CoefB(i),inull,ist)
             call TBERDD(TabID,j,icol(25),CoefBt(i),inull,ist)
C  Class(i) is 1 char., so  we don't need to use ctest and then FT_EOS()
             call TBERDC(TabID,j,icol(26),Class(i),inull,ist)
             call TBERDI(TabID,j,icol(27),grID(i),inull,ist)
             call TBERDD(TabID,j,icol(28),AtmLam(i),inull,ist)
             call TBERDD(TabID,j,icol(29),AtmFos(i),inull,ist)
             call TBERDD(TabID,j,icol(30),AtmGam(i),inull,ist)
             call TBERDD(TabID,j,icol(31),AtmMas(i),inull,ist)

            end if 
           end if  
        end do

        nrows=i

        CALL TBTCLO(TabID,ist)

        i1=0                    !stop on errors
        i2=2
        i3=1
        call STECNT('PUT',i1,i2,i3)

        return
        end

C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
        SUBROUTINE ShPar1(header)
C     
C
C       Prints on the screen the content of lypar.tbl more 
C       frequently accessed by the user.
C
C       if header = 'NORMAL" the columns are well explained;
C       if header = 'EDITPARAM" only column symbols are written
C
C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
        implicit none
        character*(*) header

        include 'MID_REL_INCL:fit_var.inc'
        
        integer ifound(NMXLIN) 
        integer i,ist,j,ni,is
        character a
        character*80 strout
        character*9Parcar(4,NMXLIN)

C
        INTEGER MADRID(1)
        INCLUDE 'MID_INCLUDE:ST_DEF.INC'

        COMMON/VMR/MADRID

        INCLUDE 'MID_INCLUDE:ST_DAT.INC'

        do i=1,NMXLIN
           ifound(i)=0
        end do
        
        do i=1,4
           do j=1,NROWS
              call CnvrtP(CPar(i,j),ni,a,is)
              if (ifound(ni).eq.0.and.a.ne.'Z'.and.a.ne.'T') then 
                                     !never found yet nor constrained
                 ifound(ni) =1
                 if(i.eq.1) write(ParCar(i,j),97) ' ',LamIni(j),' ' 
                 if(i.eq.2) write(ParCar(i,j),98) '  ',NIni(j),' ' 
                 if(i.eq.3) write(ParCar(i,j),99) '  ',BIni(j),' ' 
                 if(i.eq.4) write(ParCar(i,j),99) '  ',BtuIni(j),' ' 
              else
                 if(i.eq.1) write(ParCar(i,j),97) '(',LamIni(j) ,')'
                 if(i.eq.2) write(ParCar(i,j),98) ' (',NIni(j),')' 
                 if(i.eq.3) write(ParCar(i,j),99) ' (',BIni(j),')' 
                 if(i.eq.4) write(ParCar(i,j),99) ' (',BtuIni(j),')' 
              end if   
 97           format(a1,f7.2,a1)
 98           format(a2,f6.3,a1)
 99           format(a2,f6.2,a1)

           end do
        end do



        call sttdis(' ',0,ist)
        write(strout,'(25x,a30)')'** Current Parameter Table **'
        call sttdis(strout,0,ist)
        call sttdis(' ',0,ist)

c        write(strout,*)' # ','   Element    '
        if (header.eq.'NORMAL') then
           write(strout,*)'  #', '  Element     ','   lambda'
     1          ,'       ','   column',' den.  ','     b  ',
     2          '      ','     bT  ','      ' 
        end if
        if (header.eq.'EDITPARAM') then
           write(strout,*)'  #', '  E           ','      L  '
     1          ,'   PL  ','     N   ','  PN   ','     B  ',
     2          '  PB  ','     BT  ','  PT  ' 
        end if

        call sttdis(strout,0,ist)  
        call sttdis(' ',0,ist)
        do i=1,nrows
          write(strout,100)i,ElmtNm(i),ParCar(1,i),CPar(1,i),
     1         ParCar(2,i),CPar(2,i),ParCar(3,i),CPar(3,i),ParCar(4,i)
     2          ,CPar(4,i)
           call sttdis(strout,0,ist)
        end do   

 100    format (i3,1x,A14,A9,'[',A4,']',A9,'[',A4,']',
     1       A9,'[',A4,']',A9,'[',A4,']')


        return
        end
           


C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
        SUBROUTINE F_TBLW(TblNam,nrun,ier)
C
C     
C       Writes  the initial parameters  on a table 
C
C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
        implicit none

        character*(*) TblNam
        integer ier,nrun

        include 'MID_REL_INCL:fit_var.inc'

        integer j,i,i1,i2,i3,k1,k2,nlines
        integer TabID,ist
        integer icol(COLTBL)
        
C
        INTEGER MADRID(1)
        INCLUDE 'MID_INCLUDE:ST_DEF.INC'

        COMMON/VMR/MADRID

        INCLUDE 'MID_INCLUDE:ST_DAT.INC'


C!!!!!!!
C       Creates the table and reads the column numbers
C!!!!!!!
      i1=1                    !doesn't stop on errors
      i2=0
      i3=0
      call STECNT('PUT',i1,i2,i3)
      
      if (nrun.lt.1) then
         ier=-1
         return
      end if      
      
      if (nrun.gt.1) then
         call TBTOPN(TblNam,F_IO_MODE,TabID,ist) !open
      end if

      if (ist.ne.0.or.nrun.eq.1) then
         call TBTINI(TblNam,F_TRANS,F_O_MODE,COLTBL,1,TabID,ist)
         if (ist.ne.0) then
            ier=1
            return
         end if
         call TBCINI(TabID,D_C_FORMAT,14,'A14',' ','Element',icol(1),i)
         call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','L_ini',icol(2),i)
         call TBCINI(TabID,D_C_FORMAT,4,'A4',' ','P_l',icol(3),i)
         call TBCINI(TabID,D_R8_FORMAT,1,'F5.2',' ','N_ini',icol(4),i)
         call TBCINI(TabID,D_C_FORMAT,4,'A4',' ','P_n',icol(5),i)
         call TBCINI(TabID,D_R8_FORMAT,1,'F6.2',' ','b_ini',icol(6),i)
         call TBCINI(TabID,D_C_FORMAT,4,'A4',' ','P_b',icol(7),i)
         call TBCINI(TabID,D_R8_FORMAT,1,'F6.2',' ','bt_ini',icol(8),i)
         call TBCINI(TabID,D_C_FORMAT,4,'A4',' ','P_bt',icol(9),i)
         call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','l_min',icol(10),i)
         call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','l_max',icol(11),i)
         call TBCINI(TabID,D_R8_FORMAT,1,'F5.2',' ','N_min',icol(12),i)
         call TBCINI(TabID,D_R8_FORMAT,1,'F5.2',' ','N_max',icol(13),i)
         call TBCINI(TabID,D_R8_FORMAT,1,'F6.2',' ','b_min',icol(14),i)
         call TBCINI(TabID,D_R8_FORMAT,1,'F6.2',' ','B_max',icol(15),i)
        call TBCINI(TabID,D_R8_FORMAT,1,'F6.2',' ','bt_min',icol(16),i)
        call TBCINI(TabID,D_R8_FORMAT,1,'F6.2',' ','bt_max',icol(17),i)
        call TBCINI(TabID,D_R8_FORMAT,1,'F7.3',' ','l_step',icol(18),i)
        call TBCINI(TabID,D_R8_FORMAT,1,'F6.3',' ','n_step',icol(19),i)
        call TBCINI(TabID,D_R8_FORMAT,1,'F6.3',' ','b_step',icol(20),i)
        call TBCINI(TabID,D_R8_FORMAT,1,'F7.3',' ',
     1       'bt_step',icol(21),i)
        call TBCINI(TabID,D_R8_FORMAT,1,'E12.6',' ','Coef_l',
     1       icol(22),i)
        call TBCINI(TabID,D_R8_FORMAT,1,'F3.1',' ','Coef_n',icol(23),i)
        call TBCINI(TabID,D_R8_FORMAT,1,'E12.6',' ','Coef_b',
     1       icol(24),i)
        call TBCINI(TabID,D_R8_FORMAT,1,'F3.1',' ','Coef_bt',
     1       icol(25),i)
        call TBCINI(TabID,D_C_FORMAT,1,'A1',' ','Class',icol(26),i)
        call TBCINI(TabID,D_I4_FORMAT,1,'I2',' ','grp',icol(27),i)
        call TBCINI(TabID,D_R8_FORMAT,1,'F10.4',' ',
     1       'atm_lam',icol(28),i)
        call TBCINI(TabID,D_R8_FORMAT,1,'F7.5',' ',
     1       'atm_fos',icol(29),i)
        call TBCINI(TabID,D_R8_FORMAT,1,'E10.5',' ',
     1       'atm_gam',icol(30),i)
        call TBCINI(TabID,D_R8_FORMAT,1,'F7.5',' ',
     1       'atm_mas',icol(31),i)
        call TBCINI(TabID,D_I4_FORMAT,1,'i9',' ','ID',
     1             icol(32),ist)

      else 

         call TBLSER(TabID,'Element',icol(1),ist)
         call TBLSER(TabID,'L_ini',icol(2),ist)
         call TBLSER(TabID,'P_l',icol(3),ist)
         call TBLSER(TabID,'N_ini',icol(4),ist)
         call TBLSER(TabID,'P_n',icol(5),ist)
         call TBLSER(TabID,'b_ini',icol(6),ist)
         call TBLSER(TabID,'P_b',icol(7),ist)
         call TBLSER(TabID,'bt_ini',icol(8),ist)
         call TBLSER(TabID,'P_bt',icol(9),ist)
         call TBLSER(TabID,'L_min',icol(10),ist)
         call TBLSER(TabID,'L_max',icol(11),ist)
         call TBLSER(TabID,'N_min',icol(12),ist)
         call TBLSER(TabID,'N_max',icol(13),ist)
         call TBLSER(TabID,'b_min',icol(14),ist)
         call TBLSER(TabID,'b_max',icol(15),ist)
         call TBLSER(TabID,'bt_min',icol(16),ist)
         call TBLSER(TabID,'bt_max',icol(17),ist)
         call TBLSER(TabID,'L_step',icol(18),ist)
         call TBLSER(TabID,'n_step',icol(19),ist)
         call TBLSER(TabID,'b_step',icol(20),ist)
         call TBLSER(TabID,'bt_step',icol(21),ist)
         call TBLSER(TabID,'Coef_l',icol(22),ist)
         call TBLSER(TabID,'Coef_n',icol(23),ist)
         call TBLSER(TabID,'Coef_b',icol(24),ist)
         call TBLSER(TabID,'Coef_bt',icol(25),ist)
         call TBLSER(TabID,'Class',icol(26),ist)
         call TBLSER(TabID,'grp',icol(27),ist)
         call TBLSER(TabID,'atm_lam',icol(28),ist)
         call TBLSER(TabID,'atm_fos',icol(29),ist)
         call TBLSER(TabID,'atm_gam',icol(30),ist)
         call TBLSER(TabID,'atm_mas',icol(31),ist)
         call TBLSER(TabID,'ID',icol(32),ist)

c         if (nrun.eq.1) then    ! delete all rows
c            call TBIGET(TabID,I,j,K1,k2,nlines,ist) !n. of rows
c            do j=1,nlines
c               call TBRDEL(TabID,j,ist)
c               call TBSPUT(TabID,j,.false.,ist)
c            end do
c         end if
      end if

      call TBIGET(TabID,I,nlines,K1,k2,j,ist) !n. of rows


C!!!!!!!
C       Writes the variables
C!!!!!!!

      IF (NROWS.GT.0) THEN
        do j=1+nlines,nrows+nlines
             call TBEWRC(TabID,j,icol(1),ElmtNm(j-nlines),ist)
             call TBEWRD(TabID,j,icol(2),LamIni(j-nlines),ist)
             call TBEWRC(TabID,j,icol(3),CPar(1,j-nlines),ist)
             call TBEWRD(TabID,j,icol(4),NIni(j-nlines),ist)
             call TBEWRC(TabID,j,icol(5),CPar(2,j-nlines),ist)
             call TBEWRD(TabID,j,icol(6),BIni(j-nlines),ist)
             call TBEWRC(TabID,j,icol(7),CPar(3,j-nlines),ist)
             call TBEWRD(TabID,j,icol(8),BtuIni(j-nlines),ist)
             call TBEWRC(TabID,j,icol(9),CPar(4,j-nlines),ist)
             call TBEWRD(TabID,j,icol(10),LamMin(j-nlines),ist)
             call TBEWRD(TabID,j,icol(11),LamMax(j-nlines),ist)
             call TBEWRD(TabID,j,icol(12),NMin(j-nlines),ist)
             call TBEWRD(TabID,j,icol(13),NMax(j-nlines),ist)
             call TBEWRD(TabID,j,icol(14),BMin(j-nlines),ist)
             call TBEWRD(TabID,j,icol(15),BMax(j-nlines),ist)
             call TBEWRD(TabID,j,icol(16),BtuMin(j-nlines),ist)
             call TBEWRD(TabID,j,icol(17),BtuMax(j-nlines),ist)
             call TBEWRD(TabID,j,icol(18),LamSte(j-nlines),ist)
             call TBEWRD(TabID,j,icol(19),NSte(j-nlines),ist)
             call TBEWRD(TabID,j,icol(20),BSte(j-nlines),ist)
             call TBEWRD(TabID,j,icol(21),BtuSte(j-nlines),ist)
             call TBEWRD(TabID,j,icol(22),CoefL(j-nlines),ist)
             call TBEWRD(TabID,j,icol(23),CoefN(j-nlines),ist)
             call TBEWRD(TabID,j,icol(24),CoefB(j-nlines),ist)
             call TBEWRD(TabID,j,icol(25),CoefBt(j-nlines),ist)
             call TBEWRC(TabID,j,icol(26),Class(j-nlines),ist)
             call TBEWRI(TabID,j,icol(27),grID(j-nlines),ist)
             call TBEWRD(TabID,j,icol(28),AtmLam(j-nlines),ist)
             call TBEWRD(TabID,j,icol(29),AtmFos(j-nlines),ist)
             call TBEWRD(TabID,j,icol(30),AtmGam(j-nlines),ist)
             call TBEWRD(TabID,j,icol(31),AtmMas(j-nlines),ist)
             call TBEWRI(TabID,j,icol(32),nrun,ist)
        end do

      END IF
      
      CALL TBTCLO(TabID,ist)

      i1=0                      !stop on errors
      i2=2
      i3=1
      call STECNT('PUT',i1,i2,i3)
      
      return
      end

C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
        SUBROUTINE CnvrtP(PmtCar,PmtInt,Link,ist)
C       (ConvertParameter)
C     
C       Analizes a Parameter definition (char*4) and returns
C       the relative parameter number, the kind of link 
C       converted to uppercase (if it exists),
C       and sets ist=1 if link exists, 0 if it doesn't
C       -1 if any error occurs
C
C     PmtCar    IN     Parameter character  (e.g. 10.T)
C     PmtInt    OUT    Parameter number     (e.g. 10)
C     Link      OUT    link (if exists)     (e.g. T)
C     ist       OUT    Exists the link?(Y=1)(e.g. 1)
C                                      (N=0)
C                                   (err=-1)
C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
        implicit none

        character*4 PmtCar
        integer PmtInt,ist
        character Link

        character*4 App
        integer idx

        ist=0
        Link=' '

        idx=index(PmtCar,'.T')
        if (idx.ne.0) then
           App=PmtCar
           App(idx:idx+1)='  '
           read(App,'(I4)')PmtInt
           Link='T'
           ist=1
           return
        end if
        idx=index(PmtCar,'.t')
        if (idx.ne.0) then
           App=PmtCar
           App(idx:idx+1)='  '
           read(App,'(I4)')PmtInt
           Link='T'
           ist=1
           return
        end if

        idx=index(PmtCar,'.Z')
        if (idx.ne.0) then
           App=PmtCar
           App(idx:idx+1)='  '
           read(App,'(I4)')PmtInt
           Link='Z'
           ist=1
           return
        end if
        idx=index(PmtCar,'.z')
        if (idx.ne.0) then
           App=PmtCar
           App(idx:idx+1)='  '
           read(App,'(I4)')PmtInt
           Link='Z'
           ist=1
           return
        end if           

        idx=index(PmtCar,'.F')
        if (idx.ne.0) then
           App=PmtCar
           App(idx:idx+1)='  '
           read(App,'(I4)')PmtInt
           Link='F'
           ist=1
           return
        end if
        idx=index(PmtCar,'.f')
        if (idx.ne.0) then
           App=PmtCar
           App(idx:idx+1)='  '
           read(App,'(I4)')PmtInt
           Link='F'
           ist=1
           return
        end if

        if (ist.ne.1) then
           read(PmtCar,'(I4)',err=100)PmtInt
           return                  ! RETURN OK
        end if


 100    ist=-1
        return
        end


           
C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
        SUBROUTINE ChkPar(ErrMsg,ist)
c       
C       Checks the consistency of the parameter definition
C       stored in memory. First looks for unrecoverable (SEVERE)
C       errors (ist=1), then for recoverable errors (ist=2)
C       or general warnings (ist=2)
C       and tries to correct them.
C       In case of severe errors returns a message in ErrMsg;
C       in case of recoverable messages displays a warning.
C
C       Kind and classification of errors investigated:
C      
C  Severe: 1- Unidentified symbols (e.g. 10.j, or 10T, or 10.)
C          2- Same parameter number in different columns
C            (e.g. parm. n. 10 is both a wavelength and a b-value.
C          3- Wrong parameter link (e.g. 10.T on a wave. col.) 
C          4- Prameter number negative
C          5- Parameter numbers not contiguous
C
C  Recover:1- Parameters fixed only sometimes (10 and 10.F)
C          2-
C          3
C     
C  Warning:1-  
C
C  Further actions: if TURBLN.eq.0 writes the correct CPar(4,j)
C   
C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
        character*(*) ErrMsg
        integer ist

        include 'MID_REL_INCL:fit_var.inc'

        integer IPar(4,NMXLIN)
        
        integer i,j,is,np(NMXFRE),fp(NMXFRE),ni,nmx
        character a

C        include 'MID_REL_INCL:fit_mid.inc'
        INTEGER MADRID(1)
        INCLUDE 'MID_INCLUDE:ST_DEF.INC'

        COMMON/VMR/MADRID

        INCLUDE 'MID_INCLUDE:ST_DAT.INC'


        ist=0
        ErrMsg=' '
C!!!!!!!
C       ** 1 SEVERE ERROR:  Unidentified symbols (meanwhile
C       converts parameter definition in parameter numbers)
C!!!!!!!
        
        do i=1,4
           do j=1,NROWS
              call CnvrtP(CPar(i,j),IPar(i,j),a,is)
              if (is.eq.-1) then
                 write(ErrMsg,101)CPar(i,j),i,j
                 ist=1
                 return
              end if                
           end do
        end do
 101    format('SEVERE ERROR: UNIDENTIFIED SYMBOL ',A4,i3,i3)

C!!!!!!!
C       ** 2 SEVERE ERROR:  same par. number in different columns
C!!!!!!!

        do j=1,NROWS
           do i=1,NROWS                  
              if (IPar(1,j).eq.IPar(2,i).and.(j.ne.i)) then
                 write(ErrMsg,102)IPar(1,j)
                 ist=1
                 return
              end if
           END DO
        end do   


 102    format('SEVERE ERROR: PARAMETER ',I3,' 
     1       DEFINED ON MORE COLUMNS')


C!!!!!!!
C       ** 3 SEVERE ERROR:  Wrong parameter constraint on columns
C!!!!!!!

                 ! Column of wavelengths
        do j=1,NROWS
           call CnvrtP(CPar(1,j),i,a,is)
           if (is .eq.1) then
              if (a.ne.'Z'.and.a.ne.'F') then
                 write(ErrMsg,103)CPar(1,j)
                 ist=1
                 return
              end if
           end if   
        end do

                 ! Column of Column densities
        do j=1,NROWS
           call CnvrtP(CPar(2,j),i,a,is)
           if (is .eq.1) then
              if (a.ne.'F') then
                 write(ErrMsg,103)CPar(2,j)
                 ist=1
                 return
              end if
           end if   
        end do

                 ! Column of b-values
        do j=1,NROWS
           call CnvrtP(CPar(3,j),i,a,is)
           if (is .eq.1) then
              if (a.ne.'T'.and.a.ne.'F') then
                 write(ErrMsg,103)CPar(3,j)
                 ist=1
                 return
              end if
           end if   
        end do

                 ! Column of b-turbolence values
        do j=1,NROWS
           call CnvrtP(CPar(4,j),i,a,is)
           if (is .eq.1) then
              if (a.ne.'F') then
                 write(ErrMsg,103)CPar(4,j)
                 ist=1
                 return
              end if
           end if   
        end do


 103  format('SEVERE ERROR: WRONG CONSTRAINT ON PARAMETER ',A4)
   

C!!!!!!!
C       ** 4 SEVERE ERROR:  parameter number < 1
C!!!!!!!

        do i=1,4    
           do j=1,NROWS
              if (IPar(i,j).lt. 1) then
                 write(ErrMsg,104)CPar(i,j)
                 ist=1
                 return
              end if
           end do
        end do

   
 104    format('SEVERE ERROR: PARAMETER NUMBER: ',A4,' IS LESS THAN 0')


C!!!!!!!
C       ** 5 SEVERE ERROR:  parameter numbers not contiguous
C       (BYPRODUCT: total parameter number nmx, vector of
C       parameter numbers np() and parameter links cp())
C!!!!!!!

 
        do i=1,NMXFRE
           np(i)=0
        end do
   
        nmx=0

        do i=1,4
           do j=1,NROWS
              call CnvrtP(CPar(i,j),ni,a,is)
              np(ni)=ni
              if (ni.gt.nmx) nmx=ni
           end do
        end do

        do i=1,nmx
           if (np(i).eq.0) then
                 write(ErrMsg,105)i
                 ist=1
                 return
           end if
        end do
   
 105    format('SEVERE ERROR:  PARAMETER',I3,' MISSING')


C!!!!!!!
C       ** 1 RECOVERABLE ERROR:  parameter fixed only sometimes
C!!!!!!!

        do i=1,NMXFRE
           fp(i)=0
        end do
   
        do i=1,4                ! Looks for fixed param
           do j=1,NROWS
              call CnvrtP(CPar(i,j),ni,a,is)
              if (is .eq.1 .and. a.eq.'F') fp(ni)=1
           end do
        end do
       
        do i=1,4                ! writes .F on the fixed param 
           do j=1,NROWS
              call CnvrtP(CPar(i,j),ni,a,is)
              if (fp(ni).eq.1 .and. is.eq.0) then
                 write(ErrMsg,201)ni,i,j
                 call sttdis(ErrMsg,0,is)
                 write(CPar(i,j),202)ni
              end if   
           end do
        end do

 201    format('WARNING: PARAMETER ',I3,' FIXED AT POSITION ',I3,I3)
 202    format(I2,'.F')


        NTOTPA=nmx

C!!!!!!!
C       ** 1 FURTHER ACTIONS: WRITES the correct CPar(4,j) if TURBLN=0
C!!!!!!!

        if (TURBLN.eq.0) then
           do j=1,NROWS
              if(IPar(4,j).eq.0) write(CPar(4,j),'(i2,a2)')nmx+1,'.F'
           end do
        end if

 
        return
        end



C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
        SUBROUTINE AddAtP(ist)
C
C       Uses the element name of the table to fill
C       the columns of the atomic parameters.
C       Atompar must have already been read!!
C
C       Ist (OUT) =1 if error (wrong paramname), otherwise 0
C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&

        implicit none

        include 'MID_REL_INCL:fit_var.inc'

        integer ist,i,j,iflag
        
C        include 'MID_REL_INCL:fit_mid.inc'
        INTEGER MADRID(1)
        INCLUDE 'MID_INCLUDE:ST_DEF.INC'

        COMMON/VMR/MADRID

        INCLUDE 'MID_INCLUDE:ST_DAT.INC'


        ist=0

        do i=1,NROWS
           iflag=0
           do j=1,AT_N
                if (ElmtNm(i).eq.AT_NAM(j)) then
                  iflag=1
                  AtmLam(i)=AT_LAM(j)
                  AtmFos(i)=AT_FOS(j)
                  AtmGam(i)=AT_GAM(j)
                  AtmMas(i)=AT_MAS(j)
                end if
            end do  
            if (iflag.eq.0) then
               ist=1
               return
            end if   
        end do
           
        return
        end

C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
        SUBROUTINE AtmRD(Iflag)
C
C       Legge il file atompar.tbl
C
C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&

        implicit none
        integer iflag,i,TABID,icol(5),i1,i2,i3,i4,nj,njj,ist
        logical la,isel
        character  natom*14              !must have same length as AT_NAM(i)
         
        INCLUDE 'MID_REL_INCL:fit_var.inc'

        INTEGER MADRID(1)
        INCLUDE 'MID_INCLUDE:ST_DEF.INC'

        COMMON/VMR/MADRID

        INCLUDE 'MID_INCLUDE:ST_DAT.INC'

C&&&&&&&
C&        Legge il file atompar.tbl con i parametri atomici
C&&&&&&&
        call seterr('OFF')
        call TBTOPN('atompar',F_IO_MODE,TABID,i)
        if (i.ne.0) then
           iflag=1
           call ERRMSG('FATAL: atompar.tbl not found')
           return
        end if
        
        call TBLSER(TABID,'transition',icol(1),i)
        if (i.ne.0) then
           iflag=1
           call ERRMSG('FATAL: :TRANSITION not found in atompar.tbl')
           return
        end if
        call TBLSER(TABID,'lambda',icol(2),i)
        if (i.ne.0) then
           iflag=1
           call ERRMSG('FATAL: column LAMBDA not found in atompar.tbl')
           return
        end if
        call TBLSER(TABID,'gamma',icol(3),i)
        if (i.ne.0) then
           iflag=1
           call ERRMSG('FATAL: column GAMMA not found in atompar.tbl')
           return
        end if
        call TBLSER(TABID,'fosc',icol(4),i)
        if (i.ne.0) then
           iflag=1
           call ERRMSG('FATAL: column FOSC not found in atompar.tbl')
           return
        end if
        call TBLSER(TABID,'mass',icol(5),i)
        if (i.ne.0) then
           iflag=1
           call ERRMSG('FATAL: column MASS not found in atompar.tbl')
           return
        end if

C        call TBIGET(TABID,i1,i2,i3,i4,nj,ist) !n. of rows
        call TBIGET(TABID,i1,nj,i2,i4,i3,ist) !n. of rows

        call seterr('ON')

        njj = 0
        isel = .FALSE.

        do 1000,i=1,nj
           call TBSGET(TABID,i,isel,ist)     !check if row is selected
           if (.NOT. isel) goto 1000

           njj = njj + 1                !get true no. of atoms listed
           call TBERDC(TABID,i,icol(1),natom,la,ist)
           CALL FT_EOS(natom,14,AT_NAM(i),ist)
           if (ist .ne. 0) then
              CALL STTPUT('bad atom label in table atompar!',ist)
              iflag = 99
              return
           endif

CC        write(*,12345) i,AT_NAM(i)
CC12345   format('AT_NAM(',i3,') = ',A14,']')

           call TBERDD(TABID,i,icol(2),AT_LAM(i),la,ist)
           call TBERDD(TABID,i,icol(3),AT_GAM(i),la,ist)
           call TBERDD(TABID,i,icol(4),AT_FOS(i),la,ist)
           call TBERDD(TABID,i,icol(5),AT_MAS(i),la,ist)
1000    continue

        call TBTCLO(TABID,ist)
        AT_N=njj

        iflag=0
        return
        end
 
C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
        SUBROUTINE AtmRDold(Iflag)
C
C       Legge il file atompar.tbl
C
C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&

        implicit none

        INCLUDE 'MID_REL_INCL:fit_var.inc'

        character*14 intestazione,app
        integer iflag,i
        real a,b,c,d

C&&&&&&&
C&        Legge il file atompar.dat con i parametri atomici
C&&&&&&&
        open(12,file='atompar.dat',status='old',iostat=iflag)
                
        if (iflag.ne.0) then
                iflag=1
c                call ERRORMSG('FATAL: atompar.dat not found')
                call sttdis('FATAL: atompar.dat not found',0,i)
                return
        end if

        i=1
        read(12,'(a14)')Intestazione
99      read(12,'(1x,a14,5x,f9.4,3x,f7.5,4x,e7.3)',end=100)App,a,b,c,d
        AT_LAM(i)= a
        AT_FOS(i)=b
        AT_GAM(i)=c
        AT_NAM(i)=App
        AT_MAS(I)=d
        i=i+1
        goto 99
100     continue

        close(12)
        AT_N=i-1
        iflag=0


        return

        end
C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
        SUBROUTINE AdPLim
C
C       Adds the internal limits on the parameters.
C
C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&

        implicit none

        include 'MID_REL_INCL:fit_var.inc'

        integer i
        
C        include 'MID_REL_INCL:fit_mid.inc'
        INTEGER MADRID(1)
        INCLUDE 'MID_INCLUDE:ST_DEF.INC'

        COMMON/VMR/MADRID

        INCLUDE 'MID_INCLUDE:ST_DAT.INC'


        do i=1,NROWS
           if (LAMLIM(1).eq.0) then
              LamMin(i)=0.0
           else
              LamMin(i)=LamIni(i) - LAMLIM(1)
           end if
           if (LAMLIM(2).eq.0) then
              LamMax(i)=0.0
           else
              LamMax(i)=LamIni(i) + LAMLIM(2)
           end if
           BMin(i)=BLIM(1)
           BMax(i)=BLIM(2)
           BtuMin(i)=BTULIM(1)
           BtuMax(i)=BTULIM(2)
           NMin(i)=NLIM(1)
           NMax(i)=NLIM(2)
           LamSte(i)=LAMLIM(3)
           BSte(i)=BLIM(3)
           BtuSte(i)=BTULIM(3)
           NSte(i)=NLIM(3)
        end do
           
        return
        end

C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
        SUBROUTINE MinuHd
C
C       Writes an ascii file with the header instruction
C       for minuit (i.e. parameter definition and fix)
C       using lypar values as stored in memory
C       and lymin values as stored in memory
C
C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&

        implicit none

        include 'MID_REL_INCL:fit_var.inc'

        integer ifound(NMXLIN),ifix(NMXLIN),ix(NMXLIN),jx(NMXLIN)
        integer i,j,ni,is,nmx,ista
        character a
        character*5 suffix(4)
        character*20 name 
        real valmin,valmax,valini,valste

C        include 'MID_REL_INCL:fit_mid.inc'
        INTEGER MADRID(1)
        INCLUDE 'MID_INCLUDE:ST_DEF.INC'

        COMMON/VMR/MADRID

        INCLUDE 'MID_INCLUDE:ST_DAT.INC'


        suffix(1)='''lam['
        suffix(3)='''  b['
        suffix(2)='''  N['
        suffix(4)='''btu['

        do i=1,NMXLIN
           ifound(i)=0
           ifix(i)=0
           ix(i)=0
           jx(i)=0
        end do
   
        nmx=0
        do i=1,4
           do j=1,NROWS
              call CnvrtP(CPar(i,j),ni,a,is)
              if (ifound(ni).eq.0.and.a.ne.'Z'.and.a.ne.'T') then 
                                     !never found yet nor constrained
                 ifound(ni) =1
                 ix(ni)=i
                 jx(ni)=j
              end if   
              if(a.eq.'F') ifix(ni)=1      ! in any case if fixed..
              if (ni.gt.nmx) nmx=ni
           end do
        end do

 
C!!!!!!!
C        Apre il file fdummy.MIN cancellando il vecchio
C!!!!!!!
40        continue
        open(20,file='fdummy.min',status='old',iostat=ista)
        close(20,status='delete')
        open(20,file='fdummy.min',status='new',iostat=ista)


C!!!!!!!
C        Comincia a scrivere
C!!!!!!!
        write(20,'(A34)')'FITLYMAN Minimization  - ESO Midas'
        
        do i=1,nmx
           
           write(name,'(A5,i2,A2)')suffix(ix(i)),jx(i),']'' '          
           if (ix(i).eq.1) valini = LamIni(jx(i))
           if (ix(i).eq.3) valini = BIni(jx(i))
           if (ix(i).eq.2) valini = NIni(jx(i))
           if (ix(i).eq.4) valini = BtuIni(jx(i))

           if (ix(i).eq.1) valste = LamSte(jx(i))
           if (ix(i).eq.3) valste = BSte(jx(i))
           if (ix(i).eq.2) valste = NSte(jx(i))
           if (ix(i).eq.4) valste = BtuSte(jx(i))

           if (ix(i).eq.1) valmin = LamMin(jx(i))
           if (ix(i).eq.3) valmin = BMin(jx(i))
           if (ix(i).eq.2) valmin = NMin(jx(i))
           if (ix(i).eq.4) valmin = BtuMin(jx(i))

           if (ix(i).eq.1) valmax = LamMax(jx(i))
           if (ix(i).eq.3) valmax = BMax(jx(i))
           if (ix(i).eq.2) valmax = NMax(jx(i))
           if (ix(i).eq.4) valmax = BtuMax(jx(i))

           if (ifix(i).eq.1) then
              write(20,101)i,name,valini ! parameter fixed
           else
              if (valmin.lt.1e-5.or.valmax.lt.1e-5) then
                 write(20,102)i,name,valini,valste ! parameter free
              else
                 write(20,103)i,name,valini,valste,valmin,valmax
              end if
           end if
        end do
 101    format(I3,3x,A10,G14.7)
 102    format(I3,3x,A10,2G14.7)
 103    format(I3,3x,A10,4G14.7)

        write(20,*)     !!  IMPORTANT: END OF HEADER

        IMINOS=0
        do i=1,NMINCM
           write(20,*)MINCOM(i)
           if (MINCOM(i).eq.'MINOS') IMINOS=1
        end do

        close(20)
        return
        end



C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
        SUBROUTINE AdCoef
C
C       Using the values of lypar.tbl loaded in memory,
C       computes the coefficients of proportionality for
C       constrained parameters. Now working only
C       on lambda and b parameters. (N not constrained!!
C
C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&

        implicit none

        include 'MID_REL_INCL:fit_var.inc'

        integer ifound(NMXLIN),ix(NMXLIN),jx(NMXLIN)
        integer i,j,ni,is
        character a

C        include 'MID_REL_INCL:fit_mid.inc'
        INTEGER MADRID(1)
        INCLUDE 'MID_INCLUDE:ST_DEF.INC'

        COMMON/VMR/MADRID

        INCLUDE 'MID_INCLUDE:ST_DAT.INC'


        do i=1,NMXLIN
           ifound(i)=0
           ix(i)=0
           jx(i)=0
           CoefL(i)=1.
           CoefN(i)=1.
           CoefB(i)=1.
           CoefBt(i)=1.
        end do
   

        i=1       ! Lambda
        do j=1,NROWS
           call CnvrtP(CPar(i,j),ni,a,is)
           if (ifound(ni).eq.0.and.a.ne.'Z'.and.a.ne.'T') then 
                                     !never found yet nor constrained
              ifound(ni) =1
              ix(ni)=i
              jx(ni)=j
           end if
        end do
        do j=1,NROWS
           call CnvrtP(CPar(i,j),ni,a,is)
           if (a.eq.'Z') CoefL(j)=AtmLam(j)/AtmLam(jx(ni))
        end do

   
        i=3       ! b-values
        do j=1,NROWS
           call CnvrtP(CPar(i,j),ni,a,is)
           if (ifound(ni).eq.0.and.a.ne.'Z'.and.a.ne.'T') then 
                                     !never found yet nor constrained
              ifound(ni) =1
              ix(ni)=i
              jx(ni)=j
           end if
        end do
        do j=1,NROWS
           call CnvrtP(CPar(i,j),ni,a,is)
           if (a.eq.'T') Coefb(j)=sqrt(AtmMas(jx(ni))/AtmMas(j))
        end do

   
        return
        end
   
      
C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
        SUBROUTINE AddInP
C
C       Computes the values of the initial constrained parameters
C       using the values of lypar.tbl loaded in memory,
C       and the coefficients of proportionality 
C       
C
C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&

       implicit none

        include 'MID_REL_INCL:fit_var.inc'

        integer ifound(NMXLIN),ix(NMXLIN),jx(NMXLIN)
        integer IPar(4,NMXLIN)
        integer i,j,ni,is
        character a

C        include 'MID_REL_INCL:fit_mid.inc'
        INTEGER MADRID(1)
        INCLUDE 'MID_INCLUDE:ST_DEF.INC'

        COMMON/VMR/MADRID

        INCLUDE 'MID_INCLUDE:ST_DAT.INC'


        do i=1,NMXLIN
           ifound(i)=0
           ix(i)=0
           jx(i)=0
           do j=1,4
              IPar(j,i)=0
           end do
        end do
   

        do i=1,4
           do j=1,NROWS
              call CnvrtP(CPar(i,j),IPar(i,j),a,is)
              ni=IPar(i,j)
              if (ifound(ni).eq.0.and.a.ne.'Z'.and.a.ne.'T') then 
                                     !never found yet nor constrained
                 ifound(ni) =1
                 jx(ni)=j
              end if   
           end do
        end do   

        do j=1,NROWS
           LamIni(j)=LamIni(jx(IPar(1,j)))*CoefL(j) 
           NIni(j)=NIni(jx(IPar(2,j)))*CoefN(j) 
           BIni(j)=BIni(jx(IPar(3,j)))*CoefB(j) 
           BtuIni(j)=BtuIni(jx(IPar(4,j)))*CoefBt(j) 
        end do   

        return
        end
   
      

C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
        SUBROUTINE FCNHd
C
C       Writes an ascii file 'fdummy.fcn' 
C       with the information required
C       by FCN to convert MINUIT parameters into line
C       parameters. 
C
C
C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&


        implicit none

        include 'MID_REL_INCL:fit_var.inc'

        integer i,j,Ipar(4,NMXLIN),ista
        character a

C        include 'MID_REL_INCL:fit_mid.inc'
        INTEGER MADRID(1)
        INCLUDE 'MID_INCLUDE:ST_DEF.INC'

        COMMON/VMR/MADRID

        INCLUDE 'MID_INCLUDE:ST_DAT.INC'


C!!!!!!!
C       gets parameter numbers
C!!!!!!!
        do i=1,4
           do j=1,NROWS
              call CnvrtP(CPar(i,j),IPar(i,j),a,ista)
           end do
        end do


C!!!!!!!
C        Apre il file fdummy.fcn cancellando il vecchio
C!!!!!!!
40        continue
        open(20,file='fdummy.fcn',status='old',iostat=ista)
        close(20,status='delete')
        open(20,file='fdummy.fcn',status='new',iostat=ista)

        write(20,*)NROWS
        do j=1,NROWS
           write(20,101)(IPar(i,j),i=1,4),CoefL(j),CoefN(j),CoefB(j),
     1          CoefBt(j),AtmLam(j),AtmFos(j),AtmGam(j)
        end do

        write(20,*)NINTFT
        do j=1,NINTFT
           write(20,*)FITMIN(j),FITMAX(j)
        end do


        close(20)
c 101    format(4I3,x2,G16.8,x2,F4.1,x2,G16.8E2,x2,F4.1,x2,F11.4,x2,
c     1       F9.5,x2,G13.5)
 101    format(4I3,7G16.8)

        return
        end


C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
        SUBROUTINE SETERR(choice)
c
c       sets error behaviour
c
c     choice:  ON
C              OFF
C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&

        character*(*) choice
        integer i1,i2,i3

        if (choice.eq.'OFF') then

           i1=1                 !doesn't stop on errors
           i2=0
           i3=0
           call STECNT('PUT',i1,i2,i3)

        endif


        if (choice.eq.'ON') then
           i1=0                 !stop on errors
           i2=2
           i3=1
           call STECNT('PUT',i1,i2,i3)
        endif

        return
        end




S

