program uv_splitpolar
  use gkernel_interfaces
  !
  ! Split a UV table by Polarization
  !
  ! Input:
  !   A UV Table with visibilities containing Nstokes x Nchan
  ! 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_splitpolar (nami,namo,mystoke,error)
  call gagout('I-UV_SPLITPOLAR,  Successful completion')
end program uv_splitpolar
!<FF>
subroutine sub_splitpolar(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_SPLITPOLAR'
  type (gildas) :: hin, hou
  real(kind=4), allocatable :: din(:,:), dou(:,:)
  !
  character(len=message_length) :: mess
  !
  integer i, istoke, ivisi, is, ns, iv, jv, ier
  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.
  !
  ! 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
  !
  !
  call gildas_null(hou, type='UVT')
  call gdf_copy_header (hin, hou, error)
  call sic_parsef (namo,hou%file,'  ','.uvt')
  !
  hou%gil%nstokes = 1
  hou%gil%order = 0
  !
  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 '//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
      !
      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,'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
    ns = hin%gil%nstokes
    mess = 'Stokes: '
    next = 10
    do i=1,ns
      mess(next:) = gdf_stokes_name(hin%gil%stokes(i))
      next = len_trim(mess)+3
    enddo
    call map_message(seve%i,rname,mess)
    !
    !!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.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 i=1,code_uvt_last
            if (hou%gil%column_pointer(i).gt.hin%gil%fcol) then
              hou%gil%column_pointer(i) =  hou%gil%column_pointer(i) - &
                & hin%gil%natom * hin%gil%nchan
            endif
          enddo
          !
        else
          call map_message(seve%e,rname,'Cannot derive '//mystoke// &
          ' from '//gdf_stokes_name(astoke(1))//' and '//gdf_stokes_name(astoke(2)))
          error = .true.
          return
        endif
        !
        hou%gil%dim(2) = hou%gil%nvisi
        hou%gil%dim(1) = hin%gil%dim(1) - hin%gil%nchan*hin%gil%natom &
                       + ontrail-intrail
        oend = hou%gil%dim(1)+intrail-ontrail
        !!Print *,'IN ',hin%gil%natom,  hin%gil%nchan,  hin%gil%nvisi, hin%gil%dim(1)
        !!Print *,'OUT ',hou%gil%natom,  hou%gil%nchan,  hou%gil%nvisi, hou%gil%dim(1)
        !!Print *,'OEND ',oend, intrail, ontrail
        if (istoke.eq.code_stokes_all) then
          hou%gil%column_pointer(code_uvt_stok) = hou%gil%dim(1)
        endif
        !
        ! Here, we make the loop
        ! We make no assumption about the Stokes ordering, so allocate
        ! a block which may handle all input visibilities
        mblock = multi*nblock
        allocate (dou(hou%gil%dim(1),mblock),din(hin%gil%dim(1),nblock),stat=ier)
        if (ier.ne.0) then
          call map_message(seve%e,rname,'Memory allocation error')
          error = .true.
          return
        endif
        !
        hin%blc = 0
        hin%trc = 0
        hou%blc = 0
        hou%trc = 0
        call gdf_create_image(hou,error)
        if (error) return
        !
        hou%blc(2) = 1
        do iloop = 1,hin%gil%dim(2),nblock
          write(mess,*) iloop,' / ',hin%gil%dim(2),nblock
          call map_message(seve%d,rname,mess)
          hin%blc(2) = iloop
          hin%trc(2) = min(iloop+nblock-1,hin%gil%dim(2))
          call gdf_read_data(hin,din,error)
          if (error) return
          nvisi = hin%trc(2)-hin%blc(2)+1
          !
          if (hin%gil%order.eq.code_chan_stok) then
            ! Nchan X Nstokes channels  (ALL)
            !
            if (istoke.eq.code_stokes_all) then
              !
              jv = 0
              do iv = 1,nvisi
                jv = jv+1
                dou(1:nlead,jv) = din(1:nlead,iv)
                dou(nlead+1:nlead+natom*nchan,jv) = din(nlead+1:nlead+natom*nchan,iv)
                if (ontrail.ne.intrail) dou(oend+1,jv) = astoke(1)
                if (intrail.gt.0) dou(1+nlead+natom*nchan:oend,jv) = &
                     din(nlead+1+2*natom*nchan:iend,iv)
                !
                jv = jv+1
                dou(1:nlead,jv) = din(1:nlead,iv)
                dou(nlead+1:nlead+natom*nchan,jv) = din(nlead+1+natom*nchan:nlead+2*natom*nchan,iv)
                if (ontrail.ne.intrail) dou(oend+1,jv) = astoke(2)
                if (intrail.gt.0) dou(1+nlead+natom*nchan:oend,jv) = &
                     din(nlead+1+2*natom*nchan:iend,iv)
              enddo
            else
              call map_message(seve%e,rname, &
              & 'Nchan X Nstokes channel order only supported for code ALL')
              error = .true.
              return
            endif
          else
            !
            ! Nstokes x Nchan channels
            jv = 0
            do iv = 1,nvisi
              jv = jv+1
              dou(1:nlead,jv) = din(1:nlead,iv)
              kin = nlead
              kou = nlead
              !
              if (istoke.eq.code_stokes_none) then  ! Unpolarized case
  ! Stokes NONE
                do i=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
                  kou = kou + natom
                  kin = kin + natom
                enddo
                !
              else if (istoke.eq.code_stokes_i) then
! Stokes I
! Stokes I is strictly Stokes I, i.e.   HH+VV or LL+RR, not
! an arbitray weighted combination.
! For unpolarized signals, to maximize sensitivity, use Stokes NONE
                do i=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
                  kou = kou + natom
                  kin = kin + natom
                enddo
  !
              else
  ! Stokes ALL
                do i=1,nchan
                  dou(kou+1:kou+natom,jv) = din(kin+1:kin+natom,iv)
                  kou = kou + natom
                  kin = kin + 2*natom
                enddo
                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)
                kin = nlead+natom
                kou = nlead
                do i=1,nchan
                  dou(kou+1:kou+natom,jv) = din(kin+1:kin+natom,iv)
                  kou = kou + natom
                  kin = kin + 2*natom
                enddo
                if (ontrail.ne.intrail) dou(oend+1,jv) = astoke(2)
!
              endif
!
! Fill trailing columns
              if (intrail.gt.0) dou(1+nlead+natom*nchan:oend,jv) = &
                   din(nlead+1+2*natom*nchan:iend,iv)
              !
            enddo
          endif
          if (jv.ne.multi*nvisi) then
            write(mess,*) 'Expecting up to ',nvisi, &
            & ' visibilities, found ',jv
            call map_message(seve%w,rname,mess)
          endif
          hou%trc(2) = hou%blc(2)+jv-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 (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.ge.1 .and. istoke.le.4) then
          ! 4 Stokes, wanted any of I,Q,U,V
          ! apply matrix conversion to compute the desired stuff
          call map_message(seve%e,rname,'Cannot yet handle 4 Stokes ')
          error = .true.
          return
        else
          call map_message(seve%e,rname,'Cannot extract '//mystoke// &
          ' from '//gdf_stokes_name(astoke(1))//gdf_stokes_name(astoke(2))// &
          gdf_stokes_name(astoke(3))//' and '//gdf_stokes_name(astoke(4)) )
          error = .true.
          return
        endif
      else
        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)))
        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.
    !
    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
        !
        if (hin%gil%order.eq.code_chan_stok) then
          ! Nchan X Nstokes channels
          do iv = 1,hin%gil%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 (intrail.gt.0) dou(1+nlead+natom*nchan:,iv) = din(nlead+1+ns*natom*nchan:,iv)
          enddo
        else
          ! Nstokes x Nchan channels
          do iv = 1,hin%gil%nvisi
            dou(1:nlead,iv) = din(1:nlead,iv)
            kin = nlead+(ivisi-1)*natom
            kou = nlead
            do i=1,nchan
              dou(kou+1:kou+natom,iv) = din(kin+1:kin+natom,iv)
              kou = kou + natom
              kin = kin + ns*natom
            enddo
            if (intrail.gt.0) dou(1+nlead+natom*nchan:,iv) = din(nlead+1+ns*natom*nchan:,iv)
            !
          enddo
        endif
        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
