program gauss_smooth
  use gildas_def
  use gbl_format
  use phys_const
  use image_def
  use gbl_message
  use gkernel_interfaces
  !---------------------------------------------------------------------
  !   Main program for 2D smoothing in fourier plane by an elliptical
  ! gaussian.
  !   First 2 dimensions (in pixels) should be powers of two, but the
  ! map doesn't need to be square. Map is plunged into a factor 2
  ! larger image to avoid aliasing.
  !---------------------------------------------------------------------
  character(len=*), parameter :: pname = 'GAUSS_SMOOTH'
  character(len=filename_length) :: namex,namey
  logical :: error
  real(kind=8) :: bmaj,bmin,pa
  real(kind=4) :: bmaj4,bmin4,pa4
  integer(kind=4) :: i, j, nx, ny, nxy, ndim, dim(2), mx, my, ier
  complex(kind=4), allocatable :: cdata(:,:)
  real(kind=4), allocatable :: rdata(:,:), work(:)
  type(gildas) :: x,y
  character(len=message_length) :: mess
  !
  call gildas_open
  call gildas_char('Y_NAME$',namey)
  call gildas_char('X_NAME$',namex)
  call gildas_dble('MAJOR$',bmaj,1)
  call gildas_dble('MINOR$',bmin,1)
  call gildas_dble('PA$',pa,1)
  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
  !
  ! Prepare the output header
  call gildas_null(x)
  call gdf_copy_header(y,x,error)
  x%gil%extr_words = 0  ! Disable extrema section
  !
  ! Resolution section if present
  if (x%gil%reso_words.gt.0) then
    bmaj4 = bmaj
    bmin4 = bmin
    pa4 = pa*rad_per_deg
    call gdf_gauss2d_convolution(x,bmaj4,bmin4,pa4,error)
    if (error)  goto 99
    write(mess,'(A,3(1PG14.7,A))')  &
      'I-'//pname//', Smoothed beam is ', &
      x%gil%majo*sec_per_rad,' x ',  &
      x%gil%mino*sec_per_rad,' sec (PA ', &
      x%gil%posa*deg_per_rad,' deg)'
    call gagout(mess)
    !
  endif
  !
  ! Create output image
  call sic_parsef(namex,x%file,' ','.gdf')
  call gdf_create_image (x,error)
  if (error) then
    call gagout ('F-'//pname//',  Cannot create output image')
    goto 100
  endif
  !
  mx = x%gil%dim(1)
  my = x%gil%dim(2)
  !
  nx = 2*mx
  ny = 2*my
  ndim = 2
  dim(1) = nx
  dim(2) = ny
  nxy = nx * ny 
  allocate (work(2*max(nx,ny)), cdata(nx, ny), rdata(mx,my), stat=ier)
  if (ier.ne.0) goto 99
  !
  call fourt_plan (cdata,dim,ndim,1,0)
  call fourt_plan (cdata,dim,ndim,-1,1)
  do j=1,x%gil%dim(4)
    x%blc(4) = j
    x%trc(4) = j
    do i=1,x%gil%dim(3)
      x%blc(3) = i
      x%trc(3) = i
      y%blc = x%blc
      y%trc = x%trc
      call gdf_read_data(y,rdata,error)
      !
      call copyc (mx,my,rdata,nx,ny,cdata)
      call fourt (cdata,dim,ndim,1,0,work)
      call mulgau(cdata,nx,ny,   &
     &        bmaj,bmin,pa,x%gil%inc(1),x%gil%inc(2))
      call fourt (cdata,dim,ndim,-1,+1,work)
      !
      call copyn (nx,ny,cdata,mx,my,rdata)
      call gdf_write_data (x,rdata,error)
    enddo
  enddo
  call gagout ('S-'//pname//',  Successful completion')
  call sysexi (1)
  !
99 call gagout ('F-'//pname//',  Lost my mind')
100 call sysexi (fatale)
end program gauss_smooth
!
subroutine copyc(mx,my,r,nx,ny,c)
  !---------------------------------------------------------------------
  !     Insert Real array R(NX,NY) into Complex array C(MX,MY)
  !---------------------------------------------------------------------
  integer :: mx                     !
  integer :: my                     !
  real :: r(mx,my)                  !
  integer :: nx                     !
  integer :: ny                     !
  complex :: c(nx,ny)                !
  ! Local
  integer :: i,j,i0,j0
  !
  c = 0.0
  !
  i0 = nx/2-mx/2
  j0 = ny/2-my/2
  !
  do j=1,my
    do i=1,mx
      c(i+i0,j+j0) = r(i,j)
    enddo
  enddo
end subroutine copyc
!
subroutine copyn(nx,ny,c,mx,my,r)
  !---------------------------------------------------------------------
  !     Copy and normalize the result
  !     Extract Real array R(NX,NY) from Complex array C(MX,MY)
  !---------------------------------------------------------------------
  integer :: nx                     !
  integer :: ny                     !
  complex :: c(nx,ny)               !
  integer :: mx                     !
  integer :: my                     !
  real :: r(mx,my)                  !
  ! Local
  integer :: i,j,i0,j0
  real :: w
  !
  i0 = nx/2-mx/2
  j0 = ny/2-my/2
  !
  w = 1.0/(nx*ny)
  do j=1,my
    do i=1,mx
      r(i,j) = real(c(i+i0,j+j0)) * w
    enddo
  enddo
end subroutine copyn
!
subroutine mulgau(data,nx,ny,bmaj,bmin,pa,x_inc1,x_inc2)
  !---------------------------------------------------------------------
  ! GDF   Multiply the TF of an image by the TF of
  !       a convolving gaussian function. BMAJ and BMIN are the
  !       widths of the original gaussian. PA is the position angle of major
  !       axis (from north towards east)
  !---------------------------------------------------------------------
  integer :: nx                     !
  integer :: ny                     !
  complex :: data(nx,ny)            !
  real*8 :: bmaj                    !
  real*8 :: bmin                    !
  real*8 :: pa                      !
  real*8 :: x_inc1                  !
  real*8 :: x_inc2                  !
  ! Local
  integer :: i,j,nx1,nx2
  real :: amaj,amin,fact,cx,cy,sx,sy
  logical :: norot,rot90
  real*8 :: pi,rpa
  parameter (pi=3.141592653589793d0)
  real*4 :: eps
  parameter (eps=1.e-7)
  !
  norot = ( abs(mod(pa,180.d0)).le.eps)
  rot90 = ( abs(mod(pa,180.d0)-90.d0).le.eps)
  amaj = bmaj*pi/(2.*sqrt(log(2.)))
  amin = bmin*pi/(2.*sqrt(log(2.)))
  rpa = pa*pi/180.d0
  !
  cx = cos(rpa)/nx*amin
  cy = cos(rpa)/ny*amaj
  sx = sin(rpa)/nx*amaj
  sy = sin(rpa)/ny*amin
  !
  ! Convert map units to pixels
  cx = cx / x_inc1
  cy = cy / x_inc2
  sx = sx / x_inc1
  sy = sy / x_inc2
  nx2 = nx/2
  nx1 = nx2+1
  !
  ! Optimised code for Position Angle 0 degrees
  if (norot) then
    do j=1,ny/2
      do i=1,nx2
        fact = (float(j-1)*cy)**2 + (float(i-1)*cx)**2
        if (fact.lt.80.) then
          fact = exp (-fact)
          data(i,j) = data(i,j)*fact
        else
          data(i,j) = 0.
        endif
      enddo
      do i=nx1,nx
        fact = (float(j-1)*cy)**2 + (float(i-nx-1)*cx)**2
        if (fact.lt.80.) then
          fact = exp (-fact)
          data(i,j) = data(i,j)*fact
        else
          data(i,j) = 0.
        endif
      enddo
    enddo
    do j=ny/2+1,ny
      do i=1,nx2
        fact = (float(j-ny-1)*cy)**2 + (float(i-1)*cx)**2
        if (fact.lt.80.) then
          fact = exp (-fact)
          data(i,j) = data(i,j)*fact
        else
          data(i,j) = 0.
        endif
      enddo
      do i=nx1,nx
        fact = (float(j-ny-1)*cy)**2 + (float(i-nx-1)*cx)**2
        if (fact.lt.80.) then
          fact = exp (-fact)
          data(i,j) = data(i,j)*fact
        else
          data(i,j) = 0.
        endif
      enddo
    enddo
    !
    ! Optimised code for Position Angle 90 degrees
  elseif (rot90) then
    do j=1,ny/2
      do i=1,nx2
        fact = (float(i-1)*sx)**2 +(float(j-1)*sy)**2
        if (fact.lt.80.) then
          fact = exp (-fact)
          data(i,j) = data(i,j)*fact
        else
          data(i,j) = 0.
        endif
      enddo
      do i=nx1,nx
        fact = (float(i-nx-1)*sx)**2 + (float(j-1)*sy)**2
        if (fact.lt.80.) then
          fact = exp (-fact)
          data(i,j) = data(i,j)*fact
        else
          data(i,j) = 0.
        endif
      enddo
    enddo
    do j=ny/2+1,ny
      do i=1,nx2
        fact = (float(i-1)*sx)**2 + (float(j-ny-1)*sy)**2
        if (fact.lt.80.) then
          fact = exp (-fact)
          data(i,j) = data(i,j)*fact
        else
          data(i,j) = 0.
        endif
      enddo
      do i=nx1,nx
        fact = (float(i-nx-1)*sx)**2 + (float(j-ny-1)*sy)**2
        if (fact.lt.80.) then
          fact = exp (-fact)
          data(i,j) = data(i,j)*fact
        else
          data(i,j) = 0.
        endif
      enddo
    enddo
    !
    ! General case of a rotated elliptical gaussian
  else
    do j=1,ny/2
      do i=1,nx2
        fact = (float(i-1)*sx + float(j-1)*cy)**2 +   &
     &          (-float(i-1)*cx + float(j-1)*sy)**2
        if (fact.lt.80.) then
          fact = exp (-fact)
          data(i,j) = data(i,j)*fact
        else
          data(i,j) = 0.
        endif
      enddo
      do i=nx1,nx
        fact = (float(i-nx-1)*sx + float(j-1)*cy)**2 +   &
     &          ( -float(i-nx-1)*cx + float(j-1)*sy)**2
        if (fact.lt.80.) then
          fact = exp (-fact)
          data(i,j) = data(i,j)*fact
        else
          data(i,j) = 0.
        endif
      enddo
    enddo
    do j=ny/2+1,ny
      do i=1,nx2
        fact = (float(i-1)*sx + float(j-ny-1)*cy)**2 +   &
     &          ( -float(i-1)*cx + float(j-ny-1)*sy)**2
        if (fact.lt.80.) then
          fact = exp (-fact)
          data(i,j) = data(i,j)*fact
        else
          data(i,j) = 0.
        endif
      enddo
      do i=nx1,nx
        fact = (float(i-nx-1)*sx   &
     &          + float(j-ny-1)*cy)**2 +   &
     &          ( -float(i-nx-1)*cx + float(j-ny-1)*sy)**2
        if (fact.lt.80.) then
          fact = exp (-fact)
          data(i,j) = data(i,j)*fact
        else
          data(i,j) = 0.
        endif
      enddo
    enddo
  endif
end subroutine mulgau
