subroutine stokes_comm(line,error)
  use image_def
  use gkernel_interfaces
  use gbl_message
  use clean_arrays
  use imager_interfaces, except_this => stokes_comm
  !---------------------------------------------------------------------
  ! @ private
  !
  ! IMAGER
  !   Support for command
  !
  ! STOKES Value [/FILE FileIn FileOut]
  !
  ! Extract a Polarization state from a UV table
  !
  !---------------------------------------------------------------------
  character(len=*) :: line
  logical error
  !
  character(len=*), parameter :: rname='STOKES'
  integer, parameter :: o_file=1
  !
  character(len=filename_length) :: nami,namo
  character(len=12) :: mystoke
  integer :: n, istoke
  type (gildas) :: hin
  logical :: err
  !
  error = .false.
  call sic_ke(line,0,1,mystoke,n,.true.,error)
  if (error) return
  !
  ! Scan the requested polarization code
  if (mystoke.eq.'NONE') then
    istoke = code_stokes_none
  elseif (mystoke.eq.'ALL') then
    istoke = code_stokes_all
  else
    call gdf_stokes_code(mystoke,istoke,error)
    if (error) then 
      call map_message(seve%e,rname,'Invalid Stokes '//mystoke)
      error = .true.
      return
    endif
  endif
  !
  if (sic_present(o_file,0)) then
    call sic_ch(line,o_file,1,nami,n,.true.,error)
    if (error) return
    call sic_ch(line,o_file,2,namo,n,.true.,error)
    if (error) return
    call sub_splitpolar (nami,namo,mystoke,hin,error)  
    call gdf_close_image(hin,err)
  else
    call sub_splitpolar_mem (mystoke,huv,error)
  endif
  !
end subroutine stokes_comm
!<FF>
subroutine sub_splitpolar(nami,namo,mystoke,hin,error)
  use image_def
  use gkernel_interfaces
  use gbl_message
  use imager_interfaces, except_this => sub_splitpolar
  !
  ! @ private
  !
  character(len=*), intent(inout) :: nami  ! Input file name
  character(len=*), intent(inout) :: namo  ! Output file name
  character(len=*), intent(in) :: mystoke  ! Desired Stoke parameter
  type (gildas), intent(inout) :: hin
  logical, intent(out) :: error
  !
  character(len=*), parameter :: rname='STOKES'
  type (gildas) :: hou
  real(kind=4), allocatable :: din(:,:), dou(:,:)
  !
  character(len=message_length) :: mess
  !
  integer i, j, k, istoke, ivisi, is, iv, jv, ier, ipara
  integer astoke(4)
  integer nstok, natom, nlead, nchan, next
  logical extract, doit
  integer intrail, ontrail, iend, oend
  integer :: kv, iloop, nblock, nvisi, mblock, multi
  integer :: isign=1    ! This is the correct sign for Parallactic Angle
  integer :: iextract  
  !
  error = .false.
  !
  extract = .false.
  !
  ! Scan the requested polarization code
  if (mystoke.eq.'NONE') then
    istoke = code_stokes_none
  elseif (mystoke.eq.'ALL') then
    istoke = code_stokes_all
  else
    call gdf_stokes_code(mystoke,istoke,error)
    if (error) then
      call map_message(seve%e,rname,'Invalid Stokes '//mystoke)
      error = .true.
      return
    endif
  endif
  !
  ! Read Header of a sorted, UV table
  call gildas_null(hin, type= 'UVT')
  call sic_parsef (nami,hin%file,' ','.uvt')
  call gdf_read_header (hin,error)
  if (error) return
  !
  ipara = hin%gil%column_pointer(code_uvt_para)
  ! Test for debug
  call sic_get_inte('SIGN_PARA',isign,error)
  if (isign.ne.1) Print *,'Using ISIGN ',ISIGN
  !
  !
  call gildas_null(hou, type='UVT')
  call gdf_copy_header (hin, hou, error)
  call sic_parsef (namo,hou%file,'  ','.uvt')
  !
  ! Define the Output Stokes parameter value
  hou%gil%nstokes = 1
  hou%gil%order = istoke           ! Unless it is "ANY" - will be changed later
  !
  call gdf_nitems('SPACE_GILDAS',nblock,hin%gil%dim(1))
  nblock = min(nblock,hin%gil%dim(2))
  !
  ! Check Random Frequency / Stokes axis
  if (hin%gil%nfreq.ne.0) then
    call map_message(seve%i,rname,'Random Frequency Axis case ')
    !
    nstok = 1
    astoke(1) = hin%gil%stokes(1)
    do i=2,hin%gil%nfreq
      k = 0
      do j=1,nstok
        if (astoke(j).eq.hin%gil%stokes(i)) then
          k = j
          exit
        endif
      enddo
      if (k.eq.0) then
        nstok = nstok+1
        astoke(nstok) = hin%gil%stokes(i)
      endif
    enddo
    !! Print *,'Found ',nstok,' Stokes of values ',astoke(1:nstok)
    !
    natom = hin%gil%natom
    nchan = hin%gil%nchan
    nlead = hin%gil%nlead
    intrail = hin%gil%ntrail
    ontrail = intrail
    iend = hin%gil%dim(1)
    !
    if (nstok.eq.1) then
      doit = .false.
      if (istoke.eq.astoke(1) .or. istoke.eq.0) then
        doit = .true.
      else if (istoke.ge.code_stokes_i .or. istoke.eq.code_stokes_none &
        .or. istoke.eq.code_stokes_all) then
        if ( (astoke(1).eq.code_stokes_hh) .or. (astoke(1).eq.code_stokes_vv) ) doit = .true.
        if ( (astoke(1).eq.code_stokes_ll) .or. (astoke(1).eq.code_stokes_rr) ) doit = .true.
        if ( (astoke(1).eq.code_stokes_xx) .or. (astoke(1).eq.code_stokes_yy) ) doit = .true.
        if ( (astoke(1).eq.code_stokes_i) ) doit = .true.
      endif
      !
      if (doit) then
        hou%gil%stokes(:) = istoke  ! Change the Stokes information
        !
        ! OK copy the whole stuff...
        allocate (din(hin%gil%dim(1),nblock),stat=ier)
        if (ier.ne.0) then
          call map_message(seve%e,rname,'Memory allocation error ')
          error = .true.
          return
        endif
        !
        hin%blc = 0
        hin%trc = 0
        hou%blc = 0
        hou%trc = 0
        call gdf_create_image(hou,error)
        if (error) return
        !
        call map_message(seve%i,rname,'Replicating UV table ')
        do iloop = 1,hin%gil%dim(2),nblock
          hin%blc(2) = iloop
          hin%trc(2) = min(iloop+nblock-1,hin%gil%dim(2))
          hou%blc(2) = iloop
          hou%trc(2) = hin%trc(2)
          call gdf_read_data (hin,din,error)
          if (error) return
          call gdf_write_data (hou, din, error)
          if (error) return
        enddo
        call gdf_close_image(hou,error)
      else
        call map_message(seve%i,rname,'Polar '//mystoke// &
        ' does not match '//gdf_stokes_name(astoke(1)) )
        error = .true.
      endif
      !
      return
    else if (nstok.ge.2) then
      !
      ! Check first for simple Extraction
      iextract = 0
      if (nstok.eq.2) then
        doit = .false.
        if (istoke.eq.astoke(1)) then
          iextract = 1
          doit = .true.
        else if (istoke.eq.astoke(2)) then
          iextract = 2
          doit = .true.
          ! Then for conversion
        else if (istoke.ge.code_stokes_i .or. istoke.eq.code_stokes_none &
          .or. istoke.eq.code_stokes_all) then
          if ( (astoke(1).eq.code_stokes_hh) .and. (astoke(2).eq.code_stokes_vv) ) doit = .true.
          if ( (astoke(2).eq.code_stokes_hh) .and. (astoke(1).eq.code_stokes_vv) ) doit = .true.
          if ( (astoke(1).eq.code_stokes_ll) .and. (astoke(2).eq.code_stokes_rr) ) doit = .true.
          if ( (astoke(2).eq.code_stokes_ll) .and. (astoke(1).eq.code_stokes_rr) ) doit = .true.
          if ( (astoke(1).eq.code_stokes_xx) .and. (astoke(2).eq.code_stokes_yy) ) doit = .true.
          if ( (astoke(2).eq.code_stokes_xx) .and. (astoke(1).eq.code_stokes_yy) ) doit = .true.
          iextract = 0
          doit = .true.
          call map_message(seve%i,rname,'Compression case from Stokes '//gdf_stokes_name(astoke(1))// &
            &' '//gdf_stokes_name(astoke(2))//' to Stokes '//gdf_stokes_name(istoke) )
        endif
      else if (nstok.eq.4) then
        doit = .true. !!! TEST
        iextract = 0
      endif
      if (iextract.ne.0) call map_message(seve%i,rname,'Extracting Stokes '//gdf_stokes_name(istoke) )
      !
      ! Re-allocate the Frequencies and Stokes axes
      hou%gil%nfreq = hin%gil%nfreq / nstok
      deallocate(hou%gil%stokes,hou%gil%freqs)
      allocate(hou%gil%stokes(hou%gil%nfreq),hou%gil%freqs(hou%gil%nfreq),stat=ier)
      hou%gil%stokes(:) = istoke
      hou%gil%nstokes = 1
      k = max(iextract,1)
      do i=1,hou%gil%nfreq
        hou%gil%freqs(i) = hin%gil%freqs(k)
        k = k+nstok
      enddo
      !
      ! Shift the trailing columns
      do i=1,code_uvt_last
        if (hou%gil%column_pointer(i).gt.hin%gil%fcol) then
          hou%gil%column_pointer(i) =  hou%gil%column_pointer(i) - &
            & hin%gil%natom * hin%gil%nchan
        endif
      enddo
      !
      ! Then, do the job
      hou%gil%dim(2) = hou%gil%nvisi
      hou%gil%dim(1) = hin%gil%dim(1) - hin%gil%nchan*hin%gil%natom &
                     + ontrail-intrail
      oend = hou%gil%dim(1)+intrail-ontrail
      !!Print *,'IN ',hin%gil%natom,  hin%gil%nchan,  hin%gil%nvisi, hin%gil%dim(1)
      !!Print *,'OUT ',hou%gil%natom,  hou%gil%nchan,  hou%gil%nvisi, hou%gil%dim(1)
      !!Print *,'OEND ',oend, intrail, ontrail
      if (istoke.eq.code_stokes_all) then
          PRINT *,'Invalid Stokes ALL code'
!!        hou%gil%column_pointer(code_uvt_stok) = hou%gil%dim(1)
      endif
      !
      ! Here, we make the loop
      allocate (dou(hou%gil%dim(1),nblock),din(hin%gil%dim(1),nblock),stat=ier)
      if (ier.ne.0) then
        call map_message(seve%e,rname,'Memory allocation error')
        error = .true.
        return
      endif
      !
      hin%blc = 0
      hin%trc = 0
      hou%blc = 0
      hou%trc = 0
      !
!TEST!      call gdf_print_header(hou)
!TEST!      read(5,*) iextract
      !
      call gdf_create_image(hou,error)
      if (error) return
      !
      hou%blc(2) = 1
      do iloop = 1,hin%gil%dim(2),nblock
        write(mess,*) iloop,' / ',hin%gil%dim(2),nblock
        call map_message(seve%d,rname,mess)
        hin%blc(2) = iloop
        hin%trc(2) = min(iloop+nblock-1,hin%gil%dim(2))
        call gdf_read_data(hin,din,error)
        if (error) return
        nvisi = hin%trc(2)-hin%blc(2)+1
        !
        ! This must be Nstokes x Nchan channels order...
        !!Print *,'ISTOKE ',istoke,' ASTOKE ',astoke(1:nstok)
        call stokes_derive_stok (din,dou,nvisi,nlead,natom,nchan,nstok, &
        & intrail,istoke,astoke,ipara,isign,error)
        if (error) return
        !
        hou%trc(2) = hou%blc(2)+nvisi-1
        call gdf_write_data(hou,dou,error)
        hou%blc(2) = hou%trc(2)+1
        !
      enddo ! By block
      !
      call gdf_close_image(hou,error)
      return
    endif
    !
    ! Failure Cases...
    call map_message(seve%e,rname,'Cannot yet handle Random Stokes / Frequency values')
    error = .true.
    return
  endif
  !
  ! Check it has more than 1 polarization
  if (hin%gil%nstokes.eq.1) then
    call map_message(seve%i,rname,'Already only 1 polar per visibility ')
    ! Here need to check if a Polar column is present, through the
    ! extra columns (code_uvt_stok)
    !
    is = hin%gil%column_pointer(code_uvt_stok)
    if (is.eq.0) then
      call map_message(seve%i,rname,'Already only 1 polar in total')
      nstok = 1
      astoke(nstok) = hin%gil%order
      if (istoke.eq.astoke(1) .or. istoke.eq.0) then
        !
        ! OK copy the whole stuff...
        allocate (din(hin%gil%dim(1),nblock),stat=ier)
        if (ier.ne.0) then
          call map_message(seve%e,rname,'Memory allocation error ')
          error = .true.
          return
        endif
        !
        hin%blc = 0
        hin%trc = 0
        hou%blc = 0
        hou%trc = 0
        call gdf_create_image(hou,error)
        if (error) return
        !
        call map_message(seve%i,rname,'Replicating UV table ')
        do iloop = 1,hin%gil%dim(2),nblock
          hin%blc(2) = iloop
          hin%trc(2) = min(iloop+nblock-1,hin%gil%dim(2))
          hou%blc(2) = iloop
          hou%trc(2) = hin%trc(2)
          call gdf_read_data (hin,din,error)
          if (error) return
          call gdf_write_data (hou, din, error)
          if (error) return
        enddo
        call gdf_close_image(hou,error)
      else
        call map_message(seve%i,rname,'Polar '//mystoke// &
        ' does not match '//gdf_stokes_name(astoke(1)) )
        error = .true.
      endif
      !
      return
    else
      call map_message(seve%i,rname,'Perhaps more than 1 polar, scanning...')
      allocate (din(hin%gil%dim(1),nblock),dou(hou%gil%dim(1),nblock),stat=ier)
      if (ier.ne.0) then
        call map_message(seve%i,rname,'Memory allocation error ')
        error = .true.
        return
      endif
      !
      hin%blc = 0
      hin%trc = 0
      hou%blc = 0
      hou%trc = 0
      hou%blc(2) = 1
      jv = 0
      call gdf_create_image(hou,error)
      if (error) return
      !
      nstok = 0
      do iloop = 1,hin%gil%dim(2),nblock
        hin%blc(2) = iloop
        hin%trc(2) = min(iloop+nblock-1,hin%gil%dim(2))
        kv = hin%trc(2)-hin%blc(2)+1
        call gdf_read_data (hin,din,error)
        if (error) return
        !
        jv = 0
        do iv = 1,kv
          if (din(is,iv).ne.istoke) cycle
          jv = jv+1
          dou(:,jv) = din(:,iv)
        enddo
        !
        if (jv.gt.0) then
          hou%trc(2) = hou%blc(2)+jv-1
          call gdf_write_data(hou,dou,error)
          hou%blc(2) = hou%trc(2)+1
        endif
      enddo
      !
      ! Finalize
      hou%gil%nvisi = hou%trc(2)
      hou%gil%dim(2) = hou%trc(2)
      call gdf_update_header(hou,error)
      call gdf_close_image(hou,error)
    endif
    !
  else
    !
    ! This means each Visi has Nstokes x Nchan or Nchan x Nstokes elements
    !
    if (hin%gil%order.eq.code_chan_stok) then
      ! Nchan X Nstokes channels
      !
      call map_message(seve%i,rname,'Input order: Nchan channels X Nstokes stokes')
    else if (hin%gil%order.eq.code_stok_chan) then
      call map_message(seve%i,rname,'Input order: Nstokes stokes X  Nchan channels')
      ! Nstokes x Nchan channels
    else
      call map_message(seve%e,rname,'Inconsistent UV table state for polarization')
      error = .true.
      return
    endif
    nstok = hin%gil%nstokes
    mess = 'Input Stokes: '
    next = 20
    do i=1,nstok
      mess(next:) = gdf_stokes_name(hin%gil%stokes(i))
      next = len_trim(mess)+3
    enddo
    call map_message(seve%i,rname,mess)
    call map_message(seve%i,rname,'Output Stokes:     '//gdf_stokes_name(istoke))
    !
    !!print *,'DIN ',(din(1:10,i),i=1,10)
    !
    astoke(1:nstok) = hin%gil%stokes(1:nstok)
    natom = hin%gil%natom
    nchan = hin%gil%nchan
    nlead = hin%gil%nlead
    intrail = hin%gil%ntrail
    ontrail = intrail
    iend = hin%gil%dim(1)
    !
    ! The useful cases are
    if (nstok.eq.2) then
      if (istoke.ge.code_stokes_i .or. istoke.eq.code_stokes_none &
        .or. istoke.eq.code_stokes_all) then
        ! Input: 2 Stokes, HH+VV or XX+YY or RR+LL, Output: I, NONE or ALL
        ! keep everything, make proper weighting
        if ( (astoke(1).eq.code_stokes_hh.and.astoke(2).eq.code_stokes_vv) &
        .or. (astoke(2).eq.code_stokes_hh.and.astoke(1).eq.code_stokes_vv) &
        .or. (astoke(1).eq.code_stokes_ll.and.astoke(2).eq.code_stokes_rr) &
        .or. (astoke(2).eq.code_stokes_ll.and.astoke(1).eq.code_stokes_rr) &
        .or. (astoke(1).eq.code_stokes_xx.and.astoke(2).eq.code_stokes_yy) &
        .or. (astoke(2).eq.code_stokes_xx.and.astoke(1).eq.code_stokes_yy) &
        ) then
          if (istoke.eq.code_stokes_all) then
            hou%gil%nvisi = 2*hin%gil%nvisi
            multi = 2
            ontrail = ontrail+1
          else
            multi = 1
            hou%gil%nvisi = hin%gil%nvisi
          endif
          call map_message(seve%i,rname,'Deriving '//mystoke// &
          ' from '//gdf_stokes_name(astoke(1))//' and '//gdf_stokes_name(astoke(2)))
          !
          ! Shift the trailing columns
          do i=1,code_uvt_last
            if (hou%gil%column_pointer(i).gt.hin%gil%fcol) then
              hou%gil%column_pointer(i) =  hou%gil%column_pointer(i) - &
                & hin%gil%natom * hin%gil%nchan
            endif
          enddo
          !
        else
          call map_message(seve%e,rname,'Cannot derive '//mystoke// &
          ' from '//gdf_stokes_name(astoke(1))//' and '//gdf_stokes_name(astoke(2)))
          error = .true.
          return
        endif
        !
        hou%gil%dim(2) = hou%gil%nvisi
        hou%gil%dim(1) = hin%gil%dim(1) - hin%gil%nchan*hin%gil%natom &
                       + ontrail-intrail
        oend = hou%gil%dim(1)+intrail-ontrail
        !!Print *,'IN ',hin%gil%natom,  hin%gil%nchan,  hin%gil%nvisi, hin%gil%dim(1)
        !!Print *,'OUT ',hou%gil%natom,  hou%gil%nchan,  hou%gil%nvisi, hou%gil%dim(1)
        !!Print *,'OEND ',oend, intrail, ontrail
        if (istoke.eq.code_stokes_all) then
          hou%gil%column_pointer(code_uvt_stok) = hou%gil%dim(1)
        endif
        !
        ! Here, we make the loop
        ! We make no assumption about the Stokes ordering, so allocate
        ! a block which may handle all input visibilities
        mblock = multi*nblock
        allocate (dou(hou%gil%dim(1),mblock),din(hin%gil%dim(1),nblock),stat=ier)
        if (ier.ne.0) then
          call map_message(seve%e,rname,'Memory allocation error')
          error = .true.
          return
        endif
        !
        hin%blc = 0
        hin%trc = 0
        hou%blc = 0
        hou%trc = 0
        call gdf_create_image(hou,error)
        if (error) return
        !
        hou%blc(2) = 1
        do iloop = 1,hin%gil%dim(2),nblock
          write(mess,*) iloop,' / ',hin%gil%dim(2),nblock
          call map_message(seve%d,rname,mess)
          hin%blc(2) = iloop
          hin%trc(2) = min(iloop+nblock-1,hin%gil%dim(2))
          call gdf_read_data(hin,din,error)
          if (error) return
          nvisi = hin%trc(2)-hin%blc(2)+1
          !
          if (hin%gil%order.eq.code_chan_stok) then
            ! Nchan X Nstokes channels  (ALL)
            !
            if (istoke.eq.code_stokes_all) then
              !
              jv = 0
              do iv = 1,nvisi
                jv = jv+1
                dou(1:nlead,jv) = din(1:nlead,iv)
                dou(nlead+1:nlead+natom*nchan,jv) = din(nlead+1:nlead+natom*nchan,iv)
                if (ontrail.ne.intrail) dou(oend+1,jv) = astoke(1)
                if (intrail.gt.0) dou(1+nlead+natom*nchan:oend,jv) = &
                     din(nlead+1+2*natom*nchan:iend,iv)
                !
                jv = jv+1
                dou(1:nlead,jv) = din(1:nlead,iv)
                dou(nlead+1:nlead+natom*nchan,jv) = din(nlead+1+natom*nchan:nlead+2*natom*nchan,iv)
                if (ontrail.ne.intrail) dou(oend+1,jv) = astoke(2)
                if (intrail.gt.0) dou(1+nlead+natom*nchan:oend,jv) = &
                     din(nlead+1+2*natom*nchan:iend,iv)
              enddo
            else
              call map_message(seve%e,rname, &
              & 'Nchan X Nstokes channel order only supported for code ALL')
              error = .true.
              return
            endif
          else
            !
            ! Nstokes x Nchan channels
            call stokes_derive_stok(din,dou,nvisi,nlead,natom,nchan,nstok, &
            & intrail,istoke,astoke,ipara,isign,error)
            if (error) return
          endif
          hou%trc(2) = hou%blc(2)+multi*nvisi-1
          call gdf_write_data(hou,dou,error)
          hou%blc(2) = hou%trc(2)+1
          !
        enddo ! By block
      else
        ! Input: 2 Stokes, HH+VV or RR+LL, Output: one among these.
        ! keep only that one...
        if (istoke.eq.astoke(1)) then
          ivisi = 1
        else if (istoke.eq.astoke(2)) then
          ivisi = 2
        else
          call map_message(seve%e,rname,'Cannot extract '//mystoke// &
          ' from '//gdf_stokes_name(astoke(1))//' and '//gdf_stokes_name(astoke(2)))
          error = .true.
          return
        endif
        call map_message(seve%e,rname,'Extracting '//mystoke// &
          ' from '//gdf_stokes_name(astoke(1))//' and '//gdf_stokes_name(astoke(2)))
        !
        hou%gil%dim(1) = hin%gil%dim(1)-hin%gil%nchan*hin%gil%natom
        extract = .true.
        !
        ! Shift the trailing columns
        do i=1,code_uvt_last
          if (hou%gil%column_pointer(i).gt.hin%gil%fcol) then
            hou%gil%column_pointer(i) =  hou%gil%column_pointer(i) - &
              & hin%gil%natom * hin%gil%nchan
          endif
        enddo
      endif
      !
    else if (nstok.eq.4) then
      !
      ! 4 Stokes, extract one of them, or derive the desired one from others
      ivisi = 0
      do i=1,nstok
        if (istoke.eq.astoke(i)) then
          ivisi = i
          exit
        endif
      enddo
      !
      if (ivisi.eq.0) then
        ! Cannot be extracted, must be Derived
        if ( (istoke.eq.code_stokes_none) .or. & 
          & ((istoke.ge.code_stokes_i).and.(istoke.le.code_stokes_v)) )  then
          !
          ! Is derivation possible ?
          if ( (astoke(1).eq.code_stokes_hh.and.astoke(2).eq.code_stokes_vv) &
          .or. (astoke(2).eq.code_stokes_hh.and.astoke(1).eq.code_stokes_vv) &
          .or. (astoke(1).eq.code_stokes_ll.and.astoke(2).eq.code_stokes_rr) &
          .or. (astoke(2).eq.code_stokes_ll.and.astoke(1).eq.code_stokes_rr) &
          .or. (astoke(1).eq.code_stokes_xx.and.astoke(2).eq.code_stokes_yy) &
          .or. (astoke(2).eq.code_stokes_xx.and.astoke(1).eq.code_stokes_yy) &
          ) then
            continue
          else
            call map_message(seve%e,rname, &
              & 'Unsupported Stokes ordering ')
            error = .true.
            return
          endif   
          !
          multi = 1   ! 1 output visibility per input Visibility      
          ! Shift the trailing columns
          do i=1,code_uvt_last
            if (hou%gil%column_pointer(i).gt.hin%gil%fcol) then
              hou%gil%column_pointer(i) =  hou%gil%column_pointer(i) - &
                & 3 * hin%gil%natom * hin%gil%nchan
            endif
          enddo
          !
          ! Figure out which case is to be compressed
          hou%gil%dim(2) = hou%gil%nvisi
          hou%gil%dim(1) = hin%gil%dim(1)-3*hin%gil%nchan*hin%gil%natom &
                &        + ontrail-intrail
          oend = hou%gil%dim(1)+intrail-ontrail
          !!Print *,'IN ',hin%gil%natom,  hin%gil%nchan,  hin%gil%nvisi, hin%gil%dim(1)
          !!Print *,'OUT ',hou%gil%natom,  hou%gil%nchan,  hou%gil%nvisi, hou%gil%dim(1)
          !!Print *,'OEND ',oend, intrail, ontrail
          !
          ! Here, we make the loop
          ! We make no assumption about the Stokes ordering, so allocate
          ! a block which may handle all input visibilities
          mblock = multi*nblock
          allocate (dou(hou%gil%dim(1),mblock),din(hin%gil%dim(1),nblock),stat=ier)
          if (ier.ne.0) then
            call map_message(seve%e,rname,'Memory allocation error')
            error = .true.
            return
          endif
          !
          hin%blc = 0
          hin%trc = 0
          hou%blc = 0
          hou%trc = 0
          call gdf_create_image(hou,error)
          if (error) return
          !
          hou%blc(2) = 1
          do iloop = 1,hin%gil%dim(2),nblock
            write(mess,*) iloop,' / ',hin%gil%dim(2),nblock
            call map_message(seve%i,rname,mess)
            hin%blc(2) = iloop
            hin%trc(2) = min(iloop+nblock-1,hin%gil%dim(2))
            call gdf_read_data(hin,din,error)
            if (error) return
            nvisi = hin%trc(2)-hin%blc(2)+1
            !
            ! Nstokes x Nchan channels
            if (hin%gil%order.eq.code_chan_stok) then
              call stokes_derive_chan(din,dou,nvisi,nlead,natom,nchan,nstok, &
                & intrail,istoke,astoke,ipara,isign,error)            
            else
            !
              call stokes_derive_stok(din,dou,nvisi,nlead,natom,nchan,nstok, &
                & intrail,istoke,astoke,ipara,isign,error)
            endif
            if (error) return
            !
            hou%trc(2) = hou%blc(2)+multi*nvisi-1
            call gdf_write_data(hou,dou,error)
            hou%blc(2) = hou%trc(2)+1
          enddo ! Block
          !
        else
          call map_message(seve%e,rname,'Cannot extract '//mystoke// &
            & ' from '//gdf_stokes_name(astoke(1))//gdf_stokes_name(astoke(2))// &
            & gdf_stokes_name(astoke(3))//' and '//gdf_stokes_name(astoke(4)) )
          error = .true.
          return
        endif
      else
        ! Extraction among those already present
        call map_message(seve%i,rname,'Extracting '//mystoke// &
            & ' from '//gdf_stokes_name(astoke(1))//gdf_stokes_name(astoke(2))// &
            & gdf_stokes_name(astoke(3))//' and '//gdf_stokes_name(astoke(4)) )
        !
        hou%gil%dim(1) = hin%gil%dim(1)-3*hin%gil%nchan*hin%gil%natom
        extract = .true.
        !
        ! Shift the trailing columns
        do i=1,code_uvt_last
          if (hou%gil%column_pointer(i).gt.hin%gil%fcol) then
            hou%gil%column_pointer(i) =  hou%gil%column_pointer(i) - &
              & 3 * hin%gil%natom * hin%gil%nchan
          endif
        enddo
      endif
    endif
    !
    ! The extraction code makes no assumption about the Stokes order at all.
    if (extract) then
      Print *,'EXTRACTING ',nstok
      !
      call gdf_create_image(hou,error)
      if (error) return
      !
      allocate (dou(hou%gil%dim(1),nblock),din(hin%gil%dim(1),nblock),stat=ier)
      if (ier.ne.0) then
        call map_message(seve%e,rname,'Memory allocation error ')
        error = .true.
        return
      endif
      hin%blc = 0
      hou%trc = 0
      !
      hou%blc(2) = 1
      do iloop = 1,hin%gil%dim(2),nblock
        hin%blc(2) = iloop
        hin%trc(2) = min(iloop+nblock-1,hin%gil%dim(2))
        kv = hin%trc(2)-hin%blc(2)+1
        call gdf_read_data(hin,din,error)
        if (error) return
        !
        call stokes_extract(hin%gil%order,din,dou,kv,nlead,natom,nchan,nstok,intrail,ivisi)
        !
        hou%trc(2) = hou%blc(2)+kv-1
        call gdf_write_data(hou,dou,error)
        hou%blc(2) = hou%trc(2)+1
      enddo
    endif
    call gdf_close_image(hou,error)
  endif
  !
end subroutine sub_splitpolar
!
subroutine stokes_extract(inorder,din,dou,nvisi,nlead,natom,nchan,nstok, & 
  & ntrail,ivisi)
  use image_def
  !---------------------------------------------------------------------
  ! @ private-mandatory
  !
  ! IMAGER
  !
  ! Support routine for STOKES command: extract the relevant
  ! Stokes parameter from the input visibilities. 
  !---------------------------------------------------------------------  
  real(kind=4), intent(in) :: din(:,:)
  real(kind=4), intent(out) :: dou(:,:)
  integer, intent(in) :: inorder ! Code order
  integer, intent(in) :: nvisi  ! number of visibilities
  integer, intent(in) :: nlead  ! number of leading columns
  integer, intent(in) :: natom  ! Atomic length of a visibility (2 or 3)
  integer, intent(in) :: nchan  ! number of channels
  integer, intent(in) :: nstok  ! number of input Stokes
  integer, intent(in) :: ntrail ! number of trailing columns
  integer, intent(in) :: ivisi  ! Pointer into Stokes parameter
  !
  integer :: iv
  integer :: ic
  integer :: kin, kou
  !
  if (inorder.eq.code_chan_stok) then
    ! Nchan X Nstokes channels
    do iv = 1,nvisi
      dou(1:nlead,iv) = din(1:nlead,iv)
      dou(nlead+1:nlead+natom*nchan,iv) = &
      & din(nlead+1+(ivisi-1)*natom*nchan:nlead+ivisi*natom*nchan,iv)
      if (ntrail.gt.0) dou(1+nlead+natom*nchan:,iv) = din(nlead+1+nstok*natom*nchan:,iv)
    enddo
  else
    ! Nstokes x Nchan channels
    do iv = 1,nvisi 
      dou(1:nlead,iv) = din(1:nlead,iv)
      kin = nlead+(ivisi-1)*natom
      kou = nlead
      do ic=1,nchan
        dou(kou+1:kou+natom,iv) = din(kin+1:kin+natom,iv)
        kou = kou + natom
        kin = kin + nstok*natom
      enddo
      if (ntrail.gt.0) dou(1+nlead+natom*nchan:,iv) = din(nlead+1+nstok*natom*nchan:,iv)
    enddo
  endif
end subroutine stokes_extract
!
subroutine stokes_derive_stok(din,dou,nvisi,nlead,natom,nchan,nstok,ntrail, &
  & istoke,astoke,ipara,isign,error)
  use image_def
  use gbl_message
  use imager_interfaces, only : map_message
  !---------------------------------------------------------------------
  ! @ private-mandatory
  !
  ! IMAGER
  !
  ! Support routine for STOKES command: Derive the relevant
  ! Stokes parameter from the input visibilities. This routine works
  ! for CODE_STOKE_CHAN order, and 2 or 4 input Stokes parameters.
  ! Not all combinations are allowed, however.
  !---------------------------------------------------------------------  
  real(kind=4), intent(in) :: din(:,:)
  real(kind=4), intent(out) :: dou(:,:)
  integer, intent(in) :: nvisi  ! Number of visibilities
  integer, intent(in) :: nlead  ! number of leading columns
  integer, intent(in) :: natom  ! Atomic length of a visibility (2 or 3)
  integer, intent(in) :: nchan  ! number of channels
  integer, intent(in) :: nstok  ! number of input Stokes
  integer, intent(in) :: ntrail ! number of trailing columns
  integer, intent(in) :: istoke ! desired Stokes parameter
  integer, intent(in) :: astoke(nstok)   ! Input Stokes parameters
  integer, intent(in) :: ipara  ! Parallactic angle column
  integer, intent(in) :: isign  ! test integer for PA angle
  logical, intent(out) :: error ! Error flag
  !
  character(len=*), parameter :: rname='STOKES'
  !
  character(len=80) :: msg
  integer :: iv, jv
  integer :: kin, kou
  integer :: ic, ip, is
  real :: re, im, we, da, db
  integer :: iend, oend, multi, jsign
  real :: hh(2), hv(2), vv(2), vh(2), aa(2), bb(2), xx, yy
  real :: rr(2), ll(2), rl(2), lr(2)
  logical :: debug
  logical :: good_order, circular
  !
  iend = ubound(din,1)
  oend = ubound(dou,1)
  !
  debug = .false.
  call sic_get_logi('DEBUG',debug,error)  
  if (debug) then
    Print *, 'NVISI ', nvisi  ! Number of visibilities
    Print *, 'NLEAD ', nlead  ! number of leading columns
    Print *, 'NATOM ', natom  ! Atomic length of a visibility (2 or 3)
    Print *, 'NCHAN ', nchan  ! number of channels
    Print *, 'NSTOK ', nstok  ! number of input Stokes
    Print *, 'NTRAIL ', ntrail ! number of trailing columns
    Print *, 'ISTOKE ', istoke ! desired Stokes parameter
    Print *, 'ASTOKE ', astoke(1:nstok)   ! Input Stokes parameters
    Print *, 'IPARA ', ipara ! Parallactic angle column
    Print *,'Iend ',iend,' Oend ',oend
  endif
  error = .false.
  !
  if (istoke.eq.code_stokes_all) then
    multi = nstok
    oend = oend-1
  else
    multi = 1
  endif
  !
  jv = 0
  select case(istoke)
  !
  case (code_stokes_none)  
    ! Stokes NONE: Unpolarized case - optimize sensitivity
    jv = 0
    do iv = 1,nvisi
      jv = jv+1
      dou(1:nlead,jv) = din(1:nlead,iv)
      kin = nlead
      kou = nlead
      ! 
      do ic=1,nchan
        if (natom.eq.3) then ! Real, Image, Weight
          if (din(kin+3,iv).gt.0) then
            re = din(kin+1,iv) * din(kin+3,iv)
            im = din(kin+2,iv) * din(kin+3,iv)
            we = din(kin+3,iv)
          else
            re = 0
            im = 0
            we = 0
          endif
          kin = kin+natom
          if (din(kin+3,iv).gt.0) then
            re = re + din(kin+1,iv) * din(kin+3,iv)
            im = im + din(kin+2,iv) * din(kin+3,iv)
            we = we + din(kin+3,iv)
          endif
          if (we.ne.0) then
            dou(kou+1:kou+1,jv) = re/we
            dou(kou+2:kou+2,jv) = im/we
            dou(kou+3:kou+3,jv) = we
          else
            dou(kou+1:kou+3,jv) = 0
          endif
          !
        else if (natom.eq.2) then
          ! Only Real Weight
          if (din(kin+2,iv).gt.0) then
            re = din(kin+1,iv) * din(kin+2,iv)
            we = din(kin+2,iv)
          else
            re = 0
            we = 0
          endif
          kin = kin+natom
          if (din(kin+2,iv).gt.0) then
            re = re + din(kin+1,iv) * din(kin+2,iv)
            we = we + din(kin+2,iv)
          endif
          if (we.ne.0) then
            dou(kou+1:kou+1,jv) = re/we
            dou(kou+2:kou+2,jv) = we
          else
            dou(kou+1:kou+2,jv) = 0
          endif
        endif
        ! Skip the HV and VH or LR and RL values
        kin = kin + (nstok-2)*natom
        !
        kou = kou + natom
        kin = kin + natom
      enddo
      !
      ! Fill trailing columns
      if (ntrail.gt.0) dou(1+nlead+natom*nchan:oend,jv) = &
           din(nlead+1+nstok*natom*nchan:iend,iv)
    enddo
  case (code_stokes_i)
    ! Stokes I
    ! Stokes I is strictly Stokes I, i.e.   (HH+VV)/2 or (LL+RR)/2, not
    ! an arbitray weighted combination.
    ! For unpolarized signals, to maximize sensitivity, use Stokes NONE
    do iv=1,nvisi
      jv = jv+1
      dou(1:nlead,jv) = din(1:nlead,iv)
      kin = nlead
      kou = nlead
      !
      do ic=1,nchan
        if (din(kin+natom,iv).gt.0)  then
          dou(kou+1:kou+natom,jv) = din(kin+1:kin+natom-1,iv)  ! Visib
          da = 1.0/din(kin+natom,iv) ! Noise**2
          ip = 1
        else
          da = 0.0
          ip = 0
        endif
        kin = kin+natom
        if (din(kin+natom,iv).gt.0)  then
          dou(kou+1:kou+natom-1,jv) = dou(kou+1:kou+natom-1,jv) + &
            din(kin+1:kin+natom-1,iv)
          db = 1.0/din(kin+natom,iv)  ! Noise**2
          ip = ip+1
        else
          db = 0.0
        endif
        if (ip.eq.2) then
          dou(kou+1:kou+natom-1,jv) = dou(kou+1:kou+natom-1,jv) / ip
          dou(kou+natom,jv) = 4.0/(da+db)   ! Weight = 1/noise^2
        else
          dou(kou+natom,jv) = 0.0
        endif
        ! Skip the HV and VH or LR and RL values
        kin = kin + (nstok-2)*natom
        !
        kou = kou + natom
        kin = kin + natom
      enddo
      !
      ! Fill trailing columns
      if (ntrail.gt.0) dou(1+nlead+natom*nchan:oend,jv) = &
           din(nlead+1+nstok*natom*nchan:iend,iv)
    enddo
    !
  case (code_stokes_V)
    ! Stokes V is -j(HV-VH)/2 or -j(XY-YX)/2 or (RR-LL)/2
    ! a proper test on ordering would be good.
    !
    ! Natom must be 3 in this case (we need complex numbers)
    if ( ((astoke(3).eq.code_stokes_hv).and.(astoke(4).eq.code_stokes_vh)) &
      & .or. ((astoke(3).eq.code_stokes_xy).and.(astoke(4).eq.code_stokes_yx)) &
      & ) then
      ! We only support HH VV HV VH and XX YY XY YX order for the time being
      !
      ! V = -j (XY-YX)/2  =  -j (HV-VH)/2
      !
      do iv=1,nvisi
        jv = jv+1
        dou(1:nlead,jv) = din(1:nlead,iv)
        kin = nlead
        kou = nlead
        !
        kin = kin+2*natom ! Skipp HH and VV 
        !
        do ic=1,nchan
          if (din(kin+natom,iv).gt.0)  then
            HV(1:2) = din(kin+1:kin+natom-1,iv)  
            da = 1.0/din(kin+natom,iv) ! Noise**2
            ip = 1
          else
            da = 0.0
            ip = 0
          endif
          kin = kin+natom
          if (din(kin+natom,iv).gt.0)  then
            VH(1:2) = din(kin+1:kin+natom-1,iv)
            db = 1.0/din(kin+natom,iv)  ! Noise**2
            ip = ip+1
          else
            db = 0.0
          endif
          if (ip.eq.2) then
            dou(kou+1:kou+1,jv) = +(hv(2)-vh(2))/2          
            dou(kou+2:kou+2,jv) = -(hv(1)-vh(1))/2
            dou(kou+natom,jv) = 4.0/(da+db)   ! Weight = 1/noise^2
          else
            dou(kou+natom,jv) = 0.0
          endif
          !
          kou = kou + natom
          kin = kin + natom
        enddo
        !
        ! Fill trailing columns
        if (ntrail.gt.0) dou(1+nlead+natom*nchan:oend,jv) = &
             din(nlead+1+nstok*natom*nchan:iend,iv)
      enddo
      !
    elseif ( (astoke(1).eq.code_stokes_rr).and.(astoke(2).eq.code_stokes_ll) .and. & 
      &  (astoke(3).eq.code_stokes_rl).and.(astoke(4).eq.code_stokes_lr) ) then
      !
      ! (RR - LL ) /2
      do iv=1,nvisi
        jv = jv+1
        dou(1:nlead,jv) = din(1:nlead,iv)
        kin = nlead
        kou = nlead
        !
        !
        do ic=1,nchan
          if (din(kin+natom,iv).gt.0)  then
            RR(1:2) = din(kin+1:kin+natom-1,iv)  
            da = 1.0/din(kin+natom,iv) ! Noise**2
            ip = 1
          else
            da = 0.0
            ip = 0
          endif
          kin = kin+natom
          if (din(kin+natom,iv).gt.0)  then
            LL(1:2) = din(kin+1:kin+natom-1,iv)
            db = 1.0/din(kin+natom,iv)  ! Noise**2
            ip = ip+1
          else
            db = 0.0
          endif
          if (ip.eq.2) then
            dou(kou+1:kou+2,jv) = (rr-ll)/2
            dou(kou+natom,jv) = 4.0/(da+db)   ! Weight = 1/noise^2
          else
            dou(kou+natom,jv) = 0.0
          endif
          !
          kou = kou + natom
          kin = kin + natom
          kin = kin+2*natom ! Skip RL and LR 
        enddo
        !
        ! Fill trailing columns
        if (ntrail.gt.0) dou(1+nlead+natom*nchan:oend,jv) = &
             din(nlead+1+nstok*natom*nchan:iend,iv)
      enddo
    else
      write(msg,'(A,4(1X,I0),A)') 'Ordering ',astoke,' not supported'
      call map_message(seve%e,rname,msg)
      error = .true.
      return
    endif    
    !  
  case (code_stokes_Q,code_stokes_U)
    ! Stokes Q and U are more complex
    !
    ! From HH,VV etc..., they require the parallactic angle and HH,VV,HV,VH order
    ! From XX,YY etc..., they require XX,YY,XY,YX order, but no parallactic angle
    ! a proper test on ordering would be good.
    !
    ! Natom must be 3 in this case (we need complex numbers)
    good_order = .false.
    circular = .false.
    if ( (astoke(1).eq.code_stokes_hh).and.(astoke(2).eq.code_stokes_vv) .and. & 
      &  (astoke(3).eq.code_stokes_hv).and.(astoke(4).eq.code_stokes_vh) ) then
      if (ipara.eq.0) then
        call map_message(seve%e,rname,'No parallactic angle column ')
        error = .true.
        return
      endif
      jsign = isign ! Temporary, normally should be 1
      good_order = .true.
    else if ( (astoke(1).eq.code_stokes_xx).and.(astoke(2).eq.code_stokes_yy) .and. & 
      &  (astoke(3).eq.code_stokes_xy).and.(astoke(4).eq.code_stokes_yx) ) then
      jsign = 0
      good_order = .true.
    elseif ( (astoke(1).eq.code_stokes_rr).and.(astoke(2).eq.code_stokes_ll) .and. & 
      &  (astoke(3).eq.code_stokes_rl).and.(astoke(4).eq.code_stokes_lr) ) then
      write(msg,'(A,4(1X,I0),A)') 'Ordering ',astoke,' not fully tested'
      call map_message(seve%w,rname,msg)
      good_order = .false.
      circular = .true.
    else
      write(msg,'(A,4(1X,I0),A)') 'Ordering ',astoke,' not supported '
      call map_message(seve%e,rname,msg)
      error = .true.
      return
    endif    
    !
    if (good_order) then
      !
      ! compute aa = (HH-VV)/2   and bb = (HV+VH)/2 then
      !  Q = aa cos(2.phi) - bb sin(2.phi)
      !  U = aa sin(2.phi) + bb cos(2.phi)
      ! or
      ! compute aa = (XX-YY)/2   and bb = (XY+YX)/2 then
      !  Q = aa 
      !  U = bb
      !
      db = 0 ! to avoid initialization warnings.
      do iv=1,nvisi
        jv = jv+1
        dou(1:nlead,jv) = din(1:nlead,iv)
        kin = nlead
        kou = nlead
        !
        if (istoke.eq.code_stokes_q) then
          if (jsign.ne.0) then
            xx =  cos(2*jsign*din(ipara,iv))
            yy = -sin(2*jsign*din(ipara,iv))
          else
            xx = 1.0
            yy = 0.0
          endif
        else
          if (jsign.ne.0) then
            xx = sin(2*jsign*din(ipara,iv))
            yy = cos(2*jsign*din(ipara,iv))
          else
            xx = 0.0
            yy = 1.0
          endif
        endif
        !
        do ic=1,nchan
          if (din(kin+natom,iv).gt.0)  then
            HH(1:2) = din(kin+1:kin+natom-1,iv)  
            da = 1.0/din(kin+natom,iv) ! Noise**2
            ip = 1
          else
            da = 0.0
            ip = 0
          endif
          kin = kin+natom
          if (din(kin+natom,iv).gt.0)  then
            VV(1:2) = din(kin+1:kin+natom-1,iv)
            db = 1.0/din(kin+natom,iv)  ! Noise**2
            ip = ip+1
          endif
          kin = kin+natom
          if (din(kin+natom,iv).gt.0)  then
            HV(1:2) = din(kin+1:kin+natom-1,iv)
            ip = ip+1
          endif
          kin = kin+natom
          if (din(kin+natom,iv).gt.0)  then
            VH(1:2) = din(kin+1:kin+natom-1,iv)
            ip = ip+1
          endif
          !
          aa = (HH-VV)/2
          bb = (HV+VH)/2
          !
          if (ip.eq.4) then
            dou(kou+1:kou+2,jv) = xx*aa + yy*bb
            dou(kou+natom,jv) = 4.0/(da+db)   ! Weight = 1/noise^2
          else
            dou(kou+natom,jv) = 0.0
          endif
          !
          kou = kou + natom
          kin = kin + natom
        enddo
        !
        ! Fill trailing columns
        if (ntrail.gt.0) dou(1+nlead+natom*nchan:oend,jv) = &
             din(nlead+1+nstok*natom*nchan:iend,iv)
      enddo
      !
    else if (circular) then
      !
      db = 0   ! Avoid initialization warning
      do iv=1,nvisi
        jv = jv+1
        dou(1:nlead,jv) = din(1:nlead,iv)
        kin = nlead
        kou = nlead
        !
        do ic=1,nchan
          if (din(kin+natom,iv).gt.0)  then
            RR(1:2) = din(kin+1:kin+natom-1,iv)  
            da = 1.0/din(kin+natom,iv) ! Noise**2
            ip = 1
          else
            da = 0.0
            ip = 0
          endif
          kin = kin+natom
          if (din(kin+natom,iv).gt.0)  then
            LL(1:2) = din(kin+1:kin+natom-1,iv)
            db = 1.0/din(kin+natom,iv)  ! Noise**2
            ip = ip+1
          endif
          kin = kin+natom
          if (din(kin+natom,iv).gt.0)  then
            RL(1:2) = din(kin+1:kin+natom-1,iv)
            ip = ip+1
          endif
          kin = kin+natom
          if (din(kin+natom,iv).gt.0)  then
            LR(1:2) = din(kin+1:kin+natom-1,iv)
            ip = ip+1
          endif
          !
          if (istoke.eq.code_stokes_q) then
            !  Q = (RL + LR)/2 
            bb = (RL+LR)/2
          else if (istoke.eq.code_stokes_u) then              
            !  U = -i (RL - LR)/2 
            aa = (RL-LR)/2
            bb(2) = -aa(1)
            bb(1) =  aa(2)
          endif
          !
          if (ip.eq.4) then
            dou(kou+1:kou+2,jv) = bb !! 
            dou(kou+natom,jv) = 4.0/(da+db)   ! Weight = 1/noise^2
          else
            dou(kou+natom,jv) = 0.0
          endif
          !
          kou = kou + natom
          kin = kin + natom
        enddo
        !
        ! Fill trailing columns
        if (ntrail.gt.0) dou(1+nlead+natom*nchan:oend,jv) = &
             din(nlead+1+nstok*natom*nchan:iend,iv)
      enddo
    
    endif
    !  
  case (code_stokes_all)
    ! Stokes ALL : explodes the Stokes / Channel visibilities
    ! into one visibility per Stokes. Add the Stokes column at
    ! end of each Visibility.  
    do iv=1,nvisi
      do is=1,nstok
        jv = jv+1
        dou(1:nlead,jv) = din(1:nlead,iv)
        kin = nlead
        kou = nlead
        do ic=1,nchan
          dou(kou+1:kou+natom,jv) = din(kin+1:kin+natom,iv)
          kou = kou + natom
          kin = kin + nstok*natom
        enddo
        if (ntrail.gt.0) dou(1+nlead+natom*nchan:oend,jv) = &
             din(nlead+1+nstok*natom*nchan:iend,iv)
        dou(oend+1,jv) = astoke(is)
      enddo
    enddo
  case default
    write(*,*) 'Case ',istoke,' Not supported'
  end select
  !
  ! Sanity check
  if (jv.ne.multi*nvisi) then
    write(*,*) 'E-STOKES, ','Expecting up to ',nvisi,' visibilities, found ',jv
  endif
end subroutine stokes_derive_stok


subroutine stokes_derive_chan(din,dou,nvisi,nlead,natom,nchan,nstok,ntrail, &
  & istoke,astoke,ipara,isign,error)
  use image_def
  use gbl_message
  use imager_interfaces, only : map_message
  !---------------------------------------------------------------------
  ! @ private-mandatory
  !
  ! IMAGER
  !
  ! Support routine for STOKES command: Derive the relevant
  ! Stokes parameter from the input visibilities. This routine works
  ! for CODE_CHAN_STOKE order, and 2 or 4 input Stokes parameters.
  ! Not all combinations are allowed, however.
  !---------------------------------------------------------------------  
  real(kind=4), intent(in) :: din(:,:)
  real(kind=4), intent(out) :: dou(:,:)
  integer, intent(in) :: nvisi  ! Number of visibilities
  integer, intent(in) :: nlead  ! number of leading columns
  integer, intent(in) :: natom  ! Atomic length of a visibility (2 or 3)
  integer, intent(in) :: nchan  ! number of channels
  integer, intent(in) :: nstok  ! number of input Stokes
  integer, intent(in) :: ntrail ! number of trailing columns
  integer, intent(in) :: istoke ! desired Stokes parameter
  integer, intent(in) :: astoke(nstok)   ! Input Stokes parameters
  integer, intent(in) :: ipara  ! Parallactic angle column
  integer, intent(in) :: isign  ! test integer for PA angle
  logical, intent(out) :: error ! Error flag
  !
  character(len=*), parameter :: rname='STOKES'
  !
  character(len=80) :: msg
  integer :: iv, jv
  integer :: kin, kou
  integer :: ic, ip, is
  real :: re, im, we, da, db
  integer :: iend, oend, multi, jsign
  real :: hh(2), hv(2), vv(2), vh(2), aa(2), bb(2), xx, yy
  real :: rr(2), ll(2), rl(2), lr(2)
  logical :: debug
  logical :: good_order, circular
  !
  iend = ubound(din,1)
  oend = ubound(dou,1)
  !
  debug = .false.
  call sic_get_logi('DEBUG',debug,error)  
  if (debug) then
    Print *, 'NVISI ', nvisi  ! Number of visibilities
    Print *, 'NLEAD ', nlead  ! number of leading columns
    Print *, 'NATOM ', natom  ! Atomic length of a visibility (2 or 3)
    Print *, 'NCHAN ', nchan  ! number of channels
    Print *, 'NSTOK ', nstok  ! number of input Stokes
    Print *, 'NTRAIL ', ntrail ! number of trailing columns
    Print *, 'ISTOKE ', istoke ! desired Stokes parameter
    Print *, 'ASTOKE ', astoke(1:nstok)   ! Input Stokes parameters
    Print *, 'IPARA ', ipara ! Parallactic angle column
    Print *,'Iend ',iend,' Oend ',oend
  endif
  error = .false.
  !
  if (istoke.eq.code_stokes_all) then
    multi = nstok
    oend = oend-1
  else
    multi = 1
  endif
  !
  jv = 0
  select case(istoke)
  !
  case (code_stokes_none)  
    ! Stokes NONE: Unpolarized case - optimize sensitivity
    ! Order HH,VV  or LL,RR
    jv = 0
    do iv = 1,nvisi
      jv = jv+1
      dou(1:nlead,jv) = din(1:nlead,iv)
      kin = nlead
      kou = nlead
      ! 
      do ic=1,nchan
        if (natom.eq.3) then ! Real, Image, Weight
          if (din(kin+3,iv).gt.0) then
            re = din(kin+1,iv) * din(kin+3,iv)
            im = din(kin+2,iv) * din(kin+3,iv)
            we = din(kin+3,iv)
          else
            re = 0
            im = 0
            we = 0
          endif
          kin = kin+natom*nchan  ! Skip NCHAN channels
          if (din(kin+3,iv).gt.0) then
            re = re + din(kin+1,iv) * din(kin+3,iv)
            im = im + din(kin+2,iv) * din(kin+3,iv)
            we = we + din(kin+3,iv)
          endif
          if (we.ne.0) then
            dou(kou+1:kou+1,jv) = re/we
            dou(kou+2:kou+2,jv) = im/we
            dou(kou+3:kou+3,jv) = we
          else
            dou(kou+1:kou+3,jv) = 0
          endif
          !
        else if (natom.eq.2) then
          ! Only Real Weight
          if (din(kin+2,iv).gt.0) then
            re = din(kin+1,iv) * din(kin+2,iv)
            we = din(kin+2,iv)
          else
            re = 0
            we = 0
          endif
          kin = kin+natom*nchan
          if (din(kin+2,iv).gt.0) then
            re = re + din(kin+1,iv) * din(kin+2,iv)
            we = we + din(kin+2,iv)
          endif
          if (we.ne.0) then
            dou(kou+1:kou+1,jv) = re/we
            dou(kou+2:kou+2,jv) = we
          else
            dou(kou+1:kou+2,jv) = 0
          endif
        endif
        ! Skip the HV and VH or LR and RL values
        kin = kin - natom*nchan
        !
        ! Increment by 1 channel
        kou = kou + natom
        kin = kin + natom
      enddo
      !
      ! Fill trailing columns
      if (ntrail.gt.0) dou(1+nlead+natom*nchan:oend,jv) = &
           din(nlead+1+nstok*natom*nchan:iend,iv)
    enddo
  case (code_stokes_i)
    ! Stokes I
    ! Stokes I is strictly Stokes I, i.e.   (HH+VV)/2 or (LL+RR)/2, not
    ! an arbitray weighted combination.
    ! For unpolarized signals, to maximize sensitivity, use Stokes NONE
    do iv=1,nvisi
      jv = jv+1
      dou(1:nlead,jv) = din(1:nlead,iv)
      kin = nlead
      kou = nlead
      !
      do ic=1,nchan
        if (din(kin+natom,iv).gt.0)  then
          dou(kou+1:kou+natom,jv) = din(kin+1:kin+natom-1,iv)  ! Visib
          da = 1.0/din(kin+natom,iv) ! Noise**2
          ip = 1
        else
          da = 0.0
          ip = 0
        endif
        kin = kin+natom*nchan
        if (din(kin+natom,iv).gt.0)  then
          dou(kou+1:kou+natom-1,jv) = dou(kou+1:kou+natom-1,jv) + &
            din(kin+1:kin+natom-1,iv)
          db = 1.0/din(kin+natom,iv)  ! Noise**2
          ip = ip+1
        else
          db = 0.0
        endif
        if (ip.eq.2) then
          dou(kou+1:kou+natom-1,jv) = dou(kou+1:kou+natom-1,jv) / ip
          dou(kou+natom,jv) = 4.0/(da+db)   ! Weight = 1/noise^2
        else
          dou(kou+natom,jv) = 0.0
        endif
        ! Skip the HV and VH or LR and RL values
        kin = kin - natom*nchan
        !
        kou = kou + natom
        kin = kin + natom
      enddo
      !
      ! Fill trailing columns
      if (ntrail.gt.0) dou(1+nlead+natom*nchan:oend,jv) = &
           din(nlead+1+nstok*natom*nchan:iend,iv)
    enddo
    !
  case (code_stokes_V)
    ! Stokes V is -j(HV-VH)/2 or -j(XY-YX)/2 or (RR-LL)/2
    ! a proper test on ordering would be good.
    !
    ! Natom must be 3 in this case (we need complex numbers)
    if ( ((astoke(3).eq.code_stokes_hv).and.(astoke(4).eq.code_stokes_vh)) &
      & .or. ((astoke(3).eq.code_stokes_xy).and.(astoke(4).eq.code_stokes_yx)) &
      & ) then
      ! We only support HH VV HV VH and XX YY XY YX order for the time being
      !
      ! V = -j (XY-YX)/2  =  -j (HV-VH)/2
      !
      do iv=1,nvisi
        jv = jv+1
        dou(1:nlead,jv) = din(1:nlead,iv)
        kin = nlead
        kou = nlead
        !
        kin = kin+2*nchan*natom ! Skipp HH and VV 
        !
        do ic=1,nchan
          if (din(kin+natom,iv).gt.0)  then
            HV(1:2) = din(kin+1:kin+natom-1,iv)  
            da = 1.0/din(kin+natom,iv) ! Noise**2
            ip = 1
          else
            da = 0.0
            ip = 0
          endif
          kin = kin+natom*nchan
          if (din(kin+natom,iv).gt.0)  then
            VH(1:2) = din(kin+1:kin+natom-1,iv)
            db = 1.0/din(kin+natom,iv)  ! Noise**2
            ip = ip+1
          else
            db = 0.0
          endif
          if (ip.eq.2) then
            dou(kou+1:kou+1,jv) = +(hv(2)-vh(2))/2          
            dou(kou+2:kou+2,jv) = -(hv(1)-vh(1))/2
            dou(kou+natom,jv) = 4.0/(da+db)   ! Weight = 1/noise^2
          else
            dou(kou+natom,jv) = 0.0
          endif
          kin = kin - natom*nchan
          !
          kou = kou + natom
          kin = kin + natom
        enddo
        !
        ! Fill trailing columns
        if (ntrail.gt.0) dou(1+nlead+natom*nchan:oend,jv) = &
             din(nlead+1+nstok*natom*nchan:iend,iv)
      enddo
      !
    elseif ( (astoke(1).eq.code_stokes_rr).and.(astoke(2).eq.code_stokes_ll) .and. & 
      &  (astoke(3).eq.code_stokes_rl).and.(astoke(4).eq.code_stokes_lr) ) then
      !
      ! (RR - LL ) /2
      do iv=1,nvisi
        jv = jv+1
        dou(1:nlead,jv) = din(1:nlead,iv)
        kin = nlead
        kou = nlead
        !
        !
        do ic=1,nchan
          if (din(kin+natom,iv).gt.0)  then
            RR(1:2) = din(kin+1:kin+natom-1,iv)  
            da = 1.0/din(kin+natom,iv) ! Noise**2
            ip = 1
          else
            da = 0.0
            ip = 0
          endif
          kin = kin+natom*nchan
          if (din(kin+natom,iv).gt.0)  then
            LL(1:2) = din(kin+1:kin+natom-1,iv)
            db = 1.0/din(kin+natom,iv)  ! Noise**2
            ip = ip+1
          else
            db = 0.0
          endif
          if (ip.eq.2) then
            dou(kou+1:kou+2,jv) = (rr-ll)/2
            dou(kou+natom,jv) = 4.0/(da+db)   ! Weight = 1/noise^2
          else
            dou(kou+natom,jv) = 0.0
          endif
          !
          kin = kin - natom*nchan ! Skip RL and LR if present
          kou = kou + natom
          kin = kin + natom
        enddo
        !
        ! Fill trailing columns
        if (ntrail.gt.0) dou(1+nlead+natom*nchan:oend,jv) = &
             din(nlead+1+nstok*natom*nchan:iend,iv)
      enddo
    else
      write(msg,'(A,4(1X,I0),A)') 'Ordering ',astoke,' not supported'
      call map_message(seve%e,rname,msg)
      error = .true.
      return
    endif    
    !  
  case (code_stokes_Q,code_stokes_U)
    ! Stokes Q and U are more complex
    !
    ! From HH,VV etc..., they require the parallactic angle and HH,VV,HV,VH order
    ! From XX,YY etc..., they require XX,YY,XY,YX order, but no parallactic angle
    ! a proper test on ordering would be good.
    !
    ! Natom must be 3 in this case (we need complex numbers)
    good_order = .false.
    circular = .false.
    if ( (astoke(1).eq.code_stokes_hh).and.(astoke(2).eq.code_stokes_vv) .and. & 
      &  (astoke(3).eq.code_stokes_hv).and.(astoke(4).eq.code_stokes_vh) ) then
      if (ipara.eq.0) then
        call map_message(seve%e,rname,'No parallactic angle column ')
        error = .true.
        return
      endif
      jsign = isign ! Temporary, normally should be 1
      good_order = .true.
    else if ( (astoke(1).eq.code_stokes_xx).and.(astoke(2).eq.code_stokes_yy) .and. & 
      &  (astoke(3).eq.code_stokes_xy).and.(astoke(4).eq.code_stokes_yx) ) then
      jsign = 0
      good_order = .true.
    elseif ( (astoke(1).eq.code_stokes_rr).and.(astoke(2).eq.code_stokes_ll) .and. & 
      &  (astoke(3).eq.code_stokes_rl).and.(astoke(4).eq.code_stokes_lr) ) then
      write(msg,'(A,4(1X,I0),A)') 'Ordering ',astoke,' not fully tested'
      call map_message(seve%w,rname,msg)
      good_order = .false.
      circular = .true.
    else
      write(msg,'(A,4(1X,I0),A)') 'Ordering ',astoke,' not supported '
      call map_message(seve%e,rname,msg)
      error = .true.
      return
    endif    
    !
    if (good_order) then
      !
      ! compute aa = (HH-VV)/2   and bb = (HV+VH)/2 then
      !  Q = aa cos(2.phi) - bb sin(2.phi)
      !  U = aa sin(2.phi) + bb cos(2.phi)
      ! or
      ! compute aa = (XX-YY)/2   and bb = (XY+YX)/2 then
      !  Q = aa 
      !  U = bb
      !
      db = 0 ! to avoid initialization warnings.
      do iv=1,nvisi
        jv = jv+1
        dou(1:nlead,jv) = din(1:nlead,iv)
        kin = nlead
        kou = nlead
        !
        if (istoke.eq.code_stokes_q) then
          if (jsign.ne.0) then
            xx =  cos(2*jsign*din(ipara,iv))
            yy = -sin(2*jsign*din(ipara,iv))
          else
            xx = 1.0
            yy = 0.0
          endif
        else
          if (jsign.ne.0) then
            xx = sin(2*jsign*din(ipara,iv))
            yy = cos(2*jsign*din(ipara,iv))
          else
            xx = 0.0
            yy = 1.0
          endif
        endif
        !
        do ic=1,nchan
          if (din(kin+natom,iv).gt.0)  then
            HH(1:2) = din(kin+1:kin+natom-1,iv)  
            da = 1.0/din(kin+natom,iv) ! Noise**2
            ip = 1
          else
            da = 0.0
            ip = 0
          endif
          kin = kin+natom*nchan
          if (din(kin+natom,iv).gt.0)  then
            VV(1:2) = din(kin+1:kin+natom-1,iv)
            db = 1.0/din(kin+natom,iv)  ! Noise**2
            ip = ip+1
          endif
          kin = kin+natom*nchan
          if (din(kin+natom,iv).gt.0)  then
            HV(1:2) = din(kin+1:kin+natom-1,iv)
            ip = ip+1
          endif
          kin = kin+natom*nchan
          if (din(kin+natom,iv).gt.0)  then
            VH(1:2) = din(kin+1:kin+natom-1,iv)
            ip = ip+1
          endif
          !
          aa = (HH-VV)/2
          bb = (HV+VH)/2
          !
          if (ip.eq.4) then
            dou(kou+1:kou+2,jv) = xx*aa + yy*bb
            dou(kou+natom,jv) = 4.0/(da+db)   ! Weight = 1/noise^2
          else
            dou(kou+natom,jv) = 0.0
          endif
          !
          kin = kin - 3*natom*nchan
          kou = kou + natom
          kin = kin + natom
        enddo
        !
        ! Fill trailing columns
        if (ntrail.gt.0) dou(1+nlead+natom*nchan:oend,jv) = &
             din(nlead+1+nstok*natom*nchan:iend,iv)
      enddo
      !
    else if (circular) then
      !
      db = 0   ! Avoid initialization warning
      do iv=1,nvisi
        jv = jv+1
        dou(1:nlead,jv) = din(1:nlead,iv)
        kin = nlead
        kou = nlead
        !
        do ic=1,nchan
          if (din(kin+natom,iv).gt.0)  then
            RR(1:2) = din(kin+1:kin+natom-1,iv)  
            da = 1.0/din(kin+natom,iv) ! Noise**2
            ip = 1
          else
            da = 0.0
            ip = 0
          endif
          kin = kin+natom*nchan
          if (din(kin+natom,iv).gt.0)  then
            LL(1:2) = din(kin+1:kin+natom-1,iv)
            db = 1.0/din(kin+natom,iv)  ! Noise**2
            ip = ip+1
          endif
          kin = kin+natom*nchan
          if (din(kin+natom,iv).gt.0)  then
            RL(1:2) = din(kin+1:kin+natom-1,iv)
            ip = ip+1
          endif
          kin = kin+natom*nchan
          if (din(kin+natom,iv).gt.0)  then
            LR(1:2) = din(kin+1:kin+natom-1,iv)
            ip = ip+1
          endif
          !
          if (istoke.eq.code_stokes_q) then
            !  Q = (RL + LR)/2 
            bb = (RL+LR)/2
          else if (istoke.eq.code_stokes_u) then              
            !  U = -i (RL - LR)/2 
            aa = (RL-LR)/2
            bb(2) = -aa(1)
            bb(1) =  aa(2)
          endif
          !
          if (ip.eq.4) then
            dou(kou+1:kou+2,jv) = bb !! 
            dou(kou+natom,jv) = 4.0/(da+db)   ! Weight = 1/noise^2
          else
            dou(kou+natom,jv) = 0.0
          endif
          !
          kin = kin - 3*natom*nchan
          kou = kou + natom
          kin = kin + natom
        enddo
        !
        ! Fill trailing columns
        if (ntrail.gt.0) dou(1+nlead+natom*nchan:oend,jv) = &
             din(nlead+1+nstok*natom*nchan:iend,iv)
      enddo
    
    endif
    !  
  case (code_stokes_all)
    ! Stokes ALL : explodes the Stokes / Channel visibilities
    ! into one visibility per Stokes. Add the Stokes column at
    ! end of each Visibility.  
    do iv=1,nvisi
      do is=1,nstok
        jv = jv+1
        dou(1:nlead,jv) = din(1:nlead,iv)
        kin = nlead+(is-1)*nchan
        kou = nlead
        dou(kou+1:kou*natom*nchan,jv) = din(kin+1:kin+natom*nchan,iv)
        if (ntrail.gt.0) dou(1+nlead+natom*nchan:oend,jv) = &
             din(nlead+1+nstok*natom*nchan:iend,iv)
        dou(oend+1,jv) = astoke(is)
      enddo
    enddo
  case default
    write(*,*) 'Case ',istoke,' Not supported'
  end select
  !
  ! Sanity check
  if (jv.ne.multi*nvisi) then
    write(*,*) 'E-STOKES, ','Expecting up to ',nvisi,' visibilities, found ',jv
  endif
end subroutine stokes_derive_chan



subroutine sub_splitpolar_mem(mystoke,huv,error)
  use image_def
  use gkernel_interfaces
  use gbl_message
  use imager_interfaces, except_this => sub_splitpolar_mem
  !
  ! @ private
  !
  character(len=*), intent(in) :: mystoke  ! Desired Stoke parameter
  type (gildas), intent(inout) :: huv
  logical, intent(out) :: error
  !
  character(len=*), parameter :: rname='STOKES'
  type (gildas) :: hin
  type (gildas) :: hou
  real, pointer :: duv_previous(:,:), duv_next(:,:)
  real(kind=4), pointer  :: din(:,:), dou(:,:)
  !
  character(len=message_length) :: mess
  !
  integer i, j, k, istoke, ivisi, is, iv, jv, ier, ipara
  integer astoke(4)
  integer nstok, natom, nlead, nchan, next
  logical extract, doit
  integer intrail, ontrail, iend, oend
  integer :: kv, nblock, nvisi, multi
  integer :: isign=1    ! This is the correct sign for Parallactic Angle
  integer :: iextract 
  integer :: nu ! 
  !
  error = .false.
  !
  extract = .false.
  !
  ! Scan the requested polarization code
  if (mystoke.eq.'NONE') then
    istoke = code_stokes_none
  elseif (mystoke.eq.'ALL') then
    istoke = code_stokes_all
  else
    call gdf_stokes_code(mystoke,istoke,error)
    if (error) then
      call map_message(seve%e,rname,'Invalid Stokes '//mystoke)
      error = .true.
      return
    endif
  endif
  !
  ! Read Header of a sorted, UV table
  call gildas_null(hin,type='UVT')
  call gdf_copy_header(huv,hin,error)
  !
  ipara = hin%gil%column_pointer(code_uvt_para)
  ! Test for debug
  call sic_get_inte('SIGN_PARA',isign,error)
  if (isign.ne.1) Print *,'Using ISIGN ',ISIGN
  !
  !
  call gildas_null(hou, type='UVT')
  call gdf_copy_header (hin, hou, error)
  !
  ! Define the Output Stokes parameter value
  hou%gil%nstokes = 1
  hou%gil%order = istoke           ! Unless it is "ANY" - will be changed later
  !
  call gdf_nitems('SPACE_GILDAS',nblock,hin%gil%dim(1))
  nblock = min(nblock,hin%gil%dim(2))
  !
  ! Check Random Frequency / Stokes axis
  if (hin%gil%nfreq.ne.0) then
    call map_message(seve%i,rname,'Random Frequency Axis case ')
    !
    nstok = 1
    astoke(1) = hin%gil%stokes(1)
    do i=2,hin%gil%nfreq
      k = 0
      do j=1,nstok
        if (astoke(j).eq.hin%gil%stokes(i)) then
          k = j
          exit
        endif
      enddo
      if (k.eq.0) then
        nstok = nstok+1
        astoke(nstok) = hin%gil%stokes(i)
      endif
    enddo
    !! Print *,'Found ',nstok,' Stokes of values ',astoke(1:nstok)
    !
    natom = hin%gil%natom
    nchan = hin%gil%nchan
    nlead = hin%gil%nlead
    intrail = hin%gil%ntrail
    ontrail = intrail
    iend = hin%gil%dim(1)
    !
    if (nstok.eq.1) then
      doit = .false.
      if (istoke.eq.astoke(1) .or. istoke.eq.0) then
        doit = .true.
      else if (istoke.ge.code_stokes_i .or. istoke.eq.code_stokes_none &
        .or. istoke.eq.code_stokes_all) then
        if ( (astoke(1).eq.code_stokes_hh) .or. (astoke(1).eq.code_stokes_vv) ) doit = .true.
        if ( (astoke(1).eq.code_stokes_ll) .or. (astoke(1).eq.code_stokes_rr) ) doit = .true.
        if ( (astoke(1).eq.code_stokes_xx) .or. (astoke(1).eq.code_stokes_yy) ) doit = .true.
        if ( (astoke(1).eq.code_stokes_i) ) doit = .true.
      endif
      !
      if (doit) then
        hou%gil%stokes(:) = istoke  ! Change the Stokes information
      else
        call map_message(seve%i,rname,'Polar '//mystoke// &
        ' does not match '//gdf_stokes_name(astoke(1)) )
        error = .true.
      endif
      !
      return
    else if (nstok.ge.2) then
      !
      ! Check first for simple Extraction
      iextract = 0
      if (nstok.eq.2) then
        doit = .false.
        if (istoke.eq.astoke(1)) then
          iextract = 1
          doit = .true.
        else if (istoke.eq.astoke(2)) then
          iextract = 2
          doit = .true.
          ! Then for conversion
        else if (istoke.ge.code_stokes_i .or. istoke.eq.code_stokes_none &
          .or. istoke.eq.code_stokes_all) then
          if ( (astoke(1).eq.code_stokes_hh) .and. (astoke(2).eq.code_stokes_vv) ) doit = .true.
          if ( (astoke(2).eq.code_stokes_hh) .and. (astoke(1).eq.code_stokes_vv) ) doit = .true.
          if ( (astoke(1).eq.code_stokes_ll) .and. (astoke(2).eq.code_stokes_rr) ) doit = .true.
          if ( (astoke(2).eq.code_stokes_ll) .and. (astoke(1).eq.code_stokes_rr) ) doit = .true.
          if ( (astoke(1).eq.code_stokes_xx) .and. (astoke(2).eq.code_stokes_yy) ) doit = .true.
          if ( (astoke(2).eq.code_stokes_xx) .and. (astoke(1).eq.code_stokes_yy) ) doit = .true.
          iextract = 0
          doit = .true.
          call map_message(seve%i,rname,'Compression case from Stokes '//gdf_stokes_name(astoke(1))// &
            &' '//gdf_stokes_name(astoke(2))//' to Stokes '//gdf_stokes_name(istoke) )
        endif
      else if (nstok.eq.4) then
        doit = .true. !!! TEST
        iextract = 0
      endif
      if (iextract.ne.0) call map_message(seve%i,rname,'Extracting Stokes '//gdf_stokes_name(istoke) )
      !
      ! Re-allocate the Frequencies and Stokes axes
      hou%gil%nfreq = hin%gil%nfreq / nstok
      deallocate(hou%gil%stokes,hou%gil%freqs)
      allocate(hou%gil%stokes(hou%gil%nfreq),hou%gil%freqs(hou%gil%nfreq),stat=ier)
      hou%gil%stokes(:) = istoke
      hou%gil%nstokes = 1
      k = max(iextract,1)
      do i=1,hou%gil%nfreq
        hou%gil%freqs(i) = hin%gil%freqs(k)
        k = k+nstok
      enddo
      !
      ! Shift the trailing columns
      do i=1,code_uvt_last
        if (hou%gil%column_pointer(i).gt.hin%gil%fcol) then
          hou%gil%column_pointer(i) =  hou%gil%column_pointer(i) - &
            & hin%gil%natom * hin%gil%nchan
        endif
      enddo
      !
      ! Then, do the job
      hou%gil%dim(2) = hou%gil%nvisi
      hou%gil%dim(1) = hin%gil%dim(1) - hin%gil%nchan*hin%gil%natom &
                     + ontrail-intrail
      oend = hou%gil%dim(1)+intrail-ontrail
      !!Print *,'IN ',hin%gil%natom,  hin%gil%nchan,  hin%gil%nvisi, hin%gil%dim(1)
      !!Print *,'OUT ',hou%gil%natom,  hou%gil%nchan,  hou%gil%nvisi, hou%gil%dim(1)
      !!Print *,'OEND ',oend, intrail, ontrail
      if (istoke.eq.code_stokes_all) then
          PRINT *,'Invalid Stokes ALL code'
!!        hou%gil%column_pointer(code_uvt_stok) = hou%gil%dim(1)
      endif
      !
      ! Allocate the buffers
      nu = hou%gil%dim(1)
      kv = hou%gil%dim(2)
      call uv_find_buffers (rname,nu,kv,duv_previous,duv_next,error)
      if (error) return
      !
      hin%blc = 0
      hin%trc = 0
      hou%blc = 0
      hou%trc = 0
      !
!TEST!      call gdf_print_header(hou)
!TEST!      read(5,*) iextract
      !
      nvisi = hin%gil%nvisi
      call stokes_derive_stok (duv_previous,duv_next,nvisi,nlead,natom,nchan,nstok, &
      & intrail,istoke,astoke,ipara,isign,error)
      if (error) return
      !
      call uv_clean_buffers(duv_previous,duv_next,error)
      call gdf_copy_header(hou,huv,error)
      return
    endif
    !
    ! Failure Cases...
    call map_message(seve%e,rname,'Cannot yet handle Random Stokes / Frequency values')
    error = .true.
    return
  endif
  !
  ! Check it has more than 1 polarization
  if (hin%gil%nstokes.eq.1) then
    call map_message(seve%i,rname,'Already only 1 polar per visibility ')
    ! Here need to check if a Polar column is present, through the
    ! extra columns (code_uvt_stok)
    !
    is = hin%gil%column_pointer(code_uvt_stok)
    if (is.eq.0) then
      call map_message(seve%i,rname,'Already only 1 polar in total')
      nstok = 1
      astoke(nstok) = hin%gil%order
      if (istoke.eq.astoke(1) .or. istoke.eq.0) then
        !
        ! OK this is the right stuff...
      else
        call map_message(seve%i,rname,'Polar '//mystoke// &
        ' does not match '//gdf_stokes_name(astoke(1)) )
        error = .true.
      endif
      !
      return
    else
      call map_message(seve%i,rname,'Perhaps more than 1 polar, scanning...')
      nu = hou%gil%dim(1)
      kv = hou%gil%dim(2)
      call uv_find_buffers (rname,nu,kv,duv_previous,duv_next,error)
      !
      hin%blc = 0
      hin%trc = 0
      hou%blc = 0
      hou%trc = 0
      jv = 0
      nstok = 0
      jv = 0
      do iv = 1,kv
        if (duv_previous(is,iv).ne.istoke) cycle
        jv = jv+1
        duv_next(:,jv) = duv_previous(:,iv)
      enddo
      if (jv.eq.0) then
        call map_message(seve%i,rname,'No such polarization state in data')
        error = .true.
        return
      endif
      !
      ! Finalize
      hou%gil%nvisi = jv
      hou%gil%dim(2) = jv
    endif
    !
  else
    !
    ! This means each Visi has Nstokes x Nchan or Nchan x Nstokes elements
    !
    if (hin%gil%order.eq.code_chan_stok) then
      ! Nchan X Nstokes channels
      !
      call map_message(seve%i,rname,'Input order: Nchan channels X Nstokes stokes')
    else if (hin%gil%order.eq.code_stok_chan) then
      call map_message(seve%i,rname,'Input order: Nstokes stokes X  Nchan channels')
      ! Nstokes x Nchan channels
    else
      call map_message(seve%e,rname,'Inconsistent UV table state for polarization')
      error = .true.
      return
    endif
    nstok = hin%gil%nstokes
    mess = 'Input Stokes: '
    next = 20
    do i=1,nstok
      mess(next:) = gdf_stokes_name(hin%gil%stokes(i))
      next = len_trim(mess)+3
    enddo
    call map_message(seve%i,rname,mess)
    call map_message(seve%i,rname,'Output Stokes:     '//gdf_stokes_name(istoke))
    !
    !!print *,'DIN ',(din(1:10,i),i=1,10)
    !
    astoke(1:nstok) = hin%gil%stokes(1:nstok)
    natom = hin%gil%natom
    nchan = hin%gil%nchan
    nlead = hin%gil%nlead
    intrail = hin%gil%ntrail
    ontrail = intrail
    iend = hin%gil%dim(1)
    !
    ! The useful cases are
    if (nstok.eq.2) then
      if (istoke.ge.code_stokes_i .or. istoke.eq.code_stokes_none &
        .or. istoke.eq.code_stokes_all) then
        ! Input: 2 Stokes, HH+VV or XX+YY or RR+LL, Output: I, NONE or ALL
        ! keep everything, make proper weighting
        if ( (astoke(1).eq.code_stokes_hh.and.astoke(2).eq.code_stokes_vv) &
        .or. (astoke(2).eq.code_stokes_hh.and.astoke(1).eq.code_stokes_vv) &
        .or. (astoke(1).eq.code_stokes_ll.and.astoke(2).eq.code_stokes_rr) &
        .or. (astoke(2).eq.code_stokes_ll.and.astoke(1).eq.code_stokes_rr) &
        .or. (astoke(1).eq.code_stokes_xx.and.astoke(2).eq.code_stokes_yy) &
        .or. (astoke(2).eq.code_stokes_xx.and.astoke(1).eq.code_stokes_yy) &
        ) then
          if (istoke.eq.code_stokes_all) then
            hou%gil%nvisi = 2*hin%gil%nvisi
            multi = 2
            ontrail = ontrail+1
          else
            multi = 1
            hou%gil%nvisi = hin%gil%nvisi
          endif
          call map_message(seve%i,rname,'Deriving '//mystoke// &
          ' from '//gdf_stokes_name(astoke(1))//' and '//gdf_stokes_name(astoke(2)))
          !
          ! Shift the trailing columns
          do i=1,code_uvt_last
            if (hou%gil%column_pointer(i).gt.hin%gil%fcol) then
              hou%gil%column_pointer(i) =  hou%gil%column_pointer(i) - &
                & hin%gil%natom * hin%gil%nchan
            endif
          enddo
          !
        else
          call map_message(seve%e,rname,'Cannot derive '//mystoke// &
          ' from '//gdf_stokes_name(astoke(1))//' and '//gdf_stokes_name(astoke(2)))
          error = .true.
          return
        endif
        !
        hou%gil%dim(2) = hou%gil%nvisi
        hou%gil%dim(1) = hin%gil%dim(1) - hin%gil%nchan*hin%gil%natom &
                       + ontrail-intrail
        oend = hou%gil%dim(1)+intrail-ontrail
        !!Print *,'IN ',hin%gil%natom,  hin%gil%nchan,  hin%gil%nvisi, hin%gil%dim(1)
        !!Print *,'OUT ',hou%gil%natom,  hou%gil%nchan,  hou%gil%nvisi, hou%gil%dim(1)
        !!Print *,'OEND ',oend, intrail, ontrail
        if (istoke.eq.code_stokes_all) then
          hou%gil%column_pointer(code_uvt_stok) = hou%gil%dim(1)
        endif
        !
        nu = hou%gil%dim(1)
        kv = hou%gil%dim(2)
        call uv_find_buffers (rname,nu,kv,duv_previous,duv_next,error)
        dou => duv_next
        din => duv_previous
        !
        hin%blc = 0
        hin%trc = 0
        hou%blc = 0
        hou%trc = 0
        !
        nvisi = hin%gil%nvisi
        if (hin%gil%order.eq.code_chan_stok) then
          ! Nchan X Nstokes channels  (ALL)
          !
          if (istoke.eq.code_stokes_all) then
            !
            jv = 0
            do iv = 1,nvisi
              jv = jv+1
              dou(1:nlead,jv) = din(1:nlead,iv)
              dou(nlead+1:nlead+natom*nchan,jv) = din(nlead+1:nlead+natom*nchan,iv)
              if (ontrail.ne.intrail) dou(oend+1,jv) = astoke(1)
              if (intrail.gt.0) dou(1+nlead+natom*nchan:oend,jv) = &
                   din(nlead+1+2*natom*nchan:iend,iv)
              !
              jv = jv+1
              dou(1:nlead,jv) = din(1:nlead,iv)
              dou(nlead+1:nlead+natom*nchan,jv) = din(nlead+1+natom*nchan:nlead+2*natom*nchan,iv)
              if (ontrail.ne.intrail) dou(oend+1,jv) = astoke(2)
              if (intrail.gt.0) dou(1+nlead+natom*nchan:oend,jv) = &
                   din(nlead+1+2*natom*nchan:iend,iv)
            enddo
            !
            hou%gil%nvisi = jv
            hou%gil%dim(2) = jv
          else
            call map_message(seve%e,rname, &
            & 'Nchan X Nstokes channel order only supported for code ALL')
            error = .true.
            return
          endif
        else
          !
          ! Nstokes x Nchan channels
          call stokes_derive_stok(din,dou,nvisi,nlead,natom,nchan,nstok, &
          & intrail,istoke,astoke,ipara,isign,error)
          if (error) return
        endif
      else
        ! Input: 2 Stokes, HH+VV or RR+LL, Output: one among these.
        ! keep only that one...
        if (istoke.eq.astoke(1)) then
          ivisi = 1
        else if (istoke.eq.astoke(2)) then
          ivisi = 2
        else
          call map_message(seve%e,rname,'Cannot extract '//mystoke// &
          ' from '//gdf_stokes_name(astoke(1))//' and '//gdf_stokes_name(astoke(2)),3)
          error = .true.
          return
        endif
        call map_message(seve%e,rname,'Extracting '//mystoke// &
          ' from '//gdf_stokes_name(astoke(1))//' and '//gdf_stokes_name(astoke(2)))
        !
        hou%gil%dim(1) = hin%gil%dim(1)-hin%gil%nchan*hin%gil%natom
        extract = .true.
        !
        ! Shift the trailing columns
        do i=1,code_uvt_last
          if (hou%gil%column_pointer(i).gt.hin%gil%fcol) then
            hou%gil%column_pointer(i) =  hou%gil%column_pointer(i) - &
              & hin%gil%natom * hin%gil%nchan
          endif
        enddo
      endif
      !
    else if (nstok.eq.4) then
      !
      ! 4 Stokes, extract one of them, or derive the desired one from others
      ivisi = 0
      do i=1,nstok
        if (istoke.eq.astoke(i)) then
          ivisi = i
          exit
        endif
      enddo
      !
      if (ivisi.eq.0) then
        ! Cannot be extracted, must be Derived
        if ( (istoke.eq.code_stokes_none) .or. & 
          & ((istoke.ge.code_stokes_i).and.(istoke.le.code_stokes_v)) )  then
          !
          ! Is derivation possible ?
          if ( (astoke(1).eq.code_stokes_hh.and.astoke(2).eq.code_stokes_vv) &
          .or. (astoke(2).eq.code_stokes_hh.and.astoke(1).eq.code_stokes_vv) &
          .or. (astoke(1).eq.code_stokes_ll.and.astoke(2).eq.code_stokes_rr) &
          .or. (astoke(2).eq.code_stokes_ll.and.astoke(1).eq.code_stokes_rr) &
          .or. (astoke(1).eq.code_stokes_xx.and.astoke(2).eq.code_stokes_yy) &
          .or. (astoke(2).eq.code_stokes_xx.and.astoke(1).eq.code_stokes_yy) &
          ) then
            continue
          else
            call map_message(seve%e,rname, &
              & 'Unsupported Stokes ordering ')
            error = .true.
            return
          endif   
          !
          multi = 1   ! 1 output visibility per input Visibility      
          ! Shift the trailing columns
          do i=1,code_uvt_last
            if (hou%gil%column_pointer(i).gt.hin%gil%fcol) then
              hou%gil%column_pointer(i) =  hou%gil%column_pointer(i) - &
                & 3 * hin%gil%natom * hin%gil%nchan
            endif
          enddo
          !
          ! Figure out which case is to be compressed
          hou%gil%dim(2) = hou%gil%nvisi
          hou%gil%dim(1) = hin%gil%dim(1)-3*hin%gil%nchan*hin%gil%natom &
                &        + ontrail-intrail
          oend = hou%gil%dim(1)+intrail-ontrail
          !!Print *,'IN ',hin%gil%natom,  hin%gil%nchan,  hin%gil%nvisi, hin%gil%dim(1)
          !!Print *,'OUT ',hou%gil%natom,  hou%gil%nchan,  hou%gil%nvisi, hou%gil%dim(1)
          !!Print *,'OEND ',oend, intrail, ontrail
          !
          nu = hou%gil%dim(1)
          kv = hou%gil%dim(2)
          call uv_find_buffers (rname,nu,kv,duv_previous,duv_next,error)
          dou => duv_next
          din => duv_previous
          !
          hin%blc = 0
          hin%trc = 0
          hou%blc = 0
          hou%trc = 0
          nvisi = hin%gil%nvisi 
          !
          ! Nstokes x Nchan channels
          if (hin%gil%order.eq.code_chan_stok) then
            call stokes_derive_chan(din,dou,nvisi,nlead,natom,nchan,nstok, &
              & intrail,istoke,astoke,ipara,isign,error)            
          else
          !
            call stokes_derive_stok(din,dou,nvisi,nlead,natom,nchan,nstok, &
              & intrail,istoke,astoke,ipara,isign,error)
          endif
          if (error) return
          !
        else
          call map_message(seve%e,rname,'Cannot extract '//mystoke// &
            & ' from '//gdf_stokes_name(astoke(1))//gdf_stokes_name(astoke(2))// &
            & gdf_stokes_name(astoke(3))//' and '//gdf_stokes_name(astoke(4)) )
          error = .true.
          return
        endif
      else
        ! Extraction among those already present
        call map_message(seve%i,rname,'Extracting '//mystoke// &
            & ' from '//gdf_stokes_name(astoke(1))//gdf_stokes_name(astoke(2))// &
            & gdf_stokes_name(astoke(3))//' and '//gdf_stokes_name(astoke(4)) )
        !
        hou%gil%dim(1) = hin%gil%dim(1)-3*hin%gil%nchan*hin%gil%natom
        extract = .true.
        !
        ! Shift the trailing columns
        do i=1,code_uvt_last
          if (hou%gil%column_pointer(i).gt.hin%gil%fcol) then
            hou%gil%column_pointer(i) =  hou%gil%column_pointer(i) - &
              & 3 * hin%gil%natom * hin%gil%nchan
          endif
        enddo
      endif
    endif
    !
    ! The extraction code makes no assumption about the Stokes order at all.
    if (extract) then
      !
      nu = hou%gil%dim(1)
      kv = hou%gil%dim(2)
      call uv_find_buffers (rname,nu,kv,duv_previous,duv_next,error)
      dou => duv_next
      din => duv_previous
      !
      hin%blc = 0
      hou%trc = 0
      !
      call stokes_extract(hin%gil%order,din,dou,kv,nlead,natom,nchan,nstok,intrail,ivisi)
    endif
  endif
  !
  ! Finalize
  call uv_clean_buffers(duv_previous,duv_next,error)
  call gdf_copy_header(hou,huv,error)  
  !
end subroutine sub_splitpolar_mem
!
