module back_conversion
  real, save :: cvi(6),cvo(6)
end module back_conversion
!
program background_main
  use gildas_def
  use image_def
  use gkernel_interfaces
  use gbl_format
  use back_conversion
  !---------------------------------------------------------------------
  ! Compute a large scale background
  !---------------------------------------------------------------------
  ! Local
  character(len=filename_length) :: namex,namey
  character(len=4) :: method
  integer :: mode
  logical :: error,slow,fourier
  integer :: n, scale, nw, nt
  integer :: nhisto,nback,ier
  real :: pmin,pmax,pinc,x1,x2
  real(4), allocatable :: x(:), y(:), z(:), w(:), histo(:)
  real(4), allocatable :: iw(:)
  integer :: nx,ny,nz
  integer :: mx,my
  type(gildas) :: xima,yima
  !
  slow=.false.
  call gildas_open
  call gildas_char('Y_NAME$',namey)
  call gildas_char('X_NAME$',namex)
  call gildas_real('X_MIN$',x1,1)
  call gildas_real('X_MAX$',x2,1)
  call gildas_inte('NBINS$',nhisto,1)
  call gildas_inte('WIDTH$',nw,1)
  call gildas_inte('SCALE$',scale,1)
  call gildas_inte('N_MIN$',nt,1)
  call gildas_char('METHOD$',method)
  call gildas_close
  !
  n = len_trim(namey)
  call gildas_null(yima)
  call gdf_read_gildas(yima,namey,'.gdf',error, rank=3) 
  if (error) then
    write(6,*) 'F-BACKGROUND,  Cannot read input file'
    goto 100
  endif
  !
  call gildas_null(xima)
  call gdf_copy_header(yima,xima,error)
  !
  nx=xima%gil%dim(1)
  ny=xima%gil%dim(2)
  pmin = min(x1,x2)
  pmax = max(x1,x2)
  pinc = (pmax-pmin)/nhisto
  !
  ! Consistency checks.
  nt = max(nt,3*nhisto)
  nt = min(nt,3*nw**2/4)       ! PI*D^2/4
  mode=1
  slow=.false.
  fourier=.false.
  if (method.eq.'ZERO') then
    mode=0
  elseif (method.eq.'FAST') then
    mode=1
  elseif (method.eq.'LINE') then
    mode=1
  elseif (method.eq.'PARA') then
    mode=2
  elseif (method.eq.'GAUS') then
    mode=3
  elseif (method.eq.'FOUR') then
    fourier = .true.
    mode=-1
  elseif (method.eq.'SLOW') then
    slow=.true.
    mode=0
  endif
  !
  ! Get some work space
  allocate (histo(nhisto), stat=ier)
  if (ier.ne.0) goto 99
  mx=int(float(nx-nw)/float(scale))+1
  my=int(float(ny-nw)/float(scale))+1
  cvi(:) = 1.0
  cvo(1)=1.0
  cvo(2)=float(nw+1)*0.5
  cvo(3)=float(scale)
  cvo(4)=1.0
  cvo(5)=float(nw+1)*0.5
  cvo(6)=float(scale)
  nback = mx*my
  if (slow) then
    write(6,*) 'Using slow method...'
	allocate (x(nback), y(nback), z(nback), iw(35*nback), w(13*nback), stat=ier)
  elseif (fourier) then
    xima%gil%dim(1)=mx
    xima%gil%dim(2)=my
    xima%loca%size = xima%gil%dim(1)*xima%gil%dim(2)*xima%gil%dim(3)*xima%gil%dim(4)
  else
	allocate (x(3*nback), stat=ier)
  endif
  n = len_trim(namex)
  call sic_parsef(namex(1:n),xima%file,' ','.gdf')
  call gdf_create_image(xima,error)  
  if (error) then
    write(6,*) 'F-BACKGROUND,  Cannot create output image'
    goto 100
  endif
  !
  ! Allocate the data 
  allocate(xima%r3d(xima%gil%dim(1), xima%gil%dim(2), xima%gil%dim(3) ) , stat=ier) 
  if (ier.ne.0) goto 100
  !
  ! Do the real work
  nz = xima%gil%dim(3)
  if (slow) then
    call zodi011 (yima%r3d,   & !Input image
     &      nx,ny,nz,         & !Size
     &      nt,   &            !Minimum number of data points
     &      scale,   &         !Scale
     &      nw,   &            !Width
     &      xima%gil%bval,    &        !Blanking value
     &      xima%gil%eval,    &
     &      pmin,pmax,pinc,   &
     &      histo,   &
     &      x, y, z, w, iw,   &
  	 &      xima%r3d )
  else
    ! Define the background map
    if (xima%gil%blan_words.eq.0) then
      xima%gil%bval = pmin-1.0
      xima%gil%eval = 0.9
      xima%gil%blan_words = 2
    endif
!!    if (fourier) x = ipx
    call zodi001 (yima%r3d,   & !Input image
     &      nx,ny,nz,         & !Size
     &      nt,   &            !Minimum number of data points
     &      scale,   &         !Scale
     &      nw,   &            !Width
     &      xima%gil%bval,   &        !Blanking value
     &      xima%gil%eval,   &
     &      pmin,pmax,pinc,   &
     &      histo,   &
     &      x,   &
     &      xima%r3d,   &
     &      mode)
  endif
  ! Update disk files and free memory
  call gdf_write_data(xima, xima%r3d, error)
  if (error) goto 100
  !
  stop 'S-BACKGROUND,  Successful completion'
  !
99 write(6,*) 'F-BACKGROUND,  Memory allocation failure'
100 call sysexi (fatale)
end program background_main
!
subroutine zodi001(a,nx,ny,nz,nt,scale,nw,bval,eval,   &
     &    pmin,pmax,pinc,histo,inter,b,mode)
  !---------------------------------------------------------------------
  ! Compute a large scale background, FAST VERSION
  !
  ! Arguments:
  !	A	R*4	Input data cube				Input
  !	NX	I	First dimension of A			Input
  !	NY	I	Second dimension of A			Input
  !	NZ	I	Third dimension of A			Input
  !	NT	I	Minimum valid number of points 		Input
  !	SCALE	I	Scale factor for intermediate grid	Input
  !	NW	I	Diameter of smoothing circle		Input
  !	BVAL	R*4	Blanking value				Input
  !	EVAL	R*4	Tolerance on blanking value		Input
  !	PMIN	R*4	Minimum accepted value			Input
  !	PMAX	R*4	Maximum accepted value			Input
  !	PINC	R*4	Histogram step				Input
  !	HISTO	R*4	Histogram array				Scratch
  !	INTER	R*4	Intermediate image			Scratch
  !	B	R*4	Output background image			Output
  !       MODE    I       0=nointerpol, 1 or 2 interpol same orderInput
  !---------------------------------------------------------------------
  integer :: nx                     !
  integer :: ny                     !
  integer :: nz                     !
  real(4) :: a(nx,ny,nz)             !
  integer :: nt                     !
  integer :: scale                  !
  integer :: nw                     !
  real(4) :: bval                    !
  real(4) :: eval                    !
  real(4) :: pmin                    !
  real(4) :: pmax                    !
  real(4) :: pinc                    !
  real(4) :: histo(*)                !
  real(4) :: inter(*)                !
  real(4) :: b(nx,ny,nz)             !
  integer :: mode                   !
  ! Local
  integer :: mx,my
  !
  integer nh,i
  !
  mx=int(float(nx-nw)/float(scale))+1
  my=int(float(ny-nw)/float(scale))+1
  ! Define the Histogram
  nh = nint((pmax-pmin)/pinc)
  !
  ! Compute the background image
  do i=1,nz                    ! Loop on planes
    call zodi002(a(1,1,i),nx,ny,scale,nw,pmin,   &
     &      pmax,pinc,histo,nh,nt,inter,mx,my,bval)
    !
    ! Resample the image to the full Grid
    if (mode.ne.-1) call zodi003(inter,mx,my,   &
     &      b(1,1,i),nx,ny,bval,eval,   &
     &      scale,nw,mode)
    !
    ! Subtract the background from the image
    !         CALL ZODI004 (A,B,NX,NY,BVAL,EVAL)
  enddo
end subroutine zodi001
!
subroutine zodi002(a,nx,ny,ns,nw,pmin,pmax,pinc,h,nh,nt,   &
     &    inter,mx,my,bval)
  use back_conversion
  !---------------------------------------------------------------------
  ! Estimate large scale background on reduced grid, FAST VERSION
  ! Arguments:
  !	A	R*4	Input data cube				Input
  !	NX	I	First dimension of A			Input
  !	NY	I	Second dimension of A			Input
  !	NS	I	Scale factor for intermediate grid	Input
  !	NW	I	Diameter of smoothing circle		Input
  !	PMIN	R*4	Minimum accepted value			Input
  !	PMAX	R*4	Maximum accepted value			Input
  !	PINC	R*4	Histogram step				Input
  !	H	R*4	Histogram array				Scratch
  !	NH	I	Size of histogram			Input
  !	NT	I	Minimum valid number of points 		Input
  !     INTER	R*4	Intermediate image		        Output
  !	MX	I	First dimension of INTER		Input
  !	MY	I	Second dimension of INTER		Input
  !	BVAL	R*4	Blanking value				Input
  !---------------------------------------------------------------------
  integer :: nx                     !
  integer :: ny                     !
  real(4) :: a(nx,ny)                !
  integer :: ns                     !
  integer :: nw                     !
  real(4) :: pmin                    !
  real(4) :: pmax                    !
  real(4) :: pinc                    !
  integer :: nh                     !
  real(4) :: h(nh)                   !
  integer :: nt                     !
  integer :: mx                     !
  integer :: my                     !
  real(4) :: inter(mx,my,3)          !
  real(4) :: bval                    !
  ! Local
  integer :: m
  real(4) :: ja,ia
  !
  real r,grav(2)
  integer i,j,nf,k,ier
  !
  write(6,*) 'Size of intermediate background grid: ',mx,my
  k = 0
  do j = 1,my
    ja = (j-cvo(4))*cvo(6)+cvo(5)
    do i = 1,mx
      ia = (i-cvo(1))*cvo(3)+cvo(2)
      call zodi102(a,nx,ny,ia,ja,pmin,pmax,pinc,   &
     &        h,nh,nw,nf)
      if (nf.ge.nt) then
        call zodi122(h,nh,r,pmin,pinc)
        call zodi123(a,nx,ny,ia,ja,nw,pinc,r,grav,ier)
        if (ier.eq.0) then
          k    = k+1
          inter(i,j,1) = r
          inter(i,j,2) = grav(1)
          inter(i,j,3) = grav(2)
        endif
      endif
    enddo
  enddo
  m = k
  write(6,*) m,' valid background values found'
end subroutine zodi002
!
subroutine zodi003(a,mx,my,b,nx,ny,bval,eval,ns,nw,mode)
  use back_conversion
  !---------------------------------------------------------------------
  !	Regrid the intermediate background map on the same scale as
  !       the original map, zero,1 or 2-order linear interpolation
  ! Arguments
  !       A	R*4(*)	Input map                               Input
  !	MX	I	First dimension of A			Input
  !	MY	I	Second dimension of A			Input
  !	B	R*4(*)	Output map                              Output
  !	NX	I	First dimension of B			Input
  !	NY	I	Second dimension of B			Input
  !	BVAL	R*4	Blanking value                          Input
  !	EVAL	R*4	Tolerance on blanking value		Input
  !	NS	I	Scale factor for intermediate grid	Input
  !	NW	I	Diameter of smoothing circle		Input
  !       MODE    I       0=nointerpol, 1 or 2 interpol same orderInput
  !---------------------------------------------------------------------
  integer :: mx                     !
  integer :: my                     !
  real(4) :: a(mx,my,3)              !
  integer :: nx                     !
  integer :: ny                     !
  real(4) :: b(nx,ny)                !
  real(4) :: bval                    !
  real(4) :: eval                    !
  integer :: ns                     !
  integer :: nw                     !
  integer :: mode                   !
  ! Local
  integer :: ib,jb,i,j,imin,imax,jmin,jmax
  real :: xa,ya,xr,yr,aplus,azero,amoin
  integer :: ia,ja
  !
  real x,y,z,x0,y0,dx,dy,tmp,delta,dist
  real*8 value,weight
  integer ibb,jbb,isup
  integer count
  integer nexp,mexp
  parameter (mexp=100)
  real myexp(mexp)
  !
  ! Interpolate,Take Blanking into account, version #1
  ! Loop over Output data points
  ! blank output map
  do jb=1,ny
    do ib=1,nx
      b(ib,jb) = bval
    enddo
  enddo
  !
  ! Gauss mode
  if (mode.eq.3) then
    ! Pre-compute the gaussian weights just once
    delta=float(nw)*float(nw)/(4*alog(2.0))
    write(6,*) 'Gaussian weights: '
    do i=1,100
      x=(i-1)*0.03*float(nw)
      x=x*x
      myexp(i)=exp(-1.0*x/delta)
      write (6,*) (i-1)*0.03,myexp(i)
    enddo
    isup=int(float(nw)/cvo(3))
    !
    count=0
    do jb=1,ny
      count = count+nx
      if (count.ge.32*1024) then   ! Say something, every 32 kpixels
        write(6,*) 'Interpolating background for row ',jb
        count = 0
      endif
      y0=float(jb)
      tmp  = (jb-cvo(5))/cvo(6)+cvo(4)
      j  = nint(tmp)
      jmin = max(1,j-isup)     !support de la fonction Gauss dans A
      jmax = min(my,j+isup)
      do ib=1,nx
        x0=float(ib)
        tmp  = (ib-cvo(2))/cvo(3)+cvo(1)
        i  = nint(tmp)
        imin = max(1,i-isup)
        imax = min(mx,i+isup)
        value=0.0
        weight=0.0
        do jbb=jmin,jmax
          do ibb=imin,imax
            z=a(ibb,jbb,1)
            if (z.ne.bval) then
              x=a(ibb,jbb,2)
              y=a(ibb,jbb,3)
              dx=(x-x0)/float(nw)
              dy=(y-y0)/float(nw)
              dist=dx*dx+dy*dy
              nexp= nint(100.0*dist)+1
              if (nexp.le.mexp) then
                tmp=myexp(nexp)
                value=value+z*tmp
                weight=weight+tmp
              endif
            endif
          enddo
        enddo
        if (weight.gt.0.0) then
          b(ib,jb)=value/weight
        else
          b(ib,jb)=bval
        endif
      enddo
    enddo
  elseif (mode.eq.0) then
    tmp  = (1-cvo(1))*cvo(3)+cvo(2)
    imin = nint(tmp)
    tmp  = (mx-cvo(1))*cvo(3)+cvo(2)
    imax = nint(tmp)
    tmp  = (1-cvo(4))*cvo(6)+cvo(5)
    jmin = nint(tmp)
    tmp  = (my-cvo(4))*cvo(6)+cvo(5)
    jmax = nint(tmp)
    do jb = jmin,jmax
      do ib = imin,imax
        tmp  = (ib-cvo(2))/cvo(3)+cvo(1)
        i  = nint(tmp)
        tmp  = (jb-cvo(5))/cvo(6)+cvo(4)
        j  = nint(tmp)
        b(ib,jb) = a(i,j,1)
      enddo
    enddo
  elseif (mode.eq.1) then
    tmp  = (1-cvo(1))*cvo(3)+cvo(2)
    imin = nint(tmp)
    tmp  = (mx-1-cvo(1))*cvo(3)+cvo(2)
    imax = nint(tmp)
    tmp  = (1-cvo(4))*cvo(6)+cvo(5)
    jmin = nint(tmp)
    tmp  = (my-1-cvo(4))*cvo(6)+cvo(5)
    jmax = nint(tmp)
    do jb = jmin,jmax
      do ib = imin,imax
        tmp  = (ib-cvo(2))/cvo(3)+cvo(1)
        i  = nint(tmp)
        tmp  = (jb-cvo(5))/cvo(6)+cvo(4)
        j  = nint(tmp)
        xa = (i-cvo(1))*cvo(3)+cvo(2)
        ya = (j-cvo(4))*cvo(6)+cvo(5)
        ia = nint(xa)
        ja = nint(ya)
        xr = (float(ib)-float(ia))/cvo(3)+0.5
        yr = (float(jb)-float(ja))/cvo(6)+0.5
        if (a(i,j,1).eq.bval) then
          b(ib,jb) = bval
        elseif (a(i+1,j,1).eq.bval) then
          b(ib,jb) = bval
        elseif (a(i,j+1,1).eq.bval) then
          b(ib,jb) = bval
        elseif (a(i+1,j+1,1).eq.bval) then
          b(ib,jb) = bval
        else
          b(ib,jb) = (1-xr)*(1-yr)*a(i,j,1)+   &
     &            xr*(1-yr)*a(i+1,j,1)+   &
     &            xr*yr*a(i+1,j+1,1)+   &
     &            (1-xr)*yr*a(i,j+1,1)
        endif
      enddo
    enddo
  elseif (mode.eq.2) then
    tmp  = (2-cvo(1))*cvo(3)+cvo(2)
    imin = nint(tmp)
    tmp  = (mx-1-cvo(1))*cvo(3)+cvo(2)
    imax = nint(tmp)
    tmp  = (2-cvo(4))*cvo(6)+cvo(5)
    jmin = nint(tmp)
    tmp  = (my-1-cvo(4))*cvo(6)+cvo(5)
    jmax = nint(tmp)
    do jb = jmin,jmax
      do ib = imin,imax
        tmp  = (ib-cvo(2))/cvo(3)+cvo(1)
        i  = nint(tmp)
        tmp  = (jb-cvo(5))/cvo(6)+cvo(4)
        j  = nint(tmp)
        xa = (i-cvo(1))*cvo(3)+cvo(2)
        ya = (j-cvo(4))*cvo(6)+cvo(5)
        ia = nint(xa)
        ja = nint(ya)
        xr = (float(ib)-float(ia))/cvo(3)+0.5
        yr = (float(jb)-float(ja))/cvo(6)+0.5
        if (a(i-1,j-1,1).eq.bval) then
          b(ib,jb) = bval
        elseif (a(i,j-1,1).eq.bval) then
          b(ib,jb) = bval
        elseif (a(i+1,j-1,1).eq.bval) then
          b(ib,jb) = bval
        elseif (a(i-1,j,1).eq.bval) then
          b(ib,jb) = bval
        elseif (a(i,j,1).eq.bval) then
          b(ib,jb) = bval
        elseif (a(i+1,j,1).eq.bval) then
          b(ib,jb) = bval
        elseif (a(i-1,j+1,1).eq.bval) then
          b(ib,jb) = bval
        elseif (a(i,j+1,1).eq.bval) then
          b(ib,jb) = bval
        elseif (a(i+1,j+1,1).eq.bval) then
          b(ib,jb) = bval
        else
          !
          ! Interpolate (XR or YR first, does not matter in this case)
          aplus = xr*(xr-1)*a(i-1,j+1,1)*0.5+   &
     &            xr*(xr+1)*a(i+1,j+1,1)*0.5-   &
     &            (xr+1)*(xr-1)*a(i,j+1,1)
          azero = xr*(xr-1)*a(i-1,j,1)*0.5+   &
     &            xr*(xr+1)*a(i+1,j,1)*0.5-   &
     &            (xr+1)*(xr-1)*a(i,j,1)
          amoin = xr*(xr-1)*a(i-1,j-1,1)*0.5+   &
     &            xr*(xr+1)*a(i+1,j-1,1)*0.5-   &
     &            (xr+1)*(xr-1)*a(i,j-1,1)
          !     Then YR (or XR)
          b(ib,jb) = yr*(yr-1)*amoin*0.5+   &
     &            yr*(yr+1)*aplus*0.5-   &
     &            (yr+1)*(yr-1)*azero
        endif
      enddo
    enddo
  endif
end subroutine zodi003
!
subroutine zodi011(a,nx,ny,nz,nt,scale,nw,bval,eval,   &
     &    pmin,pmax,pinc,histo,x,y,z,w,iw,b)
  !---------------------------------------------------------------------
  ! Compute a large scale background, SLOW METHOD
  !
  ! Arguments:
  !	A	R*4	Input data cube				Input
  !	NX	I	First dimension of A			Input
  !	NY	I	Second dimension of A			Input
  !	NZ	I	Third dimension of A			Input
  !	NT	I	Minimum valid number of points 		Input
  !	SCALE	I	Scale factor for intermediate grid	Input
  !	NW	I	Diameter of smoothing circle		Input
  !	BVAL	R*4	Blanking value				Input
  !	EVAL	R*4	Tolerance on blanking value		Input
  !	PMIN	R*4	Minimum accepted value			Input
  !	PMAX	R*4	Maximum accepted value			Input
  !	PINC	R*4	Histogram step				Input
  !	HISTO	R*4	Histogram array				Scratch
  !	X	R*4	Work space				Scratch
  !	Y	R*4	Work space				Scratch
  !	Z	R*4	Work space				Scratch
  !	W	R*4	Work space				Scratch
  !	IW	R*4	Work space				Scratch
  !	B	R*4	Output background image			Output
  !---------------------------------------------------------------------
  integer :: nx                     !
  integer :: ny                     !
  integer :: nz                     !
  real(4) :: a(nx,ny,nz)             !
  integer :: nt                     !
  integer :: scale                  !
  integer :: nw                     !
  real(4) :: bval                    !
  real(4) :: eval                    !
  real(4) :: pmin                    !
  real(4) :: pmax                    !
  real(4) :: pinc                    !
  real(4) :: histo(*)                !
  real(4) :: x(*)                    !
  real(4) :: y(*)                    !
  real(4) :: z(*)                    !
  real(4) :: w(*)                    !
  real(4) :: iw(*)                   !
  real(4) :: b(nx,ny,nz)             !
  ! Local
  integer :: ier
  !
  integer mx,my,m,nh,i
  !
  ! Define the background map
  mx=int(float(nx-nw)/float(scale))+1
  my=int(float(ny-nw)/float(scale))+1
  nh = nint((pmax-pmin)/pinc)
  !
  ! Compute the background image
  m = mx*my
  do i=1,nz                    ! Loop on planes
    call zodi012(a(1,1,i),nx,ny,scale,nw,pmin,   &
     &      pmax,pinc,histo,nh,nt,   &
     &      x,y,z,mx,my,m)
    !
    ! Resample the image to the full Grid
    call zodi013(m,x,y,z,w,iw,b(1,1,i),nx,ny,bval,ier)
    if (ier.ne.0) return
    !
    ! Subtract the background from the image
    !         CALL ZODI004 (A,B,NX,NY,BVAL,EVAL)
  enddo
end subroutine zodi011
!
subroutine zodi012(a,nx,ny,ns,nw,pmin,pmax,pinc,h,nh,nt,   &
     &    x,y,z,mx,my,m)
  use back_conversion
  !---------------------------------------------------------------------
  ! Estimate large scale background on reduced grid
  !
  ! Arguments:
  !	A	R*4	Input data cube				Input
  !	NX	I	First dimension of A			Input
  !	NY	I	Second dimension of A			Input
  !	NS	I	Scale factor for intermediate grid	Input
  !	NW	I	Diameter of smoothing circle		Input
  !	PMIN	R*4	Minimum accepted value			Input
  !	PMAX	R*4	Maximum accepted value			Input
  !	PINC	R*4	Histogram step				Input
  !	H	R*4	Histogram array				Scratch
  !	NH	I	Size of histogram			Input
  !	NT	I	Minimum valid number of points 		Input
  !	BVAL	R*4	Blanking value				Input
  !	EVAL	R*4	Tolerance on blanking value		Input
  !	X	R*4	X coordinate for reduced grid		Output
  !	Y	R*4	Y coordinate for reduced grid		Output
  !	Z	R*4	Background value on reduced grid	Output
  !	MX	I	First dimension of submap		Input
  !	MY	I	Second dimension of submap		Input
  !	M	I	Number of valid points in reduced grid	Output
  !---------------------------------------------------------------------
  integer :: nx                     !
  integer :: ny                     !
  real(4) :: a(nx,ny)                !
  integer :: ns                     !
  integer :: nw                     !
  real(4) :: pmin                    !
  real(4) :: pmax                    !
  real(4) :: pinc                    !
  integer :: nh                     !
  real(4) :: h(nh)                   !
  integer :: nt                     !
  real(4) :: x(*)                    !
  real(4) :: y(*)                    !
  real(4) :: z(*)                    !
  integer :: mx                     !
  integer :: my                     !
  integer :: m                      !
  ! Local
  real(4) :: ja,ia
  !
  real r,grav(2)
  integer i,j,nf,k,ier
  !
  k = 0
  do j = 1,my
    ja = (j-cvo(4))*cvo(6)+cvo(5)
    do i = 1,mx
      ia = (i-cvo(1))*cvo(3)+cvo(2)
      call zodi102(a,nx,ny,ia,ja,pmin,pmax,pinc,   &
     &        h,nh,nw,nf)
      if (nf.gt.nt) then
        call zodi122(h,nh,r,pmin,pinc)
        call zodi123(a,nx,ny,ia,ja,nw,pinc,r,grav,ier)
        if (ier.eq.0) then
          k    = k+1
          z(k) = r
          x(k) = grav(1)
          y(k) = grav(2)
        endif
      endif
    enddo
  enddo
  write(6,*) k,' intermediate background values found'
  if (k.gt.0) call zodi124(k,x,y,z)
  m = k
  write(6,*) m,' unredondant (valid) background values found'
  do j=1,m
    write(1,*) x(j),y(j),1.0,z(j)
  enddo
end subroutine zodi012
!
subroutine zodi124(n,x,y,z)
  !---------------------------------------------------------------------
  !     ensures no two entries have the same coordinates (arises when
  !     background is estimated on areas greater than the mesh width)
  !---------------------------------------------------------------------
  integer :: n                      !
  real :: x(*)                      !
  real :: y(*)                      !
  real :: z(*)                      !
  ! Local
  integer :: i,k,good
  !
  good=1
  do i=2,n
    do k=1,good
      if (x(i).eq.x(k).and.y(i).eq.y(k)) goto 1
    enddo
    good=good+1
    x(good)=x(i)
    y(good)=y(i)
    z(good)=z(i)
1   continue
  enddo
  n=good
  return
end subroutine zodi124
!
subroutine zodi102 (a,nx,ny,ia,ja,pmin,pmax,pinc,h,nh,nw,nf)
  use back_conversion
  !---------------------------------------------------------------------
  ! Determine an histogram for map values in a disk around the
  ! specified point.
  !
  ! Arguments:
  !	A	R*4	Input data cube				Input
  !	NX	I	First dimension of A			Input
  !	NY	I	Second dimension of A			Input
  !	IA	R*4	First coordinate of specified point	Input
  !	JA	R*4	Second coordinate of specified point	Input
  !	PMIN	R*4	Minimum accepted value			Input
  !	PMAX	R*4	Maximum accepted value			Input
  !	PINC	R*4	Histogram step				Input
  !	H	R*4	Histogram array				Output
  !	NH	I	Size of histogram			Input
  !	NW	I	Diameter of smoothing circle		Input
  !	NF	I	Number of valid data points		Output
  !---------------------------------------------------------------------
  integer :: nx                     !
  integer :: ny                     !
  real(4) :: a(nx,ny)                !
  real(4) :: ia                      !
  real(4) :: ja                      !
  real(4) :: pmin                    !
  real(4) :: pmax                    !
  real(4) :: pinc                    !
  integer :: nh                     !
  real(4) :: h(nh)                   !
  integer :: nw                     !
  integer :: nf                     !
  ! Local
  integer :: i,j,k,imin,imax,jmin,jmax
  real :: r
  !
  ! Zero Histogram
  do i = 1,nh
    h(i) = 0.0
  enddo
  nf = 0
  !
  ! Build it
  jmin = max(1,int(ja-0.5*nw)+1)
  jmax = min(ny,int(ja+0.5*nw)-1)
  imin = max(1,int(ia-0.5*nw)+1)
  imax = min(nx,int(ia+0.5*nw)-1)
  do j = jmin,jmax
    do i = imin,imax
      r = a(i,j)
      if (r.ge.pmin .and. r.lt.pmax) then
        k = int((r-pmin)/pinc)+1
        h(k) = h(k)+1.0
        nf = nf+1
      endif
    enddo
  enddo
end subroutine zodi102
!
subroutine zodi122 (h,nh,r,pmin,pinc)
  !---------------------------------------------------------------------
  ! Determine maximum in an histogram.
  !
  ! Arguments:
  !	H	R*4	Histogram array				Input
  !	NH	I	Size of histogram			Input
  !	R	R*4	Coordinate of histogram maximum		Output
  !	PMIN	R*4	Minimum accepted value			Input
  !	PMAX	R*4	Maximum accepted value			Input
  !	PINC	R*4	Histogram step				Input
  !	NW	I	Radius of smoothing circle		Input
  !---------------------------------------------------------------------
  integer :: nh                     !
  real :: h(nh)                     !
  real :: r                         !
  real :: pmin                      !
  real :: pinc                      !
  ! Local
  integer :: i,n
  real :: t
  !
  t = h(1)
  n = 1
  do i=2,nh
    if (h(i).gt.t) then
      n = i
      t = h(i)
    endif
  enddo
  r = pmin+(n-0.5)*pinc
end subroutine zodi122
!
subroutine zodi123(a,nx,ny,ia,ja,nw,pinc,r,grav,ier)
  use back_conversion
  !---------------------------------------------------------------------
  ! Determine the center of gravity of pixels belonging to the histogram
  ! bin of value R (width PINC) in map A, inside circle of diameter
  ! NW centered at IA JA
  !
  ! Arguments:
  !	A	R*4	Input data cube				Input
  !	NX	I	First dimension of A			Input
  !	NY	I	Second dimension of A			Input
  !	IA	R*4	First coordinate of specified point	Input
  !	JA	R*4	Second coordinate of specified point	Input
  !	NW	I	Diameter of smoothing circle		Input
  !	PINC	R*4	Histogram step				Input
  !	R	R*4	Coordinate of histogram maximum		Output
  !	GRAV(2)	R*4	gravity center coordinates		Output
  !	IER	I	Logical error flag			Output
  !---------------------------------------------------------------------
  integer :: nx                     !
  integer :: ny                     !
  real(4) :: a(nx,ny)                !
  real(4) :: ia                      !
  real(4) :: ja                      !
  integer :: nw                     !
  real(4) :: pinc                    !
  real(4) :: r                       !
  real(4) :: grav(2)                 !
  integer :: ier                    !
  ! Local
  integer :: i,j,imin,imax,jmin,jmax,ngrav
  real(4) :: rmin,rmax
  !
  ! Zero
  grav(1)=0
  grav(2)=0
  ngrav=0
  ! Build it
  jmin = max(1,int(ja-0.5*nw)+1)
  jmax = min(ny,int(ja+0.5*nw)-1)
  imin = max(1,int(ia-0.5*nw)+1)
  imax = min(nx,int(ia+0.5*nw)-1)
  rmin=r-pinc*0.5
  rmax=rmin+pinc
  do j = jmin,jmax
    do i = imin,imax
      if (a(i,j).ge.rmin .and. a(i,j).le.rmax) then
        grav(1)=grav(1)+float(i)
        grav(2)=grav(2)+float(j)
        ngrav=ngrav+1
      endif
    enddo
  enddo
  if (ngrav.gt.0) then
    grav(1)=grav(1)/ngrav
    grav(2)=grav(2)/ngrav
    ier=0
    return
  endif
  ier=1
end subroutine zodi123
!
subroutine zodi013(m,x,y,z,w,iw,b,nx,ny,bval,ier)
  integer :: m                      !
  real :: x(*)                      !
  real :: y(*)                      !
  real :: z(*)                      !
  real :: w(*)                      !
  real :: iw(*)                     !
  integer :: nx                     !
  integer :: ny                     !
  real :: b(nx,ny)                  !
  real :: bval                      !
  integer :: ier                    !
  ! Local
  integer :: ncp
  logical :: logran(7), error
  external :: dumf
  data logran /7*.false./, ncp/4/
  !
  call gridini(nx,1.d0,1.d0,1.d0, ny,1.d0,1.d0,1.d0)
  call gridset(ncp,bval,logran)
  call gridran(x,y,z,m,w,iw,b,dumf,dumf,dumf,error)
  if (error) ier = 10
end subroutine zodi013
!
subroutine dumf
end subroutine dumf
!
subroutine zodi004 (a,b,nx,ny,bval,eval)
  integer :: nx                     !
  integer :: ny                     !
  real :: a(nx,ny)                  !
  real :: b(nx,ny)                  !
  real :: bval                      !
  real :: eval                      !
  ! Local
  integer :: i,j
  !
  do j=1,ny
    do i=1,nx
      if (abs(a(i,j)-bval).gt.eval .and.   &
     &        abs(b(i,j)-bval).gt.eval) then
        b(i,j) = a(i,j) - b(i,j)
      else
        b(i,j) = bval
      endif
    enddo
  enddo
end subroutine zodi004
