program histo_table
  use gildas_def
  use image_def
  use gbl_format
  use gkernel_interfaces
  !---------------------------------------------------------------------
  ! Main program for making a cross Histogram from two columns of a
  ! table
  !---------------------------------------------------------------------
  ! Local
  character(len=*), parameter :: rname='HISTO_TABLE'
  character(len=filename_length) :: namey,namex
  logical :: error
  real(kind=4) :: hzmin,hzmax,hzstep, hymin,hymax,hystep
  integer(kind=4) :: n,nhz,nhy,nco(2),ier
  real(kind=4), allocatable :: xdata(:,:), yd1(:), yd2(:)
  type(gildas) :: x,y
  !
  call gildas_open
  call gildas_char('Y_NAME$',namey)
  call gildas_inte('Y_COLUMNS$',nco,2)
  call gildas_inte('BINS1$',nhz,1)
  call gildas_real('MIN1$',hzmin,1)
  call gildas_real('MAX1$',hzmax,1)
  call gildas_inte('BINS2$',nhy,1)
  call gildas_real('MIN2$',hymin,1)
  call gildas_real('MAX2$',hymax,1)
  call gildas_char('X_NAME$',namex)
  call gildas_close
  !
  ! Map input table
  call gildas_null(y)
  y%gil%ndim = 2
  call sic_parse_file(namey,' ','.tab',y%file)
  call gdf_read_header(y,error)
  if (error) goto 100
  if (nco(1).lt.1 .or. nco(1).gt.y%gil%dim(2) .or.  &
      nco(2).lt.1 .or. nco(2).gt.y%gil%dim(2)) then
    write(6,*) 'Input columns out of range 1 -',y%gil%dim(2)
    goto 100
  endif
  !
  ! Define output histogram
  call gildas_null(x)
  n = len_trim(namex)
  if (n.eq.0) goto 100
  call sic_parse_file(namex(1:n),' ','.gdf',x%file)
  hzstep = (hzmax-hzmin)/(nhz-1)
  hystep = (hymax-hymin)/(nhy-1)
  !
  x%gil%ndim = 2
  x%gil%dim(1) = nhz
  x%gil%dim(2) = nhy
  x%gil%dim(3) = 1
  x%gil%dim(4) = 1
  x%gil%coor_words = 6*gdf_maxdims
  x%gil%convert(1,1) = 1.0
  x%gil%convert(2,1) = hzmin
  x%gil%convert(3,1) = hzstep
  x%gil%convert(1,2) = 1.0
  x%gil%convert(2,2) = hymin
  x%gil%convert(3,2) = hystep
  x%gil%extr_words = 0
  x%gil%spec_words = 0
  x%gil%blan_words = 2
  x%gil%desc_words = def_desc_words
  x%gil%proj_words = 0
  x%gil%bval = 0.d0
  x%gil%eval = -1.d0
  x%char%code(1) = 'UNKNOWN     '
  x%char%code(2) = 'UNKNOWN     '
  x%char%code(3) = 'UNKNOWN     '
  x%char%code(4) = 'UNKNOWN     '
  x%char%unit    = 'PIXELS      '
  !
  ! Change boundaries
  hzmin = hzmin - 0.5*hzstep
  hzmax = hzmax + 0.5*hzstep
  hymin = hymin - 0.5*hystep
  hymax = hymax + 0.5*hystep
  allocate(xdata(x%gil%dim(1),x%gil%dim(2)),stat=ier)
  if (failed_allocate(rname,'output buffer',ier,error))  goto 100
  allocate(yd1(y%gil%dim(1)),yd2(y%gil%dim(1)),stat=ier)
  if (failed_allocate(rname,'input buffers',ier,error))  goto 100
  !
  y%blc(2) = nco(1)
  y%trc(2) = nco(1) 
  call gdf_read_data(y,yd1,error)
  if (error)  goto 100
  !
  y%blc(2) = nco(2)
  y%trc(2) = nco(2)
  call gdf_read_data(y,yd2,error)
  if (error)  goto 100
  !
  call histo004(yd1,yd2,y%gil%dim(1),0.0,-1.0,hzmin,hzstep,hzmax,hymin,  &
    hystep,hymax,x%gil%dim(1),x%gil%dim(2),xdata)
  !
  call gdf_write_image(x,xdata,error)
  if (error)  goto 100
  call gagout('S-HISTO_TABLE,  Successful completion')
  call sysexi(1)
  !
100 call sysexi(fatale)
end program histo_table
!
subroutine histo004(z,y,nl,bval,eval,pzmin,pzstep,pzmax,pymin,pystep,  &
  pymax,nhz,nhy,h)
  use gildas_def
  !---------------------------------------------------------------------
  ! Compute the crossed histogram map of two columns of a table.
  !---------------------------------------------------------------------
  integer(kind=index_length), intent(in)  :: nl          ! Number of lines
  real(kind=4),               intent(in)  :: z(nl)       ! First input column address
  real(kind=4),               intent(in)  :: y(nl)       ! Second input column address
  real(kind=4),               intent(in)  :: bval        ! Blanking value
  real(kind=4),               intent(in)  :: eval        ! Tolerance on blanking
  real(kind=4),               intent(in)  :: pzmin       ! Low threshold for Z input array
  real(kind=4),               intent(in)  :: pzstep      ! Histogram step for Z input array
  real(kind=4),               intent(in)  :: pzmax       !
  real(kind=4),               intent(in)  :: pymin       ! Low threshold for Y input array
  real(kind=4),               intent(in)  :: pystep      ! Histogram step for Y input array
  real(kind=4),               intent(in)  :: pymax       !
  integer(kind=index_length), intent(in)  :: nhz         ! First dimension for histogram array
  integer(kind=index_length), intent(in)  :: nhy         ! Second dimension for histogram array
  real(kind=4),               intent(out) :: h(nhz,nhy)  ! Histogram array
  ! Local
  integer(kind=index_length) :: i
  integer(kind=4) :: iz,jy,nin,nout,nblank,ntot
  !
  h = 0.0
  nin = 0
  nout = 0
  nblank = 0
  !
  if (eval.ge.0.0) then
    !
    do i=1,nl
      if (abs(z(i)-bval).gt.eval .and.   &
          abs(y(i)-bval).gt.eval) then
        if (z(i).ge.pzmin .and. z(i).lt.pzmax) then
          iz = int((z(i)-pzmin)/pzstep) + 1
          if (y(i).ge.pymin .and. y(i).lt.pymax) then
            jy = int((y(i)-pymin)/pystep) + 1
            h(iz,jy) = h(iz,jy)+1.0
            nin = nin+1
          else
            nout = nout+1
          endif
        else
          nout = nout+1
        endif
      else
        nblank = nblank+1
      endif
    enddo
    !
  else
    !
    do i=1,nl
      if (z(i).ge.pzmin .and. z(i).lt.pzmax) then
        iz = int((z(i)-pzmin)/pzstep) + 1
        if (y(i).ge.pymin .and. y(i).le.pymax) then
          jy = int((y(i)-pymin)/pystep) + 1
          h(iz,jy) = h(iz,jy)+1.0
          nin = nin+1
        else
          nout = nout+1
        endif
      else
        nout = nout+1
      endif
    enddo
    !
  endif
  !
  ntot = nin+nout+nblank
  write(6,100) nin,float(nin)/float(ntot)*1.e2,   &
               nout,float(nout)/float(ntot)*1.e2,   &
               nblank,float(nblank)/float(ntot)*1.e2,   &
               ntot
100 format(1x,'Number of points in histogram ',i12,4x,f5.1,' %',   &
            /,'  "    "    "    out of  "    ',i12,4x,f5.1,' %',  &
            /,'  "    "    "    blanked      ',i12,4x,f5.1,' %',  &
            /,'                 Total      = ',i12)
end subroutine histo004
