module gauss_2d_data
  use image_def
  type(gildas), save :: xima
  !
  ! Former 'ellipse.inc':
  real(kind=4) :: spar(10),kpar(10),sigbas,sigrai,par(10),err(10)
  real, allocatable :: array(:,:)
  integer(kind=index_length) :: t_dim(2)
  real(kind=8) :: t_ref1, t_ref2
  !
end module gauss_2d_data
!
program gauss_2d
  use gildas_def
  use image_def
  use gkernel_interfaces
  use fit_minuit
  use gauss_2d_data
  !---------------------------------------------------------------------
  ! Make a 2-D gaussfit to a part of an image
  !---------------------------------------------------------------------
  ! Global
  external :: min2d
  ! Local
  type(fit_minuit_t) :: fit
  character(len=filename_length) :: in_name,out_name,name,res_name
  logical :: error, do_res
  real :: upar(20),s
  integer :: i,i3, i4, blc(4), trc(4), lun, ier
  type(gildas) :: y
  !
  ! Read commands
  call gildas_open
  call gildas_char('IN$',in_name)
  call gildas_char('OUT$',out_name)
  call gildas_logi('DO_RES$',do_res,1)
  if (do_res) then
    call gildas_char('RES$',res_name)
  endif
  call gildas_real('MAX_INT$',upar(1),2)
  call gildas_real('X_POS$',upar(3),2)
  call gildas_real('Y_POS$',upar(5),2)
  call gildas_real('MAJOR$',upar(7),2)
  call gildas_real('MINOR$',upar(9),2)
  call gildas_real('POSANG$',upar(11),2)
  call gildas_inte('BLC$',blc,4)
  call gildas_inte('TRC$',trc,4)
  call gildas_real('SIGMA$',s,1)
  call gildas_close
  fit%verbose=.false.
  !
  ! Read input map
  call gildas_null(xima, type = 'IMAGE')
  call gdf_read_gildas(xima, in_name, '.gdf', error, rank=4)
  !
  ! Create map  of residuals  (Y common)
  if (do_res) then
    call gildas_null (y, type = 'IMAGE')
    call gdf_copy_header(xima,y,error)
    call sic_parsef(res_name,y%file,' ','.gauss-res')
    call gagout('I-GAUSS_2D,  Creating residuals image '//y%file)
    call gdf_create_image (y, error)
    if (error) then
      call gagout('F-GAUSS_2D,  Cannot create residuals table')
      goto 99
    endif
    y%gil%ndim = 4
    call gdf_allocate(y,error)
  endif
  !
  ! Open listing file
  call sic_parsef(out_name,name,' ','.gauss')
  lun = 1
  ier = sic_open(lun,name,'NEW',.false.)
  !
  do i=1,4
    if (blc(i).eq.0) then
      blc(i) = 1
    else
      blc(i) = max(1,min(xima%gil%dim(i),blc(i)))
    endif
  enddo
  do i=1,4
    if (trc(i).eq.0) then
      trc(i) = xima%gil%dim(i)
    else
      trc(i) = max(blc(i),min(xima%gil%dim(i),trc(i)))
    endif
  enddo
  !
  t_dim(1) = trc(1)-blc(1)+1
  t_dim(2) = trc(2)-blc(2)+1
  t_ref1 = xima%gil%ref(1)-blc(1)+1
  t_ref2 = xima%gil%ref(2)-blc(2)+1
  allocate (array(t_dim(1),t_dim(2)),stat=ier)
  if (ier.ne.0) goto 99
  !
  do i4 = blc(4), trc(4)
    do i3 = blc(3), trc(3)
      write (6,*) 'Plane ',i3,i4,' starting'
      do i=1,6
        spar(i) = upar(2*i-1)
        kpar(i) = upar(2*i)
      enddo
      sigbas = s
      sigrai = s
      ! Extract one plane
      call ext2d(xima%r4d(:,:,i3,i4),xima%gil%dim(1),xima%gil%dim(2),  &
                 array,              t_dim(1),       t_dim(2),         &
                 blc,trc)
      ! Fit the gaussian
      call fit2d(fit,min2d,.false.,error)
      ! Get residuals
      if (do_res) then
        call res2d(xima%r4d(:,:,i3,i4),xima%gil%dim(1),xima%gil%dim(2),  &
                y%r4d(:,:,i3,i4),                                        &
                xima%gil%ref(1),xima%gil%val(1),xima%gil%inc(1),         &
                xima%gil%ref(2),xima%gil%val(2),xima%gil%inc(2),         &
                xima%gil%bval,xima%gil%eval)
      endif
      ! Write the results to listing file
      call wri2d (lun,i3,i4)
    enddo
  enddo
  if (do_res) then
    call gdf_write_data(y, y%r4d, error)
    call gdf_close_image (y, error)
  endif
  call gdf_close_image (xima,error)
  stop 'S-GAUSS_2D,  Successful completion'
  !
99 call sysexi (fatale)
end program gauss_2d
!
subroutine ext2d(x,nx1,nx2,y,ny1,ny2,blc,trc)
  use gildas_def
  !---------------------------------------------------------------------
  ! Extract the relevant part of one plane in the image
  !---------------------------------------------------------------------
  integer(kind=index_length), intent(in) :: nx1         !
  integer(kind=index_length), intent(in) :: nx2         !
  real(kind=4),               intent(in) :: x(nx1,nx2)  !
  integer(kind=index_length), intent(in) :: ny1         !
  integer(kind=index_length), intent(in) :: ny2         !
  real(kind=4)                           :: y(ny1,ny2)  !
  integer(kind=4),            intent(in) :: blc(4)      !
  integer(kind=4),            intent(in) :: trc(4)      !
  ! Local
  integer(kind=4) :: j,l
  l = 1
  do j=blc(2),trc(2)
    call r4tor4 (x(blc(1),j),y(1,l),trc(1)-blc(1)+1)
    l = l+1
  enddo
end subroutine ext2d
!
subroutine wri2d (lun, i, j)
  use gildas_def
  use gauss_2d_data
  !---------------------------------------------------------------------
  !
  !---------------------------------------------------------------------
  integer :: lun                    !
  integer :: i                      ! I, J = plane number
  integer :: j                      !
  ! Local
  real aa
  !
  if (par(4).lt.par(5)) then
    par(6) = par(6)+90.
    aa = par(4)
    par(4) = par(5)
    par(5) = aa
  endif
  par(6) = -90.+mod(par(6)+3690.,180.)
  ! Writing result in arc second is 1) in contradistinction with the doc
  ! and 2) incompatible with GILDAS philosophy for Xinc, Yinc.
  write (lun,100) par(1),err(1),par(2),err(2)   &
     &    ,par(3),err(3),par(4),err(4)   &
     &    ,par(5),err(5),par(6),err(6), i, j
100 format(12(1x,g10.4),2(1x,i4))
end subroutine wri2d
!
subroutine res2d (map,nx,ny,res,xref,xval,xinc,yref,yval,yinc,bad,tol)
  use gildas_def
  use gauss_2d_data
  !---------------------------------------------------------------------
  !
  !---------------------------------------------------------------------
  integer(kind=index_length), intent(in) :: nx  !
  integer(kind=index_length), intent(in) :: ny  !
  real :: map(nx,ny)                !
  real :: res(nx,ny)                !
  real*8 :: xref                    !
  real*8 :: xval                    !
  real*8 :: xinc                    !
  real*8 :: yref                    !
  real*8 :: yval                    !
  real*8 :: yinc                    !
  real :: bad                       !
  real :: tol                       !
  ! Local
  real :: far,sfar
  parameter (far=24.0, sfar=5.0)
  integer :: i,j
  real :: x,y
  real :: i0, x0,y0,a,b,alpha
  real :: t1,t2, gint, gg, ca, sa
  real :: zz
  real*8 :: pi
  parameter (pi=3.141592653589793d0)
  !
  i0 = par(1)
  x0 = par(2)
  y0 = par(3)
  a = par(4)/2.0/sqrt(log(2.0))
  b = par(5)/2.0/sqrt(log(2.0))
  alpha = (par(6)-90)*pi/180.
  ca = cos(alpha)
  sa = sin(alpha)
  do j = 1,ny
    y = (j-yref)*yinc+yval
    do i = 1,nx
      zz = map(i,j)
      if (abs(zz-bad).gt.tol) then
        x = (i-xref)*xinc+xval
        t1 = ca * (x - x0) + sa * (y - y0)
        t2 = sa * (x - x0) - ca * (y - y0)
        gint = (t1/a)**2 + (t2/b)**2
        if (gint.ge.far) then
          res(i,j)= zz
        else
          gg = exp(-gint)
          res(i,j) = zz-i0*gg
        endif
      else
        res(i,j)= zz
      endif
    enddo
  enddo
end subroutine res2d
!
subroutine fit2d(fit,fcn,liter,error)
  use gildas_def
  use gbl_message
  use gkernel_interfaces
  use fit_minuit
  use gauss_2d_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
  ! Local
  real*8, parameter :: pi=3.141592653589793d0
  integer :: i,k,l,ifatal,ier
  real*8 :: dx,al,ba,du1,du2
  real :: sec
  character(len=message_length) :: mess
  !
  error = .false.
  fit%isyswr=6
  fit%maxext=ntot
  fit%maxint=nvar
  !
  ! Initialise values
  call mid2d(fit,ifatal,liter)
  if (ifatal.ne.0) then
    error = .true.
    return
  endif
  call intoex(fit,fit%x)
  call fcn(fit%npar,fit%g,fit%amin,fit%u,3)
  write(fit%isyswr,*) 'Sigmas 1:',sigbas,sigrai
  fit%up = sigbas**2
  fit%nfcnmx = 5000
  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 intoex(fit,fit%x)
  call fcn(fit%npar,fit%g,fit%amin,fit%u,1)
  !
  ! Simplex Minimization
  if (.not.liter) then
    call simplx(fit,fcn,ier)
    ! Error Patch in Case of bad behaved Function
    if (ier.ne.0) then
      error=.true.
      return
    endif
    do k=1,fit%nu
      par(k) = fit%u(k)
    enddo
  endif
  !
  ! Gradient Minimization
  fit%nfcnmx = 5000
  call intoex(fit,fit%x)
  call fcn(fit%npar,fit%g,fit%amin,fit%u,3)
  write(fit%isyswr,*) 'Sigmas 2:',sigbas,sigrai
  fit%up = sigbas**2
  fit%epsi  = 0.1d0 * fit%up
  fit%apsi  = fit%epsi
  call hesse(fit,fcn)
  call migrad(fit,fcn,ier)
  ! CALL HESSE fait par FITGAU si IER = 1
  if (ier.eq.1) then
    ier=0
    error=.false.
    call hesse(fit,fcn)
  endif
  !
  ! Print Results
  do k=1,fit%nu
    par(k)  = fit%u(k)
  enddo
  call intoex(fit,fit%x)
  call fcn(fit%npar,fit%g,fit%amin,fit%u,3)
  write(fit%isyswr,*) 'Sigmas 3:',sigbas,sigrai
  fit%up  = sigbas**2
  !
  ! Calculate External Errors
  do i=1,fit%nu
    l  = fit%lcorsp(i)
    if (l .eq. 0)  then
      fit%werr(i)=0.
    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
      endif
    endif
  enddo
  !
  if (sigbas.lt.sigrai/1.5 .or. sigbas.gt.1.5*sigrai) then
    write(fit%isyswr,*) 'I-GAUSS,  Bad fit'
  else
    write(fit%isyswr,*) 'I-GAUSS,  Good fit'
  endif
  !
  ! Setup results
  sec = 3600*180/pi
  par(1) = fit%u(1)
  err(1) = fit%werr(1)
  write(mess,*) 'Peak Intensity ',par(1),err(1)
  call gagout(mess)
  !
  par(2) = fit%u(2)
  err(2) = fit%werr(2)
  write(mess,*) 'X Position ',par(2),err(2),par(2)*sec,err(2)*sec
  call gagout(mess)
  !
  par(3) = fit%u(3)
  err(3) = fit%werr(3)
  write(mess,*) 'Y Position ',par(3),err(3),par(3)*sec,err(3)*sec
  call gagout(mess)
  !
  par(4) = 2.0*sqrt(log(2.0))*fit%u(4)
  err(4) = 2.0*sqrt(log(2.0))*fit%werr(4)
  write(mess,*) 'Major axis ',par(4),err(4),par(4)*sec,err(4)*sec
  call gagout(mess)
  !
  par(5) = 2.0*sqrt(log(2.0))*fit%u(5)
  err(5) = 2.0*sqrt(log(2.0))*fit%werr(5)
  write(mess,*) 'Minor axis ',par(5),err(5),par(5)*sec,err(5)*sec
  call gagout(mess)
  !
  par(6) = fit%u(6)*180.0/pi+90.0
  err(6) = fit%werr(6)*180.0/pi
  write(mess,*) 'Position Angle',par(6),err(6)
  call gagout(mess)
  !
end subroutine fit2d
!
subroutine mid2d(fit,ifatal,liter)
  use gkernel_interfaces
  use gildas_def
  use gbl_message
  use gkernel_interfaces
  use fit_minuit
  use gauss_2d_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,            intent(out)   :: ifatal  ! Number of fatal errors
  logical,            intent(in)    :: liter   ! Iterate a fit
  ! Local
  real*8, parameter :: pi=3.141592653589793d0
  integer :: i, nint, k
  real*8 :: sav, sav2, vplu, vminu
  real :: sln2
  character(len=message_length) :: mess
  !
  sln2 = 2.0*sqrt(log(2.0))
  !
  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
  par(1) = spar(1)             ! Intensite
  fit%u(1) = par(1)
  if (kpar(1).eq.1) then
    fit%werr(1)=0.
  else
    fit%werr(1) = abs(0.1*fit%u(1))
    ! if (liter) fit%werr(1) = err(1)
    if (fit%u(1).lt.0) then
      fit%alim(1) = 100.*fit%u(1)
      fit%blim(1) = 0.01*fit%u(1)
    else
      fit%blim(1) = 100.*fit%u(1)
      fit%alim(1) = 0.01*fit%u(1)
    endif
  endif
  !
  par(2) = spar(2)             ! X Position
  fit%u(2) = par(2)
  if (kpar(2).eq.1) then
    fit%werr(2)=0.
  else
    fit%werr(2) = abs(3.0*xima%gil%inc(1))
    ! if (liter) fit%werr(2) = err(2)
    fit%alim(2) = fit%u(2) - 40.*fit%werr(2)
    fit%blim(2) = fit%u(2) + 40.*fit%werr(2)
  endif
  !
  par(3) = spar(3)             ! Y Position
  fit%u(3) = par(3)
  if (kpar(3).eq.1) then
    fit%werr(3)=0.
  else
    fit%werr(3) = abs(3.0*xima%gil%inc(2))
    ! if (liter) fit%werr(3) = err(3)
    fit%alim(3) = fit%u(3) - 40.*fit%werr(3)
    fit%blim(3) = fit%u(3) + 40.*fit%werr(3)
  endif
  !
  par(4) = spar(4) / sln2      ! Major axis
  fit%u(4) = par(4)
  if (kpar(4).eq.1) then
    fit%werr(4)=0.
  else
    fit%werr(4) = 3.0*sqrt(abs(xima%gil%inc(2)*xima%gil%inc(1))) / sln2
    ! if (liter) fit%werr(4) = err(4) / sln2
    fit%alim(4) = fit%werr(4)/9.0
    fit%blim(4) = max(abs(xima%gil%dim(1)*xima%gil%inc(1)),abs(xima%gil%dim(2)*xima%gil%inc(2)))*3.0/ sln2
  endif
  !
  par(5) = spar(5) / sln2      ! Minor axis
  fit%u(5) = par(5)
  if (kpar(5).eq.1) then
    fit%werr(5)=0.
  else
    fit%werr(5) = fit%werr(4)
    ! if (liter) fit%werr(5) = err(5) / sln2
    fit%alim(5) = fit%alim(4)
    fit%blim(5) = fit%blim(4)
  endif
  !
  par(6) = spar(6)*pi/180.0    ! Position Angle
  fit%u(6) = par(6)
  if (kpar(6).eq.1) then
    fit%werr(6)=0.
  else
    fit%werr(6) = pi/8.0
    ! if (liter) fit%werr(6)=err(6)*180.0/pi
    fit%alim(6) = fit%u(6)-pi/4.0
    fit%blim(6) = fit%u(6)+pi/4.0
  endif
  !
  fit%nu = 6
  !
  ! 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
    write(mess,1010) k,' is fixed'
    call gagout('W-MID2D,  '//mess)
    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,fit%alim(k),fit%blim(k)
    go to 160
155 if (k.gt.3) then
      write(mess,1010) k,' is at limit'
      call gagout('W-MID2D,  '//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 ',1pg11.4,1x,1pg11.4)
1013 format (1x,i3,' Errors on input parameters. ABORT.')
end subroutine mid2d
!
subroutine min2d (npar,g,f,var,iflag)
  use gkernel_interfaces
  use gildas_def
  use gauss_2d_data
  integer :: npar                   !
  real*8 :: g(npar)                 !
  real*8 :: f                       !
  real*8 :: var(npar)               !
  integer :: iflag                  !
  ! Local
  real :: xref,xval,xinc, yref,yval,yinc
  !
  xref = t_ref1
  xval = xima%gil%val(1)
  xinc = xima%gil%inc(1)
  yref = t_ref2
  yval = xima%gil%val(2)
  yinc = xima%gil%inc(2)
  call mn2d(npar,g,f,var,iflag,array,t_dim(1),t_dim(2),xref,xval,xinc,  &
  yref,yval,yinc,xima%gil%bval,xima%gil%eval,sigbas,sigrai)
end subroutine min2d
!
subroutine mn2d(npar,g,f,var,iflag,map,nx,ny,xref,xval,xinc,yref,yval,yinc,  &
  bad,tol,sigbas,sigrai)
  use gildas_def
  !---------------------------------------------------------------------
  ! Let
  !	t1 : (x-x0) Cos[alpha] + (y-y0) Sin[alpha]
  !	t2 : (x-x0) Sin[alpha] - (y-y0) Cos[alpha]
  ! Then
  ! 	dt&NAME : D[t&,NAME]
  ! Let
  !	g : i0 Exp[-t1^2/(a^2) - t2^2/(b^2)]
  ! Then
  !	dgNAME : D[g,NAME]/g
  !---------------------------------------------------------------------
  integer(kind=4)            :: npar
  real(kind=8)               :: g(npar)
  real(kind=8)               :: f
  real(kind=8)               :: var(npar)
  integer(kind=4)            :: iflag
  integer(kind=index_length) :: nx
  integer(kind=index_length) :: ny
  real(kind=4)               :: map(nx,ny)
  real(kind=4)               :: xref
  real(kind=4)               :: xval
  real(kind=4)               :: xinc
  real(kind=4)               :: yref
  real(kind=4)               :: yval
  real(kind=4)               :: yinc
  real(kind=4)               :: bad
  real(kind=4)               :: tol
  real(kind=4)               :: sigbas
  real(kind=4)               :: sigrai
  ! Local
  real(kind=4), parameter :: far=24.0
  real(kind=4), parameter :: sfar=5.0
  logical :: dograd,dosig
  integer(kind=index_length) :: i,j
  integer(kind=4) :: nrai,nbas
  real(kind=4) :: x,y
  real(kind=4) :: i0, x0,y0,a,b,alpha
  real(kind=4) :: dfx0,dfy0,dfa,dfb,dfalp
  real(kind=4) :: dgx0,dgy0,dga,dgb,dgalp
  real(kind=4) :: dt1x0,dt1y0,dt1alp
  real(kind=4) :: dt2x0,dt2y0,dt2alp
  real(kind=4) :: dgt1,dgt2
  real(kind=4) :: t1,t2, gint, gsxy, gd,gg, ca, sa
  real(kind=4) :: zz, frai, fbas
  !
  if (iflag.eq.3) then
    dosig = .true.
    nbas = 0
    nrai = 0
  endif
  dograd = iflag.eq.2
  !
  ! Setup
  i0 = var(1)
  x0 = var(2)
  y0 = var(3)
  a = var(4)
  b = var(5)
  alpha = var(6)
  dfx0 = 0.0
  dfy0 = 0.0
  dfa = 0.0
  dfb = 0.0
  dfalp = 0.0
  !
  ! Constants
  ca = cos(alpha)
  sa = sin(alpha)
  !
  ! Constant intermediate values for derivatives
  if (dograd) then
    dt1y0 = - sa
    dt1x0 = - ca
    dt2x0 = - sa
    dt2y0 = ca
  endif
  !
  ! Preliminaries
  fbas = 0.0
  frai = 0.0
  gsxy = 0.0
  do j=1,ny
    y = (j-yref)*yinc+yval
    if (abs(y-y0).gt.sfar*a) then
      do i=1,nx
        zz = map(i,j)
        if (abs(zz-bad).gt.tol) then
          fbas = fbas + zz*zz
          if (dosig) nbas = nbas+1
        endif
      enddo
      cycle                    ! J
    endif
    do i=1,nx
      zz = map(i,j)
      if (abs(zz-bad).le.tol) cycle    ! I
      x = (i-xref)*xinc+xval
      t1 = ca * (x - x0) + sa * (y - y0)
      t2 = sa * (x - x0) - ca * (y - y0)
      gint = (t1/a)**2 + (t2/b)**2
      !
      ! Skip zero values
      if (gint.ge.far) then
        fbas = fbas + zz*zz
        if (dosig) nbas = nbas+1
        cycle                  ! I
      endif
      !
      ! Function
      gg = exp(-gint)
      gd = i0*gg-zz
      frai = frai + gd*gd      ! sum of squares
      !
      if (dograd) then
        dt1alp = - t2
        dt2alp = t1
        dgt1 = - 2*t1/a/a
        dgt2 = - 2*t2/b/b
        dga = -t1*dgt1/a
        dgb = -t2*dgt2/b
        dgx0 = dgt1 * dt1x0 + dgt2 * dt2x0
        dgy0 = dgt1 * dt1y0 + dgt2 * dt2y0
        dgalp = dgt1 * dt1alp + dgt2 * dt2alp
        !
        gg = 2*gd*gg
        gsxy = gsxy + gg
        gg = i0*gg
        !
        dfx0 = dfx0 + dgx0*gg
        dfy0 = dfy0 + dgy0*gg
        dfalp = dfalp + dgalp*gg
        dfa = dfa + dga*gg
        dfb = dfb + dgb*gg
      endif
      if (dosig) nrai = nrai+1
    enddo                      ! I
  enddo                        ! J
  !
  if (dosig) then
    if (nbas.ne.0) then
      sigbas = sqrt (fbas/nbas)
      if (nrai.ne.0) then
        sigrai = sqrt (frai/nrai)
      else
        sigrai = sigbas
      endif
    else
      if (nrai.ne.0) sigrai = sqrt (frai/nrai)
      sigbas = sigrai
    endif
  endif
  f = fbas+frai
  if (.not.dograd) return
  !
  g(1) = gsxy/i0
  g(2) = dfx0
  g(3) = dfy0
  g(4) = dfa
  g(5) = dfb
  g(6) = dfalp
  !
end subroutine mn2d
