!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! This module is obsolescent. Please adapt your codes to use the more
! standard stack_spectra_tool module.
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
module cubemain_stack_spectral
  use cubetools_parameters
  use cube_types
  use cubeadm_cubeprod_types
  use cubemain_messaging
  use cubemain_windowing
  use cubemain_spaelli_types
  use cubetopology_spapos_types
  !
  public :: stack_spectral_prog_t
  public :: cubemain_stack_spectral_domean
  public :: cubemain_stack_spectral_noaperture
  private
  !
  type stack_spectral_prog_t
     type(window_array_t), pointer :: wind             ! Window to be spectrally stacked
     type(cube_t), pointer         :: cube             ! Input cube
     type(cube_prod_t)             :: stackprod        ! Output (stacked) spectrum description
     type(cube_t), pointer         :: stacked          ! Output (stacked) spectrum
     type(cube_t), pointer         :: mask             ! Mask
     type(cube_t), pointer         :: noise            ! Noise reference
     real(kind=sign_k)             :: factor           ! brightness conversion factor
     logical                       :: mask2d = .false. ! Is the mask 2d?
     logical                       :: domean = .false. ! Output is a mean spectrum
     logical                       :: domask           ! Use a mask
     logical                       :: donoise          ! Use weighting by noise
     logical                       :: contaminate      ! NaNs contaminate spectrum
     logical, allocatable          :: include(:)       ! Channel is going to be included?
     !
     ! Deferred procedures
     procedure(stack_interface_header), pointer :: header => null()
     procedure(stack_interface_loop),   pointer :: loop   => null()
   contains
     procedure :: init            => cubemain_stack_spectral_init
     procedure :: allocate        => cubemain_stack_spectral_allocate
     procedure :: header_setscale => cubemain_stack_spectral_header_set_scale
     !
     procedure :: data            => cubemain_stack_spectral_data
     procedure :: get             => cubemain_stack_spectral_get_weight_image
     procedure :: act_nomask      => cubemain_stack_spectral_act_nomask
     procedure :: act_mask        => cubemain_stack_spectral_act_mask
  end type stack_spectral_prog_t
  !
contains
  !
  !----------Interfaces--------------------------------------------------
  !
  subroutine stack_interface_header(prog,error)
    !----------------------------------------------------------------------
    ! Interface for deferred procedures
    !----------------------------------------------------------------------
    class(stack_spectral_prog_t), intent(inout) :: prog
    logical,                      intent(inout) :: error
  end subroutine stack_interface_header
  !
  subroutine stack_interface_loop(prog,iter,error)
    use cubeadm_taskloop
    !----------------------------------------------------------------------
    ! Interface for deferred procedures
    !----------------------------------------------------------------------
    class(stack_spectral_prog_t), intent(inout) :: prog
    type(cubeadm_iterator_t),     intent(inout) :: iter
    logical,                      intent(inout) :: error
  end subroutine stack_interface_loop
  !
  !----------Common-utility----------------------------------------------
  !
  subroutine cubemain_stack_spectral_domean(cube,domean,error)
    use cubetools_header_methods
    use cubetools_brightness
    !----------------------------------------------------------------------
    ! If User has not chosen a mean or a sum decide based on cube unit
    !----------------------------------------------------------------------
    type(cube_t), intent(in)    :: cube
    logical,      intent(out)   :: domean
    logical,      intent(inout) :: error
    !
    logical :: valid
    character(len=unit_l) :: unitin
    integer(kind=code_k) :: codein
    character(len=*), parameter :: rname='STACK>SPECTRAL>DOMEAN'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call cubetools_header_get_array_unit(cube%head,unitin,error)
    if (error) return
    call cubetools_brightness_valid_brightness_unit(unitin,codein,valid,error)
    if (error) return
    if (valid) then
       select case(codein)
       case (code_unit_jyperbeam,code_unit_jyperpixel,code_unit_mjypersr)
          domean = .false.
       case (code_unit_tmb)
          domean = .true.
       case (code_unit_tas)
          call cubemain_message(seve%e,rname,'Convert it with CUBE\CONVERT first')
          error = .true.
          return
       case default
          call cubemain_message(seve%e,rname,'Unknown brightness unit '//trim(unitin))
          error = .true.
          return
       end select
    else
       call cubemain_message(seve%w,rname,'Default to averaging for unit '//trim(unitin))
       domean = .true.
    endif
  end subroutine cubemain_stack_spectral_domean
  !
  !----------Entry-points------------------------------------------------
  !
  subroutine cubemain_stack_spectral_noaperture(domean,window,cube,domask,&
       mask,donoise,noise,stackprod,stacked,error)
    !----------------------------------------------------------------------
    ! Does a stack without aperture
    !----------------------------------------------------------------------
    logical,               intent(in)    :: domean
    type(window_array_t),  intent(in)    :: window
    type(cube_t), pointer, intent(inout) :: cube
    logical,               intent(in)    :: domask
    type(cube_t), pointer, intent(inout) :: mask
    logical,               intent(in)    :: donoise
    type(cube_t), pointer, intent(inout) :: noise
    type(cube_prod_t),     intent(in)    :: stackprod
    type(cube_t), pointer, intent(inout) :: stacked
    logical,               intent(inout) :: error
    !
    type(stack_spectral_prog_t) :: prog
    character(len=*), parameter :: rname='STACK>SPECTRAL>NOAPERTURE'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call prog%init(domean,window,cube,domask,mask,donoise,noise,stackprod,stacked,error)
    if (error) return
    call prog%header(error)
    if (error) return
    call prog%data(error)
    if (error) return
  end subroutine cubemain_stack_spectral_noaperture
  !
  !----------Common-code-base--------------------------------------------
  !
  subroutine cubemain_stack_spectral_allocate(prog,error)
    use gkernel_interfaces
    use cubetools_shape_types
    use cubetools_header_methods
    !----------------------------------------------------------------------
    ! allocates stack_spectral_prog_t
    !----------------------------------------------------------------------
    class(stack_spectral_prog_t), intent(inout) :: prog
    logical,                      intent(inout) :: error
    !
    type(shape_t) :: n
    integer(kind=4) :: ier,iw
    character(len=*), parameter :: rname='STACK>SPECTRAL>ALLOCATE'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call cubetools_header_get_array_shape(prog%cube%head,n,error)
    if (error) return
    allocate(prog%include(n%c),stat=ier)
    if (failed_allocate(rname,'Channels to be included',ier,error)) return
    prog%include(:) = .false.
    do iw=1,prog%wind%n
       prog%include(prog%wind%val(iw)%o(1):prog%wind%val(iw)%o(2)) = .true.
    enddo ! iw
  end subroutine cubemain_stack_spectral_allocate
  !
  subroutine cubemain_stack_spectral_header_set_scale(prog,error)
    use cubetools_header_methods
    use cubetools_brightness
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(stack_spectral_prog_t), intent(inout) :: prog
    logical,                      intent(inout) :: error
    !
    logical :: valid
    integer(kind=code_k) :: incode
    character(len=unit_l) :: inunit,ouunit
    real(kind=sign_k), parameter :: feff=1.0
    real(kind=sign_k), parameter :: beff=1.0
    character(len=*), parameter :: rname='STACK>SPECTRAL>HEADER>SET>SCALE'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call cubetools_header_get_array_unit(prog%cube%head,inunit,error)
    if (error) return
    call cubetools_brightness_valid_brightness_unit(inunit,incode,valid,error)
    if (error) return
    if (valid) then
       if (prog%domean) then
          call cubetools_header_brightness2brightness(prog%cube%head,&
               .not.applyeff,feff,beff,code_unit_tmb,prog%factor,error)
          if (error) return
          ouunit = brightness_get(code_unit_tmb)
       else
          call cubetools_header_brightness2flux(prog%cube%head,code_unit_jy,prog%factor,error)
          if (error) return
          ouunit = flux_get(code_unit_jy)
       endif
    else
       prog%factor = 1
       ouunit = inunit
    endif
    call cubetools_header_put_array_unit(ouunit,prog%stacked%head,error)
    if (error) return
  end subroutine cubemain_stack_spectral_header_set_scale
  !
  subroutine cubemain_stack_spectral_data(prog,error)
    use cubeadm_opened
    !----------------------------------------------------------------------
    ! 
    !----------------------------------------------------------------------
    class(stack_spectral_prog_t), intent(inout) :: prog
    logical,                      intent(inout) :: error
    !
    type(cubeadm_iterator_t) :: iter
    character(len=*), parameter :: rname='STACK>SPECTRAL>DATA'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call cubeadm_datainit_all(iter,error)
    if (error) return
    !
    !$OMP PARALLEL DEFAULT(none) SHARED(prog,error) FIRSTPRIVATE(iter)
    !$OMP SINGLE
    do while (cubeadm_dataiterate_all(iter,error))
       if (error) exit
       !$OMP TASK SHARED(prog,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 cubemain_stack_spectral_data
  !
  subroutine cubemain_stack_spectral_get_weight_image(prog,iter,weight,error)
    use cubeadm_image_types
    use cubeadm_taskloop
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(stack_spectral_prog_t), intent(in)    :: prog
    type(cubeadm_iterator_t),     intent(in)    :: iter
    type(image_t),                intent(out)   :: weight
    logical,                      intent(inout) :: error
    !
    integer(kind=entr_k), parameter :: one = 1
    integer(kind=pixe_k) :: ix,iy
    character(len=*), parameter :: rname='STACK>SPECTRAL>GET>WEIGHT>IMAGE'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    if (prog%donoise) then
       call weight%associate('weight',prog%noise,iter,error)
       if (error) return
       call weight%get(one,error)
       if (error) return
       do iy=1,weight%ny
          do ix=1,weight%nx
             weight%val(ix,iy) = 1/weight%val(ix,iy)**2
          enddo ! ix
       enddo ! iy
    else
       call weight%allocate('weight',prog%cube,iter,error)
       if (error) return
       do iy=1,weight%ny
          do ix=1,weight%nx
             weight%val(ix,iy) = 1
          enddo ! ix
       enddo ! iy
    endif
  end subroutine cubemain_stack_spectral_get_weight_image
  !
  !----------------------------------------------------------------------
  !
  subroutine cubemain_stack_spectral_init(prog,domean,wind,cube,domask,&
       mask,donoise,noise,stackprod,stacked,error)
    use cubetools_shape_types
    use cubetools_header_methods
    use cubedag_allflags
    !----------------------------------------------------------------------
    ! Initializes stack_spectral_prog_t
    !----------------------------------------------------------------------
    class(stack_spectral_prog_t),  intent(out)   :: prog
    logical,                       intent(in)    :: domean
    type(window_array_t), target,  intent(in)    :: wind
    type(cube_t),         pointer, intent(in)    :: cube
    logical,                       intent(in)    :: domask
    type(cube_t),         pointer, intent(in)    :: mask
    logical,                       intent(in)    :: donoise
    type(cube_t),         pointer, intent(in)    :: noise
    type(cube_prod_t),             intent(in)    :: stackprod
    type(cube_t),         pointer, intent(in)    :: stacked
    logical,                       intent(inout) :: error
    !
    type(shape_t) :: n
    character(len=*), parameter :: rname='STACK>SPECTRAL>INIT'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    prog%domean = domean
    prog%wind => wind
    prog%cube => cube
    prog%domask = domask
    prog%mask => mask
    prog%donoise = donoise
    prog%noise => noise
    prog%stacked => stacked
    !
    prog%contaminate = .false.
    !
    ! Do not replace the flag in-place, do it in a copy
    call stackprod%copy(prog%stackprod,error)
    if (error)  return
    call prog%stackprod%flag_to_flag(flag_image_or_spectrum,flag_spectrum,error)
    if (error)  return
    !
    call prog%allocate(error)
    if (error) return
    !
    prog%header => cubemain_stack_spectral_header
    if (prog%domask) then
       call cubetools_header_get_array_shape(prog%mask%head,n,error)
       if (error) return
       prog%mask2d = n%c.eq.1
       prog%loop => cubemain_stack_spectral_loop_mask
    else       
       prog%loop => cubemain_stack_spectral_loop_nomask
    endif
  end subroutine cubemain_stack_spectral_init
  !
  subroutine cubemain_stack_spectral_header(prog,error)
    use phys_const
    use cubetools_header_methods
    use cubetools_axis_types
    use cubetools_beam_types
    use cubeadm_clone
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(stack_spectral_prog_t), intent(inout) :: prog
    logical,                      intent(inout) :: error
    !
    real(kind=coor_k) :: size(2)
    type(axis_t) :: axis
    type(beam_t) :: beam
    !
    character(len=*), parameter :: rname='STACK>SPECTRAL>HEADER'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call cubeadm_clone_header(prog%stackprod,prog%cube,prog%stacked,error)
    if (error) return
    !
    call prog%header_setscale(error)
    if (error) return
    !
    ! l axis
    call cubetools_header_get_axis_head_l(prog%stacked%head,axis,error)
    if (error) return
    ! *** JP The following code is only a first approximation. We want:
    ! *** JP 1. to set the position to the average of the unprojected sky position
    ! *** JP    inside the mask. For the moment, take the projection center.
    ! *** JP 2. to set the increment to the rms of the unprojected sky distance from
    ! *** JP    the averaged position. For the moment, take the size of the image.
    size(1) = abs(axis%inc*axis%n)
    axis%ref = 0.0
    axis%val = 0.0
    axis%inc = size(1)
    axis%n = 1_pixe_k
    call cubetools_header_update_axset_l(axis,prog%stacked%head,error)
    if (error) return
    !
    ! m axis
    call cubetools_header_get_axis_head_m(prog%stacked%head,axis,error)
    if (error) return
    ! *** JP The following code is only a first approximation. We want:
    ! *** JP 1. to set the position to the average of the unprojected sky position
    ! *** JP    inside the mask. For the moment, take the projection center.
    ! *** JP 2. to set the increment to the rms of the unprojected sky distance from
    ! *** JP    the averaged position. For the moment, take the size of the image.
    size(2) = abs(axis%inc*axis%n)
    axis%ref = 0.0
    axis%val = 0.0
    axis%inc = size(2)
    axis%n = 1_pixe_k
    call cubetools_header_update_axset_m(axis,prog%stacked%head,error)
    if (error) return
    !
    ! Beam
    call cubetools_header_get_spabeam(prog%stacked%head,beam,error)
    if (error) return
    beam%major = max(size(1),size(2))
    beam%minor = min(size(1),size(2))
    ! *** JP Unclear whether this is the correct angle convention
    if (size(1).ge.size(2)) then
       beam%pang = 0.0
    else
       beam%pang = pi/2
    endif
    call cubetools_header_update_spabeam(beam,prog%stacked%head,error)
    if (error) return
  end subroutine cubemain_stack_spectral_header
  !
  !------------------------------------------------------------------------
  !
  subroutine cubemain_stack_spectral_loop_nomask(prog,iter,error)
    use cubetools_nan
    use cubeadm_taskloop
    use cubeadm_image_types
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(stack_spectral_prog_t), intent(inout) :: prog
    type(cubeadm_iterator_t),     intent(inout) :: iter
    logical,                      intent(inout) :: error
    !
    integer(kind=entr_k), parameter :: one = 1
    type(image_t) :: image,stacked,weight
    character(len=*), parameter :: rname='STACK>SPECTRAL>LOOP>NOMASK'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call image%associate('image',prog%cube,iter,error)
    if (error) return
    call prog%get(iter,weight,error)
    if (error) return
    call stacked%allocate('stacked',prog%stacked,iter,error)
    if (error) return
    !
    do while (iter%iterate_entry(error))
       if (prog%include(iter%ie)) then
          call image%get(iter%ie,error)
          if (error) return
          call prog%act_nomask(image,weight,stacked,error)
          if (error) return
       else
          stacked%val(one,one) = gr4nan
       endif
       call stacked%put(iter%ie,error)
       if (error) return
    enddo ! ie
  end subroutine cubemain_stack_spectral_loop_nomask
  ! 
  subroutine cubemain_stack_spectral_act_nomask(prog,image,weight,stacked,error)
    use cubetools_nan
    use cubeadm_image_types
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(stack_spectral_prog_t), intent(in)    :: prog
    type(image_t),                intent(in)    :: image
    type(image_t),                intent(in)    :: weight
    type(image_t),                intent(inout) :: stacked
    logical,                      intent(inout) :: error
    !
    integer(kind=pixe_k), parameter :: one = 1
    integer(kind=pixe_k) :: ix,iy
    real(kind=sign_k) :: val,wei
    character(len=*), parameter :: rname='STACK>SPECTRAL>ACT>NOMASK'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    val = 0
    wei = 0
    if (prog%contaminate) then
       do iy=1,image%ny
          do ix=1,image%nx
             val = val + image%val(ix,iy)*weight%val(ix,iy)
             wei = wei + weight%val(ix,iy)
          enddo ! ix
       enddo ! iy
    else
       do iy=1,image%ny
          do ix=1,image%nx
             if (.not.ieee_is_nan(image%val(ix,iy)).and..not.ieee_is_nan(weight%val(ix,iy))) then
                val = val + image%val(ix,iy)*weight%val(ix,iy)
                wei = wei + weight%val(ix,iy)
             endif
          enddo ! ix
       enddo ! iy
    endif
    if (wei.gt.0) then
       stacked%val(one,one) = val/wei*prog%factor
    else
       stacked%val(one,one) = gr4nan
    endif
  end subroutine cubemain_stack_spectral_act_nomask
  !
  !------------------------------------------------------------------------
  !
  subroutine cubemain_stack_spectral_loop_mask(prog,iter,error)
    use cubetools_nan
    use cubeadm_taskloop
    use cubeadm_image_types
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(stack_spectral_prog_t), intent(inout) :: prog
    type(cubeadm_iterator_t),     intent(inout) :: iter
    logical,                      intent(inout) :: error
    !
    integer(kind=entr_k), parameter :: one = 1
    type(image_t) :: image,stacked,weight,mask
    character(len=*), parameter :: rname='STACK>SPECTRAL>LOOP>MASK'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    call image%associate('image',prog%cube,iter,error)
    if (error) return
    call mask%associate('mask',prog%mask,iter,error)
    if (error) return
    call prog%get(iter,weight,error)
    if (error) return
    call stacked%allocate('stacked',prog%stacked,iter,error)
    if (error) return
    !
    if (prog%mask2d) then
      call mask%get(one,error)
      if (error) return 
    endif
    do while (iter%iterate_entry(error))
       if (prog%include(iter%ie)) then
          if (.not.prog%mask2d) then
             call mask%get(iter%ie,error)
             if (error) return 
          endif
          call image%get(iter%ie,error)
          if (error) return
          call prog%act_mask(image,weight,mask,stacked,error)
          if (error) return
       else
          stacked%val(one,one) = gr4nan
       endif
       call stacked%put(iter%ie,error)
       if (error) return
    enddo ! ie
  end subroutine cubemain_stack_spectral_loop_mask
  !
  subroutine cubemain_stack_spectral_act_mask(prog,image,weight,mask,stacked,error)
    use cubetools_nan
    use cubeadm_image_types
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(stack_spectral_prog_t), intent(in)    :: prog
    type(image_t),                intent(in)    :: image
    type(image_t),                intent(in)    :: weight
    type(image_t),                intent(in)    :: mask
    type(image_t),                intent(inout) :: stacked
    logical,                      intent(inout) :: error
    !
    integer(kind=pixe_k), parameter :: one = 1
    integer(kind=pixe_k) :: ix,iy
    real(kind=sign_k) :: val,wei
    character(len=*), parameter :: rname='STACK>SPECTRAL>ACT>MASK'
    !
    call cubemain_message(mainseve%trace,rname,'Welcome')
    !
    val = 0
    wei = 0
    if (prog%contaminate) then
       do iy=1,image%ny
          do ix=1,image%nx
             if (ieee_is_nan(mask%val(ix,iy))) cycle
             val = val + image%val(ix,iy)*weight%val(ix,iy)
             wei = wei + weight%val(ix,iy)
          enddo ! ix
       enddo ! iy
    else
       do iy=1,image%ny
          do ix=1,image%nx
             if ((ieee_is_nan(image%val(ix,iy))).or.&
                  (ieee_is_nan(weight%val(ix,iy))).or.&
                  (ieee_is_nan(mask%val(ix,iy)))) cycle
             val = val + image%val(ix,iy)*weight%val(ix,iy)
             wei = wei + weight%val(ix,iy)
          enddo ! ix
       enddo ! iy
    endif
    if (wei.gt.0) then
       stacked%val(one,one) = val/wei*prog%factor
    else
       stacked%val(one,one) = gr4nan
    endif
  end subroutine cubemain_stack_spectral_act_mask
end module cubemain_stack_spectral
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
