!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
module cubefield_derivative_tool
  use cubetools_parameters
  use cubefield_messaging
  !
  public :: derivative_1d_prog_t,derivative_2d_prog_t
  private
  !
  type derivative_1d_prog_t
     integer(kind=indx_k) :: n = 0      ! Number of pixels along derivative axis
     integer(kind=indx_k) :: i = 0      ! Number of pixels used in derivative computation
     real(kind=coor_k)    :: inc = 0d0  ! Increment value
   contains
     procedure, public :: init => derivative_1d_prog_init
     procedure, public :: list => derivative_1d_prog_list
  end type derivative_1d_prog_t
  !
  type derivative_2d_prog_t
     type(derivative_1d_prog_t) :: x
     type(derivative_1d_prog_t) :: y
   contains
     procedure, public :: init => derivative_2d_prog_init
     procedure, public :: list => derivative_2d_prog_list
  end type derivative_2d_prog_t
  !
contains
  !
  subroutine derivative_1d_prog_init(d,cube,iaxis,error)
    use phys_const
    use cube_types
    use cubetools_axis_types
    use cubetools_header_methods
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(derivative_1d_prog_t), intent(out)   :: d
    type(cube_t),                intent(in)    :: cube
    integer(kind=ndim_k),        intent(in)    :: iaxis
    logical,                     intent(inout) :: error
    !
    type(axis_t) :: axis
    character(len=*), parameter :: rname='DERIVATIVE>1D>PROG>INIT'
    !
    call cubefield_message(fieldseve%trace,rname,'Welcome')
    !
    call cubetools_header_get_axis_head(iaxis,cube%head,axis,error)
    if (error) return
    d%n = axis%n
    d%i = 1 ! *** JP: should be customizable depending on the angular resolution
    d%inc = (2*d%i)*axis%inc
    d%inc = d%inc*sec_per_rad ! *** JP: should use the current angle unit
  end subroutine derivative_1d_prog_init
  !
  subroutine derivative_1d_prog_list(d,error)
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(derivative_1d_prog_t), intent(in)    :: d
    logical,                     intent(inout) :: error
    !
    character(len=*), parameter :: rname='DERIVATIVE>1D>PROG>LIST'
    !
    call cubefield_message(fieldseve%trace,rname,'Welcome')
    !
    print *,'Axis number of pixels',d%n
    print *,'Derivative increment',d%i,d%inc
  end subroutine derivative_1d_prog_list
  !
  !------------------------------------------------------------------------
  !
  subroutine derivative_2d_prog_init(d,cube,error)
    use cube_types
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(derivative_2d_prog_t), intent(out)   :: d
    type(cube_t),                intent(in)    :: cube
    logical,                     intent(inout) :: error
    !
    character(len=*), parameter :: rname='DERIVATIVE>2D>PROG>INIT'
    !
    call cubefield_message(fieldseve%trace,rname,'Welcome')
    !
    call d%x%init(cube,cube%head%set%il,error)
    if (error) return
    call d%y%init(cube,cube%head%set%im,error)
    if (error) return
  end subroutine derivative_2d_prog_init
  !
  subroutine derivative_2d_prog_list(d,error)
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(derivative_2d_prog_t), intent(in)    :: d
    logical,                     intent(inout) :: error
    !
    character(len=*), parameter :: rname='DERIVATIVE>2D>PROG>LIST'
    !
    call cubefield_message(fieldseve%trace,rname,'Welcome')
    !
    print *,''
    print *,'X axis'
    call d%x%list(error)
    if (error) return
    print *,'Y axis'
    call d%y%list(error)
    if (error) return
  end subroutine derivative_2d_prog_list
end module cubefield_derivative_tool
!
module cubefield_hessian
  use cubetools_parameters
  use cube_types
  use cubetools_structure
  use cubeadm_cubeid_types
  use cubeadm_cubeprod_types
  use cubetopology_cuberegion_types
  use cubefield_messaging
  use cubefield_derivative_tool
  !
  public :: hessian
  private
  !
  type :: hessian_comm_t
     type(option_t), pointer :: comm
     type(cuberegion_comm_t) :: region
     type(cubeid_arg_t), pointer :: df_dx ! Gradient x component
     type(cubeid_arg_t), pointer :: df_dy ! Gradient y component
     type(cube_prod_t),  pointer :: d2f_dx2
     type(cube_prod_t),  pointer :: d2f_dy2
     type(cube_prod_t),  pointer :: d2f_dxdy
     type(cube_prod_t),  pointer :: laplacian
     type(cube_prod_t),  pointer :: determinant
     type(cube_prod_t),  pointer :: eigenval1
     type(cube_prod_t),  pointer :: eigenval2
     type(cube_prod_t),  pointer :: angle
   contains
     procedure, public  :: register => cubefield_hessian_comm_register
     procedure, private :: parse    => cubefield_hessian_comm_parse
     procedure, private :: main     => cubefield_hessian_comm_main
  end type hessian_comm_t
  type(hessian_comm_t) :: hessian  
  !
  type hessian_user_t
     type(cubeid_user_t)     :: cubeids
     type(cuberegion_user_t) :: region
   contains
     procedure, private :: toprog => cubefield_hessian_user_toprog
  end type hessian_user_t
  !
  type hessian_prog_t
     type(cuberegion_prog_t) :: region
     type(derivative_2d_prog_t) :: d
     type(cube_t), pointer :: df_dx
     type(cube_t), pointer :: df_dy
     type(cube_t), pointer :: d2f_dx2
     type(cube_t), pointer :: d2f_dy2
     type(cube_t), pointer :: d2f_dxdy
     type(cube_t), pointer :: laplacian
     type(cube_t), pointer :: determinant
     type(cube_t), pointer :: eigenval1
     type(cube_t), pointer :: eigenval2
     type(cube_t), pointer :: angle
   contains
     procedure, private :: header => cubefield_hessian_prog_header
     procedure, private :: data   => cubefield_hessian_prog_data
     procedure, private :: loop   => cubefield_hessian_prog_loop
     procedure, private :: act    => cubefield_hessian_prog_act
  end type hessian_prog_t
  !
contains
  !
  subroutine cubefield_hessian_command(line,error)
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    character(len=*), intent(in)    :: line
    logical,          intent(inout) :: error
    !
    type(hessian_user_t) :: user
    character(len=*), parameter :: rname='HESSIAN>COMMAND'
    !
    call cubefield_message(fieldseve%trace,rname,'Welcome')
    !
    call hessian%parse(line,user,error)
    if (error) return
    call hessian%main(user,error)
    if (error) continue
  end subroutine cubefield_hessian_command
  !
  !----------------------------------------------------------------------
  !
  subroutine cubefield_hessian_comm_register(comm,error)
    use cubedag_allflags
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(hessian_comm_t), intent(inout) :: comm
    logical,                intent(inout) :: error
    !
    type(cubeid_arg_t) :: incube
    type(cube_prod_t) :: oucube
    character(len=*), parameter :: rname='HESSIAN>COMM>REGISTER'
    !
    call cubefield_message(fieldseve%trace,rname,'Welcome')
    !
    ! Syntax
    call cubetools_register_command(&
         'HESSIAN','[df_dx_id df_dy_id]',&
         'Compute the Hessian from a 2D spatial gradient',&
         'Compute centered finite-difference Hessian products from the X and&
         & Y gradient-component cubes. The command writes D2F_DX2,&
         & D2F_DY2, D2F_DXDY, LAPLACIAN, DETERMINANT, EIGENVAL1,&
         & EIGENVAL2, and ANGLE outputs. Border pixels remain blank because&
         & only interior pixels are evaluated.',&
         cubefield_hessian_command,&
         comm%comm,&
         error)
    if (error) return
    call incube%register(&
         'DF_DX_ID',&
         'Identifier for the X gradient',&
         'Use the X gradient-component cube. If omitted, use the last&
         & matching cube (*gradient,dx*) in the default index (DAG by&
         & default; see SET\INDEX).',&
         code_arg_optional,&
         [flag_gradient,flag_dx],&
         code_read,&
         code_access_imaset,&
         comm%df_dx,&
         error)
    if (error) return
    call incube%register(&
         'DF_DY_ID',&
         'Identifier for the Y gradient',&
         'Use the Y gradient-component cube. If omitted, use the last&
         & matching cube (*gradient,dy*) in the default index (DAG by&
         & default; see SET\INDEX).',&
         code_arg_optional,&
         [flag_gradient,flag_dy],&
         code_read,&
         code_access_imaset,&
         comm%df_dy,&
         error)
    if (error) return
    call comm%region%register(error)
    if (error) return
    !
    ! Products
    call oucube%register(&
         'D2F_DX2',&
         'Cube of hessian d2f_dx2',&
         strg_emp,&
         [flag_hessian,flag_dx2],&
         comm%d2f_dx2,&
         error)
    if (error)  return
    call oucube%register(&
         'D2F_DY2',&
         'Cube of hessian d2f_dy2',&
         strg_emp,&
         [flag_hessian,flag_dy2],&
         comm%d2f_dy2,&
         error)
    if (error)  return
    call oucube%register(&
         'D2F_DXDY',&
         'Cube of hessian d2f_dxdy',&
         strg_emp,&
         [flag_hessian,flag_dxdy],&
         comm%d2f_dxdy,&
         error)
    if (error)  return
    !
    call oucube%register(&
         'LAPLACIAN',&
         'Cube of laplacian (= trace of the hessian)',&
         'This is also equal to div(grad(F)), where F is the initial 2D field',&
         [flag_laplacian],&
         comm%laplacian,&
         error)
    if (error)  return
    call oucube%register(&
         'DETERMINANT',&
         'Cube of hessian determinant',&
         strg_emp,&
         [flag_hessian,flag_determinant],&
         comm%determinant,&
         error)
    if (error)  return
    !
    call oucube%register(&
         'EIGENVAL1',&
         'Cube of first Hessian eigenvalue',&
         strg_emp,&
         [flag_hessian,flag_eigen,flag_value,flag_one],&
         comm%eigenval1,&
         error)
    if (error)  return
    call oucube%register(&
         'EIGENVAL2',&
         'Cube of second Hessian eigenvalue',&
         strg_emp,&
         [flag_hessian,flag_eigen,flag_value,flag_two],&
         comm%eigenval2,&
         error)
    if (error)  return
    call oucube%register(&
         'ANGLE',&
         'Cube of hessian angle',&
         strg_emp,&
         [flag_hessian,flag_angle],&
         comm%angle,&
         error)
    if (error)  return
  end subroutine cubefield_hessian_comm_register
  !
  subroutine cubefield_hessian_comm_parse(comm,line,user,error)
    !----------------------------------------------------------------------
    ! HESSIAN df_dxid df_dyid
    !----------------------------------------------------------------------
    class(hessian_comm_t), intent(in)    :: comm
    character(len=*),      intent(in)    :: line
    type(hessian_user_t),  intent(out)   :: user
    logical,               intent(inout) :: error
    !
    character(len=*), parameter :: rname='HESSIAN>COMM>PARSE'
    !
    call cubefield_message(fieldseve%trace,rname,'Welcome')
    !
    call cubeadm_cubeid_parse(line,comm%comm,user%cubeids,error)
    if (error) return
    call comm%region%parse(line,user%region,error)
    if (error) return
  end subroutine cubefield_hessian_comm_parse
  !
  subroutine cubefield_hessian_comm_main(comm,user,error)
    use cubeadm_timing
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(hessian_comm_t), intent(in)    :: comm
    type(hessian_user_t),  intent(inout) :: user
    logical,               intent(inout) :: error
    !
    type(hessian_prog_t) :: prog
    character(len=*), parameter :: rname='HESSIAN>MAIN'
    !
    call cubefield_message(fieldseve%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 cubefield_hessian_comm_main
  !
  !----------------------------------------------------------------------
  !
  subroutine cubefield_hessian_user_toprog(user,comm,prog,error)
    use cubeadm_get
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(hessian_user_t), intent(in)    :: user
    type(hessian_comm_t),  intent(in)    :: comm
    type(hessian_prog_t),  intent(out)   :: prog
    logical,               intent(inout) :: error
    !
    character(len=*), parameter :: rname='HESSIAN>USER>TOPROG'
    !
    call cubefield_message(fieldseve%trace,rname,'Welcome')
    !
    call cubeadm_get_header(comm%df_dx,user%cubeids,prog%df_dx,error)
    if (error) return
    call user%region%toprog(prog%df_dx,prog%region,error)
    if (error) return
    call cubeadm_get_header(comm%df_dy,user%cubeids,prog%df_dy,error)
    if (error) return
    call user%region%toprog(prog%df_dy,prog%region,error)
    if (error) return
    ! User feedback about the interpretation of his command line
    call prog%region%list(error)
    if (error) return
  end subroutine cubefield_hessian_user_toprog
  !
  !----------------------------------------------------------------------
  !
  subroutine cubefield_hessian_prog_header(prog,comm,error)
    use cubeadm_clone
    use cubetools_header_methods
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(hessian_prog_t), intent(inout) :: prog
    type(hessian_comm_t),  intent(in)    :: comm
    logical,               intent(inout) :: error
    !
    character(len=*), parameter :: rname='HESSIAN>PROG>HEADER'
    !
    call cubefield_message(fieldseve%trace,rname,'Welcome')
    !
    call prog%d%init(prog%df_dx,error)
    if (error) return
    call prog%d%list(error)
    if (error) return
    !
    call cubeadm_clone_header_with_region(comm%d2f_dx2,  &
      prog%df_dx,prog%region,prog%d2f_dx2,error)
    if (error) return
    call cubeadm_clone_header_with_region(comm%d2f_dy2,  &
      prog%df_dy,prog%region,prog%d2f_dy2,error)
    if (error) return
    call cubeadm_clone_header_with_region(comm%d2f_dxdy,  &
      prog%df_dx,prog%region,prog%d2f_dxdy,error)
    if (error) return
    !
    call cubeadm_clone_header_with_region(comm%laplacian,  &
      prog%df_dx,prog%region,prog%laplacian,error)
    if (error) return
    call cubeadm_clone_header_with_region(comm%determinant,  &
      prog%df_dx,prog%region,prog%determinant,error)
    if (error) return
    !
    call cubeadm_clone_header_with_region(comm%eigenval1,  &
      prog%df_dx,prog%region,prog%eigenval1,error)
    if (error) return
    call cubeadm_clone_header_with_region(comm%eigenval2,  &
      prog%df_dx,prog%region,prog%eigenval2,error)
    if (error) return
    call cubeadm_clone_header_with_region(comm%angle,  &
      prog%df_dx,prog%region,prog%angle,error)
    if (error) return
  end subroutine cubefield_hessian_prog_header
  !
  subroutine cubefield_hessian_prog_data(prog,error)
    use cubeadm_opened
    !----------------------------------------------------------------------
    ! 
    !----------------------------------------------------------------------
    class(hessian_prog_t), intent(inout) :: prog
    logical,               intent(inout) :: error
    !
    type(cubeadm_iterator_t) :: iter
    character(len=*), parameter :: rname='HESSIAN>PROG>DATA'
    !
    call cubefield_message(fieldseve%trace,rname,'Welcome')
    !
    call cubeadm_datainit_all(iter,prog%region,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) &
         call prog%loop(iter,error)
       !$OMP END TASK
    enddo
    !$OMP END SINGLE
    !$OMP END PARALLEL
  end subroutine cubefield_hessian_prog_data
  !   
  subroutine cubefield_hessian_prog_loop(prog,iter,error)
    use cubeadm_taskloop
    use cubeadm_image_types
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(hessian_prog_t),    intent(inout) :: prog
    type(cubeadm_iterator_t), intent(inout) :: iter
    logical,                  intent(inout) :: error
    !
    type(image_t) :: df_dx,df_dy
    type(image_t) :: d2f_dx2,d2f_dy2,d2f_dxdy
    type(image_t) :: laplacian,determinant
    type(image_t) :: eigenval1,eigenval2,angle
    character(len=*), parameter :: rname='HESSIAN>PROG>LOOP'
    !
    call df_dx%associate('df_dx',prog%df_dx,iter,error)
    if (error) return
    call df_dy%associate('df_dy',prog%df_dy,iter,error)
    if (error) return
    !
    call d2f_dx2%allocate('d2f_dx2',prog%d2f_dx2,iter,error)
    if (error) return
    call d2f_dy2%allocate('d2f_dy2',prog%d2f_dy2,iter,error)
    if (error) return
    call d2f_dxdy%allocate('d2f_dxdy',prog%d2f_dxdy,iter,error)
    if (error) return
    !
    call laplacian%allocate('laplacian',prog%laplacian,iter,error)
    if (error) return
    call determinant%allocate('determinant',prog%determinant,iter,error)
    if (error) return
    !
    call eigenval1%allocate('eigenval1',prog%eigenval1,iter,error)
    if (error) return
    call eigenval2%allocate('eigenval2',prog%eigenval2,iter,error)
    if (error) return
    call angle%allocate('angle',prog%angle,iter,error)
    if (error) return
    !
    do while (iter%iterate_entry(error))
       call prog%act(iter%ie,df_dx,df_dy,&
            d2f_dx2,d2f_dy2,d2f_dxdy,&
            laplacian,determinant,&
            eigenval1,eigenval2,angle,error)
       if (error) return
    enddo ! ie
  end subroutine cubefield_hessian_prog_loop
  !   
  subroutine cubefield_hessian_prog_act(prog,ie,df_dx,df_dy,&
       d2f_dx2,d2f_dy2,d2f_dxdy,&
       laplacian,determinant,&
       eigenval1,eigenval2,angle,&
       error)
    use phys_const
    use cubetools_nan
    use cubeadm_image_types
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(hessian_prog_t), intent(inout) :: prog
    integer(kind=entr_k),  intent(in)    :: ie
    type(image_t), target, intent(inout) :: df_dx
    type(image_t), target, intent(inout) :: df_dy
    type(image_t),         intent(inout) :: d2f_dx2
    type(image_t),         intent(inout) :: d2f_dy2
    type(image_t),         intent(inout) :: d2f_dxdy
    type(image_t),         intent(inout) :: laplacian
    type(image_t),         intent(inout) :: determinant
    type(image_t),         intent(inout) :: eigenval1
    type(image_t),         intent(inout) :: eigenval2
    type(image_t),         intent(inout) :: angle
    logical,               intent(inout) :: error
    !
    integer(kind=pixe_k) :: ix,iy
    character(len=*), parameter :: rname='HESSIAN>PROG>ACT'
    !
    call df_dx%get(ie,error)
    if (error) return
    call df_dy%get(ie,error)
    if (error) return
    call d2f_dx2%set_frame(prog%d%x%i,prog%d%y%i,gr4nan,error)
    if (error) return
    call d2f_dy2%set_frame(prog%d%x%i,prog%d%y%i,gr4nan,error)
    if (error) return
    call d2f_dxdy%set_frame(prog%d%x%i,prog%d%y%i,gr4nan,error)
    if (error) return
    call laplacian%set_frame(prog%d%x%i,prog%d%y%i,gr4nan,error)
    if (error) return
    call determinant%set_frame(prog%d%x%i,prog%d%y%i,gr4nan,error)
    if (error) return
    call eigenval1%set_frame(prog%d%x%i,prog%d%y%i,gr4nan,error)
    if (error) return
    call eigenval2%set_frame(prog%d%x%i,prog%d%y%i,gr4nan,error)
    if (error) return
    call angle%set_frame(prog%d%x%i,prog%d%y%i,gr4nan,error)
    if (error) return
    do iy=prog%d%y%i+1,prog%d%y%n-prog%d%y%i
       do ix=prog%d%x%i+1,prog%d%x%n-prog%d%x%i
          d2f_dx2%val(ix,iy)  = (df_dx%val(ix+prog%d%x%i,iy)-df_dx%val(ix-prog%d%x%i,iy))/prog%d%x%inc
          d2f_dy2%val(ix,iy)  = (df_dy%val(ix,iy+prog%d%y%i)-df_dy%val(ix,iy-prog%d%y%i))/prog%d%y%inc
          d2f_dxdy%val(ix,iy) = (df_dx%val(ix,iy+prog%d%y%i)-df_dx%val(ix,iy-prog%d%y%i))/prog%d%y%inc
          laplacian%val(ix,iy) = d2f_dx2%val(ix,iy)+d2f_dy2%val(ix,iy)
          determinant%val(ix,iy) = d2f_dx2%val(ix,iy)*d2f_dy2%val(ix,iy)-d2f_dxdy%val(ix,iy)**2
          call eigen_decomposition(&
               d2f_dx2%val(ix,iy),d2f_dy2%val(ix,iy),d2f_dxdy%val(ix,iy),&
               eigenval1%val(ix,iy),eigenval2%val(ix,iy),angle%val(ix,iy),&
               error)
          if (error) return
       enddo ! ix
    enddo ! iy
    call d2f_dx2%put(ie,error)
    if (error) return
    call d2f_dy2%put(ie,error)
    if (error) return
    call d2f_dxdy%put(ie,error)
    if (error) return
    call laplacian%put(ie,error)
    if (error) return
    call determinant%put(ie,error)
    if (error) return
    call eigenval1%put(ie,error)
    if (error) return
    call eigenval2%put(ie,error)
    if (error) return
    call angle%put(ie,error)
    if (error) return
    !
  contains
    !
    subroutine eigen_decomposition(a,b,c,eigenval1,eigenval2,angle,error)
      !--------------------------------------------------------------------
      ! Compute the eigendecomposition of a 2-by-2 symmetric matrix
      !     [  a   b  ]
      !     [  b   c  ].
      !--------------------------------------------------------------------
      real(kind=sign_k), intent(in)    :: a
      real(kind=sign_k), intent(in)    :: b
      real(kind=sign_k), intent(in)    :: c
      real(kind=sign_k), intent(out)   :: eigenval1
      real(kind=sign_k), intent(out)   :: eigenval2
      real(kind=sign_k), intent(out)   :: angle
      logical,           intent(inout) :: error
      !
      real(kind=sign_k) :: cos1,sin1
      !
      call slaev2(a,b,c,eigenval1,eigenval2,cos1,sin1)
      angle = atan2(sin1,cos1)*deg_per_rad
!!$      if (abs(eigenval1).lt.5e-2) then
!!$         print *,cos1,sin1,angle*deg_per_rad
!!$      endif
    end subroutine eigen_decomposition
  end subroutine cubefield_hessian_prog_act
end module cubefield_hessian
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
