module greg3_def
  use image_def
  !---------------------------------------------------------------------
  ! Variables and parameters for image support in GREG3
  ! For portability, SAVE Fortran variables which are target of SIC
  ! variables.
  !---------------------------------------------------------------------
  !
  ! Subset
  integer(kind=4) :: ixmin(4),ixmax(4)
  integer(kind=4) :: ixdim(4)
  !
  ! Support 'file' for the IMAGE buffer (not strictly the RG buffer...)
  type(gildas), save :: imag
  !
end module greg3_def
!
subroutine greg3_close
  use greg_dependencies_interfaces
  use greg_interfaces, except_this=>greg3_close
  use greg3_def
  !---------------------------------------------------------------------
  ! @ private
  ! GREG  -- Support routine for command GREG3\IMAGE [Name]
  !   Close the current image
  !---------------------------------------------------------------------
  ! Global
  include 'gbl_memory.inc'
  !
  integer(kind=address_length) :: zero,ip
  character(len=filename_length) :: file
  logical :: error
  integer :: ier
  !
  if (imag%loca%islo.ne.0) then
    error = .false.
    if (.not.imag%loca%read) then
      call gdf_write_data(imag, imag%r2d, error)
    endif
    call gdf_close_image(imag,error)
    if (associated(imag%r2d)) deallocate (imag%r2d, stat=ier)
    if (associated(imag%d2d)) deallocate (imag%d2d, stat=ier)
    zero = 0
    ip = gag_pointer(zero,memory)
    call gr4_rgive(0,0,imag%gil%convert,memory(ip))
  endif
  file = imag%file
  call gildas_null(imag)
  imag%file = file
end subroutine greg3_close
!
subroutine greg3_image(line,error)
  use greg_dependencies_interfaces
  use greg_interfaces, except_this=>greg3_image
  use gildas_def
  use greg3_def
  use gbl_message
  use gbl_format
  use gbl_constant
  !---------------------------------------------------------------------
  ! @ private
  ! GREG  -- Support routine for command
  !  GREG3\IMAGE [Name]
  !  1     [/PLANE I1 I2]
  !  2     [/SUBSET Imin Imax Jmin Jmax]
  !  3     [/WRITE]
  !  4     [/CLOSE]
  !---------------------------------------------------------------------
  character(len=*)                :: line   ! Input command line
  logical,          intent(inout) :: error  ! Logical error flag
  ! Local
  character(len=*), parameter :: rname='IMAGE'
  character(len=filename_length) :: name 
  integer(kind=8) :: ipl4,ipl3
  integer :: i,n,nx1,nx2,ny1,ny2,ier
  integer :: nfx,nfy,ninfx,nsupx,ninfy,nsupy
  integer(kind=address_length) :: zero,addr,addrs
  logical :: alloc
  ! Data
  data addr/0/,addrs/0/,zero/0/
  !
  call greg3_variables(error)  ! Should be moved after successful load of the image, isn't it?
  if (error)  return
  !
  if (sic_present(4,0)) then
    ! IMAGE /CLOSE : disconnect current image
    call greg3_close
    call gildas_null(imag)
    return
    !
  elseif (sic_present(0,1)) then
    ! With argument: open new one
    call sic_ch (line,0,1,name,n,.true.,error)
    if (error) return
    !
    ! New image, free previous one
    call greg3_close
    call gildas_null(imag)
    alloc = .true.
    !
    ! Open new one
    imag%file = name(1:n)
    imag%loca%read = .not.sic_present(3,0)
    call gdf_read_header(imag,error)
    if (error) then
      call greg_message(seve%e,rname,'Cannot read input file')
    elseif (imag%gil%form.ne.fmt_r4 .and. imag%gil%form.ne.fmt_r8) then
      call greg_message(seve%e,rname,'Only real images supported')
      call gdf_close_image(imag,error)
      error = .true.
    endif
    if (error) goto 98
    !
    ! Prepare graphic context
    if (imag%gil%proj_words.ne.0 .and. imag%gil%ptyp.ne.p_none) then
      if (imag%gil%xaxi.eq.0.and.imag%gil%yaxi.eq.0) then
        imag%gil%xaxi = 1
        imag%gil%yaxi = 2
      endif
      if (imag%gil%xaxi.eq.1.and.imag%gil%yaxi.eq.2) then
        call greg_projec(imag%gil%ptyp,imag%gil%a0)
      elseif (imag%gil%xaxi.eq.2.and.imag%gil%yaxi.eq.1) then
        call greg_projec(imag%gil%ptyp,imag%gil%a0)
      else
        call greg_projec(p_none,imag%gil%a0)
      endif
    else
      call greg_projec(p_none,imag%gil%a0)
    endif
    if (imag%gil%blan_words.ne.0) then
      call gr8_blanking(dble(imag%gil%bval),dble(imag%gil%eval))
    else
      imag%gil%bval = 0.0
      imag%gil%eval = -1.0
    endif
    if (imag%gil%desc_words.ne.0) then
      if (imag%char%syst.eq.'ICRS') then
        call gr8_system(type_ic,error)
      elseif (imag%char%syst.eq.'EQUATORIAL') then
        call gr8_system(type_eq,error,imag%gil%epoc)
      elseif (imag%char%syst.eq.'GALACTIC') then
        call gr8_system(type_ga,error)
      elseif (imag%char%syst.eq.'HORIZONTAL') then
        call gr8_system(type_ho,error)
      else
        call gr8_system(type_un,error)
      endif
      if (error)  goto 98
    endif
    !
  elseif (sic_present(1,0) .or. sic_present(2,0)) then
    ! No argument, /PLANE or /SUBSET
    ! Old image: use the existing one
    if (imag%loca%islo.eq.0) then
      call greg_message(seve%e,rname,'No image loaded yet')
      error = .true.
      return
    endif
    if (.not.imag%loca%read) then
      call gdf_write_data(imag, imag%r2d, error)
    endif
    alloc = .false.
    !
  else
    ! No argument, no option: list the header
    if (imag%loca%islo.eq.0) then
      call greg_message(seve%e,rname,'No image loaded yet')
      error = .true.
    else
      call gdf_print_header(imag)
    endif
    return
  endif
  !
  imag%blc = 0
  imag%trc = 0
  !
  if (sic_present(1,0)) then
    ! IMAGE /PLANE
    ! Image mode : select one plane only
    if (imag%gil%dim(4).gt.1) then
      call sic_i8 (line,1,2,ipl4,.true.,error)
      if (error) goto 98
      if (ipl4.gt.imag%gil%dim(4) .or. ipl4.lt.1) then
         call greg_message(seve%e,rname,'Slice out of bounds')
         goto 98
      endif
      imag%blc(4) = ipl4
      imag%trc(4) = ipl4
    endif
    if (imag%gil%dim(3).gt.1) then
      call sic_i8 (line,1,1,ipl3,.true.,error)
      if (error) goto 98
      if (ipl3.gt.imag%gil%dim(3) .or. ipl3.lt.1) then
        call greg_message(seve%e,rname,'Slice out of bounds')
        goto 98
      endif
      ixmin(3) = ipl3
      ixmax(3) = ipl3
      imag%blc(3) = ipl3
      imag%trc(3) = ipl3
    endif
  else
    !
    ! 1st (default) plane
    imag%blc(3) = 1
    imag%trc(3) = 1
    imag%blc(4) = 1
    imag%trc(4) = 1
  endif
  !
  ! Subset
  if (sic_present(2,0)) then
    ! IMAGE /SUBSET
    call sic_i4 (line,2,4,ny2,.true.,error)
    if (error) goto 98
    call sic_i4 (line,2,3,ny1,.true.,error)
    if (error) goto 98
    call sic_i4 (line,2,2,nx2,.true.,error)
    if (error) goto 98
    call sic_i4 (line,2,1,nx1,.true.,error)
    if (error) goto 98
    ninfx = min(nx1,nx2)
    ninfy = min(ny1,ny2)
    nsupx = max(nx1,nx2)
    nsupy = max(ny1,ny2)
    if (ninfx.lt.1 .or. nsupx.gt.imag%gil%dim(1) .or.  &
        ninfy.lt.1 .or. nsupy.gt.imag%gil%dim(2)) then
      call greg_message(seve%e,rname,'Subset does not lie in the map')
      goto 98
    endif
    !
    nfx = nsupx-ninfx+1
    nfy = nsupy-ninfy+1
    if (nfx.le.1 .or. nfy.le.1) then
      call greg_message(seve%e,rname,'Image is one-dimensional, not loaded')
      goto 98
    endif
    ixmin (1) = ninfx
    ixmax (1) = nsupx
    ixmin (2) = ninfy
    ixmax (2) = nsupy
  else
    if (imag%gil%dim(1).le.1 .or. imag%gil%dim(2).le.1) then
      call greg_message(seve%e,rname,'Image is one-dimensional, not loaded')
      goto 98
    endif
    ixmin (1) = 1
    ixmax (1) = imag%gil%dim(1)
    ixmin (2) = 1
    ixmax (2) = imag%gil%dim(2)
  endif
  do i=1,4
    ixdim(i) = ixmax(i)-ixmin(i)+1
  enddo
  !
  ! Read only required part
  if (imag%gil%form.eq.fmt_r4) then
    if (alloc)  allocate(imag%r2d(imag%gil%dim(1),imag%gil%dim(2)),stat=ier)
    call gdf_read_data (imag,imag%r2d,error)
  else
    if (alloc)  allocate(imag%d2d(imag%gil%dim(1),imag%gil%dim(2)),stat=ier)
    call gdf_read_data (imag,imag%d2d,error)
  endif
  if (error) then
     call greg3_close 
     error = .true.
     return
  endif
  imag%status = 0
  !
  if (sic_present(2,0)) then
    ! Load subset into GreG
    if (imag%gil%form.eq.fmt_r4) then
      call gr4_rgivesub(imag%gil%dim(1),imag%gil%dim(2),imag%gil%convert, &
           imag%r2d,ninfx,nsupx,ninfy,nsupy)
    else
      call gr8_tgivesub(imag%gil%dim(1),imag%gil%dim(2),imag%gil%convert, &
           imag%d2d,ninfx,nsupx,ninfy,nsupy)
    endif
  else
    ! Full image
    if (imag%gil%form.eq.fmt_r4) then
      call gr4_rgive(imag%gil%dim(1),imag%gil%dim(2),imag%gil%convert,imag%r2d)
    else
      call gr8_tgive(imag%gil%dim(1),imag%gil%dim(2),imag%gil%convert,imag%d2d)
    endif
  endif
  !
  if (imag%gil%extr_words.ne.0) then
    call gr4_egive(imag%gil%rmin,imag%gil%rmax,imag%gil%minloc(1),imag%gil%maxloc(1),  &
    imag%gil%minloc(2),imag%gil%maxloc(2),imag%gil%bval,imag%gil%eval)
  endif
  !
  return
  !
98 continue
   error = .true.
end subroutine greg3_image
!
subroutine greg3_spectrum(line,error)
  use greg_dependencies_interfaces
  use greg_interfaces, except_this=>greg3_spectrum
  !---------------------------------------------------------------------
  ! @ private
  ! Support routine for the 2 alternate syntaxes of command
  !     GREG3\SPECTRUM
  !---------------------------------------------------------------------
  character(len=*), intent(in)    :: line   ! Input command line
  logical,          intent(inout) :: error  ! Logical error flag
  ! Local
  integer(kind=4) :: iopt
  logical :: anyoption
  !
  anyoption = .false.
  do iopt=1,4  ! Command has up to 4 options
    if (sic_present(iopt,0))  anyoption = .true.
  enddo
  !
  if (anyoption) then
    call greg3_spectrum_compute(line,error)
  else
    call greg3_spectrum_extract(line,error)
  endif
  !
end subroutine greg3_spectrum
!
subroutine greg3_spectrum_extract(line,error)
  use gildas_def
  use gbl_format
  use gbl_message
  use greg_dependencies_interfaces
  use greg_interfaces, except_this=>greg3_spectrum_extract
  use greg3_def
  !---------------------------------------------------------------------
  ! @ private
  ! GILDAS      Support routine for command
  !     GREG3\SPECTRUM I,J,K
  !---------------------------------------------------------------------
  character(len=*) :: line          ! Input command line
  logical :: error                  ! Logical error flag
  ! Local
  character(len=*), parameter :: rname='SPECTRUM'
  integer :: i,ier
  integer(kind=index_length) :: j, save_blc(gdf_maxdims), save_trc(gdf_maxdims)
  integer :: islice(4)
  real(8), allocatable :: xarray(:)
  !
  ! Note: this is one of the few places where we may access (temporarily)
  ! two Memory Slots on a single Image Slot.  Accordingly, the %loca%mslo
  ! %loca%addr variables MUST be restored to their previous values...
  !
  if (imag%loca%islo.eq.0) then
    call greg_message(seve%e,rname,'No image loaded')
    error = .true.
    return
  endif
  !
  islice = 0
  do i=4,2,-1
    if (imag%gil%dim(i).gt.1) then
      call sic_i4 (line,0,i-1,islice(i),.true.,error)
      if (error) return
      if (islice(i).gt.imag%gil%dim(i) .or. islice(i).lt.1) then
        call greg_message(seve%e,rname,'Spectrum out of bounds')
        error = .true.
      endif
    endif
  enddo
  !
  save_blc = imag%blc
  save_trc = imag%trc
  imag%blc(1:4) = islice
  imag%trc(1:4) = islice
  if (imag%gil%form.eq.fmt_r4) then
    allocate (imag%r1d(imag%gil%dim(1)), stat=ier)
    call gdf_read_data (imag,imag%r1d,error)
    if (.not.error) call gr4_give('Y',imag%gil%dim(1),imag%r1d)
    deallocate(imag%r1d, stat=ier)
  elseif (imag%gil%form.eq.fmt_r8) then
    allocate (imag%d1d(imag%gil%dim(1)), stat=ier)
    call gdf_read_data (imag,imag%d1d,error)
    if (.not.error) call gr8_give('Y',imag%gil%dim(1),imag%r1d)
    deallocate(imag%d1d, stat=ier)
  else
    error = .true.
  endif
  imag%blc = save_blc 
  imag%trc = save_trc
  if (error) return
  !
  allocate(xarray(imag%gil%dim(1)),stat=ier)
  if (ier.ne.0) then
     error = .true.
     return
  endif
  do j=1,imag%gil%dim(1)
     xarray(j) = imag%gil%convert(2,1) + (j-imag%gil%convert(1,1))*imag%gil%convert(3,1)
  enddo
  call gr8_give('X',imag%gil%dim(1),xarray)
  deallocate(xarray)
end subroutine greg3_spectrum_extract
!
subroutine greg3_kill(line,error)
  use gildas_def
  use gbl_message
  use greg_dependencies_interfaces
  use greg_interfaces, except_this=>greg3_kill
  use greg3_def
  use greg_rg
  !---------------------------------------------------------------------
  ! @ private
  !  Support routine for command
  !   GRGE3\KILL
  !  Call the cursor, and display the map value or kill the pixel
  ! depending on the cursor code
  !---------------------------------------------------------------------
  character(len=*), intent(in)    :: line   !
  logical,          intent(inout) :: error  !
  ! Local
  character(len=*), parameter :: rname='KILL'
  integer :: nc,pixel(2)
  character(len=1) :: code
  real(8) :: xu,yu
  real(4) :: xp,yp
  !
  if (imag%loca%islo.eq.0 .or. imag%loca%mslo.eq.0) then
     call greg_message(seve%e,rname,'No image loaded')
     error = .true.
  elseif (imag%loca%read) then
     call greg_message(seve%e,rname,'Image is mapped in ReadOnly')
     error = .true.
  else
     error = .false.
  endif
  if (error) return
  !
  if (sic_present(0,1)) then
    call sic_ke (line,0,1,code,nc,.true.,error)
    if (error) return
    call sic_i4 (line,0,2,pixel(1),.true.,error)
    if (error) return
    call sic_i4 (line,0,3,pixel(2),.true.,error)
    if (error) return
    ! The data was "rgiven" to the RG buffer: work on rg%data
    call killr(rg%data,pixel,code)
  elseif (.not.gtg_curs()) then
    call greg_message(seve%e,rname,'No cursor available')
    error = .true.
  else
    do while (.true.)
      call gr_curs(xu,yu,xp,yp,code)
      if (code.eq.'E') return
      pixel(1) = nint((xu-imag%gil%convert(2,1))/imag%gil%convert(3,1)  &
                 + imag%gil%convert(1,1) )
      pixel(2) = nint((yu-imag%gil%convert(2,2))/imag%gil%convert(3,2)  &
                 + imag%gil%convert(1,2) )
      ! The data was "rgiven" to the RG buffer: work on rg%data
      call killr(rg%data,pixel,code)
    enddo
  endif
  !
end subroutine greg3_kill
!
subroutine killr(xarray,pixel,code)
  use gbl_message
  use greg_interfaces, except_this=>killr
  use greg3_def
  !---------------------------------------------------------------------
  ! @ private
  !  Support routine for command
  !    GREG3\KILL
  !  Display the map value or kill the pixel depending on the cursor
  ! code.
  !---------------------------------------------------------------------
  real(kind=4),     intent(inout) :: xarray(:,:)  ! Current map
  integer(kind=4),  intent(in)    :: pixel(2)     ! Pixel coordinate
  character(len=*), intent(in)    :: code         ! Code for operation
  ! Local
  real(kind=4) :: rk
  integer(kind=4) :: i,j,k,l
  !
  i = pixel(1)
  j = pixel(2)
  if (i.ge.ixmin(1) .and. i.le.ixmax(1) .and.  &
      j.ge.ixmin(2) .and. j.le.ixmax(2)) then
    k = i-ixmin(1)+1
    l = j-ixmin(2)+1
    if (code.eq.'K') then
      xarray(k,l) = imag%gil%bval
    elseif (code.eq.'V') then
      write(6,100) i,j,xarray(k,l)
    elseif (code.eq.'I') then
      rk = 0.0
      write(6,100) i,j,xarray(k,l)
      xarray(k,l) = 0.0
      if (k.gt.1) then
        if (abs(xarray(k-1,l)-imag%gil%bval).gt.imag%gil%eval) then
          xarray(k,l) = xarray(k,l)+xarray(k-1,l)
          rk = rk+1.0
        endif
      endif
      if (k.lt.ixdim(1)) then
        if (abs(xarray(k+1,l)-imag%gil%bval).gt.imag%gil%eval) then
          xarray(k,l) = xarray(k,l)+xarray(k+1,l)
          rk = rk+1.0
        endif
      endif
      if (l.gt.1) then
        if (abs(xarray(k,l-1)-imag%gil%bval).gt.imag%gil%eval) then
          xarray(k,l) = xarray(k,l)+xarray(k,l-1)
          rk = rk+1.0
        endif
      endif
      if (l.lt.ixdim(2)) then
        if (abs(xarray(k,l+1)-imag%gil%bval).gt.imag%gil%eval) then
          xarray(k,l) = xarray(k,l)+xarray(k,l+1)
          rk = rk+1.0
        endif
      endif
      if (rk.gt.0.0) then
        xarray(k,l) = xarray(k,l)/rk
        write(6,100) i,j,xarray(k,l)
      else
        call greg_message(seve%w,'KILL','All neighbours blanked')
      endif
    endif
  endif
100 format(' Pixel (',i6,',',i6,')  Value = ',1pg13.6)
end subroutine killr
!
subroutine run_greg3(line,comm,error)
  use gbl_message
  use greg_dependencies_interfaces
  use greg_interfaces, except_this=>run_greg3
  !---------------------------------------------------------------------
  ! @ public-mandatory (public but should not) (mandatory because symbol
  ! is used elsewhere)
  ! This entry is for 3-D analysis
  !---------------------------------------------------------------------
  character(len=*), intent(in)  :: line   !
  character(len=*), intent(in)  :: comm   !
  logical,          intent(out) :: error  !
  ! Local
  character(len=*), parameter :: rname='GREG3'
  integer(kind=4), save :: icall=0
  !
  error = .false.
  !
  if (icall.ne.0)  &
    call greg_message(seve%d,rname,'Reentrant call to RUN_GREG3 '//comm)
  icall = icall+1
  !
  call greg_message(seve%c,rname,line)
  !
  error = .false.
  select case (comm)
  case('IMAGE')
    call greg3_image(line,error)
  case('KILL')
    call greg3_kill(line,error)
  case('SPECTRUM')
    call greg3_spectrum(line,error)
  case default
    call greg_message(seve%e,rname,'No code to execute for '//comm)
    error = .true.
  end select
  !
  icall = icall-1
end subroutine run_greg3
!
subroutine greg3_variables(error)
  use gbl_message
  use sic_types
  use greg_dependencies_interfaces
  use greg_interfaces, except_this=>greg3_variables
  use greg3_def
  !---------------------------------------------------------------------
  ! @ private
  !---------------------------------------------------------------------
  logical, intent(inout) :: error  ! Logical error flag
  ! Local
  logical :: readonly
  type(sic_identifier_t) :: var
  logical, save :: first=.true.
  !
  if (.not.first)  return
  !
  call greg_message(seve%w,'GREG3','Defining GREG3 variables')
  call gildas_null(imag)
  !
  var%name = 'G'
  var%lname = 1
  var%level = 0
  readonly = .false.
  ! Use a nasty trick to call (without check) directly the SIC inner routine
  ! to use _ instead of % as the separator...
  call sub_def_header(var,'_',imag,readonly,0,error)
  if (error)  return
  !
  ! Keep old (obsolete) names (SB, 08-mar-2013)
  call sic_def_char('G_COORD',imag%char%syst,.false.,error)
  call sic_def_inte('G_PTYP',imag%gil%ptyp,0,0,.false.,error)
  call sic_def_inte('G_XAXI',imag%gil%xaxi,0,0,.false.,error)
  call sic_def_inte('G_YAXI',imag%gil%yaxi,0,0,.false.,error)
  !
  first = .false.
  !
end subroutine greg3_variables
