!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
module cubemain_smooth
  use cube_types
  use cubetools_structure
  use cubetools_shape_types
  use cubetools_beam_types
  use cubeadm_cubeid_types
  use cubemain_messaging
  use cubemain_auxiliary
  use cubemain_spaelli_types
  !
  public :: smooth
  public :: cubemain_smooth_command
  private
  !
  integer(kind=code_k), parameter :: type_kern =  1
  integer(kind=code_k), parameter :: type_beam =  2
  integer(kind=code_k), parameter :: type_null = -1
  !
  type :: smooth_comm_t
     type(option_t), pointer :: comm
     type(ellipse_opt_t)     :: gauss
     type(beam_opt_t)        :: beam      
     type(option_t), pointer :: like
   contains
     procedure, public  :: register => cubemain_smooth_register
     procedure, private :: parse    => cubemain_smooth_parse
     procedure, private :: main     => cubemain_smooth_main
  end type smooth_comm_t
  type(smooth_comm_t) :: smooth
  !
  integer(kind=4), parameter :: icube = 1
  type smooth_user_t
     type(cubeid_user_t)    :: cubeids
     type(auxiliary_user_t) :: like
     type(beam_user_t)      :: beam               ! [beam,beam,pang] User beam
     type(ellipse_user_t)   :: gauss
   contains
     procedure, private :: toprog => cubemain_smooth_user_toprog
  end type smooth_user_t
  !
  type smooth_prog_t
     integer(kind=code_k)  :: type = type_null ! smoothing type
     integer(kind=pixe_k)  :: fftdim(2)        ! FFT dimensions
     type(shape_t)         :: n                ! Shape of input and output cube
     type(ellipse_prog_t)  :: kern             ! [rad] Smoothing kernel
     type(beam_t)          :: oubeam           ! Output beam
     type(cube_t), pointer :: cube             ! input cube
     type(cube_t), pointer :: smoothed         ! output cube
   contains
     procedure, private :: header          => cubemain_smooth_prog_header
     procedure, private :: data            => cubemain_smooth_prog_data
     procedure, private :: loop            => cubemain_smooth_prog_loop
     procedure, private :: act             => cubemain_smooth_prog_act
     !
     procedure, private :: beam_deconvolve => cubemain_smooth_prog_beam_deconvolve
     procedure, private :: beam_convolve   => cubemain_smooth_prog_beam_convolve
     procedure, private :: kernel_multiply => cubemain_smooth_prog_kernel_multiply
  end type smooth_prog_t
  !
contains
  !
  subroutine cubemain_smooth_command(line,error)
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    character(len=*), intent(in)    :: line
    logical,          intent(inout) :: error
    !
    type(smooth_user_t) :: user
    character(len=*), parameter :: rname='SMOOTH>COMMAND'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call smooth%parse(line,user,error)
    if (error) return
    call smooth%main(user,error)
    if (error) continue
  end subroutine cubemain_smooth_command
  !
  !----------------------------------------------------------------------
  !
  subroutine cubemain_smooth_register(smooth,error)
    use cubedag_allflags
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(smooth_comm_t), intent(inout) :: smooth
    logical,              intent(inout) :: error
    !
    type(cubeid_arg_t) :: cubearg
    character(len=*), parameter :: comm_abstract='Spatially smooth a cube'
    character(len=*), parameter :: comm_help=&
         'The smoothing is based on a gaussian kernel. This gaussian&
         & kernel can be given directly (/GAUSS) or can be determined&
         & from a desired spatial resolution, either provided by the&
         & user (/BEAM) or from another cube (/LIKE)'
    character(len=*), parameter :: rname='SMOOTH>REGISTER'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call cubetools_register_command(&
         'SMOOTH','[cube]',&
         comm_abstract,&
         comm_help,&
         cubemain_smooth_command,&
         smooth%comm,&
         error)
    if (error) return
    call cubearg%register(&
         'CUBE',&
         'Signal cube',&
         strg_id,&
         code_arg_optional,&
         [flag_cube],&
         error)
    if (error) return
    !
    call smooth%gauss%register(&
         'GAUSS',&
         'Define the gaussian smoothing kernel',&
         error)
    if (error) return
    !
    call smooth%beam%register(&
         'Define the desired spatial resolution',&
         error)
    if (error) return
    !
    call cubemain_auxiliary_register(&
         'LIKE',&
         'Smooth to the same resolution as a reference cube',&
         strg_id,&
         'Reference cube',&
         [flag_cube],&
         code_arg_mandatory,&
         smooth%like,&
         error)
    if (error) return
  end subroutine cubemain_smooth_register
  !
  subroutine cubemain_smooth_parse(comm,line,user,error)
    !----------------------------------------------------------------------
    ! SMOOTH cubname
    ! /GAUSS major [minor [pa]]
    ! /BEAM major [minor [pa]]
    ! /LIKE refname
    !----------------------------------------------------------------------
    class(smooth_comm_t), intent(in)    :: comm
    character(len=*),     intent(in)    :: line
    type(smooth_user_t),  intent(out)   :: user
    logical,              intent(inout) :: error
    !
    character(len=*), parameter :: rname='SMOOTH>PARSE'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call cubeadm_cubeid_parse(line,comm%comm,user%cubeids,error)
    if (error) return
    call comm%gauss%parse(line,user%gauss,error)
    if (error) return
    call comm%beam%parse(line,user%beam,error)
    if (error) return
    call cubemain_auxiliary_parse(line,comm%like,user%like,error)
    if (error) return
    !
    select case (cubetools_nopt())
    case(0)
       call cubemain_message(seve%e,rname,'At least one option must be given')
       error = .true.
       return
    case(1)
       continue
    case default
       call cubemain_message(seve%e,rname,'All options are exclusive')
       error = .true.
       return
    end select
  end subroutine cubemain_smooth_parse
  !
  subroutine cubemain_smooth_main(comm,user,error)
    use cubeadm_timing
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(smooth_comm_t), intent(in)    :: comm
    type(smooth_user_t),  intent(in)    :: user
    logical,              intent(inout) :: error
    !
    type(smooth_prog_t) :: prog
    character(len=*), parameter :: rname='SMOOTH>MAIN'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call user%toprog(comm,prog,error)
    if (error) return
    call prog%header(error)
    if (error) return
    call cubeadm_timing_prepro2process()
    call prog%data(error)
    if (error) return
    call cubeadm_timing_process2postpro()
  end subroutine cubemain_smooth_main
  !
  !----------------------------------------------------------------------
  !
  subroutine cubemain_smooth_user_toprog(user,comm,prog,error)
    use cubetools_header_methods
    use cubetools_unit
    use cubeadm_get
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(smooth_user_t), intent(in)    :: user
    type(smooth_comm_t),  intent(in)    :: comm
    type(smooth_prog_t),  intent(out)   :: prog
    logical,              intent(inout) :: error
    !
    type(cube_t), pointer :: ref
    character(len=*), parameter :: rname='SMOOTH>USER>TOPROG'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call cubeadm_cubeid_get_header(comm%comm,icube,user%cubeids,code_access_imaset,code_read,prog%cube,error)
    if (error) return
    if (user%gauss%do) then
       prog%type = type_kern
       call user%gauss%toprog(prog%cube,prog%kern,error)
       if (error) return
    else if (user%beam%do) then
       prog%type = type_beam
       call cubetools_header_get_spabeam(prog%cube%head,prog%oubeam,error)
       if (error) return
       call comm%beam%user2prog(user%beam,prog%oubeam,error)
       if (error) return
    else if (user%like%do) then
       prog%type = type_beam
       call cubemain_auxiliary_user2prog(comm%like,code_access_imaset_or_speset,  &
            user%like,ref,error)
       if (error) return
       call cubetools_header_get_spabeam(ref%head,prog%oubeam,error)
       if (error) return
    else
       call cubemain_message(seve%e,rname,'Unknown operation to be done')
       error = .true.
       return
    endif
  end subroutine cubemain_smooth_user_toprog
  !
  !----------------------------------------------------------------------
  !
  subroutine cubemain_smooth_prog_header(prog,error)
    use cubetools_header_methods
    use cubedag_allflags
    use cubeadm_clone
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(smooth_prog_t), intent(inout) :: prog
    logical,              intent(inout) :: error
    !
    type(beam_t) :: inbeam
    character(len=*), parameter :: rname='SMOOTH>PROG>HEADER'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call cubeadm_clone_header(prog%cube,[flag_smooth,flag_cube],prog%smoothed,error)
    if (error) return
    call cubetools_header_get_array_shape(prog%cube%head,prog%n,error)
    if (error) return
    call cubetools_header_get_spabeam(prog%cube%head,inbeam,error)
    if (error) return
    !    
    select case(prog%type)
    case (type_kern)
       call prog%beam_convolve(inbeam,prog%kern,prog%oubeam,error)
       if (error) return
    case (type_beam)
       call prog%beam_deconvolve(inbeam,prog%oubeam,prog%kern,error)
       if (error) return
    case default
       call cubemain_message(seve%e,rname,'Unknown smooth method')
       error = .true.
       return
    end select
    !
    call cubetools_header_update_spabeam(prog%oubeam,prog%smoothed%head,error)
    if (error) return
    !
    ! User feedback
    call cubemain_message(seve%r,rname,'Smoothing Gaussian Kernel')
    call prog%kern%list(error)
    if (error) return
    call cubemain_message(seve%r,rname,'Resulting beam')
    call cubetools_beam_list(prog%oubeam,error)
    if (error) return
  end subroutine cubemain_smooth_prog_header
  !
  subroutine cubemain_smooth_prog_beam_deconvolve(prog,inbeam,oubeam,kernel,error)
    use cubetopology_spatial_coordinates
    !----------------------------------------------------------------------
    ! Finds the convolution kernel to go from input beam to desired
    ! beam
    !----------------------------------------------------------------------
    class(smooth_prog_t), intent(in)    :: prog
    type(beam_t),         intent(in)    :: inbeam ! Input beam
    type(beam_t),         intent(in)    :: oubeam ! Desired beam
    type(ellipse_prog_t), intent(out)   :: kernel ! Resulting kernel
    logical,              intent(inout) :: error  
    !
    real(kind=coor_k) :: oldpang,newpang,kerpang
    type(beam_t) :: old,new,ker
    character(len=*), parameter :: rname='SMOOTH>PROG>BEAM>DECONVOLVE'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    ! VVV What happens if beam is 0.1% larger
    if ((oubeam%major.le.inbeam%major).or.(oubeam%minor.le.inbeam%minor)) then
       call cubemain_message(seve%e,rname,'Desired resolution cannot be smaller than the original one')
       error = .true.
       return
    endif
    !
    call cubetopology_spatial_pang_to_fortran(prog%cube,real(inbeam%pang,coor_k),oldpang,error)
    if (error) return
    call cubetopology_spatial_pang_to_fortran(prog%cube,real(oubeam%pang,coor_k),newpang,error)
    if (error) return
    !
    old%major = inbeam%major
    old%minor = inbeam%minor
    old%pang  = real(oldpang,beam_k)
    !
    new%major = oubeam%major
    new%minor = oubeam%minor
    new%pang  = real(newpang,beam_k)
    !
    call gauss2d_deconvolution(&
         old%major,old%minor,old%pang,&
         new%major,new%minor,new%pang,&
         ker%major,ker%minor,ker%pang,error)
    if (error) return
    !
    call cubetopology_spatial_fortran_to_pang(prog%cube,real(ker%pang,coor_k),kerpang,error)
    if (error) return
    kernel%major = ker%major
    kernel%minor = ker%minor
    kernel%pang  = real(kerpang,beam_k)
  end subroutine cubemain_smooth_prog_beam_deconvolve
  !
  subroutine cubemain_smooth_prog_beam_convolve(prog,inbeam,kernel,oubeam,error)
    use cubetopology_spatial_coordinates
    !----------------------------------------------------------------------
    ! Convolves a kernel with the beam from the header to give the
    ! final beam
    !----------------------------------------------------------------------
    class(smooth_prog_t), intent(in)    :: prog
    type(beam_t),         intent(in)    :: inbeam  ! Input beam
    type(ellipse_prog_t), intent(in)    :: kernel  ! Convolution kernel
    type(beam_t),         intent(out)   :: oubeam  ! Resulting beam
    logical,              intent(inout) :: error   
    !
    real(kind=coor_k) :: oldpang,newpang,kerpang
    type(beam_t) :: old,new,ker
    character(len=*), parameter :: rname='SMOOTH>PROG>BEAM>CONVOLVE'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call cubetopology_spatial_pang_to_fortran(prog%cube,real(inbeam%pang,coor_k),oldpang,error)
    if (error) return
    call cubetopology_spatial_pang_to_fortran(prog%cube,real(kernel%pang,coor_k),kerpang,error)
    if (error) return
    !
    old%major = inbeam%major
    old%minor = inbeam%minor
    old%pang  = real(oldpang,beam_k)
    !
    ker%major = kernel%major
    ker%minor = kernel%minor
    ker%pang  = real(kerpang,beam_k)
    !
    call gauss2d_convolution(&
         old%major,old%minor,old%pang,&
         ker%major,ker%minor,ker%pang,&
         new%major,new%minor,new%pang,error)
    if (error) return
    !
    call cubetopology_spatial_fortran_to_pang(prog%cube,real(new%pang,coor_k),newpang,error)
    if (error) return
    oubeam%major = new%major
    oubeam%minor = new%minor
    oubeam%pang  = real(newpang,beam_k)
  end subroutine cubemain_smooth_prog_beam_convolve
  !
  subroutine cubemain_smooth_prog_data(prog,error)
    use cubeadm_opened
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(smooth_prog_t), intent(inout) :: prog
    logical,              intent(inout) :: error
    !
    character(len=*), parameter :: rname='SMOOTH>PROG>DATA'
    type(cubeadm_iterator_t) :: iter
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call cubeadm_datainit_all(iter,error)
    if (error) return
    !$OMP PARALLEL DEFAULT(none) SHARED(prog,error) FIRSTPRIVATE(iter)
    !$OMP SINGLE
    do while (cubeadm_dataiterate_all(iter,error))
       if (error) exit
       !$OMP TASK SHARED(prog,error) FIRSTPRIVATE(iter)
       if (.not.error) then
          call prog%loop(iter,error)
       endif
       !$OMP END TASK
    enddo ! iter
    !$OMP END SINGLE
    !$OMP END PARALLEL
  end subroutine cubemain_smooth_prog_data
  !
  subroutine cubemain_smooth_prog_loop(prog,iter,error)
    use gkernel_interfaces
    use cubetools_header_methods
    use cubeadm_taskloop
    use cubeadm_image_types
    use cubeadm_visi_types
    use cubemain_fft_utils
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(smooth_prog_t),     intent(inout) :: prog
    type(cubeadm_iterator_t), intent(inout) :: iter
    logical,                  intent(inout) :: error
    !
    type(shape_t) :: n
    type(visi_t) :: visi
    type(image_t) :: input,smoothed
    integer(kind=4) :: ier
    real(kind=sign_k), allocatable :: fftwork(:)
    character(len=*), parameter :: rname='SMOOTH>PROG>LOOP'
    !
    call cubetools_header_get_array_shape(prog%smoothed%head,n,error)
    if (error) return
    ! This makes the code about 10 times faster, but it also introduces
    ! aliased structures in the image of the order of 1e-4
    prog%fftdim(1) = cubemain_fft_nextpow2(2*n%l)
    prog%fftdim(2) = cubemain_fft_nextpow2(2*n%m)
    !
    call input%associate('input',prog%cube,iter,error)
    if (error) return
    call visi%reallocate('visi',prog%fftdim(1),prog%fftdim(2),error)
    if (error) return
    call smoothed%allocate('smoothed',prog%smoothed,iter,error)
    if (error) return
    !
    allocate(fftwork(2*max(prog%fftdim(1),prog%fftdim(2))),stat=ier)
    if (failed_allocate(rname,'FFT work array',ier,error)) then
       error = .true.
       return
    endif
    !
    do while (iter%iterate_entry(error))
       call prog%act(iter%ie,input,visi,fftwork,smoothed,error)
       if (error) return
    enddo ! ie
  end subroutine cubemain_smooth_prog_loop
  !
  subroutine cubemain_smooth_prog_act(prog,ie,input,visi,fftwork,smoothed,error)
    use cubeadm_image_types
    use cubeadm_visi_types
    use cubemain_fft_utils
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(smooth_prog_t), intent(inout) :: prog
    integer(kind=entr_k), intent(in)    :: ie
    type(image_t),        intent(inout) :: input
    type(visi_t),         intent(inout) :: visi
    real(kind=sign_k),    intent(inout) :: fftwork(*) ! FFT buffer
    type(image_t),        intent(inout) :: smoothed
    logical,              intent(inout) :: error
    !
    ! VVV Dim has to have kind=4 because of previous interfaces
    integer(kind=4) :: ndim,dim(2)
    character(len=*), parameter :: rname='SMOOTH>PROG>ACT'
    !
    dim = prog%fftdim
    ndim = 2
    !
    call input%get(ie,error)
    if (error) return
    call cubemain_fft_plunge(&
         prog%n%l,prog%n%m,input,&
         prog%fftdim(1),prog%fftdim(2),visi,error)
    if (error) return
    ! Direct FFT
    call fourt(visi%val,dim,ndim,code_inve,code_rdata,fftwork)
    call prog%kernel_multiply(visi,error)
    if (error) return
    ! Inverse FFT
    call fourt(visi%val,dim,ndim,code_dire,code_cdata,fftwork)
    call cubemain_fft_deplunge(&
         prog%fftdim(1),prog%fftdim(2),visi,&
         prog%n%l,prog%n%m,smoothed,error)
    if (error) return
    call smoothed%blank_like(input,error)
    if (error) return
    call smoothed%put(ie,error)
    if (error) return
  end subroutine cubemain_smooth_prog_act
  !
  subroutine cubemain_smooth_prog_kernel_multiply(prog,visi,error)
    use phys_const
    use cubeadm_visi_types
    !----------------------------------------------------------------------
    ! Multiplies the FFT of the original image by the FT of the
    ! smoothing gaussian
    !----------------------------------------------------------------------
    class(smooth_prog_t), intent(inout) :: prog
    type(visi_t),         intent(inout) :: visi
    logical,              intent(inout) :: error
    !
    logical :: norot,rot90
    integer(kind=pixe_k) :: ix,iy,nx,ny,xhalf,yhalf,xhalf1,yhalf1
    real(kind=coor_k) :: ftmaj,ftmin,cosx,cosy,sinx,siny,ftpa
    real(kind=sign_k) :: expo, amp
    real(kind=sign_k), parameter :: tolr4=1.e-7
    character(len=*), parameter :: rname='SMOOTH>PROG>KERNEL_MULTIPLY'
    !
    norot = ( abs(mod(prog%kern%pang,180.d0)).le.tolr4)
    rot90 = ( abs(mod(prog%kern%pang,180.d0)-90.d0).le.tolr4)
    ftmaj = prog%kern%major*pi/(2.*sqrt(log(2.)))
    ftmin = prog%kern%minor*pi/(2.*sqrt(log(2.)))
    ftpa  = prog%kern%pang
    !
    nx = prog%fftdim(1)
    ny = prog%fftdim(2)
    !
    cosx = cos(ftpa)/nx*ftmin
    cosy = cos(ftpa)/ny*ftmaj
    sinx = sin(ftpa)/nx*ftmaj
    siny = sin(ftpa)/ny*ftmin
    !
    ! Convert map units to pixels
    cosx = cosx / prog%smoothed%head%spa%l%inc
    cosy = cosy / prog%smoothed%head%spa%m%inc
    sinx = sinx / prog%smoothed%head%spa%l%inc
    siny = siny / prog%smoothed%head%spa%m%inc
    !
    xhalf  = nx/2
    xhalf1 = xhalf+1
    yhalf  = ny/2
    yhalf1 = ny/2+1
    !
    ! Optimised code for Position Angle 0 degrees
    if (norot) then
       do iy=1,yhalf
          do ix=1,xhalf
             expo = (float(iy-1)*cosy)**2 + (float(ix-1)*cosx)**2
             if (expo.lt.80.) then
                amp = exp (-expo)
                visi%val(ix,iy) = visi%val(ix,iy)*amp
             else
                visi%val(ix,iy) = 0.
             endif
          enddo ! ix
          do ix=xhalf1,nx
             expo = (float(iy-1)*cosy)**2 + (float(ix-nx-1)*cosx)**2
             if (expo.lt.80.) then
                amp = exp (-expo)
                visi%val(ix,iy) = visi%val(ix,iy)*amp
             else
                visi%val(ix,iy) = 0.
             endif
          enddo
       enddo ! iy
       do iy=yhalf1,ny
          do ix=1,xhalf
             expo = (float(iy-ny-1)*cosy)**2 + (float(ix-1)*cosx)**2
             if (expo.lt.80.) then
                amp = exp (-expo)
                visi%val(ix,iy) = visi%val(ix,iy)*amp
             else
                visi%val(ix,iy) = 0.
             endif
          enddo ! ix
          do ix=xhalf1,nx
             expo = (float(iy-ny-1)*cosy)**2 + (float(ix-nx-1)*cosx)**2
             if (expo.lt.80.) then
                amp = exp (-expo)
                visi%val(ix,iy) = visi%val(ix,iy)*amp
             else
                visi%val(ix,iy) = 0.
             endif
          enddo
       enddo ! iy
    elseif (rot90) then
       ! Optimised code for Position Angle 90 degrees
       do iy=1,yhalf
          do ix=1,xhalf
             expo = (float(ix-1)*sinx)**2 +(float(iy-1)*siny)**2
             if (expo.lt.80.) then
                amp = exp (-expo)
                visi%val(ix,iy) = visi%val(ix,iy)*amp
             else
                visi%val(ix,iy) = 0.
             endif
          enddo ! ix
          do ix=xhalf1,nx
             expo = (float(ix-nx-1)*sinx)**2 + (float(iy-1)*siny)**2
             if (expo.lt.80.) then
                amp = exp (-expo)
                visi%val(ix,iy) = visi%val(ix,iy)*amp
             else
                visi%val(ix,iy) = 0.
             endif
          enddo ! ix
       enddo ! iy
       do iy=yhalf1,ny
          do ix=1,xhalf
             expo = (float(ix-1)*sinx)**2 + (float(iy-ny-1)*siny)**2
             if (expo.lt.80.) then
                amp = exp (-expo)
                visi%val(ix,iy) = visi%val(ix,iy)*amp
             else
                visi%val(ix,iy) = 0.
             endif
          enddo ! ix
          do ix=xhalf1,nx
             expo = (float(ix-nx-1)*sinx)**2 + (float(iy-ny-1)*siny)**2
             if (expo.lt.80.) then
                amp = exp (-expo)
                visi%val(ix,iy) = visi%val(ix,iy)*amp
             else
                visi%val(ix,iy) = 0.
             endif
          enddo ! ix
       enddo ! iy
    else
       ! General case of a rotated elliptical gaussian
       do iy=1,yhalf
          do ix=1,xhalf
             expo = (float(ix-1)*sinx + float(iy-1)*cosy)**2 +   &
                  &          (-float(ix-1)*cosx + float(iy-1)*siny)**2
             if (expo.lt.80.) then
                amp = exp (-expo)
                visi%val(ix,iy) = visi%val(ix,iy)*amp
             else
                visi%val(ix,iy) = 0.
             endif
          enddo ! ix
          do ix=xhalf1,nx
             expo = (float(ix-nx-1)*sinx + float(iy-1)*cosy)**2 +   &
                  &          ( -float(ix-nx-1)*cosx + float(iy-1)*siny)**2
             if (expo.lt.80.) then
                amp = exp (-expo)
                visi%val(ix,iy) = visi%val(ix,iy)*amp
             else
                visi%val(ix,iy) = 0.
             endif
          enddo ! ix
       enddo ! iy
       do iy=yhalf1,ny
          do ix=1,xhalf
             expo = (float(ix-1)*sinx + float(iy-ny-1)*cosy)**2 +   &
                  &          ( -float(ix-1)*cosx + float(iy-ny-1)*siny)**2
             if (expo.lt.80.) then
                amp = exp (-expo)
                visi%val(ix,iy) = visi%val(ix,iy)*amp
             else
                visi%val(ix,iy) = 0.
             endif
          enddo ! ix
          do ix=xhalf1,nx
             expo = (float(ix-nx-1)*sinx   &
                  &          + float(iy-ny-1)*cosy)**2 +   &
                  &          ( -float(ix-nx-1)*cosx + float(iy-ny-1)*siny)**2
             if (expo.lt.80.) then
                amp = exp (-expo)
                visi%val(ix,iy) = visi%val(ix,iy)*amp
             else
                visi%val(ix,iy) = 0.
             endif
          enddo ! ix
       enddo ! iy
    endif
  end subroutine cubemain_smooth_prog_kernel_multiply
end module cubemain_smooth
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
