program grid_extend
  use gildas_def
  use image_def
  use gkernel_interfaces
  use gbl_format
  !---------------------------------------------------------------------
  ! TASK  Compute a map from a Sorted Table by Gridding .
  !
  ! Input :
  !	a sorted table, ordered with Y increasing.
  ! Output :
  !	a VLM cube
  !---------------------------------------------------------------------
  ! Global
  character(len=*), parameter :: pname = 'GRID_EXTEND'
  real :: ubias,vbias,ubuff(4096),vbuff(4096)
  common /conv/ ubias,vbias,ubuff,vbuff
  !
  ! Local
  type(gildas) :: x,y
  ! PI is defined with more digits than necessary to avoid losing
  ! the last few bits in the decimal to binary conversion
  real(8), parameter :: pi=3.14159265358979323846d0
  integer :: nx,ny,nc,np,nd,nxmore,nymore
  integer :: ctypx,ctypy, i, ier
  real(4), allocatable :: ipxc(:), ipyc(:)
  real(4), allocatable :: ipw(:), ipra(:,:,:), ipwe(:)
  integer :: xcol,ycol,mcol(2),ocol,lcol,wcol
  real(8) :: xconv(3),yconv(3)
  real :: xmin,xmax,ymin,ymax,xinc,yinc,tole,beam,smooth
  real :: xparm(10),yparm(10),support(2),cell(2),space
  real :: wmax
  logical :: error
  character(len=80) :: table, map_name, name
  character(len=2) :: weight_mode
  character(len=12) :: ctype(5)
  data ctype /'BOX','EXP','SINC','EXP*SINC','SPHEROIDAL'/
  !------------------------------------------------------------------------
  ! Code:
  xconv = 0.d0
  yconv = 0.d0
  call gildas_open
  call gildas_char('TABLE$',table)
  call gildas_char('MAP$',map_name)
  call gildas_inte('XCOL$',xcol,1)
  call gildas_inte('YCOL$',ycol,1)
  call gildas_inte('WCOL$',wcol,1)
  call gildas_inte('MCOL$',mcol,2)
  call gildas_char('WEIGHT_MODE$',weight_mode)
  call gildas_real('TOLE$',tole,1)
  call gildas_real('BEAM$',beam,1)
  call gildas_real('SPACING$',space,1)
  call gildas_close
  xconv(3) = -space
  yconv(3) =  space
  !
  ! Input file
  call gildas_null(y)
  y%loca%read = .false.
  y%gil%form = fmt_r4
  call gdf_read_gildas(y,table,'.tab',error,rank=0,data=.true.)
  if (error) then
    call gagout('F-'//pname//',  Cannot read input file')
    goto 999
  endif
  if (xcol.gt.y%gil%dim(1) .or. ycol.gt.y%gil%dim(1)) then
    write(6,*) 'F-'//pname//',  X or Y column does not exist'
    goto 999
  endif
  nd = y%gil%dim(1)
  np = y%gil%dim(2)
  !
  ! Check order
  allocate (ipw(max(nd,np)), stat=ier)
  if (ier.ne.0) goto 999
  call dosor (y%r1d,nd,np,ipw,ycol)
  !
  ! Compute weights
  call dowei (y%r1d,nd,np,ipw,wcol) 
  !
  ! Compute extrema
  call finsiz (y%r1d,nd,np,xcol,ycol,ipw,   &
     &    xmin,xmax,ymin,ymax)
  !
  ! Find increment if required
  if (xconv(3).eq.0 .or. yconv(3).eq.0) then
    xinc = xmax-xmin
    yinc = ymax-ymin
    call fininc (y%r1d,nd,np,xcol,ycol,ipw,   &
     &      xinc,yinc,tole)
    if (xconv(3).eq.0) xconv(3) = -xinc
    if (yconv(3).eq.0) yconv(3) = +yinc
  endif
  !
  ! Find size
  nx = nint ( (xmax-xmin)/abs(xconv(3))) + 1
  ny = nint ( (ymax-ymin)/abs(yconv(3))) + 1
  nxmore = nint(3*beam/abs(xconv(3)))+1
  nx = nx+2*nxmore
  nymore = nint(3*beam/abs(yconv(3)))+1
  ny = ny+2*nymore
  !
  ! Extend to nearest power of two
  i = 4
  do while(2**i.lt.nx)
    i = i+1
  enddo
  nx = 2**i
  i = 4
  do while(2**i.lt.ny)
    i = i+1
  enddo
  ny = 2**i
  xconv(1) = nx/2+1-(xmin+xmax)/2/xconv(3)
  xconv(2) = 0.0
  yconv(1) = ny/2+1-(ymin+ymax)/2/yconv(3)
  yconv(2) = 0.0
  !
  write(6,*) 'Creating a cube with ',nx,' by ',ny,' pixels'
  write(6,*) 'Increment ',nint(yconv(3)*180*3600/pi)
  !
  ! Warn for big images
  if (nx.gt.4096 .or. ny.ge.4096) then
    write(6,*) 'W-'//pname//',  More than 4096 pixels in X or Y'
    goto 999
  elseif (nx.gt.512 .or. ny.gt.512) then
    write(6,*) 'W-'//pname//',  More than 512 pixels in X or Y'
  endif
  if (mcol(2).eq.0) mcol(2) = nd
  mcol(1) = max(1,min(mcol(1),nd))
  mcol(2) = max(1,min(mcol(2),nd))
  ocol = min(mcol(1),mcol(2))-1
  lcol = max(mcol(1),mcol(2))
  !
  ! Push in stack
  call gildas_null(x)
  call gdf_copy_header(y,x,error)
  nc = lcol-ocol
  write(6,*) ' Creating ',nc,' Channels from ',mcol
  !
  ! Compute gridding function
  smooth = beam/4.0
  ctypx = 2
  ctypy = 2
  support(1) = 5*smooth        ! Go far enough...
  support(2) = 5*smooth
  xparm(1) = support(1)/abs(xconv(3))
  yparm(1) = support(2)/abs(yconv(3))
  xparm(2) = smooth/(2*sqrt(log(2.0)))/abs(xconv(3))
  yparm(2) = smooth/(2*sqrt(log(2.0)))/abs(yconv(3))
  xparm(3) = 2
  yparm(3) = 2
  call grdflt (ctypx, ctypy, xparm, yparm)
  call convfn (ctypx, xparm, ubuff, ubias)
  call convfn (ctypy, yparm, vbuff, vbias)
  cell(1) = xconv(3)
  cell(2) = yconv(3)
  !
  ! Create image (in order v l m )
  name = map_name
  call sic_parsef(name,x%file,' ','.vlm')
  write(6,*) 'I-'//pname//',  Creating map file '//trim(x%file)
  x%gil%ndim = 3
  x%gil%dim(1) = nc
  x%gil%dim(2) = nx
  x%gil%dim(3) = ny
  x%gil%dim(4) = 1
  x%gil%ref(1) = y%gil%ref(1)-ocol
  x%gil%val(1) = x%gil%voff
  x%gil%inc(1) = x%gil%vres
  x%gil%convert(:,2) = xconv
  x%gil%convert(:,3) = yconv
  x%gil%coor_words = 6*gdf_maxdims ! Not a table
  x%gil%extr_words = 0             ! extrema not computed
  x%gil%xaxi = 2                   ! Reset projected axis
  x%gil%yaxi = 3                   !
  !
  !
  call gdf_create_image(x,error)
  if (error) then
    call gagout('F-'//pname//',  Cannot create output LMV image')
    goto 999
  endif
  !
  ! Convolve or grid
  allocate (ipxc(nx), ipyc(ny), x%r3d(nc,nx,ny), stat=ier)
  if (ier.ne.0) goto 999
  call docoor (nx,x%gil%ref(2),x%gil%val(2),x%gil%inc(2),ipxc)
  call docoor (ny,x%gil%ref(3),x%gil%val(3),x%gil%inc(3),ipyc)
  !
  ! Get the workspace for intermediate smoothing
  allocate (ipra(nc,nx,ny), ipwe(nx*ny), stat=ier)
  if (ier.ne.0) goto 999
  !
  call doconv (     &
     &    nd,np,    &     ! Number of input points
     &    y%r1d,    &     ! Input Values
     &    xcol,ycol,ocol,   &  ! Pointers to special values
     &    ipw,      &     ! Weights
     &    ipwe,     &     ! Gridded weights
     &    nc,nx,ny, &     ! Cube size
     &    ipra,     &     ! RAW Cube
     &    ipxc,ipyc,&     ! Cube coordinates
     &    support,cell)
  write(6,*) 'I-'//pname//',  Finished gridding'
  !
  ! Compute smoothing function
  ctypx = 2
  ctypy = 2
  xparm(1) = 3*beam/abs(xconv(3))
  yparm(1) = 3*beam/abs(yconv(3))
  xparm(2) = beam/(2*sqrt(log(2.0)))/abs(xconv(3))
  yparm(2) = beam/(2*sqrt(log(2.0)))/abs(yconv(3))
  xparm(3) = 2
  yparm(3) = 2
  call grdflt (ctypx, ctypy, xparm, yparm)
  call convfn (ctypx, xparm, ubuff, ubias)
  call convfn (ctypy, yparm, vbuff, vbias)
  support(1) = 3*beam
  support(2) = 3*beam
  cell(1) = xconv(3)
  cell(2) = yconv(3)
  !
  ! Free input grid and Create output map
  deallocate(y%r1d)
  !
  allocate (x%r3d(nc,nx,ny), stat=ier)
  if (ier.ne.0) goto 999
  !
  ! Smooth
  write(6,*) 'I-'//pname//',  Starting smoothing'
  call dosmoo (     &
     &    ipra,     &    ! RAW gridded Values
     &    ipwe,     &    ! Gridded weights
     &    nc,nx,ny, &        ! Cube size
     &    x%r3d,    &     ! Smoothed Cube
     &    ipxc,ipyc,&   ! Cube coordinates
     &    support,cell)
  write(6,*) 'I-'//pname//',  Finished smoothing'
  !
  ! Get maximum weight
  wmax = maxval (ipwe) 
  !
  ! Multiply by the gaussian truncation and replace by "raw" map.
  call doapod (xmin,xmax,ymin,ymax,tole,beam,   &
     &    nc,nx,ny,x%r1d,ipra,   &
     &    ipxc,ipyc,   &   ! Cube coordinates
     &    ipwe,wmax)
  write(6,*) 'I-'//pname//',  Finished apodizing'
  !
  call gdf_write_data(x,x%r3d,error)
  if (error) goto 999
  call gagout('S-'//pname//',  Successful completion')
  call sysexi(1)
  !
999 call sysexi (fatale)
end program grid_extend
!
subroutine docoor (n,xref,xval,xinc,x)
  integer :: n                      !
  real*8 :: xref                    !
  real*8 :: xval                    !
  real*8 :: xinc                    !
  real :: x(n)                      !
  ! Local
  integer :: i
  do i=1,n
    x(i) = (dble(i)-xref)*xinc+xval
  enddo
end subroutine docoor
!
subroutine doconv (nd,np,visi,jx,jy,jo,we,gwe,   &
     &    nc,nx,ny,map,mapx,mapy,sup,cell)
  integer :: nd                     ! Number of "visibilities"
  integer :: np                     ! number of values
  real :: visi(nd,np)               ! values
  integer :: jx                     ! X coord, Y coord location in VISI
  integer :: jy                     ! X coord, Y coord location in VISI
  integer :: jo                     ! offset for data in VISI
  real :: we(np)                    ! Weights
  integer :: nx                     ! map size
  integer :: ny                     ! map size
  real :: gwe(nx,ny)                ! gridded weights
  integer :: nc                     ! number of channels
  real :: map(nc,nx,ny)             ! gridded values
  real :: mapx(nx)                  ! Coordinates of grid
  real :: mapy(ny)                  ! Coordinates of grid
  real :: sup(2)                    ! Support of convolving function in User Units
  real :: cell(2)                   ! cell size in User Units
  ! Local
  integer :: ifirs,ilast          ! Range to be considered
  integer :: ix,iy,ic,i
  real :: result,weight
  real :: u,v,du,dv,um,up,vm,vp
  !
  ! Loop on Y rows
  ifirs = 1
  do iy=1,ny
    v = mapy(iy)
    vm = v-sup(2)
    vp = v+sup(2)
    !
    ! Optimized dichotomic search, taking into account the fact that
    !	MAPY is an ordered array
    !
    call findr (np,nd,jy,visi,vm,ifirs)
    ilast = ifirs
    call findr (np,nd,jy,visi,vp,ilast)
    ilast = ilast-1
    !
    ! Initialize X column
    do ix=1,nx
      do ic=1,nc
        map(ic,ix,iy) = 0.0
      enddo
    enddo
    do ix=1,nx
      gwe(ix,iy) = 0.0
    enddo
    !
    ! Loop on X cells
    if (ilast.ge.ifirs) then
      do ix=1,nx
        u = mapx(ix)
        um = u-sup(1)
        up = u+sup(1)
        weight = 0.0
        !
        ! Do while in X cell
        do i=ifirs,ilast
          if (visi(jx,i).ge.um .and. visi(jx,i).le.up) then
            du = (u-visi(jx,i))/cell(1)
            dv = (v-visi(jy,i))/cell(2)
            call convol (du,dv,result)
            if (result.ne.0.) then
              result = result*we(i)
              weight = weight + result
              do ic=1,nc
                map (ic,ix,iy) = map (ic,ix,iy) +   &
     &                  visi(ic+jo,i)*result
              enddo
            endif
          endif
        enddo
        !
        ! Normalize weight only in cells where some data exists...
        gwe(ix,iy) = weight
        if (weight.ne.0) then
          weight = 1.0/weight
          do ic=1,nc
            map (ic,ix,iy) = map(ic,ix,iy)*weight
          enddo
        endif
      enddo
    endif
  enddo
end subroutine doconv
!
subroutine dosmoo (raw,we,nc,nx,ny,map,mapx,mapy,sup,cell)
  !---------------------------------------------------------------------
  ! Smooth an input data cube in VLM along L and M by convolution
  ! by a gaussian...
  !---------------------------------------------------------------------
  integer :: nc                     ! map size
  integer :: nx                     ! map size
  integer :: ny                     ! map size
  real :: raw(nc,nx,ny)             ! Raw map
  real :: we(nx,ny)                 ! Weights
  real :: map(nc,nx,ny)             ! Smoothed map
  real :: mapx(nx)                  ! Coordinates of grid
  real :: mapy(ny)                  ! Coordinates of grid
  real :: sup(2)                    ! Support of convolving function in User Units
  real :: cell(2)                   ! cell size in User Units
  ! Local
  integer :: yfirs,ylast          ! Range to be considered
  integer :: xfirs,xlast          ! Range to be considered
  integer :: ix,iy,ic
  integer :: jx,jy                ! X coord, Y coord location in RAW
  real :: result,weight
  real :: u,v,du,dv,dx,dy
  !
  dx = abs(mapx(2)-mapx(1))
  dy = abs(mapy(2)-mapy(1))
  !
  ! Loop on Y rows
  do iy=1,ny
    v = mapy(iy)
    yfirs = max(1,nint((iy-sup(2)/dy)))
    ylast = min(ny,nint((iy+sup(2)/dy)))
    !
    ! Initialize X column
    do ix=1,nx
      do ic=1,nc
        map(ic,ix,iy) = 0.0
      enddo
    enddo
    !
    ! Loop on X cells
    if (yfirs.le.ylast) then
      do ix=1,nx
        u = mapx(ix)
        weight = 0.0
        xfirs = max(1,nint(ix-sup(1)/dx))
        xlast = min(nx,nint(ix+sup(1)/dx))
        !
        ! Do while in X cell
        if (xfirs.le.xlast) then
          do jy=yfirs,ylast
            dv = (v-mapy(jy))/cell(2)
            do jx=xfirs,xlast
              du = (u-mapx(jx))/cell(1)
              call convol (du,dv,result)
              ! No weight normalization
              !                       result = result*we(jx,jy)
              if (result.ne.0.0) then
                weight = weight + result
                do ic=1,nc
                  map (ic,ix,iy) = map (ic,ix,iy) +   &
     &                    raw(ic,jx,jy)*result
                enddo
              endif
            enddo
          enddo
          !
          ! Normalize weight only in cells where some data exists...
          if (weight.ne.0) then
            weight = 1.0/weight
            do ic=1,nc
              map (ic,ix,iy) = map(ic,ix,iy)*weight
            enddo
          endif
        endif
      enddo
    endif
  enddo
end subroutine dosmoo
!
subroutine dowei (visi,nd,np,we,iw)
  integer :: nd                     !
  integer :: np                     !
  real :: visi(nd,np)               !
  real :: we(np)                    !
  integer :: iw                     !
  ! Local
  integer :: i
  if (iw.le.0 .or. iw.gt.nd) then
    do i=1,np
      we(i) = 1.0
    enddo
  else
    do i=1,np
      we(i) = visi(iw,i)
    enddo
  endif
end subroutine dowei
!
subroutine findr (nv,nc,ic,xx,xlim,nlim)
  !---------------------------------------------------------------------
  ! GILDAS	Internal routine
  !	Find NLIM such as
  !	 	XX(IC,NLIM-1) < XLIM < XX(IC,NLIM)
  !	for input data ordered, retrieved from memory
  !	Assumes NLIM already preset so that XX(IC,NLIM-1) < XLIM
  !---------------------------------------------------------------------
  integer :: nv                     !
  integer :: nc                     !
  integer :: ic                     !
  real :: xx(nc,nv)                 !
  real :: xlim                      !
  integer :: nlim                   !
  ! Local
  integer :: ninf,nsup,nmid
  !
  if (nlim.gt.nv) return
  if (xx(ic,nlim).gt.xlim) then
    return
  elseif (xx(ic,nv).lt.xlim) then
    nlim = nv+1
    return
  endif
  !
  ninf = nlim
  nsup = nv
  do while(nsup.gt.ninf+1)
    nmid = (nsup + ninf)/2
    if (xx(ic,nmid).lt.xlim) then
      ninf = nmid
    else
      nsup = nmid
    endif
  enddo
  nlim = nsup
end subroutine findr
!
subroutine convol (du,dv,resu)
  real :: du                        !
  real :: dv                        !
  real :: resu                      !
  ! Local
  real :: ubias,vbias,ubuff(4096),vbuff(4096)
  common /conv/ ubias,vbias,ubuff,vbuff
  integer :: iu,iv
  !
  iu = nint(100.0*du+ubias)
  iv = nint(100.0*dv+vbias)
  resu = ubuff(iu)*vbuff(iv)
  if (resu.lt.1e-10) resu = 0.0
end subroutine convol
!
subroutine convfn (type, parm, buffer, bias)
  use gkernel_interfaces
  use gildas_def
  !---------------------------------------------------------------------
  ! 	CONVFN computes the convolving functions and stores them in
  !   	the supplied buffer. Values are tabulated every 1/100 cell.
  ! Arguments :
  !	TYPE		I*4	Convolving function type
  ! 	PARM(10)        R*4  	Convolving function parameters.
  !				PARM(1) = radius of support in cells
  !	BUFFER(4096)	R*4  	Work buffer.
  !	BIAS		R*4	Center of convolution
  !---------------------------------------------------------------------
  integer :: type                   !
  real*4 ::  parm(10)               !
  real*4 ::  buffer(4096)           !
  real*4 ::  bias                   !
  ! Local
  integer :: lim, i, im, ialf, ier, ibias
  real*4 ::  pi, p1, p2, u, umax, absu, eta, psi
  data pi /3.1415926536/
  !
  ! Number of rows
  i = max (parm(1) , 1.0)
  i = i * 2 + 1
  lim = i * 100 + 1
  if (lim.gt.1.5*4096) then
    write(6,*) 'E-GRID,  Work buffer insufficient ',lim
    call sysexi(fatale)
  elseif (lim.gt.4096) then
    lim = 4096
    bias = 2049
  else
    bias = 50.0 * i + 1.0
  endif
  umax = parm(1)
  !                                       Check function types.
  goto (100,200,300,400,500) type
  !
  ! Type defaulted or not implemented, use Default = EXP * SINC
  type = 4
  parm(1) = 3.0
  parm(2) = 1.55
  parm(3) = 2.52
  parm(4) = 2.00
  goto 400
  !
  ! Pill box
100 continue
  do i = 1,lim
    u = (i-bias) * 0.01
    absu = abs (u)
    if (absu.lt.umax) then
      buffer(i) = 1.0
    elseif (absu.eq.umax) then
      buffer(i) = 0.5
    else
      buffer(i) = 0.0
    endif
  enddo
  return
  !
  ! Exponential function.
200 continue
  p1 = 1.0 / parm(2)
  do i = 1,lim
    u = (i-bias) * 0.01
    absu = abs (u)
    if (absu.gt.umax) then
      buffer(i) = 0.0
    else
      buffer(i) = exp (-((p1*absu) ** parm(3)))
    endif
  enddo
  return
  !
  ! Sinc function.
300 continue
  p1 = pi / parm(2)
  do i = 1,lim
    u = (i-bias)*0.01
    absu = abs (u)
    if (absu.gt.umax) then
      buffer(i) = 0.0
    elseif (absu.eq.0.0) then
      buffer(i) = 1.0
    else
      buffer(i) = sin (p1*absu) / (p1*absu)
    endif
  enddo
  return
  !
  ! EXP * SINC convolving function
400 continue
  p1 = pi / parm(2)
  p2 = 1.0 / parm(3)
  do i = 1,lim
    ! Cannot see why different from others ?
    !	    u = (i - lim/2 - 1) * 0.01
    u = (i-bias)*0.01
    absu = abs (u)
    if (absu.gt.umax) then
      buffer(i) = 0.0
    elseif (absu.lt.0.01) then
      buffer(i) = 1.0
    else
      buffer(i) = sin(u*p1) / (u*p1) *   &
     &        exp (-((absu * p2) ** parm(4)))
    endif
  enddo
  return
  !
500 continue
  do i = 1,lim
    buffer(i) = 0.0
  enddo
  ialf = 2.0 * parm(2) + 1.1
  im = 2.0 * parm(1) + 0.1
  ialf = max (1, min (5, ialf))
  im = max (4, min (8, im))
  lim = parm(1) * 100.0 + 0.1
  ibias = bias
  do i = 1,lim
    eta = float (i-1) / float (lim-1)
    call sphfn (ialf, im, 0, eta, psi, ier)
    buffer(ibias+i-1) = psi
  enddo
  lim = ibias-1
  do i = 1,lim
    buffer(ibias-i) = buffer(ibias+i)
  enddo
  return
  !
end subroutine convfn
!
subroutine sphfn (ialf, im, iflag, eta, psi, ier)
  !---------------------------------------------------------------------
  !     SPHFN is a subroutine to evaluate rational approximations to se-
  !  lected zero-order spheroidal functions, psi(c,eta), which are, in a
  !  sense defined in VLA Scientific Memorandum No. 132, optimal for
  !  gridding interferometer data.  The approximations are taken from
  !  VLA Computer Memorandum No. 156.  The parameter c is related to the
  !  support width, m, of the convoluting function according to c=
  !  pi*m/2.  The parameter alpha determines a weight function in the
  !  definition of the criterion by which the function is optimal.
  !  SPHFN incorporates approximations to 25 of the spheroidal func-
  !  tions, corresponding to 5 choices of m (4, 5, 6, 7, or 8 cells)
  !  and 5 choices of the weighting exponent (0, 1/2, 1, 3/2, or 2).
  !
  !  Input:
  !    IALF    I*4   Selects the weighting exponent, alpha.  IALF =
  !                  1, 2, 3, 4, and 5 correspond, respectively, to
  !                  alpha = 0, 1/2, 1, 3/2, and 2.
  !    IM      I*4   Selects the support width m, (=IM) and, correspond-
  !                  ingly, the parameter c of the spheroidal function.
  !                  Only the choices 4, 5, 6, 7, and 8 are allowed.
  !    IFLAG   I*4   Chooses whether the spheroidal function itself, or
  !                  its Fourier transform, is to be approximated.  The
  !                  latter is appropriate for gridding, and the former
  !                  for the u-v plane convolution.  The two differ on-
  !                  by a factor (1-eta**2)**alpha.  IFLAG less than or
  !                  equal to zero chooses the function appropriate for
  !                  gridding, and IFLAG positive chooses its F.T.
  !    ETA     R*4   Eta, as the argument of the spheroidal function, is
  !                  a variable which ranges from 0 at the center of the
  !                  convoluting function to 1 at its edge (also from 0
  !                  at the center of the gridding correction function
  !                  to unity at the edge of the map).
  !
  !  Output:
  !    PSI      R*4  The function value which, on entry to the subrou-
  !                  tine, was to have been computed.
  !    IER      I*4  An error flag whose meaning is as follows:
  !                     IER = 0  =>  No evident problem.
  !                           1  =>  IALF is outside the allowed range.
  !                           2  =>  IM is outside of the allowed range.
  !                           3  =>  ETA is larger than 1 in absolute
  !                                     value.
  !                          12  =>  IALF and IM are out of bounds.
  !                          13  =>  IALF and ETA are both illegal.
  !                          23  =>  IM and ETA are both illegal.
  !                         123  =>  IALF, IM, and ETA all are illegal.
  !---------------------------------------------------------------------
  integer*4 :: ialf                 !
  integer*4 :: im                   !
  integer*4 :: iflag                !
  real*4 :: eta                     !
  real*4 :: psi                     !
  integer*4 :: ier                  !
  ! Local
  integer*4 :: j
  real*4 :: alpha(5), eta2, x
  real*4 :: p4(5,5), q4(2,5), p5(7,5), q5(5), p6l(5,5), q6l(2,5)
  real*4 :: p6u(5,5), q6u(2,5), p7l(5,5), q7l(2,5), p7u(5,5)
  real*4 :: q7u(2,5), p8l(6,5), q8l(2,5), p8u(6,5), q8u(2,5)
  data alpha / 0., .5, 1., 1.5, 2. /
  data p4 /   &
     &    1.584774e-2, -1.269612e-1,  2.333851e-1, -1.636744e-1,   &
     &    5.014648e-2,  3.101855e-2, -1.641253e-1,  2.385500e-1,   &
     &    -1.417069e-1,  3.773226e-2,  5.007900e-2, -1.971357e-1,   &
     &    2.363775e-1, -1.215569e-1,  2.853104e-2,  7.201260e-2,   &
     &    -2.251580e-1,  2.293715e-1, -1.038359e-1,  2.174211e-2,   &
     &    9.585932e-2, -2.481381e-1,  2.194469e-1, -8.862132e-2,   &
     &    1.672243e-2 /
  data q4 /   &
     &    4.845581e-1,  7.457381e-2,  4.514531e-1,  6.458640e-2,   &
     &    4.228767e-1,  5.655715e-2,  3.978515e-1,  4.997164e-2,   &
     &    3.756999e-1,  4.448800e-2 /
  data p5 /   &
     &    3.722238e-3, -4.991683e-2,  1.658905e-1, -2.387240e-1,   &
     &    1.877469e-1, -8.159855e-2,  3.051959e-2,  8.182649e-3,   &
     &    -7.325459e-2,  1.945697e-1, -2.396387e-1,  1.667832e-1,   &
     &    -6.620786e-2,  2.224041e-2,  1.466325e-2, -9.858686e-2,   &
     &    2.180684e-1, -2.347118e-1,  1.464354e-1, -5.350728e-2,   &
     &    1.624782e-2,  2.314317e-2, -1.246383e-1,  2.362036e-1,   &
     &    -2.257366e-1,  1.275895e-1, -4.317874e-2,  1.193168e-2,   &
     &    3.346886e-2, -1.503778e-1,  2.492826e-1, -2.142055e-1,   &
     &    1.106482e-1, -3.486024e-2,  8.821107e-3 /
  data q5 /   &
     &    2.418820e-1,  2.291233e-1,  2.177793e-1,  2.075784e-1,   &
     &    1.983358e-1 /
  data p6l /   &
     &    5.613913e-2, -3.019847e-1,  6.256387e-1, -6.324887e-1,   &
     &    3.303194e-1,  6.843713e-2, -3.342119e-1,  6.302307e-1,   &
     &    -5.829747e-1,  2.765700e-1,  8.203343e-2, -3.644705e-1,   &
     &    6.278660e-1, -5.335581e-1,  2.312756e-1,  9.675562e-2,   &
     &    -3.922489e-1,  6.197133e-1, -4.857470e-1,  1.934013e-1,   &
     &    1.124069e-1, -4.172349e-1,  6.069622e-1, -4.405326e-1,   &
     &    1.618978e-1 /
  data q6l /   &
     &    9.077644e-1,  2.535284e-1,  8.626056e-1,  2.291400e-1,   &
     &    8.212018e-1,  2.078043e-1,  7.831755e-1,  1.890848e-1,   &
     &    7.481828e-1,  1.726085e-1 /
  data p6u /   &
     &    8.531865e-4, -1.616105e-2,  6.888533e-2, -1.109391e-1,   &
     &    7.747182e-2,  2.060760e-3, -2.558954e-2,  8.595213e-2,   &
     &    -1.170228e-1,  7.094106e-2,  4.028559e-3, -3.697768e-2,   &
     &    1.021332e-1, -1.201436e-1,  6.412774e-2,  6.887946e-3,   &
     &    -4.994202e-2,  1.168451e-1, -1.207733e-1,  5.744210e-2,   &
     &    1.071895e-2, -6.404749e-2,  1.297386e-1, -1.194208e-1,   &
     &    5.112822e-2 /
  data q6u /   &
     &    1.101270e+0,  3.858544e-1,  1.025431e+0,  3.337648e-1,   &
     &    9.599102e-1,  2.918724e-1,  9.025276e-1,  2.575336e-1,   &
     &    8.517470e-1,  2.289667e-1 /
  data p7l /   &
     &    2.460495e-2, -1.640964e-1,  4.340110e-1, -5.705516e-1,   &
     &    4.418614e-1,  3.070261e-2, -1.879546e-1,  4.565902e-1,   &
     &    -5.544891e-1,  3.892790e-1,  3.770526e-2, -2.121608e-1,   &
     &    4.746423e-1, -5.338058e-1,  3.417026e-1,  4.559398e-2,   &
     &    -2.362670e-1,  4.881998e-1, -5.098448e-1,  2.991635e-1,   &
     &    5.432500e-2, -2.598752e-1,  4.974791e-1, -4.837861e-1,   &
     &    2.614838e-1 /
  data q7l /   &
     &    1.124957e+0,  3.784976e-1,  1.075420e+0,  3.466086e-1,   &
     &    1.029374e+0,  3.181219e-1,  9.865496e-1,  2.926441e-1,   &
     &    9.466891e-1,  2.698218e-1 /
  data p7u /   &
     &    1.924318e-4, -5.044864e-3,  2.979803e-2, -6.660688e-2,   &
     &    6.792268e-2,  5.030909e-4, -8.639332e-3,  4.018472e-2,   &
     &    -7.595456e-2,  6.696215e-2,  1.059406e-3, -1.343605e-2,   &
     &    5.135360e-2, -8.386588e-2,  6.484517e-2,  1.941904e-3,   &
     &    -1.943727e-2,  6.288221e-2, -9.021607e-2,  6.193000e-2,   &
     &    3.224785e-3, -2.657664e-2,  7.438627e-2, -9.500554e-2,   &
     &    5.850884e-2 /
  data q7u /   &
     &    1.450730e+0,  6.578685e-1,  1.353872e+0,  5.724332e-1,   &
     &    1.269924e+0,  5.032139e-1,  1.196177e+0,  4.460948e-1,   &
     &    1.130719e+0,  3.982785e-1 /
  data p8l /   &
     &    1.378030e-2, -1.097846e-1,  3.625283e-1, -6.522477e-1,   &
     &    6.684458e-1, -4.703556e-1,  1.721632e-2, -1.274981e-1,   &
     &    3.917226e-1, -6.562264e-1,  6.305859e-1, -4.067119e-1,   &
     &    2.121871e-2, -1.461891e-1,  4.185427e-1, -6.543539e-1,   &
     &    5.904660e-1, -3.507098e-1,  2.580565e-2, -1.656048e-1,   &
     &    4.426283e-1, -6.473472e-1,  5.494752e-1, -3.018936e-1,   &
     &    3.098251e-2, -1.854823e-1,  4.637398e-1, -6.359482e-1,   &
     &    5.086794e-1, -2.595588e-1 /
  data q8l /   &
     &    1.076975e+0,  3.394154e-1,  1.036132e+0,  3.145673e-1,   &
     &    9.978025e-1,  2.920529e-1,  9.617584e-1,  2.715949e-1,   &
     &    9.278774e-1,  2.530051e-1 /
  data p8u /   &
     &    4.290460e-5, -1.508077e-3,  1.233763e-2, -4.091270e-2,   &
     &    6.547454e-2, -5.664203e-2,  1.201008e-4, -2.778372e-3,   &
     &    1.797999e-2, -5.055048e-2,  7.125083e-2, -5.469912e-2,   &
     &    2.698511e-4, -4.628815e-3,  2.470890e-2, -6.017759e-2,   &
     &    7.566434e-2, -5.202678e-2,  5.259595e-4, -7.144198e-3,   &
     &    3.238633e-2, -6.946769e-2,  7.873067e-2, -4.889490e-2,   &
     &    9.255826e-4, -1.038126e-2,  4.083176e-2, -7.815954e-2,   &
     &    8.054087e-2, -4.552077e-2 /
  data q8u /   &
     &    1.379457e+0,  5.786953e-1,  1.300303e+0,  5.135748e-1,   &
     &    1.230436e+0,  4.593779e-1,  1.168075e+0,  4.135871e-1,   &
     &    1.111893e+0,  3.744076e-1 /
  !
  ! Code
  ier = 0
  if (ialf.lt.1 .or. ialf.gt.5) ier = 1
  if (im.lt.4 .or. im.gt.8) ier = 2+10*ier
  if (abs(eta).gt.1.) ier = 3+10*ier
  if (ier.ne.0) then
    write(6,*) 'E-SPHEROIDAL,  Error ',ier
    return
  endif
  eta2 = eta**2
  j = ialf
  !
  ! Support width = 4 cells:
  if (im.eq.4) then
    x = eta2-1.
    psi = (p4(1,j)+x*(p4(2,j)+x*(p4(3,j)+x*(p4(4,j)+x*p4(5,j)))))   &
     &      / (1.+x*(q4(1,j)+x*q4(2,j)))
    !
    ! Support width = 5 cells:
  elseif (im.eq.5) then
    x = eta2-1.
    psi = (p5(1,j)+x*(p5(2,j)+x*(p5(3,j)+x*(p5(4,j)+x*(p5(5,j)   &
     &      +x*(p5(6,j)+x*p5(7,j)))))))   &
     &      / (1.+x*q5(j))
    !
    ! Support width = 6 cells:
  elseif (im.eq.6) then
    if (abs(eta).le..75) then
      x = eta2-.5625
      psi = (p6l(1,j)+x*(p6l(2,j)+x*(p6l(3,j)+x*(p6l(4,j)   &
     &        +x*p6l(5,j))))) / (1.+x*(q6l(1,j)+x*q6l(2,j)))
    else
      x = eta2-1.
      psi = (p6u(1,j)+x*(p6u(2,j)+x*(p6u(3,j)+x*(p6u(4,j)   &
     &        +x*p6u(5,j))))) / (1.+x*(q6u(1,j)+x*q6u(2,j)))
    endif
    !
    ! Support width = 7 cells:
  elseif (im.eq.7) then
    if (abs(eta).le..775) then
      x = eta2-.600625
      psi = (p7l(1,j)+x*(p7l(2,j)+x*(p7l(3,j)+x*(p7l(4,j)   &
     &        +x*p7l(5,j))))) / (1.+x*(q7l(1,j)+x*q7l(2,j)))
    else
      x = eta2-1.
      psi = (p7u(1,j)+x*(p7u(2,j)+x*(p7u(3,j)+x*(p7u(4,j)   &
     &        +x*p7u(5,j))))) / (1.+x*(q7u(1,j)+x*q7u(2,j)))
    endif
    !
    ! Support width = 8 cells:
  elseif (im.eq.8) then
    if (abs(eta).le..775) then
      x = eta2-.600625
      psi = (p8l(1,j)+x*(p8l(2,j)+x*(p8l(3,j)+x*(p8l(4,j)   &
     &        +x*(p8l(5,j)+x*p8l(6,j)))))) / (1.+x*(q8l(1,j)+x*q8l(2,j)))
    else
      x = eta2-1.
      psi = (p8u(1,j)+x*(p8u(2,j)+x*(p8u(3,j)+x*(p8u(4,j)   &
     &        +x*(p8u(5,j)+x*p8u(6,j)))))) / (1.+x*(q8u(1,j)+x*q8u(2,j)))
    endif
  endif
  !
  ! Normal return:
  if (iflag.gt.0 .or. ialf.eq.1 .or. eta.eq.0.) return
  if (abs(eta).eq.1.) then
    psi = 0.0
  else
    psi = (1.-eta2)**alpha(ialf)*psi
  endif
end subroutine sphfn
!
subroutine grdflt (ctypx, ctypy, xparm, yparm)
  !---------------------------------------------------------------------
  !     GRDFLT determines default parameters for the convolution functions
  !     If no convolving type is chosen, an Spheroidal is picked.
  !     Otherwise any unspecified values ( = 0.0) will be set to some
  !     value.
  ! Arguments:
  !     CTYPX,CTYPY           I  Convolution types for X and Y direction
  !                                1 = pill box
  !                                2 = exponential
  !                                3 = sinc
  !                                4 = expontntial * sinc
  !                                5 = spheroidal function
  !     XPARM(10),YPARM(10)   R*4  Parameters for the convolution fns.
  !                                (1) = support radius (cells)
  !---------------------------------------------------------------------
  integer :: ctypx                  !
  integer :: ctypy                  !
  real*4 ::    xparm(10)            !
  real*4 ::    yparm(10)            !
  ! Local
  character(len=12) :: chtyps(5)
  integer :: numprm(5), i, k
  data numprm /1, 3, 2, 4, 2/
  data chtyps /'Pillbox','Exponential','Sin(X)/(X)',   &
     &    'Exp*Sinc','Spheroidal'/
  !
  ! Default = type 5
  if ((ctypx.le.0) .or. (ctypx.gt.5)) ctypx = 5
  goto (110,120,130,140,150) ctypx
  !
  ! Pillbox
110 continue
  if (xparm(1).le.0.0) xparm(1) = 0.5
  go to 500
  ! Exponential.
120 continue
  if (xparm(1).le.0.0) xparm(1) = 3.0
  if (xparm(2).le.0.0) xparm(2) = 1.00
  if (xparm(3).le.0.0) xparm(3) = 2.00
  go to 500
  ! Sinc.
130 continue
  if (xparm(1).le.0.0) xparm(1) = 3.0
  if (xparm(2).le.0.0) xparm(2) = 1.14
  go to 500
  ! Exponential * sinc
140 continue
  if (xparm(1).le.0.0) xparm(1) = 3.0
  if (xparm(2).le.0.0) xparm(2) = 1.55
  if (xparm(3).le.0.0) xparm(3) = 2.52
  if (xparm(4).le.0.0) xparm(4) = 2.00
  go to 500
  ! Spheroidal function
150 continue
  if (xparm(1).le.0.0) xparm(1) = 3.0
  if (xparm(2).le.0.0) xparm(2) = 1.0
  go to 500
  !
  ! Put default cheking here for further function types
500 continue
  ! Check Y convolution defaults
  if ((ctypy.gt.0) .and. (ctypy.le.5)) go to (610,620,630,   &
     &    640,650) ctypy
  ! Use X values
  ctypy = ctypx
  do i = 1,10
    yparm(i) = xparm(i)
  enddo
  goto 900
  ! Pillbox
610 continue
  if (yparm(1).le.0.0) yparm(1) = 0.5
  go to 900
  ! Exponential
620 continue
  if (yparm(1).le.0.0) yparm(1) = 3.0
  if (yparm(2).le.0.0) yparm(2) = 1.0
  if (yparm(3).le.0.0) yparm(3) = 2.0
  go to 900
  ! Sinc
630 continue
  if (yparm(1).le.0.0) yparm(1) = 3.0
  if (yparm(2).le.0.0) yparm(2) = 1.14
  go to 900
  ! Exponential * sinc
640 continue
  if (yparm(1).le.0.0) yparm(1) = 3.0
  if (yparm(2).le.0.0) yparm(2) = 1.55
  if (yparm(3).le.0.0) yparm(3) = 2.52
  if (yparm(4).le.0.0) yparm(4) = 2.00
  go to 900
  ! Spheroidal function
650 continue
  if (yparm(1).le.0.0) yparm(1) = 3.0
  if (yparm(2).le.0.0) yparm(2) = 1.0
  go to 900
  !
  ! Put default checking for new types here.
  ! Print parameters chosen.
900 continue
  write(6,1001) 'X',chtyps(ctypx),(xparm(k),k=1,numprm(ctypx))
  write(6,1001) 'Y',chtyps(ctypy),(yparm(k),k=1,numprm(ctypy))
1001 format(1x,a,' Convolution ',a,' Par.=',5f8.4)
end subroutine grdflt
!
subroutine finsiz (x,nd,np,ix,iy,we,xmin,xmax,ymin,ymax)
  integer :: nd                     !
  integer :: np                     !
  real :: x(nd,np)                  !
  integer :: ix                     !
  integer :: iy                     !
  real :: we(np)                    !
  real :: xmin                      !
  real :: xmax                      !
  real :: ymin                      !
  real :: ymax                      !
  ! Local
  integer :: i,j
  !
  i = 1
  do while (we(i).eq.0)
    i = i+1
  enddo
  xmin = x(ix,i)
  xmax = x(ix,i)
  ymin = x(iy,i)
  i = i+1
  do j=i,np
    if (we(j).ne.0) then
      if (x(ix,j).lt.xmin) then
        xmin = x(ix,j)
      elseif (x(ix,j).gt.xmax) then
        xmax = x(ix,j)
      endif
    endif
  enddo
  i = np
  do while (we(i).eq.0)
    i = i-1
  enddo
  ymax = x(iy,i)
end subroutine finsiz
!
subroutine finsiy (x,nd,np,iy,we,ymin,ymax)
  integer :: nd                     !
  integer :: np                     !
  real :: x(nd,np)                  !
  integer :: iy                     !
  real :: we(np)                    !
  real :: ymin                      !
  real :: ymax                      !
  ! Local
  integer :: i
  !
  i = 1
  do while (we(i).eq.0)
    i = i+1
  enddo
  ymin = x(iy,i)
  i = np
  do while (we(i).eq.0)
    i = i-1
  enddo
  ymax = x(iy,i)
end subroutine finsiy
!
subroutine fininc (x,nd,np,ix,iy,we,xinc,yinc,tole)
  integer :: nd                     !
  integer :: np                     !
  real :: x(nd,np)                  !
  integer :: ix                     !
  integer :: iy                     !
  real :: we(np)                    !
  real :: xinc                      !
  real :: yinc                      !
  real :: tole                      !
  ! Local
  integer :: i,j
  real :: dist
  !
  do i=1,np-1
    if (we(i).ne.0) then
      do j=i+1,np
        if (we(j).ne.0) then
          dist = abs(x(ix,j)-x(ix,i))
          if (dist.gt.tole .and. dist.lt.xinc) xinc = dist
          dist = x(iy,j)-x(iy,i)
          if (dist.gt.tole .and. dist.lt.yinc) yinc = dist
        endif
      enddo
    endif
  enddo
end subroutine fininc
!
subroutine dosor  (visi,nd,np,we,iy)
  use gkernel_interfaces
  use gildas_def
  integer :: nd                     !
  integer :: np                     !
  real :: visi(nd,np)               !
  real :: we(nd)                    !
  integer :: iy                     !
  ! Global
  integer :: trione
  ! Local
  integer :: i,ier
  do i=1,np-1
    if (visi(iy,i).gt.visi(iy,i+1)) then
      write(6,*) 'I-GRID,  Sorting input table'
      ier = trione (visi,nd,np,iy,we)
      if (ier.ne.1) call sysexi (fatale)
      return
    endif
  enddo
end subroutine dosor
!
function trione (x,nd,n,ix,work)
  !---------------------------------------------------------------------
  ! 	Sorting program that uses a quicksort algorithm.
  !	Sort on one row
  !	X	R*4(*)	Unsorted array				Input
  !	ND	I	First dimension of X 			Input
  !	N	I	Second dimension of X			Input
  !	IX	I	X(IX,*) is the key for sorting		Input
  !	WORK	R*4(ND)	Work space for exchange			Input
  !---------------------------------------------------------------------
  integer :: trione                 !
  integer :: nd                     !
  integer :: n                      !
  real*4 :: x(nd,n)                 !
  integer :: ix                     !
  real*4 :: work(nd)                !
  ! Local
  integer :: maxstack,nstop
  parameter (maxstack=1000,nstop=15)
  integer*4 :: i, j, k, l1, r1
  integer*4 :: l, r, m, lstack(maxstack), rstack(maxstack), sp
  real*4 :: key
  logical :: mgtl, lgtr, rgtm
  !
  trione = 1
  if (n.le.nstop) goto 50
  sp = 0
  sp = sp + 1
  lstack(sp) = 1
  rstack(sp) = n
  !
  ! Sort a subrecord off the stack
  ! Set KEY = median of X(L), X(M), X(R)
  ! No! This is not reasonable, as systematic very inequal partitioning will
  ! occur in some cases (especially for nearly already sorted files)
  ! To fix this problem, I found (but I cannot prove it) that it is best to
  ! select the estimation of the median value from intermediate records. P.V.
1 l = lstack(sp)
  r = rstack(sp)
  sp = sp - 1
  m = (l + r) / 2
  l1=(2*l+r)/3
  r1=(l+2*r)/3
  !
  mgtl = x(ix,m) .gt. x(ix,l)
  rgtm = x(ix,r) .gt. x(ix,m)
  !
  ! Algorithm to select the median key. The original one from MONGO
  ! was completely wrong. P. Valiron, 24-Jan-84 .
  !
  !		   	MGTL	RGTM	LGTR	MGTL.EQV.LGTR	MEDIAN_KEY
  !
  !	KL < KM < KR	T	T	*	*		KM
  !	KL > KM > KR	F	F	*	*		KM
  !
  !	KL < KM > KR	T	F	F	F		KR
  !	KL < KM > KR	T	F	T	T		KL
  !
  !	KL > KM < KR	F	T	F	T		KL
  !	KL > KM < KR	F	T	T	F		KR
  !
  if (mgtl .eqv. rgtm) then
    key = x(ix,m)
  else
    lgtr = x(ix,l) .gt. x(ix,r)
    if (mgtl .eqv. lgtr) then
      key = x(ix,l)
    else
      key = x(ix,r)
    endif
  endif
  i = l
  j = r
  !
  ! Find a big record on the left
10 if (x(ix,i).ge.key) goto 11
  i = i + 1
  goto 10
11 continue
  ! Find a small record on the right
20 if (x(ix,j).le.key) goto 21
  j = j - 1
  goto 20
21 continue
  if (i.ge.j) goto 2
  !
  ! Exchange records
  call r4tor4 (x(1,i),work,nd)
  call r4tor4 (x(1,j),x(1,i),nd)
  call r4tor4 (work,x(1,j),nd)
  i = i + 1
  j = j - 1
  goto 10
  !
  ! Subfile is partitioned into two halves, left .le. right
  ! Push the two halves on the stack
2 continue
  if (j-l+1 .gt. nstop) then
    sp = sp + 1
    if (sp.gt.maxstack) then
      write(6,*) 'E-SORT,  Stack overflow ',sp
      trione = 0
      return
    endif
    lstack(sp) = l
    rstack(sp) = j
  endif
  if (r-j .gt. nstop) then
    sp = sp + 1
    if (sp.gt.maxstack) then
      write(6,*) 'E-SORT,  Stack overflow ',sp
      trione = 0
      return
    endif
    lstack(sp) = j+1
    rstack(sp) = r
  endif
  !
  ! Anything left to process?
  if (sp.gt.0) goto 1
  !
50 continue
  !
  do j=n-1,1,-1
    k = j
    do i = j+1,n
      if (x(ix,j).le.x(ix,i)) exit ! I
      k = i
    enddo
    if (k.eq.j) cycle          ! J
    call r4tor4 (x(1,j),work,nd)
    do i = j+1,k
      call r4tor4 (x(1,i),x(1,i-1),nd)
    enddo
    call r4tor4 (work,x(1,k),nd)
  enddo                        ! J
end function trione
!
subroutine doapod (xmin,xmax,ymin,ymax,tole,beam,   &
     &    nc,nx,ny,map,raw,mapx,mapy, weight,wmax)
  real :: xmin                      !
  real :: xmax                      !
  real :: ymin                      !
  real :: ymax                      !
  real :: tole                      !
  real :: beam                      !
  integer :: nc                     !
  integer :: nx                     !
  integer :: ny                     !
  real :: map(nc,nx,ny)             !
  real :: raw(nc,nx,ny)             !
  real :: mapx(nx)                  !
  real :: mapy(ny)                  !
  real :: weight(nx,ny)             !
  real :: wmax                      !
  ! Local
  integer :: ic,ix,iy
  real :: lobe,apod,disty,distx,pi,wmin
  wmin = 0.02 * wmax
  !
  pi = acos(-1.0)
  write(6,*) 'Min-Max ',xmin,xmax,ymin,ymax
  write(6,*) 'Beam et Inc ',beam*180*3600/pi,tole*180*3600/pi   &
     &    ,(mapx(1)-mapx(2))*180*3600/pi
  ! Use a beam size twice larger
  lobe = log(2.0)/beam**2
  do iy=1,ny
    if (mapy(iy).le.ymin-tole) then
      disty = ymin-mapy(iy)
    elseif (mapy(iy).ge.ymax+tole) then
      disty = mapy(iy)-ymax
    else
      disty = 0.0
    endif
    do ix=1,nx
      if (mapx(ix).le.xmin-tole) then
        distx = xmin-mapx(ix)
      elseif (mapx(ix).ge.xmax+tole) then
        distx = mapx(ix)-xmax
      else
        distx = 0.0
      endif
      apod = (distx**2+disty**2)*lobe
      if (apod.ne.0.0) then
        apod = exp(-apod)
        do ic=1,nc
          map(ic,ix,iy) = map(ic,ix,iy)*apod
        enddo
      else
        if (weight(ix,iy).gt.wmin) then
          do ic=1,nc
            map(ic,ix,iy) = raw(ic,ix,iy)
          enddo
        endif
      endif
    enddo
  enddo
end subroutine doapod
!
function maxvec(a,n)
  real :: maxvec                    !
  real :: a(*)                      !
  integer :: n                      !
  ! Local
  real :: r
  integer :: i
  !
  r = 0.0
  do i =1,n
    r = max(r,a(i))
  enddo
  maxvec = r
end function maxvec
