subroutine stokes_comm(line,error)
  use image_def
  use gkernel_interfaces
  use gbl_message
  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
  !
  integer, parameter :: code_stokes_all=100
  integer, parameter :: code_stokes_any=-100
  character(len=*), parameter :: rname='STOKES'
  integer, parameter :: o_file=1
  !
  character(len=filename_length) :: nami,namo
  character(len=12) :: mystoke
  character(len=message_length) :: mess
  integer :: n, i, istoke
  !
  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 stokes_code(mystoke,istoke,error)
    if (error) then
      call map_message(seve%e,rname,'Invalid Stokes '//mystoke)
      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
  else
    call sic_ch(line,0,2,nami,n,.true.,error)
    if (error) return
    call sic_ch(line,0,3,namo,n,.true.,error)
    if (error) return
    Print *,'Not yet coded on Buffers, Using File arguments...'
  endif
  call sub_splitpolar (nami,namo,mystoke,error)  
end subroutine stokes_comm
!<FF>
subroutine sub_splitpolar(nami,namo,mystoke,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
  logical, intent(out) :: error
  !
  character(len=*), parameter :: rname='STOKES'
  type (gildas) :: hin, hou
  real(kind=4), allocatable :: din(:,:), dou(:,:)
  !
  integer, parameter :: code_stokes_all=100
  integer, parameter :: code_stokes_any=-100
  character(len=message_length) :: mess
  !
  integer i, istoke, ivisi, is, ns, iv, jv, ier, ipara
  integer astoke(4)
  integer natom, nlead, nchan, kin, kou, next
  logical extract
  real :: re, im, we
  integer intrail, ontrail, iend, oend
  real :: da, db
  integer :: ip
  integer :: kv, iloop, nblock, nvisi, mblock, multi
  !
  error = .false.
  extract = .false.
  !
  if (mystoke.eq.'NONE') then
    istoke = code_stokes_none
  elseif (mystoke.eq.'ALL') then
    istoke = code_stokes_all
  else
    call stokes_code(mystoke,istoke,error)
    if (error) then
      call map_message(seve%e,rname,'Invalid Stokes '//mystoke)
      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)
  !
  !
  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 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')
      ns = 1
      astoke(ns) = 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 '//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
      !
      ns = 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
    ns = hin%gil%nstokes
    mess = 'Input Stokes: '
    next = 20
    do i=1,ns
      mess(next:) = 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:     '//stokes_name(istoke))
    !
    !!print *,'DIN ',(din(1:10,i),i=1,10)
    !
    astoke(1:ns) = hin%gil%stokes(1:ns)
    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 (ns.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 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) &
        ) 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 '//stokes_name(astoke(1))//' and '//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 '//stokes_name(astoke(1))//' and '//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(din,dou,nvisi,nlead,natom,nchan,ns,intrail,istoke,astoke,ipara)
          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 '//stokes_name(astoke(1))//' and '//stokes_name(astoke(2)))
          error = .true.
          return
        endif
        call map_message(seve%e,rname,'Extracting '//mystoke// &
        ' from '//stokes_name(astoke(1))//' and '//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 (ns.eq.4) then
      !
      ! 4 Stokes, extract one of them
      ivisi = 0
      do i=1,ns
        if (istoke.eq.astoke(i)) then
          ivisi = i
          exit
        endif
      enddo
      if (ivisi.eq.0) then
        if ( (istoke.eq.code_stokes_none) .or. & 
          & ((istoke.ge.code_stokes_i).and.(istoke.le.code_stokes_v)) )  then
          if (hin%gil%order.eq.code_chan_stok) then
            call map_message(seve%e,rname, &
              & 'Nchan X Nstokes channel order only supported for code ALL')
            error = .true.
            return
          endif   
          !
          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) &
          ) 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
            call stokes_derive(din,dou,nvisi,nlead,natom,nchan,ns,intrail,istoke,astoke,ipara)
            !
            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 '//stokes_name(astoke(1))//stokes_name(astoke(2))//stokes_name(astoke(3))// &
          ' and '//stokes_name(astoke(4)) )
          error = .true.
          return
        endif
      else
        call map_message(seve%i,rname,'Extracting '//mystoke// &
          ' from '//stokes_name(astoke(1))//stokes_name(astoke(2))//stokes_name(astoke(3))// &
          ' and '//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,ns,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(din,dou,nvisi,nlead,natom,nchan,nstok,ntrail, &
  & istoke,astoke,ipara)
  use image_def
  !---------------------------------------------------------------------
  ! @ 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, parameter :: code_stokes_all=100
  integer, parameter :: code_stokes_any=-100
  !
  integer :: iv, jv
  integer :: kin, kou
  integer :: ic, ip, is
  real :: re, im, we, da, db
  integer :: iend, oend, multi
  real :: hh(2), hv(2), vv(2), vh(2), aa(2), bb(2), xx, yy
  logical :: debug=.false.
  !
  iend = ubound(din,1)
  oend = ubound(dou,1)
  !
  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(nstok)   ! Input Stokes parameters
    Print *, 'IPARA ', ipara ! Parallactic angle column
    Print *,'Iend ',iend,' Oend ',oend
  endif
  !
  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 (LL-RR)/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) ) then
      ! We only support HH VV HV VH order for the time being
      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(2))/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
      Print *,'Ordering ',astoke,' not supported'
    endif    
    !  
  case (code_stokes_Q,code_stokes_U)
    ! Stokes Q and U are more complex
    ! they require the parallactic angle and HH,VV,HV,VH order
    ! a proper test on ordering would be good.
    !
    ! Natom must be 3 in this case (we need complex numbers)
    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
      !
      ! We only support HH VV HV VH order for the time being
      if (ipara.eq.0) then
        Print *,'No parallactic angle column '
        return
      endif
      !
      ! 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)
      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
          xx =  cos(2*din(ipara,iv))
          yy = -sin(2*din(ipara,iv))
        else
          xx = sin(2*din(ipara,iv))
          yy = cos(2*din(ipara,iv))
        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
      !
    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
      Print *,'Ordering ',astoke,' not (yet) supported'
    else
      Print *,'Ordering ',astoke,' not supported'
    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 + 2*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
  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

