subroutine gio_gems (ms, is, blc, trc, addr, form, error)
  use gio_dependencies_interfaces
  use gio_interfaces, except_this=>gio_gems
  use gildas_def
  use gio_image
  use gbl_message
  use gbl_format
  !---------------------------------------------------------------------
  ! @ public
  ! GIO
  !     GEt Memory Slot
  !     Generalized version to also obtain non-contiguous subsets
  !---------------------------------------------------------------------
  integer, intent(out) :: ms                         ! Memory slot
  integer, intent(in)  :: is                         ! Image slot
  integer(kind=index_length), intent(in)  :: blc(:)  ! Bottom left corner
  integer(kind=index_length), intent(in)  :: trc(:)  ! Top right corner
  integer(kind=address_length), intent(out) :: addr  ! Returned address
  integer, intent(in)  :: form                       ! Image format
  logical, intent(out) :: error                      ! Flag
  ! Global
  include 'gbl_memory.inc'
  ! Local
  character(len=*), parameter :: rname='GIO_GEMS'
  integer(kind=address_length) :: ipi, ipo, addr_tmp
  integer :: ms_tmp, ier, ndim
  integer(kind=index_length) :: jblc(gdf_maxdims), jtrc(gdf_maxdims), dimin(gdf_maxdims), dimou(gdf_maxdims), &
       & iblc(gdf_maxdims), itrc(gdf_maxdims)
  integer(kind=size_length) :: isize,ioffs, ileng, i, j
  logical :: icont
  !
  if (islot(is).eq.code_gio_empty) then
    call gio_message(seve%e,rname,'Image slot is empty')
    error = .true.
    return
  elseif (islot(is).eq.code_gio_full) then
    call gio_message(seve%e,rname,'Image is not mapped')
    error = .true.
    return
  endif
  error = .false.
  !
  call gio_cont (is,ndim,blc,trc,iblc,itrc,isize,icont)
  if (isize.le.0) then
    call gio_message(seve%e,rname,'Requesting a zero length memory slot')
  endif
  !
  ! Do not allow to open in Read/Write old UV data files
  if (islot(is).ne.code_gio_reado) then
    if (abs(ivers(is)).eq.code_gdf_uvold) then
      call gio_message(seve%e,rname,'Old UV data files cannot be written')
      error = .true.
      return
    endif
  endif
  !
  ! Try to allocate a memory frame big enough
  if (icont) then
    call gio_gemsco (ms, is, blc, trc, addr, form, error)
    dimou(:) = itrc(:)-iblc(:)+1
  else
    if (islot(is).ne.code_gio_reado) then
      call gio_message(seve%e,rname,'Subset option not supported for '//  &
      'Write access')
      error = .true.
      return
    endif
    !
    ! Define smallest contiguous containing subset
    jblc(:) = iblc(:)
    jtrc(:) = itrc(:)
    do i=ndim,1,-1
      if (iblc(i).ne.itrc(i)) then
        do j=1,i-1
          jblc(j) = 1
          jtrc(j) = idims(j,is)
        enddo
      endif
    enddo
    dimin(:) = jtrc(:)-jblc(:)+1
    dimou(:) = itrc(:)-iblc(:)+1
    !
    ! Get virtual memory for the subset
    ioffs = 0
    do i=ndim,1,-1
      ioffs = ioffs*idims(i,is)+iblc(i)-1
    enddo
    ileng = isize
    if (form.eq.fmt_r8.or.form.eq.fmt_c4) then
      ileng = 2*isize
    elseif (form.eq.fmt_by) then
      ileng = (isize+3)/4
    else
      ileng = isize
    endif
    ileng = -ileng
    call gio_gmslot (ioffs,ileng,form,ms,isbig(is),istbl(is),error)
    if (error) return
    mslot(ms) = is
    ier = sic_getvm (isize,addr)
    if (ier.ne.1) goto 99
    maddr(1,ms) = addr
    maddr(2,ms) = addr+4*(isize-1)
    mleng(ms) = ileng
    !
    ! Get the continuous subset
    call gio_gemsco (ms_tmp, is, jblc, jtrc, addr_tmp, form, error)
    !
    ! Extract the subset
    ipo = gag_pointer(addr,memory)
    ipi = gag_pointer(addr_tmp,memory)
    !
    ! Good code...
    do i=1,ndim
      if (dimin(i).eq.dimou(i)) iblc(i) = 1
    enddo
    !
    if (form.eq.fmt_r8.or.form.eq.fmt_c4) then
      call gdf_sub8(iblc,dimin(1),dimin(2),dimin(3),dimin(4),memory(ipi),  &
                         dimou(1),dimou(2),dimou(3),dimou(4),memory(ipo))
    elseif (form.eq.fmt_by) then
      call gdf_sub1(iblc,dimin(1),dimin(2),dimin(3),dimin(4),memory(ipi),  &
                         dimou(1),dimou(2),dimou(3),dimou(4),memory(ipo))
    else
      call gdf_sub4(iblc,dimin(1),dimin(2),dimin(3),dimin(4),memory(ipi),  &
                         dimou(1),dimou(2),dimou(3),dimou(4),memory(ipo))
    endif
    !
    ! Free the temporary subset.
    ! Note that ISLOT(IS) = READO in this case
    call gio_frms (ms_tmp, error)
  endif
  ! Define memory slot format
  mform(ms) = form
  !
  ! Patch old UV data files
  if (abs(ivers(is)).eq.code_gdf_uvold) then
    call gio_message(seve%i,rname,'Patching old UV data weights')
    !
    ! If the array has been re-shaped for transposition, re-re-shape it
    if (dimou(1).eq.1 .and. dimou(3).ne.1) then
      dimou(1) = dimou(2)
      dimou(2) = dimou(3)
      dimou(3) = dimou(4)
      dimou(4) = 1
    endif
    ipo = gag_pointer(addr,memory)
    call patch_weight(ivers(is),memory(ipo),dimou(1),dimou(2),dimou(3),dimou(4))
  endif
  return
  !
99 call gio_message(seve%e,rname,'Memory allocation failure')
  mslot(ms) = code_gio_empty
  error = .true.
end subroutine gio_gems
!
subroutine gio_gemsco (ms, is, blc, trc, addr, form, error)
  use gio_dependencies_interfaces
  use gio_interfaces, except_this=>gio_gemsco
  use gildas_def
  use gio_image
  use gbl_message
  use gbl_format
  !---------------------------------------------------------------------
  ! @ private
  ! GDF
  !     GEt Memory Slot COntiguous
  !     Restricted version for contiguous subsets
  !---------------------------------------------------------------------
  integer, intent(out) :: ms                         ! Memory slot
  integer, intent(in)  :: is                         ! Image slot
  integer(kind=index_length), intent(in)  :: blc(gdf_maxdims)    ! Bottom left corner
  integer(kind=index_length), intent(in)  :: trc(gdf_maxdims)    ! Top right corner
  integer(kind=address_length), intent(out) :: addr  ! Returned address
  integer, intent(in)  :: form                       ! Image format
  logical, intent(out) :: error                      ! Flag
  ! Local
  character(len=*), parameter :: rname='GIO_GEMSCO'
  integer :: ier, ndim
  integer(kind=index_length) :: iblc(gdf_maxdims), itrc(gdf_maxdims)
  integer(kind=size_length) :: isize, ioffs, ileng, i
  logical :: icont
  !
  !!Print *,'FORM gio_gemsco ',form
  if (islot(is).eq.code_gio_empty) then
    call gio_message(seve%e,rname,'Image slot is empty')
    error = .true.
    return
  elseif (islot(is).eq.code_gio_full) then
    call gio_message(seve%e,rname,'Image is not mapped')
    error = .true.
    return
  endif
  error = .false.
  !
  call gio_cont (is,ndim,blc,trc,iblc,itrc,isize,icont)
  if (isize.le.0) then
    call gio_message(seve%e,rname,'Requesting a zero length memory slot')
  endif
  !
  ! Try to allocate a memory frame big enough
  if (icont) then
    ioffs = 0
    do i=ndim,1,-1
      ioffs = ioffs*idims(i,is)+iblc(i)-1
    enddo
    ileng = isize
    !
    ! Disk file
    if (ichan(is).ne.0) then
      call gio_gmslot (ioffs,ileng,form,ms,isbig(is),istbl(is),error)
      if (error) return
      mslot(ms) = is
      !
      if (form.eq.fmt_r8.or.form.eq.fmt_c4) then
        ileng = 2*isize
      elseif (form.eq.fmt_by) then
        ileng = (isize+3)/4
      else
        ileng = isize
      endif
      !
      call gio_mmslot (ioffs,ileng,form,ms,addr,error)
      if (error)  return
      !
      ! Virtual memory
    else
      ileng = -ileng
      call gio_gmslot (ioffs,ileng,form,ms,isbig(is),istbl(is),error)
      if (error) return
      mslot(ms) = is
      !
      ! Allocate what is needed, no less, no more (to 4 byte rouding)
      if (form.eq.fmt_r8.or.form.eq.fmt_c4) then
        ileng = 2*isize
      elseif (form.eq.fmt_by) then
        ileng = (isize+3)/4
      else
        ileng = isize
      endif
      ier = sic_getvm (ileng,addr)
      if (ier.ne.1) goto 99
      maddr(1,ms) = addr
      maddr(2,ms) = addr+4*(ileng-1)
      ! Negative value means "Virtual Memory"
      mleng(ms) = -ileng
    endif
    if (error) then
      mslot(ms) = code_gio_empty
      return
    else
      mblc(:,ms) = blc(:)
      mtrc(:,ms) = trc(:)
      msize(ms) = isize
      mcont(ms) = icont
    endif
  else
    call gio_message(seve%e,rname,'Subset option not yet supported')
    error = .true.
  endif
  ! Define memory slot format
  mform(ms) = form
  return
  !
99 call gio_message(seve%e,rname,'Memory allocation failure')
  mslot(ms) = code_gio_empty
  error = .true.
end subroutine gio_gemsco
!
subroutine gdf_sub1 (blc, n1,n2,n3,n4,in, m1,m2,m3,m4,out)
  use gildas_def
  !---------------------------------------------------------------------
  ! @ no-interface (type mismatch)
  !---------------------------------------------------------------------
  integer(kind=index_length) :: blc(4)                    !
  integer(kind=index_length) :: n1                        !
  integer(kind=index_length) :: n2                        !
  integer(kind=index_length) :: n3                        !
  integer(kind=index_length) :: n4                        !
  integer(kind=1) :: in(n1,n2,n3,n4)   !
  integer(kind=index_length) :: m1                        !
  integer(kind=index_length) :: m2                        !
  integer(kind=index_length) :: m3                        !
  integer(kind=index_length) :: m4                        !
  integer(kind=1) :: out(m1,m2,m3,m4)  !
  ! Local
  integer(kind=index_length) :: i1,i2,i3,i4
  integer(kind=index_length) :: j1,j2,j3,j4
  !
  i4 = blc(4)
  do j4=1,m4
    i3 = blc(3)
    do j3=1,m3
      i2 = blc(2)
      do j2=1,m2
        i1 = blc(1)
        do j1=1,m1
          out(j1,j2,j3,j4) = in(i1,i2,i3,i4)
          i1 = i1+1
        enddo
        i2 = i2
      enddo
      i3  = i3+1
    enddo
    i4 = i4+1
  enddo
end subroutine gdf_sub1
!
subroutine gdf_sub8 (blc, n1,n2,n3,n4,in, m1,m2,m3,m4,out)
  use gildas_def
  !---------------------------------------------------------------------
  ! @ no-interface (type mismatch)
  !---------------------------------------------------------------------
  integer(kind=index_length) :: blc(4)                 !
  integer(kind=index_length) :: n1                     !
  integer(kind=index_length) :: n2                     !
  integer(kind=index_length) :: n3                     !
  integer(kind=index_length) :: n4                     !
  real(8) :: in(n1,n2,n3,n4)        !
  integer(kind=index_length) :: m1                     !
  integer(kind=index_length) :: m2                     !
  integer(kind=index_length) :: m3                     !
  integer(kind=index_length) :: m4                     !
  real(8) :: out(m1,m2,m3,m4)       !
  ! Local
  integer(kind=index_length) :: i1,i2,i3,i4
  integer(kind=index_length) :: j1,j2,j3,j4
  !
  i4 = blc(4)
  do j4=1,m4
    i3 = blc(3)
    do j3=1,m3
      i2 = blc(2)
      do j2=1,m2
        i1 = blc(1)
        do j1=1,m1
          out(j1,j2,j3,j4) = in(i1,i2,i3,i4)
          i1 = i1+1
        enddo
        i2 = i2
      enddo
      i3  = i3+1
    enddo
    i4 = i4+1
  enddo
end subroutine gdf_sub8
!
subroutine gdf_sub4 (blc, n1,n2,n3,n4,in, m1,m2,m3,m4,out)
  use gildas_def
  !---------------------------------------------------------------------
  ! @ private
  !---------------------------------------------------------------------
  integer(kind=index_length) :: blc(4)                 !
  integer(kind=index_length) :: n1                     !
  integer(kind=index_length) :: n2                     !
  integer(kind=index_length) :: n3                     !
  integer(kind=index_length) :: n4                     !
  integer(4) :: in(n1,n2,n3,n4)     !
  integer(kind=index_length) :: m1                     !
  integer(kind=index_length) :: m2                     !
  integer(kind=index_length) :: m3                     !
  integer(kind=index_length) :: m4                     !
  integer(4) :: out(m1,m2,m3,m4)    !
  ! Local 
  integer(kind=index_length) :: i1,i2,i3,i4
  integer(kind=index_length) :: j1,j2,j3,j4
  !
  i4 = blc(4)
  do j4=1,m4
    i3 = blc(3)
    do j3=1,m3
      i2 = blc(2)
      do j2=1,m2
        i1 = blc(1)
        do j1=1,m1
          out(j1,j2,j3,j4) = in(i1,i2,i3,i4)
          i1 = i1+1
        enddo
        i2 = i2+1
      enddo
      i3  = i3+1
    enddo
    i4 = i4+1
  enddo
end subroutine gdf_sub4
!
subroutine gio_cont (is,ndim,blc,trc,iblc,itrc,isize,icont)
  use gio_interfaces, except_this=>gio_cont
  use gio_image
  !---------------------------------------------------------------------
  ! @ private
  ! GDF / GIO
  !     Determine if a slot is contiguous in memory
  !---------------------------------------------------------------------
  integer, intent(in)  :: is                         ! Image slot
  integer, intent(out) :: ndim                       ! Number of dimensions
  integer(kind=index_length), intent(in)  :: blc(:)  ! Bottom left corner
  integer(kind=index_length), intent(in)  :: trc(:)  ! Top right corner
  integer(kind=index_length), intent(out) :: iblc(:) ! Bottom left corner
  integer(kind=index_length), intent(out) :: itrc(:) ! Top right corner
  integer(kind=size_length), intent(out) :: isize    ! Size of memory region
  logical, intent(out) :: icont                      ! Contiguous flag
  ! Local
  integer(kind=index_length) :: i, j
  !
  isize = 1
  icont = .true.
  ndim = indim(is)
  do i=1,ndim
    if (blc(i).le.0) then
      iblc(i) = 1
    else
      iblc(i) = min(blc(i),idims(i,is))
    endif
    if (trc(i).le.0) then
      itrc(i) = idims(i,is)
    else
      itrc(i) = min(trc(i),idims(i,is))
      itrc(i) = max(iblc(i),itrc(i))
    endif
    isize = isize*(itrc(i)-iblc(i)+1)
  enddo
  do i=1,ndim-1
    if (iblc(i).ne.1 .or. itrc(i).ne.idims(i,is)) then
      do j=i+1,ndim
        if (iblc(j).ne.itrc(j)) then
          icont = .false.      ! Not contiguous
        endif
      enddo
    endif
  enddo
  do i=ndim+1,gdf_maxdims
    iblc(i) = 1
    itrc(i) = 1
  enddo
end subroutine gio_cont
!
subroutine gio_gmslot (offs, size, form, ms, big, stablo, error)
  use gio_dependencies_interfaces
  use gio_interfaces, except_this=> gio_gmslot
  use gio_image
  use gbl_message
  use gbl_format
  !---------------------------------------------------------------------
  ! @ private 
  ! GDF   Get a free memory slot.
  !---------------------------------------------------------------------
  integer(kind=size_length), intent(in)  :: offs          ! Offset from start of image, in "pixel"
  integer(kind=size_length), intent(inout)  :: size       ! Required size (in pixels), and allocated size (in WOrds)
  integer, intent(in)  :: form          ! Type of image
  integer, intent(out) :: ms            ! Memory slot number
  integer, intent(in)  :: big           ! Are big blocks being used ?
  integer, intent(in)  :: stablo        ! Number of Starting Blocks
  logical, intent(out) :: error         ! Logical error flag
  ! Local
  character(len=*), parameter :: rname='GIO_GMSLOT'
  integer :: i, freems, sizbuf
  integer(kind=record_length) :: ikbfi,ikbla
  integer(kind=size_length) :: ioffs, isize
  !
  !!Print *,'FORM gdf_gmslot ',form
  !
  if (form.eq.fmt_r8.or.form.eq.fmt_c4) then
    isize = 8*size
    ioffs = 8*offs
  elseif (form.eq.fmt_by) then
    isize = size
    ioffs = offs
  else
    isize = 4*size
    ioffs = 4*offs
  endif
  !
  ! Compute length, taking into account header, offset and block size
  if (size.gt.0) then
    size = isize/4 ! In words...
    call gio_buffs_vm(big,ioffs,size,ikbfi,ikbla,sizbuf,stablo)
  endif
  !
  ! OK, now get a free frame-ID and virtual memory
  freems = 0
  ms = 0
  do i=1,mms
    if (mslot(i).eq.code_gio_empty) then
      ! Enough space in a previously freed frame
      if (size.gt.0) then
        if (mleng(i).ge.size) then
          if (ms.ne.0) then
            if (mleng(ms).gt.mleng(i)) ms = i
          else
            ms = i
          endif
        else
          if (freems.eq.0) freems = i
        endif
      else
        if (freems.eq.0) freems = i
      endif
    endif
  enddo
  if (ms.ne.0) return
  !
  ! No free frame large enough, or virtual memory
  if (freems.eq.0) then
    call gio_message(seve%e,rname,'Too many memory frames')
    error = .true.
  else
    ms = freems
    maddr(1,ms) = 0
    maddr(2,ms) = 0
    mleng(ms) = 0
  endif
end subroutine gio_gmslot
!
subroutine gio_mmslot (offs,leng,form,ms,addr,error)
  use gio_dependencies_interfaces
  use gio_interfaces, except_this=>gio_mmslot
  use gildas_def
  use gio_image
  use gbl_message
  use gbl_format
  !---------------------------------------------------------------------
  ! @ private
  ! GDF / GIO
  !             Map Memory SLOT
  !---------------------------------------------------------------------
  integer(kind=size_length), intent(in)  :: offs     ! Offset from start of image, in "pixel"
  integer(kind=size_length), intent(in)  :: leng     ! Required size (in Words)
  integer, intent(in)  :: form                       ! Type of image
  integer, intent(in)  :: ms                         ! Memory slot number
  integer(kind=address_length), intent(out) :: addr  ! Returned address
  logical, intent(out) :: error                      ! Logical error flag
  ! Global
  integer(kind=4) :: gdf_conv
  include 'gbl_memory.inc'
  character(len=*), parameter :: rname='GIO_MMSLOT'
  ! Local
  integer(kind=address_length) :: ip
  integer(kind=record_length) :: i,ikbfi,ikbla,lastbl
  integer(kind=size_length) :: ioffs,size
  integer :: ier, is
  integer(kind=4) :: buffer(lenbig), sizbuf
  character(len=message_length) :: mess
  !
  error = .true.
  if (form.eq.fmt_r8.or.form.eq.fmt_c4) then
    ioffs = 8*offs
  elseif (form.eq.fmt_by) then
    ioffs = offs
  else
    ioffs = 4*offs
  endif
  !
  is = mslot(ms)
  size = leng
  call gio_buffs_vm(isbig(is),ioffs,size,ikbfi,ikbla,sizbuf,istbl(is))
  !
  ! Get some virtual memory
  ier = sic_getvm (size,addr)
  if (ier.ne.1) goto 99
  !
  open(unit=iunit(is),file=cname(is),status='OLD',form='UNFORMATTED',  &
       access='DIRECT',recl=sizbuf*facunf,iostat=ier)
  !
  ! Do not read beyond written parts
  lastbl = imblock(is)/isbig(is) 
  ikbfi = max(1,min(ikbfi,lastbl)) 
  ikbla = min(ikbla,lastbl) 
  !
  maddr(1,ms) = addr
  maddr(2,ms) = addr+4*size
  mleng(ms) = size
  moffs(ms) = ioffs
  !
  ! The new offset from the first read block is
  !       MOFFS(MS) = (IKBFI-1)*4*SIZBUF
  !
  ! Read file
  ip = gag_pointer(addr,memory)
  if (iform(is).eq.form) then
    !
    ! Here, we could do a true memory mapping instead of reading
    do i=ikbfi,ikbla
      ier = gio_riox (iunit(mslot(ms)),i,memory(ip),sizbuf)
      if (ier.ne.0) then
        write(mess,*) 'READ error #1 on slot ', mslot(ms),' Block ',i
        call gio_message(seve%e,rname,mess)
        call putios(seve%e,rname,ier)
        write(mess,*) ' Range ',ikbfi,ikbla,'  End ',imblock(is),' Sizbuf ',sizbuf
        call gio_message(seve%e,rname,mess)
        return
      endif
      ip = ip+sizbuf
    enddo
  else
    !
    ! Here we must convert the data, so a read is required...
    do i=ikbfi,ikbla
      ier = gio_riox (iunit(mslot(ms)),i,buffer,sizbuf)
      if (ier.ne.0) then
        write(mess,*) 'READ error #2 on slot ', mslot(ms),' Block ',i
        call gio_message(seve%e,rname,mess)
        call putios(seve%e,rname,ier)
        write(mess,*) ' Range ',ikbfi,ikbla,'  End ',imblock(is),' Sizbuf ',sizbuf
        call gio_message(seve%e,rname,mess)
        return
      endif
      if (i.eq.1) then ! First big buffer may contain header ....
        call r4tor4 (buffer,memory(ip),istbl(is)*lenbuf)
        ier = gdf_conv(buffer(1+istbl(is)*lenbuf),memory(ip+istbl(is)*lenbuf), &
        &    sizbuf-istbl(is)*lenbuf,form,iform(is))
      else
        ier = gdf_conv (buffer,memory(ip),sizbuf,form,iform(is))
      endif
      if (ier.ne.1) goto 98
      ip = ip+sizbuf
    enddo
  endif
  close (unit=iunit(is))
  !
  ! Compute address
  ioffs = mod(ioffs,4*sizbuf)
  addr = addr+ioffs
  error = .false.
  return
  !
98 continue 
  write(mess,*) 'Unsupported conversion from ',iform(is),' to ',form
  call gio_message(seve%e,rname,mess)
  call free_vm (size,addr)
  close (unit=iunit(is))
  return
99 call gio_message(seve%e,rname,'Memory allocation failure')
  mslot(ms) = code_gio_empty
  error = .true.
end subroutine gio_mmslot
!
subroutine gio_frms (ms,error)
  use gio_dependencies_interfaces
  use gio_interfaces, except_this=>gio_frms
  use gio_image
  use gbl_message
  !---------------------------------------------------------------------
  ! @ public
  ! GDF   FRee Memory Slot
  !
  ! In case of success, error flag (T/F) is preserved on return. Code is
  ! insensitive to error=T on input.
  !---------------------------------------------------------------------
  integer, intent(in)    :: ms     ! Memory slot
  logical, intent(inout) :: error  ! error flag
  ! Local
  character(len=*), parameter :: rname='GIO_FRMS'
  integer :: is
  !
  is = mslot(ms)
  if (is.eq.code_gio_empty) then
    call gio_message(seve%e,rname,'Memory slot is empty')
    error = .true.
    return
  endif
  !
  ! Contiguous slot
  if (mcont(ms)) then
    !
    ! If virtual memory, free it
    if (mleng(ms).lt.0) then
      !!            Print *,'FREE_VM Virtual memory slot'
      call free_vm(-mleng(ms),maddr(1,ms))
    else
      !!            Print *,'Disk memory slot'
      !
      ! Write disk file
      call gio_wmslot (ms,iunit(is),error)
    endif
    !
  else
    ! Not contiguous Read-Only: just free memory if needed
    if (islot(is).lt.code_gio_write) then
      !!            Print *,'FREE_VM Read-Only  memory slot ',
      !!     $           islot(is),write
      call free_vm (mleng(ms),maddr(1,ms))
    else if (islot(is).ne.code_gio_reade) then
      ! Not contiguous, DUMPI or DUMPE : update line by line
      call gio_message(seve%e,rname,'Inconsistent state of GDF library')
      call gio_message(seve%e,rname,'Non-contiguous WRITE slot')
      error = .true.
    endif
  endif
  !
  ! In all cases, set the memory slot to empty state...
  maddr(1,ms) = 0
  maddr(2,ms) = 0
  mleng(ms) = 0
  mslot(ms) = code_gio_empty
end subroutine gio_frms
!
subroutine gio_wmslot (ms,lun,error)
  use gio_dependencies_interfaces
  use gio_interfaces, except_this=>gio_wmslot
  use gildas_def
  use gio_image
  use gbl_message
  use gbl_format
  !---------------------------------------------------------------------
  ! @ private
  ! Write Memory SLOT.
  ! Direct access solution, contiguous data only.
  !
  ! In case of success, error flag (T/F) is preserved on return. Code is
  ! insensitive to error=T on input.
  !---------------------------------------------------------------------
  integer, intent(in)    :: ms     ! Memory slot number
  integer, intent(in)    :: lun    ! Logical Unit Number
  logical, intent(inout) :: error  ! Logical error flag
  ! Global
  integer(kind=4) :: gdf_conv
  include 'gbl_memory.inc'
  character(len=*), parameter :: rname='GIO_WMSLOT'
  ! Local
  integer(kind=4) :: ier, is, buffer(lenbig), sizbuf, lasbuf, form
  integer(kind=record_length) :: i,ikbfi,ikbla
  integer(kind=size_length) :: ioffs, ileft 
  integer(kind=4) :: koffs
  integer(kind=address_length) :: ip
  !
  is = mslot(ms)
  !
  ! Do nothing for READE (External Memory, Read-Only
  if (islot(is).eq.code_gio_reade) return
  !
  ! Only Free Virtual Memory for Read-Only and Full slots
  if (islot(is).lt.code_gio_write) then
    call free_vm (mleng(ms),maddr(1,ms))
    return
  endif
  !
  form = mform(ms)
  !
  ! This should be redone in a different way, like in GDF_RMSLO, by
  !  - keeping MOFFS(MS) as the offset in Byte from the data start
  !  - Reading the header blocks
  !  - Copying the end part of the first block to the beginning of the data      (READ)
  !    or
  !    copying the beginning of the data to the end part of the first block,
  !    and writing the first block     (WRITE)
  !  - Reading the intermediate areas (READ) or Writing them (WRITE)
  !  - Reading the last block
  !  - Copying the beginning of the last block to the end of the data      (READ)
  !      or
  !    copying the end of the data to the first part of the last block,
  !    and writing the last block                                         (WRITE)
  !
  ! Let us do it only for DUMPE to debug...
  if (islot(is).eq.code_gio_dumpe) then
    !
    ! DUMPE State, i.e. a slot which is associated to a user-handled
    ! memory area. There is safeguard around...
    !
    ioffs = moffs(ms)/4+istbl(is)*lenbuf ! Offset in Word in file
    sizbuf = isbig(is) * lenbuf
    koffs = mod(ioffs,sizbuf)  ! Offset in Word from first buffer!
    ikbfi = ioffs/sizbuf + 1
    ikbla = (ioffs+mleng(ms)+sizbuf-1)/sizbuf  ! Last buffer address
    !
    open(unit=lun,file=cname(is),status='OLD',form='UNFORMATTED',  &
         access='DIRECT',recl=sizbuf*facunf,iostat=ier)
    if (ier.ne.0) then
      Print *,'Opened in DUMPE ',ier,sizbuf,lenbuf,isbig(is)
      Print *,'DUMPE -- WMSLOT Iform ',iform(is), ' MFORM ',mform(ms)
      goto 90
    endif
    ip = gag_pointer(maddr(1,ms),memory)
    !
    ! Write file
    ! Native format
    if (iform(is).eq.mform(ms)) then
      ileft = mleng(ms)
      do i=ikbfi,ikbla-1
        if (i.eq.ikbfi) then
        ! Could be simplified by if (i.eq.ikbfi .and. koffs.gt.0) then
          if (koffs.gt.0) then 
            ier = gio_riox (lun,i,buffer,sizbuf)
            if (ier.ne.0) then
              Print *,'DUMPE -- NATIVE Buffer ',i,ikbfi,ikbla,' Read IER ',ier
              goto 90
            endif
          endif
          call r4tor4 (memory(ip),buffer(1+koffs),sizbuf-koffs)
          ier = gio_wiox (lun,i,buffer,sizbuf)
          if (ier.ne.0) then
            Print *,'DUMPE -- NATIVE Buffer ',i,ikbfi,ikbla,' Write IER ',ier,sizbuf
            goto 90
          endif
          ip = ip+sizbuf-koffs
          ileft = ileft-sizbuf+koffs
        else
          ier = gio_wiox (lun,i,memory(ip),sizbuf)
          if (ier.ne.0) then 
            Print *,'DUMPE -- Direct write ',i,ikbfi,ikbla,' Write IER ',ier
            goto 90
          endif
          ip = ip+sizbuf
          ileft = ileft-sizbuf
        endif
        iwblock(is) = i*isbig(is)
        imblock(is) = max(iwblock(is),imblock(is))
      enddo
      !
      ! Last buffer may be incomplete
      if (ikbla.le.imblock(is)/isbig(is)) then
        ier = gio_riox(lun,ikbla,buffer,sizbuf)
        if (ier.ne.0) then
          Print *,'DUMPE - NATIVE Buffer ',i,ikbfi,ikbla,' Read IER ',ier,sizbuf
          Print *,'IMBLOCk ',imblock(is),' StartBlock ',istbl(is)
          goto 90
        endif
      endif
      if (ikbla.eq.ikbfi) then
        call r4tor4(memory(ip),buffer(koffs+1),ileft)
      else
        call r4tor4(memory(ip),buffer,ileft)
      endif
      ier = gio_wiox(lun,ikbla,buffer,sizbuf)
      if (ier.ne.0) then
        Print *,'DUMPE -- Last Buffer IKBLA ',ikbla,' Write IER ',ier
        goto 90
      endif
      iwblock(is) = i*isbig(is)
      imblock(is) = max(iwblock(is),imblock(is))
    else
      ! As above, but with format Conversion
      !!Print *,'CONVERT ',iform(is), form
      ileft = mleng(ms)
      do i=ikbfi,ikbla-1
        if (i.eq.ikbfi) then
          ier = gio_riox (lun,i,buffer,sizbuf)
          if (ier.ne.0) goto 90
          ier = gdf_conv(memory(ip),buffer(1+koffs),sizbuf-koffs,form,iform(is))
          if (ier.ne.1) goto 80
          ier = gio_wiox (lun,i,buffer,sizbuf)
          if (ier.ne.0) goto 90
          ip = ip+sizbuf-koffs
          ileft = ileft-sizbuf+koffs
        else
          ier = gdf_conv(memory(ip),buffer,sizbuf,form,iform(is))
          if (ier.ne.1) goto 80
          ier = gio_wiox (lun,i,buffer,sizbuf)
          if (ier.ne.0) goto 90
          ip = ip+sizbuf
          ileft = ileft-sizbuf
        endif
      enddo
      ier = gio_riox(lun,ikbla,buffer,sizbuf)
      if (ikbla.eq.ikbfi) then
        ier = gdf_conv(memory(ip),buffer(koffs+1),ileft,form,iform(is))
      else
        ier = gdf_conv(memory(ip),buffer,ileft,form,iform(is))
      endif
      ier = gio_wiox(lun,ikbla,buffer,sizbuf)
      if (ier.ne.0) goto 90
    endif
  else !! if (islot(is).eq.code_gio_dumpi) then
    !
    ! WRITE, DUMPI state: Write the file
    !
    ! Here, the MOFFS(MS) pointer and MLENG(MS) size take into account the
    ! rounding to an integer number of blocks.
    !
    ! So we use a different system to read and write.
    !
    sizbuf = isbig(is) * lenbuf
    if (isbig(is).ne.1) then
      ikbfi = moffs(ms)/4/sizbuf + 1
      !!          Print *,'Big ',4*LENBIG*(IKBFI-1)+512, moffs(ms)
      ikbla = ikbfi + (mleng(ms)-1)/sizbuf ! Last buffer address
    else
      ikbfi = moffs(ms)/4/sizbuf + 1 + istbl(is)   ! First buffer address
      !!          Print *,'Small ',4*LENBUF*(IKBFI-1), moffs(ms)
      ikbla = ikbfi + (mleng(ms)-1)/sizbuf ! Last buffer address
    endif
    !
    open(unit=iunit(is),file=cname(is),status='OLD',form='UNFORMATTED',  &
         access='DIRECT',recl=sizbuf*facunf,iostat=ier)
    if (ier.ne.0) then
      Print *,'Opened in DUMPI ',islot(is),code_gio_dumpi
      goto 90
    endif
    !
    ip = gag_pointer(maddr(1,ms),memory)
    !
    ! Write file (Version OK for WRITE and DUMPI)
    ! Code should now be correct even for DUMPE
    !
    ! Well, now the test differs whether it is a "big" or "small" block...
    !!Print *,'DUMPI -- WMSLOT Iform ',iform(is), ' MFORM ',mform(ms)
    !!Print *,'DUMPI -- MLENG ',mleng(ms), ' IKB ',ikbfi,ikbla
    if (iform(is).eq.mform(ms)) then
      !!Print *,'NATIVE '
      if (isbig(is).ne.1) then
        do i=ikbfi,ikbla-1
          ! Here we read the Header Buffers...
          if (i.eq.1) then
            ier = gio_riox (lun,i,buffer,lenbuf*istbl(is))  ! Just read the header blocks
            if (ier.ne.0) goto 90
            call r4tor4 (buffer,memory(ip),lenbuf*istbl(is))
          endif
          ! and write the "big" buffer
          ier = gio_wiox (lun,i,memory(ip),sizbuf)
          if (ier.ne.0) goto 90
          ip = ip+sizbuf
        enddo
        !
        ! Last buffer is special
        lasbuf = mod(mleng(ms),sizbuf)
        if (lasbuf.eq.0) lasbuf = sizbuf
        if (ikbla.eq.1) then
          ier = gio_riox (lun,ikbla,buffer,lenbuf*istbl(is))
          if (ier.ne.0) goto 90
          call r4tor4 (buffer,memory(ip),lenbuf*istbl(is))
        endif
        ier = gio_wiox (lun,ikbla,memory(ip),lasbuf)
!!        Print *,'Last buffer ',ier,lasbuf
!!        call r4tor4(memory(ip),buffer,lasbuf)
!!        Print *,'Last buffer ',buffer(1:lasbuf)
        if (ier.ne.0) goto 90
      else
        !
        ! Header blocks cannot be present here
        do i=ikbfi,ikbla-1
          if (ikbfi.le.istbl(is)) then
            print *,'Major programming error IKBFI ',ikbfi,  &
            & ' < istbl(is) ',istbl(is)
            STOP
          endif
          ! Write the "small" buffer
          ier = gio_wiox (lun,i,memory(ip),sizbuf)
          if (ier.ne.0) goto 90
          ip = ip+sizbuf
        enddo
        !
        ! Last buffer is special
        lasbuf = mod(mleng(ms),sizbuf)
        if (lasbuf.eq.0) lasbuf = sizbuf
        ier = gio_wiox (lun,ikbla,memory(ip),lasbuf)
        if (ier.ne.0) goto 90
      endif
      !
    else
      ! With conversion
      Print *,'CONVERT ',iform(is), mform(ms), isbig(is)
      if (isbig(is).ne.1) then
        do i=ikbfi,ikbla-1
          ! Here we read the Header Buffer...
          if (i.eq.1) then
            ier = gio_riox (lun,i,buffer,lenbuf*istbl(is))
            if (ier.ne.0) goto 90
            ier = gdf_conv(memory(ip+lenbuf*istbl(is)), &
          &     buffer(1+lenbuf*istbl(is)),sizbuf-lenbuf*istbl(is),  &
                iform(is),mform(ms))
          else
            ier = gdf_conv(memory(ip),buffer,sizbuf,iform(is),mform(ms))
          endif
          if (ier.ne.1) goto 80
          ! and write the "big" buffer
          ier = gio_wiox (lun,i,buffer,sizbuf)
          if (ier.ne.0) goto 90
          ip = ip+sizbuf
        enddo
        !
        ! Last buffer is special: length may be shorter
        lasbuf = mod(mleng(ms),sizbuf)
        if (lasbuf.eq.0) lasbuf = sizbuf
        if (ikbla.eq.1) then
          ier = gio_riox (lun,ikbla,buffer,lenbuf*istbl(is))
          if (ier.ne.0) goto 90
          ier = gdf_conv(memory(ip+lenbuf*istbl(is)), &
          &     buffer(1+lenbuf*istbl(is)),lasbuf-lenbuf*istbl(is),  &
                iform(is),mform(ms))
        else
          ier = gdf_conv(memory(ip),buffer,lasbuf,iform(is),mform(ms))
        endif
        if (ier.ne.1) goto 80
        ier = gio_wiox (lun,ikbla,buffer,lasbuf)
        if (ier.ne.0) goto 90
      else
        !
        ! Header blocks cannot be present here
        do i=ikbfi,ikbla-1
          if (ikbfi.le.istbl(is)) then
            print *,'Major programming error IKBFI ',ikbfi,  &
            & ' < istbl(is) ',istbl(is)
            STOP
          endif
          ier = gdf_conv(memory(ip),buffer,sizbuf,iform(is),mform(ms))
          if (ier.ne.1) goto 80
          ! Write the "small" buffer
          ier = gio_wiox (lun,i,buffer,sizbuf)
          if (ier.ne.0) goto 90
          ip = ip+sizbuf
        enddo
        !
        ! Last buffer is special: length may be shorter
        lasbuf = mod(mleng(ms),sizbuf)
        if (lasbuf.eq.0) lasbuf = sizbuf
        ier = gdf_conv(memory(ip),buffer,lasbuf,iform(is),mform(ms))
        if (ier.ne.1) goto 80
        ier = gio_wiox (lun,ikbla,buffer,lasbuf)
        if (ier.ne.0) goto 90
      endif
    endif
  endif                        !
  goto 100
  !
  ! Free virtual memory
80 call gio_message(seve%e,rname,'Output conversion error in data')
  Print *,iform(is),mform(ms),ier
  error = .true.
  goto 100
  !
90 call gio_message(seve%e,rname,'Write error in data')
  call putios(seve%e,rname,ier)
  Print *,'Blocks ',irblock(is),iwblock(is),imblock(is)
  Print *,'OFFSETS ',koffs,ileft
  error = .true.
  goto 100
  !
100 continue
  close (unit=iunit(is))
  !
  ! Free Virtual memory if allocated by the Image Library
  !
  !!      Print *,'Slot Status ',islot(is),write,dumpi
  if (islot(is).eq.code_gio_write) then
    !!         Print *,'FREE_VM Freeing memory '
    call free_vm (mleng(ms),maddr(1,ms))
  endif
end subroutine gio_wmslot
!
subroutine gio_buffs_vm(big,ioffs,size,ikbfi,ikbla,sizbuf,stablo)
  use gio_interfaces, except_this=>gio_buffs_vm
  use gildas_def
  use gio_image
  !---------------------------------------------------------------------
  ! @ private
  !---------------------------------------------------------------------
  integer(kind=4), intent(in) :: big ! Blocking factor
  integer(kind=size_length),   intent(inout) :: ioffs   ! Memory offset
  integer(kind=size_length),   intent(inout) :: size    ! Effective size in words
  integer(kind=record_length), intent(out)   :: ikbfi   ! First block
  integer(kind=record_length), intent(out)   :: ikbla   ! Last block
  integer(kind=4),             intent(out)   :: sizbuf  ! Buffer Size in words (output)
  integer(kind=4),             intent(in)    :: stablo  ! Number of Starting Blocks
  !
  if (big.ne.1) then
    ! Note that first BIG block is read
    ioffs = ioffs+4*stablo*lenbuf ! Add header small buffers
    sizbuf = lenbuf*big
    ikbfi = ioffs/4/sizbuf + 1             ! First BIG block
    ikbla = (ioffs/4+size-1)/sizbuf + 1    ! Last BIG block
    size = sizbuf*(ikbla-ikbfi+1)          ! In words
  else
    ! Note that the Header Blocks are skipped
    ikbfi = ioffs/4/lenbuf + 1 + stablo              ! First buffer address
    ikbla = (ioffs/4+size-1)/lenbuf + 1 + stablo     ! Last buffer address
    size = (ikbla-ikbfi+1)*lenbuf
    sizbuf = lenbuf
  endif
end subroutine gio_buffs_vm
!
subroutine gio_umps (ms,error)
  use gio_interfaces, except_this=>gio_umps
  use gio_image
  use gbl_message
  !---------------------------------------------------------------------
  ! @ private
  ! GDF   UPdate Memory Slot
  !             Write it to file if needed
  !
  ! THIS ROUTINE IS NOW OBSOLETE (Apr 2014)
  ! and the code code_gdf_dumpi  also
  !---------------------------------------------------------------------
  integer, intent(in)  :: ms                     ! Memory slot
  logical, intent(out) :: error                  ! Error flag
  !
  character(len=*), parameter :: rname='GIO_UPMS'
  ! Local
  integer :: is,jslot
  !
  is = mslot(ms)
  if (is.eq.code_gio_empty) then
    call gio_message(seve%e,rname,'Memory slot is empty')
    error = .true.
    return
  endif
  error = .false.
  !
  ! Contiguous slot
  if (mcont(ms)) then
    !
    ! If virtual memory, free it
    if (mleng(ms).lt.0) then
      call gio_message(seve%e,rname,'Virtual Memory slot cannot be '//  &
      'updated')
      error = .true.
      return
    else
      if (mapped(is)) then
        return
      else
        !
        ! Write disk file
        jslot = islot(is)
        islot(is) = code_gio_dumpi
        call gio_wmslot (ms,iunit(is),error)
        maddr(1,ms) = 0
        maddr(2,ms) = 0
        mleng(ms) = 0
        mslot(ms) = code_gio_empty
        ! Restore slot status
        islot(is) = jslot
      endif
    endif
    !
  else
    error = .true.
    ! Not contiguous Read-Only:
    if (islot(is).lt.code_gio_write) then
      call gio_message(seve%e,rname,'Read-0nly Memory slot cannot be '//  &
      'updated')
    else
      ! Not contiguous : update line by line
      call gio_message(seve%e,rname,'Inconsistent state of GDF library')
      call gio_message(seve%e,rname,'Non-contiguous WRITE slot')
    endif
  endif
end subroutine gio_umps
!
subroutine gio_zams (ms,error)
  use gio_interfaces, except_this=>gio_zams
  use gio_image
  use gbl_message
  !---------------------------------------------------------------------
  ! @ private
  ! GDF   ZAp Memory Slot
  !                     Just delete it, don't do anything else
  !---------------------------------------------------------------------
  integer, intent(in)  :: ms                     ! Memory slot
  logical, intent(out) :: error                  ! Error flag
  character(len=*), parameter :: rname='GIO_ZAMS'
  ! Local
  integer :: is
  !
  is = mslot(ms)
  if (is.eq.code_gio_empty) then
    call gio_message(seve%e,rname,'Memory slot is empty')
    error = .true.
    return
  endif
  !
  maddr(1,ms) = 0
  maddr(2,ms) = 0
  mleng(ms) = 0
  mslot(ms) = code_gio_empty
end subroutine gio_zams
!
subroutine patch_weight(icode,uv,nx,ny,nz,nt)
  use gio_interfaces
  use gio_params
  !---------------------------------------------------------------------
  ! @ no-interface
  ! Patch UV data weights for old data
  !---------------------------------------------------------------------
  integer, intent(in) :: icode      ! Data code > 0 means UVT order, < 0 means TUV order
  integer(kind=index_length), intent(in) :: nx                     !
  integer(kind=index_length), intent(in) :: ny                     !
  integer(kind=index_length), intent(in) :: nz                     !
  integer(kind=index_length), intent(in) :: nt                     !
  real, intent(inout) :: uv(nx,ny,nz,nt)        !
  ! Local
  integer(kind=index_length) :: i,j,k,l
  !
  !!      PRINT *,'icode ',ICODE
  !!      READ(5,*) ICODE
  if (icode.gt.0) then
    do l=1,nt
      do k=1,nz
        do j=1,ny
          do i=10,nx,3
            uv(i,j,k,l) = 2.0*uv(i,j,k,l)
          enddo
        enddo
      enddo
    enddo
  elseif  (icode.lt.0) then
    do l=1,nt
      do k=1,nz
        do j=10,ny,3
          do i=1,nx
            uv(i,j,k,l) = 2.0*uv(i,j,k,l)
          enddo
        enddo
      enddo
    enddo
  endif
end subroutine patch_weight
