module mod_kepler
  use image_def
  type(gildas), save, target :: hvelo
  type(gildas), save, target :: hkpv
  !
  integer, parameter :: o_hfs=1
  integer, parameter :: o_mask=2
  integer, parameter :: o_reset=3
  integer, parameter :: o_funct=4
  integer, parameter :: o_vdisk=5
  integer, parameter :: o_widget=6
  !
  integer :: kep_nchan=0
  integer :: kep_nrad=0
  !
  logical :: kepler_setup=.true.
  logical :: kepler_usevdisk=.false.
  real(8) :: kepler_x0 = 0.
  real(8) :: kepler_y0 = 0.
  real(8) :: kepler_rota = 0.
  real(8) :: kepler_incli= 30.
  real(8) :: kepler_vmass= 2.5
  real(8) :: kepler_vdisk= 0.
  real(8) :: kepler_rint=50.
  real(8) :: kepler_rmin=50.
  real(8) :: kepler_rout=500.
  real(8) :: kepler_rmax=800.
  real(8) :: kepler_dist=150.
  real(8) :: kepler_step=50.
  real(8) :: kepler_theta=60.
  real(8) :: kepler_azimut(2)=[0d0,360d0]
  !
  real(8), allocatable :: kep_spectrum(:,:)
  real(8), allocatable :: kep_profile(:,:)
  real(4), allocatable, save, target :: kep_spectra(:,:)
  !
  logical :: kepler_usefunc=.false.
  character(len=256) :: kepler_func,kepler_expr
  character(len=32) :: kepler_variable
end module mod_kepler
!
subroutine kepler_comm(line,comm,quiet,error)
  use gkernel_types
  use gkernel_interfaces
  use imager_interfaces, only : sub_readhead, map_message
  use clean_default
  use clean_arrays
  use gbl_message
  use mod_kepler
  use iso_c_binding
!-----------------------------------------------------------------------
! @ private
! IMAGER
!
!   Support for command
!   KEPLER [?|DataCube|SHOW Arg] [/VSYSTEM Value] [/RESET [Script]
!     [/VELOCITY R function(R)] [/MASK [File]] [/HFS [File.hfs]]
!     [/WIDGET]
!
! Input parameters
!     KEPLER_X0   KEPLER_Y0     Center of disk (arcsec)
!     KEPLER_ROTA KEPLER_INCLI  Orientation, Inclination in °
!     KEPLER_VMASS              Rotation velocity at 100 au (km/s)
!     KEPLER_VDISK              Disk velocity (km/s)
!     KEPLER_DIST               Distance (pc)
!     KEPLER_ROUT               Outer radius (au) for the Spectrum
!     KEPLER_RINT               Inner radius (au) ...
!     KEPLER_RMIN               Minimum radius (au) for the profile
!     KEPLER_RMAX               Maximum radius (au) for the profile
!     KEPLER_STEP               Radial sampling (au)
!     KEPLER_THETA              Maximum angle from major axis in °
!     KEPLER_AZIMUT[2]          Valid Azimut range (°)
! Input data
!     CLEAN Image (by default) or specified data cube
! Output data
!     Integrated spectral line profile, with error bars
!     Radial profile at line center
!     Radius-Velocity diagram ("teardrop" plot)
!
! Open issues:
!     Should the profile be radially weighted ?
!     How ?
!-----------------------------------------------------------------------
  character(len=*), intent(in) :: line
  character(len=*), intent(in) :: comm
  logical, intent(inout) :: quiet
  logical, intent(out) :: error
  !
  real(kind=8), parameter :: pi=3.14159265358979323846d0
  character(len=*), parameter :: rname='KEPLER'
  !
  character(len=filename_length), save :: dtype='CLEAN'
  character(len=filename_length) :: stype, csetup, name
  character(len=8) :: utype
  character(len=32) :: topic 
  character(len=64) :: chain
  integer :: ns, nc, n1, n2, nt, i
  character(len=1), parameter :: question_mark='?'
  !
  type(gildas) :: hmap
  real, allocatable :: data(:,:,:)
  logical :: is_image, rdonly, lexist, lerr
  logical :: do_reset, do_mask, do_some, do_funct, do_vdisk, do_hfs
  type(c_ptr) :: cptr
  real(4), pointer :: r3ptr(:,:,:)
  integer :: ier,n
  type (sic_descriptor_t) :: desc
  logical :: found
  real :: hfs_tau
  !
  error = .false.
  do_vdisk = sic_present(o_vdisk,0)
  do_reset = sic_present(o_reset,0)
  do_mask  = sic_present(o_mask,0)
  do_funct = sic_present(o_funct,0)
  do_hfs = sic_present(o_hfs,0)
  do_some = do_mask.or.do_funct.or.do_vdisk
  !
  quiet = .true.
  if (kepler_setup) then
    call kepler_init(error)
    if (error) then
      call map_message(seve%e,rname,'Initialisation error, remove all KEPLER* variables')
      return
    endif
  endif
  !
  ! /WIDGET option
  if (sic_present(o_widget,0)) then
    do i=1,o_widget-1 
      if (sic_narg(i).ge.0) error = .true.
    enddo
    if (error) then
      call map_message(seve%e,rname,'No other option allowed with /WIDGET')
    endif
    if (sic_narg(0).ne.0) then
      call map_message(seve%e,rname,'No argument allowed with /WIDGET option')
      error = .true.
    endif
    if (error) return
    !
    call exec_program('@ d_kepler')
    call exec_program('@ x_kepler')
    return
  endif
  !
  ! Normal command
  if (sic_narg(0).eq.0) stype = dtype
  if (sic_present(o_reset,1)) then
    call sic_ch(line,0,1,stype,ns,.false.,error)
    if (error) return
    call sic_ch(line,o_reset,1,name,nc,.true.,error)
    if (error) return
    lexist = sic_findfile(name,csetup,' ','.ima')
    if (lexist) then
      call exec_program('@ '//trim(csetup))  
    else
      call map_message(seve%e,rname,'No such file '//trim(csetup))
      error = .true.
      return 
    endif
  else if (sic_narg(0).ge.1) then
    call sic_ch(line,0,1,stype,ns,.true.,error)
    if (error) return  
  endif
  !
  if (sic_narg(0).eq.1) then
    utype = stype
    call sic_upper(utype)
    if ((utype.eq.question_mark).or.(utype.eq.'INIT')) then
      if (do_some.or.do_hfs) then
        call map_message(seve%e,rname,'Option not allowed with KEPLER ?')
        error = .true.
        return
      endif
      if (utype.eq.'?') call exec_program('@ i_kepler') 
      ! Initialise KEPLER_SHOW variables
      call exec_program('@ d_kepler')
      if (.not.do_reset) return
    endif
    !
  else if (sic_narg(0).eq.2) then
    if (stype.eq.question_mark) then
      call sic_ch(line,0,2,topic,nt,.true.,error)
      chain = 'HELP  KEPLER '//topic
      call exec_program(chain)
      return        
    endif
    !
    call sic_ke(line,0,1,utype,ns,.true.,error)
    if (utype.eq.'SHOW') then
      if (do_some) then
        call map_message(seve%e,rname,'Option not allowed with KEPLER SHOW')
        error = .true.
        return
      endif
      ! KEPLER SHOW Arg
      call sic_ke(line,0,2,stype,ns,.true.,error)
      if (error) return 
      !
      ! /HFS or not ?
      call sic_descriptor('HFS',desc,found)
      if (do_hfs) then
        if (sic_present(o_hfs,1)) then
          call sic_ch(line,o_hfs,1,name,ns,.true.,error)  
          if (error) return
          MappingError = .true.
          if (sic_narg(o_hfs).eq.1) then      
            call exec_program('@ kepler_hfs '//name(1:ns))
          else
            call sic_r4(line,o_hfs,2,hfs_tau,.true.,error)
            if (error) return
            write(chain,*) hfs_tau
            call exec_program('@ kepler_hfs '//name(1:ns)//trim(chain))
          endif
          if (MappingError) then
            error = .true.
            return
          endif
          MappingError = .true. ! We will again call a script
        else if (.not.found) then
          call map_message(seve%e,rname,'No Hyperfine structure defined, see HELP KEPLER /HFS')
          error = .true.
          return
        endif
      else if (found) then
        call sic_delvariable('HFS',.true.,error)
      endif
      !
      if (stype.eq.'VELO') then
        call exec_program('SHOW KEPLER_VELO')
      else
        call exec_program('SHOW KEPLER '//stype(1:ns)) 
      endif
      return
    else
      call sic_ch(line,0,1,topic,nt,.true.,error)
      stype = ' '
      call sic_ch(line,0,2,stype,nt,.true.,error)
      if (stype.eq.question_mark) then
        chain = 'HELP  KEPLER '//topic
        call exec_program(chain)
      else
        call map_message(seve%e,rname,'Invalid syntax, expected KEPLER SHOW Something or KEPLER SomeThing ?')
        error = .true.
      endif
      ! Initialise KEPLER_SHOW variables
      call exec_program('@ d_kepler')
      return
    endif
  else if (do_hfs) then
    call map_message(seve%e,rname,'Option /HFS only valid with KEPLER SHOW Something')
    error = .true.
    return  
  endif
  !
  error = .false.
  if (kep_nchan.ne.0) then
    ! Delete in Reverse order - Otherwise there is a bug: KEPLER_SPECTRUM inherit a (wrong) header
    call sic_delvariable ('KEPLER_VELO',.false.,error)
    call sic_delvariable ('KEPLER_PV',.false.,error)
    call sic_delvariable ('KEPLER_PROFILE',.false.,error)
    call sic_delvariable ('KEPLER_SPECTRUM',.false.,error)
    deallocate(kep_profile,kep_spectrum,kep_spectra,hvelo%r2d) 
    kep_nchan = 0
    kep_nrad = 0
  endif
  call gildas_null(hvelo)
  error = .false.
  if (do_reset) return
  !
  quiet = .false.
  !
  ! Attempt to define the velocity function
  !
  if (do_funct) then
    !
    ! Get arguments first
    call sic_ke(line,o_funct,1,kepler_func,n1,.true.,error)
    if (error) return
    kepler_func = 'KEPLER_LAW('//kepler_func(1:n1)//')'
    n1 = n1+12
    call sic_ke(line,o_funct,2,kepler_expr,n2,.true.,error)
    !
    ! The function below is PRIVATE unfortunately
    ! call sic_del_expr('KEPLER_LAW',10,error)
    if (kepler_usefunc) then
      ! DELETE is not in "sic°_libr" cases yet
      name = 'DELETE /FUNCTION KEPLER_LAW'
      call exec_command(name,error) 
      error = .false. ! Ignore previous error if any
    endif
    !
    ! The function below is PRIVATE unfortunately
    ! sic_def_expr (kepler_func,n1,kepler_expr,n2,error)
    call sic_libr('DEFINE FUNCTION '//kepler_func(1:n1)//' '//kepler_expr(1:n2),error)
    if (error) return
    kepler_usefunc = .true.
    call map_message(seve%w,rname,'Using rotation law ' &
      & //kepler_func(1:n1)//' = '//kepler_expr(1:n2),3)
  else
    if (kepler_usefunc) then
      name = 'DELETE /FUNCTION KEPLER_LAW'
      call exec_command(name,error) 
      error = .false. ! Ignore previous error if any
    endif
    kepler_usefunc = .false.
  endif
  !
  ! Read the Image / Data file header
  dtype = stype
  call gildas_null(hmap)
  is_image = .false.
  rdonly =  .not.do_mask  !! .true.
  call sub_readhead(rname,stype,hmap,is_image,error,rdonly,fmt_r4)
  if (error) return
  !
  ! Verify shape conformance
  if ((hmap%gil%ndim.ne.3).or.(hmap%gil%faxi.ne.3)) then
    call map_message(seve%e,rname,trim(stype)//' is not a LMV cube')
    error = .true.
    return
  endif
  !
  if (do_mask) then
    Print *,'Allocating MASK'
    ! Allocate the Mask as needed here
    if (sic_present(o_mask,1)) then
      allocate(data(hmap%gil%dim(1),hmap%gil%dim(2),hmap%gil%dim(3)),stat=ier)
      if (ier.ne.0) then
        call map_message(seve%e,rname,'Data cube allocation error')
        error = .true.
        return
      endif 
      ! There is some logic error in case of MASK and IMAGE
      call sic_ch(line,o_mask,1,name,n,.true.,error)
      if (error) return
      call kepler_mask(line,hmap,data,error)
      call sic_parse_file(name,' ','.msk',hmap%file)    
      call gdf_write_image(hmap,data,lerr)
    else
      call sic_delvariable ('MASK',.false.,error)
      if (allocated(dmask)) deallocate(dmask)
      call gdf_copy_header(hmap,hmask,error)
      if (error) return
      allocate(dmask(hmap%gil%dim(1),hmap%gil%dim(2),hmap%gil%dim(3)),stat=ier)
      if (ier.ne.0) then
        call map_message(seve%e,rname,'Data cube allocation error')
        error = .true.
        return
      endif 
      call kepler_mask(line,hmask,dmask,error)
      call sic_mapgildas ('MASK',hmask,error,dmask)
    endif
  else if (is_image) then
    Kepler_Variable = stype
  else if (.not.is_image) then 
    Kepler_Variable = 'FILE'
    ! Read the data file if specified
    allocate(data(hmap%gil%dim(1),hmap%gil%dim(2),hmap%gil%dim(3)),stat=ier)
    if (ier.ne.0) then
      call map_message(seve%e,rname,'Data cube allocation error')
      error = .true.
      return
    endif
    !!Print *,'Reading HMAP data '
    call gdf_read_data(hmap,data,error)
    call gdf_close_image(hmap,lerr)
    if (error) then
      call map_message(seve%e,rname,'Data cube read error')
      error = .true.      
      return
    endif
  endif
  !
  ! Do the job
  if (.not.do_mask) then
    !!Print *,'Calling KEPLER_COMPUTE ',hmap%loca%addr, is_image
    if (is_image) then
      call adtoad(hmap%loca%addr,cptr,1)
      call c_f_pointer(cptr,r3ptr,hmap%gil%dim(1:3))
      call kepler_compute(line,hmap,r3ptr,error)
    else
      call kepler_compute(line,hmap,data,error)
    endif
  endif
  !!Print *,'Done KEPLER_COMPUTE or KEPLER_MASK ',is_image
  !
  if (kepler_usefunc) then
    !!Print *,'Deleting KEPLER_CURRENT'
    call sic_delvariable('KEPLER_CURRENT',.false.,lerr)
    call sic_delvariable('KEPLER_VPROJ',.false.,lerr)
    !!Print *,'Deleted KEPLER_VPROJ'
  endif
  ! Initialise KEPLER_SHOW variables
  call exec_program('@ d_kepler')
end subroutine kepler_comm

subroutine kepler_compute(line,hmap,data,error)
  use gkernel_types
  use gkernel_interfaces
  use imager_interfaces, except_this => kepler_compute
  use clean_arrays
  use gbl_message
  use mod_kepler
  !$ use omp_lib
!-----------------------------------------------------------------------
! @ private
! IMAGER
!
!   Support for command
!   KEPLER [Arg] [/VSYSTEM Value] [/VELOCITY R function(R)]
!
! Output data
!     Integrated spectral line profile, with error bars
!     Radial profile at line center
!     Spectral profiles as a function of radius, with error bars
!
!-----------------------------------------------------------------------
  character(len=*), intent(in) :: line ! Command line
  type(gildas), intent(inout) :: hmap
  real, intent(in) :: data(hmap%gil%dim(1),hmap%gil%dim(2),hmap%gil%dim(3))
  logical, intent(out) :: error
  !
  real(kind=8), parameter :: pi=3.14159265358979323846d0
  character(len=*), parameter :: rname='KEPLER'
  !
  real(8) :: cospa, sinpa, cosi, sini
  real(8) :: offx, offy, offmax, offmin, sec
  real(8) :: xoff, yoff, roff, x0, y0
  real(8) :: xinc, xval, xref
  real(8) :: yinc, yval, yref
  real :: bval, rstep
  integer(kind=index_length) :: np, xdim, ydim, ic1, icn
  real, allocatable :: x(:,:), y(:,:), s(:,:), t(:), r(:), v(:)
  integer, allocatable :: n(:,:), m(:)
  real, allocatable :: rwork(:,:)
  integer, allocatable :: iwork(:,:)
  logical :: blanked
  integer :: ix, jy, iv, kv, is, ie, ier, istep, nstep, mstep, fstep, lstep
  integer :: nx, ny, nv, iloc(1)
  real :: radius, theta, thetamax, vproj, vsini, theta_min, theta_max
  real :: jyperk, beam_area, factor, z, circum
  integer(kind=address_length) :: dim(7)
  logical :: strict
  integer :: je, js
  character(len=80) :: chain
  !
  integer :: ithread, nthread
  real, allocatable :: ss(:,:,:)
  integer, allocatable :: nn(:,:,:)
  !
  sec = pi/180/3600   ! Second to Radian
  !
  if (sic_present(o_vdisk,0)) then
    call sic_r8(line,o_vdisk,1,kepler_vdisk,.false.,error)
    kepler_usevdisk = .true.
  else
    kepler_usevdisk = .false.
  endif
  if (kepler_usefunc) then
    call sic_def_real('Kepler_Vproj',vproj,0,dim,.false.,error)
    call sic_def_real('Kepler_Current',radius,0,dim,.false.,error)
  endif
  !
  ! Do yo keep the spectrum if you have a full coverage (STRICT=YES)
  ! or only a partial coverage of the total velocity extent in the
  ! Radius - Velocity diagram ?
  !   The default is "lousy", i.e. partial coverage is allowed,
  strict = .false.
  call sic_get_logi('KEPLER_STRICT',strict,error)
  !
  call gdf_copy_header(hmap,hvelo,error)
  if (error) return
  hvelo%gil%ndim = 2
  hvelo%gil%dim(3) = 1
  hvelo%gil%convert(:,3) = 1.
  hvelo%char%unit = 'km/s'
  !
  thetamax = kepler_theta*pi/180
  !
  theta_min = kepler_azimut(1)
  theta_max = kepler_azimut(2)
  !
  cospa = cos(pi*kepler_rota/180)
  sinpa = sin(pi*kepler_rota/180)
  sini = sin(kepler_incli*pi/180)
  cosi = cos(kepler_incli*pi/180)
  !
  vsini = kepler_vmass * sini
  !
  ! Compute the Radial Sampling size
  rstep = (kepler_rout-kepler_rmin)/kepler_step
  nstep = int(rstep)
  if (real(nstep).ne.rstep) nstep = nstep+1
  !
  ! Rmax is by default Rout + 5 Steps
  kepler_rmax = 0
  call sic_get_dble('KEPLER_RMAX',kepler_rmax,error)
  if (kepler_rmax.le.kepler_rout) kepler_rmax = kepler_rmin+(nstep+5)*kepler_step
  mstep =   nint((kepler_rmax-kepler_rmin)/kepler_step)
  !
  offmin = kepler_rmin/kepler_dist*sec
  offmax = (kepler_rmin + mstep*kepler_step)/kepler_dist*sec 
  !!Print *,'NSTEP ',nstep,kepler_step,kepler_rint,kepler_rout,kepler_rmax
  !!Print *,'Offmin ',offmin, offmin/sec*kepler_dist
  !
  yinc = hmap%gil%inc(3)
  yref = hmap%gil%ref(3)
  yval = hmap%gil%val(3)
  !
  xref = yref
  xinc = yinc
  xdim = hmap%gil%dim(3)
  ydim = xdim
  ic1 = 1
  icn = hmap%gil%dim(3)
  np = 1
  !
  allocate (x(1,xdim),y(1,ydim),s(xdim,mstep),n(xdim,mstep),t(xdim), stat=ier)
  if (ier.ne.0) then
    call map_message(seve%e,rname,'Memory allocation failure')
    error = .true.
    return
  endif
  allocate (r(mstep), m(xdim), v(xdim), iwork(2,xdim), rwork(4,xdim), stat=ier)
  if (ier.ne.0) then
    call map_message(seve%e,rname,'Memory allocation failure')
    error = .true.
    return
  endif
  !
  ! Radial sampling
  !!Print *,'XDIM ',xdim,' MSTEP ',mstep
  do is=1,mstep
    r(is) = kepler_rmin + kepler_step*(is-0.5)
  enddo
  nx = hmap%gil%dim(1)
  ny = hmap%gil%dim(2)
  nv = hmap%gil%dim(3) 
  !!Print *,'NX,NY,NV ',nx,ny,nv 
  !
  allocate(hvelo%r2d(nx,ny),stat=ier)
  if (ier.ne.0) then
    call map_message(seve%e,rname,'Memory allocation failure')
    error = .true.
    return
  endif
  !
  bval = -1000.0
  hvelo%r2d = bval
  hvelo%gil%bval = bval
  hvelo%gil%eval = 0.
  hvelo%gil%blan_words = 2
  !
  x0 = kepler_x0 * sec
  y0 = kepler_y0 * sec
  !
  if (kepler_step.lt.(0.59*abs(hmap%gil%inc(1))*kepler_dist/sec)) then
    write(chain,'(A,I0,A,I0,A)') 'KEPLER_STEP (',nint(kepler_step), &
    ') smaller than Pixel size (',nint(abs(hmap%gil%inc(1))*kepler_dist/sec),')'
    call map_message(seve%w,rname,chain,3)
  endif 
  !
  ! Step A)   Compute 2D distribution and Radial profile
  !
  ! Note: Loop can NOT be parallel when Kepler_Usefunc is set
  ! because of call to SIC_LIBR which is not thread-safe.
  nthread = 1
  !$ if (.not.kepler_usefunc) nthread = omp_get_max_threads()
  Print *,'NTHREAD ',nthread
  allocate (ss(xdim,mstep,nthread),nn(xdim,mstep,nthread))
  s = 0
  n = 1
  ss = 0.
  nn = 0 ! Can't be one
  !
  !$OMP PARALLEL IF(.not.kepler_usefunc) DEFAULT(none) &
  !$OMP & SHARED(hmap,data,x0,y0,nx,ny,nv,cospa,sinpa,mstep) &
  !$OMP & SHARED(hvelo,theta_min,theta_max,thetamax, np,ic1,icn) & 
  !$OMP & SHARED(xdim,xref,xinc, ydim,yref,yval,yinc, bval, blanked) &
  !$OMP & SHARED(kepler_usefunc,kepler_dist,kepler_rout,kepler_rmin,kepler_vdisk,kepler_step) &
  !$OMP & SHARED(sec,vsini,cosi,sini,offmax,offmin) &
  !$OMP & PRIVATE(ix,jy,offx,offy,xoff,yoff,roff,theta,radius,vproj) &
  !$OMP & PRIVATE(iv,kv,istep,error, x,y, iwork, rwork, xval) & 
  !$OMP & SHARED(Ss,Nn,S,N,nthread) PRIVATE(ithread)                  ! S and N are Reduction arrays
  !
  ithread = 1
  !$ ithread = omp_get_thread_num()+1
  !$OMP DO COLLAPSE(2)
  do jy=1,ny
    do ix=1,nx
      !
      offy = (jy-hmap%gil%ref(2))*hmap%gil%inc(2) + hmap%gil%val(2) - y0
      if (abs(offy).gt.offmax) cycle
      offx = (ix-hmap%gil%ref(1))*hmap%gil%inc(1) + hmap%gil%val(1) - x0
      if (abs(offx).gt.offmax) cycle
      !
      ! Apply rotation Matrix and Deproject Y axis
      xoff = offx*cospa-offy*sinpa
      yoff = (offx*sinpa+offy*cospa) /cosi
      roff = sqrt(xoff**2+yoff**2)         ! Radial distance in radians
      if (roff.gt.offmax) cycle            !
      if (roff.lt.offmin) cycle
      !
      ! Apply Kepler Shift
      radius = roff*kepler_dist/sec        ! Radial distance in au
      if (radius.eq.0) cycle               ! Undefined velocity
      !
      ! Angle range
      theta = abs(atan(yoff/xoff))         ! Absolute polar angle      
      if (theta.gt.thetamax) cycle         ! Out of range: ignore
      !
      theta = atan2(yoff,xoff)             ! Polar angle - 90°
      vproj = vsini/sqrt(radius/100)*cos(theta) ! Line of sight velocity offset
      if (kepler_usefunc) then
        ! Get rotation velocity
        call sic_libr('LET Kepler_Vproj Kepler_Law(Kepler_Current)',error)
        ! Apply projection effect
        vproj = vproj*cos(theta)*sini
      endif
      !
      ! Bring to 0 360° determination
      theta = theta+pi/2.d0                ! Polar angle itself
      theta = mod(theta+2d0*pi,2d0*pi)*180.d0/pi
      ! Azimuth range
      if (theta_min.lt.theta_max) then        
        if (theta.lt.theta_min .or. theta.gt.theta_max) cycle
      else 
        if (theta.le.theta_min .and. theta.ge.theta_max) cycle 
      endif
      !
      hvelo%r2d(ix,jy) = -vproj            ! Remember the velocity
      !
      ! Subtract this velocity to that of the spectrum...
      xval = yval - vproj
      !! !!Print *,'Velocities ',xval,yval,vproj
      !
      ! Interpolate the values
      y(1,:) = data(ix,jy,:)  ! Input array
      x(1,:) = 0.0            ! Output array
      blanked = .false.     
      call all_inter (np,ic1,icn,x,xdim,xinc,xref,xval, &
        & y,ydim,yinc,yref,yval,bval,blanked,iwork,rwork)
      !
      ! Add them to the appropriate radial range
      istep = nint((radius-kepler_rmin)/kepler_step + 0.5)
      if (istep.ge.1 .and. istep.le.mstep) then
        !! !!Print *,'Adding ',ix,jy,' at ',istep, radius
        !
        if (nthread.eq.1) then
          do kv = 1,ydim 
            if (x(1,kv).ne.bval .and. s(kv,istep).ne.bval) then
              s(kv,istep) = s(kv,istep) + x(1,kv)
              n(kv,istep) = n(kv,istep) + 1
            else
              s(kv,istep) = bval
              n(kv,istep) = 0
            endif
          enddo
        else
          do kv = 1,ydim 
            if (x(1,kv).ne.bval) then
              ss(kv,istep,ithread) = ss(kv,istep,ithread) + x(1,kv)
              nn(kv,istep,ithread) = nn(kv,istep,ithread) + 1
            else
              s(kv,istep) = bval
              n(kv,istep) = 0
            endif
          enddo
        endif
      endif
    enddo
  enddo
  !$OMP END DO
  !$OMP END PARALLEL
  !
  if (nthread.eq.1) then
    where (n.gt.1) 
      s = s/(n-1)
    else where
      s = bval
    end where
  else
    do ithread=1,nthread
      s(:,:) = s(:,:) + ss(:,:,ithread)
      where(n.ne.0) n = n + nn(:,:,ithread)
    enddo
    !
    ! Normalize to get the Mean Brightness for each radius
    where (n.ne.0) 
      s = s/n
    else where
      s = bval
    end where
  endif
  !
  t = 0
  call get_jyperk(hmap,beam_area,jyperk)
  !
  ! Convert mean "brightness" to integrated flux
  !
  ! If we want to get the flux, we shall multiply by the area
  !   of each radius, including the Azimuth range,
  !   or extrapolated to the whole disk 
  !
  !! For circles
  !! circum = min(2*pi,(theta_max-theta_min)*pi/180d0)
  !! circum = 2*pi* min(1.0,(2*thetamax/pi)) 
  !! circum = 2*pi
  !
  ! For an ellipse,
  ! Approximate ellipse length, with some precision
  !   circum = pi*(1.+cosi)*(3-sqrt(4.-((1.-cosi)/(1.+cosi))**2)
  ! but even first order will do it given all other uncertainties
  circum = pi*(1.+cosi)
  ! The radius will be accounted for later.
  ! That gives the flux for the whole disk 
  factor = circum * kepler_step     ! in au^2 
  factor = factor / kepler_dist**2    
  factor = factor * sec**2          ! Get it in Steradian
  !
  ! Actually, to get the flux, we should divide by the beam area
  factor = factor / beam_area       ! Divide by the beam area
  ! 
  !   Velocity Axis
  do kv=1,ydim
    v(kv) = (kv-yref)*yinc+yval
  enddo
  !
  ! Integrated spectrum (From Kepler_Rint to Kepler_Rout) 
  fstep = nint((kepler_rint-kepler_rmin)/kepler_step)
  lstep = nint((kepler_rout-kepler_rmin)/kepler_step) 
  if (STRICT) then
    m = 1
    do istep = fstep,lstep  
      !
      if (any(n(:,istep).gt.1)) then
        do kv = 1,nv
          if (n(kv,istep).gt.1 .and. m(kv).ne.0) then
            t(kv) = t(kv) + s(kv,istep) * factor * r(istep)
          else 
            t(kv) = bval
            m(kv) = 0
          endif
        enddo
      endif
    enddo  
  else
    m = 0
    do istep = fstep,lstep  
      !
      do kv = 1,nv
        if (n(kv,istep).gt.1) then
!!          Print *,'Istep ',istep,' KV ',kv,' S ',s(kv,istep),' R ',r(istep)
          t(kv) = t(kv) + s(kv,istep) * factor * r(istep)
          m(kv) = 1
        endif
      enddo
    enddo  
    where (m.eq.0) t = bval
  endif
  !
  ! OK got them. Extract the significant part of the spectrum
  ! Patch for Blank and Zeros (?)
  is = 0
  ie = ydim
  do kv=1,ydim
    if (is.eq.0) then
      if ((t(kv).ne.bval).and.(t(kv).ne.0)) is = kv
    else if (ie.eq.ydim) then
      if ((t(kv).eq.bval).or.(t(kv).eq.0)) then
        ie = kv-1
        exit
      endif
    endif
  enddo
  !
  ! Compute the rms noise
  !!Print *,'IS IE ',is,ie
  call kepler_rms(t,ie,is,z)
  !!Print *,'Done KEPLER_RMS'
  !
  ! Allow extended display range (or not)
  js = is
  je = ie
  if (.not.STRICT) then
    is = 1
    ie = ydim
  endif
  !
  ! Take the peak velocity
  if (kepler_usevdisk) then
    iv = nint((kepler_vdisk-yval)/yinc + yref)
  else
    iloc = maxloc(t)
    iv = iloc(1)
  endif
  !
  kep_nrad = mstep  ! Full PV diagram and Profile 
  kep_nchan = ie-is+1
  allocate(kep_spectrum(kep_nchan,3),kep_profile(kep_nrad,3), &
    & kep_spectra(kep_nchan,kep_nrad),stat=ier)
  if (ier.ne.0) then
    call map_message(seve%e,rname,'Memory allocation error')
    error = .true.
    return
  endif
  kep_spectrum(:,1) = v(is:ie)
  kep_spectrum(:,2) = t(is:ie)
  kep_spectrum(:,3) = z
  !
  ! Get the radial profile from this channel - The problem
  ! is that we have no information on line width there...
  ! Let us get the brightness at line center, in K 
  !
  ! Line width can be derived from a model - They should be the same
  ! for all lines of the same object observed at the same angular
  ! resolution - They can also be derived from a fit to the line profiles.
  !
  kep_spectra = bval
  do istep=1,mstep  ! Whole range
    !
    kep_profile(istep,1) = r(istep)
    if (s(iv,istep).ne.bval) then
      ! This may be just a refinement over the previous (js,je) pair
      if (.not.STRICT) then
        do kv=1,ydim
          if (s(kv,istep).ne.bval) then
            js = kv
            exit
          endif
        enddo
        do kv=ydim,1,-1
          if (s(kv,istep).ne.bval) then
            je = kv
            exit
          endif
        enddo
      endif
      !
      call kepler_rms(s(:,istep),je,js,z)
      kep_profile(istep,2) = s(iv,istep)/jyperk
      kep_profile(istep,3) = z/jyperk
    else
      kep_profile(istep,2) = bval
      kep_profile(istep,3) = 0 
    endif 
    where (s(is:ie,istep).ne.bval)
      kep_spectra(:,istep) = s(is:ie,istep)/jyperk 
    end where
  enddo
  !!Print *,'Done KEPLER_PROFILE ',mstep
  !
  error = .false.
  dim(1:2) = [kep_nchan,3]
  call sic_def_dble('KEPLER_SPECTRUM',kep_spectrum,2,dim,.true.,error)
  !!sline = 'HEADER KEPLER_SPECTRUM'
  !!call exec_command(sline,error)
  dim(1:2) = [kep_nrad,3]  
  call sic_def_dble('KEPLER_PROFILE',kep_profile,2,dim,.true.,error)
  !
  ! We want KEPLER_PV to be a full 2-D data set,
  call gildas_null(hkpv)
  call gdf_copy_header(hmap,hkpv,error)
  if (error) return
  !!Print *,'Setting KEPLER_PV ',kep_nchan, kep_nrad
  !
  hkpv%gil%ndim = 2
  hkpv%gil%dim = 1
  hkpv%gil%dim(1) = kep_nchan
  hkpv%gil%dim(2) = kep_nrad
  hkpv%gil%convert(:,1) = [yref-dble(is),yval,yinc]
  hkpv%gil%convert(:,2) = [0.5d0,dble(kepler_rmin),dble(kepler_step)]
  hkpv%gil%faxi = 1
  hkpv%char%syst = ' '
  hkpv%char%code(1) = 'VELOCITY'
  hkpv%char%code(2) = 'RADIUS'
  hkpv%char%unit = 'K'
  hkpv%gil%bval = bval
  hkpv%gil%eval = 0
  hkpv%gil%blan_words = 2
  hkpv%gil%ptyp = p_none
  hkpv%gil%voff = yval
  hkpv%gil%vres = yinc
  hkpv%gil%fres = -yinc/299792.458d0*hkpv%gil%freq
  hkpv%loca%size = kep_nchan*kep_nrad
  hkpv%loca%addr = locwrd(kep_spectra)
  hkpv%r2d => kep_spectra
  call gdf_get_extrema (hkpv,error)
  if (error) return
  call sic_mapgildas('KEPLER_PV',hkpv,error,kep_spectra) 
  !!Print *,'Done KEPLER_PV'
  !
  ! Velocity field
  hvelo%loca%size = nx*ny
  hvelo%loca%addr = locwrd(hvelo%r2d)
  call gdf_get_extrema (hvelo,error)
  if (error) return
  call sic_mapgildas('KEPLER_VELO',hvelo,error,hvelo%r2d)
  !
  !!Print *,'Done KEPLER_VELO ',error
  error = .false.
end subroutine kepler_compute
!
subroutine kepler_rms(t,ie,is,z)
  !---------------------------------------------------------------------
  ! @ private
  ! IMAGER
  !
  !   Support for command
  !   KEPLER [Arg] [/VSYSTEM Value] [/VELOCITY R function(R)]
  !
  ! Estimate noise in the spectrum
  !---------------------------------------------------------------------
  real(4), intent(in) :: t(*)     ! Input data array
  integer, intent(in) :: ie,is    ! Range to be considered
  real(4), intent(out) :: z       ! RMS value
  !
  integer k,kv
  real :: z1,z2
  !
  ! Assume line is in the middle of selected range
  k = 0
  z1 = 0
  do kv=is,(3*is+ie)/4
    k = k+1
    z1 = z1+t(kv)**2
  enddo
  z1 = sqrt(z1/(k-1))
  k = 0
  z2 = 0
  do kv=(3*ie+is)/4,ie
    k = k+1
    z2 = z2+t(kv)**2
  enddo
  z2 = sqrt(z2/(k-1))
  !
  ! Take RMS as mean or lowest value of both parts of the spectrum
  if (abs(z2-z1).lt.0.5*sqrt(z1*z2)) then
    z = sqrt(z1*z2)
  else
    !!Print *,'Warning, secondary peak... ',z1,sqrt(z1*z2),z2
    z = min(z1,z2)
    !
    ! A second pass with filtering improves the stuff then
    k = 0
    z2 = 0
    do kv=is,ie
      if (abs(t(kv)).gt.2.5*z) cycle ! 2.5 sigma, since Sigma is rather biased by Line...
      z2 = z2+t(kv)**2
      k = k+1
    enddo
    if (k.gt.1) z = sqrt(z2/(k-1))
    !!Print *,'Final rms ',z,k
  endif
end subroutine kepler_rms
!
subroutine kepler_init(error)
  use mod_kepler
  use gkernel_types
  use gkernel_interfaces
  !---------------------------------------------------------------------
  ! @ private
  ! IMAGER
  !
  !   Support for command KEPLER
  !
  ! Initialize all variables
  !---------------------------------------------------------------------
  logical, intent(out) :: error
  !
  integer(8) :: dim(1)
  !
  error = .false.
  !
  if (.not.kepler_setup) return
  !
  kepler_x0 = 0
  kepler_y0 = 0
  kepler_rota = 0
  kepler_incli = 30.
  kepler_vmass = 3.
  kepler_rint = 50.
  kepler_rmin = 0.
  kepler_rout = 500.
  kepler_step = 50.
  kepler_dist = 150.
  kepler_theta = 60.
  kepler_azimut = [0.,360.]
  kepler_vdisk = 6.0 
  kepler_usevdisk = .false.
  kepler_variable = 'CLEAN'
  !
  call sic_def_dble('KEPLER_X0',kepler_x0,0,dim,.false.,error) 
  if (error) return
  call sic_def_dble('KEPLER_Y0',kepler_y0,0,dim,.false.,error) 
  if (error) return
  call sic_def_dble('KEPLER_ROTA',kepler_rota,0,dim,.false.,error) 
  if (error) return
  call sic_def_dble('KEPLER_INCLI',kepler_incli,0,dim,.false.,error) 
  if (error) return
  call sic_def_dble('KEPLER_VMASS',kepler_vmass,0,dim,.false.,error) 
  if (error) return
  call sic_def_dble('KEPLER_RINT',kepler_rint,0,dim,.false.,error) 
  if (error) return
  call sic_def_dble('KEPLER_RMIN',kepler_rmin,0,dim,.false.,error) 
  if (error) return
  call sic_def_dble('KEPLER_ROUT',kepler_rout,0,dim,.false.,error) 
  if (error) return
  call sic_def_dble('KEPLER_DIST',kepler_dist,0,dim,.false.,error) 
  if (error) return
  call sic_def_dble('KEPLER_STEP',kepler_step,0,dim,.false.,error) 
  if (error) return
  call sic_def_dble('KEPLER_THETA',kepler_theta,0,dim,.false.,error) 
  if (error) return
  dim(1) = 2
  call sic_def_dble('KEPLER_AZIMUT',kepler_azimut,1,dim,.false.,error) 
  if (error) return
  call sic_def_logi('KEPLER_USEVDISK',kepler_usevdisk,.false.,error)
  if (error) return
  call sic_def_dble('KEPLER_VDISK',kepler_vdisk,0,dim,.false.,error) 
  if (error) return
  !
  call sic_def_char('KEPVARIABLE',kepler_variable,.false.,error)
  kepler_setup = .false.
  !
end subroutine kepler_init
!
subroutine kepler_mask(line,hmap,data,error)
  !$ use omp_lib
  use gkernel_types
  use gkernel_interfaces
  use imager_interfaces, except_this => kepler_mask
  use clean_arrays
  use gbl_message
  use mod_kepler
!-----------------------------------------------------------------------
! @ private
! IMAGER
!
!   Support for command
!   KEPLER /MASK File [Threshold] [/VELOCITY R Function(R) ] [/VSYSTEM Value]
!
! Create a Mask for further use (Deconvolution, Flux computation)
!
! Output data
!     Keplerian Mask for deconvolution
!
!-----------------------------------------------------------------------
  character(len=*), intent(in) :: line ! Command line
  type(gildas), intent(inout) :: hmap
  real, intent(inout) :: data(hmap%gil%dim(1),hmap%gil%dim(2),hmap%gil%dim(3))
  logical, intent(out) :: error
  !
  real(kind=8), parameter :: pi=3.14159265358979323846d0
  character(len=*), parameter :: rname='KEPLER'
  !
  real(8) :: elapsed_s, elapsed_e, elapsed
  real(8) :: cospa, sinpa, cosi, sini
  real(8) :: offx, offy, offmax, offmin, sec
  real(8) :: xoff, yoff, roff, x0, y0
  real(8) :: yinc, yval, yref
  integer :: ix, jy, iv, ier
  integer :: nx, ny, nv !, iloc(1)
  real :: radius, theta, thetamax, vproj, vsini, theta_min, theta_max
  integer(kind=address_length) :: dim(2)
  !
  real :: vlocal, dvlocal, beam, filling, pa, fact, rxinc, ryinc
  complex, allocatable :: ft(:,:)
  real, allocatable :: wfft(:)
  integer :: ndim, fdim(2)
  real :: threshold
  character(len=80) :: chain
  !
  threshold = 0.
  call sic_r4(line,o_mask,2,threshold,.false.,error)
  if (threshold.lt.0. .or. threshold.gt.1.) then
    call map_message(seve%e,rname,'Threshold must be in range [0,1]')
    error = .true.
    return
  endif
  !
  sec = pi/180/3600   ! Second to Radian
  beam = sqrt(hmap%gil%majo*hmap%gil%mino) ! Beam in Radians
  !
  if (sic_present(o_vdisk,0)) then
    call sic_r8(line,o_vdisk,1,kepler_vdisk,.false.,error)
    kepler_usevdisk = .true.
  else
    kepler_usevdisk = .false.
  endif
  if (kepler_usefunc) then
    call sic_def_real('Kepler_Vproj',vproj,0,dim,.false.,error)
    call sic_def_real('Kepler_Current',radius,0,dim,.false.,error)
  endif
  !
  thetamax = kepler_theta*pi/180
  !
  theta_min = kepler_azimut(1)
  theta_max = kepler_azimut(2)
  !
  cospa = cos(pi*kepler_rota/180)
  sinpa = sin(pi*kepler_rota/180)
  sini = sin(kepler_incli*pi/180)
  cosi = cos(kepler_incli*pi/180)
  !
  vsini = kepler_vmass * sini
  !
  yinc = hmap%gil%inc(3)
  yref = hmap%gil%ref(3)
  yval = hmap%gil%val(3)
  !
  nx = hmap%gil%dim(1)
  ny = hmap%gil%dim(2)
  nv = hmap%gil%dim(3) 
  !
  x0 = kepler_x0 * sec
  y0 = kepler_y0 * sec
  beam = beam*kepler_dist/sec ! Beam in AU
  !
  offmax = kepler_rout/kepler_dist*sec
  offmin = 0.0 !!  kepler_rint/kepler_dist*sec
  data = 0.0 
  !$ elapsed_s = omp_get_wtime()
  !
  ! Note: Loop can NOT be parallel because of call to SIC_LIBR which is
  ! not thread-safe.
  !$OMP PARALLEL IF(.not.kepler_usefunc) DEFAULT(none) &
  !$OMP & SHARED(hmap,data,x0,y0,nx,ny,nv,cospa,sinpa,beam) &
  !$OMP & SHARED(kepler_usefunc,kepler_dist,kepler_rout,kepler_vdisk) &
  !$OMP & SHARED(sec,vsini,cosi,sini,offmax,offmin,yref,yinc,yval) &
  !$OMP & PRIVATE(ix,jy,offx,offy,xoff,yoff,roff,theta,radius,vproj,filling) &
  !$OMP & PRIVATE(iv,dvlocal,vlocal, error)
  !$OMP DO COLLAPSE(2)
  do jy=1,ny
    do ix=1,nx
      offy = (jy-hmap%gil%ref(2))*hmap%gil%inc(2) + hmap%gil%val(2) - y0
      if (abs(offy).gt.offmax) cycle
      !
      offx = (ix-hmap%gil%ref(1))*hmap%gil%inc(1) + hmap%gil%val(1) - x0
      if (abs(offx).gt.offmax) cycle
      !
      ! Apply rotation Matrix and Deproject Y axis
      xoff = offx*cospa-offy*sinpa
      yoff = (offx*sinpa+offy*cospa) /cosi
      !
      ! Apply Kepler Shift
      roff = sqrt(xoff**2+yoff**2)         ! Radial distance in radians
      radius = roff*kepler_dist/sec        ! Radial distance in au
      if (radius.le.0.0) cycle             ! Undefined velocity
      !
!!      theta = abs(atan(yoff/xoff))         ! Absolute polar angle      
!!      if (theta.gt.thetamax) cycle         ! Out of range: ignore
      !
      theta = atan2(yoff,xoff)             ! Polar angle - 90°
      vproj = vsini/sqrt(radius/100)*cos(theta) ! Line of sight velocity offset
      if (kepler_usefunc) then
        ! Get rotation velocity
        call sic_libr('LET Kepler_Vproj Kepler_Law(Kepler_Current)',error)
        ! Apply projection effect
        vproj = vproj*cos(theta)*sini
      endif
      !
      ! Radial range
      if (roff.gt.offmax) cycle            !
      if (roff.lt.offmin) then
        !!Print *,'Radius ',radius,' roff ',roff,' < offmin '
        cycle
      endif
      !
      if (radius.gt.beam) then
        filling = 1.0
      else
        filling = (radius/beam)**2  ! Attempt to get filling factor
      endif
      !
      dvlocal = sqrt((1.0-filling)*vproj**2 + 0.3**2) ! Attempt to  account for dilution ?
      !
      ! Compute the brightness, with 1/sqrt(r) dependency
      do iv=1,nv
        !
        vlocal = (iv-yref)*yinc + yval - kepler_vdisk
        data(ix,jy,iv) = filling * sqrt(kepler_rout/radius) * exp(-((vlocal-vproj)/dvlocal)**2)
      enddo
      !
    enddo
  enddo
  !$OMP END DO
  !$OMP END PARALLEL
  !$  elapsed_e = omp_get_wtime()
  !$  elapsed = elapsed_e - elapsed_s
  !$  elapsed_s = elapsed_e
  write(chain,'(a,a,f9.2,a)') 'Finished raw mask','  - Elapsed time ',elapsed,' sec'
  call map_message(seve%i,'KEPLER',chain)
  !
  ! Convolve by FT
  allocate (wfft(2*max(nx,ny)),ft(nx,ny),stat=ier)
  if (ier.ne.0) then
    call map_message(seve%e,rname,'Memory allocation error')
    error = .true.
    return
  endif
  !! !!Print *,'Smoothing by Clean beam ',180/pi*3600*hmap%gil%majo,180/pi*3600*hmap%gil%mino
  pa = hmap%gil%pang * 180 / pi
  rxinc = hmap%gil%inc(1)
  ryinc = hmap%gil%inc(2)
  ndim = 2
  fdim(1) = nx
  fdim(2) = ny
  !$OMP PARALLEL DEFAULT(none) &
  !$OMP & SHARED(data, rxinc, ryinc, pa, ndim, fdim, nx, ny, nv, hmap) &
  !$OMP & PRIVATE(ft, wfft, fact, iv)
  !$OMP DO
  do iv=1,nv
    ft(:,:) = cmplx(data(:,:,iv))
    call fourt(ft,fdim,ndim,-1,0,wfft)
    !
    ! Beam Area = PI * BMAJ * BMIN / (4 * LOG(2) ) for flux density
    ! normalisation
    fact = hmap%gil%majo*hmap%gil%mino*pi/(4.0*log(2.0))   &
         &    /abs(rxinc*ryinc)/(nx*ny)
    call mulgau(ft,nx,ny,   &
         &    hmap%gil%majo,hmap%gil%mino,pa,   &
         &    fact,rxinc,ryinc,-1)
    call fourt(ft,fdim,ndim,1,1,wfft)
    !
    ! Extract Real part
    data(:,:,iv)  = real(ft)
  enddo
  !$OMP END DO
  !$OMP END PARALLEL
  deallocate (wfft,ft)
  !$  elapsed_e = omp_get_wtime()
  !$  elapsed = elapsed_e - elapsed_s
  !$  elapsed_s = elapsed_e
  write(chain,'(a,a,f9.2,a)') 'Finished smmothing mask','  - Elapsed time ',elapsed,' sec'
  call map_message(seve%i,'KEPLER',chain)
  !
  ! Normalize if needed
  if (threshold.gt.0) then
    threshold  = maxval(data)*threshold
    !!Print *,'Threshold ',threshold,maxval(data)
    where (data.lt.threshold) 
      data = 0.
    else where
      data = 1.
    end where
    hmap%gil%rmax = 1.0
    hmap%gil%rmin = 0.0
  endif
  !
end subroutine kepler_mask
!
