module code_polar_gildas
  ! These codes should ideally match the Values of the code_stokes_ab's 
  ! integers (equal to abs(first code_stokes_ab..)) sequence to identify
  ! the coherent sets of Polarization.
  !   But the coding behind makes no assumption about this:
  ! Assumed values are only in "polar_order" routine
  integer, parameter :: code_polar_circular=1      ! R+L sky frame
  integer, parameter :: code_polar_linear=5        ! X+Y sky frame
  integer, parameter :: code_polar_horizon=13      ! V+H antenna frame
  integer, parameter :: code_polar_round=9         ! D+S antenna frame
end module code_polar_gildas
!
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 code_polar_gildas
  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), ostoke(5)
  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 should be 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
      !
      ! Only 1 Stokes in input file, verify if the Stokes value ASTOKE(1) in the data
      ! file is an acceptable proxy of the desired Ouput Stokes values ISTOKE
      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
      !
      ! Two or more Stokes values in data file
      iextract = 0
      if (nstok.eq.2) then
        ! Two Stokes values ASTOKE(1:2)
        !
        ! Check first for simple Extraction of ISTOKE
        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
          call polar_order(nstok,astoke,ostoke,error)
          if (error) then
            call map_message(seve%i,rname,'Unsupported conversion from Stokes '//gdf_stokes_name(astoke(1))// &
              &' '//gdf_stokes_name(astoke(2))//' to Stokes '//gdf_stokes_name(istoke) )
            return
          endif
          iextract = 0
          call map_message(seve%i,rname,'Conversion 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
        !
        ! 4 Stokes values, there is always a solution
        doit = .true. !!! TEST
        iextract = 0
        call polar_order(nstok,astoke,ostoke,error)
        if (error) return
      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'
          error = .true.
          return
!!        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, ostoke)
        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
        call polar_order(nstok,astoke,ostoke,error)
        if (error) then
          call map_message(seve%i,rname,'Unsupported conversion from Stokes '//gdf_stokes_name(astoke(1))// &
            &' '//gdf_stokes_name(astoke(2))//' to Stokes '//gdf_stokes_name(istoke) )
          return
        endif
        !
        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
        !
        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, ostoke)
            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
          !
          call polar_order(nstok,astoke,ostoke,error)
          if (error) return
          !
          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, ostoke)            
            else
            !
              call stokes_derive_stok(din,dou,nvisi,nlead,natom,nchan,nstok, &
                & intrail,istoke,astoke,ipara,isign,error, ostoke)
            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
      !
      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
  use code_polar_gildas
  !---------------------------------------------------------------------
  ! @ 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, cstoke)
  use image_def
  use gbl_message
  use code_polar_gildas
  use gkernel_interfaces, only : gdf_stokes_name
  use imager_interfaces, only : map_message, findloc
  !---------------------------------------------------------------------
  ! @ 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.
  !
  ! Stokes vary first,  Channel next
  !---------------------------------------------------------------------  
  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
  integer, intent(in) :: cstoke(5)
  !
  character(len=*), parameter :: rname='STOKES'
  !
  character(len=80) :: msg
  integer :: iv, jv         !   Pointer to visibilities
  integer :: kin, kou, kk   !   Pointer to channel in visibilities
  integer :: ic, ip, is, iext
  real :: re, im, we, da, db
  integer :: iend, oend, multi, jsign, kxy, kyx
  real :: hh(2), hv(2), vv(2), vh(2), aa(2), bb(2), xy(2), yx(2)
  real :: xr, xi, xw ! (real, imag, weight) for current visibility
  real :: xa, yb  ! Cos/Sin or vice versa or 0,1
  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
        xr = din(kin+(cstoke(1)-1)*natom+1,iv)
        xi = din(kin+(cstoke(1)-1)*natom+2,iv)
        xw = din(kin+(cstoke(1)-1)*natom+natom,iv)
        if (xw.gt.0) then
          re = xr * xw
          im = xi * xw
          we = xw 
        else
          re = 0
          im = 0
          we = 0
        endif
        xr = din(kin+(cstoke(2)-1)*natom+1,iv)
        xi = din(kin+(cstoke(2)-1)*natom+2,iv)
        xw = din(kin+(cstoke(2)-1)*natom+natom,iv)
        if (xw.gt.0) then
          re = re + xr * xw
          im = im + xi * xw
          we = we + xw
        endif
        if (we.ne.0) then
          dou(kou+1:kou+1,jv) = re/we
          dou(kou+2:kou+2,jv) = im/we
          dou(kou+natom:kou+natom,jv) = we
        else
          dou(kou+1:kou+natom,jv) = 0
        endif
        !
        kou = kou + natom
        kin = kin + natom*nstok
      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
        xr = din(kin+(cstoke(1)-1)*natom+1,iv)
        xi = din(kin+(cstoke(1)-1)*natom+2,iv)
        xw = din(kin+(cstoke(1)-1)*natom+natom,iv)
        if (xw.gt.0) then
          re = xr 
          im = xi
          we = xw 
          da = 1.0/xw
          ip = 1
        else
          re = 0
          im = 0
          ip = 0
          da = 0
        endif
        xr = din(kin+(cstoke(2)-1)*natom+1,iv)
        xi = din(kin+(cstoke(2)-1)*natom+2,iv)
        xw = din(kin+(cstoke(2)-1)*natom+natom,iv)
        if (xw.gt.0)  then
          re = re+xr
          im = im+xi
          db = 1.0/xw     ! Noise**2
          ip = ip+1
        else
          db = 0.0
        endif
        if (ip.eq.2) then
          dou(kou+1,jv) = re / ip 
          dou(kou+2,jv) = im / ip
          dou(kou+natom,jv) = 4.0/(da+db)   ! Weight = 1/noise^2
        else
          dou(kou+natom,jv) = 0.0
        endif
        !
        ! Skip the input multi-Stokes visibility
        kin = kin + nstok*natom
        kou = kou + 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(VH-HV)/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 ((cstoke(5).eq.code_polar_linear).or.(cstoke(5).eq.code_polar_horizon)) then
      ! Initial Linear polarization
      !
      ! V = -j (XY-YX)/2  =  -j (VH-HV)/2
      !
      do iv=1,nvisi
        jv = jv+1
        dou(1:nlead,jv) = din(1:nlead,iv)
        kin = nlead
        kou = nlead
        !
        do ic=1,nchan
          !
          kxy = kin+natom*(cstoke(3)-1)      ! XY or VH pointer 
          kyx = kin+natom*(cstoke(4)-1)      ! YX or HV pointer 
          !
          if (din(kxy+natom,iv).gt.0)  then
            XY(1:2) = din(kxy+1:kxy+natom-1,iv)  
            da = 1.0/din(kxy+natom,iv) ! Noise**2
            ip = 1
          else
            da = 0.0
            ip = 0
          endif
          if (din(kyx+natom,iv).gt.0)  then
            YX(1:2) = din(kyx+1:kyx+natom-1,iv)
            db = 1.0/din(kyx+natom,iv)  ! Noise**2
            ip = ip+1
          else
            db = 0.0
          endif
          if (ip.eq.2) then
            dou(kou+1:kou+1,jv) = +(xy(2)-yx(2))/2          
            dou(kou+2:kou+2,jv) = -(xy(1)-yx(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 + nstok*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 (cstoke(5).eq.code_polar_circular) 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
          !
          kxy = kin+natom*(cstoke(1)-1)      ! RR pointer 
          kyx = kin+natom*(cstoke(2)-1)      ! LL pointer 
          if (din(kxy+natom,iv).gt.0)  then
            RR(1:2) = din(kxy+1:kxy+natom-1,iv)  
            da = 1.0/din(kxy+natom,iv) ! Noise**2
            ip = 1
          else
            da = 0.0
            ip = 0
          endif
          if (din(kyx+natom,iv).gt.0)  then
            LL(1:2) = din(kyx+1:kin+natom-1,iv)
            db = 1.0/din(kyx+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*nstok
        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    
    !  
    ! UPDATED up to this point
  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 (cstoke(5).ge.code_polar_horizon) then      ! V and H
      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 (cstoke(5).eq.code_polar_circular) then ! R and L
      write(msg,'(A,4(1X,I0),A)') 'Ordering of R,L circular polarization not fully tested'
      call map_message(seve%w,rname,msg)
      good_order = .false.
      circular = .true.
    else if (cstoke(5).eq.code_polar_linear) then  ! X and Y
      jsign = 0
      good_order = .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 = (VV-HH)/2   and bb = (VH+HV)/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
            xa =  cos(2*jsign*din(ipara,iv))
            yb = -sin(2*jsign*din(ipara,iv))
          else
            xa = 1.0
            yb = 0.0
          endif
        else
          if (jsign.ne.0) then
            xa = sin(2*jsign*din(ipara,iv))
            yb = cos(2*jsign*din(ipara,iv))
          else
            xa = 0.0
            yb = 1.0
          endif
        endif
        !
        ! Return order in CSTOKE is VV,HH,VH,HV or XX,YY,XY,YX
        do ic=1,nchan
          !
          kk = kin+(cstoke(1)-1)*natom
          if (din(kk+natom,iv).gt.0)  then
            VV(1:2) = din(kk+1:kk+natom-1,iv)  
            da = 1.0/din(kk+natom,iv) ! Noise**2
            ip = 1
          else
            da = 0.0
            ip = 0
          endif
          kk = kin+(cstoke(2)-1)*natom
          if (din(kk+natom,iv).gt.0)  then
            HH(1:2) = din(kk+1:kk+natom-1,iv)
            db = 1.0/din(kk+natom,iv)  ! Noise**2
            ip = ip+1
          endif
          kk = kin+(cstoke(3)-1)*natom
          if (din(kk+natom,iv).gt.0)  then
            VH(1:2) = din(kk+1:kk+natom-1,iv)
            ip = ip+1
          endif
          kk = kin+(cstoke(4)-1)*natom
          if (din(kk+natom,iv).gt.0)  then
            HV(1:2) = din(kk+1:kk+natom-1,iv)
            ip = ip+1
          endif
          !
          aa = (VV-HH)/2
          bb = (VH+Hv)/2
          !
          if (ip.eq.4) then
            dou(kou+1:kou+2,jv) = xa*aa + yb*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 * nstok
        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
          kk = kin+(cstoke(1)-1)*natom
          if (din(kk+natom,iv).gt.0)  then
            RR(1:2) = din(kk+1:kk+natom-1,iv)  
            da = 1.0/din(kk+natom,iv) ! Noise**2
            ip = 1
          else
            da = 0.0
            ip = 0
          endif
          kk = kin+(cstoke(2)-1)*natom
          if (din(kk+natom,iv).gt.0)  then
            LL(1:2) = din(kk+1:kk+natom-1,iv)
            db = 1.0/din(kk+natom,iv)  ! Noise**2
            ip = ip+1
          endif
          kk = kin+(cstoke(3)-1)*natom
          if (din(kin+natom,iv).gt.0)  then
            RL(1:2) = din(kk+1:kk+natom-1,iv)
            ip = ip+1
          endif
          kk = kin+(cstoke(4)-1)*natom
          if (din(kk+natom,iv).gt.0)  then
            LR(1:2) = din(kk+1:kk+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 * nstok
        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
    !
    ! It may be a simple extraction
    iext = findloc(astoke,istoke,1)
    if (iext.ne.0) then
      !
      ! Nstokes x Nchan channels
      do iv = 1,nvisi 
        dou(1:nlead,iv) = din(1:nlead,iv)
        kin = nlead+(iext-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
      jv = nvisi
    else
      call map_message(seve%i,rname,'Case '//gdf_stokes_name(istoke)//' not supported in this context')
      error = .true.
      return
    endif
  end select
  !
  ! Sanity check
  if (jv.ne.multi*nvisi) then
    write(msg,'(A,I0,A,I0)') 'Expecting up to ',nvisi,' visibilities, found ',jv
    call map_message(seve%e,rname,msg)
  endif
end subroutine stokes_derive_stok
!
subroutine stokes_derive_chan(din,dou,nvisi,nlead,natom,nchan,nstok,ntrail, &
  & istoke,astoke,ipara,isign,error, cstoke)
  use image_def
  use code_polar_gildas
  use gbl_message
  use gkernel_interfaces, only : gdf_stokes_name
  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.
  !
  ! CSTOKE handles the ordering of the Polarization states.
  !---------------------------------------------------------------------  
  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
  integer, intent(in) :: cstoke(5)  ! Order of Polarization components
  !
  ! HERE HERE
  !
  character(len=*), parameter :: rname='STOKES'
  !
  character(len=80) :: msg
  integer :: iv, jv
  integer :: kin, kou, kk
  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), xa, yb
  real :: rr(2), ll(2), rl(2), lr(2)
  logical :: debug
  logical :: 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, or XX,YY or vice-versa
    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
        kk = kin+(cstoke(1)-1)*natom*nchan
        if (din(kk+natom,iv).gt.0)  then
          dou(kou+1:kou+natom-1,jv) = din(kk+1:kk+natom-1,iv)  ! Visib
          da = 1.0/din(kk+natom,iv) ! Noise**2
          ip = 1
        else
          da = 0.0
          ip = 0
        endif
        kk = kin+(cstoke(2)-1)*natom*nchan
        if (din(kk+natom,iv).gt.0)  then
          dou(kou+1:kou+natom-1,jv) = dou(kou+1:kou+natom-1,jv) + &
            din(kk+1:kk+natom-1,iv)
          db = 1.0/din(kk+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
        ! Next 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_V)
    ! Stokes V is -j(VH-HV)/2 or -j(XY-YX)/2 or (RR-LL)/2
    !
    ! Natom must be 3 in this case (we need complex numbers)
    if ((cstoke(5).eq.code_polar_linear).or.(cstoke(5).eq.code_polar_horizon)) then
      do iv=1,nvisi
        jv = jv+1
        dou(1:nlead,jv) = din(1:nlead,iv)
        kin = nlead
        kou = nlead
        !
        do ic=1,nchan
          kk = kin+(cstoke(3)-1)*natom*nchan
          if (din(kk+natom,iv).gt.0)  then
            VH(1:2) = din(kk+1:kk+natom-1,iv)  
            da = 1.0/din(kk+natom,iv) ! Noise**2
            ip = 1
          else
            da = 0.0
            ip = 0
          endif
          kk = kin+(cstoke(4)-1)*natom*nchan
          if (din(kk+natom,iv).gt.0)  then
            HV(1:2) = din(kk+1:kk+natom-1,iv)
            db = 1.0/din(kk+natom,iv)  ! Noise**2
            ip = ip+1
          else
            db = 0.0
          endif
          if (ip.eq.2) then
            dou(kou+1:kou+1,jv) = +(vh(2)-hv(2))/2          
            dou(kou+2:kou+2,jv) = -(vh(1)-hv(1))/2
            dou(kou+natom,jv) = 4.0/(da+db)   ! Weight = 1/noise^2
          else
            dou(kou+natom,jv) = 0.0
          endif
          ! Next 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
      !
    else if (cstoke(5).eq.code_polar_circular) 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
          kk = kin+(cstoke(1)-1)*natom*nchan
          if (din(kk+natom,iv).gt.0)  then
            RR(1:2) = din(kk+1:kk+natom-1,iv)  
            da = 1.0/din(kk+natom,iv) ! Noise**2
            ip = 1
          else
            da = 0.0
            ip = 0
          endif
          kk = kin+(cstoke(2)-1)*natom*nchan
          if (din(kk+natom,iv).gt.0)  then
            LL(1:2) = din(kk+1:kk+natom-1,iv)
            db = 1.0/din(kk+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
        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 
    ! From XX,YY etc..., they do not
    !
    ! Natom must be 3 in this case (we need complex numbers)
    if (cstoke(5).eq.code_polar_horizon) 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
      circular = .false.
    else if (cstoke(5).eq.code_polar_linear) then
      jsign = 0
      circular = .false.
    else if (cstoke(5).eq.code_polar_circular) then
      write(msg,'(A,4(1X,I0),A)') 'Ordering ',astoke,' not fully tested'
      call map_message(seve%w,rname,msg)
      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 (.not.circular) then
      !
      ! compute aa = (VV-HH)/2   and bb = (VH+HV)/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
            xa =  cos(2*jsign*din(ipara,iv))
            yb = -sin(2*jsign*din(ipara,iv))
          else
            xa = 1.0
            yb = 0.0
          endif
        else
          if (jsign.ne.0) then
            xa = sin(2*jsign*din(ipara,iv))
            yb = cos(2*jsign*din(ipara,iv))
          else
            xa = 0.0
            yb = 1.0
          endif
        endif
        !
        do ic=1,nchan
          kk = kin+(cstoke(1)-1)*nchan*natom
          if (din(kk+natom,iv).gt.0)  then
            VV(1:2) = din(kk+1:kk+natom-1,iv)  
            da = 1.0/din(kk+natom,iv) ! Noise**2
            ip = 1
          else
            da = 0.0
            ip = 0
          endif
          kk = kin+(cstoke(2)-1)*nchan*natom
          if (din(kin+natom,iv).gt.0)  then
            HH(1:2) = din(kk+1:kk+natom-1,iv)
            db = 1.0/din(kk+natom,iv)  ! Noise**2
            ip = ip+1
          endif
          kk = kin+(cstoke(3)-1)*nchan*natom
          if (din(kk+natom,iv).gt.0)  then
            VH(1:2) = din(kk+1:kk+natom-1,iv)
            ip = ip+1
          endif
          kk = kin+(cstoke(4)-1)*nchan*natom
          if (din(kk+natom,iv).gt.0)  then
            HV(1:2) = din(kk+1:kk+natom-1,iv)
            ip = ip+1
          endif
          !
          aa = (VV-HH)/2
          bb = (HV+VH)/2
          !
          if (ip.eq.4) then
            dou(kou+1:kou+2,jv) = xa*aa + yb*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*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
          !
          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
    call map_message(seve%i,rname,'Case '//gdf_stokes_name(istoke)//' not supported in this context')
    error = .true.
  end select
  !
  ! Sanity check
  if (jv.ne.multi*nvisi) then
    write(msg,'(A,I0,A,I0)') 'Expecting up to ',nvisi,' visibilities, found ',jv
    call map_message(seve%e,rname,msg)
  endif
end subroutine stokes_derive_chan
!
subroutine sub_splitpolar_mem(mystoke,huv,error)
  use image_def
  use clean_types
  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)  ! Data Polarization code values.
  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 ! 
  integer :: ostoke(5)  ! Pointers to desired Polar order, and initial Polar type
  !
  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
  !
  ! We do not use Buffers here - Need to play safe to force re-reading
  ! even if in fact the processing is not done...
  save_data(code_save_uv) = .true.
  optimize(code_save_uv)%change = optimize(code_save_uv)%change+100
  !
  ! 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
    if (nstok.ne.1 .and. istoke.eq.code_stokes_all) then
      call map_message(seve%e,rname,'Code ALL is not supported in this context')
      error = .true.
      return
    endif
    call polar_order(nstok,astoke,ostoke,error)
    if (error) return
    !
    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
        ! Matching Polarization state
        doit = .true.
      else if (istoke.eq.code_stokes_none .or. istoke.eq.code_stokes_all) then
        ! Approximate matching. Strictly speaking, it does not apply to Stokes I
        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
      !
      iextract = 0
      ! Check first for simple Extraction
      doit = .false.
      do i=1,nstok
        if (istoke.eq.astoke(i)) then
          iextract = 1
          doit = .true.
          exit
        endif
      enddo
      !
      ! Then check for derivation
      if (iextract.eq.0) then
        call polar_order(nstok,astoke,ostoke,error)
        if (error) then
          call map_message(seve%i,rname,'Unsupported conversion from Stokes '//gdf_stokes_name(astoke(1))// &
            &' '//gdf_stokes_name(astoke(2))//' to Stokes '//gdf_stokes_name(istoke) )
          return
        endif
        iextract = -1
        if (nstok.eq.2) then
          if (istoke.ge.code_stokes_i .or. istoke.eq.code_stokes_none &
            .or. istoke.eq.code_stokes_all) then
            iextract = 0
            doit = .true.
          endif
        else if (nstok.eq.4) then
          doit = .true. !!! TEST
          iextract = 0
        endif
        if (iextract.ne.0) then
          call map_message(seve%e,rname,'Cannot Extract Stokes '//gdf_stokes_name(istoke)//' from data file')
          error = .true.
          return
        endif
      else
        if (istoke.lt.0) then
          call map_message(seve%i,rname,'Extracting Polarization state '//gdf_stokes_name(istoke) )
        else
          call map_message(seve%i,rname,'Deriving Stokes parameter '//gdf_stokes_name(istoke) )
        endif
      endif
      !
      ! 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
      !
      ! 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, ostoke)
      if (error) return
      !
      call uv_clean_buffers(duv_previous,duv_next,error)
      call gdf_copy_header(hou,huv,error)
      return
    endif
    !
    ! Failure Cases... No longer accessible
    call map_message(seve%e,rname,'Cannot yet handle Random Stokes / Frequency values')
    error = .true.
    return
  endif
  !
  ! From now on, this is the simple case with Stokes separate from Frequency
  !
  ! Check it has more than 1 polarization per visibility
  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
      ! Just the same polarization for all visibilities
      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 polarization (or a sufficient approximation...)
      else
        call map_message(seve%i,rname,'Polar '//mystoke// &
        ' does not match '//gdf_stokes_name(astoke(1)) )
        error = .true.
      endif
      !
      return
    else
      !
      ! A polarization Column is present, check if it contains different values
      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
        call polar_order(nstok,astoke,ostoke,error)
        if (error) then
          call map_message(seve%i,rname,'Unsupported conversion from Stokes '//gdf_stokes_name(astoke(1))// &
            &' '//gdf_stokes_name(astoke(2))//' to Stokes '//gdf_stokes_name(istoke) )
          return
        endif
        !
        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
        !
        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, ostoke)
          if (error) return
        endif
      else
        ! Input: 2 Stokes, HH+VV, XX+YY 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 ?
          call polar_order(nstok,astoke,ostoke,error)
          if (error) then
            call map_message(seve%i,rname,'Unsupported conversion from Stokes '//gdf_stokes_name(astoke(1))// &
              &' '//gdf_stokes_name(astoke(2))//' to Stokes '//gdf_stokes_name(istoke) )
            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, ostoke)            
          else
          !
            call stokes_derive_stok(din,dou,nvisi,nlead,natom,nchan,nstok, &
              & intrail,istoke,astoke,ipara,isign,error, ostoke)
          endif
          if (error) return
          !
        else
          ! No conversion between different polarization basis
          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
!
subroutine polar_order(nstok,astoke,cstoke,error)
  use image_def
  use code_polar_gildas
  use gbl_message
  use imager_interfaces, only : findloc
  !---------------------------------------------------------------------------------------------
  ! IMAGER
  !   Return the ordering of the Polarization / Stokes states described by array ASTOK
  !
  !   Supported Cases are 
  !   Nstoke = 2    the two parallel hand polarization, any order
  !   Nstoke = 4    all four cross-polarization, any order
  !---------------------------------------------------------------------------------------------
  integer, intent(in) :: nstok
  integer, intent(in) :: astoke(nstok)
  integer, intent(out) :: cstoke(5)
  logical, intent(out) :: error
  !
  integer :: pmin, pmax
  !
  pmin = -maxval(astoke)
  pmax = -minval(astoke)
  !
  error = .false.
  if (pmax-pmin.ne.nstok-1) then      ! Must have Nstok values
    error = .true.
  else if (mod(pmin,4).ne.1) then     ! Must start with XX,VV or RR
    error = .true.
  endif
  if (error) then
    call map_message(seve%e,'STOKES','Inconsistent polarization data codes')
    return
  endif
  !
  pmin = -pmin
  cstoke = 0
  if (pmin.eq.code_stokes_rr) then
    ! R,L case
    cstoke(1) = findloc(astoke,code_stokes_rr,1)
    cstoke(2) = findloc(astoke,code_stokes_ll,1)
    cstoke(3) = findloc(astoke,code_stokes_rl,1)
    cstoke(4) = findloc(astoke,code_stokes_lr,1)
    cstoke(5) = code_polar_circular
  else if (pmin.eq.code_stokes_xx) then
    ! X,Y case
    cstoke(1) = findloc(astoke,code_stokes_xx,1)
    cstoke(2) = findloc(astoke,code_stokes_yy,1)
    cstoke(3) = findloc(astoke,code_stokes_xy,1)
    cstoke(4) = findloc(astoke,code_stokes_yx,1)
    cstoke(5) = code_polar_linear
  else if (pmin.eq.code_stokes_hh) then
    ! H,V case - HH is first here in the Code list, not VV
    cstoke(1) = findloc(astoke,code_stokes_vv,1)
    cstoke(2) = findloc(astoke,code_stokes_hh,1)
    cstoke(3) = findloc(astoke,code_stokes_vh,1)
    cstoke(4) = findloc(astoke,code_stokes_hv,1)
    cstoke(5) = code_polar_horizon
  else
    error = .true.
    call map_message(seve%e,'POLAR_CODE','Unsupported polarization data codes')
    Print *,'ASTOKE ',astoke
  endif
end subroutine polar_order
!
function findloc(array,value,dim)
  ! @ private-mandatory
  integer :: findloc
  integer, intent(in) :: array(:)
  integer, intent(in) :: value
  integer, intent(in) :: dim
  !
  integer :: i,n,k
  !
  n = size(array)
  k = 0
  do i=1,n
    if (array(i).eq.value) then
      k = i
      exit
    endif
  enddo
  findloc = k
end function findloc

