program smooth
  use gildas_def
  use image_def
  use gkernel_interfaces
  use gbl_format
  ! Local
  character(len=*), parameter :: pname = 'SMOOTH'
  character(len=12) :: method
  character(len=filename_length) :: namex,namey
  logical :: error
  integer :: i ,j, ier
  real :: width,fact,weight(6),arr(2)
  real, allocatable :: work(:,:)
  type(gildas) :: x,y
  !
  call gildas_open
  call gildas_char('Y_NAME$',namey)
  call gildas_char('X_NAME$',namex)
  call gildas_real('BLANKING$',arr,2)
  !
  ! Initialise the table
  call gildas_char('METHOD$',method)
  if (method.eq.'HANNING') then
    weight(1) = 3.
    weight(2) = 2.
    weight(3) = 2.
    weight(4) = 1.
    weight(5) = 1.
    weight(6) = 1.
  elseif (method.eq.'GAUSS') then
    call gildas_real('WIDTH$',width,1)
    fact=-(1.665109/width)**2
    weight(1) = 1.
    weight(2) = exp(fact)
    weight(3) = exp(2.*fact)
    weight(4) = exp(4.*fact)
    weight(5) = exp(5.*fact)
    weight(6) = exp(16.*fact)
  elseif (method.eq.'BOX') then
    weight(1) = 1.
    weight(2) = 1.
    weight(3) = 1.
    weight(4) = 1.
    weight(5) = 1.
    weight(6) = 1.
  elseif (method.eq.'USER') then
    call gildas_real('WEIGHT$',weight,6)
  else
    write(6,*) 'E-'//pname//', Unknown method '//method
    goto 100
  endif
  call gildas_close
  !
  call gildas_null(y)
  call gdf_read_gildas(y,namey,'.gdf',error,data=.false.)
  if (error) then
    call gagout ('F-'//pname//',  Cannot read input file')
    goto 100
  endif
  !
  call gildas_null(x)
  call gdf_copy_header(y,x,error)
  if (x%gil%blan_words.eq.0) then
    x%gil%blan_words = 2
    x%gil%bval = arr(1)
    x%gil%eval = arr(2)
  else
    if (x%gil%eval.ge.0.0) x%gil%eval = max(abs(x%gil%bval*1e-7),x%gil%eval)
  endif
  !
  ! Create output image
  call sic_parsef(namex,x%file,' ','.gdf')
  call gdf_create_image (x,error)
  if (error) then
    write(6,*) 'F-'//pname//',  Cannot create output image'
    goto 100
  endif
  !
  allocate ( work(x%gil%dim(1),x%gil%dim(2)), &
    &   x%r2d(x%gil%dim(1),x%gil%dim(2)), &
    &   y%r2d(x%gil%dim(1),x%gil%dim(2)), stat=ier)
  if (ier.ne.0) goto 100
  !
  do j=1,y%gil%dim(4)
    x%blc(4) = j
    x%trc(4) = j
    do i=1,y%gil%dim(3)
      x%blc(3) = i
      x%trc(3) = i
      y%blc = x%blc
      y%trc = x%trc
      call gdf_read_data(y,y%r2d,error)
      call smoo001 (y%r2d,   &                !Input image
     &        x%gil%dim(1),x%gil%dim(2),  &   !Size
     &        x%r2d,   &                      !Output image
     &        x%gil%bval,x%gil%eval,   &      !Blanking values
     &        weight,   &                     !Smoothing weights
     &        work)                           !Work space
      call gdf_write_data(x,x%r2d,error)
    enddo
  enddo
  call gagout ('S-'//pname//',  Successful completion')
  call sysexi (1)
  !
100 call sysexi (fatale)
end program smooth
!
subroutine smoo001(v,mi,mj,a,bval,eval,table,w)
  use gildas_def
  !---------------------------------------------------------------------
  ! 	Smoothing routine with blanking values
  ! Arguments
  !	A	R*4(*)	Smoothed array			Output
  !	MI	I	First dimension of arrays	Input
  !	MJ	I	Second dimension of arrays	Input
  !	V	R*4(*)	Original array			Input
  !	BVAL	R*4	Blanking value			Input
  !	EVAL	R*4	Tolerance on blanking		Input
  !	TABLE	R*4(6)	Smoothing coefficients		Input
  !	W	R*4(*)	Work array			*
  !---------------------------------------------------------------------
  integer(kind=index_length) :: mi                     !
  integer(kind=index_length) :: mj                     !
  real :: v(mi,mj)                  !
  real :: a(mi,mj)                  !
  real :: bval                      !
  real :: eval                      !
  real :: table(6)                  !
  real :: w(mi,mj)                  !
  ! Local
  integer :: i,j
  real :: x,sum,s00,s10,s11,s20,s21,s22
  real :: a00,a10,a11,a20,a21,a22
  !
  ! Load smoothing coefficients
  s00 = table(1)
  s10 = table(2)
  s11 = table(3)
  s20 = table(4)
  s21 = table(5)
  s22 = table(6)
  a00 = abs(s00)
  a10 = abs(s10)
  a11 = abs(s11)
  a20 = abs(s20)
  a21 = abs(s21)
  a22 = abs(s22)
  sum = a00 + 4.0*(a10+a11+a20+2.0*a21+a22)
  !
  ! Initialise arrays
  do j=1,mj
    do i=1,mi
      a(i,j) = 0.0
      w(i,j) = 0.0
    enddo
  enddo
  !
  ! Check for blanking first
  if (eval.ge.0.0) then
    !
    ! Slow method for blanked maps
    do j=3,mj-2
      do i=3,mi-2
        x = v(i,j)
        if (abs(x-bval).gt.eval) then
          ! Central pixel
          a(i,j) = a(i,j) + s00*x
          w(i,j) = w(i,j) + a00
          ! Second pixels
          a(i-1,j-1) = a(i-1,j-1) + s11*x
          a(i-1,j  ) = a(i-1,j )  + s10*x
          a(i-1,j+1) = a(i-1,j+1) + s11*x
          a(i  ,j-1) = a(i  ,j-1) + s10*x
          a(i  ,j+1) = a(i  ,j+1) + s10*x
          a(i+1,j-1) = a(i+1,j-1) + s11*x
          a(i+1,j  ) = a(i+1,j  ) + s10*x
          a(i+1,j+1) = a(i+1,j+1) + s11*x
          ! and weights
          w(i-1,j-1) = w(i-1,j-1) + a11
          w(i-1,j  ) = w(i-1,j  ) + a10
          w(i-1,j+1) = w(i-1,j+1) + a11
          w(i  ,j-1) = w(i  ,j-1) + a10
          w(i  ,j+1) = w(i  ,j+1) + a10
          w(i+1,j-1) = w(i+1,j-1) + a11
          w(i+1,j  ) = w(i+1,j  ) + a10
          w(i+1,j+1) = w(i+1,j+1) + a11
          !
          ! Third pixels
          a(i-2,j-2) = a(i-2,j-2)  + s22*x
          a(i-2,j-1) = a(i-2,j-1)  + s21*x
          a(i-2,j  ) = a(i-2,j  )  + s20*x
          a(i-2,j+1) = a(i-2,j+1)  + s21*x
          a(i-2,j+2) = a(i-2,j+2)  + s22*x
          a(i-1,j-2) = a(i-1,j-2)  + s21*x
          a(i-1,j+2) = a(i-1,j+2)  + s21*x
          a(i  ,j-2) = a(i  ,j-2)  + s20*x
          a(i  ,j+2) = a(i  ,j+2)  + s20*x
          a(i+1,j-2) = a(i+1,j-2)  + s21*x
          a(i+1,j+2) = a(i+1,j+2)  + s21*x
          a(i+2,j-2) = a(i+2,j-2)  + s22*x
          a(i+2,j-1) = a(i+2,j-1)  + s21*x
          a(i+2,j  ) = a(i+2,j  )  + s20*x
          a(i+2,j+1) = a(i+2,j+1)  + s21*x
          a(i+2,j+2) = a(i+2,j+2)  + s22*x
          !
          ! and weights
          w(i-2,j-2) = w(i-2,j-2)  + a22
          w(i-2,j-1) = w(i-2,j-1)  + a21
          w(i-2,j  ) = w(i-2,j  )  + a20
          w(i-2,j+1) = w(i-2,j+1)  + a21
          w(i-2,j+2) = w(i-2,j+2)  + a22
          w(i-1,j-2) = w(i-1,j-2)  + a21
          w(i-1,j+2) = w(i-1,j+2)  + a21
          w(i  ,j-2) = w(i  ,j-2)  + a20
          w(i  ,j+2) = w(i  ,j+2)  + a20
          w(i+1,j-2) = w(i+1,j-2)  + a21
          w(i+1,j+2) = w(i+1,j+2)  + a21
          w(i+2,j-2) = w(i+2,j-2)  + a22
          w(i+2,j-1) = w(i+2,j-1)  + a21
          w(i+2,j  ) = w(i+2,j  )  + a20
          w(i+2,j+1) = w(i+2,j+1)  + a21
          w(i+2,j+2) = w(i+2,j+2)  + a22
        endif
      enddo
    enddo
    !
    ! Set blanked pixels
    do j=1,mj
      do i=1,mi
        if (w(i,j).eq.0.0) then
          a(i,j) = bval
        else
          a(i,j) = a(i,j)/w(i,j)
        endif
      enddo
    enddo
    !
    ! Optimise for no blanking
  else
    !
    do j=3,mj-2
      do i=3,mi-2
        a(i,j) =   &
     &          s00 * v(i,j)   &
     &          + s11 * (v(i-1,j+1)+v(i+1,j+1)+v(i+1,j-1)+v(i-1,j-1))   &
     &          + s10 * (v(i,j+1)+v(i+1,j)+v(i-1,j)+v(i,j-1))   &
     &          + s22 * (v(i-2,j+2)+v(i+2,j+2)+v(i-2,j-2)+v(i+2,j-2))   &
     &          + s21 * (v(i-1,j+2)+v(i+1,j+2)+v(i+2,j+1)+v(i+2,j-1)   &
     &          +v(i+1,j-2)+v(i-1,j-2)+v(i-2,j-1)+v(i-2,j+1))   &
     &          + s20 * (v(i,j+2)+v(i+2,j)+v(i,j-2)+v(i-2,j))
        a(i,j) = a(i,j)/sum
      enddo
    enddo
    !
  endif
end subroutine smoo001
