program uv_stokes
  use gkernel_interfaces
  !
  ! Extract a polarization state from a UV table 
  !
  ! Input:
  !   A UV Table with visibilities containing Nstokes x Nchan or Nchan x Nstokes
  ! Output
  !   A UV Table with visibilities of size Nchan, but potentially different
  !   polarization states.
  !
  character(len=filename_length) :: nami,namo
  character(len=12) :: mystoke
  logical error
  !
  call gildas_open
  call gildas_char('INPUT$',nami)
  call gildas_char('OUTPUT$',namo)
  call gildas_char('STOKES$',mystoke)
  call sic_upper(mystoke)
  call gildas_close
  call sic_upper(mystoke)
  call sub_stokes (nami,namo,mystoke,error)
  if (error) then
     call gagout('E-UV_STOKES,  Extraction failed')
  else
     call gagout('I-UV_STOKES,  Successful completion')
  endif
end program uv_stokes
!
subroutine sub_stokes(nami,namo,mystoke,error)
  use image_def
  use gkernel_interfaces
  use gbl_message
  !
  character(len=*), intent(inout) :: nami     ! Input file name
  character(len=*), intent(inout) :: namo     ! Output file name
  character(len=*), intent(in)    :: mystoke  ! Desired Stoke parameterr
  logical,          intent(out)   :: error
  !
  character(len=*), parameter :: rname='UV_STOKES'
  type (gildas) :: hin, hou
  real(kind=4), allocatable :: uvin(:,:), uvou(:,:)
  !
  character(len=message_length) :: mess
  !
  integer(kind=index_length) :: icolstokes,invisi,ouvisi,nchan,iend,oend,nvisi,icol,kvisi,ipara
  integer(kind=4) :: natom, nlead, istoke, istok, nstok, ier,astoke(4),iloop
  integer(kind=4) :: nblock,mblock,multi,isign,intrail,ontrail
  logical extract
  !
  ! Interfaces for Routines below
  interface
     subroutine stokes_extract(inorder,uvin,uvou,nvisi,nlead,natom,nchan,nstok,ntrail,icolstokes)
       use image_def
       real(kind=4),               intent(in)    :: uvin(:,:)
       real(kind=4),               intent(out)   :: uvou(:,:)
       integer(kind=4),            intent(in)    :: inorder ! Code order
       integer(kind=index_length), intent(in)    :: nvisi  ! number of visibilities
       integer(kind=4),            intent(in)    :: nlead  ! number of leading columns
       integer(kind=4),            intent(in)    :: natom  ! Atomic length of a visibility (2 or 3)
       integer(kind=index_length), intent(in)    :: nchan  ! number of channels
       integer(kind=4),            intent(in)    :: nstok  ! number of input Stokes
       integer(kind=4),            intent(in)    :: ntrail ! number of trailing columns
       integer(kind=index_length), intent(in)    :: icolstokes  ! Pointer into Stokes parameter
     end subroutine stokes_extract
     !
     subroutine stokes_derive_stok(uvin,uvou,nvisi,nlead,natom,nchan,nstok,ntrail,istoke,&
          astoke,ipara,isign,error)
       use image_def
       use gbl_message
       real(kind=4),               intent(in)    :: uvin(:,:)
       real(kind=4),               intent(out)   :: uvou(:,:)
       integer(kind=index_length), intent(in)    :: nvisi  ! Number of visibilities
       integer(kind=4),            intent(in)    :: nlead  ! number of leauving columns
       integer(kind=4),            intent(in)    :: natom  ! Atomic length of a visibility (2 or 3)
       integer(kind=index_length), intent(in)    :: nchan  ! number of channels
       integer(kind=4),            intent(in)    :: nstok  ! number of input Stokes
       integer(kind=4),            intent(in)    :: ntrail ! number of trailing columns
       integer(kind=4),            intent(in)    :: istoke ! desired Stokes parameter
       integer(kind=4),            intent(in)    :: astoke(nstok)   ! Input Stokes parameters
       integer(kind=index_length), intent(in)    :: ipara  ! Parallactic angle column
       integer(kind=4),            intent(in)    :: isign  ! test integer for PA angle
       logical,                    intent(inout) :: error ! Error flag
     end subroutine stokes_derive_stok
     !
     subroutine stokes_derive_chan(uvin,uvou,nvisi,nlead,natom,nchan,nstok,ntrail,istoke,&
          astoke,ipara,isign,error)
       use image_def
       use gbl_message
       real(kind=4),               intent(in)    :: uvin(:,:)
       real(kind=4),               intent(out)   :: uvou(:,:)
       integer(kind=index_length), intent(in)    :: nvisi  ! Number of visibilities
       integer(kind=4),            intent(in)    :: nlead  ! number of leauving columns
       integer(kind=4),            intent(in)    :: natom  ! Atomic length of a visibility (2 or 3)
       integer(kind=index_length), intent(in)    :: nchan  ! number of channels
       integer(kind=4),            intent(in)    :: nstok  ! number of input Stokes
       integer(kind=4),            intent(in)    :: ntrail ! number of trailing columns
       integer(kind=4),            intent(in)    :: istoke ! desired Stokes parameter
       integer(kind=4),            intent(in)    :: astoke(nstok)   ! Input Stokes parameters
       integer(kind=index_length), intent(in)    :: ipara  ! Parallactic angle column
       integer(kind=4),            intent(in)    :: isign  ! test integer for PA angle
       logical,                    intent(inout) :: error ! Error flag
     end subroutine stokes_derive_chan
  end interface
  !
  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)
        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')
  !
  hou%gil%nstokes = 1
  ! VVV What should be done here? Put the output stokes code?
  hou%gil%order = 0
  !
  call gdf_nitems('SPACE_GILDAS',nblock,hin%gil%dim(1))
  nblock = min(nblock,hin%gil%dim(2))
  !
  ! VVV In IMAGER there is a treatment of arbitrary frequency axes
  ! here, we however do not support arbitrary frequency axes.
  !
  ! 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)
     istok = hin%gil%column_pointer(code_uvt_stok)
     if (istok.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 (uvin(hin%gil%dim(1),nblock),stat=ier)
           if (failed_allocate(rname,'Input UV table',ier,error)) return
           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,uvin,error)
              if (error) return
              call gdf_write_data (hou, uvin, 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 (uvin(hin%gil%dim(1),nblock),uvou(hou%gil%dim(1),nblock),stat=ier)
        if (failed_allocate(rname,'Input and output UV tables',ier,error)) return
        !
        hin%blc = 0
        hin%trc = 0
        hou%blc = 0
        hou%trc = 0
        hou%blc(2) = 1
        ouvisi = 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))
           kvisi = hin%trc(2)-hin%blc(2)+1
           call gdf_read_data (hin,uvin,error)
           if (error) return
           ouvisi = 0
           do invisi = 1,kvisi
              if (uvin(istok,invisi).ne.istoke) cycle
              ouvisi = ouvisi+1
              uvou(:,ouvisi) = uvin(:,invisi)
           enddo
           if (ouvisi.gt.0) then
              hou%trc(2) = hou%blc(2)+ouvisi-1
              call gdf_write_data(hou,uvou,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,'Nchan channels X Nstokes stokes')
     else if (hin%gil%order.eq.code_stok_chan) then
        call map_message(seve%i,rname,'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: '
     do istok=1,nstok
        write(mess,'(2a)') trim(mess),gdf_stokes_name(hin%gil%stokes(istok))
        if (istok.ne.nstok) write(mess,'(2a)') trim(mess),', '
     enddo
     call map_message(seve%i,rname,mess)
     call map_message(seve%i,rname,'Output Stokes: '//gdf_stokes_name(istoke))
     !
     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.eq.code_stokes_i .or. istoke.eq.code_stokes_none &
             .or. istoke.eq.code_stokes_all) then
           ! Input: 2 Stokes, XX+YY or 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) &
                .or. (astoke(1).eq.code_stokes_xx.and.astoke(2).eq.code_stokes_yy) &
                .or. (astoke(2).eq.code_stokes_xx.and.astoke(1).eq.code_stokes_yy) &
                ) then
              if (istoke.eq.code_stokes_all) then
                 hou%gil%nvisi = 2*hin%gil%nvisi
                 multi = 2
                 ontrail = ontrail+1
              else
                 multi = 1
                 hou%gil%nvisi = hin%gil%nvisi
              endif
              call map_message(seve%i,rname,'Deriving '//mystoke// &
                   ' from '//gdf_stokes_name(astoke(1))//' and '//gdf_stokes_name(astoke(2)))
              ! Shift the trailing columns
              do icol=1,code_uvt_last
                 if (hou%gil%column_pointer(icol).gt.hin%gil%fcol) then
                    hou%gil%column_pointer(icol) =  hou%gil%column_pointer(icol) - &
                         & hin%gil%natom * hin%gil%nchan
                 endif
              enddo
           else
              call map_message(seve%e,rname,'Cannot derive '//mystoke// &
                   ' from '//gdf_stokes_name(astoke(1))//' and '//gdf_stokes_name(astoke(2)))
              error = .true.
              return
           endif
           !
           hou%gil%dim(2) = hou%gil%nvisi
           hou%gil%dim(1) = hin%gil%dim(1) - hin%gil%nchan*hin%gil%natom + ontrail-intrail
           oend = hou%gil%dim(1)+intrail-ontrail
           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 (uvou(hou%gil%dim(1),mblock),uvin(hin%gil%dim(1),nblock),stat=ier)
           if (failed_allocate(rname,'Input and output UV tables',ier,error)) return
           !
           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,uvin,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
                    ouvisi = 0
                    do invisi = 1,nvisi
                       ouvisi = ouvisi+1
                       uvou(1:nlead,ouvisi) = uvin(1:nlead,invisi)
                       uvou(nlead+1:nlead+natom*nchan,ouvisi) = uvin(nlead+1:nlead+natom*nchan,invisi)
                       if (ontrail.ne.intrail) uvou(oend+1,ouvisi) = astoke(1)
                       if (intrail.gt.0) uvou(1+nlead+natom*nchan:oend,ouvisi) = &
                            uvin(nlead+1+2*natom*nchan:iend,invisi)
                       ouvisi = ouvisi+1
                       uvou(1:nlead,ouvisi) = uvin(1:nlead,invisi)
                       uvou(nlead+1:nlead+natom*nchan,ouvisi) = &
                            uvin(nlead+1+natom*nchan:nlead+2*natom*nchan,invisi)
                       if (ontrail.ne.intrail) uvou(oend+1,ouvisi) = astoke(2)
                       if (intrail.gt.0) uvou(1+nlead+natom*nchan:oend,ouvisi) = &
                            uvin(nlead+1+2*natom*nchan:iend,invisi)
                    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(uvin,uvou,nvisi,nlead,natom,nchan,nstok,intrail, &
                      & istoke,astoke,ipara,isign,error)
                 if (error) return
              endif
              hou%trc(2) = hou%blc(2)+ouvisi-1
              call gdf_write_data(hou,uvou,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
              icolstokes = 1
           else if (istoke.eq.astoke(2)) then
              icolstokes = 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 columnstok
           do icol=1,code_uvt_last
              if (hou%gil%column_pointer(icol).gt.hin%gil%fcol) then
                 hou%gil%column_pointer(icol) =  hou%gil%column_pointer(icol) - &
                      & hin%gil%natom * hin%gil%nchan
              endif
           enddo
        endif
     else if (nstok.eq.4) then
        ! 4 Stokes, extract one of them
        icolstokes = 0
        do istok=1,nstok
           if (istoke.eq.astoke(istok)) then
              icolstokes = istok
              exit
           endif
        enddo
        if (icolstokes.eq.0) then
           if ( (istoke.eq.code_stokes_none) .or. & 
                & ((istoke.ge.code_stokes_i).and.(istoke.le.code_stokes_v)) )  then
              !
              ! Is derivation possible ?
              if ( (astoke(1).eq.code_stokes_hh.and.astoke(2).eq.code_stokes_vv) &
                   .or. (astoke(2).eq.code_stokes_hh.and.astoke(1).eq.code_stokes_vv) &
                   .or. (astoke(1).eq.code_stokes_ll.and.astoke(2).eq.code_stokes_rr) &
                   .or. (astoke(2).eq.code_stokes_ll.and.astoke(1).eq.code_stokes_rr) &
                   .or. (astoke(1).eq.code_stokes_xx.and.astoke(2).eq.code_stokes_yy) &
                   .or. (astoke(2).eq.code_stokes_xx.and.astoke(1).eq.code_stokes_yy) &
                   ) then
                 continue
              else
                 call map_message(seve%e,rname, &
                      & 'Unsupported Stokes ordering ')
                 error = .true.
                 return
              endif
              !
              multi = 1   ! 1 output visibility per input Visibility      
              ! Shift the trailing columns
              do icol=1,code_uvt_last
                 if (hou%gil%column_pointer(icol).gt.hin%gil%fcol) then
                    hou%gil%column_pointer(icol) =  hou%gil%column_pointer(icol) - &
                         & 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
              !
              ! 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 (uvou(hou%gil%dim(1),mblock),uvin(hin%gil%dim(1),nblock),stat=ier)
              if (failed_allocate(rname,'Input and output UV tables',ier,error)) return
              !
              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,uvin,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(uvin,uvou,nvisi,nlead,natom,nchan,nstok, &
                         & intrail,istoke,astoke,ipara,isign,error)            
                 else
                    call stokes_derive_stok(uvin,uvou,nvisi,nlead,natom,nchan,nstok, &
                         & intrail,istoke,astoke,ipara,isign,error)
                 endif
                 if (error) return
                 !
                 hou%trc(2) = hou%blc(2)+multi*nvisi-1
                 call gdf_write_data(hou,uvou,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
           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 icol=1,code_uvt_last
              if (hou%gil%column_pointer(icol).gt.hin%gil%fcol) then
                 hou%gil%column_pointer(icol) =  hou%gil%column_pointer(icol) - &
                      & 3 * hin%gil%natom * hin%gil%nchan
              endif
           enddo
        endif
     endif
     ! The extraction code makes no assumption about the Stokes order.
     if (extract) then
        call gdf_create_image(hou,error)
        if (error) return
        allocate (uvou(hou%gil%dim(1),nblock),uvin(hin%gil%dim(1),nblock),stat=ier)
        if (failed_allocate(rname,'Input and output UV tables',ier,error)) return
        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))
           nvisi = hin%trc(2)-hin%blc(2)+1
           call gdf_read_data(hin,uvin,error)
           if (error) return
           call stokes_extract(hin%gil%order,uvin,uvou,nvisi,nlead,natom,nchan,nstok,intrail,icolstokes)
           hou%trc(2) = hou%blc(2)+kvisi-1
           call gdf_write_data(hou,uvou,error)
           hou%blc(2) = hou%trc(2)+1
        enddo
     endif
     call gdf_close_image(hou,error)
  endif
end subroutine sub_stokes
!
subroutine stokes_extract(inorder,uvin,uvou,nvisi,nlead,natom,nchan,nstok,ntrail,icolstokes)
  use image_def
  !---------------------------------------------------------------------
  ! Support routine for UV_STOKES task: extract the relevant Stokes
  ! parameter from the input visibilities.
  !---------------------------------------------------------------------
  real(kind=4),               intent(in)    :: uvin(:,:)
  real(kind=4),               intent(out)   :: uvou(:,:)
  integer(kind=4),            intent(in)    :: inorder ! Code order
  integer(kind=index_length), intent(in)    :: nvisi  ! number of visibilities
  integer(kind=4),            intent(in)    :: nlead  ! number of leading columns
  integer(kind=4),            intent(in)    :: natom  ! Atomic length of a visibility (2 or 3)
  integer(kind=index_length), intent(in)    :: nchan  ! number of channels
  integer(kind=4),            intent(in)    :: nstok  ! number of input Stokes
  integer(kind=4),            intent(in)    :: ntrail ! number of trailing columns
  integer(kind=index_length), intent(in)    :: icolstokes  ! Pointer into Stokes parameter
  !
  integer(kind=index_length) :: ivisi,ichan,incol, oucol
  !
  if (inorder.eq.code_chan_stok) then
    ! Nchan X Nstokes channels
    do ivisi = 1,nvisi
      uvou(1:nlead,ivisi) = uvin(1:nlead,ivisi)
      uvou(nlead+1:nlead+natom*nchan,ivisi) = &
      & uvin(nlead+1+(icolstokes-1)*natom*nchan:nlead+icolstokes*natom*nchan,ivisi)
      if (ntrail.gt.0) uvou(1+nlead+natom*nchan:,ivisi) = uvin(nlead+1+nstok*natom*nchan:,ivisi)
    enddo
  else
    ! Nstokes x Nchan channels
    do ivisi = 1,nvisi 
      uvou(1:nlead,ivisi) = uvin(1:nlead,ivisi)
      incol = nlead+(icolstokes-1)*natom
      oucol = nlead
      do ichan=1,nchan
        uvou(oucol+1:oucol+natom,ivisi) = uvin(incol+1:incol+natom,ivisi)
        oucol = oucol + natom
        incol = incol + nstok*natom
      enddo
      if (ntrail.gt.0) uvou(1+nlead+natom*nchan:,ivisi) = uvin(nlead+1+nstok*natom*nchan:,ivisi)
    enddo
  endif
end subroutine stokes_extract
!
subroutine stokes_derive_stok(uvin,uvou,nvisi,nlead,natom,nchan,nstok,ntrail,istoke,astoke,ipara,isign,error)
  use image_def
  use gbl_message
  !---------------------------------------------------------------------
  ! Support routine for UV_STOKES task: Derive the relevant Stokes
  ! parameter from the input visibilities. This routine works with the
  ! CODE_STOKE_CHAN order, and 2 or 4 input Stokes parameters. Not all
  ! combinations of in and out stokes parameters are allowed.
  !---------------------------------------------------------------------
  real(kind=4),               intent(in)    :: uvin(:,:)
  real(kind=4),               intent(out)   :: uvou(:,:)
  integer(kind=index_length), intent(in)    :: nvisi  ! Number of visibilities
  integer(kind=4),            intent(in)    :: nlead  ! number of leauving columns
  integer(kind=4),            intent(in)    :: natom  ! Atomic length of a visibility (2 or 3)
  integer(kind=index_length), intent(in)    :: nchan  ! number of channels
  integer(kind=4),            intent(in)    :: nstok  ! number of input Stokes
  integer(kind=4),            intent(in)    :: ntrail ! number of trailing columns
  integer(kind=4),            intent(in)    :: istoke ! desired Stokes parameter
  integer(kind=4),            intent(in)    :: astoke(nstok)   ! Input Stokes parameters
  integer(kind=index_length), intent(in)    :: ipara  ! Parallactic angle column
  integer(kind=4),            intent(in)    :: isign  ! test integer for PA angle
  logical,                    intent(inout) :: error ! Error flag
  !
  character(len=*), parameter :: rname='STOKES>DERIVE>STOK'
  !
  character(len=message_length) :: mess
  integer(kind=index_length) :: invisi, ouvisi, incol, oucol, ichan, iend, oend
  integer(kind=4) :: ip, istok
  real(kind=4) :: re, im, we, da, db
  integer(kind=4)  ::  multi, jsign
  real(kind=4)  :: hh(2), hv(2), vv(2), vh(2), aa(2), bb(2), xx, yy
  real(kind=4)  :: rr(2), ll(2), rl(2), lr(2)
  logical :: good_order, circular
  !
  iend = ubound(uvin,1)
  oend = ubound(uvou,1)
  !
  if (istoke.eq.code_stokes_all) then
     multi = nstok
     oend = oend-1
  else
     multi = 1
  endif
  ouvisi = 0
  select case(istoke)
  case (code_stokes_none)  
     ! Stokes NONE: Unpolarized case - optimize sensitivity
     ouvisi = 0
     do invisi = 1,nvisi
        ouvisi = ouvisi+1
        uvou(1:nlead,ouvisi) = uvin(1:nlead,invisi)
        incol = nlead
        oucol = nlead
        do ichan=1,nchan
           if (natom.eq.3) then ! Real, Image, Weight
              if (uvin(incol+3,invisi).gt.0) then
                 re = uvin(incol+1,invisi) * uvin(incol+3,invisi)
                 im = uvin(incol+2,invisi) * uvin(incol+3,invisi)
                 we = uvin(incol+3,invisi)
              else
                 re = 0
                 im = 0
                 we = 0
              endif
              incol = incol+natom
              if (uvin(incol+3,invisi).gt.0) then
                 re = re + uvin(incol+1,invisi) * uvin(incol+3,invisi)
                 im = im + uvin(incol+2,invisi) * uvin(incol+3,invisi)
                 we = we + uvin(incol+3,invisi)
              endif
              if (we.ne.0) then
                 uvou(oucol+1:oucol+1,ouvisi) = re/we
                 uvou(oucol+2:oucol+2,ouvisi) = im/we
                 uvou(oucol+3:oucol+3,ouvisi) = we
              else
                 uvou(oucol+1:oucol+3,ouvisi) = 0
              endif
           else if (natom.eq.2) then
              ! Only Real Weight
              if (uvin(incol+2,invisi).gt.0) then
                 re = uvin(incol+1,invisi) * uvin(incol+2,invisi)
                 we = uvin(incol+2,invisi)
              else
                 re = 0
                 we = 0
              endif
              incol = incol+natom
              if (uvin(incol+2,invisi).gt.0) then
                 re = re + uvin(incol+1,invisi) * uvin(incol+2,invisi)
                 we = we + uvin(incol+2,invisi)
              endif
              if (we.ne.0) then
                 uvou(oucol+1:oucol+1,ouvisi) = re/we
                 uvou(oucol+2:oucol+2,ouvisi) = we
              else
                 uvou(oucol+1:oucol+2,ouvisi) = 0
              endif
           endif
           ! Skip the HV and VH or LR and RL values
           incol = incol + (nstok-2)*natom
           oucol = oucol + natom
           incol = incol + natom
        enddo
        ! Fill trailing columns
        if (ntrail.gt.0) uvou(1+nlead+natom*nchan:oend,ouvisi) = &
             uvin(nlead+1+nstok*natom*nchan:iend,invisi)
     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 invisi=1,nvisi
        ouvisi = ouvisi+1
        uvou(1:nlead,ouvisi) = uvin(1:nlead,invisi)
        incol = nlead
        oucol = nlead
        do ichan=1,nchan
           if (uvin(incol+natom,invisi).gt.0)  then
              uvou(oucol+1:oucol+natom,ouvisi) = uvin(incol+1:incol+natom-1,invisi)  ! Visib
              da = 1.0/uvin(incol+natom,invisi) ! Noise**2
              ip = 1
           else
              da = 0.0
              ip = 0
           endif
           incol = incol+natom
           if (uvin(incol+natom,invisi).gt.0)  then
              uvou(oucol+1:oucol+natom-1,ouvisi) = uvou(oucol+1:oucol+natom-1,ouvisi) + &
                   uvin(incol+1:incol+natom-1,invisi)
              db = 1.0/uvin(incol+natom,invisi)  ! Noise**2
              ip = ip+1
           else
              db = 0.0
           endif
           if (ip.eq.2) then
              uvou(oucol+1:oucol+natom-1,ouvisi) = uvou(oucol+1:oucol+natom-1,ouvisi) / ip
              uvou(oucol+natom,ouvisi) = 4.0/(da+db)   ! Weight = 1/noise^2
           else
              uvou(oucol+natom,ouvisi) = 0.0
           endif
           ! Skip the HV and VH or LR and RL values
           incol = incol + (nstok-2)*natom
           oucol = oucol + natom
           incol = incol + natom
        enddo
        ! Fill trailing columns
        if (ntrail.gt.0) uvou(1+nlead+natom*nchan:oend,ouvisi) = &
             uvin(nlead+1+nstok*natom*nchan:iend,invisi)
     enddo
  case (code_stokes_V)
     ! Stokes V is -j(HV-VH)/2 or -j(XY-YX)/2 or (RR-LL)/2
     ! a proper test on ordering would be good.
     ! Natom must be 3 in this case (we need complex numbers)
     if ( ((astoke(3).eq.code_stokes_hv).and.(astoke(4).eq.code_stokes_vh)) &
          & .or. ((astoke(3).eq.code_stokes_xy).and.(astoke(4).eq.code_stokes_yx)) &
          & ) then
        ! We only support HH VV HV VH and XX YY XY YX order for the time being
        ! V = -j (XY-YX)/2  =  -j (HV-VH)/2
        do invisi=1,nvisi
           ouvisi = ouvisi+1
           uvou(1:nlead,ouvisi) = uvin(1:nlead,invisi)
           incol = nlead
           oucol = nlead
           incol = incol+2*natom ! Skipp HH and VV 
           do ichan=1,nchan
              if (uvin(incol+natom,invisi).gt.0)  then
                 HV(1:2) = uvin(incol+1:incol+natom-1,invisi)  
                 da = 1.0/uvin(incol+natom,invisi) ! Noise**2
                 ip = 1
              else
                 da = 0.0
                 ip = 0
              endif
              incol = incol+natom
              if (uvin(incol+natom,invisi).gt.0)  then
                 VH(1:2) = uvin(incol+1:incol+natom-1,invisi)
                 db = 1.0/uvin(incol+natom,invisi)  ! Noise**2
                 ip = ip+1
              else
                 db = 0.0
              endif
              if (ip.eq.2) then
                 uvou(oucol+1:oucol+1,ouvisi) = +(hv(2)-vh(2))/2          
                 uvou(oucol+2:oucol+2,ouvisi) = -(hv(1)-vh(1))/2
                 uvou(oucol+natom,ouvisi) = 4.0/(da+db)   ! Weight = 1/noise^2
              else
                 uvou(oucol+natom,ouvisi) = 0.0
              endif
              oucol = oucol + natom
              incol = incol + natom
           enddo
           ! Fill trailing columns
           if (ntrail.gt.0) uvou(1+nlead+natom*nchan:oend,ouvisi) = &
                uvin(nlead+1+nstok*natom*nchan:iend,invisi)
        enddo
        !
     elseif ( (astoke(1).eq.code_stokes_rr).and.(astoke(2).eq.code_stokes_ll) .and. & 
          &  (astoke(3).eq.code_stokes_rl).and.(astoke(4).eq.code_stokes_lr) ) then
        ! (RR - LL ) /2
        do invisi=1,nvisi
           ouvisi = ouvisi+1
           uvou(1:nlead,ouvisi) = uvin(1:nlead,invisi)
           incol = nlead
           oucol = nlead
           do ichan=1,nchan
              if (uvin(incol+natom,invisi).gt.0)  then
                 RR(1:2) = uvin(incol+1:incol+natom-1,invisi)  
                 da = 1.0/uvin(incol+natom,invisi) ! Noise**2
                 ip = 1
              else
                 da = 0.0
                 ip = 0
              endif
              incol = incol+natom
              if (uvin(incol+natom,invisi).gt.0)  then
                 LL(1:2) = uvin(incol+1:incol+natom-1,invisi)
                 db = 1.0/uvin(incol+natom,invisi)  ! Noise**2
                 ip = ip+1
              else
                 db = 0.0
              endif
              if (ip.eq.2) then
                 uvou(oucol+1:oucol+2,ouvisi) = (rr-ll)/2
                 uvou(oucol+natom,ouvisi) = 4.0/(da+db)   ! Weight = 1/noise^2
              else
                 uvou(oucol+natom,ouvisi) = 0.0
              endif
              oucol = oucol + natom
              incol = incol + natom
              incol = incol+2*natom ! Skip RL and LR 
           enddo
           ! Fill trailing columns
           if (ntrail.gt.0) uvou(1+nlead+natom*nchan:oend,ouvisi) = &
                uvin(nlead+1+nstok*natom*nchan:iend,invisi)
        enddo
     else
        write(mess,'(A,4(1X,I0),A)') 'Ordering ',astoke,' not supported'
        call map_message(seve%e,rname,mess)
        error = .true.
        return
     endif
  case (code_stokes_Q,code_stokes_U)
     ! Stokes Q and U are more complex
     ! From HH,VV etc..., they require the parallactic angle and HH,VV,HV,VH order
     ! From XX,YY etc..., they require XX,YY,XY,YX order, but no parallactic angle
     ! a proper test on ordering would be good.
     ! Natom must be 3 in this case (we need complex numbers)
     good_order = .false.
     circular = .false.
     if ( (astoke(1).eq.code_stokes_hh).and.(astoke(2).eq.code_stokes_vv) .and. & 
          &  (astoke(3).eq.code_stokes_hv).and.(astoke(4).eq.code_stokes_vh) ) then
        if (ipara.eq.0) then
           call map_message(seve%e,rname,'No parallactic angle column ')
           error = .true.
           return
        endif
        jsign = isign ! Temporary, normally should be 1
        good_order = .true.
     else if ( (astoke(1).eq.code_stokes_xx).and.(astoke(2).eq.code_stokes_yy) .and. & 
          &  (astoke(3).eq.code_stokes_xy).and.(astoke(4).eq.code_stokes_yx) ) then
        jsign = 0
        good_order = .true.
     elseif ( (astoke(1).eq.code_stokes_rr).and.(astoke(2).eq.code_stokes_ll) .and. & 
          &  (astoke(3).eq.code_stokes_rl).and.(astoke(4).eq.code_stokes_lr) ) then
        write(mess,'(A,4(1X,I0),A)') 'Ordering ',astoke,' not fully tested'
        call map_message(seve%w,rname,mess)
        good_order = .false.
        circular = .true.
     else
        write(mess,'(A,4(1X,I0),A)') 'Ordering ',astoke,' not supported '
        call map_message(seve%e,rname,mess)
        error = .true.
        return
     endif
     if (good_order) then
        ! compute aa = (HH-VV)/2   and bb = (HV+VH)/2 then
        !  Q = aa cos(2.phi) - bb sin(2.phi)
        !  U = aa sin(2.phi) + bb cos(2.phi)
        ! or
        ! compute aa = (XX-YY)/2   and bb = (XY+YX)/2 then
        !  Q = aa 
        !  U = bb
        db = 0 ! to avoid initialization warnings.
        do invisi=1,nvisi
           ouvisi = ouvisi+1
           uvou(1:nlead,ouvisi) = uvin(1:nlead,invisi)
           incol = nlead
           oucol = nlead
           !
           if (istoke.eq.code_stokes_q) then
              if (jsign.ne.0) then
                 xx =  cos(2*jsign*uvin(ipara,invisi))
                 yy = -sin(2*jsign*uvin(ipara,invisi))
              else
                 xx = 1.0
                 yy = 0.0
              endif
           else
              if (jsign.ne.0) then
                 xx = sin(2*jsign*uvin(ipara,invisi))
                 yy = cos(2*jsign*uvin(ipara,invisi))
              else
                 xx = 0.0
                 yy = 1.0
              endif
           endif
           do ichan=1,nchan
              if (uvin(incol+natom,invisi).gt.0)  then
                 HH(1:2) = uvin(incol+1:incol+natom-1,invisi)  
                 da = 1.0/uvin(incol+natom,invisi) ! Noise**2
                 ip = 1
              else
                 da = 0.0
                 ip = 0
              endif
              incol = incol+natom
              if (uvin(incol+natom,invisi).gt.0)  then
                 VV(1:2) = uvin(incol+1:incol+natom-1,invisi)
                 db = 1.0/uvin(incol+natom,invisi)  ! Noise**2
                 ip = ip+1
              endif
              incol = incol+natom
              if (uvin(incol+natom,invisi).gt.0)  then
                 HV(1:2) = uvin(incol+1:incol+natom-1,invisi)
                 ip = ip+1
              endif
              incol = incol+natom
              if (uvin(incol+natom,invisi).gt.0)  then
                 VH(1:2) = uvin(incol+1:incol+natom-1,invisi)
                 ip = ip+1
              endif
              aa = (HH-VV)/2
              bb = (HV+VH)/2
              if (ip.eq.4) then
                 uvou(oucol+1:oucol+2,ouvisi) = xx*aa + yy*bb
                 uvou(oucol+natom,ouvisi) = 4.0/(da+db)   ! Weight = 1/noise^2
              else
                 uvou(oucol+natom,ouvisi) = 0.0
              endif
              oucol = oucol + natom
              incol = incol + natom
           enddo
           ! Fill trailing columns
           if (ntrail.gt.0) uvou(1+nlead+natom*nchan:oend,ouvisi) = &
                uvin(nlead+1+nstok*natom*nchan:iend,invisi)
        enddo
     else if (circular) then
        db = 0   ! Avoid initialization warning
        do invisi=1,nvisi
           ouvisi = ouvisi+1
           uvou(1:nlead,ouvisi) = uvin(1:nlead,invisi)
           incol = nlead
           oucol = nlead
           do ichan=1,nchan
              if (uvin(incol+natom,invisi).gt.0)  then
                 RR(1:2) = uvin(incol+1:incol+natom-1,invisi)  
                 da = 1.0/uvin(incol+natom,invisi) ! Noise**2
                 ip = 1
              else
                 da = 0.0
                 ip = 0
              endif
              incol = incol+natom
              if (uvin(incol+natom,invisi).gt.0)  then
                 LL(1:2) = uvin(incol+1:incol+natom-1,invisi)
                 db = 1.0/uvin(incol+natom,invisi)  ! Noise**2
                 ip = ip+1
              endif
              incol = incol+natom
              if (uvin(incol+natom,invisi).gt.0)  then
                 RL(1:2) = uvin(incol+1:incol+natom-1,invisi)
                 ip = ip+1
              endif
              incol = incol+natom
              if (uvin(incol+natom,invisi).gt.0)  then
                 LR(1:2) = uvin(incol+1:incol+natom-1,invisi)
                 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
                 uvou(oucol+1:oucol+2,ouvisi) = bb !! 
                 uvou(oucol+natom,ouvisi) = 4.0/(da+db)   ! Weight = 1/noise^2
              else
                 uvou(oucol+natom,ouvisi) = 0.0
              endif
              oucol = oucol + natom
              incol = incol + natom
           enddo
           ! Fill trailing columns
           if (ntrail.gt.0) uvou(1+nlead+natom*nchan:oend,ouvisi) = &
                uvin(nlead+1+nstok*natom*nchan:iend,invisi)
        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 invisi=1,nvisi
        do istok=1,nstok
           ouvisi = ouvisi+1
           uvou(1:nlead,ouvisi) = uvin(1:nlead,invisi)
           incol = nlead
           oucol = nlead
           do ichan=1,nchan
              uvou(oucol+1:oucol+natom,ouvisi) = uvin(incol+1:incol+natom,invisi)
              oucol = oucol + natom
              incol = incol + nstok*natom
           enddo
           if (ntrail.gt.0) uvou(1+nlead+natom*nchan:oend,ouvisi) = &
                uvin(nlead+1+nstok*natom*nchan:iend,invisi)
           uvou(oend+1,ouvisi) = astoke(istok)
        enddo
     enddo
  case default
     write(mess,'(a,i0,a)') 'Case ',istoke,' Not supported'
     call map_message(seve%e,rname,mess)
     error = .true.
     return
  end select
  ! Sanity check
  if (ouvisi.ne.multi*nvisi) then
     write(mess,'(2(a,i0))') 'Expecting up to ',nvisi,' visibilities, found ',ouvisi
     call map_message(seve%e,rname,mess)
     error = .true.
     return
  endif
end subroutine stokes_derive_stok
!
subroutine stokes_derive_chan(uvin,uvou,nvisi,nlead,natom,nchan,nstok,ntrail,istoke,astoke,ipara,isign,error)
  use image_def
  use gbl_message
  !---------------------------------------------------------------------
  ! Support routine for UV_STOKES task: Derive the relevant Stokes
  ! parameter from the input visibilities. This routine works with the
  ! CODE_CHAN_STOKE order, and 2 or 4 input Stokes parameters. Not all
  ! combinations of in and out stokes parameters are allowed.
  !---------------------------------------------------------------------
  real(kind=4),               intent(in)    :: uvin(:,:)
  real(kind=4),               intent(out)   :: uvou(:,:)
  integer(kind=index_length), intent(in)    :: nvisi  ! Number of visibilities
  integer(kind=4),            intent(in)    :: nlead  ! number of leauving columns
  integer(kind=4),            intent(in)    :: natom  ! Atomic length of a visibility (2 or 3)
  integer(kind=index_length), intent(in)    :: nchan  ! number of channels
  integer(kind=4),            intent(in)    :: nstok  ! number of input Stokes
  integer(kind=4),            intent(in)    :: ntrail ! number of trailing columns
  integer(kind=4),            intent(in)    :: istoke ! desired Stokes parameter
  integer(kind=4),            intent(in)    :: astoke(nstok)   ! Input Stokes parameters
  integer(kind=index_length), intent(in)    :: ipara  ! Parallactic angle column
  integer(kind=4),            intent(in)    :: isign  ! test integer for PA angle
  logical,                    intent(inout) :: error ! Error flag
  !
  character(len=*), parameter :: rname='STOKES>DERIVE>CHAN'
  !
  character(len=message_length) :: mess
  integer(kind=index_length) :: invisi, ouvisi, incol, oucol, ichan, iend, oend
  integer(kind=4) :: ip, istok
  real(kind=4) :: re, im, we, da, db
  integer(kind=4)  ::  multi, jsign
  real(kind=4)  :: hh(2), hv(2), vv(2), vh(2), aa(2), bb(2), xx, yy
  real(kind=4)  :: rr(2), ll(2), rl(2), lr(2)
  logical :: good_order, circular
  !
  if (istoke.eq.code_stokes_all) then
     multi = nstok
     oend = oend-1
  else
     multi = 1
  endif
  ouvisi = 0
  select case(istoke)
  case (code_stokes_none)  
     ! Stokes NONE: Unpolarized case - optimize sensitivity
     ! Order HH,VV  or LL,RR
     ouvisi = 0
     do invisi = 1,nvisi
        ouvisi = ouvisi+1
        uvou(1:nlead,ouvisi) = uvin(1:nlead,invisi)
        incol = nlead
        oucol = nlead
        do ichan=1,nchan
           if (natom.eq.3) then ! Real, Image, Weight
              if (uvin(incol+3,invisi).gt.0) then
                 re = uvin(incol+1,invisi) * uvin(incol+3,invisi)
                 im = uvin(incol+2,invisi) * uvin(incol+3,invisi)
                 we = uvin(incol+3,invisi)
              else
                 re = 0
                 im = 0
                 we = 0
              endif
              incol = incol+natom*nchan  ! Skip NCHAN channels
              if (uvin(incol+3,invisi).gt.0) then
                 re = re + uvin(incol+1,invisi) * uvin(incol+3,invisi)
                 im = im + uvin(incol+2,invisi) * uvin(incol+3,invisi)
                 we = we + uvin(incol+3,invisi)
              endif
              if (we.ne.0) then
                 uvou(oucol+1:oucol+1,ouvisi) = re/we
                 uvou(oucol+2:oucol+2,ouvisi) = im/we
                 uvou(oucol+3:oucol+3,ouvisi) = we
              else
                 uvou(oucol+1:oucol+3,ouvisi) = 0
              endif
           else if (natom.eq.2) then
              ! Only Real Weight
              if (uvin(incol+2,invisi).gt.0) then
                 re = uvin(incol+1,invisi) * uvin(incol+2,invisi)
                 we = uvin(incol+2,invisi)
              else
                 re = 0
                 we = 0
              endif
              incol = incol+natom*nchan
              if (uvin(incol+2,invisi).gt.0) then
                 re = re + uvin(incol+1,invisi) * uvin(incol+2,invisi)
                 we = we + uvin(incol+2,invisi)
              endif
              if (we.ne.0) then
                 uvou(oucol+1:oucol+1,ouvisi) = re/we
                 uvou(oucol+2:oucol+2,ouvisi) = we
              else
                 uvou(oucol+1:oucol+2,ouvisi) = 0
              endif
           endif
           ! Skip the HV and VH or LR and RL values
           incol = incol - natom*nchan
           ! Increment by 1 channel
           oucol = oucol + natom
           incol = incol + natom
        enddo
        ! Fill trailing columns
        if (ntrail.gt.0) uvou(1+nlead+natom*nchan:oend,ouvisi) = &
             uvin(nlead+1+nstok*natom*nchan:iend,invisi)
     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 sensitinvisiity, use Stokes NONE
     do invisi=1,nvisi
        ouvisi = ouvisi+1
        uvou(1:nlead,ouvisi) = uvin(1:nlead,invisi)
        incol = nlead
        oucol = nlead
        do ichan=1,nchan
           if (uvin(incol+natom,invisi).gt.0)  then
              uvou(oucol+1:oucol+natom,ouvisi) = uvin(incol+1:incol+natom-1,invisi)  ! Visib
              da = 1.0/uvin(incol+natom,invisi) ! Noise**2
              ip = 1
           else
              da = 0.0
              ip = 0
           endif
           incol = incol+natom*nchan
           if (uvin(incol+natom,invisi).gt.0)  then
              uvou(oucol+1:oucol+natom-1,ouvisi) = uvou(oucol+1:oucol+natom-1,ouvisi) + &
                   uvin(incol+1:incol+natom-1,invisi)
              db = 1.0/uvin(incol+natom,invisi)  ! Noise**2
              ip = ip+1
           else
              db = 0.0
           endif
           if (ip.eq.2) then
              uvou(oucol+1:oucol+natom-1,ouvisi) = uvou(oucol+1:oucol+natom-1,ouvisi) / ip
              uvou(oucol+natom,ouvisi) = 4.0/(da+db)   ! Weight = 1/noise^2
           else
              uvou(oucol+natom,ouvisi) = 0.0
           endif
           ! Skip the HV and VH or LR and RL values
           incol = incol - natom*nchan
           oucol = oucol + natom
           incol = incol + natom
        enddo
        ! Fill trailing columns
        if (ntrail.gt.0) uvou(1+nlead+natom*nchan:oend,ouvisi) = &
             uvin(nlead+1+nstok*natom*nchan:iend,invisi)
     enddo
  case (code_stokes_V)
     ! Stokes V is -j(HV-VH)/2 or -j(XY-YX)/2 or (RR-LL)/2
     ! a proper test on ordering would be good.
     ! Natom must be 3 in this case (we need complex numbers)
     if ( ((astoke(3).eq.code_stokes_hv).and.(astoke(4).eq.code_stokes_vh)) &
          & .or. ((astoke(3).eq.code_stokes_xy).and.(astoke(4).eq.code_stokes_yx)) &
          & ) then
        ! We only support HH VV HV VH and XX YY XY YX order for the time being
        ! V = -j (XY-YX)/2  =  -j (HV-VH)/2
        do invisi=1,nvisi
           ouvisi = ouvisi+1
           uvou(1:nlead,ouvisi) = uvin(1:nlead,invisi)
           incol = nlead
           oucol = nlead
           incol = incol+2*nchan*natom ! Skipp HH and VV 
           do ichan=1,nchan
              if (uvin(incol+natom,invisi).gt.0)  then
                 HV(1:2) = uvin(incol+1:incol+natom-1,invisi)  
                 da = 1.0/uvin(incol+natom,invisi) ! Noise**2
                 ip = 1
              else
                 da = 0.0
                 ip = 0
              endif
              incol = incol+natom*nchan
              if (uvin(incol+natom,invisi).gt.0)  then
                 VH(1:2) = uvin(incol+1:incol+natom-1,invisi)
                 db = 1.0/uvin(incol+natom,invisi)  ! Noise**2
                 ip = ip+1
              else
                 db = 0.0
              endif
              if (ip.eq.2) then
                 uvou(oucol+1:oucol+1,ouvisi) = +(hv(2)-vh(2))/2          
                 uvou(oucol+2:oucol+2,ouvisi) = -(hv(1)-vh(1))/2
                 uvou(oucol+natom,ouvisi) = 4.0/(da+db)   ! Weight = 1/noise^2
              else
                 uvou(oucol+natom,ouvisi) = 0.0
              endif
              incol = incol - natom*nchan
              oucol = oucol + natom
              incol = incol + natom
           enddo
           ! Fill trailing columns
           if (ntrail.gt.0) uvou(1+nlead+natom*nchan:oend,ouvisi) = &
                uvin(nlead+1+nstok*natom*nchan:iend,invisi)
        enddo
     elseif ( (astoke(1).eq.code_stokes_rr).and.(astoke(2).eq.code_stokes_ll) .and. & 
          &  (astoke(3).eq.code_stokes_rl).and.(astoke(4).eq.code_stokes_lr) ) then
        ! (RR - LL ) /2
        do invisi=1,nvisi
           ouvisi = ouvisi+1
           uvou(1:nlead,ouvisi) = uvin(1:nlead,invisi)
           incol = nlead
           oucol = nlead
           do ichan=1,nchan
              if (uvin(incol+natom,invisi).gt.0)  then
                 RR(1:2) = uvin(incol+1:incol+natom-1,invisi)  
                 da = 1.0/uvin(incol+natom,invisi) ! Noise**2
                 ip = 1
              else
                 da = 0.0
                 ip = 0
              endif
              incol = incol+natom*nchan
              if (uvin(incol+natom,invisi).gt.0)  then
                 LL(1:2) = uvin(incol+1:incol+natom-1,invisi)
                 db = 1.0/uvin(incol+natom,invisi)  ! Noise**2
                 ip = ip+1
              else
                 db = 0.0
              endif
              if (ip.eq.2) then
                 uvou(oucol+1:oucol+2,ouvisi) = (rr-ll)/2
                 uvou(oucol+natom,ouvisi) = 4.0/(da+db)   ! Weight = 1/noise^2
              else
                 uvou(oucol+natom,ouvisi) = 0.0
              endif
              incol = incol - natom*nchan ! Skip RL and LR if present
              oucol = oucol + natom
              incol = incol + natom
           enddo
           ! Fill trailing columns
           if (ntrail.gt.0) uvou(1+nlead+natom*nchan:oend,ouvisi) = &
                uvin(nlead+1+nstok*natom*nchan:iend,invisi)
        enddo
     else
        write(mess,'(A,4(1X,I0),A)') 'Ordering ',astoke,' not supported'
        call map_message(seve%e,rname,mess)
        error = .true.
        return
     endif
  case (code_stokes_Q,code_stokes_U)
     ! Stokes Q and U are more complex
     ! From HH,VV etc..., they require the parallactic angle and HH,VV,HV,VH order
     ! From XX,YY etc..., they require XX,YY,XY,YX order, but no parallactic angle
     ! a proper test on ordering would be good.
     ! Natom must be 3 in this case (we need complex numbers)
     good_order = .false.
     circular = .false.
     if ( (astoke(1).eq.code_stokes_hh).and.(astoke(2).eq.code_stokes_vv) .and. & 
          &  (astoke(3).eq.code_stokes_hv).and.(astoke(4).eq.code_stokes_vh) ) then
        if (ipara.eq.0) then
           call map_message(seve%e,rname,'No parallactic angle column ')
           error = .true.
           return
        endif
        jsign = isign ! Temporary, normally should be 1
        good_order = .true.
     else if ( (astoke(1).eq.code_stokes_xx).and.(astoke(2).eq.code_stokes_yy) .and. & 
          &  (astoke(3).eq.code_stokes_xy).and.(astoke(4).eq.code_stokes_yx) ) then
        jsign = 0
        good_order = .true.
     elseif ( (astoke(1).eq.code_stokes_rr).and.(astoke(2).eq.code_stokes_ll) .and. & 
          &  (astoke(3).eq.code_stokes_rl).and.(astoke(4).eq.code_stokes_lr) ) then
        write(mess,'(A,4(1X,I0),A)') 'Ordering ',astoke,' not fully tested'
        call map_message(seve%w,rname,mess)
        good_order = .false.
        circular = .true.
     else
        write(mess,'(A,4(1X,I0),A)') 'Ordering ',astoke,' not supported '
        call map_message(seve%e,rname,mess)
        error = .true.
        return
     endif
     !
     if (good_order) then
        ! compute aa = (HH-VV)/2   and bb = (HV+VH)/2 then
        !  Q = aa cos(2.phi) - bb sin(2.phi)
        !  U = aa sin(2.phi) + bb cos(2.phi)
        ! or
        ! compute aa = (XX-YY)/2   and bb = (XY+YX)/2 then
        !  Q = aa 
        !  U = bb
        db = 0 ! to avoid initialization warnings.
        do invisi=1,nvisi
           ouvisi = ouvisi+1
           uvou(1:nlead,ouvisi) = uvin(1:nlead,invisi)
           incol = nlead
           oucol = nlead
           if (istoke.eq.code_stokes_q) then
              if (jsign.ne.0) then
                 xx =  cos(2*jsign*uvin(ipara,invisi))
                 yy = -sin(2*jsign*uvin(ipara,invisi))
              else
                 xx = 1.0
                 yy = 0.0
              endif
           else
              if (jsign.ne.0) then
                 xx = sin(2*jsign*uvin(ipara,invisi))
                 yy = cos(2*jsign*uvin(ipara,invisi))
              else
                 xx = 0.0
                 yy = 1.0
              endif
           endif
           do ichan=1,nchan
              if (uvin(incol+natom,invisi).gt.0)  then
                 HH(1:2) = uvin(incol+1:incol+natom-1,invisi)  
                 da = 1.0/uvin(incol+natom,invisi) ! Noise**2
                 ip = 1
              else
                 da = 0.0
                 ip = 0
              endif
              incol = incol+natom*nchan
              if (uvin(incol+natom,invisi).gt.0)  then
                 VV(1:2) = uvin(incol+1:incol+natom-1,invisi)
                 db = 1.0/uvin(incol+natom,invisi)  ! Noise**2
                 ip = ip+1
              endif
              incol = incol+natom*nchan
              if (uvin(incol+natom,invisi).gt.0)  then
                 HV(1:2) = uvin(incol+1:incol+natom-1,invisi)
                 ip = ip+1
              endif
              incol = incol+natom*nchan
              if (uvin(incol+natom,invisi).gt.0)  then
                 VH(1:2) = uvin(incol+1:incol+natom-1,invisi)
                 ip = ip+1
              endif
              aa = (HH-VV)/2
              bb = (HV+VH)/2
              if (ip.eq.4) then
                 uvou(oucol+1:oucol+2,ouvisi) = xx*aa + yy*bb
                 uvou(oucol+natom,ouvisi) = 4.0/(da+db)   ! Weight = 1/noise^2
              else
                 uvou(oucol+natom,ouvisi) = 0.0
              endif
              incol = incol - 3*natom*nchan
              oucol = oucol + natom
              incol = incol + natom
           enddo
           ! Fill trailing columns
           if (ntrail.gt.0) uvou(1+nlead+natom*nchan:oend,ouvisi) = &
                uvin(nlead+1+nstok*natom*nchan:iend,invisi)
        enddo
     else if (circular) then
        db = 0   ! Avoid initialization warning
        do invisi=1,nvisi
           ouvisi = ouvisi+1
           uvou(1:nlead,ouvisi) = uvin(1:nlead,invisi)
           incol = nlead
           oucol = nlead
           do ichan=1,nchan
              if (uvin(incol+natom,invisi).gt.0)  then
                 RR(1:2) = uvin(incol+1:incol+natom-1,invisi)  
                 da = 1.0/uvin(incol+natom,invisi) ! Noise**2
                 ip = 1
              else
                 da = 0.0
                 ip = 0
              endif
              incol = incol+natom*nchan
              if (uvin(incol+natom,invisi).gt.0)  then
                 LL(1:2) = uvin(incol+1:incol+natom-1,invisi)
                 db = 1.0/uvin(incol+natom,invisi)  ! Noise**2
                 ip = ip+1
              endif
              incol = incol+natom*nchan
              if (uvin(incol+natom,invisi).gt.0)  then
                 RL(1:2) = uvin(incol+1:incol+natom-1,invisi)
                 ip = ip+1
              endif
              incol = incol+natom*nchan
              if (uvin(incol+natom,invisi).gt.0)  then
                 LR(1:2) = uvin(incol+1:incol+natom-1,invisi)
                 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
                 uvou(oucol+1:oucol+2,ouvisi) = bb !! 
                 uvou(oucol+natom,ouvisi) = 4.0/(da+db)   ! Weight = 1/noise^2
              else
                 uvou(oucol+natom,ouvisi) = 0.0
              endif
              incol = incol - 3*natom*nchan
              oucol = oucol + natom
              incol = incol + natom
           enddo
           ! Fill trailing columns
           if (ntrail.gt.0) uvou(1+nlead+natom*nchan:oend,ouvisi) = &
                uvin(nlead+1+nstok*natom*nchan:iend,invisi)
        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 invisi=1,nvisi
        do istok=1,nstok
           ouvisi = ouvisi+1
           uvou(1:nlead,ouvisi) = uvin(1:nlead,invisi)
           incol = nlead+(istok-1)*nchan
           oucol = nlead
           uvou(oucol+1:oucol*natom*nchan,ouvisi) = uvin(incol+1:incol+natom*nchan,invisi)
           if (ntrail.gt.0) uvou(1+nlead+natom*nchan:oend,ouvisi) = &
                uvin(nlead+1+nstok*natom*nchan:iend,invisi)
           uvou(oend+1,ouvisi) = astoke(istok)
        enddo
     enddo
  case default
     write(mess,'(a,i0,a)') 'Case ',istoke,' Not supported'
     call map_message(seve%e,rname,mess)
     error = .true.
     return
  end select
  ! Sanity check
  if (ouvisi.ne.multi*nvisi) then
     write(mess,'(2(a,i0))') 'Expecting up to ',nvisi,' visibilities, found ',ouvisi
     call map_message(seve%e,rname,mess)
     error = .true.
     return
  endif
end subroutine stokes_derive_chan
