!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
module cubemain_histo2d
  use cube_types
  use cubetools_structure
  use cubetools_keyword_arg
  use cubeadm_cubeid_types
  use cubemain_messaging
  use cubemain_histogram
  !
  public :: histo2d
  public :: cubemain_histo2d_command
  private
  !
  type :: histo2d_comm_t
     type(option_t),      pointer :: comm
     type(option_t),      pointer :: xaxis
     type(keyword_arg_t), pointer :: xnbin_arg
     type(option_t),      pointer :: yaxis
     type(keyword_arg_t), pointer :: ynbin_arg
     type(option_t),      pointer :: blank     
     type(option_t),      pointer :: norm
   contains
     procedure, public  :: register => cubemain_histo2d_register
     procedure, private :: parse    => cubemain_histo2d_parse
     procedure, private :: main     => cubemain_histo2d_main
  end type histo2d_comm_t
  type(histo2d_comm_t) :: histo2d
  !
  integer(kind=4), parameter :: ixcub = 1 
  integer(kind=4), parameter :: iycub = 2
  type histo2d_user_t
     type(cubeid_user_t) :: cubeids
     type(histo_axis_user_t) :: xaxis
     type(histo_axis_user_t) :: yaxis
     logical :: donorm  = .true. ! Normalize histogram?
     logical :: doblank = .true. ! Blank empty bins?
   contains
     procedure, private :: toprog => cubemain_histo2d_user_toprog
  end type histo2d_user_t
  type histo2d_prog_t
     type(cube_t), pointer :: xcub
     type(cube_t), pointer :: ycub
     type(histo2d_t) :: histo2d
   contains
     procedure, private :: header => cubemain_histo2d_prog_header
     procedure, private :: data   => cubemain_histo2d_prog_data
     procedure, private :: loop   => cubemain_histo2d_prog_loop
     procedure, private :: image  => cubemain_histo2d_prog_image
  end type histo2d_prog_t
  !
contains
  !
  subroutine cubemain_histo2d_command(line,error)
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    character(len=*), intent(in)    :: line
    logical,          intent(inout) :: error
    !
    type(histo2d_user_t) :: user
    character(len=*), parameter :: rname='HISTO2D>COMMAND'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call histo2d%parse(line,user,error)
    if (error) return
    call histo2d%main(user,error)
    if (error) return
  end subroutine cubemain_histo2d_command
  !
  !----------------------------------------------------------------------
  !
  subroutine cubemain_histo2d_register(histo2d,error)
    use cubedag_allflags
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(histo2d_comm_t), intent(inout) :: histo2d
    logical,               intent(inout) :: error
    !
    type(cubeid_arg_t) :: cubearg
    character(len=*), parameter :: comm_abst = &
         'Compute the joint histogram of two cubes'
    character(len=*), parameter :: comm_help = &
         'Compute the joint histogram of two cubes'
    character(len=*), parameter :: rname='HISTO2D>REGISTER'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    ! Command
    call cubetools_register_command(&
         'HISTO2D','cube1 cube2',&
         comm_abst,&
         comm_help,&
         cubemain_histo2d_command,&
         histo2d%comm,error)
    if (error) return
    call cubearg%register(&
         'XCUBE',&
         'Input cube #1 used as X axis',  &
         strg_id,&
         code_arg_mandatory,&
         [flag_cube],&
         error)
    if (error) return
    call cubearg%register(&
         'YCUBE',&
         'Input cube #2 used as Y axis',&
         strg_id,&
         code_arg_mandatory,&
         [flag_cube],&
         error)
    if (error) return
    ! Option #1
    call cubetools_register_option(&
         'NORMALIZE','',&
         'Normalize histogram from counts to percentage',&
         strg_id,&
         histo2d%norm,error)
    if (error) return
    ! Option #2
    call cubetools_register_option(&
         'BLANK','',&
         'Set empty bins to NaN',&
         strg_id,&
         histo2d%blank,error)
    if (error) return
    ! Option #3
    call cubemain_histogram_axis_register_option('X',histo2d%xaxis,histo2d%xnbin_arg,error)
    if (error) return
    ! Option #4
    call cubemain_histogram_axis_register_option('Y',histo2d%yaxis,histo2d%ynbin_arg,error)
    if (error) return
  end subroutine cubemain_histo2d_register
  !
  subroutine cubemain_histo2d_parse(histo2d,line,user,error)
    use cubetools_parse
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(histo2d_comm_t), intent(in)    :: histo2d
    character(len=*),      intent(in)    :: line
    type(histo2d_user_t),  intent(out)   :: user
    logical,               intent(inout) :: error
    !
    character(len=*), parameter :: rname='HISTO2D>PARSE'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call histo2d%norm%present(line,user%donorm,error)
    if (error) return
    call histo2d%blank%present(line,user%doblank,error)
    if (error) return
!!$ *** JP This should be the right way of doing the following.
!!$    call cubemain_histogram_axis_parse(line,histo2d%xaxis,error)
!!$    if (error) return
    call cubemain_histogram_axis_parse(line,histo2d%xaxis,user%xaxis,error)
    if (error) return
    call cubemain_histogram_axis_parse(line,histo2d%yaxis,user%yaxis,error)
    if (error) return
    call cubeadm_cubeid_parse(line,histo2d%comm,user%cubeids,error)
    if (error) return
  end subroutine cubemain_histo2d_parse
  !
  subroutine cubemain_histo2d_main(histo2d,user,error)
    use cubeadm_timing
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(histo2d_comm_t), intent(in)    :: histo2d
    type(histo2d_user_t),  intent(inout) :: user
    logical,               intent(inout) :: error
    !
    type(histo2d_prog_t) :: prog
    character(len=*), parameter :: rname='HISTO2D>MAIN'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call user%toprog(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_histo2d_main
  !
  !----------------------------------------------------------------------
  !
  subroutine cubemain_histo2d_user_toprog(user,prog,error)
    use cubetools_consistency_methods
    use cubeadm_get
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(histo2d_user_t), intent(in)    :: user
    type(histo2d_prog_t),  intent(out)   :: prog
    logical,               intent(inout) :: error
    !
    logical :: prob
    character(len=*), parameter :: rname='HISTO2D>USER2PROG'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    prog%histo2d%donorm = user%donorm
    prog%histo2d%doblank = user%doblank
    !
    call cubeadm_cubeid_get_header(histo2d%comm,ixcub,user%cubeids,code_access_imaset,code_read,prog%xcub,error)
    if (error) return
    call cubeadm_cubeid_get_header(histo2d%comm,iycub,user%cubeids,code_access_imaset,code_read,prog%ycub,error)
    if (error) return
    !
    prob = .false.
    call cubetools_consistency_shape('Input cube #1',prog%xcub%head,'Input cube #2',prog%ycub%head,prob,error)
    if(error) return
    if (cubetools_consistency_failed(rname,prob,error)) return
    !
    call cubemain_histogram_axis_user2prog(prog%xcub,histo2d%xnbin_arg,user%xaxis,prog%histo2d%x,error)
    if (error) return
    call cubemain_histogram_axis_user2prog(prog%ycub,histo2d%ynbin_arg,user%yaxis,prog%histo2d%y,error)
    if (error) return
    call cubemain_histogram_axis_feedback(prog%histo2d%x,error)
    if (error) return
    call cubemain_histogram_axis_feedback(prog%histo2d%y,error)
    if (error) return
  end subroutine cubemain_histo2d_user_toprog
  !
  !----------------------------------------------------------------------
  !
  subroutine cubemain_histo2d_prog_header(prog,error)
    use cubetools_unit
    use cubetools_axis_types
    use cubetools_header_methods
    use cubedag_allflags
    use cubeadm_clone
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(histo2d_prog_t), intent(inout) :: prog
    logical,               intent(inout) :: error
    !
    type(axis_t) :: axis
    character(len=unit_l) :: unit
    character(len=*), parameter :: rname='HISTO2D>PROG>HEADER'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call cubeadm_clone_header(prog%xcub,flag_histo2d,prog%histo2d%cub,error)
    if (error) return
    ! Unit
    if (prog%histo2d%donorm) then
       call cubetools_header_put_array_unit('Percentage',prog%histo2d%cub%head,error)
       if (error) return
    else
       call cubetools_header_put_array_unit('Counts',prog%histo2d%cub%head,error)
       if (error) return
    endif
    ! x axis
    call cubetools_header_get_array_unit(prog%xcub%head,unit,error)
    if (error) return
    call cubetools_header_get_axis_head_l(prog%xcub%head,axis,error)
    if (error) return
    axis%name = strg_unk
    if (prog%histo2d%x%dolog) then
       ! *** JP huge risk of overflow here...
       ! Try to decrease potential overflow by only adding 'log ' at start.
       axis%unit = 'log '//trim(unit)
    else
       axis%unit = unit
    endif
    axis%kind = code_unit_unk
    axis%genuine = .true.
    axis%regular = .true.
    axis%n   = prog%histo2d%x%n
    axis%ref = 1.0
    axis%val = prog%histo2d%x%min
    axis%inc = prog%histo2d%x%inc
    call cubetools_header_update_axset_l(axis,prog%histo2d%cub%head,error)
    if (error) return
    ! y axis
    call cubetools_header_get_array_unit(prog%ycub%head,unit,error)
    if (error) return
    call cubetools_header_get_axis_head_m(prog%ycub%head,axis,error)
    if (error) return
    axis%name = strg_unk
    if (prog%histo2d%y%dolog) then
       ! *** JP huge risk of overflow here...
       ! Try to decrease potential overflow by only adding 'log ' at start.
       axis%unit = 'log '//trim(unit)
    else
       axis%unit = unit
    endif
    axis%kind = code_unit_unk
    axis%genuine = .true.
    axis%regular = .true.
    axis%n   = prog%histo2d%y%n
    axis%ref = 1.0
    axis%val = prog%histo2d%y%min
    axis%inc = prog%histo2d%y%inc
    call cubetools_header_update_axset_m(axis,prog%histo2d%cub%head,error)
    if (error) return
  end subroutine cubemain_histo2d_prog_header
  !
  subroutine cubemain_histo2d_prog_data(prog,error)
    use cubeadm_opened
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(histo2d_prog_t), intent(inout) :: prog
    logical,               intent(inout) :: error
    !
    type(cubeadm_iterator_t) :: iter
    character(len=*), parameter :: rname='HISTO2D>PROG>DATA'
    !
    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) FIRSTPRIVATE(iter,error)
       if (.not.error) &
         call prog%loop(iter%first,iter%last,error)
       !$OMP END TASK
    enddo ! ie
    !$OMP END SINGLE
    !$OMP END PARALLEL
  end subroutine cubemain_histo2d_prog_data
  !
  subroutine cubemain_histo2d_prog_loop(prog,first,last,error)
    use cubetools_nan
    use cubeadm_entryloop
    use cubemain_image_real
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(histo2d_prog_t), intent(inout) :: prog
    integer(kind=entr_k),  intent(in)    :: first
    integer(kind=entr_k),  intent(in)    :: last
    logical,               intent(inout) :: error
    !
    integer(kind=entr_k) :: ie
    type(image_t) :: xima,yima,histo2d
    character(len=*), parameter :: rname='HISTO2D>PROG>LOOP'
    !
    call xima%reallocate_and_init('xima',prog%xcub,gr4nan,error)
    if (error) return
    call yima%reallocate_and_init('yima',prog%ycub,gr4nan,error)
    if (error) return
    call histo2d%reallocate_and_init('histo2d',prog%histo2d%cub,0.0,error)
    if (error) return
    !
    do ie=first,last
      call cubeadm_entryloop_iterate(ie,error)
      if (error) return
      call prog%image(ie,xima,yima,histo2d,error)
      if (error) return
    enddo ! ie
  end subroutine cubemain_histo2d_prog_loop
  !
  subroutine cubemain_histo2d_prog_image(prog,ie,xima,yima,histo2d,error)
    use cubetools_nan
    use cubemain_image_real
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(histo2d_prog_t), intent(inout) :: prog
    integer(kind=entr_k),  intent(in)    :: ie
    type(image_t), target, intent(inout) :: xima
    type(image_t), target, intent(inout) :: yima
    type(image_t),         intent(inout) :: histo2d
    logical,               intent(inout) :: error
    !
    integer(kind=pixe_k) :: ix,iy
    integer(kind=pixe_k) :: jx,jy
    integer(kind=data_k) :: nin,nou,nblank
    real(kind=sign_k), pointer :: xval,yval
    character(len=*), parameter :: rname='HISTO2D>IMAGE'
    !
    ! Get data
    call xima%get(prog%xcub,ie,error)
    if (error) return
    call yima%get(prog%ycub,ie,error)
    if (error) return
    ! Transform it
    if (prog%histo2d%x%dolog) then
       do iy=1,xima%ny
          do ix=1,xima%nx
             xval => xima%z(ix,iy)
             xval = log10(xval)
          enddo ! iy
       enddo ! ix
    endif
    if (prog%histo2d%y%dolog) then
       do iy=1,xima%ny
          do ix=1,xima%nx
             yval => yima%z(ix,iy)
             yval = log10(yval)
          enddo ! iy
       enddo ! ix
    endif
    ! Compute histogram
    nin = 0
    nou = 0
    nblank = 0
    histo2d%z = 0.0
    do iy=1,xima%ny
       do ix=1,xima%nx
          xval => xima%z(ix,iy)
          yval => yima%z(ix,iy)
          if ((ieee_is_finite(xval)).and.(ieee_is_finite(yval))) then
             jx = nint((xval-prog%histo2d%x%min)/prog%histo2d%x%inc)
             jy = nint((yval-prog%histo2d%y%min)/prog%histo2d%y%inc)
             if ((1.le.jx).and.(jx.le.prog%histo2d%x%n).and.&
                  (1.le.jy).and.(jy.le.prog%histo2d%y%n)) then
                ! *** JP problem when many points?
                histo2d%z(jx,jy) = histo2d%z(jx,jy)+1.0
                nin = nin+1
             else
                nou = nou+1
             endif
          else
             nblank = nblank+1
          endif
       enddo ! iy
    enddo ! ix
    ! Blank empty bins when asked
    if (prog%histo2d%doblank) then
       do iy=1,prog%histo2d%y%n
          do ix=1,prog%histo2d%x%n
             if (histo2d%z(ix,iy).le.0.0) then
                histo2d%z(ix,iy) = gr4nan
             endif
          enddo ! iy
       enddo ! ix
    endif
    ! Normalize when asked
    if ((prog%histo2d%donorm).and.(nin.gt.0)) then
       do iy=1,prog%histo2d%y%n
          do ix=1,prog%histo2d%x%n
             histo2d%z(ix,iy) = 100d0*histo2d%z(ix,iy)/real(nin,kind=coor_k)
          enddo ! iy
       enddo ! ix
    endif
    call histo2d%put(prog%histo2d%cub,ie,error)
    if (error) return
  end subroutine cubemain_histo2d_prog_image
end module cubemain_histo2d
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
