! This file to be updated if GIO supports mxdim>4
module sic_bintable
  use gildas_def
  !---------------------------------------------------------------------
  ! FITS Binary tables support
  !---------------------------------------------------------------------
  integer, parameter :: mcols=999      ! Maximum number of columns in a 3D table
  integer(kind=address_length) :: vmaddr(mcols)   ! Address of variable got by SIC_GETVM
  integer :: varformat(mcols)          ! Format of variable
  real :: colscal(mcols)               ! Scaling of column
  real :: colzero(mcols)               ! Offset of column
  integer :: ncols                     ! Number of columns in table
  integer :: coladdr(mcols+1)          ! Start of column i (in bytes)
  integer :: colfmt(mcols)             ! Format of column i (SIC codes)
  integer :: nitem(mcols)              ! Repeat count for column i
  integer :: coldim(4,mcols)           ! Possible 'shape' of column
  integer :: colndim(mcols)            ! Corresponding multi-dimensionality
  ! Still in limbo for very good and true reasons by GD.
  !     INTEGER COLNULL(MCOLS)         ! Value Taken As Blanked
  logical :: usescal(mcols)       !
  character(len=64) :: collabl(mcols)  ! LABEL (type information) of column i
  character(len=20) :: colform(mcols)  ! Format of column i (FITS syntax)
  character(len=20) :: colunit(mcols)  ! Unit of data in column i
  logical :: transposevar              ! Tells if we want arrays transposed
end module sic_bintable
!
subroutine sic_fits(line,global,error)
  use gildas_def
  use sic_types
  use sic_dependencies_interfaces, no_interface=>gfits_getbuf
  use sic_interfaces, except_this=>sic_fits
  use gbl_message
  use gbl_format
  !---------------------------------------------------------------------
  ! @ private
  !
  !     Support routine for command DEFINE FITS
  !
  ! SIC\DEFINE FITS  Var File.fits  [Key1 Key2 Key3 Key4]
  !    where the optional Key is any of [index#|Header|Transpose|Basic]
  !    index# being the extension number
  !
  ! READS a FITS FILE, and defines/load SIC variables according to
  ! what is found.
  !      if index# is present, only load this Xtension number
  !      if Header is present, do not load the main data
  !      if Transpose is present, transpose Tables in Xtension
  !      if Basic is present, only load basic keywords, no fancy ones
  !---------------------------------------------------------------------
  character(len=*), intent(inout) :: line        ! Command line
  logical, intent(in) :: global                  ! Global status of variable
  logical, intent(out) :: error                  ! Error flag
  ! Global
  include 'gbl_memory.inc'
  ! Local
  integer, parameter :: o_glob=1  ! /GLOBAL
  integer, parameter :: o_like=2  ! /LIKE
  integer, parameter :: o_trim=3  ! /TRIM
  character(len=*), parameter :: rname='FITS'
  integer :: nf,ns,fmt
  character(len=8) :: dummy
  character(len=256) :: name
  character(len=256), target :: chain
  character(len=16) :: headofstruct
  integer(kind=address_length) :: ibuf,jbuf
  logical :: extend,rgroups,xtension,define
  integer :: i,naxis,intg,pcount,gcount,nbits,rndmgrpsz
  integer(kind=size_length) :: mainsiz,skipsz,nsize
  logical :: eof,transpo,ldata
  integer :: iext,mext
  integer :: ndim, therank, maxis
  integer(kind=index_length) :: dim(sic_maxdims)
  integer(kind=4), save :: naxes(sic_maxdims)
  type(sic_descriptor_t) :: desc
  integer(kind=address_length) :: ip
  integer :: n
  logical :: found
  character(len=message_length) :: mess
  integer(kind=size_length), parameter :: lcard=80
  !
  integer, parameter :: nkey=3
  integer :: ikey
  character(len=12) :: key, keys(nkey)
  data keys/'BRIEF','HEADER','TRANSPOSE'/
  !
  mext = 0                     ! All extensions by default
  transpo=.false.
  error=.false.
  ldata = .true.               ! Have data and header
  !
  do i=4,6
    if (sic_present(0,i)) then
      call sic_ke (line,0,i,name,nf,.true.,error)
      if (error) return
      call sic_ambigs_sub(rname,name,key,ikey,keys,nkey,error)
      select case(key)
      case ('TRANSPOSE')
        transpo=.true.
      case ('BRIEF')
        call sic_message(seve%w,rname,'BRIEF keyword is obsolete')
      case ('HEADER')
        ldata = .false.
      case default
        call sic_i4(line,0,i,mext,.true.,error)
        if (error) return
      end select
    endif
  enddo
  !
  ! Do not read data if a specific extension is desired
  if (mext.ne.0) ldata = .false.
  !
  ! Trim all or specified dimensions
  if (sic_present(o_trim,0)) then
    therank = -10  ! Trim all dimensions
    call sic_i4(line,o_trim,1,therank,.false.,error)
    if (error) return
  else
    therank = 0
  endif
  !
  ! Reset
  extend = .false.
  rgroups = .false.
  xtension = .false.
  mainsiz = 0
  rndmgrpsz= 0
  skipsz = 0
  pcount = 0
  gcount = 0
  nbits  = 0
  ! Retrieve HEAD of structure name
  call sic_ke (line,0,2,headofstruct,ns,.true.,error)
  if (error) then
    call sic_message(seve%e,rname,'Missing structure name')
    return
  endif
  ! Retrieve FITS file name
  call sic_ch (line,0,3,chain,nf,.true.,error)
  if (error) return
  call sic_parse_file (chain(1:nf),' ','.fits',name)
  !
  jbuf = locstr(chain)
  ibuf = bytpnt(jbuf,membyt)
  !
  ! Open
  call gfits_open(name,'IN',error)
  if (error) then
    call sic_message(seve%e,rname,'Error opening file '//name)
    return
  endif
  ! SIMPLE
  call gfits_getbuf(membyt(ibuf),lcard,error)
  if (error) goto 99
  if (chain(1:8).ne.'SIMPLE') then
    call sic_message(seve%e,rname,'SIMPLE keyword not found')
    error=.true.
    goto 99
  elseif (chain(29:30).eq.' F') then
    call sic_message(seve%w,rname,'Not a SIMPLE FITS file, trying...')
  elseif (chain(29:30).ne.' T') then
    call sic_message(seve%e,rname,'Not a standard FITS file')
    error=.true.
    goto 99
  elseif (chain(9:10).ne.'= ') then
    call sic_message(seve%w,rname,'Not a standard FITS file')
    call sic_message(seve%w,rname,'"=" should occur in column 9, and '//  &
    'column 10 should be blank')
    call sic_message(seve%w,rname,'Proceeding with fingers crossed...')
  endif
  ! BITPIX
  call gfits_getbuf(membyt(ibuf),lcard,error)
  if (error) goto 99
  if (chain(1:8).ne.'BITPIX') then
    call sic_message(seve%e,rname,'Second keyword not BITPIX '//chain(1:8))
    error = .true.
    goto 99
  endif
  read(chain(11:30),'(I20)') intg
  if (intg.eq.8) then
    fmt = fmt_by
  elseif  (intg.eq.16) then
    fmt = eei_i2
  elseif  (intg.eq.32) then
    fmt = eei_i4
  elseif  (intg.eq.-32) then
    fmt = eei_r4
  elseif  (intg.eq.-64) then
    fmt = eei_r8
  else
    write(mess,*) 'Unsupported word size: ',intg
    call sic_message(seve%e,rname,mess)
    error=.true.
    goto 99
  endif
  nbits = intg
  ! NAXIS
  call gfits_getbuf(membyt(ibuf),lcard,error)
  if (error) goto 99
  if (chain(1:8).ne.'NAXIS') then
    call sic_message(seve%e,rname,'NAXIS keyword not found')
    error=.true.
    goto 99
  endif
  read(chain(11:30),'(I20)') naxis
  !
  ! Define SIC Structure
  call sic_crestructure(headofstruct(1:ns),global,error)
  if (error) goto 99
  !
  dim = 0
  naxes = 0
  if (naxis.eq.0) then
    rgroups = .false.  ! Just no main data, not a Random Group
    mainsiz = 0
  else
    if (naxis.gt.sic_maxdims) then
      call sic_message(seve%w,rname,'More than SIC_MAXDIMS dimensions in FITS file')
      maxis = sic_maxdims
    else
      maxis = naxis
    endif
    ! NAXIS1
    call gfits_getbuf(membyt(ibuf),lcard,error)
    if (error) goto 99
    if (chain(1:8).ne.'NAXIS1') then
      call sic_message(seve%e,rname,'NAXIS1 keyword not found')
      error=.true.
      goto 99
    endif
    read(chain(11:30),'(I20)') intg
    if (intg.ne.0) then
      mainsiz= intg
      dim(1) = intg
    else                       ! random group is present
      rgroups = .true.
      rndmgrpsz = 1
      naxes(1) = intg
    endif
  endif
  ! NAXIS2-N
  do i=2,naxis
    call gfits_getbuf(membyt(ibuf),lcard,error)
    if (error) goto 99
    dummy = 'NAXIS'//char(48+i)
    if (chain(1:8).ne.dummy(1:8)) then
      call sic_message(seve%e,rname,dummy//' keyword not found')
      error=.true.
      goto 99
    endif
    read(chain(11:30),'(I20)') intg
    if (rgroups) then
      rndmgrpsz = rndmgrpsz*intg
      if (i.le.sic_maxdims) naxes(i) = intg
    else
      mainsiz = mainsiz*intg
      if (i.le.sic_maxdims) dim(i) = intg
    endif
  enddo
  ndim = min(naxis,sic_maxdims)
  if (.not.rgroups) naxes = dim
  !
  ! Define the NAXIS variable (required for any test in Scripts)
  if (maxis.gt.0) then
    write(name,'(A,A,I0,A)') headofstruct(1:ns),'%NAXIS[',maxis,']'
    n = len_trim(name)
    call sic_defvariable(fmt_i4,name(1:n),global,error)
    if (error) return  
    n = index(name,'[')-1                     ! Must Skip the dimension
    call sic_descriptor(name(1:n),desc,found)
    ip = gag_pointer(desc%addr,memory)
    call r4tor4(naxes,memory(ip),maxis)
  endif
  !
  ! EXTEND Keyword should be here
  ! However, many FITS writer (IRAF at ST-ECF for example) are not
  ! very conformant, and insert other keywords before it
  ! It actually does not harm to set the EXTEND value whenever
  ! the keyword is found...
  extend = .false.
  !
  ! Rest of 1st header
  if (rgroups) then
    do while (pcount.eq.0 .or. gcount.eq.0)
      call gfits_getbuf(membyt(ibuf),lcard,error)
      if (error) goto 99
      ! check if random groups ala NRAO VLA.
      ! if GROUPS=T, then we MUST have read NAXIS1=0 to compute size...
      if (chain(1:8).eq.'EXTEND') then
        if (chain(30:30).eq.'T') extend = .true.
      elseif  (chain(1:8).eq.'GROUPS') then
        if (chain(30:30).ne.'T') goto 98
      elseif  (chain(1:8).eq.'PCOUNT') then
        read(chain(11:30),'(I20)') intg
        pcount=intg
      elseif  (chain(1:8).eq.'GCOUNT') then
        read(chain(11:30),'(I20)') intg
        gcount=intg
      endif
    enddo
    skipsz = gcount   ! Force I*8 operation for next statement
    skipsz = skipsz*(pcount+rndmgrpsz)
  else
    skipsz = mainsiz
  endif
  !
  ! convert in bytes now
  nsize = skipsz                !! In words
  skipsz = skipsz*abs(nbits)/8  !! In Bytes
  !
  if (rgroups) then
    ! Read RANDOM group data here...
    ndim = 0
    call fits_read_rndm(headofstruct,ns,global,fmt,nsize,ndim,dim,error,  &
    extend,gcount,pcount,rndmgrpsz,ldata,skipsz)
    if (error) goto 99
  else
    ! This should be the place where we READ the Main body of data.
    ! Define DIM, NDIM, etc...
    call fits_read_basic(headofstruct,ns,global,fmt,nsize,ndim,dim,error,  &
    extend,therank,ldata,skipsz)
    if (error) goto 99
  endif
  !
  ! here we can repeatedly explore the extensions
  ! This should be the place where we READ the various extensions.
  if (extend) then
    error = .false.
    eof = .false.
    iext = 0
    define = .true.
    do while (.not.(error.or.eof))
      iext = iext+1
      if (mext.ne.0) define = iext.eq.mext
      call fits_read_extension(headofstruct,ns,global,error,eof,iext,define,  &
      transpo)
      if (iext.eq.mext) eof = .true.
    enddo
    if (.not.eof) then
      call sic_message(seve%e,rname,'Specified extension not found')
      call sic_delvariable(headofstruct,.false.,error)
      error = .true.
    endif
  else if (mext.ne.0) then
    call sic_message(seve%e,rname,'No FITS Extensions')
    call sic_delvariable(headofstruct,.false.,error)
    error = .true.
  else
    call sic_message(seve%i,rname,'No FITS Extensions')
    error = .false.
  endif
  !
99 continue
  call gfits_close(error)
  return
  !
98 call sic_message(seve%e,rname,'Inconsistent Random Group Information')
  call gfits_close(error)
  error = .true.
  return
end subroutine sic_fits
!
subroutine fits_read_extension(headofstruct,ns,global,error,eof,iext,define,  &
  transpo)
  use gildas_def
  use sic_dependencies_interfaces
  use sic_interfaces, except_this=>fits_read_extension
  use sic_bintable
  use gbl_message
  use gbl_format
  !---------------------------------------------------------------------
  ! @ private
  ! SIC\DEFINE FITS
  !     Support routine for reading extensions
  !   DEFINE FITS  /EXTENSION extension_id
  !---------------------------------------------------------------------
  character(len=*), intent(in) :: headofstruct  !  Structure name
  integer, intent(in) :: ns                     !
  logical, intent(in) :: global                 !  Global status
  logical, intent(out) :: error                 !  Error flag
  logical, intent(out) :: eof                   !  End of File indicator
  integer, intent(in) :: iext                   !  Extension number
  logical, intent(in) :: define                 !  Define or skip variables ?
  logical, intent(in) :: transpo                !  Transpose array ?
  !
  ! Local
  character(len=*), parameter :: rname='FITS'
  logical :: table,bintable,image,avoid
  character(len=8) :: comm,fits_kind
  character(len=70) :: chain,extname
  logical :: check,ok
  integer :: i,j,jj,i1,i2,k
  integer(kind=size_length) :: skipsz,naxis1
  integer(kind=8) :: intg
  integer :: nbits,pcount,nrows,nss
  character(len=80) :: name,string
  character(len=160) :: struct
  integer :: count,mxcount,ier
  character(len=1) :: quote,openbrace,closebrace,comma
  character(len=message_length) :: mess
  ! Data
  data quote/''''/
  data openbrace/'('/
  data closebrace/')'/
  data comma/','/
  !
  pcount = 0 ! Was uninitialized until 27-Jul-2017
  count = 0
  mxcount = 1000
  !
  skipsz= 0
  transposevar=transpo          !pass argument to common
  check = .false.              ! for READ
  !      CHECK = .TRUE.                    ! for READ
  table = .false.
  bintable = .false.
  avoid = .false.
  image = .false.
  error = .false.
  eof = .false.
  !
  ! XTENSION. May be EOF since there is nothing in FITS telling
  ! where the extension stops.
  !
  ! The code if voluntarily generous vis-a-vis FITS conforming standard
  ! FITS rule indicate 'XTENSION' should be the first keyword, but
  ! some lazy writers (specially HST) don't respect that...
  !
  comm = ' '
  k = 0
  do while (comm.ne.'XTENSION')
    call gfits_get(comm,chain,check,error,quiet=.true.,eof=eof)
    if (eof) return
    if (error) return
    k = k+1
  enddo
  !
  if (comm.ne.'XTENSION') then
    error =.true.
    call sic_message(seve%e,rname,'Misplaced Keyword: '//comm)
    call sic_message(seve%e,rname,chain)
    goto 100
  else
    if (chain(2:9).eq.'TABLE   ') then
      table=.true.
      fits_kind='TABLE   '
      call sic_message(seve%i,rname,'Reading an ASCII table')
    elseif (chain(2:9).eq.'BINTABLE') then
      bintable=.true.
      fits_kind='BINTABLE'
      call sic_message(seve%i,rname,'Reading a BINARY table')
    elseif (chain(2:9).eq.'A3DTABLE') then
      call sic_message(seve%w,rname,'Obsolete XTENSION type: '//chain(2:9))
      bintable=.true.
      fits_kind='A3DTABLE'
    elseif (chain(2:9).eq.'IMAGE') then
      image=.true.
      fits_kind='IMAGE'
      call sic_message(seve%i,rname,'Reading an IMAGE table')
    else
      call sic_message(seve%i,rname,'Skipping Invalid XTENSION type: '//  &
      chain(2:9))
      avoid =.true.
    endif
  endif
  !
  ! Treat IMAGE case in another subroutine
  if (image) then
    call fits_read_image(headofstruct,ns,global,error,eof,iext,define)
    return
  endif
  !
  !Common XTENSION decoding...
  call gfits_get(comm,chain,check,error)
  if (error) return
  if (comm.ne.'BITPIX') then
    goto 100
  else
    read(chain,'(I20)') intg
    if (intg.ne.8) then
      write(mess,*) 'Wrong ',fits_kind,' table BITPIX:',intg
      call sic_message(seve%e,rname,mess)
      return
    endif
    nbits = 8
  endif
  !
  !NAXIS
  call gfits_get(comm,chain,check,error)
  if (error) return
  if (comm.ne.'NAXIS   ') then
    goto 100
  else
    read(chain,'(I20)') intg
    if (intg.ne.2) then
      write(mess,*) 'Wrong ',fits_kind,' table NAXIS:',intg
      call sic_message(seve%e,rname,mess)
      return
    endif
  endif
  !
  !NAXIS1
  call gfits_get(comm,chain,check,error)
  if (error) return
  if (comm.ne.'NAXIS1  ') then
    goto 100
  else
    read(chain,'(I20)') naxis1
  endif
  !NAXIS2 = NROW
  call gfits_get(comm,chain,check,error)
  if (error) return
  if (comm.ne.'NAXIS2  ') then
    goto 100
  else
    read(chain,'(I20)',iostat=ier) nrows
    if (ier.ne.0) print *,'IER ',ier,comm,chain
  endif
  ! PCOUNT
  call gfits_get(comm,chain,check,error)
  if (error) return
  if (comm.eq.'PCOUNT  ') then
    read(chain,'(I20)',iostat=ier) pcount
    if (ier.ne.0) print *,'IER ',ier,comm,chain
    skipsz=pcount
  endif
  !
  ! If it should be ignored, ignore it...
  if (.not.define.or.avoid) then
    ! Presumably this is in Bytes to accomodate any type of data
    skipsz=naxis1*nrows+pcount   
    comm = ' '
    do while(comm.ne.'END     ')
      call gfits_get(comm,chain,check,error)
    enddo
    call gfits_flush_header(error)
    if (error) return
    !!Print *,'SKIBUF #1 ',skipsz
    call gfits_skibuf(skipsz,error)
    if (error) return
    call gfits_flush_data(error)
    return
  endif
  !
  ! GCOUNT
  call gfits_get(comm,chain,check,error)
  if (error) return
  if (comm.ne.'GCOUNT  ') then
    call sic_message(seve%w,rname,'XTENSION Header does not follow norm')
  endif
  ! TFIELDS
  call gfits_get(comm,chain,check,error)
  if (error) return
  if (comm.eq.'TFIELDS ') then
    read(chain,'(I20)') ncols
    if (ncols.gt.mcols) then
      write (mess,*) 'XTENSION has more than ',mcols,' columns, skipping it...'
      call sic_message(seve%w,rname,mess)
      skipsz=naxis1*nrows+pcount
      comm = ' '
      do while(comm.ne.'END     ')
        call gfits_get(comm,chain,check,error)
      enddo
      call gfits_flush_header(error)
      if (error) return
      !!Print *,'SKIBUF #2 ',skipsz
      call gfits_skibuf(skipsz,error)
      if (error) return
      call gfits_flush_data(error)
      return
    endif
  endif
  ! RAZ information
  do i=1,ncols
    usescal(i)=.false.
    colscal(i)=1.0
    colzero(i)=0.0
    colfmt(i)=0
    ! colnull(i)=0  ! COLNULL is still in limbo for reasons stated below.
    collabl(i)=''
    colunit(i)='UNKNOWN'
    colform(i)=''
    coldim(:,i)=0
    colndim(i)=0
  enddo
  coladdr(ncols+1)=naxis1+1    !because subtract-1 if ascii table
  !
  ! LOOP on CHAINMENTS
  ok = .true.
  extname=fits_kind            ! As default name
  nss = 0
  do while (ok)
    call gfits_get(comm,chain,check,error)
    if (error)  return
    !!Print *,'Comm '//comm//trim(chain)
    if (comm.eq.'EXTNAME ') then
      i1 = index(chain,quote)+1
      i2 = index(chain(i1:),quote)-2+i1
      extname = chain(i1:i2)
      call sic_underscore(extname)
      call sic_upper(extname)
      !
      ! Define the Head of Structure
      struct = headofstruct(1:ns)//'%'//extname    !SG
      !!Print *,'Defining head of Structure '
      call fits_defstructure(struct,global,error)
      if (error) return
      nss = len_trim(struct)       !note struct is returned with the last %
      ! We Should defer the real definition of structure in case an EXTVER keyword
      ! is present. this would mean saving temporarily all the kewords/value pairs
      !         ELSEIF (COMM.EQ.'EXTVER  ') THEN
      !            READ(CHAIN,'(I20)',IOSTAT=IER) INTG
      !            IF(INTG.GT.1) THEN  !version 1 of the struct will not bear
      !                                !(yet)? a version number, for compatibility
      !               STRUCT = HEADOFSTRUCT(1:NS)//'%'//EXTNAME//
      !     &         '.'//CHAIN !spaces will be destroyed in FITS_DEFSTRUCTURE
      !            ENDIF
    elseif (comm(1:5).eq.'TBCOL') then
      read(comm(6:8),'(BN,I3.1)') i
      if (i.le.ncols) then
        read(chain,'(I20)') coladdr(i)
      endif
    elseif (comm(1:4).eq.'TDIM') then
      read(comm(5:8),'(BN,I4.1)') i
      if (i.le.ncols) then
        i1 = index(chain,openbrace)+1
        i2 = index(chain,closebrace)-1
        if (i2.gt.i1) then     !do NOT use COMM it is NOT safe!!!
          string = chain(i1:i2)
          i1=index(string,comma)
          j=1
          do while (i1.gt.0)
            chain=string(1:i1-1)
            read (chain,'(BN,I8.1)') coldim(j,i)
            j=j+1
            string=string(i1+1:)
            i1=index(string,comma)
            if (j.gt.4) exit
          enddo
          if (j.le.4) then
            read (string,'(BN,I8.1)') coldim(j,i)
            colndim(i)=j
          else
            call sic_message(seve%w,rname,'Array has more dimension than '//  &
            'supported, option ignored')
            do jj=1,4
              coldim(jj,i)=0
            enddo
          endif
        endif
      endif
    elseif (comm(1:5).eq.'TFORM') then
      read(comm(6:8),'(BN,I3.1)') i
      if (i.le.ncols) then
        i1 = index(chain,quote)+1
        i2 = index(chain(i1:),quote)-2+i1
        colform(i) = chain(i1:i2)
      endif
    elseif (comm(1:5).eq.'TTYPE') then
      read(comm(6:8),'(BN,I3.1)') i
      if (i.le.ncols) then
        i1 = index(chain,quote)+1
        i2 = index(chain(i1:),quote)-2+i1
        collabl(i) = chain(i1:i2)
        call sic_underscore(collabl(i))
        call sic_upper(collabl(i))
      endif
    elseif (comm(1:5).eq.'TUNIT') then
      read(comm(6:8),'(BN,I3.1)') i
      if (i.le.ncols) then
        i1 = index(chain,quote)+1
        i2 = index(chain(i1:),quote)-2+i1
        colunit(i) = chain(i1:i2)
        call sic_upper(colunit(i))
      endif
    elseif (comm(1:5).eq.'TSCAL') then
      read(comm(6:8),'(BN,I3.1)') i
      if (i.le.ncols) then
        usescal(i)=.true.
        read(chain,'(F20.0)') colscal(i)
      endif
    elseif (comm(1:5).eq.'TZERO') then
      read(comm(6:8),'(BN,I3.1)') i
      if (i.le.ncols) then
        usescal(i)=.true.
        read(chain,'(F20.0)') colzero(i)
      endif
      ! TNULLnnn is a Character Array for ASCII Tables. It is also an INTEGER
      ! Value for Integer entries in a BINARY table (since NaNs are THE "blanked"
      ! values for floating-point entries). I do not see how to handle that in a
      ! general way. I choose to IGNORE NULL VALUES, and check the rare
      ! formatted-read error whenever appropriate. People will have to handle
      ! the rare integer blanked values by themselves at the interpreter's math
      ! level. Signed: Gilles.
      !         ELSEIF (COMM(1:5).EQ.'TNULL') THEN
      !            READ(COMM(6:8),'(BN,I3.1)') I
      !            IF (I.LE.NCOLS) THEN
      !               I1 = INDEX(CHAIN,quote)+1
      !               I2 = INDEX(CHAIN(I1:),quote)-2+I1
      !               READ(CHAIN(I1:I2),'(F20.0)',IOSTAT=I1) COLNULL(I)
      !            ENDIF
    elseif (comm.eq.'END') then
      ok = .false.
    elseif (comm.eq.'        ') then
      continue
    elseif (comm.eq.'HISTORY') then
      continue
    elseif (comm.eq.'COMMENT') then
      continue
    elseif (nss.gt.0 .and. comm.eq.'HIERARCH') then
      call do_hierarch(struct,nss-1,chain,global)
      !
      ! Define all other FITS keywords
    elseif  (nss.gt.0 .and. count.lt.mxcount) then   !SG
      call sic_underscore(comm)
      name = struct(1:nss)//comm
      call fits_sicvariable(name,chain,global)
      count = count+1
    endif
  enddo
  call gfits_flush_header(error)
  if (error) return
  ! Decode recently read parameters:
  if (table) then
    !!!    Print *,'FITS_DECODE_PAR '
    call fits_decode_par(error)
  else
    !!    Print *,'Calling fits_decode_binpar'
    call fits_decode_binpar(error)
  endif
  if (error) then
    call sic_message(seve%e,rname,'Error decoding binary table parameters')
    return
  endif
  !!Print *,'Done '
  !
  ! Decoding was OK, define head of structure if not yet done
  if (nss.eq.0) then
    !!Print *,'FITS_DEFSTRUCTURE '
    struct = headofstruct(1:ns)//'%'//extname
    call fits_defstructure(struct,global,error)
    if (error) return
  endif
  ! Define Corresponding sic variables
  !!Print *,'FITS_DEFVARIABLE '
  call fits_defvariable(struct,nrows,global,error)
  if (error) then
    call sic_message(seve%e,rname,'Error defining SIC variable(s)')
    ! Skip all the data block
    skipsz=naxis1*nrows+pcount
    !!Print *,'SKIBUF #3 ',skipsz
    call gfits_skibuf(skipsz,error)
    call gfits_flush_data(error)
    return
  endif
  !
  ! SKIP extension data
  if (skipsz.gt.0) then
    !!Print *,'SKIBUF #4 ',skipsz
    call gfits_skibuf(skipsz,error)
    if (error) return
  endif
  ! Decode and fill the (now defined) variables
  !!Print *,'FITS_READVARIABLE '
  call fits_readvariable(error,naxis1,nrows,bintable)
  !
  if (error) then
    ! we should destroy the variables...
    call sic_message(seve%e,rname,'Error in readvariable')
  endif
  ! Flush last buffer,return
  call gfits_flush_data(error)
  return                       ! with ERROR or not...
100 call sic_message(seve%e,rname,'Error reading extension...')
  call gfits_flush_data(error)
  error = .true.
  return
end subroutine fits_read_extension
!
subroutine fits_read_image(head,ns,global,error,eof,iext,define)
  use sic_dependencies_interfaces
  use sic_interfaces, except_this=>fits_read_image
  use sic_bintable
  use gbl_message
  use gbl_format
  !---------------------------------------------------------------------
  ! @ private
  ! SIC\DEFINE FITS
  !     Support routine for XTENSION of type IMAGE
  !---------------------------------------------------------------------
  character(len=*), intent(in) :: head          !  Structure name
  integer, intent(in) :: ns                     !  Length of name
  logical, intent(in) :: global                 !  Global status
  logical, intent(out) :: error                 !  Error flag
  logical, intent(out) :: eof                   !  End of File indicator
  integer, intent(in) :: iext                   !  Extension number
  logical, intent(in) :: define                 !  Define or skip variables ?
  ! Global
  include 'gbl_memory.inc'
  ! Local
  character(len=*), parameter :: rname='FITS'
  character(len=8) :: comm,strname
  character(len=70) :: chain
  character(len=64) :: subhead
  character(len=1) :: quote
  logical :: check
  integer :: i,ii,n,nss
  integer :: intg,nbits,pcount,gcount,ndim
  integer(kind=index_length) :: dim(sic_maxdims)
  integer :: fmt
  integer(kind=size_length) :: mainsiz, nsize
  logical :: data,extend,supported
  character(len=message_length) :: mess
  ! Data
  data quote/''''/
  !
  data   = .true.              ! Should be in Call Sequence
  !
  ! Treat IMAGE case in another subroutine
  check = .false.              ! for READ
  error = .false.
  eof = .false.
  write(strname,'(A,I4)') 'IMAG',iext
  n = 8
  call sic_black(strname,n)
  !
  call gfits_get(comm,chain,check,error)
  if (error) return
  if (comm.ne.'BITPIX') then
    goto 100
  else
    read(chain,'(I20)') intg
    if (intg.eq.8) then
      fmt = fmt_by
    elseif  (intg.eq.16) then
      fmt = eei_i2
    elseif  (intg.eq.32) then
      fmt = eei_i4
    elseif  (intg.eq.-32) then
      fmt = eei_r4
    elseif  (intg.eq.-64) then
      fmt = eei_r8
    else
      write(mess,*) 'Unsupported word size: ',intg
      call sic_message(seve%e,rname,mess)
      goto 100
    endif
    nbits = intg
  endif
  !
  !NAXIS
  supported=.true.
  mainsiz = 1
  call gfits_get(comm,chain,check,error)
  if (error) return
  if (comm.ne.'NAXIS   ') then
    goto 100
  else
    read(chain,'(I20)') intg
    ndim = intg
    if (intg.eq.0) then
      call sic_message(seve%w,rname,'No image data')
      mainsiz = 0
      supported=.false.
    elseif  (intg.lt.2.or.intg.gt.4) then
      write(mess,*) 'Skipping Wrong or Unsupported IMAGE NAXIS:',intg
      call sic_message(seve%e,rname,mess)
      supported=.false.
    endif
  endif
  !
  do i=1,ndim
    call gfits_get(comm,chain,check,error)
    if (error) return
    if (comm(1:5).ne.'NAXIS') then
      goto 100
    else
      read(comm(6:6),'(I1.1)') ii
      read(chain,'(I20)') intg
      mainsiz = mainsiz*intg
      if (ii.le.sic_maxdims) then
        dim(ii)=intg
      else
        supported=.false.
      endif
    endif
  enddo
  ! PCOUNT
  call gfits_get(comm,chain,check,error)
  if (error) return
  if (comm.eq.'PCOUNT  ') then
    read(chain,'(I20)') pcount
    if (pcount.ne.0) then
      call sic_message(seve%w,rname,'IMAGE with non 0 PCOUNT')
      goto 100
    endif
  endif
  ! GCOUNT
  call gfits_get(comm,chain,check,error)
  if (error) return
  if (comm.ne.'GCOUNT  ') then
    call sic_message(seve%w,rname,'XTENSION Header does not follow norm')
  else
    read(chain,'(I20)') gcount
    if (gcount.ne.1) then
      call sic_message(seve%w,rname,'IMAGE with non 1 GCOUNT')
      goto 100
    endif
  endif
  !
  ! Define structure of name extname
  nsize = mainsiz                     ! Size in Real*4 words
  mainsiz = mainsiz*abs(nbits/8)      ! Size in Bytes in FITS file
  !
  if (define.and.supported) then
    subhead = head(1:ns)//'%'//strname
    nss = len_trim(subhead)
    call sic_message(seve%i,rname,'Defining Structure ... '//subhead(1:nss))
    call sic_crestructure(subhead,global,error)
    !
    ! re-use the "normal" header routine
    data  = .true.             ! Read the data ?
    call fits_read_basic(subhead,nss,global,fmt,nsize,ndim,dim,error,extend,  &
    0,data,mainsiz)
  else
    !
    ! Just skip
    call sic_message(seve%w,rname,'Skipping extension')
    comm = ' '
    do while(comm.ne.'END     ')
      call gfits_get(comm,chain,check,error)
    enddo
    call gfits_flush_header(error)
    if (error) return
    !!Print *,'SKIBUF #5 ',mainsiz 
    ! Size is definitely in Bytes here
    call gfits_skibuf(mainsiz,error)
    if (error) return
    call gfits_flush_data(error)
  endif
  return                       ! with ERROR or not...
  !
100 call sic_message(seve%e,rname,'Error reading extension...')
  call gfits_flush_data(error)
  error = .true.
  return
end subroutine fits_read_image
!
subroutine fits_readvariable(error,bufsize,nrows,btabl)
  use sic_interfaces
  use gildas_def
  use sic_dependencies_interfaces
  use sic_bintable
  use gbl_message
  use gbl_format
  !---------------------------------------------------------------------
  ! @ no-interface (because of argument type mismatch)
  ! SIC\DEFINE FITS command
  !   Repeatedly fills all the defined variables by reading the
  !   Table's lines and decoding the Arguments.
  !   Multiply by  Scaling and Zero, Check Blanked values
  !---------------------------------------------------------------------
  logical,                   intent(out) :: error    ! Error flag
  integer(kind=size_length), intent(in)  :: bufsize  ! Number of bytes
  integer,                   intent(in)  :: nrows    ! Number of rows
  logical,                   intent(in)  :: btabl    ! Binary table indicator
  ! Global
  include 'gbl_memory.inc'
  ! Local
  integer :: i,j
  !
  ! Automatic array
  integer(kind=1) :: buf(bufsize)
  !
  character(len=1024) :: cbuf
  integer(kind=address_length) :: ic,tmpaddr(mcols)  ! Address of variable got by SIC_GETVM
  integer :: istart,iend
  real :: notanum
  !
  error = .false.
  call gag_notanum(notanum)
  !
  ! Convert VMADDR (absolute addresses) to offset in array MEMBYT
  ! (solves alignment problems)
  do j=1,ncols
    tmpaddr(j)=bytpnt(vmaddr(j),membyt)
  enddo
  !
  ! LOOP on rows
  do i=1,nrows
    call gfits_getbuf(buf,bufsize,error)
    if (error) then
      call sic_message(seve%e,'READ','Error Reading FITS file')
      return
    endif
    do j=1,ncols
      if (btabl) then
        !! if (i.eq.1) !!Print *,i,'tmp J ',j,' addr ',tmpaddr(j),' Nitem ',nitem(j),' Format ',varformat(j) &
        !!  ,'Column ',coladdr(j),' Format ',colfmt(j)
        call get_btable_item (membyt(tmpaddr(j)),nitem(j),varformat(j),  &
        &   buf(coladdr(j)),colfmt(j),error,i)
        if (error) then
          write (*,'(A)') '         for variable '//collabl(j)
          error = .false.
        endif
      else
        istart = coladdr(j)
        iend = coladdr(j+1)-1
        ic = bytpnt(locstr(cbuf),membyt)
        call bytoby(buf,membyt(ic),iend)
        call get_table_item(membyt(tmpaddr(j)),varformat(j),cbuf, &
        istart,iend,colform(j),notanum,error)
      endif
      if (error) goto 99
      ! increment offset in array:
      if (varformat(j).gt.0) then
        tmpaddr(j)=tmpaddr(j)+varformat(j)*nitem(j)
      elseif (varformat(j).eq.fmt_r8 .or.  &
              varformat(j).eq.fmt_c4 .or.  &
              varformat(j).eq.fmt_i8) then
        tmpaddr(j)=tmpaddr(j)+8*nitem(j)
      elseif (varformat(j).eq.fmt_c8) then
        tmpaddr(j)=tmpaddr(j)+8*nitem(j)
      else
        ! Rest is converted in reals or integers...
        tmpaddr(j)=tmpaddr(j)+4*nitem(j)
      endif
    enddo
  enddo
  ! Offset, Blanking and Scaling If needed:
  do j=1,ncols
    if (usescal(j)) then
      tmpaddr(j)= gag_pointer(vmaddr(j),memory)
      if (varformat(j).eq.fmt_r8) then
        call scale_table8(memory(tmpaddr(j)),nrows*nitem(j),colscal(j),  &
        colzero(j))
      elseif (varformat(j).eq.fmt_r4) then
        call scale_table4(memory(tmpaddr(j)),nrows*nitem(j),colscal(j),  &
        colzero(j))
      endif
    endif
  enddo
  ! Transpose multi-dimensional arrays (because usually we prefer to have
  ! nrows as 1st dimension for them)
  if (transposevar) then
    do j=1,ncols
      if (nitem(j).gt.1) then
        tmpaddr(j)= gag_pointer(vmaddr(j),memory)
        if (varformat(j).eq.fmt_r8 .or. varformat(j).eq.fmt_c4) then
          call transpose_table8(memory(tmpaddr(j)),nitem(j),nrows)
        elseif (varformat(j).eq.fmt_c8) then
          call transpose_tablec8(memory(tmpaddr(j)),nitem(j),nrows)
        elseif (varformat(j).eq.fmt_r4 .or. varformat(j).eq.fmt_i4.or.  &
                varformat(j).eq.fmt_l) then
          call transpose_table4(memory(tmpaddr(j)),nitem(j),nrows)
        endif
      endif
    enddo
  endif
  return
  !
99 error=.true.
  return
end subroutine fits_readvariable
!
subroutine get_btable_item(item,nitem,fmtout,buffer,fmtin,error,jrow)
  use sic_interfaces, except_this=>get_btable_item
  use gbl_message
  use gbl_format
  use sic_dependencies_interfaces
  !---------------------------------------------------------------------
  ! @ private
  ! SIC\DEFINE FITS command
  ! Transfers (and translate) a data vector from BINTABLE row.
  !---------------------------------------------------------------------
  integer(kind=1), intent(out)   :: item(*)    ! Requested information
  integer(kind=4), intent(in)    :: nitem      ! Number of requested items
  integer(kind=4), intent(in)    :: fmtout     ! Format for requested items
  integer(kind=1), intent(in)    :: buffer(*)  ! Row buffer
  integer(kind=4), intent(in)    :: fmtin      ! Format of data in buffer
  logical,         intent(inout) :: error      ! Error flag
  integer(kind=4), intent(in)    :: jrow       ! Row number
  !
  integer, external :: gdf_conv
  ! Local
  character(len=*), parameter :: rname='READ'
  integer :: fmt
  integer :: i
  real(8) :: r8buf(2)              !extra space for Double Complex...
  integer(4) :: mybuf(4)           !
  equivalence (mybuf,r8buf)        ! To force alignment and memory location
  real(4) :: reel(2)               !extra real for Complex...
  real(8) :: double(2)
  integer(4) :: onebuf(4)
  equivalence (onebuf,reel)
  equivalence (onebuf,double)
  !
  integer :: status,n
  logical :: log
  integer(8) :: inbuf, oubuf
  integer(4) :: i4
  integer(2) :: i2
  character(len=80) :: chain
  equivalence (i2,mybuf)
  !
  ! First convert from IEEE format to corresponding local format. Force R8 TO I2
  ! alignment in the process to avoid later problems on HPs, SUNs and ALPHAs
  !
  ! All FMTIN must be checked against the EEI_j formats (our "normal" IEEE)
  if (fmtin.gt.0) then
    if (fmtout.gt.0) then
      n = nitem*fmtin
      if (error) return
      call bytoby(buffer,item,n)
    else
      call sic_message(seve%e,rname,'Invalid conversion CHAR')
      goto 99
    endif
  elseif (fmtin.eq.eei_i4) then
    if (fmtout.eq.eei_i4) then !direct no conversion
      call bytoby(buffer,item,4*nitem)
    else
      fmt = fmt_i4
      if (fmt.eq.iee_i4) then
        do i=1,nitem
          n=4*(i-1)+1
          call bytoby(buffer(n),mybuf,4)
          call eii4ie(mybuf,item(n),1)
        enddo
      elseif (fmt.eq.vax_i4) then
        do i=1,nitem
          n=4*(i-1)+1
          call bytoby(buffer(n),mybuf,4)
          call eii4va(mybuf,item(n),1)
        enddo
      else
        call sic_message(seve%e,rname,'Invalid conversion I4')
        goto 99
      endif
    endif
  elseif (fmtin.eq.fmt_by) then
    if (fmtout.eq.fmt_by) then
      call bytoby(buffer,item,nitem)
    elseif (fmtout.eq.fmt_i4) then
      do i=1,nitem
        i4=buffer(i)
        n=4*(i-1)+1
        call i4toi4(i4,item(n),1)
      enddo
    elseif (fmtout.eq.fmt_i2) then
      do i=1,nitem
        i2=buffer(i)
        n=2*(i-1)+1
        call bytoby(i2,item(n),2)
      enddo
    else
      call sic_message(seve%e,rname,'Invalid conversion BY')
      goto 99
    endif
  elseif (fmtin.eq.eei_i2) then
    if (fmtout.eq.eei_i2) then
      call bytoby(buffer,item,2*nitem)
    else                       !provide conversion to I4 also
      fmt=fmt_i2
      do i=1,nitem
        n=2*(i-1)+1
        if (fmt.eq.iee_i2) then
          call bytoby(buffer(n),mybuf,2)
          call eii2ie(mybuf,mybuf,1)
        elseif (fmt.eq.eei_i2) then
          call bytoby(buffer(n),mybuf,2)
        elseif (fmt.eq.vax_i2) then
          call bytoby(buffer(n),mybuf,2)
          call eii2va(mybuf,mybuf,1)
        else
          call sic_message(seve%e,rname,'Invalid conversion code')
          goto 99
        endif
        if (fmtout.eq.fmt_i2) then
          n=2*(i-1)+1
          call bytoby(mybuf,item(n),2)
        elseif (fmtout.eq.fmt_i4) then
          n=4*(i-1)+1
          call i2toi4(mybuf,item(n),1)
        elseif (fmtout.eq.fmt_r4) then
          n=4*(i-1)+1
          call i2tor4(mybuf,item(n),1)
        elseif (fmtout.eq.fmt_r8) then
          n=8*(i-1)+1
          call i2tor8(mybuf,item(n),1)
        else
          call sic_message(seve%e,rname,'Conversion not supported')
          goto 99
        endif
      enddo
    endif
  elseif (fmtin.eq.eei_i8) then
    if (fmtout.eq.eei_i8) then ! direct no conversion
      !!Print *,'I8 no conversion ',nitem
      call bytoby(buffer,item,8*nitem)
    else
      !!Print *,'I8 with conversion ',nitem
      fmt = fmt_i8
      if (fmt.eq.iee_i8) then
        do i=1,nitem
          n=8*(i-1)+1
          call bytoby(buffer(n),inbuf,8)
          call eii8ie(inbuf,oubuf,1)
          call bytoby(oubuf,item(n),8)
        enddo
      else
        call sic_message(seve%e,rname,'Invalid conversion I8')
        goto 99
      endif
    endif
  elseif (fmtin.eq.eei_l) then
    if (fmtout.eq.fmt_l) then
      do i=1,nitem
        if (buffer(i).eq.ichar('T')) then
          log = .true.
          n=4*(i-1)+1
          call l4tol4(log,item(n),1)
        elseif (buffer(i).eq.ichar('F') .or. buffer(i).eq.ichar('U')) then
          log = .false.
          n=4*(i-1)+1
          call l4tol4(log,item(n),1)
        else
          write(chain,1001) buffer(i)
          call sic_message(seve%e,rname,chain)
          goto 99
        endif
      enddo
    elseif (fmtout.eq.fmt_i4) then
      do i=1,nitem
        if (buffer(i).eq.ichar('T')) then
          i4 = 1
          n=4*(i-1)+1
          call i4toi4(i4,item(n),1)
        elseif (buffer(i).eq.ichar('F') .or. buffer(i).eq.ichar('U')) then
          i4 = 0
          n=4*(i-1)+1
          call i4toi4(i4,item(n),1)
        else
          chain = 'Invalid value for logical. Must be T or F or U.'
          call sic_message(seve%e,rname,chain)
          goto 99
        endif
      enddo
    elseif (fmtout.eq.fmt_i2) then
      do i=1,nitem
        if (buffer(i).eq.ichar('T')) then
          i2 = 1
          n=2*(i-1)+1
          call bytoby(i2,item(n),2)
        elseif (buffer(i).eq.ichar('F') .or. buffer(i).eq.ichar('U')) then
          i2 = 0
          n=2*(i-1)+1
          call bytoby(i2,item(n),2)
        else
          chain = 'Invalid value for logical. Must be T or F or U.'
          call sic_message(seve%e,rname,chain)
          goto 99
        endif
      enddo
    else
      call sic_message(seve%e,rname,'Invalid conversion of Logical')
      goto 99
    endif
  elseif (fmtin.eq.eei_r4) then
    if (fmtout.eq.eei_r4) then
      call bytoby(buffer,item,4*nitem)
    else
      fmt = fmt_r4
      do i=1,nitem
        n=4*(i-1)+1
        call bytoby(buffer(n),mybuf,4)
        status = gdf_conv(mybuf,onebuf,1,fmt_r4,eei_r4)
        if (status.ne.1) then
          call sic_message(seve%e,rname,'Invalid conversion in GDF_CONV,R4')
          goto 99
        endif
        if (fmtout.eq.fmt_i4) then
          n=4*(i-1)+1
          call r4toi4_fini(reel,item(n),1,error)
        elseif (fmtout.eq.fmt_r4) then
          n=4*(i-1)+1
          call r4tor4(reel,item(n),1)
        elseif (fmtout.eq.fmt_r8) then
          n=8*(i-1)+1
          call r4tor8(reel,item(n),1)
        else
          call sic_message(seve%e,rname,'Conversion not supported')
          error = .true.
        endif
        if (error)  goto 99
      enddo
    endif
  elseif (fmtin.eq.eei_r8) then
    if (fmtout.eq.eei_r8) then
      call bytoby(buffer,item,8*nitem)
    else
      fmt = fmt_r8
      do i=1,nitem
        n=8*(i-1)+1
        call bytoby(buffer(n),mybuf,8)
        status = gdf_conv(mybuf,onebuf,1*2,fmt_r8,eei_r8)
        if (status.ne.1) then
          call sic_message(seve%e,rname,'Invalid conversion in GDF_CONV,R8')
          goto 99
        endif
        if (fmtout.eq.fmt_i4) then
          n=4*(i-1)+1
          call r8toi4_fini(double,item(n),1,error)
        elseif (fmtout.eq.fmt_r4) then
          n=4*(i-1)+1
          call r8tor4(double,item(n),1)
        elseif (fmtout.eq.fmt_r8) then
          n=8*(i-1)+1
          call r8tor8(double,item(n),1)
        else
          call sic_message(seve%e,rname,'Conversion not supported')
          error = .true.
        endif
        if (error)  goto 99
      enddo
    endif
  elseif (fmtin.eq.eei_c4) then
    if (fmtout.eq.eei_c4) then
      call bytoby(buffer,item,8*nitem)
    else
      fmt = fmt_c4
      do i=1,nitem
        n=8*(i-1)+1
        call bytoby(buffer(n),mybuf,8)
        status = gdf_conv(mybuf,onebuf,2*1,fmt_r4,eei_r4)
        if (status.ne.1) then
          call sic_message(seve%e,rname,'Invalid conversion in GDF_CONV,C4')
          goto 99
        endif
        if (fmtout.eq.fmt_c4) then
          n=8*(i-1)+1
          call c4toc4(reel,item(n),1)
        elseif (fmtout.eq.fmt_c8) then
          n=16*(i-1)+1
          call r4tor8(reel,item(n),2)
        else
          call sic_message(seve%e,rname,'Conversion not supported')
          goto 99
        endif
      enddo
    endif
  elseif (fmtin.eq.eei_c8) then
    if (fmtout.eq.eei_c8) then
      call bytoby(buffer,item,16*nitem)
    else
      fmt = fmt_c8
      do i=1,nitem
        n=16*(i-1)+1
        call bytoby(buffer(n),mybuf,16)
        status = gdf_conv(mybuf,onebuf,2*2,fmt_r8,eei_r8)
        if (status.ne.1) then
          call sic_message(seve%e,rname,'Invalid conversion in GDF_CONV,C8')
          goto 99
        endif
        if (fmtout.eq.fmt_c8) then
          n=16*(i-1)+1
          call r8tor8(double,item(n),2)
        elseif (fmtout.eq.fmt_c4) then
          n=8*(i-1)+1
          call r8tor4(double,item(n),2)
        else
          call sic_message(seve%e,rname,'Conversion not supported')
          goto 99
        endif
      enddo
    endif
  elseif (fmtin.eq.0) then
    continue
  else
    if (jrow.eq.1) then
      write(chain,1000) fmtin,fmtout
      call sic_message(seve%w,rname,chain)
      goto 99
    endif
  endif
  error = .false.
  return
  !
99 error = .true.
  return
  !
1000 format('Unsupported format in BINARY table:',i6,i6)
1001 format('Invalid value for logical. (',i1.1,') Must be T, F, or U.')
end subroutine get_btable_item
!
subroutine get_table_item(item,fmtout,line,i,j,fmt,blank,error)
  use sic_dependencies_interfaces
  use sic_interfaces, except_this=>get_table_item
  use gildas_def
  use gbl_message
  use gbl_format
  !---------------------------------------------------------------------
  ! @ private
  ! SIC\DEFINE FITS command
  !   Transfers (and translate) a data vector from TABLE row.
  !---------------------------------------------------------------------
  integer(kind=1), intent(out) :: item(*)       ! Requested information
  integer, intent(in) :: fmtout                 ! Output Format
  character(len=*), intent(in) :: line          ! Row buffer
  integer, intent(in) :: i                      ! Start position
  integer, intent(in) :: j                      ! End position
  character(len=12), intent(in) :: fmt          ! Input format
  real, intent(in) :: blank                     ! Blanking value
  logical, intent(inout) :: error               ! Error flag
  ! Global
  include 'gbl_memory.inc'
  ! Local
  character(len=*), parameter :: rname='READ'
  ! (Not a) number for blanked (and unreadable) values.
  ! We use it as blanked value for undecipherable Reals, since FITS TABLE
  ! extension defines a blanked value as ascii text, which could be unreadable.
  real(8) :: dblnk
  integer :: ier
  character(len=80) :: chain
  real(4) :: r4
  integer(4) :: i4
  integer(2) :: i2
  real(8) :: r8
  logical :: log
  integer(kind=address_length) :: il
  !
  dblnk=blank
  !
  ier = 0
  if (fmtout.gt.0) then
    il = bytpnt(locstr(line),membyt)
    call bytoby(membyt(il+i-1),item,fmtout)
  elseif (fmtout.eq.fmt_by) then
    il = bytpnt(locstr(line),membyt)
    call bytoby(membyt(il+i-1),item,1)
  elseif (fmtout.eq.fmt_i4) then
    read (line(i:j),fmt=fmt,iostat=ier) i4
    if (ier.ne.0) then
      call i4toi4(i4,item,1)
      ier = 0
    endif
  elseif (fmtout.eq.fmt_i2) then
    read (line(i:j),fmt=fmt,iostat=ier) i2
    if (ier.ne.0) then
      call bytoby(i2,item,2)
      ier = 0
    endif
  elseif (fmtout.eq.fmt_r4) then
    read (line(i:j),fmt=fmt,iostat=ier) r4
    if (ier.ne.0) then
      call r4tor4(blank,item,1)
      ier = 0
    else
      call r4tor4(r4,item,1)
    endif
  elseif (fmtout.eq.fmt_r8) then
    read (line(i:j),fmt=fmt,iostat=ier) r8
    if (ier.ne.0) then
      call r8tor8(dblnk,item,1)
      ier = 0
    else
      call r8tor8(r8,item,1)
    endif
  elseif (fmtout.eq.fmt_l) then
    read (line(i:j),fmt=fmt,iostat=ier) log
    if (ier.eq.0) then
      call l4tol4(log,item,1)
    else
      ier = 0
    endif
  else
    write(chain,1000) fmtout
    call sic_message(seve%e,rname,chain)
    error = .true.
    return
  endif
  if (ier.ne.0) then
    write(chain,999) fmt
    call sic_message(seve%e,rname,chain)
    call putios('E-READ,  ',ier)
    error =.true.
  endif
  return
  !
999 format('Unable to decode format: "',a,'"')
1000 format('Unsupported format in ASCII table:',a)
end subroutine get_table_item
!
subroutine fits_defstructure(strname,global,error)
  use sic_dependencies_interfaces
  use sic_interfaces, except_this=>fits_defstructure
  use sic_structures
  use gbl_message
  !---------------------------------------------------------------------
  ! @ private
  ! SIC\DEFINE FITS command
  !   Define a new Structure, with an unambiguous name/version
  !---------------------------------------------------------------------
  character(len=*)                :: strname  !
  logical                         :: global   !
  logical,          intent(inout) :: error    !
  ! Local
  character(len=*), parameter :: rname='FITS'
  integer :: np,i,nn
  logical :: quiet
  character(len=80) :: name
  !
  ! Define structure of name extname
  quiet = sic_quiet
  sic_quiet = .true.
  name = strname
  np = len_trim(name)
  call sic_black(strname,np)
  call sic_underscore(strname)
  np = np+1
  call sic_crestructure(name,global,error)
  i = 0
  do while (error)
    i = i+1
    write(name(np:),'(''_'',I3)') i ! Don't put a dot here
    nn = len_trim(name)
    call sic_black(name,nn)
    call sic_crestructure(name,global,error)
    if (i.eq.100.and.error) then
      call sic_message(seve%e,rname,'Too many extensions, aborting')
      sic_quiet = quiet
      error = .true.
      return
    endif
  enddo
  sic_quiet = quiet
  nn = len_trim(name)+1
  name(nn:) = '%'
  if(i.gt.0)then
    call sic_message(seve%i,rname,'Defined Structure '//name(1:nn)//  &
    ' (new version)')
  else
    call sic_message(seve%i,rname,'Defined Structure ... '//name(1:nn))
  endif
  !
  ! Return the name, with the % included ...
  strname = name
end subroutine fits_defstructure
!
subroutine fits_defvariable(strname,nrows,global,error)
  use sic_dependencies_interfaces
  use gildas_def
  use sic_bintable
  use sic_interfaces, except_this=>fits_defvariable
  use sic_structures
  use sic_types
  use gbl_message
  use gbl_format
  !---------------------------------------------------------------------
  ! @ private
  ! SIC\DEFINE FITS command
  !   This version passes a character description of the variable
  !   to the generic SIC function SIC_DEFVARIABLE.
  !   This solves problems of allocation and character arrays
  !---------------------------------------------------------------------
  character(len=*), intent(in)    :: strname  ! Structure name
  integer,          intent(in)    :: nrows    ! Number of rows
  logical,          intent(in)    :: global   ! Global flag
  logical,          intent(inout) :: error    ! Error flag
  ! Local
  character(len=256) :: name
  integer :: ndim,i,j
  integer(kind=index_length) :: dim(sic_maxdims)
  integer :: nn,np,nnn, kk
  logical :: found
  !
  type(sic_descriptor_t) :: desc
  !
  ! Prepare variable names...
  name = strname
  nn = len_trim(name)+1
  name(nn:) = 'COL%'
  nn = nn+4
  call sic_crestructure (name(1:nn-1),global,error)
  if (error) return
  !
  do i=1,ncols
    ! Zero DIM to default value
    dim(:) = 0
    dim(1) = nrows
    ndim = 0
    if (dim(1).gt.1) ndim=1
    !
    ! Variable Name.
    if (len_trim(collabl(i)).eq.0) write (collabl(i),'(I6)') i
    name(nn:)=collabl(i)
    np = len_trim(name)
    !
    ! break loop (do not define variable) if NITEM=0, i.e., the column
    ! was a zero-size array:
    if (nitem(i).le.0) cycle
    !
    ! Variable size & transposition
    if (nitem(i).gt.1) then
      if (transposevar) then
        if (dim(1).gt.1) then
          ndim=2
          dim(2)=nitem(i)
        else
          ndim=1
          dim(1)=nitem(i)
        endif
        !!Print *,'Transpose ',i,ndim,dim(1:2)
      else
        if (dim(1).gt.1) then
          ndim=2
          dim(2)=dim(1)
          dim(1)=nitem(i)
        else
          ndim=1
          dim(1)=nitem(i)
        endif
        !!Print *,'Direct ',i,ndim,dim(1:2)
      endif
    endif
    !
    ! Possible multidimensional TDIMnn supplementary info:
    ! - Reshape 1-D arrays to other form
    if (colndim(i).gt.0) then
      !!Print *,'Before Colndim ',ndim,dim(1:ndim)
      !!Print *,'Colndim ',colndim(i),' nitem ',nitem(i), ' colfmt ',colfmt(i)
      !
      ! SG Character arrays are a little special ? May be not
      ! but I have not yet seen  a repeat count in other types.
      !
      if (colfmt(i).gt.0) then
        ! - Behaviour is different for Character strings than other
        !   arrays, because a N-element "byte" array  in FITS is a
        !   character*n string in SIC
        !
        ! - The *n is stored in colfmt, not in nitem for characters...
        kk = 1
        do j = 1,colndim(i)
          kk = kk*coldim(j,i)
        enddo
        if (kk.ne.colfmt(i)) then
          Print *,'Mismatch between TFORM ',colfmt(i),' and TDIM ',kk
        else if (transposevar.and.colndim(i).eq.2) then
          ! here the Nitem would be coldim(2,i), and the dimensions
          ! but I am not sure what sense this has...
          ! Can we transpose such items ?????
          colfmt(i) = coldim(2,i)
          ndim = colndim(i)
          dim(2) = dim(1)
          dim(1) = coldim(1,i)
        else
          ! here the Nitem would be coldim(1,i), and the dimensions
          colfmt(i) = coldim(1,i)
          ndim = colndim(i)
          dim(ndim) = dim(1)
          do j=2,ndim
            dim(j) = coldim(j,i)
          enddo
        endif
      else
        ! I am not convinced this is correct. I think
        ! in this case, a dimension should be added in all cases.
        if (transposevar.and.ndim.eq.2) then
          ndim=1+colndim(i)
          do j=1,colndim(i)
            dim(j+1)=coldim(j,i)
          enddo
        else
          if (ndim.eq.2) then
            ndim=1+colndim(i)
            dim(ndim)=dim(2)
            do j=1,colndim(i)
              dim(j)=coldim(j,i)
            enddo
          else
            ndim=colndim(i)
            do j=1,ndim
              dim(j)=coldim(j,i)
            enddo
          endif
        endif
      endif
      !!Print *,'After Colndim ',ndim,dim(1:ndim)
    endif
    ! The variable type:
    if (colfmt(i).eq.eei_r8) then
      varformat(i)=fmt_r8
    elseif (colfmt(i).eq.eei_c8) then
      !            VARFORMAT(I)=FMT_C8
      varformat(i)=fmt_c4      !SIC does not handle correctly C8
    elseif (colfmt(i).eq.eei_r4) then
      varformat(i)=fmt_r4
    elseif (colfmt(i).eq.eei_c4) then
      varformat(i)=fmt_c4
    elseif (colfmt(i).eq.eei_i4) then
      varformat(i)=fmt_i4
    elseif (colfmt(i).eq.eei_i8) then
      varformat(i)=fmt_i8
    elseif (colfmt(i).eq.eei_i2) then
      varformat(i)=fmt_i4
    elseif (colfmt(i).eq.eei_l) then
      varformat(i)=fmt_l
    elseif (colfmt(i).eq.fmt_by) then
      varformat(i)=fmt_i4
    elseif (colfmt(i).gt.0) then
      varformat(i)=colfmt(i)
    else                       ! This if for the '1Px(nnn)' variable type
      varformat(i) = fmt_i4
    endif
    !
    !!         IF (COLFMT(I).NE.0) THEN
    ! Encode variable characteristics in NAME, pass to SIC, get back
    ! address
    !
    if (ndim.eq.0) then
      nnn=np
    else
      !! Print *,'Nrow ',nrows,' Dims ',ndim,dim(1:ndim)
      name(np+1:np+1) = '['
      write(name(np+2:),"(7(I12,','))") (dim(j),j=1,ndim)
      nnn = len_trim(name)
      name(nnn:nnn) = ']'
      call sic_black(name,nnn)
    endif
    !
    !! Print *,'defining ',i, varformat(i),trim(name)
    call sic_defvariable(varformat(i),name,global,error)
    if (error) then
      call sic_message(seve%e,'FITS','Error defining '//name(1:nnn))
      goto 99
    endif
    ! Retrieve Pointer, store address
    call sic_descriptor(name(1:np),desc,found)
    if (.not.found) then
      call sic_message(seve%e,'READ','invalid descriptor ?')
      goto 99
    endif
    call adtoad(desc%addr,vmaddr(i),1)
    if (colfmt(i).eq.0) then
      call sic_message(seve%w,'FITS','Data pointer ignored')
    endif
  enddo
  return
  !
99 error=.true.
  return
end subroutine fits_defvariable
!
subroutine fits_decode_binpar(error)
  use sic_dependencies_interfaces
  use sic_interfaces, except_this=>fits_decode_binpar
  use sic_bintable
  use gbl_message
  use gbl_format
  !---------------------------------------------------------------------
  ! @ private
  ! SIC\DEFINE FITS command
  !   Try to decode the column description (for binary tables).
  !---------------------------------------------------------------------
  logical, intent(inout) :: error  ! Error flag
  ! Local
  character(len=*), parameter :: rname='FITS'
  integer :: i,j,m,n,k,length
  character(len=20) :: format
  character(len=message_length) :: mess
  !
  !Print *,'Into fits_decode_binpar'
  coladdr(1) = 1
  !
  ! Decode FITS format of each column into a length, a repeat count and
  ! a SIC format code.
  do i=1,ncols
    format = colform(i)
    n = len(format)
    call sic_black(format,n)
    if (n.eq.0) then
      write(mess,'(A,I0)') 'Format not specified for column ',i
      call sic_message(seve%e,rname,mess)
      call sic_message(seve%e,rname,  &
        'Unable to determine alignment of further columns')
      error = .true.
      return
    endif
    !
    ! Test about strange things like 1PE(1024)
    ! M is normally the first non numeric character index
    j = 1
    m = 0
    do while (m.eq.0)
      k = ichar(format(j:j))
      if (k.lt.ichar('0') .or. k.gt.ichar('9')) then
        m = j
      else
        j = j+1
      endif
    enddo
    !Print *,'Row ',i,m,format
    m = m-1
    if (m.gt.0) then
      read(format(1:m),*,err=10) nitem(i)
      if (nitem(i).le.0) then  ! protect for zerolength array
        length = 0
        colfmt(i) = 0
        goto 33
      endif
    else
      nitem(i) = 1
    endif
    !
    n = m+1
    select case (format(n:n))
    case ('A')  ! Ascii chain
      length = nitem(i)
      colfmt(i) = nitem(i)
      nitem(i) = 1
    case ('D')  ! Real*8
      length = nitem(i)*8
      colfmt(i) = eei_r8
    case ('E')  ! Real*4
      length = nitem(i)*4
      colfmt(i) = eei_r4
    case ('K')  ! Integer*8
      length = nitem(i)*8
      colfmt(i) = eei_i8
    case ('J')  ! Integer*4
      length = nitem(i)*4
      colfmt(i) = eei_i4
    case ('I')  ! Integer*2
      length = nitem(i)*2
      colfmt(i) = eei_i2
    case ('L')  ! Logical = one character 'T' or 'F'
      length = nitem(i)
      colfmt(i) = eei_l
    case ('B')  ! Byte
      length = nitem(i)
      colfmt(i) = fmt_by
    case ('X')  ! Bit Field (imagine that!)
      length = (nitem(i)+7)/8
      colfmt(i) = length
      nitem(i) = 1
    case ('M')  ! Complex*8
      length = nitem(i)*16
      colfmt(i) = eei_c8
    case ('C')  ! Complex*4
      length = nitem(i)*8
      colfmt(i) = eei_c4
    case ('P')  ! Pointer to variable array
      length = 4
      colfmt(i) = 0            ! TEST
      nitem = 2
    case default
      write(mess,'(A,A,A,I0)') 'Unsupported format ',format(1:n),' in column ',i
      call sic_message(seve%e,rname,mess)
      call sic_message(seve%e,rname,  &
        'Unable to determine alignment of further columns')
      error = .true.
      return
    end select
33  coladdr(i+1) = coladdr(i)+length
  enddo
  !
  return
  !
10 call sic_message(seve%e,rname,'Error decoding '//format)
  return
end subroutine fits_decode_binpar
!
subroutine fits_decode_par(error)
  use sic_dependencies_interfaces
  use sic_interfaces, except_this=>fits_decode_par
  use sic_bintable
  use gbl_message
  use gbl_format
  !---------------------------------------------------------------------
  ! @ private
  ! SIC\DEFINE FITS command
  !     Try to decode the column description (for ascii tables).
  !     Adds the '(' around the format for further use
  !---------------------------------------------------------------------
  logical, intent(inout) :: error  ! Error flag
  ! Local
  character(len=*), parameter :: rname='FITS'
  integer :: i,n,m
  character(len=20) :: format
  character(len=1) :: what
  character(len=message_length) :: mess
  !
  ! Decode FITS format of each column into a length, a repeat count and
  ! a SIC format code.
  do i=1,ncols
    format = colform(i)
    call sic_black (format,n)
    colform(i)='('//format(1:n)//')'
    if (n.eq.0) then
      write(mess,'(A,I3)') 'Format not specified for column',i
      call sic_message(seve%e,rname,mess)
      call sic_message(seve%e,rname,'Unable to determine alignment of '//  &
      'further columns')
      goto 99
    endif
    what=format(1:1)
    m=n-1
    ! Ascii chain
    if (what.eq.'A') then
      read(format(2:n),*,err=10) nitem(i)
      colfmt(i) = nitem(i)
      nitem(i)  = 1
      ! Integer
    elseif (what.eq.'I') then
      colfmt(i) = eei_i4
      ! Real*8
    elseif (what.eq.'D') then
      colfmt(i) = eei_r8
      ! Real*4
    elseif (what.eq.'E') then
      colfmt(i) = eei_r4
      ! Real*4 again...
    elseif (what.eq.'F') then
      colfmt(i) = eei_r4
    else
      write(mess,'(A,A,A,I3)') 'Unsupported format ',format(1:n),' in column',i
      call sic_message(seve%e,rname,mess)
      call sic_message(seve%e,rname,'Unable to determine alignment of '//  &
      'further columns')
      goto 99
    endif
    ! Nitem = 1 for TABLES...
    nitem(i)  = 1
  enddo
  !
  return
  !
99 error = .true.
  return
10 call sic_message(seve%e,rname,'Error decoding '//format(1:n-1))
  return
end subroutine fits_decode_par
!
subroutine scale_table8(a,n,s,z)
  use sic_interfaces
  !---------------------------------------------------------------------
  ! @ no-interface (because of argument type mismatch)
  !---------------------------------------------------------------------
  integer, intent(in) :: n                      ! Array size
  real(8), intent(inout) :: a(n)                ! Array
  real(4), intent(in) :: s                      ! Scaling factor
  real(4), intent(in) :: z                      ! Offset
  ! Local
  integer :: i
  !
  do i=1,n
    a(i)=a(i)*s+z
  enddo
end subroutine scale_table8
!
subroutine scale_table4(a,n,s,z)
  use sic_interfaces
  !---------------------------------------------------------------------
  ! @ no-interface (because of argument type mismatch)
  !---------------------------------------------------------------------
  integer, intent(in) :: n                      ! Array size
  real(4), intent(inout) :: a(n)                ! Array
  real(4), intent(in) :: s                      ! Scaling factor
  real(4), intent(in) :: z                      ! Offset
  ! Local
  integer :: i
  !
  do i=1,n
    a(i)=a(i)*s+z
  enddo
  return
end subroutine scale_table4
!
subroutine transpose_table8(a,n,m)
  use sic_interfaces
  !---------------------------------------------------------------------
  ! @ no-interface (because of argument type & rank mismatch)
  ! transpose A using workspace W and dimensions N and M
  !---------------------------------------------------------------------
  integer, intent(in) :: n                      ! Dimensions
  integer, intent(in) :: m                      ! Dimensions
  integer(8), intent(inout) :: a(m,n)                ! Array
  integer(8) :: w(n,m)                ! Automatic array
  integer :: i,j
  !
  ! Copy in work
  call i8toi8(a,w,n*m)
  ! transpose
  do j=1,n
    do i=1,m
      a(i,j) = w(j,i)
    enddo
  enddo
end subroutine transpose_table8
!
subroutine transpose_tablec8(a,n,m)
  use sic_interfaces
  !---------------------------------------------------------------------
  ! @ no-interface (because of argument type mismatch)
  ! transpose A using workspace W and dimensions N and M for Complex values
  !---------------------------------------------------------------------
  integer, intent(in) :: n                      ! Dimensions
  integer, intent(in) :: m                      ! Dimensions
  real(8), intent(out) :: a(2,m,n)              ! Array
  real(8) :: w(2,n,m)              ! Automatic array
  ! Local
  integer :: i,j
  ! Copy in work
  call r8tor8(a,w,2*m*n)
  ! transpose
  do j=1,n
    do i=1,m
      a(:,i,j) = w(:,j,i)
    enddo
  enddo
end subroutine transpose_tablec8
!
subroutine transpose_table4(a,n,m)
  use sic_interfaces
  !---------------------------------------------------------------------
  ! @ no-interface (because of argument type mismatch)
  ! transpose A using workspace W and dimensions N and M
  !---------------------------------------------------------------------
  integer, intent(in) :: n                      ! Dimensions
  integer, intent(in) :: m                      ! Dimensions
  integer(4), intent(out) :: a(m,n)                ! Array
  integer(4) :: w(n,m)                ! Automatic array
  ! Local
  integer :: i,j
  ! Copy in work
  call i4toi4(a,w,m*n)
  ! transpose
  do j=1,n
    do i=1,m
      a(i,j) = w(j,i)
    enddo
  enddo
end subroutine transpose_table4
!
subroutine sic_underscore(a)
  !---------------------------------------------------------------------
  ! @ private
  !  Replace all SIC reserved characters by "_" to produce a valid SIC
  ! variable name. Length of string not modified.
  !---------------------------------------------------------------------
  character(len=*), intent(inout) :: a  ! Variable name to be checked
  ! Local
  integer(kind=4) :: n,i
  !
  n = len_trim(a)
  do i=1,n
    if (a(i:i).eq.' ' .or. a(i:i).eq.'(' .or. a(i:i).eq.')' .or.  &
        a(i:i).eq.'.' .or. a(i:i).eq.'%' .or. a(i:i).eq.'[' .or.  &
        a(i:i).eq.']' .or. a(i:i).eq.'+' .or. a(i:i).eq.'-')  a(i:i)='_'
  enddo
  !
end subroutine sic_underscore
!
subroutine read_mainfits(array,nsize,bscal,bzero,fmtin,blank,error)
  use sic_interfaces
  use sic_dependencies_interfaces
  use gbl_message
  use gbl_format
  !---------------------------------------------------------------------
  ! @ no-interface (because of argument type mismatch)
  ! SIC\DEFINE FITS command
  !     Read the "standard" FITS header and data and define main FITS data
  !     as a SIC variable
  !---------------------------------------------------------------------
  integer, intent(in)    :: nsize         ! Size of data array
  real(4), intent(inout) :: array(nsize)  ! Data array
  real(4), intent(in)    :: bscal         ! Scaling factor
  real(4), intent(in)    :: bzero         ! Offset
  integer, intent(in)    :: fmtin         ! Format of data
  real(4), intent(inout) :: blank(2)      ! Blanking Value
  logical, intent(inout) :: error         ! Error flag
  !
  integer, external :: gdf_conv
  !
  ! Local
  integer, parameter :: nbufsiz=2880
  integer :: nfill,nitem,i,fmt,status
  integer(kind=size_length) :: nbyt
  integer(kind=1) :: buffer(nbufsiz)
  integer(kind=4) :: ibuffer(nbufsiz/4)
  equivalence (ibuffer,buffer)
  real :: ritem(nbufsiz)          ! Must be as long as BUFFER in elements
  integer(4) :: iritem(720)       ! But this one only needs the buffer size
  equivalence (iritem,ritem)
  !
  integer(4) :: item(720)
  integer(2) :: item2(1440)
  !
  real(8) :: ditem(360)
  integer(4) :: jditem(720)
  equivalence (jditem,ditem)
  character(len=80) :: chain
  character(len=message_length) :: mess
  logical :: check_blank
  !
  nfill = 0
  if ((fmtin.eq.eei_r4).or.(fmtin.eq.eei_r8)) then
    check_blank = .true.
  else
    check_blank = .false.
    blank(1) = blank(1)*bscal+bzero
  endif
  !
  do while (.true.)
    nbyt = nbufsiz
    call gfits_getbuf(buffer,nbyt,error)
    if ((nbyt.eq.0).or.error) then
      call sic_message(seve%e,'READ','Error reading FITS file')
      error = .true.
      return
    endif
    !
    if (fmtin.eq.eei_i4) then
      fmt = fmt_i4
      nitem = min(nbyt/4,nsize-nfill)
      if (fmt.eq.iee_i4) then
        call eii4ie(buffer,item,nitem)
      elseif  (fmt.eq.vax_i4) then
        call eii4va(buffer,item,nitem)
      else
        call bytoby_sl(buffer,item,nbyt)
      endif
      call i4tor4(item,ritem,nitem)
      !
    elseif (fmtin.eq.eei_i2) then
      fmt = fmt_i2
      nitem = min(nbyt/2,nsize-nfill)
      if (fmt.eq.iee_i2) then
        call eii2ie(buffer,item2,nitem)
      elseif  (fmt.eq.vax_i2) then
        call eii2va(buffer,item2,nitem)
      else
        call bytoby_sl(buffer,item2,nbyt)
      endif
      call i2tor4(item2,ritem,nitem)
      !
    elseif (fmtin.eq.eei_r4) then
      fmt = fmt_r4
      nitem = min(nbyt/4,nsize-nfill)
      if (fmtin.eq.fmt_r4) then
        call r4tor4(buffer,ritem,nitem)
      else
        status = gdf_conv(ibuffer,iritem,nitem,fmt_r4,eei_r4)
        if (status.ne.1) then
          write(mess,*) 'Convert error R*4 ',fmt_r4,eei_r4
          call sic_message(seve%e,'FITS',mess)
        endif
      endif
    elseif (fmtin.eq.eei_r8) then
      fmt = fmt_r4
      nitem = min(nbyt/8,nsize-nfill)
      if (fmtin.eq.fmt_r8) then
        call r8tor4(buffer,ritem,nitem)
      else
        status = gdf_conv(ibuffer,jditem,nitem*2,fmt_r8,eei_r8)
        if (status.ne.1) then
          write(mess,*) 'Convert error R*8 ',fmt_r8,eei_r4
          call sic_message(seve%e,'FITS',mess)
        endif
        call r8tor4(ditem,ritem,nitem)
      endif
    elseif (fmtin.eq.fmt_by) then
      nitem = min(nbyt,nsize-nfill)
      do i = 1,nitem
        ritem(i) = buffer(i)
      enddo
    else
      write(chain,1000) fmtin
      call sic_message(seve%e,'READ',chain)
      goto 99
    endif
    !
    ! Scale and zero
    if (check_blank) then
      do i = 1,nitem
        nfill = nfill+1
        if (ritem(i).ne.ritem(i)) then
          array(nfill) = blank(1)
          blank(2) = 0.0
        else
          array(nfill) = ritem(i)*bscal+bzero
        endif
      enddo
    else
      do i = 1,nitem
        nfill = nfill+1
        array(nfill) = ritem(i)*bscal+bzero
      enddo
    endif
    if (nfill.ge.nsize) return
  enddo
  return
  !
99 error = .true.
  return
  !
1000 format('Unsupported format in main data: ',i6)
end subroutine read_mainfits
!
subroutine fits_read_basic(head,ns,global,fmt,nsize,ndim,dim,error,extend,  &
  therank,data,skipsz)
  use gildas_def
  use gbl_constant
  use gbl_format
  use gbl_message
  use sic_dependencies_interfaces
  use sic_interfaces, except_this=>fits_read_basic
  use sic_types
  !---------------------------------------------------------------------
  ! @ private
  ! SIC\DEFINE FITS command
  !   Read a basic FITS header
  !---------------------------------------------------------------------
  character(len=*),           intent(in)    :: head              ! Header name
  integer(kind=4),            intent(in)    :: ns                ! Length of name
  logical,                    intent(in)    :: global            ! Global / Local status
  integer(kind=4),            intent(in)    :: fmt               ! Format of data
  integer(kind=size_length),  intent(in)    :: nsize             ! Size in output words 
  integer(kind=4),            intent(inout) :: ndim              ! Number of dimensions
  integer(kind=index_length), intent(inout) :: dim(sic_maxdims)  ! Dimensions
  logical,                    intent(inout) :: error             ! Error flag
  logical,                    intent(out)   :: extend            ! Are there extensions ?
  integer(kind=4),            intent(in)    :: therank           ! Desired trimming
  logical,                    intent(in)    :: data              ! Do you want the data ?
  integer(kind=size_length),  intent(in)    :: skipsz            ! Size in bytes in FITS data
  ! Global
  include 'gbl_memory.inc'
  ! Local
  character(len=*), parameter :: routname='FITS'
  real(kind=4) :: bscal,bzero
  character(len=80) :: name,chain
  character(len=8) :: comm, trans
  integer(kind=4) :: nnn,i,ier
  integer(kind=address_length) :: ip
  type(sic_descriptor_t) :: desc
  logical :: found
  real(kind=4) :: blank(2)
  !
  blank(1) = -1.23456E+38
  blank(2) = -1.0
  !
  ! Define data size if non zero
  if (ndim.ne.0) then
    if (data)  call sic_message(seve%i,routname,'Loading the basic array')
    !
    bscal = 1.0
    bzero = 0.0
    !
    call fits_trim(ndim,dim,therank)
  endif
  !
  do
    call gfits_get(comm,chain,.false.,error)
    if (error)  return
    !
    ! Translate symbols if any
    call sic_getsymbol (comm,trans,error)
    if (error) then
       error = .false.
    else
       comm = trans
    endif
    !
    select case (comm)
    case ('EXTEND')  ! Test the EXTEND keyword even if it is misplaced
      if (index(chain,'T').ne.0) extend = .true.
    case ('GROUPS')
      if (chain(20:20).eq.'T')  return
    case ('PCOUNT','GCOUNT')
      return
    case ('HISTORY','COMMENT','BLOCKED','','DATA')
      continue
    case ('HIERARCH')
      ! print *,'Hierarch keyword ',comm
      call do_hierarch(head,ns,chain,global)
      ! print *,'Hierarch keyword ',comm,' done '
    case ('BSCALE')
      read(chain,*,iostat=ier) bscal
    case ('BZERO')
      read(chain,*,iostat=ier) bzero
    case ('BLANK')
      read(chain,*,iostat=ier) blank(1)  ! The Blanking Value is in Scaled Units
      blank(2) = 0.0
    case ('END')
      exit
    case default
      call sic_underscore(comm)
      name = head(1:ns)//'%'//comm
      call fits_sicvariable(name,chain,global)
    end select
  enddo
  !
  ! Skip to next FITS record
  !
  ! Skip only if there is some data
  if (ndim.ne.0) call gfits_flush_data(error)
  !
  ! Return if no data
  if (ndim.eq.0) return
  !
  if (data) then
    ! Define the data array
    name = head(1:ns)//'%DATA['
    nnn = len_trim(name)+1
    write(name(nnn:),"(20(I12,','))") (dim(i),i=1,ndim)
    nnn = len_trim(name)
    name(nnn:nnn) = ']'
    call sic_black(name,nnn)
    call sic_defvariable(fmt_r4,name(1:nnn),global,error)
    if (error)  return
    !
    ! Read the file
    nnn = ns+5
    call sic_descriptor(name(1:nnn),desc,found)
    ip = gag_pointer(desc%addr,memory)
    call read_mainfits(memory(ip),nsize,bscal,bzero,fmt,blank,error)
    !
    if (blank(2).ge.0.0) then
      name = head(1:ns)//'%BLANK[2]'
      nnn = len_trim(name)
      call sic_defvariable(fmt_r4,name(1:nnn),global,error)
      if (error)  return
      nnn = nnn-3
      call sic_descriptor(name(1:nnn),desc,found)
      ip = gag_pointer(desc%addr,memory)
      call r4tor4(blank,memory(ip),2)
    endif
  else
    ! Skip the DATA array
    !!Print *,'SKIBUF #6 ',skipsz,' Bytes'
    call gfits_skibuf(skipsz,error)
    if (error) return
    call gfits_flush_data(error)
  endif
  !
end subroutine fits_read_basic
!
subroutine fits_read_rndm(head,ns,global,fmt,nsize,ndim,dim,error,extend,  &
  gcount,pcount,rndmsize,data,skipsz)
  use gildas_def
  use sic_dependencies_interfaces
  use sic_interfaces, except_this=>fits_read_rndm
  use sic_types
  use gbl_message
  use gbl_format
  !---------------------------------------------------------------------
  ! @ private
  ! SIC\DEFINE FITS command
  !   Read a Random Group
  !---------------------------------------------------------------------
  character(len=*),           intent(in)    :: head              ! Header name
  integer(kind=4),            intent(in)    :: ns                ! Length of name
  logical,                    intent(in)    :: global            ! Global / Local status
  integer(kind=4),            intent(in)    :: fmt               ! Format of data
  integer(kind=size_length),  intent(in)    :: nsize             ! Size in words of data
  integer(kind=4),            intent(inout) :: ndim              ! Number of dimensions
  integer(kind=index_length), intent(inout) :: dim(sic_maxdims)  ! Dimensions
  logical,                    intent(inout) :: error             ! Error flag
  logical,                    intent(out)   :: extend            ! Are there extensions ?
  integer(kind=4),            intent(in)    :: gcount            ! GCOUNT value
  integer(kind=4),            intent(in)    :: pcount            ! PCOUNT value
  integer(kind=4),            intent(in)    :: rndmsize          ! Random group size
  logical,                    intent(in)    :: data              ! Read data ?
  integer(kind=size_length),  intent(in)    :: skipsz            ! Size in Bytes in FITS file
  ! Global
  include 'gbl_memory.inc'
  ! Local
  character(len=*), parameter :: routname='FITS'
  real(kind=4) :: bscal,bzero,x
  real(kind=4) :: rscal(10),rzero(10)
  character(len=80) :: name,chain
  character(len=8) :: comm
  integer(kind=4) :: nnn,i,ier,igroup
  integer(kind=address_length) :: ip
  type(sic_descriptor_t) :: desc
  logical :: found
  real(kind=4) :: blank(2)
  !
  blank(1) = 1.23456E+38
  blank(2) = -1.0
  !
  ! Define data size if non zero
  bscal = 1.0
  bzero = 0.0
  !
  if (ndim.ne.0 .or. gcount.ne.0) then
    if (ndim.ne.0) then
      if (data) call sic_message(seve%i,routname,'Loading the basic array')
    else
      if (data) call sic_message(seve%i,routname,'Loading the random group array')
      ndim = 2
      dim(1) = pcount+rndmsize   ! Not PCOUNT, also data here...
      dim(2) = gcount
      dim(3:) = 0
    endif
  endif
  !
  do
    call gfits_get(comm,chain,.false.,error)
    if (error)  return
    !
    ! Test the EXTEND keyword even if it is misplaced
    if (comm.eq.'EXTEND') then
      if (index(chain,'T').ne.0) extend = .true.
    elseif (comm.eq.'GROUPS') then
      if (chain(20:20).eq.'T')  return
    elseif  (comm.eq.'PCOUNT') then
      return
    elseif  (comm.eq.'GCOUNT') then
      return
    elseif (comm.eq.'BLANK') then
      ! The Blanking Value is in Scaled Units
      read(chain,*,iostat=IER) blank(1)
      blank(2) = 0.0
      !
      ! Random group scaling factors
    elseif (comm(1:5).eq.'PTYPE') then
      continue
    elseif (comm(1:5).eq.'PSCAL') then
      read(comm(6:6),'(I1)',iostat=ier) igroup
      if (igroup.lt.9) then
        read(chain,*,iostat=ier) x
        rscal(igroup) = x
      endif
    elseif (comm(1:5).eq.'PZERO') then
      read(comm(6:6),'(I1)',iostat=ier) igroup
      if (igroup.le.9) then
        read(chain,*,iostat=ier) x
        rzero(igroup) = x
      endif
      !
    elseif  (comm.eq.'HISTORY') then
      continue
    elseif  (comm.eq.'COMMENT') then
      continue
    elseif  (comm.eq.'HIERARCH') then
      call do_hierarch(head,ns,chain,global)
    elseif  (comm.eq.'BLOCKED') then
      continue
    elseif  (comm.eq.'        ') then
      continue
    elseif  (comm.eq.'DATA') then  ! Reserved for main array
      continue
    elseif  (comm.eq.'END') then
      exit
      !
    else
      call sic_underscore(comm)
      name = head(1:ns)//'%'//comm
      call fits_sicvariable(name,chain,global)
    endif
  enddo
  !
  ! Skip to next FITS record
  !
  ! Skip only if there is some data, but there must be
  if (ndim.ne.0 .or. gcount.ne.0) call gfits_flush_data(error)
  !
  ! Test if Random or Normal data
  if (data) then
    if (pcount.eq.0) then
      !
      ! Define the data array
      name = head(1:ns)//'%DATA['
      nnn = len_trim(name)+1
      write(name(nnn:),"(20(I12,','))") (dim(i),i=1,ndim)
      nnn = len_trim(name)
      name(nnn:nnn) = ']'
      call sic_black(name,nnn)
      call sic_defvariable(fmt_r4,name(1:nnn),global,error)
      !!Print *,'Main Name ',name(1:nnn)
      if (error)  return
      !
      ! Read the file
      nnn = ns+5
      call sic_descriptor(name(1:nnn),desc,found)
      ip = gag_pointer(desc%addr,memory)
      call read_mainfits(memory(ip),nsize,bscal,bzero,fmt,blank,error)
      !
      if (blank(2).ge.0.0) then
        name = head(1:ns)//'%BLANK[2]'
        nnn = len_trim(name)
        call sic_defvariable(fmt_r4,name(1:nnn),global,error)
        if (error)  return
        nnn = nnn-3
        call sic_descriptor(name(1:nnn),desc,found)
        ip = gag_pointer(desc%addr,memory)
        call r4tor4(blank,memory(ip),2)
      endif
    elseif  (gcount.ne.0) then
      !
      ! Define the data array
      name = head(1:ns)//'%DATA['
      nnn = len_trim(name)+1
      write(name(nnn:),"(20(I12,','))") (dim(i),i=1,ndim)
      nnn = len_trim(name)
      name(nnn:nnn) = ']'
      call sic_black(name,nnn)
      name(nnn:nnn) = ']'
      call sic_black(name,nnn)
      call sic_defvariable(fmt_r4,name(1:nnn),global,error)
      if (error)  return
      !
      ! Read the file
      nnn = ns+5
      call sic_descriptor(name(1:nnn),desc,found)
      ip = gag_pointer(desc%addr,memory)
      rscal(10) = bscal
      rzero(10) = bzero
      !!Print *,'Calling READ_RNDMFITS', pcount+rndmsize,gcount,pcount
      call read_rndmfits(memory(ip),pcount+rndmsize,gcount,pcount,rscal,rzero,  &
      fmt,error)
    else
      call sic_message(seve%w,routname,'No data at all')
    endif
  else
    ! Sizes are already in Bytes here 
    !!Print *,'SKIBUF #7 ',skipsz,' Bytes or ',nsize, gcount*(pcount+rndmsize),' Words'
    call gfits_skibuf(skipsz,error)
    if (error) return
    call gfits_flush_data(error)
  endif
  !
end subroutine fits_read_rndm
!
subroutine read_rndmfits(array,kc,gc,pc,rscal,rzero,fmt,error)
  use gildas_def
  !---------------------------------------------------------------------
  ! @ no-interface (because of argument type mismatch)
  ! SIC\DEFINE FITS
  !      Read a Random group
  !---------------------------------------------------------------------
  integer, intent(in)    :: kc            ! First dimension of Array
  integer, intent(in)    :: gc            ! Second dimension of Array
  real,    intent(out)   :: array(kc,gc)  ! Array
  integer, intent(in)    :: pc            ! Pcount offset
  real,    intent(in)    :: rscal(10)     ! Scaling
  real,    intent(in)    :: rzero(10)     ! Offset
  integer, intent(in)    :: fmt           ! Data format
  logical, intent(inout) :: error         ! Error flag
  ! Local
  integer :: ig,ip,kp,mp,istart
  integer(kind=size_length) :: lp
  !
  ! FMT is the format of input...
  kp = kc-pc
  mp = min(pc,9)
  !
  do ig=1,gc
    ! The 9 first with appropriate scaling
    lp = 1
    do ip=1,mp
      call sgetreal(lp,array(ip,ig),rscal(ip),rzero(ip),error,fmt)
    enddo
    ! The next ones up to PC with 1. and 0.
    if (pc.gt.9) then
      lp = pc-mp
      call sgetreal(lp,array(10,ig),1.0,0.0,error,fmt)
    endif
    ! The last ones with their scaling
    if (kp.gt.0) then
      istart = pc+1
      do ip=1,kp,720
        lp = min(kp-ip+1,720)
        call sgetreal(lp,array(istart,ig),rscal(10),rzero(10),error,fmt)
        istart = istart+720
      enddo
    endif
  enddo
end subroutine read_rndmfits
!
subroutine sgetreal(ndat,data,scale,zero,error,fmt)
  use gildas_def
  use gbl_message
  use gbl_format
  use sic_interfaces, except_this=>sgetreal
  use sic_dependencies_interfaces, no_interface=>gfits_getbuf
  !---------------------------------------------------------------------
  ! @ private
  ! SIC\DEFINE FITS command
  !   Read NDAT data values in FITS data area,
  !   with scaling SCALE and offset ZERO
  !---------------------------------------------------------------------
  integer(kind=size_length), intent(in)    :: ndat        ! Number of data
  real(kind=4),              intent(out)   :: data(ndat)  ! Data array
  real(kind=4),              intent(in)    :: scale       ! Scaling factor
  real(kind=4),              intent(in)    :: zero        ! Offset
  logical,                   intent(inout) :: error       ! Error flag
  integer(kind=4),           intent(in)    :: fmt         ! Data format
  ! Local
  logical :: err
  integer(kind=4) :: nfill
  integer(kind=size_length) :: i,nbyt
  real(kind=4) :: vtest
  real(kind=4) :: buffer(720)
  integer(kind=2) :: i2buf(1440)
  integer(kind=4) :: i4buf(720)
  equivalence (buffer,i2buf,i4buf)  ! Needed, but possibly causing problems
  !                                 ! because of argument overlap
  !                                 ! Must be removed using appropriate GDF_CONV
  !
  err = .false.
  !
  !  Print *,'FMTIN ',fmt,eei_i2,eei_i4
  !  Print *,'FMTOU ',fmt,fmt_i2,fmt_i4
  !
  ! I*2
  if (fmt.eq.eei_i2) then
    nbyt = 2_8*ndat
    call gfits_getbuf(buffer,nbyt,err)
    if (fmt_i2.ne.eei_i2) then
      call iei2ei_sl(buffer,i2buf,ndat)
    endif
    do i=1,ndat
      vtest = i2buf(i)
      data(i) = scale*vtest+zero
    enddo
  elseif (fmt.eq.eei_i4) then
    nbyt = 4_8*ndat
    call gfits_getbuf(buffer,nbyt,err)
    if (fmt_i4.ne.eei_i4) then
      call iei4ei_sl(buffer,i4buf,ndat)
    endif
    do i = 1, ndat
      vtest = i4buf(i)
      data(i) = scale*vtest+zero
    enddo
  elseif (fmt.eq.eei_r4) then
    nbyt = 4_8*ndat
    call gfits_getbuf(buffer,nbyt,err)
    !
    ! To be replaced by appropriate call to GDF_CONV
    ! if some conversion is needed...
    !
    !        STATUS = GDF_CONV(BUFFER,RITEM,NITEM,FMT_R4,EEI_R4)
    !
    nfill = 0
    call ieee32_to_real(buffer,ndat,data,ndat,nfill,scale,zero,vtest)
  else
    call sic_message(seve%e,'SGETREAL','Wrong NBIT')
    error = .true.
  endif
end subroutine sgetreal
!
subroutine do_hierarch(s,n,val,global)
  use gildas_def
  use gbl_format
  use sic_dependencies_interfaces
  use sic_interfaces, except_this=>do_hierarch
  !---------------------------------------------------------------------
  ! @ private
  ! Support for command
  !   SIC\DEFINE FITS
  ! Support for HIERARCH keywords (ESO certainly, most possibly all
  ! others). Note that due to the nature of the SIC variables, blanks in
  ! the keyword are translated to underscores.
  !---------------------------------------------------------------------
  character(len=*), intent(in)    :: s       ! Header name
  integer(kind=4),  intent(in)    :: n       ! Length of name
  character(len=*), intent(inout) :: val     ! HIERARCH value
  logical,          intent(in)    :: global  ! Global flag
  ! Local
  integer(kind=4) :: i1,i2,nn,nnn,ier
  character(len=varname_length) :: struct
  character(len=80) :: string,key
  logical :: error,logi
  real(kind=8) :: double
  character(len=1), parameter :: quote=''''
  !
  error = .false.
  !
  ! Should do Nothing until a special flag '/DO_HIERARCH' for example
  ! has been inserted since the numerous ESO keywords simply overflow
  ! the max num of sic variables.
  !
  call gfits_hierarch(key,val,error)
  if (error)  return
  !
  ! Replace blank chars with underscores:
  call sic_underscore(key)
  struct = s(1:n)//'%'//key
  nnn = len_trim(struct)
  !
  ! Use of sic_makestructhier avoid unpleasant warnings and insure structure
  ! existence.
  call sic_makestructhier(struct,global,error)
  if (error) return
  !
  ! Look val more closely for string or real value. reals are mapped to doubles
  ! ZZZ should use fits_sicvariable but the logical letter are not aligned
  ! as in the other cases.
  i1 = index(val,quote)
  if (i1.ne.0) then
    string = val(i1+1:)
    i2 = index(string,quote)
    string(i2:) = ' '
    i2 = i2-1
    if (i2.gt.0) then
      call fits_sicstr(string,i2,struct,global)
    endif
  else
    nn = len_trim(val)
    call sic_black(val,nn)
    if  (val(1:1).ne.'T' .and. val(1:1).ne.'F' .and. val(1:1).ne.'U') then
      ! Define a double value
      read(val,*,iostat=ier) double
      call fits_sicnum(double,fmt_r8,struct,global)
    else
      ! Define a logical value
      logi = val(1:1).eq.'T'
      call fits_sicnum(logi,fmt_l,struct,global)
    endif
  endif
  !
end subroutine do_hierarch
!
subroutine sic_blanktostruct(a,n)
  use sic_interfaces, except_this=>sic_blanktostruct
  !---------------------------------------------------------------------
  ! @ private
  !   Replace spaces by % sign
  !---------------------------------------------------------------------
  character(len=*) :: a             !
  integer :: n                      !
  ! Local
  integer :: i
  n=len_trim(a)
  !
  do i=1,n
    if (a(i:i).eq.' ') a(i:i) = '%'
  enddo
end subroutine sic_blanktostruct
!
subroutine sic_makestructhier(namein,global,error)
  use sic_interfaces, except_this=>sic_makestructhier
  use gildas_def
  use sic_structures
  use sic_dictionaries
  use sic_types
  use gbl_message
  !---------------------------------------------------------------------
  ! @ private
  ! SIC\DEFINE FITS command
  !   Create a SIC structure from a HIERARCH keyword
  !   Creates all intermediate structures if needed
  !---------------------------------------------------------------------
  character(len=*), intent(in)  :: namein        ! Structure name
  logical, intent(in)  :: global                 ! Global status
  logical, intent(out)  :: error                 ! Error flag
  ! Local
  integer :: in
  integer :: n,i,ier
  type(sic_identifier_t) :: var
  !
  ! test structure existence
  error = .false.
  n = len_trim(namein)
  if (namein(n:n).eq.'%') then
    call sic_message(seve%e,'CHECK','Invalid structure member name '//  &
    namein(1:n-1))
    error = .true.
    return
  endif
  !
  do i=1,n
    if (namein(i:i).eq.'%') then
      ! Seems to be a structure
      var%name = namein(1:i-1)
      var%lname = i-1
      if (global) then
        var%level = 0
      else
        var%level = var_level
      endif
      ier = sic_hasfin(maxvar,pfvar,pnvar,dicvar,var,in)
      if (ier.ne.1) then
        call sic_crestructure(namein(1:i-1),global,error)
        if (error) return
      endif
    endif
  enddo
  !
end subroutine sic_makestructhier
!
subroutine fits_sicvariable(name,chain,global)
  use gbl_format
  use gbl_message
  !---------------------------------------------------------------------
  ! @ private
  !   Create a Sic variable from a FITS value string
  !---------------------------------------------------------------------
  character(len=*), intent(in) :: name    ! Variable name
  character(len=*), intent(in) :: chain   ! Value to be decoded
  logical,          intent(in) :: global  ! Logical error flag
  ! Local
  character(len=*), parameter :: rname='FITS'
  character(len=1), parameter :: quote='''',dot='.',eexp='E',dexp='D'
  integer(kind=4) :: i1,i2,ier
  logical :: intformatted
  ! Support for actual values:
  character(len=80) :: string
  integer(kind=8) :: intg
  real(kind=8) :: doubl
  logical :: logi
  !
  i1 = index(chain,quote)
  if (i1.ne.0) then
    string = chain(i1+1:)
    i2 = index(string,quote)
    string(i2:) = ' '
    i2 = i2-1
    ! Define a character string
    if (i2.gt.0) then
      call fits_sicstr(string,i2,name,global)
    else
      ! Empty string... Should we define a Sic variable?
    endif
    !
  elseif (chain(20:20).ne.'T' .and. chain(20:20).ne.'F' .and.  &
          chain(20:20).ne.'U') then
    ! Define numeric variable (real or integer)
    intformatted = index(chain,dot).eq.0  .and.  &
                   index(chain,eexp).eq.0 .and.  &
                   index(chain,dexp).eq.0
    if (intformatted) then
      read(chain,'(I20)',iostat=ier) intg
      if (ier.eq.0) then
        call fits_sicnum(intg,fmt_i8,name,global)
      else
        call sic_message(seve%w,rname,'Error decoding '//chain)
      endif
    else
      read(chain,*,iostat=ier) doubl
      if (ier.eq.0) then
        call fits_sicnum(doubl,fmt_r8,name,global)
      else
        call sic_message(seve%w,rname,'Error decoding '//chain)
      endif
    endif
  else
    ! Define a logical value
    logi = chain(20:20).eq.'T'
    call fits_sicnum(logi,fmt_l,name,global)
  endif
  !
end subroutine fits_sicvariable
!
subroutine fits_sicnum(in,fmt,name,global)
  use gildas_def
  use sic_dependencies_interfaces
  use sic_interfaces
  use sic_types
  use gbl_message
  use gbl_format
  !---------------------------------------------------------------------
  ! @ no-interface (because of argument type mismatch - on purpose - )
  ! SIC\DEFINE FITS command
  !   Fill a SIC variable of specified (numerical) type
  !   from a FITS keyword number value
  !---------------------------------------------------------------------
  real(kind=8),     intent(in) :: in      ! Input value
  integer(kind=4),  intent(in) :: fmt     ! Type of SIC variable
  character(len=*), intent(in) :: name    ! Variable name
  logical,          intent(in) :: global  ! Global flag
  ! Local
  logical :: error
  integer :: n
  logical :: found
  integer(kind=address_length) :: ip
  type(sic_descriptor_t) :: desc
  include 'gbl_memory.inc'
  !
  error = .false.
  n = len_trim(name)
  call sic_defvariable(fmt,name(1:n),global,error)
  if (error) return
  !
  call sic_descriptor(name(1:n),desc,found)
  ip = gag_pointer(desc%addr,memory)
  !
  select case (fmt)
  case (fmt_r8,fmt_i8)
     call r8tor8(in,memory(ip),1)
  case default
     call r4tor4(in,memory(ip),1)
  end select
end subroutine fits_sicnum
!
subroutine fits_sicstr(str,lstr,name,global)
  use sic_dependencies_interfaces
  use gildas_def
  use sic_interfaces, except_this=>fits_sicstr
  use sic_types
  use gbl_message
  use gbl_format
  !---------------------------------------------------------------------
  ! @ private
  ! SIC\DEFINE FITS command
  !   Fill a SIC character variable from a FITS keyword value
  !---------------------------------------------------------------------
  character(len=*), intent(in) :: str
  integer, intent(in) :: lstr
  character(len=*), intent(in) :: name
  logical, intent(in) :: global
  !
  logical :: error
  integer :: n
  logical :: found
  type(sic_descriptor_t) :: desc
  !
  error = .false.
  n = len_trim(name)
  call sic_defvariable(lstr,name(1:n),global,error)
  if (error) return
  call sic_descriptor(name(1:n),desc,found)
  !
  call ctodes(str,desc%type,desc%addr)
end subroutine fits_sicstr
!
subroutine fits_trim(ndim,dim,therank)
  use gildas_def
  !---------------------------------------------------------------------
  ! @ private
  ! SIC\DEFINE FITS command
  !   Support for option /TRIM
  !   Truncate degenerate dimensions
  !---------------------------------------------------------------------
  integer(kind=4), intent(inout) :: ndim
  integer(kind=index_length), intent(in) :: dim(sic_maxdims)
  integer(kind=4), intent(in) :: therank
  !
  integer :: i, thedim
  !
  if (therank.gt.0) then
    ndim = therank
  else if (therank.eq.-10) then
    thedim = ndim
    do i=ndim,1,-1
      if (dim(i).gt.1) then
        thedim = i
        exit
      endif
    enddo
    ndim = thedim
  endif
end subroutine fits_trim
