!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
module cubehistogram_histo3d
  use cube_types
  use cubetools_parameters
  use cubetools_structure
  use cubetools_switch_types
  use cubeadm_cubeid_types
  use cubeadm_cubeprod_types
  use cubehistogram_messaging
  use cubehistogram_histoaxis_types
  !
  public :: histo3d
  private
  !
  type histo3d_t
     type(cube_t), pointer :: cube
     type(histoaxis_prog_t) :: x
     type(histoaxis_prog_t) :: y
     type(histoaxis_prog_t) :: z
     type(switch_prog_t) :: blank     ! Blank empty bins?
     type(switch_prog_t) :: normalize ! Normalize histogram?
     integer(kind=data_k):: nin = 0   ! Number of voxels inside the histogram
  end type histo3d_t
  !
  type :: histo3d_comm_t
     type(option_t),     pointer :: comm
     type(cubeid_arg_t), pointer :: xcube
     type(cubeid_arg_t), pointer :: ycube
     type(cubeid_arg_t), pointer :: zcube
     type(histoaxis_opt_t)       :: x
     type(histoaxis_opt_t)       :: y
     type(histoaxis_opt_t)       :: z
     type(switch_comm_t)         :: blank
     type(switch_comm_t)         :: normalize
     type(cube_prod_t),  pointer :: oucube
     type(cube_prod_t),  pointer :: pointer
   contains
     procedure, public  :: register => cubehistogram_histo3d_register
     procedure, private :: parse    => cubehistogram_histo3d_parse
     procedure, private :: main     => cubehistogram_histo3d_main
  end type histo3d_comm_t
  type(histo3d_comm_t) :: histo3d
  !
  type histo3d_user_t
     type(cubeid_user_t) :: cubeids
     type(histoaxis_user_t) :: x
     type(histoaxis_user_t) :: y
     type(histoaxis_user_t) :: z
     type(switch_user_t) :: blank
     type(switch_user_t) :: normalize
   contains
     procedure, private :: toprog => cubehistogram_histo3d_user_toprog
  end type histo3d_user_t
  !
  type histo3d_prog_t
     type(cube_t), pointer :: xcube   ! Input  cube used as histo3d x-axis
     type(cube_t), pointer :: ycube   ! Input  cube used as histo3d y-axis
     type(cube_t), pointer :: zcube   ! Input  cube used as histo3d y-axis
     type(cube_t), pointer :: pointer ! Output cube storing the position of the pixel in the 3D histogram
     type(histo3d_t) :: histo3d       ! Output 3D histogram
   contains
     procedure, private :: header   => cubehistogram_histo3d_prog_header
     procedure, private :: data     => cubehistogram_histo3d_prog_data
     procedure, private :: loop     => cubehistogram_histo3d_prog_loop
     procedure, private :: act      => cubehistogram_histo3d_prog_act
     procedure, private :: postloop => cubehistogram_histo3d_prog_postloop
  end type histo3d_prog_t
  !
contains
  !
  subroutine cubehistogram_histo3d_command(line,error)
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    character(len=*), intent(in)    :: line
    logical,          intent(inout) :: error
    !
    type(histo3d_user_t) :: user
    character(len=*), parameter :: rname='HISTO3D>COMMAND'
    !
    call cubehistogram_message(histogramseve%trace,rname,'Welcome')
    !
    call histo3d%parse(line,user,error)
    if (error) return
    call histo3d%main(user,error)
    if (error) return
  end subroutine cubehistogram_histo3d_command
  !
  !----------------------------------------------------------------------
  !
  subroutine cubehistogram_histo3d_register(histo3d,error)
    use cubedag_allflags
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(histo3d_comm_t), intent(inout) :: histo3d
    logical,               intent(inout) :: error
    !
    type(cubeid_arg_t) :: cubearg
    type(cube_prod_t) :: oucube
    character(len=*), parameter :: comm_abst = &
         'Compute the joint histogram of three cubes'
    character(len=*), parameter :: comm_help = strg_id
    character(len=*), parameter :: rname='HISTO3D>REGISTER'
    !
    call cubehistogram_message(histogramseve%trace,rname,'Welcome')
    !
    ! Command
    call cubetools_register_command(&
         'HISTO3D','xcube ycube zcube',&
         comm_abst,&
         comm_help,&
         cubehistogram_histo3d_command,&
         histo3d%comm,error)
    if (error) return
    call cubearg%register(&
         'XCUBE',&
         'Input cube #1 used as X axis',  &
         strg_id,&
         code_arg_mandatory,&
         [flag_cube],&
         code_read,&
         code_access_imaset,&
         histo3d%xcube,&
         error)
    if (error) return
    call cubearg%register(&
         'YCUBE',&
         'Input cube #2 used as Y axis',&
         strg_id,&
         code_arg_mandatory,&
         [flag_cube],&
         code_read,&
         code_access_imaset,&
         histo3d%ycube,&
         error)
    if (error) return
    call cubearg%register(&
         'ZCUBE',&
         'Input cube #3 used as Z axis',&
         strg_id,&
         code_arg_mandatory,&
         [flag_cube],&
         code_read,&
         code_access_imaset,&
         histo3d%zcube,&
         error)
    if (error) return
    !
    call histo3d%x%register('X',error)
    if (error) return
    ! 
    call histo3d%y%register('Y',error)
    if (error) return
    ! 
    call histo3d%z%register('Z',error)
    if (error) return
    ! 
    call histo3d%blank%register(&
         'BLANK','setting empty bins to NaN',&
         'ON',error)
    if (error) return
    ! 
    call histo3d%normalize%register(&
         'NORMALIZE','histogram normalization from counts to %',&
         'OFF',error)
    if (error) return
    !
    ! Products
    call oucube%register(&
         'HISTO3D',&
         'Joint histogram',&
         strg_id,&
         [flag_histo3d],&
         histo3d%oucube,&
         error,&
         access=code_access_fullset)
    if (error) return
    call oucube%register(&
         'Pointer',&
         'Positions back pointer',&
         strg_id,&
         [flag_histo3d,flag_pointer],&
         histo3d%pointer,&
         error)
    if (error) return
  end subroutine cubehistogram_histo3d_register
  !
  subroutine cubehistogram_histo3d_parse(comm,line,user,error)
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(histo3d_comm_t), intent(inout) :: comm
    character(len=*),      intent(in)    :: line
    type(histo3d_user_t),  intent(out)   :: user
    logical,               intent(inout) :: error
    !
    character(len=*), parameter :: rname='HISTO3D>PARSE'
    !
    call cubehistogram_message(histogramseve%trace,rname,'Welcome')
    !
    call cubeadm_cubeid_parse(line,comm%comm,user%cubeids,error)
    if (error) return
    call comm%x%parse(line,user%x,error)
    if (error) return
    call comm%y%parse(line,user%y,error)
    if (error) return
    call comm%z%parse(line,user%z,error)
    if (error) return
    call comm%blank%parse(line,user%blank,error)
    if (error) return
    call comm%normalize%parse(line,user%normalize,error)
    if (error) return
  end subroutine cubehistogram_histo3d_parse
  !
  subroutine cubehistogram_histo3d_main(comm,user,error)
    use cubeadm_timing
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(histo3d_comm_t), intent(in)    :: comm
    type(histo3d_user_t),  intent(inout) :: user
    logical,               intent(inout) :: error
    !
    type(histo3d_prog_t) :: prog
    character(len=*), parameter :: rname='HISTO3D>MAIN'
    !
    call cubehistogram_message(histogramseve%trace,rname,'Welcome')
    !
    call user%toprog(comm,prog,error)
    if (error) return
    call prog%header(comm,error)
    if (error) return
    call cubeadm_timing_prepro2process()
    call prog%data(error)
    if (error) return
    call cubeadm_timing_process2postpro()
  end subroutine cubehistogram_histo3d_main
  !
  !----------------------------------------------------------------------
  !
  subroutine cubehistogram_histo3d_user_toprog(user,comm,prog,error)
    use cubetools_consistency_methods
    use cubeadm_get
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(histo3d_user_t), intent(in)    :: user
    type(histo3d_comm_t),  intent(in)    :: comm
    type(histo3d_prog_t),  intent(out)   :: prog
    logical,               intent(inout) :: error
    !
    logical :: prob
    character(len=*), parameter :: rname='HISTO3D>USER2PROG'
    !
    call cubehistogram_message(histogramseve%trace,rname,'Welcome')
    !
    call cubeadm_get_header(histo3d%xcube,user%cubeids,prog%xcube,error)
    if (error) return
    call cubeadm_get_header(histo3d%ycube,user%cubeids,prog%ycube,error)
    if (error) return
    call cubeadm_get_header(histo3d%zcube,user%cubeids,prog%zcube,error)
    if (error) return
    !
    prob = .false.
    call cubetools_consistency_shape('Input cube #1',prog%xcube%head,'Input cube #2',prog%ycube%head,prob,error)
    if (error) return
    if (cubetools_consistency_failed(rname,prob,error)) return
    call cubetools_consistency_shape('Input cube #1',prog%xcube%head,'Input cube #3',prog%zcube%head,prob,error)
    if (error) return
    if (cubetools_consistency_failed(rname,prob,error)) return
    !
    call user%x%toprog(comm%x,prog%xcube,prog%histo3d%x,error)
    if (error) return
    call user%y%toprog(comm%y,prog%ycube,prog%histo3d%y,error)
    if (error) return
    call user%z%toprog(comm%z,prog%zcube,prog%histo3d%z,error)
    if (error) return
    call prog%histo3d%x%list(error)
    if (error) return
    call prog%histo3d%y%list(error)
    if (error) return
    call prog%histo3d%z%list(error)
    if (error) return
    !
    call prog%histo3d%normalize%init(comm%normalize,error)
    if (error) return
    call user%normalize%toprog(comm%normalize,prog%histo3d%normalize,error)
    if (error) return
    call prog%histo3d%blank%init(comm%blank,error)
    if (error) return
    call user%blank%toprog(comm%blank,prog%histo3d%blank,error)
    if (error) return
  end subroutine cubehistogram_histo3d_user_toprog
  !
  !----------------------------------------------------------------------
  !
  subroutine cubehistogram_histo3d_prog_header(prog,comm,error)
    use cubetools_unit
    use cubetools_axis_types
    use cubetools_header_methods
    use cubeadm_clone
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(histo3d_prog_t), intent(inout) :: prog
    type(histo3d_comm_t),  intent(in)    :: comm
    logical,               intent(inout) :: error
    !
    type(axis_t) :: axis
    character(len=unit_l) :: unit
    character(len=*), parameter :: rname='HISTO3D>PROG>HEADER'
    !
    call cubehistogram_message(histogramseve%trace,rname,'Welcome')
    !
    call cubeadm_clone_header(comm%pointer,prog%xcube,prog%pointer,error)
    if (error) return
    call cubeadm_clone_header(comm%oucube,prog%xcube,prog%histo3d%cube,error)
    if (error) return
    ! Unit
    if (prog%histo3d%normalize%enabled) then
       call cubetools_header_put_array_unit('%',prog%histo3d%cube%head,error)
       if (error) return
    else
       call cubetools_header_put_array_unit('Counts',prog%histo3d%cube%head,error)
       if (error) return
    endif
    ! X axis
    call cubetools_header_get_array_unit(prog%xcube%head,unit,error)
    if (error) return
    call cubetools_header_get_axis_head_l(prog%xcube%head,axis,error)
    if (error) return
    axis%name = 'X'
    if (prog%histo3d%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%histo3d%x%n
    axis%ref = 1.0
    axis%val = prog%histo3d%x%min
    axis%inc = prog%histo3d%x%inc
    call cubetools_header_update_axset_l(axis,prog%histo3d%cube%head,error)
    if (error) return
    ! Y axis
    call cubetools_header_get_array_unit(prog%ycube%head,unit,error)
    if (error) return
    call cubetools_header_get_axis_head_m(prog%ycube%head,axis,error)
    if (error) return
    axis%name = 'Y'
    if (prog%histo3d%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%histo3d%y%n
    axis%ref = 1.0
    axis%val = prog%histo3d%y%min
    axis%inc = prog%histo3d%y%inc
    call cubetools_header_update_axset_m(axis,prog%histo3d%cube%head,error)
    if (error) return
    ! Z axis
    call cubetools_header_get_array_unit(prog%zcube%head,unit,error)
    if (error) return
    call cubetools_header_get_axis_head_c(prog%zcube%head,axis,error)
    if (error) return
    axis%name = 'Z'
    if (prog%histo3d%z%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%histo3d%z%n
    axis%ref = 1.0
    axis%val = prog%histo3d%z%min
    axis%inc = prog%histo3d%z%inc
    call cubetools_header_update_axset_c(axis,prog%histo3d%cube%head,error)
    if (error) return
  end subroutine cubehistogram_histo3d_prog_header
  !
  subroutine cubehistogram_histo3d_prog_data(prog,error)
    use cubeadm_opened
    use cubeadm_fullcube_types
    !----------------------------------------------------------------------
    ! Removed parallelization because the histo3d can not be written by
    ! several threads at the same time
    !----------------------------------------------------------------------
    class(histo3d_prog_t), intent(inout) :: prog
    logical,               intent(inout) :: error
    !
    type(fullcube_t) :: histo3d
    type(cubeadm_iterator_t) :: iter
    character(len=*), parameter :: rname='HISTO3D>PROG>DATA'
    !
    call cubehistogram_message(histogramseve%trace,rname,'Welcome')
    !
    call cubeadm_datainit_all(iter,error)
    if (error) return
    call histo3d%allocate('histo3d',prog%histo3d%cube,error)
    if (error) return
    do while (cubeadm_dataiterate_all(iter,error))
       if (error) exit
       if (.not.error) &
         call prog%loop(iter,histo3d,error)
    enddo ! iter
    !
    call prog%postloop(histo3d,error)
    if (error) return
  end subroutine cubehistogram_histo3d_prog_data
  !
  subroutine cubehistogram_histo3d_prog_loop(prog,iter,histo3d,error)
    use cubeadm_taskloop
    use cubeadm_image_types
    use cubeadm_fullcube_types
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(histo3d_prog_t),    intent(inout) :: prog
    type(cubeadm_iterator_t), intent(inout) :: iter
    type(fullcube_t),         intent(inout) :: histo3d
    logical,                  intent(inout) :: error
    !
    type(image_t) :: xima,yima,zima,pima
    character(len=*), parameter :: rname='HISTO3D>PROG>LOOP'
    !
    ! The allocation of xima, yima, and zima allows me to take the logarithm of the inputs
    call xima%allocate('xima',prog%xcube,iter,error)
    if (error) return
    call yima%allocate('yima',prog%ycube,iter,error)
    if (error) return
    ! *** JP => segfault when zima%allocate is replaced by yima%allocate
    call zima%allocate('zima',prog%zcube,iter,error)
    if (error) return
    call pima%allocate('pointer image',prog%pointer,iter,error)
    if (error) return
    !
    do while (iter%iterate_entry(error))
      call prog%act(iter%ie,xima,yima,zima,pima,histo3d,error)
      if (error) return
    enddo ! ie
  end subroutine cubehistogram_histo3d_prog_loop
  !
  subroutine cubehistogram_histo3d_prog_act(prog,ie,xima,yima,zima,pima,histo3d,error)
    use cubetools_nan
    use cubeadm_image_types
    use cubeadm_fullcube_types
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(histo3d_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), target, intent(inout) :: zima
    type(image_t),         intent(inout) :: pima
    type(fullcube_t),      intent(inout) :: histo3d
    logical,               intent(inout) :: error
    !
    integer(kind=pixe_k) :: ix,iy
    integer(kind=pixe_k) :: jx,jy,jz
    integer(kind=data_k) :: nou,nblank
    real(kind=sign_k), pointer :: xval,yval,zval
    character(len=*), parameter :: rname='HISTO3D>ACT'
    !
    ! Get data
    call xima%get(ie,error)
    if (error) return
    call yima%get(ie,error)
    if (error) return
    call zima%get(ie,error)
    if (error) return
    ! Transform it
    if (prog%histo3d%x%dolog) then
       do iy=1,xima%ny
          do ix=1,xima%nx
             xval => xima%val(ix,iy)
             xval = log10(xval)
          enddo ! iy
       enddo ! ix
    endif
    if (prog%histo3d%y%dolog) then
       do iy=1,xima%ny
          do ix=1,xima%nx
             yval => yima%val(ix,iy)
             yval = log10(yval)
          enddo ! iy
       enddo ! ix
    endif
    if (prog%histo3d%z%dolog) then
       do iy=1,xima%ny
          do ix=1,xima%nx
             zval => zima%val(ix,iy)
             zval = log10(zval)
          enddo ! iy
       enddo ! ix
    endif
    ! Compute histogram
    nou = 0
    nblank = 0
    prog%histo3d%nin = 0
    histo3d%val = 0.0
    pima%val = 0
    do iy=1,xima%ny
       do ix=1,xima%nx
          xval => xima%val(ix,iy)
          yval => yima%val(ix,iy)
          zval => zima%val(ix,iy)
          if ((ieee_is_finite(xval)).and.(ieee_is_finite(yval)).and.(ieee_is_finite(zval))) then
             jx = nint((xval-prog%histo3d%x%min)/prog%histo3d%x%inc)
             jy = nint((yval-prog%histo3d%y%min)/prog%histo3d%y%inc)
             jz = nint((zval-prog%histo3d%z%min)/prog%histo3d%z%inc)
             if ((1.le.jx).and.(jx.le.prog%histo3d%x%n).and.&
                  (1.le.jy).and.(jy.le.prog%histo3d%y%n).and.&
                  (1.le.jz).and.(jz.le.prog%histo3d%z%n)) then
                ! *** JP problem when many points?
                pima%val(ix,iy) = jx+(jy-1)*pima%nx+(jz-1)*pima%nx*pima%ny
                histo3d%val(jx,jy,jz) = histo3d%val(jx,jy,jz)+1.0
                prog%histo3d%nin = prog%histo3d%nin+1
             else
                nou = nou+1
             endif
          else
             nblank = nblank+1
          endif
       enddo ! iy
    enddo ! ix
    ! Put result
    call pima%put(ie,error)
    if (error) return
  end subroutine cubehistogram_histo3d_prog_act
  !
  subroutine cubehistogram_histo3d_prog_postloop(prog,histo3d,error)
    use cubetools_nan
    use cubeadm_fullcube_types
    !----------------------------------------------------------------------
    ! 
    !----------------------------------------------------------------------
    class(histo3d_prog_t), intent(inout) :: prog
    type(fullcube_t),      intent(inout) :: histo3d
    logical,               intent(inout) :: error
    !
    integer(kind=data_k) :: ix,iy,iz
    character(len=*), parameter :: rname='HISTO3D>PROG>POSTLOOP'
    !
    call cubehistogram_message(histogramseve%trace,rname,'Welcome')
    !
    ! Blank empty bins when asked
    if (prog%histo3d%blank%enabled) then
       do iz=1,prog%histo3d%z%n
          do iy=1,prog%histo3d%y%n
             do ix=1,prog%histo3d%x%n
                if (histo3d%val(ix,iy,iz).le.0.0) then
                   histo3d%val(ix,iy,iz) = gr4nan
                endif
             enddo ! ix
          enddo ! iy
       enddo ! iz
    endif
    ! Normalize when asked
    if ((prog%histo3d%normalize%enabled).and.(prog%histo3d%nin.gt.0)) then
       do iz=1,prog%histo3d%z%n
          do iy=1,prog%histo3d%y%n
             do ix=1,prog%histo3d%x%n
                histo3d%val(ix,iy,iz) = 100d0*histo3d%val(ix,iy,iz)/real(prog%histo3d%nin,kind=coor_k)
             enddo ! ix
          enddo ! iy
       enddo ! iz
    endif
    ! Put result
    call histo3d%put(error)
    if (error) return
  end subroutine cubehistogram_histo3d_prog_postloop
end module cubehistogram_histo3d
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
