module gauss_1d_data
  use gildas_def
  ! Former 'rdata.inc'
  integer(kind=4) :: nxy
  real, pointer :: my_x(:), my_y(:)
  real, allocatable :: my_w(:)
  real(kind=4) :: cbad
end module gauss_1d_data
!
program gaussfit
  use gildas_def
  use image_def
  use gbl_format
  use fit_minuit
  use gkernel_interfaces
  use gauss_1d_data
  !---------------------------------------------------------------------
  ! Make a gaussfit to two columns of a Table
  !---------------------------------------------------------------------
  ! Global
  include 'gauss.inc'
  ! Local
  logical :: error
  type(fit_minuit_t) :: fit
  integer :: lt(mxline),lv(mxline),ld(mxline)
  integer :: ifatal,nout(mxline),jcol,i
  equivalence  (kt1,lt(1)), (kv1,lv(1)), (kd1,ld(1))
  real :: intens(mxline),pos(mxline),width(mxline),array(6)
  external :: mingauss
  real(kind=4), external :: progauss
  character(len=7) :: prompt
  character(len=filename_length) :: name,file
  type(gildas) :: x
  integer :: cols(2),ier
  !
  ! Open file
  call gildas_open
  call gildas_char('IN$',name)
  call gildas_char('LIST$',name)
  call sic_parsef(name,file,' ','.dat')
  call gildas_inte('COLUMN_IN$',cols,2)
  call gildas_inte('NLINE$',nline,1)
  nline = min(nline,mxline)
  call gildas_inte('COLUMN_OUT$',nout,max(nline,1))
  do i=1,nline
    write(prompt,1000) i
    call gildas_real(prompt,array,6)
    intens(i) = array(2)
    lt(i) = nint(array(1))
    pos(i) = array(4)
    lv(i) = nint(array(3))
    width(i) = array(6)
    ld(i) = nint(array(5))
  enddo
  call gildas_close
  !
  call gildas_null (x, type = 'TABLE')
  call gdf_read_gildas (x, name, '.tab', error)
  if (error) then 
    write(6,*) 'E-GAUSS_1D,  Error reading table'
    goto 99
  endif
  !
  fit%isyswr=1
  ier = sic_open(1,file,'NEW',.false.)
  if (ier.ne.0) then
    write(6,*) 'E-GAUSS_1D,  Cannot create output file'
    call putios('E-GAUSS_1D,  ',ier)
    goto 99
  endif
  jcol = nout(1)
  do i=2,nline
    jcol = max(nout(i),jcol)
  enddo
  !
  if (nline.lt.1) goto 100
  spar(1) = intens(1)
  spar(2) = pos(1)
  spar(3) = width(1)
  if (nline.lt.2) goto 100
  spar(4) = intens(2)
  spar(5) = pos(2)
  spar(6) = width(2)
  if (nline.lt.3) goto 100
  spar(7) = intens(3)
  spar(8) = pos(3)
  spar(9) = width(3)
  if (nline.lt.4) goto 100
  spar(10) = intens(4)
  spar(11) = pos(4)
  spar(12) = width(4)
  if (nline.lt.5) goto 100
  spar(13) = intens(5)
  spar(14) = pos(5)
  spar(15) = width(5)
  !
100 continue
  call check(lt,nline,kt0,1,ifatal)
  call check(lv,nline,kv0,2,ier)
  ifatal=ifatal+ier
  call check(ld,nline,kd0,3,ier)
  ifatal=ifatal+ier
  if (kt0.ne.0 .and. kd0.ne.0 .and. kt0.ne.kd0) ifatal=ifatal+1
  if (ifatal.ne.0) then
    write(6,'(1X,I3,A)') ifatal,'Fatal errors on parameters'
    call sysexi (fatale)
  endif
  !
  ! Compute Data Address
  if (cols(1).gt.x%gil%dim(2) .or. cols(2).gt.x%gil%dim(2)) then
    write(6,*) 'E-GAUSS_1D,  Columns out of range'
    call sysexi (fatale)
  endif
  nxy = x%gil%dim(1)
  my_x => x%r2d(:,cols(1))
  my_y => x%r2d(:,cols(2))
  ! Get some work space
  allocate (my_w(nxy),stat=ier)
  if (ier.ne.0) goto 99
  cbad = -1e28                 ! ....
  !
  call fitgauss(fit,mingauss,.false.,error)
  if (error) goto 99
  !
  ! Write the fits
  call extend_table(x,jcol,error)
  if (error) goto 99
  !
  my_x => x%r2d(:,cols(1))
  do i=1,max(nline,1)
    if (nout(i).gt.0) then
      my_y => x%r2d(:,nout(i)) 
      call fill_fit(my_x,my_y,x%gil%dim(1),progauss,i)
    endif
  enddo
  call gdf_write_data (x, x%r2d, error)
  stop 'S-FITGAUSS,  Successful completion'
  !
99 call sysexi (fatale)
1000 format('LINE_',i1,'$')
end program gaussfit
!
subroutine extend_table(x,ncol,error)
  use gildas_def
  use image_def
  use gkernel_interfaces
  type(gildas) :: x                 !
  integer :: ncol                   !
  logical :: error                  !
  ! Local
  integer(kind=index_length) :: mcol
  !
  error = .false.
  if (ncol.le.x%gil%dim(2)) return
  !
  mcol = ncol
  call gdf_extend_image (x,mcol, error)
  if (error) then
    write(6,*) 'E-GAUSS_1D,  Table extension failed'
    return
  endif
  !
  ! The whole thing must be mapped
  x%blc = 0
  x%trc = 0
  call gdf_allocate (x,error)
end subroutine extend_table
!
subroutine fill_fit(x,y,n,fcn,il)
  use gildas_def
  integer(kind=index_length) :: n
  real(kind=4)               :: x(n)
  real(kind=4)               :: y(n)
  real(kind=4), external     :: fcn
  integer(kind=4)            :: il
  ! Local
  integer(kind=index_length) :: i
  !
  do i=1,n
    y(i) = fcn(x(i),il)
  enddo
end subroutine fill_fit
!
subroutine check(kflag,nline,kt,ivar,ierr)
  use gkernel_interfaces
  !---------------------------------------------------------------------
  ! SAS	Internal routine (GAUSS)
  !	Control the gauss fit parameter flags
  ! Arguments :
  !	KFLAG 	I(5)	Flags to be checked		Input
  !	NLINE 	I*2	Number of lines			Input
  !	KT    	I	Independante line		Output
  !	IVAR  	I	Variable code			Input
  !	IERR  	I	Error code			Output
  ! (5-mar-1985)
  !---------------------------------------------------------------------
  integer :: kflag(5)               !
  integer :: nline                  !
  integer :: kt                     !
  integer :: ivar                   !
  integer :: ierr                   !
  ! Local
  integer :: ktdep,i
  character(len=9) :: chain(3)
  character(len=1) :: ch
  ! Data
  data chain /'Intensity',' Position','   Width '/
  !
  ierr=0
  if (nline.eq.0) then
    kflag(1)=mod(kflag(1),2)
    kt=0
    return
  endif
  ! Find dependent
  if (kflag(1).gt.4) then
    call gagout('E-CHECK,  Flag greater than 4')
    ierr=1
    return
  endif
  kt=0
  ktdep=0
  if (kflag(1).eq.2.or.kflag(1).eq.4) kt=1
  if (kflag(1).eq.3) ktdep=1
  !
  do i=2,nline
    if (kflag(i).gt.4) then
      call gagout('E-CHECK,  Flag greater than 4')
      ierr=1
      return
    endif
    if (kflag(i).eq.2.or.kflag(i).eq.4) then
      if (kt.eq.0) then
        kt=i
      else
        ierr=ierr+1
      endif
    endif
    if (kflag(i).eq.3) ktdep=ktdep+1
  enddo
  !
  if (ierr.ne.0) then
    call gagout('E-CHECK,  Several groups in '//chain(ivar))
    ierr=1
  endif
  if (ktdep.eq.0 .and. kt.ne.0) then
    write(ch,'(I1)') kt
    call gagout('E-CHECK,  Line '//ch//' alone in a '//  &
    chain(ivar)//' Group')
  endif
  if (ktdep.ne.0 .and. kt.eq.0) then
    call gagout('E-CHECK,  No independent '//chain(ivar))
    ierr=1
  endif
  return
end subroutine check
!
subroutine fitgauss(fit,fcn,liter,error)
  use gildas_def
  use gbl_message
  use gkernel_interfaces
  use fit_minuit
  use gauss_1d_data
  !---------------------------------------------------------------------
  ! SAS	Internal routine
  !	Setup and starts a GAUSS fit minimisation using MINUIT
  !---------------------------------------------------------------------
  type(fit_minuit_t), intent(inout) :: fit    !
  external                          :: fcn    ! Function to be mininized
  logical, intent(in)               :: liter  ! Logical of iterate fit
  logical                           :: error  ! Logical error flag (output)
  ! Global
  include 'gauss.inc'
  ! Local
  integer :: i,k,l,k1,k2, ifatal,ier
  real*8 :: dx, al, ba, du1, du2
  character(len=message_length) :: mess
  !
  ! Added error Patch for Initialisation
  ngline = nline
  error = .false.
  fit%maxext=ntot
  fit%maxint=nvar
  !
  ! Initialise values
  call initva(sigbas,sigrai,cbad,deltav,my_x,my_y,my_w,nxy)
  call midgauss(fit,ifatal,liter)
  if (ifatal.ne.0) then
    write(mess,*) 'Fatal ',ifatal
    call gagout('E-FITGAUSS,  '//mess)
    error = .true.
    return
  endif
  call intoex(fit,fit%x)
  fit%up = max(sigbas**2,sigrai**2)
  fit%nfcnmx = 1000
  fit%epsi   = 0.1d0 * fit%up
  fit%newmin = 0
  fit%itaur  = 0
  fit%isw(1) = 0
  fit%isw(3) = 1
  fit%nfcn   = 1
  fit%vtest  = 0.04
  call fcn(fit%npar,fit%g,fit%amin,fit%u,1)
  !
  ! Simplex Minimization
  if (.not.liter) then
    call simplx(fit,fcn,ier)
    write(mess,*) 'Simplex returned status: ',ier
    call gagout('I-FITGAUSS,  '//mess)
    if (ier.ne.0) then
      error=.true.
      return
    endif
    k=1
    do i=1,max(nline,1)
      par(k)  =fit%u(k+3)*fit%u(1)*1.7724538
      par(k+1)=fit%u(k+4)+fit%u(2)
      par(k+2)=fit%u(k+5)*1.665109*fit%u(3)
      k=k+3
    enddo
  endif
  !
  ! Gradient Minimization
  call intoex(fit,fit%x)
  call fcn(fit%npar,fit%g,fit%amin,fit%u,3)
  write(fit%isyswr,1002) sigbas,sigrai
  fit%up = max(sigbas**2,sigrai**2)
  fit%epsi = 0.1d0 * fit%up
  fit%apsi = fit%epsi
  call hesse(fit,fcn)
  call migrad(fit,fcn,ier)
  if (ier.eq.1) then
    ier=0
    call hesse(fit,fcn)
    error=.false.
  endif
  !
  ! Print Results
  k=1
  do i=1,max(nline,1)
    par(k)  =fit%u(k+3)*fit%u(1)*1.7724538
    par(k+1)=fit%u(k+4)+fit%u(2)
    par(k+2)=fit%u(k+5)*fit%u(3)*1.665109
    k=k+3
  enddo
  call intoex(fit,fit%x)
  call fcn(fit%npar,fit%g,fit%amin,fit%u,3)
  write(fit%isyswr,1002) sigbas,sigrai
  fit%up  = max(sigbas**2,sigrai**2)
  !
  ! Calculate External Errors
  do i=1,fit%nu
    l  = fit%lcorsp(i)
    if (l .eq. 0)  then
      fit%werr(i)=0.
      write(mess,*) 'Error ',i,fit%werr(i)
      call gagout('E-FITGAUSS,  '//mess)
    else
      if (fit%isw(2) .ge. 1)  then
        dx = dsqrt(dabs(fit%v(l,l)*fit%up))
        if (fit%lcode(i) .gt. 1) then
          al = fit%alim(i)
          ba = fit%blim(i) - al
          du1 = al + 0.5d0 *(dsin(fit%x(l)+dx) +1.0d0) * ba - fit%u(i)
          du2 = al + 0.5d0 *(dsin(fit%x(l)-dx) +1.0d0) * ba - fit%u(i)
          if (dx .gt. 1.0d0)  du1 = ba
          dx = 0.5d0 * (dabs(du1) + dabs(du2))
        endif
        fit%werr(i) = dx
        write(mess,*) 'Error ',i,fit%werr(i)
        call gagout('E-FITGAUSS,  '//mess)
      endif
    endif
  enddo
  !
  k=1
  if (sigbas.lt.sigrai/1.5 .or. sigbas.gt.1.5*sigrai) then
    write(fit%isyswr,1003)
  else
    write(fit%isyswr,1001)
  endif
  do i=1,max(nline,1)
    k1=k+1
    k2=k+2
    err(k)=fit%werr(k+3)
    if (i.eq.kt0) err(k)=fit%werr(1)
    err(k1)=fit%werr(k1+3)
    if (i.eq.kv0) err(k1)=fit%werr(2)
    err(k2)=fit%werr(k2+3)
    if (i.eq.kd0) err(k2)=fit%werr(3)
    write(fit%isyswr,1000) i,par(k),par(k1),par(k2),par(k)/par(k2)/1.064467,  &
                           err(k),err(k1),err(k2)
    k=k+3
  enddo
  return
  !
1000 format (1x,i1,2x,4(4x,1pg11.4),/,4x,3(4x,1pg11.4))
1001 format (/,'		FIT Results   ',//,  &
       ' Line      Area           Position      Width       Intensity')
1002 format (' RMS of Residuals :  Base = ',1pg11.3,'  Line = ',1pg11.3)
1003 format (/,'         Bad or Doubtful FIT',//,  &
       ' Line      Area               Position  Width       Intensity')
end subroutine fitgauss
!
subroutine initva (sigbas,sigrai,cbad,deltav,rdatax,rdatay,wfit,n)
  !---------------------------------------------------------------------
  ! ANALYSE	Internal routine
  !	Initialise the parameters for a gaussian fit using Minuit
  ! (10-Oct-1986)
  !---------------------------------------------------------------------
  real*4 :: sigbas                  !
  real*4 :: sigrai                  !
  real :: cbad                      !
  real :: deltav                    !
  integer :: n                      !
  real :: rdatax(n)                 !
  real :: rdatay(n)                 !
  real :: wfit(n)                   !
  ! Local
  real*4 :: aega,asup,ainf
  integer :: i,kbas,krai
  !
  ! Avoid bad channels
  do i=1, n
    if (rdatay(i).eq.cbad) then
      wfit(i)=0
    else
      wfit(i)=1
    endif
  enddo
  !
  ! Compute the Sigma
  kbas=0
  krai=0
  sigbas=0.
  sigrai=0.
  aega = rdatay(1)*wfit(1)
  asup = aega
  do i=1,n
    ainf=aega
    aega=asup
    asup=rdatay(i)*wfit(i)
    if ( ainf*aega.lt.0. .and. aega*asup.lt.0. ) then
      sigbas=sigbas+aega**2
      kbas=kbas+1
    else
      sigrai=sigrai+aega**2
      krai=krai+wfit(i-1)
    endif
  enddo
  !
  ! Try to avoid zero sigmas
  if (kbas.ne.0) sigbas=sqrt(sigbas/kbas)
  if (krai.ne.0) then
    sigrai=sqrt(sigrai/krai)
    if (sigbas.eq.0.) sigbas=sigrai
  else
    sigrai=sigbas
  endif
  deltav = abs(rdatax(2)-rdatax(1))
end subroutine initva
!
subroutine midgauss(fit,ifatal,liter)
  use gkernel_interfaces
  use gildas_def
  use gbl_message
  use gkernel_interfaces
  use fit_minuit
  use gauss_1d_data
  !---------------------------------------------------------------------
  ! ANALYSE	Internal routine
  !	Start a gaussian fit by building the PAR array and internal
  !	variable used by Minuit
  !---------------------------------------------------------------------
  type(fit_minuit_t), intent(inout) :: fit     !
  integer                           :: ifatal  ! Number of fatal errors Output
  logical, intent(in)               :: liter   ! Iterate a fit
  ! Global
  include 'gauss.inc'
  ! Local
  integer :: kt(5),kv(5),kd(5),i, nint, j1, j2, k, j
  equivalence (kt(1),kt1), (kv(1),kv1), (kd(1),kd1)
  real*8 :: sav, sav2, vplu, vminu
  character(len=message_length) :: mess
  !
  do i= 1, 7
    fit%isw(i) = 0
  enddo
  fit%sigma = 0.d0
  fit%npfix = 0
  nint = 0
  fit%nu = 0
  fit%npar = 0
  ifatal = 0
  do i= 1, fit%maxext
    fit%u(i) = 0.0d0
    fit%lcode(i) = 0
    fit%lcorsp (i) = 0
  enddo
  fit%isw(5) = 1
  !
  ! Starting values
  if (nline.eq.0) then
    call auto_guess(my_x,my_y,my_w,nxy,par)
    fit%nu=3
  else
    !
    ! Take initial guesses in SPAR
    fit%nu=3*nline
    j=1
    do i=1,nline
      j2=j+2
      !
      ! That is quite tricky, since the area is the product of the original
      !	intensity by the width. But for dependant gaussian, it is
      !	much more subtle
      if (kd(i).ne.3) then
        par(j)=spar(j)*spar(j2)*1.064467
      else
        par(j)=spar(j)
      endif
      j1=j+1
      par(j1)=spar(j1)
      par(j2)=spar(j2)
      j=j+3
    enddo
  endif
  !
  ! Type initial guesses
  fit%nu=fit%nu+3
  write(mess,597) par(1),par(2),par(3)
  call gagout('I-MIDGAUSS,  '//mess)
  k = 4
  do i=2,max(nline,1)
    write(mess,598) par(k),par(k+1),par(k+2)
    call gagout('I-MIDGAUSS,  '//mess)
    k=k+3
  enddo
598 format('                    ',1pg10.3,2x,1pg10.3,2x,1pg10.3)
597 format('Input Parameters :  ',1pg10.3,2x,1pg10.3,2x,1pg10.3)
  !
  ! Set up Parameters for Major Variables
  !
  ! Velocities
  if (kv0.eq.0) then
    fit%u(2)=0.
    fit%werr(2)=0.
  else
    fit%u(2)=par(3*kv0-1)
    if (kv(kv0).eq.4) then
      fit%werr(2)=0.
    else
      fit%werr(2)=deltav
      ! if (liter) fit%werr(2)=err(3*kv0-1)
      fit%alim(2)=fit%u(2)-40*deltav
      fit%blim(2)=fit%u(2)+40*deltav
    endif
  endif
  !
  ! Line Widths
  if (kd0.eq.0) then
    fit%u(3)=1./1.665109           ! 1 / (2*SQRT(LN(2)))
    fit%werr(3)=0.
  else
    fit%u(3)=abs(par(3*kd0))/1.665109
    if (kd(kd0).eq.4) then
      fit%werr(3)=0.
    else
      fit%werr(3)=deltav
      ! if (liter) fit%werr(3)=err(3*kd0)
      fit%alim(3)=deltav/4.
      fit%blim(3)=100.*deltav
    endif
  endif
  !
  ! Areas
  if (kt0.eq.0) then
    fit%u(1)=0.564189584           ! 1 / SQRT(PI)
    fit%werr(1)=0.
  else
    fit%u(1)=par(3*kt0-2)
    if (kt(kt0).eq.4) then
      fit%werr(1)=0.
    else
      fit%werr(1)=sigbas*deltav
      ! if (liter) fit%werr(1)=err(3*kt0-2)
      if (fit%u(1).ne.0.) then
        fit%alim(1)=dmin1(0.d0,4*fit%u(1))
        fit%blim(1)=dmax1(0.d0,4*fit%u(1))
      else
        fit%lcode(1)=1
      endif
    endif
  endif
  !
  ! Set up parameters for Secondary Variables
  !
  k=4
  do i=1,max(nline,1)
    ! Area
    fit%u(k)=par(k-3)
    if (kt(i).eq.0 .or. nline.eq.0) then
      fit%werr(k)=sigbas*deltav
      ! if (liter) fit%werr(k)=err(k-3)
      if (fit%u(k).ne.0.) then
        fit%alim(k)=dmin1(0.d0,4*fit%u(k))
        fit%blim(k)=dmax1(0.d0,4*fit%u(k))
      else
        fit%lcode(k)=1             ! No Boundaries if fit%u(k)=0.
      endif
    else
      fit%werr(k)=0.
      if (i.eq.kt0) then
        fit%u(k)=0.564189584
      else
        fit%u(k)=fit%u(k)*0.564189584
      endif
    endif
    k=k+1
    !
    ! Velocity
    fit%u(k)=par(k-3)
    if (kv(i).eq.0 .or. nline.eq.0) then
      fit%werr(k)=deltav
      ! if (liter) fit%werr(k)=err(k-3)
      fit%alim(k)=fit%u(k)-40*deltav
      fit%blim(k)=fit%u(k)+40*deltav
    else
      fit%werr(k)=0.
      if (i.eq.kv0) fit%u(k)=0.
    endif
    k=k+1
    !
    ! Line Width
    fit%u(k)=abs(par(k-3))
    if (kd(i).eq.0 .or. nline.eq.0) then
      fit%werr(k)=deltav
      ! if (liter) fit%werr(k)=err(k-3)
      fit%alim(k)=deltav
      fit%blim(k)=100.*deltav
    else
      fit%werr(k)=0.
      if (i.eq.kd0) fit%u(k)=1.
    endif
    k=k+1
  enddo
  !
  ! Various checks
  do k=1,fit%nu
    if (k .le. fit%maxext)  go to 115
    ifatal = ifatal + 1
    go to 160
115 if (fit%werr(k) .gt. 0.0d0)  go to 122
    ! Fixed parameter
    fit%lcode(k) = 0
    if (k.gt.3) then
      write(mess,1010) k-3,' is fixed'
      call gagout('W-MIDGAUSS,  '//mess)
    endif
    go to 160
    ! Variable parameter
122 nint = nint + 1
    if (fit%lcode(k).eq.1) go to 160
    fit%lcode(k) = 4
    if ((fit%blim(k)-fit%u(k))*(fit%u(k)-fit%alim(k)))  153,155,160
153 ifatal = ifatal + 1
    write(fit%isyswr,1011) k-3
    go to 160
155 if (k.gt.3) then
      write(mess,1010) k-3,' is at limit'
      call gagout('W-MIDGAUSS,  '//mess)
    endif
160 continue
  enddo
  !
  ! End parameter cards
  ! Stop if fatal error
  if (nint .gt. fit%maxint)  then
    write(fit%isyswr,1008)  nint,fit%maxint
    ifatal = ifatal + 1
  endif
  if (nint .eq. 0) then
    write(fit%isyswr,1009)
    ifatal = ifatal + 1
  endif
  if (ifatal .gt. 0)  then
    write(fit%isyswr,1013)  ifatal
    return
  endif
  !
  ! O.K. Start
  ! Calculate step sizes DIRIN
  fit%npar = 0
  do k= 1, fit%nu
    if (fit%lcode(k) .gt. 0)  then
      fit%npar = fit%npar + 1
      fit%lcorsp(k) = fit%npar
      sav = fit%u(k)
      fit%x(fit%npar) = pintf(fit,sav,k)
      fit%xt(fit%npar) = fit%x(fit%npar)
      sav2 = sav + fit%werr(k)
      vplu = pintf(fit,sav2,k) - fit%x(fit%npar)
      sav2 = sav - fit%werr(k)
      vminu = pintf(fit,sav2,k) - fit%x(fit%npar)
      fit%dirin(fit%npar) = 0.5d0 * (dabs(vplu) +dabs(vminu))
    endif
  enddo
  return
  !
1008 format (' Too many variable parameters.  You request ',i5/,  &
                ' This version of MINUIT is only dimensioned for ',i4)
1009 format (' All input parameters are fixed')
1010 format (' Warning - Parameter ',i2,' ',a)
1011 format (' Error - Parameter ',i2,' outside limits')
1013 format (1x,i3,' Errors on input parameters. ABORT.')
end subroutine midgauss
!
subroutine auto_guess(rdatax,rdatay,wfit,nxy,par)
  integer :: nxy                    !
  real :: rdatax(nxy)               !
  real :: rdatay(nxy)               !
  real :: wfit(nxy)                 !
  real :: par(3)                    !
  ! Local
  real :: ymax,ymin,aire,yy,vinf,vsup
  integer :: i
  !
  ! Automatic guess if NLINE = 0
  ymax=0.
  ymin=0.
  aire=0.
  do i=2,nxy-1
    if (wfit(i).ne.0) then
      yy = ( rdatay(i) + wfit(i-1)*rdatay(i-1) + wfit(i+1)*rdatay(i+1) ) /  &
           (1+wfit(i-1)+wfit(i+1))
      if (yy.ge.ymax) then
        ymax = yy
        vsup = rdatax(i)
      endif
      if (yy.le.ymin) then
        ymin = yy
        vinf = rdatax(i)
      endif
    endif
    aire=aire+yy*abs((rdatax(i+1)-rdatax(i-1)))
  enddo
  aire = aire*0.5
  if (abs(ymin).lt.abs(ymax)) then
    par(2)=vsup
    par(1)=ymax
  else
    par(2)=vinf
    par(1)=ymin
  endif
  par(3)=abs(aire/par(1)/1.064467)
  par(1)=aire
end subroutine auto_guess
!
subroutine mingauss (npar,g,f,x,iflag)
  use gildas_def
  use gauss_1d_data
  !---------------------------------------------------------------------
  ! LAS	Internal routine
  !	Function to be minimized in the gaussian fit.
  !	By using 3 hidden parameters, the method allows dependent
  !	and independent gaussians to be fitted. The computation is
  !	highly optimised, but take care of R*4 and R*8 values !...
  !	Basic parameters are Area, Position and Width.
  ! Arguments :
  !	NPAR	I	Number of parameters		Input
  !	G	R*8(1)	Array of derivatives		Output
  !	F	R*8	Function value			Output
  !	X	R*8(1)	Parameter values		Input
  !	IFLAG	I	Code operation			Input
  ! (5-mar-1985)
  !---------------------------------------------------------------------
  integer :: npar                   !
  real*8 :: g(*)                    !
  real*8 :: f                       !
  real*8 :: x(*)                    !
  integer :: iflag                  !
  !
  call mingau(npar,g,f,x,iflag,my_x,my_y,my_w,nxy)
end subroutine mingauss
!
subroutine mingau (npar,g,f,x,iflag,rdatax,rdatay,weight,nxy)
  !---------------------------------------------------------------------
  ! LAS	Internal routine
  !	Function to be minimized in the gaussian fit.
  !	By using 3 hidden parameters, the method allows dependent
  !	and independent gaussians to be fitted. The computation is
  !	highly optimised, but take care of R*4 and R*8 values !...
  !	Basic parameters are Area, Position and Width.
  ! Arguments :
  !	NPAR	I	Number of parameters		Input
  !	G	R*8(1)	Array of derivatives		Output
  !	F	R*8	Function value			Output
  !	X	R*8(1)	Parameter values		Input
  !	IFLAG	I	Code operation			Input
  ! (5-mar-1985)
  !---------------------------------------------------------------------
  integer :: npar                   !
  real*8 :: g(*)                    !
  real*8 :: f                       !
  real*8 :: x(*)                    !
  integer :: iflag                  !
  integer :: nxy                    !
  real :: rdatax(nxy)               !
  real :: rdatay(nxy)               !
  real :: weight(nxy)               !
  ! Global
  include 'gauss.inc'
  ! Local
  real, external :: progauss
  logical :: dograd
  !
  real :: tt,vv,dd,gt,gv,gd,t1,v1,d1,g1,g2,g3,t5,v5,d5,g13,g14,g15
  real :: t4,v4,d4,g10,g11,g12,t3,v3,d3,g7,g8,g9,t2,v2,d2,g4,g5,g6
  real :: xvel,arg1,f1,ff,arg2,arg3,f2,f3,arg4,arg5,f4,f5,arg
  real :: ybas,yrai,seuil,ta
  integer :: i,kbas,krai
  !
  ! Final computations
  if (iflag.eq.3) goto 20
  dograd = iflag.eq.2
  !
  f=0.
  tt=x(1)
  vv=x(2)
  dd=x(3)
  gt=0.
  gv=0.
  gd=0.
  t1=x(4)*tt
  v1=x(5)+vv
  d1=x(6)*dd
  goto (1,2,3,4,5) nline
  goto 1
5 t5=x(16)*tt
  v5=x(17)+vv
  d5=x(18)*dd
  g13=0.
  g14=0.
  g15=0.
  !
4 t4=x(13)*tt
  v4=x(14)+vv
  d4=x(15)*dd
  g10=0.
  g11=0.
  g12=0.
  !
3 t3=x(10)*tt
  v3=x(11)+vv
  d3=x(12)*dd
  g7=0.
  g8=0.
  g9=0.
  !
2 t2=x(7)*tt
  v2=x(8)+vv
  d2=x(9)*dd
  g4=0.
  g5=0.
  g6=0.
  !
1 g1=0.
  g2=0.
  g3=0.
  !
  !	g1 derivee / aire
  !	g2 derivee / vlsr
  !	g3 derivee / delt
  !
  ! Compute gaussians
  do i=1,nxy
    if (weight(i).eq.0) cycle
    xvel = rdatax(i)
    ! First
    arg1 = (xvel - v1) / d1
    if (abs(arg1).gt.4.) then
      f1 = 0.
      ff = 0.
    else
      f1 = exp(-arg1**2)
      ff = f1 * t1 / d1
    endif
    if (nline.le.1) goto 610
    ! Second
    arg2 = (xvel - v2) / d2
    if (abs(arg2).gt.4.) then
      f2=0.
    else
      f2 = exp(-arg2**2)
      ff = ff + f2 * t2 / d2
    endif
    if (nline.le.2) goto 610
    ! Third
    arg3 = (xvel - v3) / d3
    if (abs(arg3).gt.4.) then
      f3=0.
    else
      f3 = exp(-arg3**2)
      ff = ff + f3 * t3 / d3
    endif
    if (nline.le.3) goto 610
    ! Fourth
    arg4 = (xvel - v4) / d4
    if (abs(arg4).gt.4.) then
      f4=0.
    else
      f4 = exp(-arg4**2)
      ff = ff + f4 * t4 / d4
    endif
    if (nline.le.4) goto 610
    ! Fifth
    arg5 = (xvel - v5) / d5
    if (abs(arg5).gt.4.) then
      f5=0.
    else
      f5 = exp(-arg5**2)
      ff = ff + f5 * t5 / d5
    endif
    !
610 continue
    !
    ! Compute du Chi-2 (No ponderation, WEIGHT is ignored)
    ff =  (ff - rdatay(i))
    f = f + ff**2
    !
    ! Compute Gradients
    if (.not.dograd) goto 620
    ff = 2.*ff
    ! First
    if (f1.ne.0.) then
      arg = f1*ff/d1
      g1  = g1 + arg
      gt  = gt + arg*t1
      arg = t1/d1*arg
      g3  = g3 - arg
      gd  = gd - arg*d1
      arg = arg*arg1*2.
      g2  = g2 + arg
      gv  = gv + arg
      g3  = g3 + arg*arg1
      gd  = gd + arg*arg1*d1
    endif
    if (nline.le.1) goto 620
    ! Second
    if (f2.ne.0.) then
      arg = f2*ff/d2
      g4  = g4 + arg
      gt  = gt + arg*t2
      arg = arg*t2/d2
      g6  = g6 - arg
      gd  = gd - arg*d2
      arg = arg*arg2*2.
      g5  = g5 + arg
      gv  = gv + arg
      g6  = g6 + arg*arg2
      gd  = gd + arg*arg2*d2
    endif
    if (nline.le.2) goto 620
    ! Third
    if (f3.ne.0.) then
      arg = f3*ff/d3
      g7  = g7 + arg
      gt  = gt + arg*t3
      arg = arg*t3/d3
      g9  = g9 - arg
      gd  = gd - arg*d3
      arg = arg*arg3*2.
      g8  = g8 + arg
      gv  = gv + arg
      g9  = g9 + arg*arg3
      gd  = gd + arg*arg3*d3
    endif
    if (nline.le.3) goto 620
    ! Fourth
    if (f4.ne.0.) then
      arg = f4*ff/d4
      g10 = g10 + arg
      gt  = gt + arg*t4
      arg = arg*t4/d4
      g12 = g12 - arg
      gd  = gd - arg*d4
      arg = arg*arg4*2.
      g11 = g11 + arg
      gv  = gv + arg
      g12 = g12 + arg*arg4
      gd  = gd + arg*arg4*d4
    endif
    if (nline.le.4) goto 620
    ! Fifth
    if (f5.ne.0.) then
      arg = f5*ff/d5
      g13 = g13 + arg
      gt  = gt  + arg*t5
      arg = arg*t5/d5
      g15 = g15 - arg
      gd  = gd - arg*d5
      arg = arg*arg5*2.
      g14 = g14 + arg
      gv  = gv  + arg
      g15 = g15 + arg*arg5
      gd  = gd  + arg*arg5*d5
    endif
620 continue
    !
  enddo                        ! I
  !
  ! Setup values and return
  f = f
  g(1)=gt/tt
  g(2)=gv
  g(3)=gd/dd
  !
  g(4)=g1*tt
  g(5)=g2
  g(6)=g3*dd
  goto (701,702,703,704,705) nline
701 return
705 g(16)=g13*tt
  g(17)=g14
  g(18)=g15*dd
704 g(13)=g10*tt
  g(14)=g11
  g(15)=g12*dd
703 g(10)=g7*tt
  g(11)=g8
  g(12)=g9*dd
702 g(7)=g4*tt
  g(8)=g5
  g(9)=g6*dd
  return
  !
  ! Compute Sigma after Minimisation
20 kbas=0
  ybas=0.
  krai=0
  yrai=0.
  seuil= sigbas/3.
  !
  do i=1,nxy
    if (weight(i).eq.0) cycle
    ta = progauss (rdatax(i),0)
    if (abs(ta).lt.seuil) then
      kbas=kbas+1
      ybas=ybas+rdatay(i)**2
    else
      krai=krai+1
      yrai=yrai+(ta-rdatay(i))**2
    endif
  enddo
  if (kbas.ne.0) then
    sigbas=sqrt(ybas/kbas)
  else
    sigbas=0.d0
  endif
  if (krai.ne.0) then
    sigrai=sqrt(yrai/krai)
  else
    sigrai=0.d0
  endif
end subroutine mingau
!
function progauss (a,m)
  !---------------------------------------------------------------------
  ! ANALYSE	(Internal routine)
  !	M = 0
  ! 	Computes the composite profile from sum of all gaussians.
  !	M # 0
  !	Computes the profile from gaussian number M
  !
  ! S. Guilloteau 19-Dec-1984
  !---------------------------------------------------------------------
  real*4 :: progauss                !
  real*4 :: a                       !
  integer :: m                      !
  ! Global
  include 'gauss.inc'
  ! Local
  real*4 :: arg
  !
  progauss=0.
  arg=0.
  goto (1,2,3,4,5) m
  !
1 continue
  if (par(1).ne.0 .and. par(3).ne.0.) then
    arg = abs((a - par(2)) / par(3)*1.665109)
    if (arg.lt.4.) then
      progauss = exp(-arg**2)*par(1)/par(3)/1.064467
    endif
  endif
  if (ngline.le.1 .or. m.eq.1) return
  !
2 continue
  if (par(4).ne.0 .and. par(6).ne.0.) then
    arg = abs((a - par(5)) / par(6)*1.665109)
    if (arg.lt.4.) then
      progauss = progauss + exp(-arg**2)*par(4)/par(6)/1.064467
    endif
  endif
  if (ngline.le.2 .or. m.eq.2) return
  !
3 continue
  if (par(7).ne.0 .and. par(9).ne.0.) then
    arg = abs((a - par(8)) / par(9)*1.665109)
    if (arg.lt.4.) then
      progauss = progauss + exp(-arg**2)*par(7)/par(9)/1.064467
    endif
  endif
  if (ngline.le.3 .or. m.eq.3) return
  !
4 continue
  if (par(10).ne.0. .and. par(12).ne.0.) then
    arg = abs((a - par(11)) / par(12)*1.665109)
    if (arg.lt.4.) then
      progauss = progauss + exp(-arg**2)*par(10)/par(12)/1.064467
    endif
  endif
  if (ngline.le.4 .or. m.eq.4) return
  !
5 continue
  if (par(13).ne.0. .and. par(15).ne.0.) then
    arg = abs((a - par(14)) / par(15)*1.665109)
    if (arg.lt.4.) then
      progauss = progauss + exp(-arg**2)*par(13)/par(15)/1.064467
    endif
  endif
end function progauss
