module greg_column
  !---------------------------------------------------------------------
  ! Support module for command GREG\COLUMN
  !---------------------------------------------------------------------
  integer(kind=4) :: jund              ! Logical unit for formatted files
  integer(kind=4) :: line1             ! First line to read in file
  integer(kind=4) :: line2             ! Last line to read in file
  !
end module greg_column
!
subroutine defdel_xyz(action,i,error)
  use gbl_message
  use sic_types
  use greg_dependencies_interfaces
  use greg_interfaces, except_this=>defdel_xyz
  use greg_xyz
  !---------------------------------------------------------------------
  ! @ private
  !  Define or delete one of the X, Y, or Z Greg variables. An error is
  ! raised if the variable already exists and was not created by Greg.
  !---------------------------------------------------------------------
  integer(kind=4), intent(in)    :: action  ! 0=check, 1=define, 2=delete
  integer(kind=4), intent(in)    :: i       ! 1=X, 2=Y, 3=Z
  logical,         intent(inout) :: error   ! Logical error flag
  ! Local
  type(sic_descriptor_t) :: desc
  logical :: found,err
  character(len=1), parameter :: var(3) = (/ 'X','Y','Z' /)
  character(len=60) :: chain
  ! Data
  data chain /'Variable # not defined by GreG'/
  !
  found = .false.
  call sic_descriptor(var(i),desc,found)
  if (found) then
    ! Variable exists
    if (desc%addr.ne.locwrd(column_xyz(1,i))) then
      chain(10:10) = var(i)
      call greg_message(seve%e,'COLUMN',chain)
      error = .true.
      return
    endif
    !
    if (action.eq.2) then
      call sic_delvariable(var(i),.false.,err)
    endif
    !
  elseif (action.eq.1) then
    ! Variable does not yet exist
    call sic_def_dble(var(i),column_xyz(1,i),1,nxy,.false.,error)
    if (error)  return
  endif
  !
end subroutine defdel_xyz
!
subroutine delete_xyz(delv,error)
  use greg_dependencies_interfaces
  use greg_interfaces, except_this=>delete_xyz
  use gildas_def
  use greg_xyz
  !---------------------------------------------------------------------
  ! @ private
  ! Delete the SIC variables named X, Y and Z
  !---------------------------------------------------------------------
  logical, intent(in)    :: delv
  logical, intent(inout) :: error
  ! Local
  integer(kind=4) :: action,i
  !
  if (delv) then
    action = 2  ! Check and delete
  else
    action = 0  ! Check only
  endif
  !
  do i=1,3
    call defdel_xyz(action,i,error)
    if (error)  return
  enddo
  !
end subroutine delete_xyz
!
subroutine create_xyz(error)
  use greg_dependencies_interfaces
  use greg_interfaces, except_this=>create_xyz
  use greg_xyz
  !---------------------------------------------------------------------
  ! @ private
  !  Create the SIC variables named X, Y and Z, if they are not yet
  ! defined. If yes, they are assumed to point to the correct memory
  ! object (checked in delete_xyz).
  !---------------------------------------------------------------------
  logical, intent(inout) :: error
  ! Local
  integer(kind=4) :: action
  !
  action = 1  ! Check and create
  !
  if (associated(column_x)) then
    call defdel_xyz(action,1,error)
    if (error)  return
  endif
  !
  if (associated(column_y)) then
    call defdel_xyz(action,2,error)
    if (error)  return
  endif
  !
  if (associated(column_z)) then
    call defdel_xyz(action,3,error)
    if (error)  return
  endif
  !
end subroutine create_xyz
!
subroutine more_xyz(n,error)
  use gildas_def
  use gbl_message
  use greg_dependencies_interfaces
  use greg_interfaces, except_this=>more_xyz
  use greg_xyz
  !---------------------------------------------------------------------
  ! @ private
  ! Re-allocate more buffer space for the internal X, Y and Z buffers
  !---------------------------------------------------------------------
  integer(kind=4), intent(in)    :: n      !
  logical,         intent(inout) :: error  ! Logical error flag
  ! Local
  character(len=*), parameter :: rname='GREG'
  integer :: ier
  character(len=message_length) :: mess
  !
  if (n.lt.maxxy) return  ! Current allocation is enough
  !
  if (maxxy.ne.0) then
    deallocate(column_xyz)
    nullify(column_x,column_y,column_z)
    maxxy = max(2*maxxy,n)
  else
    maxxy = n
  endif
  maxxy = max(8192,maxxy)
  write(mess,*) 'Re-allocating XYZ buffers to ',maxxy,' > ',n
  call greg_message(seve%i,rname,mess)
  !
  allocate(column_xyz(maxxy,3),stat=ier)
  if (failed_allocate(rname,'X, Y, and Z buffers',ier,error))  return
  !
  column_x => column_xyz(:,1)
  column_y => column_xyz(:,2)
  ! Not yet, only when required
  !   column_z => column_xyz(:,3)
  ! but then the Z array must be undefined
  column_z => null()
  nxy = 0
end subroutine more_xyz
!
! Logic used to know if Z is defined must be revised
! Are we allowed to read X, Y, Z from 3 different files?
! This might be useful, but is quite difficult with the dynamic
! reallocation of arrays.
!
! Currently:
!    re-read X or Y implies re-initializing Z
!    re-read Z does not implies anything on X or Y, resulting in a problem
!       if Z is longer than X
!
subroutine column(line,error)
  use gildas_def
  use image_def
  use greg_dependencies_interfaces
  use greg_interfaces, except_this=>column
  use greg_column
  use greg_xyz
  use greg_image
  use gbl_message
  use gbl_format
  !---------------------------------------------------------------------
  ! @ private
  ! GREG  Support routine for command
  !       COLUMN [X nx] [Y ny] [Z nz]
  !  1           [/FILE Filename]
  !  2           [/LINE L1 L2]
  !  3           [/TABLE Tablename]
  !  4           [/COMMENT "Separator"]
  !  5           [/CLOSE]
  !---------------------------------------------------------------------
  character(len=*), intent(in)    :: line   ! Command line
  logical,          intent(inout) :: error  ! Error flag
  ! Global
  include 'gbl_memory.inc'
  ! Local
  character(len=*), parameter :: rname='COLUMN'
  character(len=1) :: code,com
  character(len=filename_length) :: chain
  integer(4) :: ncx,ncy,ncz,ncxyz(3),iarg
  integer :: nc,icode,ier,i
  integer :: ifirst
  logical :: newx,delv
  character(len=message_length) :: mess
  character(len=1), parameter :: c(3) =  (/ 'X','Y','Z' /)
  integer, allocatable :: work(:)
  type(gildas) :: t
  integer(kind=4), parameter :: optfile=1
  integer(kind=4), parameter :: optline=2
  integer(kind=4), parameter :: opttable=3
  integer(kind=4), parameter :: optcomment=4
  integer(kind=4), parameter :: optclose=5
  ! Save
  character(len=filename_length), save :: datafile=''
  logical, save :: table=.false.
  save newx,t
  !
  ! The /TABLE option will be re-written in the following way
  ! - read the header when the /TABLE option is given
  ! - only read the desired columns by setting BLC / TRC adequately
  ! - transfer to appropriate location according to /LINE option
  !
  ! - Reading is done indirectly, though, as the data type
  !   may (and usually will) not match.
  !
  ! The TABLE is closed only if needed (/FILE or /TABLE options
  ! are present)
  !
  delv = .false.
  if (sic_present(opttable,0)) then  ! /TABLE option
    ! Open new table if necessary
    if (sic_present(opttable,1)) then
      if (sic_present(optfile,0)) then   ! /FILE
        call greg_message(seve%e,rname,'Incompatible options /FILE and /TABLE')
        error = .true.
        return
      else
        call sic_ch (line,opttable,1,chain,nc,.true.,error)
        if (error) return
      endif
    else
      call greg_message(seve%e,rname,'Missing argument of option /TABLE')
      error = .true.
      return
    endif
    if (t%loca%islo.ne.0) then
      call gdf_close_image (t,error)
    endif
    call sic_parse_file(chain,' ','.gdf',t%file)
    call gdf_read_header(t,error)
    if (t%gil%ndim.gt.2) then
      call greg_message(seve%e,rname,'Table must have 1 or 2 dimensions')
      error = .true.
    endif
    if (error) then
      call greg_message(seve%e,rname,'Error reading table')
      goto 98
    endif
    write(chain,'(A,I0,A,I0,A)') 'Input file has ',t%gil%dim(2),' column(s) ',t%gil%dim(1),  &
    ' lines'
    call greg_message(seve%i,rname,chain)
    ! New file: reset start/end lines
    line1 = 0  ! Code for everything (default)
    line2 = 0  ! Code for everything (default)
    table = .true.
    newx = .true.
    delv = .true.
    !
  elseif (sic_present(optfile,0)) then  ! /FILE option
    table = .false.
    call sic_ch (line,1,1,chain,nc,.true.,error)
    if (error) return
    call sic_parse_file(chain,' ','.dat',datafile)
    call column_open(datafile,maxxy,error)
    if (error) return
    newx = .true.
    delv = .true.
    !
  else
    ! No /TABLE nor /FILE: reuse previous one
    if (table) then
      ! Check the TABLE is valid
      if (t%loca%islo.eq.0) then
        call greg_message(seve%e,rname,'No previous table connected')
        error = .true.
        return
      endif
    else
      if (datafile.eq.'') then
        call greg_message(seve%e,rname,'No previous file connected')
        error = .true.
        return
      endif
      call column_open(datafile,maxxy,error)
      if (error) return
      newx = .true.
      delv = .false.  ! Should be .false. if the columns are read in several calls,
                      ! but should be .true. if e.g. the number of lines changes
                      ! between calls...
    endif
  endif
  !
  !  /LINES option: set up Lines
  if (sic_present(optline,0)) then
    call sic_i4 (line,optline,1,line1,.true.,error)
    if (error) return
    call sic_i4 (line,optline,2,line2,.false.,error)
    if (error) return
    newx = .true.  ! Not obvious, if these are the same lines as before...
    delv = .true.
  endif
  !
  ! Delete X,Y,Z buffers, unless we are just simply closing an open file
  if (sic_present(optclose,0).and.(sic_narg(0).le.0).and..not.table) then
    ! COLUMN /CLOSE (with no more argument nor options)
    call greg_message(seve%w,rname,'Closing previous /FILE with /CLOSE is obsolete')
    ! Close the file uselessly opened just above
    call column_close(error)
  else
    call delete_xyz (delv,error)
    if (error) return
  endif
  !
  ! Skip reading data if nothing else
  if (sic_narg(0).le.0) goto 97
  !
  ! Delete Z buffer if new data set
  if (delv .and. newx)  nullify(column_z)
  !
  ncx=0
  ncy=0
  ncz=0
  !
  ! Check syntax and number of arguments
  do iarg=1,sic_narg(0),2
    !
    ! Get variable name
    call sic_ke (line,0,iarg,code,nc,.true.,error)
    if (error) goto 99
    !
    ! Get column number
    call sic_i4 (line,0,iarg+1,nc,.true.,error)
    if (error) goto 99
    if (nc.le.0) then
      write(mess,'(3A,I0)') 'Invalid ',code,' column number ',nc
      call greg_message(seve%e,rname,mess)
      error = .true.
      return
    endif
    !
    ! Associate variable and column number
    if (code.eq.'X') then
      ncx = nc
    elseif (code.eq.'Y') then
      ncy = nc
    elseif (code.eq.'Z') then
      ncz = nc
      if (.not.associated(column_z)) column_z => column_xyz(:,3)
    else
      call greg_message(seve%e,rname,'Invalid variable '//code)
      error = .true.
      return
    endif
  enddo
  !
  ! Read the values
  if (table) then  ! /TABLE
    if (line1.eq.0) line1 = 1
    if (line2.eq.0) line2 = t%gil%dim(1)
    ifirst = min(line1,t%gil%dim(1))-1
    nxy  = min(line2,t%gil%dim(1)) - ifirst
    ! Should try to recover by allocating more virtual memory
    do while (nxy.gt.maxxy)
      call more_xyz(nxy,error)
      newx = .true.
      if (ncz.ne.0)  column_z => column_xyz(:,3)
      nxy = min(line2,t%gil%dim(1)) - ifirst
    enddo
    if (nxy.gt.maxxy) then
      write(chain,'(A,I6)') 'Too many data points, maximum is ',maxxy
      call greg_message(seve%e,rname,chain)
      error = .true.
      return
    elseif (nxy.le.0) then
      write(chain,'(A)') 'Negative number of data points'
      call greg_message(seve%e,rname,chain)
      error = .true.
      return
    endif
    !
    allocate (work(t%gil%dim(1)), stat=ier)
    ncxyz = (/ ncx,ncy,ncz /)
    !
    do i=1,3
      if (ncxyz(i).gt.0 .and. ncxyz(i).le.t%gil%dim(2)) then
        ! Read the appropriate BLC / TRC here
        t%blc(2) = ncxyz(i)
        t%trc(2) = ncxyz(i)
        !
        if (t%gil%form.eq.fmt_r4) then
          call gdf_read_data (t,work,error)
          if (error) return
          call r4tor8(work,column_xyz(1,i),nxy)
        elseif (t%gil%form.eq.fmt_i4) then
          call gdf_read_data (t,work,error)
          if (error) return
          call i4tor8(work,column_xyz(1,i),nxy)
        elseif (t%gil%form.eq.fmt_r8) then
          call gdf_read_data (t,column_xyz(1,i),error)
        endif
      elseif (ncxyz(i).ne.0) then
        call greg_message(seve%e,rname,C(i)//' column out of range')
      endif
    enddo
    deallocate( work)
  else  ! /FILE
    if (sic_present(optcomment,0)) then
      call sic_ch(line,optcomment,1,com,nc,.true.,error)
      if (error) return
      if (nc.ne.1) then
        call greg_message(seve%e,rname,'Comment separator must be 1 char')
        error = .true.
        return
      endif
    else
      com = comment
    endif
    if (ncx.ge.1 .or. ncy.ge.1 .or. ncz.ge.1) then
      call readcol(ncx,column_x,ncy,column_y,ncz,column_z,nxy,maxxy,  &
        error,icode,com)
      if (error) then   ! Close file in case of error
        call column_close(error)
        error = .true.
        return
      endif
      do while (icode.ne.0)
        call more_xyz(2*nxy,error)
        if (ncz.ge.1) column_z => column_xyz(:,3)
        newx = .true.
        call readcol(ncx,column_x,ncy,column_y,ncz,column_z,nxy,  &
          maxxy,error,icode,com)
        if (error) then
          call column_close(error)
          error = .true.
          return
        endif
      enddo
    endif
    call column_close(error)
  endif
  if (newx) then
    call create_xyz(error)
    newx = .false.
  endif
  !
  ! /CLOSE option: only to free /TABLE
97 if (sic_present(optclose,0)) then
    if (t%loca%islo.ne.0) then
      call gdf_close_image (t,error)
    endif
  endif
  !
  ! Normal exit
  return
  !
  ! Error reading table
98 continue
  call gdf_close_image (t,error)
  return
  !
  ! Error in list
99 call greg_message(seve%e,rname,'Syntax error in list')
  error = .true.
  !
contains
  subroutine column_open(name,maxxy,error)
    !---------------------------------------------------------------------
    ! Open a formatted file for reading columns
    !---------------------------------------------------------------------
    character(len=*), intent(in)    :: name   ! The file name
    integer(kind=4),  intent(in)    :: maxxy  ! Maximum number of lines in file
    logical,          intent(inout) :: error  ! Logical error flag
    ! Local
    integer(kind=4) :: ier
    character(len=message_length) :: chain
    !
    ! New file: reset start/end lines
    line1 = 1
    line2 = 2147483647
    !
    ier = sic_getlun(jund)
    if (ier.ne.1) then
      error = .true.
      return
    endif
    ier = sic_open(jund,name,'OLD',.true.)
    if (ier.ne.0) then
      chain = 'Error opening file '//name
      call greg_message(seve%e,'COLUMN',chain)
      call putios('E-COLUMN, ',ier)
      error = .true.
    endif
  end subroutine column_open
  !
  subroutine column_close(error)
    !---------------------------------------------------------------------
    ! Close the COLUMN reserved logical unit (if opened)
    !---------------------------------------------------------------------
    logical, intent(inout) :: error
    ! Local
    integer(kind=4) :: ier
    !
    ier = sic_close(jund)
    call sic_frelun(jund)
    !
  end subroutine column_close
  !
end subroutine column
!
subroutine readcol(ncx,arrx,ncy,arry,ncz,arrz,nxy,mxy,error,icode,com)
  use gbl_message
  use greg_interfaces, except_this=>readcol
  use greg_column
  !---------------------------------------------------------------------
  ! @ private
  !   Read up to 3 columns in the input file. Uses list-directed format
  ! but avoid comment lines beginning with a comment character (default
  ! "!", but user selectable).
  !---------------------------------------------------------------------
  integer(kind=4),  intent(in)    :: ncx      ! Column number of X values
  real(kind=8),     intent(out)   :: arrx(*)  ! X array of values
  integer(kind=4),  intent(in)    :: ncy      ! Column number of Y values
  real(kind=8),     intent(out)   :: arry(*)  ! Y array of values
  integer(kind=4),  intent(in)    :: ncz      ! Column number of Z values
  real(kind=8),     intent(out)   :: arrz(*)  ! Z array of values
  integer(kind=4),  intent(out)   :: nxy      ! Number of values read
  integer(kind=4),  intent(in)    :: mxy      ! Maximum number of values
  logical,          intent(inout) :: error    ! Logical error flag
  integer(kind=4),  intent(out)   :: icode    ! Return code
  character(len=1), intent(in)    :: com      ! Comment character
  ! Local
  character(len=*), parameter :: rname='COLUMN'
  character(len=1) :: acom
  real(kind=8), allocatable :: vars(:)
  integer(kind=4) :: i,ier,nc,iline
  character(len=256) :: line
  character(len=message_length) :: mess
  !
  icode = 0
  nxy = 0
  !
  ! Skip the first 'line1-1' lines
  do iline = 1,line1-1
    read(jund,*,iostat=ier)
    if (ier.lt.0)  goto 13     ! EOF
    if (ier.ne.0)  goto 25     ! Error
  enddo
  !
  nc = max(ncx,ncy,ncz)
  if (nc.le.0) then
    call greg_message(seve%e,rname,'Invalid column numbers')
    error = .true.
    return
  endif
  !
  ! Allocate a line array
  allocate(vars(nc),stat=ier)
  if (ier.ne.0) then
    write(mess,'(A,I0)') 'Can not allocate array for column ',nc
    call greg_message(seve%e,rname,mess)
    error = .true.
    return
  endif
  !
  ! Loop on lines
  do iline = line1,line2
    read(jund,*,iostat=ier) (vars(i),i=1,nc)
    if (ier.lt.0)  exit      ! EOF
    !
    if (ier.ne.0) then
      ! Could not read into numerics. Try into a string.
      backspace(jund)
      read(jund,'(A)',iostat=ier) line
      if (ier.ne.0)  goto 25 ! Error
      !
      ! Recover from the comment lines
      acom = adjustl(line)
      if (acom.eq.com) cycle
      !
      ! Else abort reading
      write (mess,'(A,I0,A)')  &
        'Error in list-directed read, line number ',iline,':'
      call greg_message(seve%e,rname,mess)
      call greg_message(seve%r,rname,line)
      goto 26
    endif
    !
    nxy = nxy+1
    if (nxy.gt.mxy) then
      icode = 1  ! Return to allocate more XYZ, re-start reading from beginning
      goto 13
    endif
    !
    ! Assign
    if (ncx.ge.1) arrx(nxy) = vars(ncx)
    if (ncy.ge.1) arry(nxy) = vars(ncy)
    if (ncz.ge.1) arrz(nxy) = vars(ncz)
  enddo
  !
  ! Successful exit
13 continue
  if (nxy.eq.0)  call greg_message(seve%w,rname,'No data read')
  rewind(jund)
  if (allocated(vars))  deallocate(vars)
  return
  !
  ! Erroneous exit
25 continue
  write (mess,'(A,I0)')  &
    'Serious error with this file, line number ',iline
  call greg_message(seve%e,rname,mess)
26 continue
  error = .true.
  rewind(jund)
  if (allocated(vars))  deallocate(vars)
  return
  !
end subroutine readcol
