!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
module cubestatistics_histo1d
  use cube_types
  use cubetools_parameters
  use cubetools_structure
  use cubetools_switch_types
  use cubeadm_cubeid_types
  use cubemain_range
  use cubestatistics_messaging
  use cubestatistics_histoaxis_types
  !
  public :: histo1d
  public :: cubestatistics_histo1d_command
  private
  !
  type histo1d_t
     type(cube_t), pointer :: cube
     type(histoaxis_prog_t) :: x
     type(switch_prog_t) :: blank     ! Blank empty bins?
     type(switch_prog_t) :: normalize ! Normalize histogram?
  end type histo1d_t
  !
  type :: histo1d_comm_t
     type(option_t), pointer :: comm
     type(histoaxis_opt_t) :: x
     type(switch_opt_t) :: blank
     type(switch_opt_t) :: normalize
   contains
     procedure, public  :: register => cubestatistics_histo1d_register
     procedure, private :: parse    => cubestatistics_histo1d_parse
     procedure, private :: main     => cubestatistics_histo1d_main
  end type histo1d_comm_t
  type(histo1d_comm_t) :: histo1d
  !
  integer(kind=4), parameter :: ixcube = 1
  type histo1d_user_t
     type(cubeid_user_t)   :: cubeids
     type(histoaxis_user_t) :: x
     type(switch_user_t) :: blank
     type(switch_user_t) :: normalize
   contains
     procedure, private :: toprog => cubestatistics_histo1d_user_toprog
  end type histo1d_user_t
  !
  type histo1d_prog_t
     type(cube_t), pointer :: xcube ! Input cube used as histo1d x-axis
     type(histo1d_t) :: histo1d     ! Output 1D histogram
   contains
     procedure, private :: header => cubestatistics_histo1d_prog_header
     procedure, private :: data   => cubestatistics_histo1d_prog_data
     procedure, private :: loop   => cubestatistics_histo1d_prog_loop
     procedure, private :: act    => cubestatistics_histo1d_prog_act
  end type histo1d_prog_t
  !
contains
  !
  subroutine cubestatistics_histo1d_command(line,error)
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    character(len=*), intent(in)    :: line
    logical,          intent(inout) :: error
    !
    type(histo1d_user_t) :: user
    character(len=*), parameter :: rname='HISTO1D>COMMAND'
    !
    call cubestatistics_message(statisticsseve%trace,rname,'Welcome')
    !
    call histo1d%parse(line,user,error)
    if (error) return
    call histo1d%main(user,error)
    if (error) continue
  end subroutine cubestatistics_histo1d_command
  !
  !----------------------------------------------------------------------
  !
  subroutine cubestatistics_histo1d_register(histo1d,error)
    use cubedag_allflags
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(histo1d_comm_t), intent(inout) :: histo1d
    logical,               intent(inout) :: error
    !
    type(cubeid_arg_t) :: cubearg
    character(len=*), parameter :: comm_abstract = &
         'Compute the histogram of a cube'  
    character(len=*), parameter :: comm_help = &
         'The bins are sampled following a linear or logarithmic&
         & scale. The number of bins are automatically computed using&
         & the ??? heuristic or defined by the user. The histogram&
         & can be normalized.'
    character(len=*), parameter :: opt_lin_help = &
         'With this option bins are equally spaced on a linear scale.&
         & Min and Max are by default the minimum and maximum of the&
         & input cube'
    character(len=*), parameter :: opt_log_help = &
         'With this option bins are equally spaced on a log10 scale.&
         & The Maximum value is by default the maximum of cubname and&
         & the default value for range is 1000. The minimum value to be&
         & taken into account for the histogram is: min=max/range.'
    character(len=*), parameter :: opt_nbin_help = &      
         'This option defines the number of bins to be used. Its&
         & argument can be a positive integer or one of 3 methods: RICE,&
         & STURGES or SQRT. If this option is not given explicitly by&
         & the user the number of bins defaults to the value defined by&
         & the STURGES method.'
    !   The number of bins is defined by each&
    !        & method as demonstrated in the table below, where n is the&
    !        & number of valid values in cubname (nl*nm*nc-nnans)
    ! .nf
    !  | Method  | Nbins              |
    !  |---------+--------------------| 
    !  | RICE    | ceiling(2n**(1/3)) |
    !  | STURGES | ceiling(log2(n))+1 |
    !  | SQRT    | ceiling(sqrt(n))   |
    ! .nf
    character(len=*), parameter :: opt_norm_help = &
         'Normalize the histogram to 1 by dividing the number of counts&
         & in each bin by the total number of counts in the histogram.'  
    !
    character(len=*), parameter :: rname='HISTO1D>REGISTER'
    !
    call cubestatistics_message(statisticsseve%trace,rname,'Welcome')
    !
    ! Command
    call cubetools_register_command(&
         'HISTO1D','cube',&
         comm_abstract,&
         comm_help,&
         cubestatistics_histo1d_command,&
         histo1d%comm,error)
    if (error) return
    call cubearg%register(&
         'XCUBE',&
         'Input cube used as X axis',&
         strg_id,&
         code_arg_optional,&
         [flag_cube],&
         error)
    if (error) return
    !
    call histo1d%x%register('X',error)
    if (error) return
    ! 
    call histo1d%blank%register(&
         'BLANK','setting empty bins to NaN',&
         'ON',error)
    if (error) return
    ! 
    call histo1d%normalize%register(&
         'NORMALIZE','histogram normalization from counts to %',&
         'OFF',error)
    if (error) return
  end subroutine cubestatistics_histo1d_register
  !
  subroutine cubestatistics_histo1d_parse(comm,line,user,error)
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(histo1d_comm_t), intent(inout) :: comm
    character(len=*),      intent(in)    :: line
    type(histo1d_user_t),  intent(out)   :: user
    logical,               intent(inout) :: error
    !
    character(len=*), parameter :: rname='HISTO1D>PARSE'
    !
    call cubestatistics_message(statisticsseve%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%blank%parse(line,user%blank,error)
    if (error) return
    call comm%normalize%parse(line,user%normalize,error)
    if (error) return
  end subroutine cubestatistics_histo1d_parse
  !
  subroutine cubestatistics_histo1d_main(comm,user,error)
    use cubeadm_timing
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(histo1d_comm_t), intent(in)    :: comm
    type(histo1d_user_t),  intent(in)    :: user
    logical,               intent(inout) :: error
    !
    type(histo1d_prog_t) :: prog
    character(len=*), parameter :: rname='HISTO1D>MAIN'
    !
    call cubestatistics_message(statisticsseve%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 cubestatistics_histo1d_main
  !
  !------------------------------------------------------------------------
  !
  subroutine cubestatistics_histo1d_user_toprog(user,comm,prog,error)
    use cubetools_nan
    use cubeadm_get
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(histo1d_user_t), intent(in)    :: user
    type(histo1d_comm_t),  intent(in)    :: comm
    type(histo1d_prog_t),  intent(out)   :: prog
    logical,               intent(inout) :: error
    !
    character(len=*), parameter :: rname='HISTO1D>USER>TOPROG'
    !
    call cubestatistics_message(statisticsseve%trace,rname,'Welcome')
    !
    call cubeadm_cubeid_get_header(histo1d%comm,ixcube,user%cubeids,&
         code_access_imaset,code_read,prog%xcube,error)
    if (error) return
    !
    call user%x%toprog(comm%x,prog%xcube,prog%histo1d%x,error)
    if (error) return
    call prog%histo1d%x%list(error)
    if (error) return
    !
    call prog%histo1d%normalize%init(comm%normalize,error)
    if (error) return
    call user%normalize%toprog(comm%normalize,prog%histo1d%normalize,error)
    if (error) return
    call prog%histo1d%blank%init(comm%blank,error)
    if (error) return
    call user%blank%toprog(comm%blank,prog%histo1d%blank,error)
    if (error) return
  end subroutine cubestatistics_histo1d_user_toprog
  !
  !----------------------------------------------------------------------
  !
  subroutine cubestatistics_histo1d_prog_header(prog,error)
    use cubetools_unit
    use cubetools_axis_types
    use cubetools_header_methods
    use cubedag_allflags
    use cubeadm_clone
    !----------------------------------------------------------------------
    ! 
    !----------------------------------------------------------------------
    class(histo1d_prog_t), intent(inout) :: prog
    logical,               intent(inout) :: error
    !
    type(axis_t) :: axis
    character(len=unit_l) :: unit
    character(len=*), parameter :: rname='HISTO1D>PROG>HEADER'
    !
    call cubestatistics_message(statisticsseve%trace,rname,'Welcome')
    !
    call cubeadm_clone_header(prog%xcube,flag_histo1d,prog%histo1d%cube,error)
    if (error) return
    ! Unit
    if (prog%histo1d%normalize%enabled) then
       call cubetools_header_put_array_unit('%',prog%histo1d%cube%head,error)
       if (error) return
    else
       call cubetools_header_put_array_unit('Counts',prog%histo1d%cube%head,error)
       if (error) return
    endif
    ! l axis will be used as the histogram 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%histo1d%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%histo1d%x%n
    axis%ref = 1.0
    axis%val = prog%histo1d%x%min
    axis%inc = prog%histo1d%x%inc
    call cubetools_header_update_axset_l(axis,prog%histo1d%cube%head,error)
    if (error) return
    ! m axes
    call cubetools_header_nullify_axset_m(prog%histo1d%cube%head,error)
    if (error) return
  end subroutine cubestatistics_histo1d_prog_header
  !
  subroutine cubestatistics_histo1d_prog_data(prog,error)
    use cubeadm_opened
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(histo1d_prog_t), intent(inout) :: prog
    logical,               intent(inout) :: error
    !
    type(cubeadm_iterator_t) :: iter
    character(len=*), parameter :: rname='HISTO1D>PROG>DATA'
    !
    call cubestatistics_message(statisticsseve%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 cubestatistics_histo1d_prog_data
  !
  !----------------------------------------------------------------------
  !
  subroutine cubestatistics_histo1d_prog_loop(prog,iter,error)
    use gkernel_interfaces
    use cubeadm_taskloop
    use cubeadm_image_types
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(histo1d_prog_t),    intent(inout) :: prog
    type(cubeadm_iterator_t), intent(inout) :: iter
    logical,                  intent(inout) :: error
    !
    type(image_t) :: xima,histo1d
    character(len=*), parameter :: rname='HISTO1D>PROG>LOOP'
    !
    call cubestatistics_message(statisticsseve%trace,rname,'Welcome')
    !
    ! The allocation of xima allows me to take the logarithm of the input
    call xima%allocate('xima',prog%xcube,iter,error)
    if (error) return
    call histo1d%allocate('histo1d',prog%histo1d%cube,iter,error)
    if (error) return
    !
    do while (iter%iterate_entry(error))
      call prog%act(iter%ie,xima,histo1d,error)
      if (error) return
    enddo ! ie
  end subroutine cubestatistics_histo1d_prog_loop
  !
  subroutine cubestatistics_histo1d_prog_act(prog,ie,xima,histo1d,error)
    use cubetools_nan
    use cubeadm_image_types
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(histo1d_prog_t), intent(inout) :: prog
    integer(kind=entr_k),  intent(in)    :: ie
    type(image_t), target, intent(inout) :: xima
    type(image_t),         intent(inout) :: histo1d
    logical,               intent(inout) :: error
    !
    integer(kind=pixe_k) :: ix,iy
    integer(kind=pixe_k) :: jx
    integer(kind=pixe_k), parameter :: one=1
    integer(kind=data_k) :: nin,nou,nblank
    real(kind=sign_k), pointer :: xval
    character(len=*), parameter :: rname='HISTO1D>PROG>ACT'
    !
    call cubestatistics_message(statisticsseve%trace,rname,'Welcome')
    !
    ! Get data
    call xima%get(ie,error)
    if (error) return
    ! Transform it
    if (prog%histo1d%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
    ! Compute histogram
    nin = 0
    nou = 0
    nblank = 0
    histo1d%val = 0.0
    do iy=1,xima%ny
       do ix=1,xima%nx
          xval => xima%val(ix,iy)
          if (ieee_is_finite(xval)) then
             jx = nint((xval-prog%histo1d%x%min)/prog%histo1d%x%inc)
             if ((1.le.jx).and.(jx.le.prog%histo1d%x%n)) then
                ! *** JP problem when many points?
                histo1d%val(jx,one) = histo1d%val(jx,one)+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%histo1d%blank%enabled) then
       do ix=1,prog%histo1d%x%n
          if (histo1d%val(ix,one).le.0.0) then
             histo1d%val(ix,one) = gr4nan
          endif
       enddo ! ix
    endif
    ! Normalize when asked
    if ((prog%histo1d%normalize%enabled).and.(nin.gt.0)) then
       do ix=1,prog%histo1d%x%n
          histo1d%val(ix,one) = 100d0*histo1d%val(ix,one)/real(nin,kind=coor_k)
       enddo ! ix
    endif
    ! Put result
    call histo1d%put(ie,error)
    if (error) return
  end subroutine cubestatistics_histo1d_prog_act
end module cubestatistics_histo1d
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
