!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
module cubemain_reproject_opt
  use cubetools_parameters
  use cubetools_structure
  use cubeadm_cubeid_types
  use cubeadm_cubeprod_types
  use cubemain_messaging
  !---------------------------------------------------------------------
  ! Support module for commands which need to call the reproject engine:
  ! they must share the same command (option 0) type (= option_t +
  ! cubeid_arg_t)
  !---------------------------------------------------------------------
  !
  public :: reproject_opt_comm_t,reproject_opt_user_t
  private
  !
  type :: reproject_opt_comm_t
    type(option_t),     pointer :: comm
    type(cubeid_arg_t), pointer :: cube
    type(cube_prod_t),  pointer :: reprojected
  contains
    procedure, public :: register => cubemain_reproject_opt_register
    procedure, public :: parse    => cubemain_reproject_opt_parse
  end type reproject_opt_comm_t
  !
  type reproject_opt_user_t
    type(cubeid_user_t) :: cubeids ! Input cube
  end type reproject_opt_user_t
  !
contains
  !
  subroutine cubemain_reproject_opt_register(comm,name,abstract,help,run, &
    ouname,ouflag,error)
    use cubedag_allflags
    use cubedag_parameters
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(reproject_opt_comm_t), intent(inout) :: comm
    character(len=*),            intent(in)    :: name      ! Command name
    character(len=*),            intent(in)    :: abstract  ! Command abstract
    character(len=*),            intent(in)    :: help      ! Command help
    external                                   :: run       !
    character(len=*),            intent(in)    :: ouname    ! Output cube qualifier
    type(flag_t),                intent(in)    :: ouflag    ! Output cube flag
    logical,                     intent(inout) :: error
    !
    type(cubeid_arg_t) :: cubearg
    type(cube_prod_t) :: oucube
    character(len=*), parameter :: rname='REPROJECT>OPT>REGISTER'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call cubetools_register_command(&
         name,'[cube]',&
         abstract,&
         help,&
         run,&
         comm%comm,error)
    if (error) return
    call cubearg%register(&
         'CUBE',&
         'Signal cube',&
         'If omitted, use the last matching cube (cube flag) in&
         & the default index (DAG by default; see SET\INDEX).',&
         code_arg_optional,&
         [flag_cube],&
         code_read,&
         code_access_imaset,&
         comm%cube,&
         error)
    if (error) return
    !
    ! Product
    call oucube%register(&
         name,&
         ouname//' cube',&
         strg_emp,&
         [ouflag,flag_cube],&
         comm%reprojected,&
         error)
    if (error) return
  end subroutine cubemain_reproject_opt_register
  !
  subroutine cubemain_reproject_opt_parse(comm,line,user,error)
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(reproject_opt_comm_t), intent(in)    :: comm
    character(len=*),            intent(in)    :: line
    type(reproject_opt_user_t),  intent(out)   :: user
    logical,                     intent(inout) :: error
    !
    character(len=*), parameter :: rname='REPROJECT>OPT>PARSE'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call cubeadm_cubeid_parse(line,comm%comm,user%cubeids,error)
    if (error) return
  end subroutine cubemain_reproject_opt_parse
end module cubemain_reproject_opt
!
module cubemain_reproject
  use gbl_constant
  use cubetools_parameters
  use cube_types
  use cubetools_structure
  use cubetools_axis_types
  use cubetools_spatial_types
  use cubetools_header_types
  use cubeadm_cubeid_types
  use cubemain_messaging
  use cubemain_auxiliary
  use cubemain_reproject_opt
  !
  public :: reproject
  public :: code_conv_none,code_conv_equ2gal,code_conv_gal2equ,code_conv_equ2equ
  public :: reproject_comm_t,reproject_user_t,reproject_prog_t
  public :: cubemain_reproject_user_toprog_find_conv
  private
  !
  ! Coordinate system conversion codes
  integer(kind=code_k), parameter :: code_conv_none    =  0
  integer(kind=code_k), parameter :: code_conv_equ2gal =  1
  integer(kind=code_k), parameter :: code_conv_gal2equ = -1
  integer(kind=code_k), parameter :: code_conv_equ2equ = -2
  type :: reproject_conv_t  ! Conversion description
    integer(kind=code_k) :: code  = code_conv_none
    real(kind=4)         :: eqin  = equinox_null  ! Input equinox, if relevant
    real(kind=4)         :: eqout = equinox_null  ! Output equinox, if relevant
  end type reproject_conv_t
  !
  type :: reproject_comm_t
     type(reproject_opt_comm_t)  :: comm   ! Command (option 0) description
     type(option_t),     pointer :: like
     type(cubeid_arg_t), pointer :: like_arg
     type(spafra_opt_t)          :: spafra
     type(spapro_type_opt_t)     :: ptype
     type(spapro_center_opt_t)   :: pcenter
     type(spapro_angle_opt_t)    :: pangle
     type(axis_opt_t)            :: laxis
     type(axis_opt_t)            :: maxis
   contains
     procedure, public  :: register => cubemain_reproject_register
     procedure, private :: parse    => cubemain_reproject_parse
     procedure, public  :: main     => cubemain_reproject_main
  end type reproject_comm_t
  type(reproject_comm_t) :: reproject
  !
  type reproject_user_t
     type(reproject_opt_user_t) :: comm    ! Command (option 0) arguments
     type(auxiliary_user_t)     :: like    ! Use another cube as reference
     type(spafra_user_t)        :: spafra  ! User Spatial frame
     type(spapro_type_user_t)   :: ptype   ! Projection type
     type(spapro_center_user_t) :: pcenter ! Projection center
     type(spapro_angle_user_t)  :: pangle  ! Projection angle
     type(axis_user_t)          :: newx    ! [sec|min|deg|rad] User l axis description
     type(axis_user_t)          :: newy    ! [sec|min|deg|rad] User m axis description
   contains
     procedure, public  :: init   => cubemain_reproject_user_init 
     procedure, private :: toprog => cubemain_reproject_user_toprog
  end type reproject_user_t
  !
  type reproject_prog_t
     type(cube_t), pointer  :: cube                  ! Input cube
     type(cube_t), pointer  :: reprojected           ! Reprojected cube
     type(cube_header_t)    :: ouhead
     type(reproject_conv_t) :: conv
     type(axis_t)           :: oldx                  ! [rad] old l axis description
     type(axis_t)           :: oldy                  ! [rad] old m axis description
     type(axis_t)           :: newx                  ! [rad] new l axis description 
     type(axis_t)           :: newy                  ! [rad] new m axis description
     real(kind=coor_k), allocatable :: xfrac(:,:)   ! [---] Fraction of input pixel in output pixel
     real(kind=coor_k), allocatable :: yfrac(:,:)   ! [---] Fraction of input pixel in output pixel
     integer(kind=pixe_k), allocatable :: ix(:,:)   ! Output pixel number in input cube
     integer(kind=pixe_k), allocatable :: iy(:,:)   ! Output pixel number in input cube
   contains
     procedure, public  :: header     => cubemain_reproject_prog_header
     procedure, public  :: precompute => cubemain_reproject_prog_precompute
     procedure, public  :: data       => cubemain_reproject_prog_data
     procedure, private :: loop       => cubemain_reproject_prog_loop
     procedure, private :: act        => cubemain_reproject_prog_act
  end type reproject_prog_t
  !
contains
  !
  subroutine cubemain_reproject_command(line,error)
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    character(len=*), intent(in)    :: line
    logical,          intent(inout) :: error
    !
    type(reproject_user_t) :: user
    character(len=*), parameter :: rname='REPROJECT>COMMAND'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call reproject%parse(line,user,error)
    if (error) return
    call reproject%main(user,error)
    if (error) continue
  end subroutine cubemain_reproject_command
  !
  !----------------------------------------------------------------------
  !
  subroutine cubemain_reproject_register(comm,error)
    use cubetools_unit
    use cubedag_parameters
    use cubedag_allflags
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(reproject_comm_t), intent(inout) :: comm
    logical,                 intent(inout) :: error
    !
    character(len=*), parameter :: rname='REPROJECT>REGISTER'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call comm%comm%register(&
         'REPROJECT',&
         'Reproject the spatial grid of a cube',&
         'Reproject the spatial axes of an input image or cube to a&
         & different projection or coordinate system.'//strg_bl//&
         'Behavior:'//strg_cr//&
         '- Spatial resampling uses bilinear interpolation. For best interpolation&
         & fidelity, choose output pixel increments smaller than the input ones.'//strg_cr//&
         '- At least one target-definition option must be provided.'//strg_cr//&
         '- /SPATIALFRAME, /PTYPE, /PCENTER, /PANGLE, /LAXIS, and /MAXIS can be&
         & combined to define the output projection and coordinates.'//strg_cr//&
         '- If /LIKE is provided, all other target-definition options are ignored&
         & and output projection and coordinates are copied from the&
         & reference cube.'//strg_cr//&
         '- REPROJECT changes the spatial grid while keeping non-spatial&
         & axes unchanged.'//strg_bl//&
         'Examples:'//strg_cr//&
         'CUBE> REPROJECT cubeA /SPATIALFRAME EQUATORIAL /PTYPE TAN'//strg_cr//&
         'CUBE> REPROJECT cubeA /LAXIS 512 256 0 1 arcsec /MAXIS 512&
         & 256 0 1 arcsec'//strg_cr//&
         'CUBE> REPROJECT cubeA /LIKE refcube'//strg_bl//&
         'Typical workflow:'//strg_cr//&
         'CUBE> HEADER cubeA'//strg_cr//&
         'CUBE> REPROJECT cubeA /LIKE refcube'//strg_cr//&
         'CUBE> HEADER reprojected'//strg_cr//&
         'CUBE> CONSISTENCY refcube reprojected',&
         cubemain_reproject_command,&
         'Reprojected',flag_reproject,error)
    if (error)  return
    !
    call comm%spafra%register(&
         'Define the spatial frame of the reprojected cube',&
         error)
    if (error) return
    !
    call comm%ptype%register(&
         'PTYPE',&
         'Define the new projection type',&
         error)
    if (error) return
    call comm%pcenter%register(&
         'PCENTER',&
         'Define the new projection center',&
         error)
    if (error) return
    call comm%pangle%register(&
         'PANGLE',&
         'Define the new projection angle',&
         error)
    if (error) return
    !
    call comm%laxis%register(&
         code_unit_fov,&
         'LAXIS',&
         'Define the l axis of the reprojected cube',&
         error)
    if (error) return
    call comm%maxis%register(&
         code_unit_fov,&
         'MAXIS',&
         'Define the m axis of the reprojected cube',&
         error)
    if (error) return
    !
    call cubemain_auxiliary_register(&
         'LIKE',&
         'Reproject onto the same grid as a reference cube',&
         strg_emp,&
         comm%like,&
         'Reference cube',&
         [flag_cube],&
         code_arg_mandatory, &
         code_access_imaset, &
         comm%like_arg, &
         error)
    if (error) return
  end subroutine cubemain_reproject_register
  !
  subroutine cubemain_reproject_parse(comm,line,user,error)
    !----------------------------------------------------------------------
    ! REPROJECT [cubeid]
    ! /SPATIALFRAME name [equinox]
    ! /PTYPE type
    ! /PCENTER l0 m0 relative|absolute [unit]
    ! /PANGLE  pang [pangunit]
    ! /LAXIS n ref val inc [unit]
    ! /MAXIS n ref val inc [unit]
    ! /LIKE refcube
    !----------------------------------------------------------------------
    class(reproject_comm_t), intent(in)    :: comm
    character(len=*),        intent(in)    :: line
    type(reproject_user_t),  intent(out)   :: user
    logical,                 intent(inout) :: error
    !
    character(len=*), parameter :: rname='REPROJECT>PARSE'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call user%init(error)
    if (error) return
    call comm%comm%parse(line,user%comm,error)
    if (error)  return
    call cubemain_auxiliary_parse(line,comm%like,user%like,error)
    if (error) return
    call comm%ptype%parse(line,user%ptype,error)
    if (error) return
    call comm%pcenter%parse(line,user%pcenter,error)
    if (error) return
    call comm%pangle%parse(line,user%pangle,error)
    if (error) return
    call comm%spafra%parse(line,user%spafra,error)
    if (error) return
    call comm%laxis%parse(line,user%newx,error)
    if (error) return
    call comm%maxis%parse(line,user%newy,error)
    if (error) return
  end subroutine cubemain_reproject_parse
  !
  subroutine cubemain_reproject_main(comm,user,error)
    use cubetools_header_types
    use cubeadm_timing
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(reproject_comm_t), intent(in)    :: comm
    type(reproject_user_t),  intent(in)    :: user
    logical,                 intent(inout) :: error
    !
    type(reproject_prog_t) :: prog
    character(len=*), parameter :: rname='REPROJECT>MAIN'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call user%toprog(comm,prog,error)
    if (error) goto 10
    call prog%header(comm,error)
    if (error) goto 10
    call cubeadm_timing_prepro2process()
    call prog%data(prog%cube,prog%reprojected,error)
    if (error) goto 10
    call cubeadm_timing_process2postpro()
10  call cubetools_header_final(prog%ouhead,error)
  end subroutine cubemain_reproject_main
  !
  !------------------------------------------------------------------------
  !
  subroutine cubemain_reproject_user_init(user,error)
    !----------------------------------------------------------------------
    ! Initialize at strg_star things that are should be kept as default in
    ! the case of the rotate command
    !----------------------------------------------------------------------
    class(reproject_user_t), intent(out)   :: user
    logical,                 intent(inout) :: error
    !
    character(len=*), parameter :: rname='REPROJECT>USER>INIT'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    user%newx%n    = strg_star
    user%newx%ref  = strg_star
    user%newx%val  = strg_star
    user%newx%inc  = strg_star
    user%newx%unit = strg_star
    user%newy%n    = strg_star
    user%newy%ref  = strg_star
    user%newy%val  = strg_star
    user%newy%inc  = strg_star
    user%newy%unit = strg_star
  end subroutine cubemain_reproject_user_init
  !
  subroutine cubemain_reproject_user_toprog(user,reproject,prog,error)
    use cubetools_header_types
    use cubetools_header_methods
    use cubeadm_get
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(reproject_user_t), intent(in)    :: user
    type(reproject_comm_t),  intent(in)    :: reproject
    type(reproject_prog_t),  intent(inout) :: prog
    logical,                 intent(inout) :: error
    !
    type(cube_t), pointer :: refcube
    character(len=*), parameter :: rname='REPROJECT>MAIN'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call cubeadm_get_header(reproject%comm%cube,user%comm%cubeids,prog%cube,error)
    if (error) return
    call cubetools_header_copy(prog%cube%head,prog%ouhead,error)
    if (error) return
    !
    ! Get input cube axes description in the prog%oldx and prog%oldy description
    call cubetools_header_get_axis_head_l(prog%cube%head,prog%oldx,error)
    if (error) return
    call cubetools_header_get_axis_head_m(prog%cube%head,prog%oldy,error)
    if (error) return
    !
    if (user%like%do) then
       ! Simple case => The grid is completly defined by the reference cube
       call cubemain_auxiliary_user2prog(reproject%like_arg,user%like,refcube,error)
       if (error) return
       call cubetools_header_spatial_like(refcube%head,prog%ouhead,error)
       if (error) return
       call cubemain_reproject_user_toprog_find_conv(&
            prog%cube%head%spa%fra,&
            prog%ouhead%spa%fra,&
            prog%conv,error)
       if (error) return
       !
       call cubetools_header_get_axis_head_l(prog%ouhead,prog%newx,error)
       if (error) return
       call cubetools_header_get_axis_head_m(prog%ouhead,prog%newy,error)
       if (error) return
    else      
       ! Complex case => We may need clear default when the user does not define everything
       ! First: User2prog user inputs
       call cubetools_header_get_axis_head_l(prog%ouhead,prog%newx,error)
       if (error) return
       call cubetools_header_get_axis_head_m(prog%ouhead,prog%newy,error)
       if (error) return
       call reproject%spafra%user2prog(user%spafra,prog%ouhead%spa%fra,error)
       if (error) return
       call reproject%ptype%user2prog(user%ptype,prog%ouhead%spa%pro,error)
       if (error) return
       call reproject%pcenter%user2prog(prog%ouhead%spa%fra,user%pcenter,prog%ouhead%spa%pro,error)
       if (error) return
       call reproject%pangle%user2prog(user%pangle,prog%ouhead%spa%pro,error)
       if (error) return
       !
       ! Second: Change of referential
       call cubemain_reproject_user_toprog_find_conv(&
            prog%cube%head%spa%fra,&
            prog%ouhead%spa%fra,&
            prog%conv,error)
       if (error) return
       call cubemain_reproject_user_toprog_center(prog%conv,prog%cube%head%spa,prog%ouhead%spa,error)
       if (error) return
       ! Third: Axis redefinition
       call cubemain_reproject_user_toprog_find_grid(user%newx,user%newy,prog,error)
       if (error) return
    endif
  end subroutine cubemain_reproject_user_toprog
  !
  subroutine cubemain_reproject_user_toprog_center(conv,old,new,error)
    use gkernel_interfaces
    use cubetools_spatial_types
    !----------------------------------------------------------------------
    ! Update projection center according to new spatial frame
    !----------------------------------------------------------------------
    type(reproject_conv_t), intent(in)    :: conv
    type(spatial_t),        intent(in)    :: old
    type(spatial_t),        intent(inout) :: new
    logical,                intent(inout) :: error
    !
    character(len=fram_l) :: frame
    character(len=*), parameter :: rname='REPROJECT>USER>TOPROG>CENTER'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    if (conv%code.eq.code_conv_none) return
    ! If The user has given explicit l0 and m0 no need to compute
    ! coordinates in new spatial frame, user can change just l0 or
    ! just m0.
    if ((new%pro%l0.ne.old%pro%l0).or.(new%pro%m0.ne.old%pro%m0)) return
    !
    if (conv%code.eq.code_conv_equ2gal) then
       call equ_gal(old%pro%l0,old%pro%m0,conv%eqin,  &
                    new%pro%l0,new%pro%m0,            &
                    error)
       if (error) return
    else if (conv%code.eq.code_conv_gal2equ) then
       call gal_equ(old%pro%l0,old%pro%m0,             &
                    new%pro%l0,new%pro%m0,conv%eqout,  &
                    error)
       if (error) return
    else if (conv%code.eq.code_conv_equ2equ) then
       call equ_equ(old%pro%l0,old%pro%m0,conv%eqin,  &
                    new%pro%l0,new%pro%m0,conv%eqout, &
                    error)
       if (error) return
    else
       call cubemain_message(seve%e,rname,'Unrecognized conversion code: '//trim(frame))
       error = .true.
       return
    endif
  end subroutine cubemain_reproject_user_toprog_center
  !
  subroutine cubemain_reproject_user_toprog_find_conv(oldframe,newframe,&
       conv,error)
    use cubetools_header_interface
    use cubetools_spafra_types
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    type(spafra_t),         intent(in)    :: oldframe
    type(spafra_t),         intent(in)    :: newframe
    type(reproject_conv_t), intent(out)   :: conv
    logical,                intent(inout) :: error
    !
    logical :: converror,convicrs
    character(len=fram_l) :: newname, oldname
    real(kind=4), parameter :: eqicrs=2000.0  ! ICRS equinox when approximated to Equatorial
    character(len=*), parameter :: rname='REPROJECT>USER>TOPROG>FIND>CONV'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    converror = .false.
    convicrs = .false.
    select case (newframe%code)
    case (code_spaframe_icrs)
       if (oldframe%code.eq.code_spaframe_equatorial) then
          conv%code = code_conv_equ2equ
          convicrs = .true.
       elseif (oldframe%code.eq.code_spaframe_galactic) then
          conv%code = code_conv_gal2equ
          convicrs = .true.
       elseif (oldframe%code.eq.code_spaframe_icrs) then
          conv%code = code_conv_none
       else
          converror = .true.
       endif
    case (code_spaframe_galactic)
       if (oldframe%code.eq.code_spaframe_equatorial) then
          conv%code = code_conv_equ2gal
       elseif (oldframe%code.eq.code_spaframe_galactic) then
          conv%code = code_conv_none
       else if (oldframe%code.eq.code_spaframe_icrs) then
          conv%code = code_conv_equ2gal
          convicrs = .true.
       else
          converror = .true.
       endif
    case (code_spaframe_equatorial)
       if (oldframe%code.eq.code_spaframe_equatorial) then
          if (oldframe%equinox.ne.newframe%equinox) then
             ! Both Equatorial, but different equinox
             call cubemain_message(seve%i,rname,'Converting from equinox '//&
                  trim(equinox_name(oldframe%equinox))//  &
                  ' to '//trim(equinox_name(newframe%equinox)))
             conv%code = code_conv_equ2equ
          else
             ! Both Equatorial, same equinox
             conv%code = code_conv_none
          endif
       elseif (oldframe%code.eq.code_spaframe_galactic) then
          conv%code = code_conv_gal2equ
       else if (oldframe%code.eq.code_spaframe_icrs) then
          if (newframe%equinox.ne.eqicrs) then
             ! From ICRS to Equatorial but improper equinox
             call cubemain_message(seve%i,rname,'Converting from equinox '//&
                  trim(equinox_name(eqicrs))//  &
                  ' to '//trim(equinox_name(newframe%equinox)))
             conv%code = code_conv_equ2equ
          else
             ! From ICRS to EQ 2000: no conversion
             conv%code = code_conv_none
          endif
          convicrs = .true.
       else
          converror = .true.
       endif
    case (code_spaframe_unknown)
       if (oldframe%code.eq.code_spaframe_icrs) then
          converror = .true.
       elseif (oldframe%code.eq.code_spaframe_galactic) then
          converror = .true.
       elseif (oldframe%code.eq.code_spaframe_equatorial) then
          converror = .true.
       else
          conv%code = code_conv_none
       endif
    case default
       call cubemain_message(seve%w,rname,'Unknown spatial frame code, no conversion applied')
       conv%code = code_conv_none
    end select
    !
    if (converror) then
       call cubetools_convert_code2spaframe(oldframe%code,oldname,error)
       if (error) return
       call cubetools_convert_code2spaframe(newframe%code,newname,error)
       if (error) return
       call cubemain_message(seve%e,rname,'Cannot convert from '//oldname//' to '//newname)
       error = .true.
       return
    endif
    !
    ! Set up the from/to equinoxes
    if (oldframe%code.eq.code_spaframe_equatorial)  conv%eqin  = oldframe%equinox
    if (newframe%code.eq.code_spaframe_equatorial)  conv%eqout = newframe%equinox
    if (convicrs) then
      call cubemain_message(seve%w,rname,  &
        'Approximating ICRS system to equatorial '//equinox_name(eqicrs))
      if (oldframe%code.eq.code_spaframe_icrs)  conv%eqin  = eqicrs
      if (newframe%code.eq.code_spaframe_icrs)  conv%eqout = eqicrs
    endif
    !
  contains
    function equinox_name(equinox)
      real(kind=4), intent(in) :: equinox
      character(len=10) :: equinox_name
      !
      if (equinox.eq.equinox_null) then
         equinox_name = 'Unknown'
      else
         write(equinox_name,'(F0.2)') equinox
      endif
    end function equinox_name
  end subroutine cubemain_reproject_user_toprog_find_conv
  !
  subroutine cubemain_reproject_user_toprog_find_grid(newx,newy,prog,error)
    use gkernel_interfaces
    use gkernel_types
    use cubetools_spapro_types
    use cubetools_header_methods
    use cubetools_header_interface
    use cubetools_unit
    use cubetools_user2prog
    !----------------------------------------------------------------------
    ! Compute n, inc, and ref for X and Y reprojected axes.  The X and Y
    ! val are left unmodified. val.eq.0 means aligned on projection center.
    ! 
    ! *** JP should we use float or dble in this routine?
    !----------------------------------------------------------------------
    type(axis_user_t),      intent(in)    :: newx
    type(axis_user_t),      intent(in)    :: newy
    type(reproject_prog_t), intent(inout) :: prog
    logical,                intent(inout) :: error
    !
    integer(kind=8), parameter :: one=1
    !
    logical :: warn,doxinc,doyinc,findgrid,doxref,doyref,doxn,doyn
    ! VVV has to be integer 4 for interface reasons...
    integer(kind=4) :: ier,ndp
    integer(kind=pixe_k) :: ix,iy,smartn
    real(kind=coor_k), allocatable :: dxd(:),indxd(:),oudxd(:)
    real(kind=coor_k), allocatable :: dyd(:),indyd(:),oudyd(:)
    real(kind=coor_k) :: sizex,sizey,ratio
    real(kind=coor_k) :: dxmin,dxmax
    real(kind=coor_k) :: dymin,dymax,boundary
    type(projection_t) :: proj
    type(unit_user_t) :: xunit, yunit
    real(kind=coor_k) :: default
    character(len=*), parameter :: rname='REPROJECT>USER>TOPROG>FIND>GRID'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    doxn   = newx%n.eq.strg_star
    doyn   = newy%n.eq.strg_star
    doxref = newx%ref.eq.strg_star
    doyref = newy%ref.eq.strg_star
    doxinc = newx%inc.eq.strg_star
    doyinc = newy%inc.eq.strg_star
    findgrid = doxinc.or.doyinc.or.doxref.or.doyref.or.doxn.or.doyn
    if (.not.findgrid) return
    !
    ! Allocation of work arrays
    allocate(dxd(prog%oldx%n*prog%oldy%n),dyd(prog%oldx%n*prog%oldy%n), stat=ier)
    if (failed_allocate(rname,'work arrays',ier,error)) return
    !
    ! Convert input projection to absolute coordinates
    call prog%cube%head%spa%pro%gwcs(proj,error)
    if (error) return
    ! Load data points
    ndp=0
    do iy=1,prog%oldy%n
       do ix=1,prog%oldx%n
          ndp = ndp+1
          dxd(ndp) = prog%oldx%coord(ix)
          dyd(ndp) = prog%oldy%coord(iy)
       enddo
    enddo
    !
    if (prog%conv%code.ne.code_conv_none) then
       ! Change coordinate spaframe and use new equinox
       allocate(indxd(ndp),indyd(ndp),oudxd(ndp),oudyd(ndp),stat=ier)
       if (failed_allocate(rname,'work arrays',ier,error)) return
       call rel_to_abs(proj,dxd,dyd,oudxd,oudyd,ndp)
       if (prog%conv%code.eq.code_conv_equ2gal) then
          call equ_gal(oudxd,oudyd,prog%conv%eqin,  &
                       indxd,indyd,                 &
                       ndp,error)
       elseif (prog%conv%code.eq.code_conv_gal2equ) then
          call gal_equ(oudxd,oudyd,                     &
                       indxd,indyd,prog%conv%eqout,     &
                       ndp,error)
       elseif (prog%conv%code.eq.code_conv_equ2equ) then
          call equ_equ(oudxd,oudyd,prog%conv%eqin,   &
                       indxd,indyd,prog%conv%eqout,  &
                       ndp,error)
       endif
       deallocate(oudxd,oudyd)
       if (error) return
    else
       allocate(indxd(ndp),indyd(ndp),stat=ier) 
       if (failed_allocate(rname,'work arrays',ier,error)) return
       call rel_to_abs(proj,dxd,dyd,indxd,indyd,ndp)
    endif
    !
    ! Setup Output projection
    call prog%ouhead%spa%pro%gwcs(proj,error)
    if (error) return
    !
    ! Convert Absolute coordinates to input projection
    call abs_to_rel(proj,indxd,indyd,dxd,dyd,ndp)
    !
    dxmin = minval(dxd(1:ndp))
    dymin = minval(dyd(1:ndp))
    dxmax = maxval(dxd(1:ndp))
    dymax = maxval(dyd(1:ndp))
    !
    ! Test extreme cases of unbound projections
    if (prog%ouhead%spa%pro%code.eq.p_gnomonic) then
       boundary = 1.5d0
    elseif (prog%ouhead%spa%pro%code.eq.p_stereo) then
       boundary = 1.0d0
    endif
    if (prog%ouhead%spa%pro%code.eq.p_gnomonic .or. &
         prog%ouhead%spa%pro%code.eq.p_stereo) then
       if (dxmin.lt.-boundary) then
          warn = .true.
          dxmin = -boundary
       endif
       if (dymin.lt.-boundary) then
          warn = .true.
          dymin = -boundary
       endif
       if (dxmax.gt.boundary) then
          warn = .true.
          dxmax = boundary
       endif
       if (dymax.gt.boundary) then
          warn = .true.
          dymax = boundary
       endif
       if (warn) then
          call cubemain_message(seve%w,rname,'Output Projection is unbound')
          call cubemain_message(seve%w,rname,'Will be limited to one hemisphere')
       endif
    endif
    !
    ! Image dimension and spatial increments
    sizex = dxmax-dxmin
    sizey = dymax-dymin
    ratio = sizex/sizey
    !
    call yunit%get_from_name_for_code(newy%unit,prog%newy%kind,error)
    if (error) return
    default = 0d0
    call cubetools_user2prog_resolve_all(newy%val,yunit,default,prog%oldy%val,prog%newy%val,error)
    if (error) return
    call xunit%get_from_name_for_code(newx%unit,prog%newx%kind,error)
    if (error) return
    default = 0d0
    call cubetools_user2prog_resolve_all(newx%val,xunit,default,prog%oldx%val,prog%newx%val,error)
    if (error) return
    !
    ! If user gave number of pixels, use it
    if (doyinc) then
       smartn = nint(sqrt(dble(prog%oldx%n*prog%oldy%n)*2d0/ratio))
       call cubetools_user2prog_resolve_all(newy%n,smartn,prog%oldy%n,prog%newy%n,error)
       if (error) return
    else
       default = prog%oldy%inc
       call cubetools_user2prog_resolve_all(newy%inc,yunit,default,prog%oldy%inc,prog%newy%inc,error)
       if (error) return
       prog%newy%n = sizey/abs(prog%newy%inc)+1
    endif  
    if (doxinc) then
       smartn = nint(dble(prog%newy%n)*ratio)
       call cubetools_user2prog_resolve_all(newx%n,smartn,prog%oldx%n,prog%newx%n,error)
       if (error) return
    else
       default = prog%oldx%inc
       call cubetools_user2prog_resolve_all(newx%inc,xunit,default,prog%oldx%inc,prog%newx%inc,error)
       if (error) return
       prog%newx%n = sizex/abs(prog%newx%inc)+1
    endif
    ! Sanity check
    if (prog%newx%n.le.0.or.prog%newy%n.le.0) then
       call cubemain_message(seve%e,rname,'Negative or zero sized image')
       error = .true.
       return
    endif
    ! Compute increments from dimensions if requested
    if (doxinc) prog%newx%inc = sizex/(prog%newx%n-1)
    if (doyinc) prog%newy%inc = sizey/(prog%newy%n-1)
    if (doxinc.and.doyinc) then
       ! Both Xinc and Yinc are automatic => At this stage the automatic
       ! increments may be slightly different because
       ! prog%newx%n/prog%newy%n differs slightly from sizex/sizey (nint()
       ! rounding). Equal increments are desirable. Select the one which
       ! ensures no loss of map coverage.
       if (prog%newx%inc.gt.prog%newy%inc) then
          prog%newy%inc = prog%newx%inc
       else
          prog%newx%inc = prog%newy%inc
       endif
    endif
    ! Keep input map conventions, if any
    if (doxinc .and. prog%oldx%inc.lt.0.d0) prog%newx%inc = -prog%newx%inc
    if (doyinc .and. prog%oldy%inc.lt.0.d0) prog%newy%inc = -prog%newy%inc
    !
    ! Reference pixels
    call cubemain_reproject_user_toprog_find_grid_ref(newx%ref,dxmin,dxmax,prog%newx,error)
    if (error) return
    call cubemain_reproject_user_toprog_find_grid_ref(newy%ref,dymin,dymax,prog%newy,error)
    if (error) return
    !
    select case(prog%ouhead%spa%fra%code)
    case (code_spaframe_galactic)
       prog%newx%name = 'Lii'
       prog%newy%name = 'Bii'
    case (code_spaframe_equatorial,code_spaframe_icrs)
       prog%newx%name = 'RA'
       prog%newy%name = 'DEC'
    case default
       prog%newx%name = 'L'
       prog%newy%name = 'M'
    end select
    !
    ! Update reprojected header
    call cubetools_header_update_axset_l(prog%newx,prog%ouhead,error)
    if (error) return
    call cubetools_header_update_axset_m(prog%newy,prog%ouhead,error)
    if (error) return
  end subroutine cubemain_reproject_user_toprog_find_grid
  !
  subroutine cubemain_reproject_user_toprog_find_grid_ref(user,min,max,new,error)
    use cubetools_user2prog
    use cubetools_unit
    !----------------------------------------------------------------------
    ! 
    !----------------------------------------------------------------------
    character(len=*),  intent(in)    :: user
    real(kind=coor_k), intent(in)    :: min
    real(kind=coor_k), intent(in)    :: max
    type(axis_t),      intent(inout) :: new
    logical,           intent(inout) :: error
    !
    real(kind=coor_k) :: smartref,previous
    type(unit_user_t) :: nounit
    character(len=*), parameter :: rname='REPROJECT>USER>TOPROG>FIND>GRID>REF'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    if (new%inc.gt.0.d0) then
       smartref = 1.d0-min/new%inc  ! ref so that 1st pixel (1.0) is aligned on dxmin
    else
       smartref = 1.d0-max/new%inc  ! ref (same at dmax)
    endif
    call nounit%get_from_code(code_unit_unk,error)
    if (error) return
    previous = new%ref
    call cubetools_user2prog_resolve_all(user,nounit,smartref,previous,new%ref,error)
    if (error) return
    ! Round ref to an integer value so that the projection center at the
    ! middle of a pixel. Use nearest value towards Nx/2+1 so that we stay as
    ! near as possible to the Fourier Transform solution.
    if (new%ref.lt.new%n/2.d0+1.d0) then
       new%ref = ceiling(new%ref)
    else
       new%ref = floor(new%ref)
    endif
  end subroutine cubemain_reproject_user_toprog_find_grid_ref
  !
  !------------------------------------------------------------------------
  !
  subroutine cubemain_reproject_prog_header(prog,comm,error)
    use cubeadm_clone
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(reproject_prog_t), intent(inout) :: prog
    class(reproject_comm_t), intent(in)    :: comm
    logical,                 intent(inout) :: error
    !
    character(len=*), parameter :: rname='REPROJECT>PROG>HEADER'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call cubeadm_clone_header(comm%comm%reprojected,prog%cube,prog%reprojected,error)
    if (error) return
    call cubetools_header_copy(prog%ouhead,prog%reprojected%head,error)
    if (error) return
  end subroutine cubemain_reproject_prog_header
  !
  subroutine cubemain_reproject_prog_precompute(prog,error)
    use gkernel_interfaces
    use gkernel_types
    use cubetools_spapro_types
    !----------------------------------------------------------------------
    ! Precomputes coordinates to speed up reprojection
    !----------------------------------------------------------------------
    class(reproject_prog_t), intent(inout) :: prog
    logical,                 intent(inout) :: error
    !
    integer(kind=4) :: ier
    integer(kind=4) :: npoints
    integer(kind=pixe_k) :: ixou,iyou
    real(kind=coor_k) :: xvalin,yvalin,xpixin,ypixin,oldxref,oldxval,oldyref,oldyval
    real(kind=coor_k), allocatable :: xou(:,:),you(:,:),inxou(:),inyou(:),ouxou(:),ouyou(:)
    type(projection_t) :: proj
    character(len=*), parameter :: rname='REPROJECT>PROG>PRECOMPUTE'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    npoints = prog%newx%n*prog%newy%n
    ! Setup Output projection
    call prog%reprojected%head%spa%pro%gwcs(proj,error)
    if (error) return
    !
    allocate(xou(prog%newx%n,prog%newy%n),you(prog%newx%n,prog%newy%n),stat=ier)
    if (failed_allocate(rname,'work arrays',ier,error)) return
    !
    ! Convert Output projection to Absolute coordinates
    do iyou=1,prog%newy%n
       do ixou=1,prog%newx%n
          xou(ixou,iyou) = prog%reprojected%head%spa%l%coord(ixou)
          you(ixou,iyou) = prog%reprojected%head%spa%m%coord(iyou)
       enddo
    enddo
    if (prog%conv%code.ne.code_conv_none) then
       allocate(inxou(npoints),inyou(npoints),ouxou(npoints),ouyou(npoints),stat=ier)
       if (failed_allocate(rname,'work arrays',ier,error)) return
       call rel_to_abs_1dn4(proj,xou,you,ouxou,ouyou,npoints)
       ! Change coordinate
       ! Warning: codes are reversed on purpose because we here
       !          start from the output map...
       if (prog%conv%code.eq.code_conv_equ2gal) then
          call gal_equ(ouxou,ouyou,                 &
                       inxou,inyou,prog%conv%eqin,  &
                       npoints,error)
       elseif (prog%conv%code.eq.code_conv_gal2equ) then
          call equ_gal(ouxou,ouyou,prog%conv%eqout,  &
                       inxou,inyou,                  &
                       npoints,error)
       elseif (prog%conv%code.eq.code_conv_equ2equ) then
          call equ_equ(ouxou,ouyou,prog%conv%eqout,  &
                       inxou,inyou,prog%conv%eqin,   &
                       npoints,error)
       endif
       if (error) return
    else
       allocate(inxou(npoints),inyou(npoints),stat=ier)
       if (failed_allocate(rname,'work arrays',ier,error)) return
       call rel_to_abs_1dn4(proj,xou,you,inxou,inyou,npoints)
    endif
    !
    ! Setup input projection
    call prog%cube%head%spa%pro%gwcs(proj,error)
    if (error) return    
    !
    ! Convert absolute coordinates to input projection
    call abs_to_rel_1dn4(proj,inxou,inyou,xou,you,npoints)
    !
    ! Force the conversion formula for input to be adapted to the
    ! NINT function that will be used on the reprojection. Now Xref=1.0
    oldxval = (1.0-prog%oldx%ref)*prog%oldx%inc+prog%oldx%val
    oldxref = 1.0
    oldyval = (1.0-prog%oldy%ref)*prog%oldy%inc+prog%oldy%val
    oldyref = 1.0
    !
    allocate(prog%ix(prog%newx%n,prog%newy%n),prog%iy(prog%newx%n,prog%newy%n),stat=ier)
    if (failed_allocate(rname,'Pixels',ier,error)) return
    allocate(prog%xfrac(prog%newx%n,prog%newy%n),prog%yfrac(prog%newx%n,prog%newy%n),stat=ier)
    if (failed_allocate(rname,'Pixel fractions',ier,error)) return
    !
    ! Precompute pixel fractions
    do iyou = 1,prog%newy%n
       do ixou = 1,prog%newx%n
          xvalin = xou(ixou,iyou)
          yvalin = you(ixou,iyou)
          xpixin = (xvalin-oldxval)/prog%oldx%inc+oldxref
          ypixin = (yvalin-oldyval)/prog%oldy%inc+oldyref
          prog%ix(ixou,iyou)    = int(xpixin)
          prog%iy(ixou,iyou)    = int(ypixin)
          prog%xfrac(ixou,iyou) = xpixin-dble(prog%ix(ixou,iyou))
          prog%yfrac(ixou,iyou) = ypixin-dble(prog%iy(ixou,iyou))
       enddo !ixou
    enddo ! iyou  
  end subroutine cubemain_reproject_prog_precompute
  !
  subroutine cubemain_reproject_prog_data(prog,incube,oucube,error)
    use cubeadm_opened
    !----------------------------------------------------------------------
    ! This function takes as arguments two cubes so that it can be
    ! used by an exterior caller
    !----------------------------------------------------------------------
    class(reproject_prog_t), intent(inout) :: prog
    type(cube_t),            intent(inout) :: incube
    type(cube_t),            intent(inout) :: oucube
    logical,                 intent(inout) :: error
    !
    type(cubeadm_iterator_t) :: iter
    character(len=*), parameter :: rname='REPROJECT>PROG>DATA'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call prog%precompute(error)
    if (error) return
    !
    call cubeadm_datainit_all(iter,error)
    if (error) return
    !$OMP PARALLEL DEFAULT(none) SHARED(prog,incube,oucube,error) FIRSTPRIVATE(iter)
    !$OMP SINGLE
    do while (cubeadm_dataiterate_all(iter,error))
       if (error) exit
       !$OMP TASK SHARED(prog,incube,oucube,error) FIRSTPRIVATE(iter)
       if (.not.error) & 
          call prog%loop(incube,oucube,iter,error)
       !$OMP END TASK
    enddo ! iter
    !$OMP END SINGLE
    !$OMP END PARALLEL
  end subroutine cubemain_reproject_prog_data
  !
  subroutine cubemain_reproject_prog_loop(prog,incube,oucube,iter,error)
    use cubeadm_taskloop
    use cubeadm_image_types
    !----------------------------------------------------------------------
    ! 
    !----------------------------------------------------------------------
    class(reproject_prog_t),  intent(inout) :: prog
    type(cube_t),             intent(inout) :: incube
    type(cube_t),             intent(inout) :: oucube
    type(cubeadm_iterator_t), intent(inout) :: iter
    logical,                  intent(inout) :: error
    !
    type(image_t) :: inima,ouima
    character(len=*), parameter :: rname='REPROJECT>DATA>LOOP'
    !
    call inima%associate('inima',incube,iter,error)
    if (error) return
    call ouima%allocate('ouima',oucube,iter,error)
    if (error) return
    !
    do while (iter%iterate_entry(error))
       call prog%act(iter%ie,inima,ouima,error)
       if (error) return
    enddo ! ie
  end subroutine cubemain_reproject_prog_loop
  !
  subroutine cubemain_reproject_prog_act(prog,ie,inima,ouima,error)
    use cubetools_nan
    use cubeadm_image_types
    !----------------------------------------------------------------------
    ! 
    !----------------------------------------------------------------------
    class(reproject_prog_t), intent(in)    :: prog
    integer(kind=entr_k),    intent(in)    :: ie
    type(image_t),           intent(inout) :: inima
    type(image_t),           intent(inout) :: ouima
    logical,                 intent(inout) :: error
    !
    integer(kind=pixe_k) :: ixou,iyou
    character(len=*), parameter :: rname='REPROJECT>PROG>ACT'
    !
    call inima%get(ie,error)
    if (error) return
    !
    do iyou=1,prog%newy%n
       do ixou=1,prog%newx%n
          if (prog%ix(ixou,iyou).lt.1 .or. prog%ix(ixou,iyou).ge.prog%oldx%n .or.&
               prog%iy(ixou,iyou).lt.1 .or. prog%iy(ixou,iyou).ge.prog%oldy%n) then
             ouima%val(ixou,iyou) = gr4nan
          else
             ouima%val(ixou,iyou) = &
             (1-prog%xfrac(ixou,iyou))*(1-prog%yfrac(ixou,iyou))*inima%val(prog%ix(ixou,iyou),prog%iy(ixou,iyou))+&
             prog%xfrac(ixou,iyou)*(1-prog%yfrac(ixou,iyou))*inima%val(prog%ix(ixou,iyou)+1,prog%iy(ixou,iyou))+&
             prog%xfrac(ixou,iyou)*prog%yfrac(ixou,iyou)*inima%val(prog%ix(ixou,iyou)+1,prog%iy(ixou,iyou)+1)+ &
             (1-prog%xfrac(ixou,iyou))*prog%yfrac(ixou,iyou)*inima%val(prog%ix(ixou,iyou),prog%iy(ixou,iyou)+1)
          endif
       enddo ! ixou
    enddo ! iyou
    !
    call ouima%put(ie,error)
    if (error) return
  end subroutine cubemain_reproject_prog_act
end module cubemain_reproject
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
