program gauss_compress
  use gildas_def
  use image_def
  use gkernel_interfaces
  use gbl_format
  !---------------------------------------------------------------------
  ! GILDAS
  !	COMPRESS a data cube along its TWO first dimensions, by Fourier
  !     Transform
  !---------------------------------------------------------------------
  ! Local
  real, parameter :: eps = 2.e-7
  !
  character(len=filename_length) :: namex,namey
  integer :: i,j,ier,n,nx,ny,lx,ly,mx,my,sx,sy,nexp
  real :: rexp
  real(8) :: bmaj,bmin,pa
  logical :: error
  integer :: ndim,dim(2)
  real, allocatable :: ipi(:,:), ipj(:,:)
  complex, allocatable :: ips(:,:), ipl(:,:) 
  real, allocatable :: work(:)
  type(gildas) :: x,y
  !
  call gildas_open
  call gildas_char('INPUT_MAP$',namey)
  call gildas_char('OUTPUT_MAP$',namex)
  call gildas_inte('COMPRESS$',nexp,1)
  call gildas_dble('MAJOR$',bmaj,1)
  call gildas_dble('MINOR$',bmin,1)
  call gildas_dble('PA$',pa,1)
  call gildas_close
  !
  if (nexp.lt.2. .or. nexp.gt.128) then
    write(6,*) 'E-GAUSS_COMPRESS,  Invalid compression ',nexp
    goto 100
  endif
  !
  n = len_trim(namey)
  if (n.eq.0) goto 100
  y%gil%ndim = 4
  y%gil%form = fmt_r4
  call gdf_read_gildas(y,namey(1:n),'.lmv',error, rank=4, data=.false.)
  if (error) then
    write(6,*) 'F-GAUSS_COMPRESS,  Cannot read input file'
    goto 100
  endif
  !
  call gildas_null(x)
  call gdf_copy_header(y,x,error)
  !
  nx = y%gil%dim(1)
  ny = y%gil%dim(2)
  lx = 2*nx
  ly = 2*ny
  !
  ! Get work space
  rexp = nexp
  sx = nint(float(y%gil%dim(1))/rexp)
  sy = nint(float(y%gil%dim(2))/rexp)
  rexp = max( float(y%gil%dim(1))/float(sx) , float(y%gil%dim(2))/float(sy))
  x%gil%dim(1) = nint(y%gil%dim(1)/rexp)
  x%gil%dim(2) = nint(y%gil%dim(2)/rexp)
  mx = x%gil%dim(1)
  my = x%gil%dim(2)
  sx = 2*mx
  sy = 2*my
  !
  allocate(ips(sx,sy), ipj(sx,sy), ipi(lx,ly), ipl(lx,ly), work(2*max(lx,ly)), stat=ier)
  if (ier.ne.0) goto 100
  allocate(x%r2d(mx,my), y%r2d(nx,ny), stat=ier)
  if (ier.ne.0) goto 100
  !
  ! Transform coordinates (1,1) ---> (1,1)
  x%gil%inc(1:2) = y%gil%inc(1:2)*float(y%gil%dim(1:2))/float(x%gil%dim(1:2))
  x%gil%ref(1:2) = 1.0d0
  x%gil%val(1:2) = (1.0d0-y%gil%ref(1:2))*y%gil%inc(1:2)+y%gil%val(1:2)
  !
  ! Transform back
  x%gil%ref(1:2) = (y%gil%val(1:2) - x%gil%val(1:2)) / x%gil%inc(1:2) + x%gil%ref(1:2)
  x%gil%val(1:2) = y%gil%val(1:2)
  !
  ! Create Output file
  n = len_trim(namex)
  if (n.eq.0) goto 100
  call sic_parsef(namex(1:n),x%file,' ','.gdf')
  x%gil%extr_words = 0                   ! No extrema
  !
  ! Squeezee dummy trailing dimensions
  do i=4,1,-1
    if (x%gil%dim(i).le.1) then
      x%gil%ndim = i-1
    else
      exit
    endif
  enddo
  !
  call gdf_create_image(x,error)
  if (error) then
    write(6,*) 'F-GAUSS_COMPRESS,  Cannot create output image'
    goto 100
  endif
  !
  ! Setup FFTW
  ndim = 2
  dim(1) = lx
  dim(2) = ly
  call fourt_plan(ipl,dim,ndim,1,0)
  dim(1) = sx
  dim(2) = sy
  call fourt_plan(ips,dim,ndim,-1,1)
  !
  ! Now loop over planes
  do j=1,y%gil%dim(4)
    y%blc(4) = j
    y%trc(4) = j
    do i=1,y%gil%dim(3)
      y%blc(3) = i
      y%trc(3) = i
      x%blc = y%blc
      x%trc = y%trc
      call gdf_read_data(y,y%r2d,error)
      call copyr (nx,ny,y%r2d,lx,ly,ipi)
      call compress_gauss (   &
     &      lx,ly,ipi,ipl,   &
     &      sx,sy,ipj,ips,   &
     &      work,bmaj,bmin,pa,x%gil%inc(1),x%gil%inc(2) )
      call copys (sx,sy,ipj,mx,my,x%r2d)
      call gdf_write_data(x,x%r2d,error)
    enddo
  enddo
  !
  call gagout('S-GAUSS_COMPRESS,  Successful completion')
  call sysexi (1)
100 call sysexi (fatale)
end program gauss_compress
!
subroutine compress_gauss(nx,ny,large,wl,mx,my,small,ws,work,   &
     &    bmaj,bmin,pa,incx,incy)
  use gkernel_interfaces
  !---------------------------------------------------------------------
  !	Compress an image through FT truncation
  !---------------------------------------------------------------------
  integer :: nx                     !
  integer :: ny                     !
  real :: large(nx,ny)              !
  complex :: wl(nx,ny)              !
  integer :: mx                     !
  integer :: my                     !
  real :: small(mx,my)              !
  complex :: ws(mx,my)              !
  real :: work(*)                   !
  real(8) :: bmaj                    !
  real(8) :: bmin                    !
  real(8) :: pa                      !
  real(8) :: incx                    !
  real(8) :: incy                    !
  ! Local
  integer :: j,ndim,dim(2)
  real :: fact
  !
  wl = cmplx(large,0.0)
  !
  ndim = 2
  dim(1) = nx
  dim(2) = ny
  call fourt(wl,dim,ndim,1,0,work)
  !
  ! Keep inner area
  do j=1,my/2
    call r4tor4 (wl(1,j),ws(1,j),mx)
    call r4tor4 (wl(1+nx-mx/2,j),ws(mx/2+1,j),mx)
  enddo
  do j=my/2+1,my
    call r4tor4 (wl(1,j+ny-my),ws(1,j),mx)
    call r4tor4 (wl(1+nx-mx/2,j+ny-my),ws(mx/2+1,j),mx)
  enddo
  !
  ! Gaussian Smoothing
  call mulgau(ws,mx,my,bmaj,bmin,pa,incx,incy)
  !
  ! Transform back
  dim(1) = mx
  dim(2) = my
  call fourt (ws,dim,ndim,-1,1,work)
  fact = 1.0/(nx*ny)
  small = real(ws)*fact
end subroutine compress_gauss
!
subroutine copyr(mx,my,r,nx,ny,c)
  !---------------------------------------------------------------------
  !     Insert Real array R(NX,NY) into Real array C(MX,MY)
  !---------------------------------------------------------------------
  integer :: mx                     !
  integer :: my                     !
  real :: r(mx,my)                  !
  integer :: nx                     !
  integer :: ny                     !
  real :: 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 copyr
!
subroutine copys (mx,my,r,nx,ny,c)
  !---------------------------------------------------------------------
  !     Extract from Real array R(NX,NY) the Real array C(MX,MY)
  !---------------------------------------------------------------------
  integer :: mx                     !
  integer :: my                     !
  real :: r(mx,my)                  !
  integer :: nx                     !
  integer :: ny                     !
  real :: c(nx,ny)                  !
  ! Local
  integer :: i,j,i0,j0
  !
  i0 = mx/2-nx/2
  j0 = my/2-ny/2
  !
  do j=1,ny
    do i=1,nx
      c(i,j) = r(i+i0,j+j0)
    enddo
  enddo
end subroutine copys
!
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) :: rpa
  real(8), parameter :: pi=3.141592653589793d0
  real(4), 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
