module get_pseudo_ensperts_mod
use abstract_get_pseudo_ensperts_mod
  type, extends(abstract_get_pseudo_ensperts_class) :: get_pseudo_ensperts_class
  contains
    procedure, pass(this) :: get_pseudo_ensperts => get_pseudo_ensperts_wrf
    procedure, nopass :: read_wrf_nmm_tclib
    procedure, nopass :: get_bgtc_center
    procedure, nopass :: create_pseudo_enpert_blend
    procedure, nopass :: pseudo_ens_e2a
  end type get_pseudo_ensperts_class

contains
  subroutine get_pseudo_ensperts_wrf(this,en_perts,nelen)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    get_pseudo_ensperts
!   prgmmr: mtong           org: np22                date: 2011-09-06
!
! abstract: read pseudo ensemble members from TC library, and interpolate to analysis
!           grid. Calculate pseudo ensemble perturbations and replace global ensemble
!           perturbations in vortex region (300 km from storm center)
!
! program history log:
!
!   input argument list:
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$ end documentation block

    use gridmod, only: half_grid,filled_grid,regional
    use constants,only: zero,one,two
    use mpimod, only: mpi_comm_world,ierror,mype,mpi_rtype
    use kinds, only: r_kind,i_kind,r_single
    use gsi_4dvar, only: nhr_assimilation
    use hybrid_ensemble_parameters, only: n_ens,grd_ens,uv_hyb_ens, &
                                          grid_ratio_ens,write_ens_sprd
    use general_sub2grid_mod, only: sub2grid_info,general_sub2grid,general_grid2sub, &
                                    general_sub2grid_create_info
    use gsi_io, only: lendian_in
    use hybrid_ensemble_parameters, only: n_ens,grd_ens
    use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d
    use gsi_bundlemod, only: gsi_bundlecreate
    use gsi_bundlemod, only: gsi_grid
    use gsi_bundlemod, only: gsi_bundle
    use gsi_bundlemod, only: gsi_bundlegetpointer
    use gsi_bundlemod, only: gsi_bundledestroy
    use gsi_bundlemod, only: gsi_gridcreate
    use get_wrf_nmm_ensperts_mod, only: get_wrf_nmm_ensperts_class
    use get_wrf_mass_ensperts_mod, only: get_wrf_mass_ensperts_class

    implicit none
!   Declare passed variables
    class(get_pseudo_ensperts_class),  intent(inout) :: this
    type(gsi_bundle),allocatable, intent(in   ) :: en_perts(:,:)
    integer(i_kind),                   intent(in   ) :: nelen

    type(sub2grid_info) grd_lib,grd_tmp
    real(r_kind),allocatable,dimension(:,:,:) :: u,v,tv,rh
    real(r_kind),allocatable,dimension(:,:)   :: ps
    real(r_kind) bar_norm,sig_norm

    integer(i_kind):: ic2,ic3
    integer(i_kind) ipc2d(nc2d),ipc3d(nc3d)
    real(r_single),pointer,dimension(:,:,:):: w3
    real(r_single),pointer,dimension(:,:):: w2
    real(r_kind),pointer,dimension(:,:,:):: x3
    real(r_kind),pointer,dimension(:,:):: x2
    type(gsi_bundle):: en_bar
    type(gsi_bundle),allocatable :: lib_perts(:)
    type(gsi_grid):: grid_ens
    type(get_wrf_nmm_ensperts_class):: nmm_enspert
    type(get_wrf_mass_ensperts_class):: mass_enspert

    integer(i_kind) :: nord_blend,nn_ens1,nn_ens2
    real(r_kind),allocatable,dimension(:,:) :: blend,wgt
    real(r_single),allocatable,dimension(:,:) :: outwork
    real(r_kind),allocatable::temp(:)

    integer(i_kind) i,j,k,n,istatus,mm1
    character(120) filename,infofile
  ! character(24) fileout
    logical(4) fexist

    integer(i_kind) regional_time(6)
    integer(i_kind) nlon_regional,nlat_regional
    real(r_single) dlmd,dphd,dlmd_ens,dphd_ens,dlmd_lib,dphd_lib

    real(r_kind) dlmd2,dphd2
    integer(i_kind) nlon_regional_lib,nlat_regional_lib,nsig,nlon_lib,nlat_lib
    integer(i_kind) inner_vars,num_fields
    logical,allocatable::vector(:)

    integer(i_kind) ku,kv,kt,kq,kps
    real(r_kind),allocatable,dimension(:,:,:,:) :: work,work_sub,work_reg

    real(r_kind) bc_lon,bc_lat,lclon,lclat,lc_lon,lc_lat,lc_lonm,lc_latm
    integer(i_kind) lon_bc,lat_bc,lon_lc,lat_lc,ratio_lon,ratio_lat
    logical :: test

    associate( this => this ) ! eliminates warning for unused dummy argument needed for binding
    end associate

  ! create ensemble perturbation and ensemble mean bundle
    allocate(lib_perts(n_ens))
    call gsi_gridcreate(grid_ens,grd_ens%lat2,grd_ens%lon2,grd_ens%nsig)
    call gsi_bundlecreate(en_bar,grid_ens,'ensemble mean',istatus,names2d=cvars2d, &
                          names3d=cvars3d,bundle_kind=r_kind)
    if(istatus/=0) then
       write(6,*)' get_pseudo_ensperts: trouble creating en_bar bundle'
       call stop2(999)
    endif
    do n=1,n_ens
        call gsi_bundlecreate(lib_perts(n),grid_ens,'library perts',istatus, &
                              names2d=cvars2d,names3d=cvars3d,bundle_kind=r_single)
       if(istatus/=0) then
          write(6,*)'get_pseudo_enperts: trouble creating lib_perts bundle'
          call stop2(999)
       endif
    end do

  !
  ! INITIALIZE ENSEMBLE MEAN ACCUMULATORS
    en_bar%values=zero
    do n=1,n_ens
       lib_perts(n)%valuesr4=zero
    end do

  ! read dlmd and dphd from guess
    write(filename,'("sigf",i2.2)')nhr_assimilation
    open(lendian_in,file=filename,form='unformatted')
    rewind lendian_in
    read(lendian_in) regional_time,nlon_regional,nlat_regional,nsig, &
                dlmd,dphd
    close(lendian_in)

    open(100,file='filelistp',form='formatted',err=30)
    open(200,file='infolist',form='formatted',err=30)
    rewind (100)
    rewind (200)
    do n=1,200
    read(100,'(a120)',err=20,end=40)filename
    enddo
  40  nn_ens1=n-1

    do n=1,200
    read(200,'(a120)',err=20,end=50)infofile
    enddo
  50  nn_ens2=n-1

    if(nn_ens1 < n_ens .or. nn_ens2 < n_ens)then
       print *,'missing ensemble members or infofile'
       call stop2(401)
    end if

    rewind (100)
    read(100,'(a120)',err=20,end=60)filename
    open(lendian_in,file=trim(filename),form='unformatted')
    rewind lendian_in
    read(lendian_in) nlon_regional_lib,nlat_regional_lib,nsig,dlmd_lib,dphd_lib
  !  if(mype == 0)print *,'nlon_lib, nlat_lib, nsig=', nlon_regional_lib,nlat_regional_lib,nsig
  !  if(mype == 0)print *,'dlmd_lib,dphd_lib=', dlmd_lib,dphd_lib
    if(filled_grid) then
       nlon_lib=2*nlon_regional_lib-1
       nlat_lib=nlat_regional_lib
    endif
    if(half_grid) then
       nlon_lib=nlon_regional_lib
       nlat_lib=1+nlat_regional_lib/2
    endif
    close(lendian_in)
  !  if(mype == 0)print *,'nlon_lib, nlat_lib, nsig=', nlon_lib, nlat_lib, nsig
    num_fields=1+4*nsig
  !  if(mype == 0)print *,'num_fields=', num_fields
    inner_vars=1
    allocate(vector(num_fields))
    vector=.false.
    vector(1:2*nsig)=uv_hyb_ens
    call general_sub2grid_create_info(grd_lib,inner_vars,nlat_lib,nlon_lib,nsig,num_fields,regional,vector)

    call general_sub2grid_create_info(grd_tmp,inner_vars,grd_ens%nlat,grd_ens%nlon,nsig,num_fields,regional,vector)
    deallocate(vector)

  ! read background TC center longitude and latide and convert to analysis
  ! grid index

    call get_bgtc_center(bc_lon,bc_lat)

  !  if(mype == 0) print *,'bc_lon,bc_lat=', bc_lon,bc_lat

    if(filled_grid)then
       dlmd2=dlmd
       dphd2=dphd
    end if
    if(half_grid)then
       dlmd2=two*dlmd
       dphd2=two*dphd
    end if

    dlmd2=dlmd2*grid_ratio_ens
    dphd2=dlmd2*grid_ratio_ens
    dlmd_ens=dlmd*grid_ratio_ens
    dphd_ens=dphd*grid_ratio_ens

    allocate(blend(grd_ens%nlat,grd_ens%nlon))

    blend=zero
    nord_blend=4
    call create_pseudo_enpert_blend(bc_lon,bc_lat,dlmd2,dphd2,nord_blend,blend)

    if(mype==0)then
       allocate(outwork(grd_ens%nlon,grd_ens%nlat))
       outwork=zero
       do j=1,grd_ens%nlon
          do i=1,grd_ens%nlat
             outwork(j,i)=blend(i,j)
          end do
      end do
      call outgrads1(outwork,grd_ens%nlon,grd_ens%nlat,'blend')
      deallocate(outwork)
    end if

  ! Reorganize for eventual distribution to local domains
    allocate(temp(grd_ens%itotsub))
    if (mype==0) then
       do k=1,grd_ens%itotsub
          i=grd_ens%ltosi_s(k) ; j=grd_ens%ltosj_s(k)
          temp(k)=blend(i,j)
       end do
    end if

    allocate(wgt(grd_ens%lat2,grd_ens%lon2))
    wgt=zero
    mm1=mype+1
    call mpi_scatterv(temp,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype,&
         wgt,grd_ens%ijn_s(mm1),mpi_rtype,0,mpi_comm_world,ierror)

    call nmm_enspert%grads3d(grd_ens,wgt,1,mype,'wgt')

    deallocate(temp)

    rewind(100)
    rewind(200)
    do n=1,n_ens
       read(100,'(a120)',err=20,end=60)filename
       filename=trim(filename)
       if(mype == 0)print *,'get_pseudo_ensperts: filename=', filename
       inquire(file=filename,exist=fexist)
       if(.not. fexist) call stop2(401)

       read(200,'(a120)',err=20,end=60)infofile
       infofile=trim(infofile)
       if(mype == 0)print *,'get_pseudo_ensperts: infofile=', infofile
       inquire(file=infofile,exist=fexist)
       if(.not. fexist) call stop2(401)

  !    read library tc center index from info file and find the index of the
  !    point that match the background TC center
       open(30,file=infofile,form='formatted')
       read(30,*)lclon,lclat,lc_lon,lc_lat
       close(30)

  !     if(mype == 0)print *,'n,lc_lon,lc_lat=', n,lc_lon, lc_lat

       if(filled_grid)then
          lc_lon=(2*lc_lon)-1
       end if

       if(half_grid)then
          lc_lat=1+lc_lat/2
       end if

  !     if(mype == 0)print *,'n,lc_lon,lc_lat=', n,lc_lon, lc_lat

       lc_lonm=lc_lon-(bc_lon-NINT(bc_lon))*dlmd_ens/dlmd_lib
       lc_latm=lc_lat-(bc_lat-NINT(bc_lat))*dphd_ens/dphd_lib

  !     if(mype == 0)print *,'n,lc_lonm,lc_latm=', n,lc_lonm, lc_latm

       lon_bc=NINT(bc_lon)
       lat_bc=NINT(bc_lat)

       lon_lc=NINT(lc_lonm)
       lat_lc=NINT(lc_latm)

       ratio_lon=INT(dlmd_ens/dlmd_lib)
       ratio_lat=INT(dphd_ens/dphd_lib)

  ! test
  !     ratio_lon=1
  !     ratio_lat=1
  ! test

  !     if(mype == 0)print *,'lon_bc,lat_bc=',lon_bc,lat_bc
  !     if(mype == 0)print *,'lon_lc,lat_lc=',lon_lc,lat_lc
  !     if(mype == 0)print *,'ratio_lon,ratio_lat=',ratio_lon,ratio_lat

       allocate(   u(grd_lib%lat2,grd_lib%lon2,grd_lib%nsig))
       allocate(   v(grd_lib%lat2,grd_lib%lon2,grd_lib%nsig))
       allocate(  tv(grd_lib%lat2,grd_lib%lon2,grd_lib%nsig))
       allocate(  rh(grd_lib%lat2,grd_lib%lon2,grd_lib%nsig))
       allocate(  ps(grd_lib%lat2,grd_lib%lon2))
       u=zero ; v=zero ; tv=zero ; rh=zero ; ps=zero

  !    read fields from TC library

       call read_wrf_nmm_tclib(grd_lib,filename,mype,ps,u,v,tv,rh)

  !     write(fileout,'("tclib",i3.3)') n
  !     call grads3a(grd_lib,u,v,tv,rh,ps,grd_lib%nsig,mype,fileout)

       allocate(work_sub(grd_lib%inner_vars,grd_lib%lat2,grd_lib%lon2,num_fields))
       work_sub=zero
       do k=1,grd_lib%nsig
          ku=k ; kv=k+grd_lib%nsig ; kt=k+2*grd_lib%nsig ; kq=k+3*grd_lib%nsig
          do j=1,grd_lib%lon2
             do i=1,grd_lib%lat2
                work_sub(1,i,j,ku)=u(i,j,k)
                work_sub(1,i,j,kv)=v(i,j,k)
                work_sub(1,i,j,kt)=tv(i,j,k)
                work_sub(1,i,j,kq)=rh(i,j,k)
             end do
          end do
       end do
       deallocate(u,v,tv,rh)
       kps=num_fields
       do j=1,grd_lib%lon2
          do i=1,grd_lib%lat2
             work_sub(1,i,j,kps)=ps(i,j)
          end do
       end do
       deallocate(ps)

       allocate(work(grd_lib%inner_vars,grd_lib%nlat,grd_lib%nlon,grd_lib%kbegin_loc:grd_lib%kend_alloc))
       work=zero
       call general_sub2grid(grd_lib,work_sub,work)
       deallocate(work_sub)

  !    then match to regional analysis grid
       allocate(work_reg(grd_tmp%inner_vars,grd_tmp%nlat,grd_tmp%nlon,grd_tmp%kbegin_loc:grd_tmp%kend_alloc))
       work_reg=zero

       do k=grd_lib%kbegin_loc,grd_lib%kend_loc
          call pseudo_ens_e2a(lon_bc,lat_bc,lon_lc,lat_lc,grd_lib%nlon,grd_lib%nlat,work(1,1,1,k), &
                              blend,ratio_lon,ratio_lat,grd_ens%nlon,grd_ens%nlat,work_reg(1,1,1,k))

       end do
       deallocate(work)

  !    next general_grid2sub to go to regional grid subdomains.
       allocate(work_sub(grd_tmp%inner_vars,grd_tmp%lat2,grd_tmp%lon2,grd_tmp%num_fields))
       work_sub=zero
       call general_grid2sub(grd_tmp,work_reg,work_sub)
       deallocate(work_reg)

       allocate(   u(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig))
       allocate(   v(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig))
       allocate(  tv(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig))
       allocate(  rh(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig))
       allocate(  ps(grd_ens%lat2,grd_ens%lon2))
       do k=1,grd_ens%nsig
          ku=k ; kv=ku+grd_ens%nsig ; kt=kv+grd_ens%nsig ; kq=kt+grd_ens%nsig
          do j=1,grd_ens%lon2
             do i=1,grd_ens%lat2
                u(i,j,k)=work_sub(1,i,j,ku)
                v(i,j,k)=work_sub(1,i,j,kv)
                tv(i,j,k)=work_sub(1,i,j,kt)     !  now pot virtual temp
                rh(i,j,k)=work_sub(1,i,j,kq)     !  now rh
             end do
          end do
       end do
       kps=num_fields
       do j=1,grd_ens%lon2
          do i=1,grd_ens%lat2
             ps(i,j)=work_sub(1,i,j,kps)
          end do
       end do
       deallocate(work_sub)

  !     write(fileout,'("tclibe2a",i3.3)') n
  !     call grads3a(grd_ens,u,v,tv,rh,ps,grd_ens%nsig,mype,fileout)
  !
  ! SAVE ENSEMBLE MEMBER DATA IN COLUMN VECTOR
       do ic3=1,nc3d

          call gsi_bundlegetpointer(lib_perts(n),trim(cvars3d(ic3)),w3,istatus)
          if(istatus/=0) then
             write(6,*)' error retrieving pointer to ',trim(cvars3d(ic3)),' for ensemble member ',n
             call stop2(999)
          end if
          call gsi_bundlegetpointer(en_bar,trim(cvars3d(ic3)),x3,istatus)
          if(istatus/=0) then
             write(6,*)' error retrieving pointer to ',trim(cvars3d(ic3)),' for en_bar'
             call stop2(999)
          end if

          select case (trim(cvars3d(ic3)))

             case('sf','SF')

                do k=1,grd_ens%nsig
                   do j=1,grd_ens%lon2
                      do i=1,grd_ens%lat2
                         w3(i,j,k) = u(i,j,k)
                         x3(i,j,k) = x3(i,j,k)+u(i,j,k)
                      end do
                   end do
                end do

             case('vp','VP')

                do k=1,grd_ens%nsig
                   do j=1,grd_ens%lon2
                      do i=1,grd_ens%lat2
                         w3(i,j,k) = v(i,j,k)
                         x3(i,j,k) = x3(i,j,k)+v(i,j,k)
                      end do
                   end do
                end do

             case('t','T')

                do k=1,grd_ens%nsig
                   do j=1,grd_ens%lon2
                      do i=1,grd_ens%lat2
                         w3(i,j,k) = tv(i,j,k)
                         x3(i,j,k) = x3(i,j,k)+tv(i,j,k)
                      end do
                   end do
                end do

             case('q','Q')

                do k=1,grd_ens%nsig
                   do j=1,grd_ens%lon2
                      do i=1,grd_ens%lat2
                         w3(i,j,k) = rh(i,j,k)
                         x3(i,j,k) = x3(i,j,k)+rh(i,j,k)
                      end do
                   end do
                end do

          end select
       end do
       deallocate(u,v,tv,rh)

       do ic2=1,nc2d

          call gsi_bundlegetpointer(lib_perts(n),trim(cvars2d(ic2)),w2,istatus)
          if(istatus/=0) then
             write(6,*)' error retrieving pointer to ',trim(cvars2d(ic2)),' for ensemble member ',n
             call stop2(999)
          end if
          call gsi_bundlegetpointer(en_bar,trim(cvars2d(ic2)),x2,istatus)
          if(istatus/=0) then
             write(6,*)' error retrieving pointer to ',trim(cvars2d(ic2)),' for en_bar'
             call stop2(999)
          end if

          select case (trim(cvars2d(ic2)))

             case('ps','PS')

                do j=1,grd_ens%lon2
                   do i=1,grd_ens%lat2
                      w2(i,j) = ps(i,j)
                      x2(i,j) = x2(i,j)+ps(i,j)
                   end do
                end do

          end select
       end do
       deallocate(ps)

    end do ! end do over ensemble

    close(100)
    close(200)

    deallocate(blend)

  ! Convert to mean
    bar_norm = one/float(n_ens)
    en_bar%values=en_bar%values*bar_norm

    if(write_ens_sprd)then
       call mpi_barrier(mpi_comm_world,ierror)
       call mass_enspert%ens_spread_dualres_regional(mype,en_perts,nelen,en_bar)
       call mpi_barrier(mpi_comm_world,ierror)
    end if

    test=.false.
    if(test)then
       allocate(u(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig))
       allocate(v(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig))
       allocate(tv(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig))
       allocate(rh(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig))
       allocate(ps(grd_ens%lat2,grd_ens%lon2))

       u=zero; v=zero; tv=zero; rh=zero; ps=zero

       call gsi_bundlegetpointer(en_bar,cvars3d,ipc3d,istatus)
       if(istatus/=0) then
         write(6,*) 'mtong: cannot find 3d pointers'
         call stop2(999)
       endif
       call gsi_bundlegetpointer(en_bar,cvars2d,ipc2d,istatus)
       if(istatus/=0) then
         write(6,*) 'mtong: cannot find 2d pointers'
         call stop2(999)
       endif

       do ic3=1,nc3d
          select case (trim(cvars3d(ic3)))

             case('sf','SF')

                do k=1,grd_ens%nsig
                   do j=1,grd_ens%lon2
                      do i=1,grd_ens%lat2
                         u(i,j,k) = en_bar%r3(ipc3d(ic3))%q(i,j,k)
                      end do
                   end do
                end do

             case('vp','VP')

                do k=1,grd_ens%nsig
                   do j=1,grd_ens%lon2
                      do i=1,grd_ens%lat2
                         v(i,j,k) = en_bar%r3(ipc3d(ic3))%q(i,j,k)
                      end do
                   end do
                end do

             case('t','T')
                do k=1,grd_ens%nsig
                   do j=1,grd_ens%lon2
                      do i=1,grd_ens%lat2
                         tv(i,j,k) = en_bar%r3(ipc3d(ic3))%q(i,j,k)
                      end do
                   end do
                end do

             case('q','Q')

                do k=1,grd_ens%nsig
                   do j=1,grd_ens%lon2
                      do i=1,grd_ens%lat2
                         rh(i,j,k) = en_bar%r3(ipc3d(ic3))%q(i,j,k)
                      end do
                   end do
                end do

          end select
       end do

       do ic2=1,nc2d
          select case (trim(cvars2d(ic2)))

             case('ps','PS')

                do j=1,grd_ens%lon2
                   do i=1,grd_ens%lat2
                      ps(i,j) = en_bar%r2(ipc2d(ic2))%q(i,j)
                   end do
                end do

          end select
       end do

       call nmm_enspert%grads3a(grd_ens,u,v,tv,rh,ps,grd_ens%nsig,mype,'en_bar')
       deallocate(u,v,tv,rh,ps)
    end if

  ! Convert ensemble members to perturbations
    sig_norm=sqrt(one/max(one,n_ens-one))
    do n=1,n_ens
       do i=1,nelen
          lib_perts(n)%valuesr4(i)=(lib_perts(n)%valuesr4(i)-en_bar%values(i))*sig_norm
       end do
    end do
    call mpi_barrier(mpi_comm_world,ierror)

    call gsi_bundledestroy(en_bar,istatus)
    if(istatus/=0) then
       write(6,*)' in get_pseudo_ensperts: trouble destroying en_bar bundle'
       call stop2(999)
    endif

  ! merge pseudo ensemble perturbation to global ensemble perturbation

  ! NOTE:  because library perturbation bundle structure is same as ensemble perturbation,
  !        use same ipc3d and ipc2d indices for lib_perts and en_perts bundles.

    call gsi_bundlegetpointer (en_perts(1,1),cvars3d,ipc3d,istatus)
    if(istatus/=0) then
       write(6,*) 'get_pseudo_enperts: cannot find 3d pointers'
       call stop2(999)
    endif
    call gsi_bundlegetpointer (en_perts(1,1),cvars2d,ipc2d,istatus)
    if(istatus/=0) then
       write(6,*) 'get_pseudo_enperts: cannot find 2d pointers'
       call stop2(999)
    endif

    do n=1,n_ens

       do ic3=1,nc3d

          do k=1,grd_ens%nsig
             do j=1,grd_ens%lon2
                do i=1,grd_ens%lat2
                   en_perts(n,1)%r3(ipc3d(ic3))%qr4(i,j,k) = wgt(i,j) * &
                                lib_perts(n)%r3(ipc3d(ic3))%qr4(i,j,k)  + &
                                (one-wgt(i,j))*en_perts(n,1)%r3(ipc3d(ic3))%qr4(i,j,k)
                end do
             end do
          end do

       end do

       do ic2=1,nc2d

          do j=1,grd_ens%lon2
             do i=1,grd_ens%lat2
                en_perts(n,1)%r2(ipc2d(ic2))%qr4(i,j) = wgt(i,j)  * &
                               lib_perts(n)%r2(ipc2d(ic2))%qr4(i,j) + &
                               (one-wgt(i,j))*en_perts(n,1)%r2(ipc2d(ic2))%qr4(i,j)
             end do
          end do

       end do

    end do

    do n=1,n_ens
       call gsi_bundledestroy(lib_perts(n),istatus)
       if(istatus/=0) then
          write(6,*)' in get_pseudo_ensperts: trouble destroying lib_perts bundle'
          call stop2(999)
       endif
    end do

    deallocate(wgt,lib_perts)

  ! output perturbations

    test=.false.
    if(test)then
       allocate(u(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig))
       allocate(v(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig))
       allocate(tv(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig))
       allocate(rh(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig))
       allocate(ps(grd_ens%lat2,grd_ens%lon2))

       u=zero; v=zero; tv=zero; rh=zero; ps=zero

       do n=1,n_ens

          write(filename,"('enpert',i3.3)") n

          call gsi_bundlegetpointer(en_perts(n,1),cvars3d,ipc3d,istatus)
          if(istatus/=0) then
            write(6,*) 'mtong: cannot find 3d pointers'
            call stop2(999)
          endif
          call gsi_bundlegetpointer(en_perts(n,1),cvars2d,ipc2d,istatus)
          if(istatus/=0) then
            write(6,*) 'mtong: cannot find 2d pointers'
            call stop2(999)
          endif

          do ic3=1,nc3d
             select case (trim(cvars3d(ic3)))

                case('sf','SF')

                   do k=1,grd_ens%nsig
                      do j=1,grd_ens%lon2
                         do i=1,grd_ens%lat2
                            u(i,j,k) = en_perts(n,1)%r3(ipc3d(ic3))%qr4(i,j,k)
                         end do
                      end do
                   end do

                case('vp','VP')

                   do k=1,grd_ens%nsig
                      do j=1,grd_ens%lon2
                         do i=1,grd_ens%lat2
                            v(i,j,k) = en_perts(n,1)%r3(ipc3d(ic3))%qr4(i,j,k)
                         end do
                      end do
                   end do

                case('t','T')

                   do k=1,grd_ens%nsig
                      do j=1,grd_ens%lon2
                         do i=1,grd_ens%lat2
                            tv(i,j,k) = en_perts(n,1)%r3(ipc3d(ic3))%qr4(i,j,k)
                         end do
                      end do
                   end do

                case('q','Q')

                   do k=1,grd_ens%nsig
                      do j=1,grd_ens%lon2
                         do i=1,grd_ens%lat2
                            rh(i,j,k) = en_perts(n,1)%r3(ipc3d(ic3))%qr4(i,j,k)
                         end do
                      end do
                   end do

             end select
          end do

          do ic2=1,nc2d
             select case (trim(cvars2d(ic2)))

                case('ps','PS')

                   do j=1,grd_ens%lon2
                      do i=1,grd_ens%lat2
                         ps(i,j) = en_perts(n,1)%r2(ipc2d(ic2))%qr4(i,j)
                      end do
                   end do

             end select
          end do

          call nmm_enspert%grads3a(grd_ens,u,v,tv,rh,ps,grd_ens%nsig,mype,filename)

       end do

       deallocate(u,v,tv,rh,ps)
    end if ! if(test)then

    return
  30 write(6,*) 'GET_PSEUDO_ENSPERTS open filelist failed '
     call stop2(400)
  20 write(6,*) 'GET_PSEUDO_NMM_ENSPERTS read file list failed ',n
     call stop2(400)
  60 write(6,*) 'GET_PSEUDO_NMM_ENSPERTS reach end of file list ',n
     call stop2(400)
  end subroutine get_pseudo_ensperts_wrf

  subroutine read_wrf_nmm_tclib(grd,filename,mype,ps,u,v,tv,rh)
  !$$$  subprogram documentation block
  !                .      .    .                                       .
  ! subprogram:    read_wrf_nmm_tclib        read wrf_nmm TC library
  !   prgmmr: tong          org: np22                date: 2011-09-06
  !
  ! program history log:
  !
  !   input argument list:
  !     grd      - structure variable containing information about grid
  !                (initialized by general_sub2grid_create_info, located in general_sub2grid_mod.f90)
  !     filename - input sigma file name
  !     mype     - mpi task id
  !
  !   output argument list:
  !     *        - library fields
  !
  ! language: f90
  !   machine:  ibm RS/6000 SP
  !
  !$$$
    use kinds, only: r_kind,r_single,i_kind
    use mpimod, only: ierror,mpi_real4,mpi_comm_world,npe
    use gridmod, only: half_grid,filled_grid
    use constants, only: one,ten,one_tenth,half,fv
    use gsi_io, only: lendian_in
    use general_sub2grid_mod, only: sub2grid_info
    use hybrid_ensemble_parameters, only: q_hyb_ens
    use get_wrf_nmm_ensperts_mod, only: get_wrf_nmm_ensperts_class
    implicit none

  ! Declare passed variables here
    type(sub2grid_info)                   ,intent(in   ) :: grd
    character(120)                        ,intent(in   ) :: filename
    integer(i_kind)                       ,intent(in   ) :: mype
    real(r_kind),dimension(grd%lat2,grd%lon2)     ,intent(  out) :: ps
    real(r_kind),dimension(grd%lat2,grd%lon2,grd%nsig),intent(  out) :: u,v,tv,rh

  ! Declare local parameters
    real(r_kind),parameter:: r0_01=0.01_r_kind
    real(r_kind),allocatable,dimension(:,:,:) :: tsen,q,prsl
    real(r_kind),allocatable,dimension(:,:) :: g_pd
    type(get_wrf_nmm_ensperts_class) :: wrf_nmm

  ! Declare local variables
    integer(i_kind) kt,kq,ku,kv

  ! NMM variable names stuck in here

  ! other internal variables
    integer(i_kind) nlon_regional,nlat_regional,nsig
    real(r_single) dlmd,dphd
    real(r_single)pt,pdtop
    real(r_single),allocatable:: aeta1(:),aeta2(:)
    real(r_kind) pdtop_ll,pt_ll
    real(r_kind),allocatable:: aeta1_ll(:),aeta2_ll(:)

    real(r_single),allocatable::tempa(:)
    real(r_single),allocatable::temp1(:,:)
    real(r_single),allocatable::all_loc(:,:,:)
    integer(i_kind),allocatable::igtype(:),jsiskip(:)
    integer(i_kind) irc_s_reg(npe),ird_s_reg(npe)
    integer(i_kind) ifld,im,jm,lm,num_nmm_fields
    integer(i_kind) num_all_fields,num_loc_groups,num_all_pad
    integer(i_kind) i,icount,icount_prev,j,k
    integer(i_kind) i_0,i_pd,i_t,i_q,i_u,i_v
    integer(i_kind) iderivative
    real(r_kind) pd,psfc_this
    integer(i_kind) ireturn
    logical ice
  ! character(24) fileout

    lm=grd%nsig

    num_nmm_fields=1+4*lm

    num_all_fields=num_nmm_fields*1
    num_loc_groups=num_all_fields/npe
  !  if(mype == 0) write(6,'(" at 1 in read_wrf_nmm_tclib, lm            =",i6)')lm
  !  if(mype == 0) write(6,'(" at 1 in read_wrf_nmm_tclib, num_nmm_fields=",i6)')num_nmm_fields
  !  if(mype == 0) write(6,'(" at 1 in read_wrf_nmm_tclib, num_all_fields=",i6)')num_all_fields
  !  if(mype == 0) write(6,'(" at 1 in read_wrf_nmm_tclib, npe           =",i6)')npe
  !  if(mype == 0) write(6,'(" at 1 in read_wrf_nmm_tclib, num_loc_groups=",i6)')num_loc_groups
    do
       num_all_pad=num_loc_groups*npe
       if(num_all_pad >= num_all_fields) exit
       num_loc_groups=num_loc_groups+1
    end do
    if(mype == 0) write(6,'(" at 1 in read_wrf_nmm_tclib, num_all_pad   =",i6)')num_all_pad
    if(mype == 0) write(6,'(" at 1 in read_wrf_nmm_tclib, num_loc_groups=",i6)')num_loc_groups

    allocate(all_loc(grd%lat2,grd%lon2,num_all_pad))
    allocate(jsiskip(num_nmm_fields))
    allocate(igtype(num_nmm_fields))

    i=0
    i=i+1 ; i_pd=i                                                    ! pd
    jsiskip(i)=2
    igtype(i)=1

    i_t=i+1
    do k=1,lm
       i=i+1                                                          ! t(k)
       jsiskip(i)=0
       igtype(i)=1
    end do
    i_q=i+1
    do k=1,lm
       i=i+1                                                          ! q(k)
       jsiskip(i)=0 ; igtype(i)=1
    end do
    i_u=i+1
    do k=1,lm
       i=i+1                                                          ! u(k)
       jsiskip(i)=0 ; igtype(i)=2
    end do
    i_v=i+1
    do k=1,lm
       i=i+1                                                          ! v(k)
       jsiskip(i)=0 ; igtype(i)=2
    end do

    do i=1,npe
       irc_s_reg(i)=grd%ijn_s(mype+1)
    end do
    ird_s_reg(1)=0
    do i=1,npe
       if(i /= 1) ird_s_reg(i)=ird_s_reg(i-1)+irc_s_reg(i-1)
    end do

    icount=0
    icount_prev=1
    open(lendian_in,file=filename,form='unformatted') ; rewind lendian_in
    read(lendian_in) nlon_regional,nlat_regional,nsig,dlmd,dphd,pt,pdtop
  !  if(mype == 0)print *,'nlon_regional,nlat_regional,nsig,dlmd,dphd,pt,pdtop'
  !  if(mype == 0)print *,nlon_regional,nlat_regional,nsig,dlmd,dphd,pt,pdtop
    im=nlon_regional
    jm=nlat_regional
    allocate(aeta1(nsig),aeta2(nsig))
    allocate(aeta1_ll(nsig),aeta2_ll(nsig))
    allocate(temp1(im,jm))
    allocate(tempa(grd%itotsub))

  !    Read, interpolate, and distribute NMM restart fields
    do ifld=1,num_nmm_fields
       icount=icount+1
       if(jsiskip(ifld) > 0) then
          do i=1,jsiskip(ifld)
             if(i == 1)then
                read(lendian_in)aeta1
             else if(i == 2)then
                read(lendian_in)aeta2
             else
                read(lendian_in)
             end if
          end do
       end if
       if(mype == mod(icount-1,npe)) then
          read(lendian_in)((temp1(i,j),i=1,im),j=1,jm)
          if(filled_grid) call wrf_nmm%general_fill_nmm_grid2(grd,temp1,im,jm,tempa,abs(igtype(ifld)),1,ireturn)
          if(half_grid)   call wrf_nmm%general_half_nmm_grid2(grd,temp1,im,jm,tempa,abs(igtype(ifld)),1,ireturn)
          if(ireturn == 1)call stop2(500)
       else
          read(lendian_in)
       end if

  !    Distribute to local domains everytime we have npe fields
       if(mod(icount,npe) == 0.or.icount == num_all_fields) then
          call mpi_alltoallv(tempa,grd%ijn_s,grd%displs_s,mpi_real4, &
               all_loc(1,1,icount_prev),irc_s_reg,ird_s_reg,mpi_real4,mpi_comm_world,ierror)
          icount_prev=icount+1
       end if

    end do
    close(lendian_in)

    allocate(tsen(grd%lat2,grd%lon2,grd%nsig),q(grd%lat2,grd%lon2,grd%nsig))
    allocate(prsl(grd%lat2,grd%lon2,grd%nsig))
    allocate(g_pd(grd%lat2,grd%lon2))

    aeta1_ll=aeta1
    aeta2_ll=aeta2
    pdtop_ll=r0_01*pdtop
    pt_ll=r0_01*pt
    i_0=0
    kt=i_0+i_t-1
    kq=i_0+i_q-1
    ku=i_0+i_u-1
    kv=i_0+i_v-1

    do k=1,grd%nsig
       kt=kt+1
       kq=kq+1
       ku=ku+1
       kv=kv+1

       do i=1,grd%lon2
          do j=1,grd%lat2
             u(j,i,k) = real(all_loc(j,i,ku),r_kind)
             v(j,i,k) = real(all_loc(j,i,kv),r_kind)
             q(j,i,k) = real(all_loc(j,i,kq),r_kind)
             tsen(j,i,k) = real(all_loc(j,i,kt),r_kind)! actually holds sensible temperature
          end do
       end do
    end do

    do i=1,grd%lon2
       do j=1,grd%lat2
          g_pd(j,i)=real(all_loc(j,i,i_pd),r_kind)
       end do
    end do

  !  call grads3d(grd,u,nsig,mype,'u')

  ! convert wrf nmm pd variable to psfc in mb, and then to log(psfc) in cb
    do i=1,grd%lon2
       do j=1,grd%lat2
          pd=r0_01*real(all_loc(j,i,i_0+i_pd),r_kind)
          psfc_this=pd+pdtop_ll+pt_ll
          ps(j,i)=one_tenth*psfc_this   ! convert from mb to cb
       end do
    end do
    do k=1,grd%nsig
       do i=1,grd%lon2
          do j=1,grd%lat2
             tv(j,i,k) = tsen(j,i,k) * (one+fv*q(j,i,k))
             prsl(j,i,k)=one_tenth* &
                        (aeta1_ll(k)*pdtop_ll + &
                         aeta2_ll(k)*(ten*ps(j,i)-pdtop_ll-pt_ll) + &
                         pt_ll)
          end do
       end do
    end do

    if (.not.q_hyb_ens) then
       ice=.true.
       iderivative=0
       call genqsat(rh,tsen,prsl,grd%lat2,grd%lon2,grd%nsig,ice,iderivative)

       do k=1,grd%nsig
          do i=1,grd%lon2
             do j=1,grd%lat2
                rh(j,i,k)=q(j,i,k)/rh(j,i,k)
             end do
          end do
       end do
    else
       do k=1,grd%nsig
          do i=1,grd%lon2
             do j=1,grd%lat2
                rh(j,i,k)=q(j,i,k)
             end do
          end do
       end do
    end if

    deallocate(aeta1,aeta2,aeta1_ll,aeta2_ll)
    deallocate(all_loc,jsiskip,igtype)
    deallocate(temp1,tempa)
    deallocate(tsen,q,prsl,g_pd)

  end subroutine read_wrf_nmm_tclib

  subroutine get_bgtc_center(bc_lon,bc_lat)
  !$$$  subprogram documentation block
  !                .      .    .                                       .
  ! subprogram:    get_bgtc_center
  !
  !   prgmmr: mtong          org: np22                date: 2011-09-08
  !
  ! abstract:  read background TC center longitude and latitude and convert to
  !            analysis grid index
  !
  ! program history log:
  !
  !   input argument list:
  !
  !   output argument list:
  !     bc_lon    - TC center grid index in x direction
  !     bc_lat    - TC center grid index in y direction
  !
  ! attributes:
  !   language: f90
  !   machine:  ibm RS/6000 SP
  !
  !$$$

    use kinds, only: r_kind,r_single,i_kind
    use constants, only: zero,one,deg2rad
    use gridmod, only: tll2xy

    implicit none

    real(r_kind)                          ,intent(inout) :: bc_lon,bc_lat
    integer(i_kind) iclat,iclon
    character*1 sn,ew
    real(r_kind),parameter:: r360=360.0_r_kind
    real(r_kind) clat,clon
    logical outside

    clon=zero
    clat=zero

    open(32,file='trak.hwrf06',form='formatted')
    read(32,'(33x,I3,A1,1x,I4,A1)') iclat,sn,iclon,ew
    close(32)

    if(sn == 'S')then
      clat=- one * float(iclat)/10.0_r_kind
    else
      clat=float(iclat)/10.0_r_kind
    endif

    if(ew == 'W')then
       clon=360._r_kind - float(iclon)/10.0_r_kind
    else
       clon=float(iclon)/10.0_r_kind
    endif

    if (clon >= r360) clon=clon-r360
    if (clon < zero)  clon=clon+r360
    clat = clat * deg2rad
    clon = clon * deg2rad
    call tll2xy(clon,clat,bc_lon,bc_lat,outside)
    if (outside) then
       print *,'tc center is outside domain'
       call stop2(402)
    end if

  end subroutine get_bgtc_center

  subroutine create_pseudo_enpert_blend(bc_lon,bc_lat,dlmd,dphd,nord_blend,blndmsk)
  !$$$  subprogram documentation block
  !                .      .    .                                       .
  ! subprogram:    get_pseudo_enpert_blend
  !   prgmmr: mtong          org: np22                date: 2011-09-12
  !
  ! abstract: create blend mask for pseudo ensemble perturbations
  !           The blending function gradually change from 1 to 0
  !           witin the blending zone 150 km to 300 km from the
  !           TC center.
  !
  ! program history log:
  !   2011-09-12  mtong, initial documentation
  !
  !   input argument list:
  !     bc_lon         - background TC center x index
  !     bc_lat         - background TC center y index
  !     dlmd           - grid resolution in x direction
  !     dphd           - grid resolution in y direction
  !     nord_blend     - variable used to create variable blend mask
  !
  !   output argument list:
  !     blndmsk        - blend mask
  !
  ! attributes:
  !   language: f90
  !   machine:  ibm RS/6000 SP
  !
  !$$$ end documentation block
    use constants, only: zero,one
    use kinds, only: r_kind,i_kind,r_single
    use hybrid_ensemble_parameters, only: grd_ens
    use blendmod, only: blend
    implicit none

    real(r_kind)                          ,intent(in   ) :: bc_lon,bc_lat
    real(r_kind  )                        ,intent(in   ) :: dlmd,dphd
    integer(i_kind)                       ,intent(in   ) :: nord_blend
    real(r_kind)                          ,intent(  out) :: blndmsk(grd_ens%nlat,grd_ens%nlon)

    real(r_kind),parameter:: r300=300_r_kind
    real(r_kind),parameter:: r150=150_r_kind
    real(r_kind),parameter:: r111=111.12_r_kind
    real(r_kind) dx,dy,dr,x,y
    integer(i_kind) i,j,k,imin,jmin,imax,jmax
    integer(i_kind) mm
    integer(i_kind),dimension(0:40):: iblend

    blndmsk=zero

    dx=r111*dlmd
    dy=r111*dphd

    imin=max(1,INT(bc_lat-r300/dy))
    jmin=max(1,INT(bc_lon-r300/dx))
    imax=min(grd_ens%nlat,NINT(bc_lat+r300/dy))
    jmax=min(grd_ens%nlon,NINT(bc_lon+r300/dx))

  ! set up blend function
    mm=nord_blend
    call blend(mm,iblend)
    do j=jmin,jmax
       do i=imin,imax
          dr=sqrt((dy*(i-bc_lat))*(dy*(i-bc_lat))+(dx*(j-bc_lon))*(dx*(j-bc_lon)))
          if(dr <= r150)then
             blndmsk(i,j)=one
          else if(dr <= r300)then
             x=abs(dr-r300)/r150
             y=iblend(mm)
             do k=mm-1,0,-1
                y=x*y+iblend(k)
             end do
             y=y*x**(mm+1)
             blndmsk(i,j)=y
          end if
       end do
    end do

  end subroutine create_pseudo_enpert_blend

  subroutine pseudo_ens_e2a(lon_bc,lat_bc,lon_lc,lat_lc,nlone,nlate,e,blend,ratio_lon, &
                            ratio_lat,nlona,nlata,a)
  !$$$  subprogram documentation block
  !                .      .    .                                       .
  ! subprogram:    pseudo_ens_e2a move TC library ensemble grid to analysis grid
  !   prgmmr: mtong          org: np22                date: 2011-09-12
  !
  ! abstract: Move TC library ensemble grid to analysis grid, so that the
  !           ensemble TC centers match the background TC center
  !
  ! program history log:
  !   2011-09-12  mtong, initial documentation
  !
  !   input argument list:
  !     lon_bc         - background TC center x index
  !     lat_bc         - background TC center y index
  !     lon_lc         - ensemble member TC center x index
  !     lat_lc         - ensemble member TC center y index
  !     nlone          - ensemble grid x dimension
  !     nlate          - ensemble grid y dimension
  !     e              - ensemble member values on full ensemble global domain
  !     blend          - blending mask
  !     ratio_lon      - ensemble to analysis grid ratio in x direction
  !     ratio_lat      - ensemble to analysis grid ratio in y direction
  !     nlona          - analysis grid x dimension
  !     nlata          - analysis grid y dimension
  !
  !   output argument list:
  !     a              - ensemble member values on analysis grid
  !
  ! attributes:
  !   language: f90
  !   machine:  ibm RS/6000 SP
  !
  !$$$ end documentation block
    use kinds, only: r_kind,i_kind,r_single
    use constants, only: zero
    implicit none

    integer(i_kind)                       ,intent(in   ) :: lon_bc,lat_bc,lon_lc,lat_lc
    integer(i_kind)                       ,intent(in   ) :: nlone,nlate,nlona,nlata
    integer(i_kind)                       ,intent(in   ) :: ratio_lon,ratio_lat
    real(r_kind)                          ,intent(in   ) :: e(nlate,nlone)
    real(r_kind)                          ,intent(in   ) :: blend(nlata,nlona)
    real(r_kind)                          ,intent(  out) :: a(nlata,nlona)

    integer(i_kind) i,j,ii,jj

    do j=1,nlona
       jj=lon_lc+ratio_lon*(j-lon_bc)
       if( jj > 0 .and. jj <= nlone )then
          do i=1,nlata
             ii=lat_lc+ratio_lat*(i-lat_bc)
             if(blend(i,j) > zero .and. ii > 0 .and. ii <= nlate)then
                a(i,j)=e(ii,jj)
             end if
          end do
       end if
    end do

  end subroutine pseudo_ens_e2a
end module get_pseudo_ensperts_mod


      SUBROUTINE ROTATE (NI,NJ,XI,XJ,W,KR,E1B,E2A,ENUC,CUTOFF)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION XI(3),XJ(3),W(100),E1B(10),E2A(10)
      COMMON /NATORB/ NATORB(107)
      COMMON /TWOEL3/ F03(107)
      COMMON /ALPHA3/ ALP3(153)
      COMMON /ALPHA / ALP(107)
      COMMON /CORE  / TORE(107)
      COMMON /IDEAS / FN1(107,10),FN2(107,10),FN3(107,10)
C***********************************************************************
C
C   ROTATE CALCULATES THE TWO-PARTICLE INTERACTIONS.
C
C   ON INPUT  NI     = ATOMIC NUMBER OF FIRST ATOM.
C             NJ     = ATOMIC NUMBER OF SECOND ATOM.
C             XI     = COORDINATE OF FIRST ATOM.
C             XJ     = COORDINATE OF SECOND ATOM.
C
C ON OUTPUT W      = ARRAY OF TWO-ELECTRON REPULSION INTEGRALS.
C           E1B,E2A= ARRAY OF ELECTRON-NUCLEAR ATTRACTION INTEGRALS,
C                    E1B = ELECTRON ON ATOM NI ATTRACTING NUCLEUS OF NJ.
C           ENUC   = NUCLEAR-NUCLEAR REPULSION TERM.
C
C***********************************************************************
      COMMON /ROTDUM/ CSS1,CSP1,CPPS1,CPPP1,CSS2,CSP2,CPPS2,CPPP2
      COMMON /ROTDU2/ X1,X2,X3,Y1,Y2,Y3,Z1,Z2,Z3
      COMMON /KEYWRD/ KEYWRD
      CHARACTER*80 KEYWRD
      DIMENSION X(3),Y(3),Z(3),RI(22),CORE(4,2)
      LOGICAL SI,SK, AM1
      EQUIVALENCE (CORE(1,1),CSS1),(X(1),X1),(Y(1),Y1),(Z(1),Z1)
      DATA ITYPE /1/
C
C *** THIS ROUTINE COMPUTES THE REPULSION AND NUCLEAR ATTRACTION
C     INTEGRALS OVER MOLECULAR-FRAME COORDINATES.  THE INTEGRALS OVER
C     LOCAL FRAME COORDINATES ARE EVALUATED BY SUBROUTINE REPP AND
C     STORED AS FOLLOWS (WHERE P-SIGMA = O,   AND P-PI = P AND P* )
C     IN RI
C     (SS/SS)=1,   (SO/SS)=2,   (OO/SS)=3,   (PP/SS)=4,   (SS/OS)=5,
C     (SO/SO)=6,   (SP/SP)=7,   (OO/SO)=8,   (PP/SO)=9,   (PO/SP)=10,
C     (SS/OO)=11,  (SS/PP)=12,  (SO/OO)=13,  (SO/PP)=14,  (SP/OP)=15,
C     (OO/OO)=16,  (PP/OO)=17,  (OO/PP)=18,  (PP/PP)=19,  (PO/PO)=20,
C     (PP/P*P*)=21,   (P*P/P*P)=22.
C
      RIJ=0.D0
      DO 10 I=1,3
         X(I)=XI(I)-XJ(I)
   10 RIJ=RIJ+X(I)**2
      IF(RIJ.LT.0.2D0) THEN
         DO 20 I=1,10
            E1B(I)=0.D0
   20    E2A(I)=0.D0
         W(KR)=0.D0
         ENUC=0.D0
         RETURN
      ENDIF
   30 GOTO (40,50,110) ITYPE
   40 CONTINUE
      IF(INDEX(KEYWRD,'MINDO') .NE. 0) THEN
         ITYPE=2
      ELSE
         AM1= (INDEX(KEYWRD,'AM1') .NE. 0)
         ITYPE=3
      ENDIF
      GOTO 30
   50 CONTINUE
      SUM=14.399D0/SQRT(RIJ+(7.1995D0/F03(NI)+7.1995D0/F03(NJ))**2)
      W(1)=SUM
      KR=KR+1
      L=0
      DO 70 I=1,4
         DO 60 J=1,I
            L=L+1
            E1B(L)=0.D0
   60    E2A(L)=0.D0
         E1B(L)=-SUM*TORE(NJ)
   70 E2A(L)=-SUM*TORE(NI)
      II=MAX(NI,NJ)
      NBOND=(II*(II-1))/2+NI+NJ-II
      RIJ=SQRT(RIJ)
      SCALE=0
      IF(NATORB(NI).EQ.0) SCALE=EXP(-ALP(NI)*RIJ)
      IF(NATORB(NJ).EQ.0) SCALE=SCALE+EXP(-ALP(NI)*RIJ)
      IF(NBOND.LT.154) THEN
         IF(NBOND.EQ.22 .OR. NBOND .EQ. 29) GO TO 80
         GO TO 90
   80    SCALE=ALP3(NBOND)*EXP(-RIJ)
         GO TO 100
   90    SCALE=EXP(-ALP3(NBOND)*RIJ)
  100    CONTINUE
      ENDIF
      IF(ABS(TORE(NI)).GT.20.AND.ABS(TORE(NJ)).GT.20) THEN
         ENUC=0.D0
      ELSEIF (RIJ.LT.1.D0.AND.NATORB(NI)*NATORB(NJ).EQ.0) THEN
         ENUC=0.D0
      ELSE
         ENUC=TORE(NI)*TORE(NJ)*SUM+
     1         ABS(TORE(NI)*TORE(NJ)*(14.399D0/RIJ-SUM)*SCALE)
      ENDIF
      RETURN
  110 CONTINUE
      RIJ=MIN(SQRT(RIJ),CUTOFF)
      CALL REPP(NI,NJ,RIJ,RI,CORE)
      GAM=RI(1)
C
C *** THE REPULSION INTEGRALS OVER MOLECULAR FRAME (W) ARE STORED IN THE
C     ORDER IN WHICH THEY WILL LATER BE USED.  IE.  (I,J/K,L) WHERE
C     J.LE.I  AND  L.LE.K     AND L VARIES MOST RAPIDLY AND I LEAST
C     RAPIDLY.  (ANTI-NORMAL COMPUTER STORAGE)
C
      A=1.D0/RIJ
      DO 120 I=1,3
  120 X(I)=X(I)*A
      Z(3)=0.D0
      IF(ABS(X(3)).GT.0.99999999D0) THEN
         X(3)=SIGN(1.D0,X(3))
         GOTO 130
      ENDIF
      Z(3)=SQRT(1.D0-X(3)**2)
      A=1.D0/Z(3)
      Y(1)=-A*X(2)*SIGN(1.D0,X(1))
      Y(2)=ABS(A*X(1))
      Y(3)=0.D0
      Z(1)=-A*X(1)*X(3)
      Z(2)=-A*X(2)*X(3)
      GOTO 140
  130 Y(1)=0.D0
      Y(2)=1.D0
      Y(3)=0.D0
      Z(1)=1.D0
      Z(2)=0.D0
  140 CONTINUE
      IB=MIN(NATORB(NI),4)
      JB=MIN(NATORB(NJ),4)
      KI=0
      DO 270 I=1,IB
         SI=I.EQ.1
         II=I-1
         DO 270 J=1,I
            JJ=J-1
            IJ=0
            IF (JJ.EQ.0) IJ=-1
            IF (SI) IJ=+1
            DO 270 K=1,JB
               KK=K-1
               SK=KK.GT.0
               DO 270 L=1,K
                  KI=KI+1
                  IF (SK) GO TO 180
C
C *** INTEGRAL (I,J/K,L) IS OF THE TYPE (I,J/S,S)
C
                  IF (IJ) 160, 170, 150
C
C     (SS/SS)
C
  150             W(KI)=RI(1)
                  GO TO 260
C
C     (PS/SS)
C
  160             W(KI)=RI(2)*X(II)
                  GO TO 260
C
C     (PP/SS)
C
  170             W(KI)=RI(3)*X(II)*X(JJ)+RI(4)*(Y(II)*Y(JJ)+Z(II)*Z(JJ)
     1)
                  GO TO 260
  180             LL=L-1
                  IF (LL.GT.0) GO TO 220
C
C *** INTEGRAL (I,J/K,L) IS OF THE TYPE (I,J/P,S)
C
                  IF (IJ) 200, 210, 190
C
C     (SS/PS)
C
  190             W(KI)=RI(5)*X(KK)
                  GO TO 260
C
C     (PS/PS)
C
  200             W(KI)=RI(6)*X(II)*X(KK)+RI(7)*(Y(II)*Y(KK)+Z(II)*Z(KK)
     1)
                  GO TO 260
C
C     (PP/PS)
C
  210             W(KI)=X(KK)*(RI(8)*X(II)*X(JJ)+RI(9)*(Y(II)*Y(JJ)+Z(II
     1)*Z(JJ)))   +RI(10)*(X(II)*(Y(JJ)*Y(KK)+Z(JJ)*Z(KK))+X(JJ)*(Y(II)*
     2Y(KK)+Z(I   I)*Z(KK)))
                  GO TO 260
C
C *** INTEGRAL (I,J/K,L) IS OF THE TYPE (I,J/P,P)
C
  220             IF (IJ) 240,250,230
C
C     (SS/PP)
C
  230             W(KI)=RI(11)*X(KK)*X(LL)+RI(12)*(Y(KK)*Y(LL)+Z(KK)*Z(L
     1L))
                  GO TO 260
C
C     (PS/PP)
C
  240             W(KI)=X(II)*(RI(13)*X(KK)*X(LL)+RI(14)*(Y(KK)*Y(LL)+Z(
     1KK)*Z(LL)   ))+RI(15)*(Y(II)*(Y(KK)*X(LL)+Y(LL)*X(KK))+Z(II)*(Z(KK
     2)*X(LL)+Z   (LL)*X(KK)))
                  GO TO 260
C
C     (PP/PP)
C
  250             W(KI)=(RI(16)*X(II)*X(JJ)+RI(17)*(Y(II)*Y(JJ)+Z(II)*Z(
     1JJ)))*X(K   K)*X(LL)+RI(18)*X(II)*X(JJ)*(Y(KK)*Y(LL)+Z(KK)*Z(LL))+
     2RI(19)*(Y   (II)*Y(JJ)*Y(KK)*Y(LL)+Z(II)*Z(JJ)*Z(KK)*Z(LL))+RI(20)
     3*(X(II)*(   X(KK)*(Y(JJ)*Y(LL)+Z(JJ)*Z(LL))+X(LL)*(Y(JJ)*Y(KK)+Z(J
     4J)*Z(KK))   )+X(JJ)*(X(KK)*(Y(II)*Y(LL)+Z(II)*Z(LL))+X(LL)*(Y(II)*
     5Y(KK)+Z(I   I)*Z(KK))))+RI(21)*(Y(II)*Y(JJ)*Z(KK)*Z(LL)+Z(II)*Z(JJ
     6)*Y(KK)*Y   (LL))+RI(22)*(Y(II)*Z(JJ)+Z(II)*Y(JJ))*(Y(KK)*Z(LL)+Z(
     7KK)*Y(LL)   )
  260             CONTINUE
  270 CONTINUE
  280 CONTINUE
      E1B(1)=-CSS1
      IF(NI.GT.3) THEN
         E1B(2) = -CSP1 *X1
         E1B(3) = -CPPS1*X1**2-CPPP1*(Y1**2+Z1**2)
         E1B(4) = -CSP1 *X2
         E1B(5) = -CPPS1*X1*X2-CPPP1*(Y1*Y2+Z1*Z2)
         E1B(6) = -CPPS1*X2*X2-CPPP1*(Y2*Y2+Z2*Z2)
         E1B(7) = -CSP1 *X3
         E1B(8) = -CPPS1*X1*X3-CPPP1*(Y1*Y3+Z1*Z3)
         E1B(9) = -CPPS1*X2*X3-CPPP1*(Y2*Y3+Z2*Z3)
         E1B(10)= -CPPS1*X3*X3-CPPP1*(Y3*Y3+Z3*Z3)
      END IF
      E2A(1)=-CSS2
      IF(NJ.GT.3) THEN
         E2A(2) = -CSP2 *X1
         E2A(3) = -CPPS2*X1**2-CPPP2*(Y1**2+Z1**2)
         E2A(4) = -CSP2 *X2
         E2A(5) = -CPPS2*X1*X2-CPPP2*(Y1*Y2+Z1*Z2)
         E2A(6) = -CPPS2*X2*X2-CPPP2*(Y2*Y2+Z2*Z2)
         E2A(7) = -CSP2 *X3
         E2A(8) = -CPPS2*X1*X3-CPPP2*(Y1*Y3+Z1*Z3)
         E2A(9) = -CPPS2*X2*X3-CPPP2*(Y2*Y3+Z2*Z3)
         E2A(10)= -CPPS2*X3*X3-CPPP2*(Y3*Y3+Z3*Z3)
      END IF
      IF(ABS(TORE(NI)).GT.20.AND.ABS(TORE(NJ)).GT.20) THEN
C SPARKLE-SPARKLE INTERACTION
         ENUC=0.D0
         RETURN
      ELSEIF (RIJ.LT.1.D0.AND.NATORB(NI)*NATORB(NJ).EQ.0) THEN
         ENUC=0.D0
         RETURN
      ENDIF
      SCALE = EXP(-ALP(NI)*RIJ)+EXP(-ALP(NJ)*RIJ)
      NT=NI+NJ
      IF(NT.EQ.8.OR.NT.EQ.9) THEN
         IF(NI.EQ.7.OR.NI.EQ.8) SCALE=SCALE+(RIJ-1.D0)*EXP(-ALP(NI)*RIJ)
         IF(NJ.EQ.7.OR.NJ.EQ.8) SCALE=SCALE+(RIJ-1.D0)*EXP(-ALP(NJ)*RIJ)
      ENDIF
      ENUC = TORE(NI)*TORE(NJ)*GAM
      SCALE=ABS(SCALE*ENUC)
      IF( AM1 )THEN
         DO 290 IG=1,10
            IF(ABS(FN1(NI,IG)).GT.0.D0)
     1SCALE=SCALE +TORE(NI)*TORE(NJ)/RIJ*
     2FN1(NI,IG)*EXP(-FN2(NI,IG)*(RIJ-FN3(NI,IG))**2)
            IF(ABS(FN1(NJ,IG)).GT.0.D0)
     1SCALE=SCALE +TORE(NI)*TORE(NJ)/RIJ*
     2FN1(NJ,IG)*EXP(-FN2(NJ,IG)*(RIJ-FN3(NJ,IG))**2)
  290    CONTINUE
      ENDIF
      ENUC=ENUC+SCALE
C
C *** NOW ROTATE THE NUCLEAR ATTRACTION INTEGRALS.
C *** THE STORAGE OF THE NUCLEAR ATTRACTION INTEGRALS  CORE(KL/IJ) IS
C     (SS/)=1,   (SO/)=2,   (OO/)=3,   (PP/)=4
C
C   DEBUG PRINTING
C
      KR=KR+KI
      RETURN
      END


cc ------------ dpmjet3.4 - authors: S.Roesler, R.Engel, J.Ranft -------
cc -------- phojet1.12-40 - authors: S.Roesler, R.Engel, J.Ranft -------
cc                                                      - oct'13 -------
cc ----------- pythia-6.4 - authors: Torbjorn Sjostrand, Lund'10 -------
cc ---------------------------------------------------------------------
cc                                  converted for use with FLUKA -------
cc                                                      - oct'13 -------

C...PYPREP
C...Rearranges partons along strings.
C...Special considerations for systems with junctions, with
C...possibility of junction-antijunction annihilation.
C...Allows small systems to collapse into one or two particles.
C...Checks flavours and colour singlet invariant masses.

      SUBROUTINE PYPREP(IP)

C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      INTEGER PYCOMP

C...Commonblocks.
      include 'inc/pyjets'
      include 'inc/pydat1'
      include 'inc/pypars'
      include 'inc/pydat2'
      include 'inc/pydat3'
      include 'inc/pyint1'
C...The common block of colour tags.
      include 'inc/pyctag'

      DATA NERRPR/0/
      SAVE NERRPR
C...Local arrays.
C unvar      DIMENSION DPS(5),DPC(5),UE(3),PG(5),E1(3),E2(3),E3(3),E4(3),
C unvar     &ECL(3),IJUNC(10,0:4),IPIECE(30,0:4),KFEND(4),KFQ(4),
C unvar     &IJUR(4),PJU(4,6),IRNG(4,2),TJJ(2,5),T(5),PUL(3,5),
C unvar     &IJCP(0:6),TJUOLD(5)
       DIMENSION DPS(5),DPC(5),UE(3),PG(5),E1(3),E2(3),E3(3),E4(3),
     &ECL(3),IJUNC(10,0:4),IPIECE(30,0:4),KFQ(4),
     &IJUR(4),PJU(4,6),IRNG(4,2),TJJ(2,5),T(5),PUL(3,5),
     &IJCP(0:6),TJUOLD(5)
      CHARACTER CHTMP*6

C...Function to give four-product.
      FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)

C...Rearrange parton shower product listing along strings: begin loop.
      MSTU(24)=0
      NOLD=N
      I1=N
      NJUNC=0
      NPIECE=0
      NJJSTR=0
      MSTU32=MSTU(32)+1
      DO 100 I=MAX(1,IP),N
C...First store junction positions.
        IF(K(I,1).EQ.42) THEN
          NJUNC=NJUNC+1
          IJUNC(NJUNC,0)=I
          IJUNC(NJUNC,4)=0
        ENDIF
  100 CONTINUE

      DO 250 MQGST=1,3
        DO 240 I=MAX(1,IP),N
C...Special treatment for junctions
          IF (K(I,1).LE.0) GOTO 240
          IF(K(I,1).EQ.42) THEN
C...MQGST=2: Look for junction-junction strings (not detected in the
C...main search below).
            IF (MQGST.EQ.2.AND.NPIECE.NE.3*NJUNC) THEN
              IF (NJJSTR.EQ.0) THEN
                NJJSTR = (3*NJUNC-NPIECE)/2
              ENDIF
C...Check how many already identified strings end on this junction
              ILC=0
              DO 110 J=1,NPIECE
                IF (IPIECE(J,4).EQ.I) ILC=ILC+1
  110         CONTINUE
C...If less than 3, remaining must be to another junction
              IF (ILC.LT.3) THEN
                IF (ILC.NE.2) THEN
C...Multiple j-j connections not handled yet.
                  CALL PYERRM(2,
     &            '(PYPREP:) Too many junction-junction strings.')
                  MINT(51)=1
                  RETURN
                ENDIF
C...The colour information in the junction is unreadable for the
C...colour space search further down in this routine, so we must
C...start on the colour mother of this junction and then "artificially"
C...prevent the colour mother from connecting here again.
                ITJUNC=MOD(K(I,4)/MSTU(5),MSTU(5))
                KCS=4
                IF (MOD(ITJUNC,2).EQ.0) KCS=5
C...Switch colour if the junction-junction leg is presumably a
C...junction mother leg rather than a junction daughter leg.
                IF (ITJUNC.GE.3) KCS=9-KCS
                IF (MINT(33).EQ.0) THEN
C...Find the unconnected leg and reorder junction daughter pointers so
C...MOD(K(I,4),MSTU(5)) always points to the junction-junction string
C...piece.
                  IA=MOD(K(I,4),MSTU(5))
                  IF (K(IA,KCS)/MSTU(5)**2.GE.2) THEN
                    ITMP=MOD(K(I,5),MSTU(5))
                    IF (K(ITMP,KCS)/MSTU(5)**2.GE.2) THEN
                      ITMP=MOD(K(I,5)/MSTU(5),MSTU(5))
                      K(I,5)=K(I,5)+(IA-ITMP)*MSTU(5)
                    ELSE
                      K(I,5)=K(I,5)+(IA-ITMP)
                    ENDIF
                    K(I,4)=K(I,4)+(ITMP-IA)
                    IA=ITMP
                  ENDIF
                  IF (ITJUNC.LE.2) THEN
C...Beam baryon junction
                    K(IA,KCS)   = K(IA,KCS) + 2*MSTU(5)**2
                    K(I,KCS)    = K(I,KCS) + 1*MSTU(5)**2
C...Else 1 -> 2 decay junction
                  ELSE
                    K(IA,KCS)   = K(IA,KCS) + MSTU(5)**2
                    K(I,KCS)    = K(I,KCS) + 2*MSTU(5)**2
                  ENDIF
                  I1BEG = I1
                  NSTP = 0
                  GOTO 170
C...Alternatively use colour tag information.
                ELSE
C...Find a final state parton with appropriate dangling colour tag.
                  JCT=0
                  IA=0
                  IJUMO=K(I,3)
                  DO 140 J1=MAX(1,IP),N
                    IF (K(J1,1).NE.3) GOTO 140
C...Check for matching final-state colour tag
                    IMATCH=0
                    DO 120 J2=MAX(1,IP),N
                      IF (K(J2,1).NE.3) GOTO 120
                      IF (MCT(J1,KCS-3).EQ.MCT(J2,6-KCS)) IMATCH=1
  120               CONTINUE
                    IF (IMATCH.EQ.1) GOTO 140
C...Check whether this colour tag belongs to the present junction
C...by seeing whether any parton with this colour tag has the same
C...mother as the junction.
                    JCT=MCT(J1,KCS-3)
                    IMATCH=0
                    DO 130 J2=MINT(84)+1,N
                      IMO2=K(J2,3)
C...First scattering partons have IMO1 = 3 and 4.
                      IF (IMO2.EQ.MINT(83)+3.OR.IMO2.EQ.MINT(83)+4)
     &                     IMO2=IMO2-2
                      IF (MCT(J2,KCS-3).EQ.JCT.AND.IMO2.EQ.IJUMO)
     &                     IMATCH=1
  130               CONTINUE
                    IF (IMATCH.EQ.0) GOTO 140
                    IA=J1
  140             CONTINUE
C...Check for junction-junction strings without intermediate final state
C...glue (not detected above).
                  IF (IA.EQ.0) THEN
                    DO 160 MJU=1,NJUNC
                      IJU2=IJUNC(MJU,0)
                      IF (IJU2.EQ.I) GOTO 160
                      ITJU2=MOD(K(IJU2,4)/MSTU(5),MSTU(5))
C...Only opposite types of junctions can connect to each other.
                      IF (MOD(ITJU2,2).EQ.MOD(ITJUNC,2)) GOTO 160
                      IS=0
                      DO 150 J=1,NPIECE
                        IF (IPIECE(J,4).EQ.IJU2) IS=IS+1
  150                 CONTINUE
                      IF (IS.EQ.3) GOTO 160
                      IB=I
                      IA=IJU2
  160               CONTINUE
                  ENDIF
C...Switch to other side of adjacent parton and step from there.
                  KCS=9-KCS
                  I1BEG = I1
                  NSTP = 0
                  GOTO 170
                ENDIF
              ELSE IF (ILC.NE.3) THEN
              ENDIF
            ENDIF
          ENDIF

C...Look for coloured string endpoint, or (later) leftover gluon.
          IF(K(I,1).NE.3) GOTO 240
          KC=PYCOMP(K(I,2))
          IF(KC.EQ.0) GOTO 240
          KQ=KCHG(KC,2)
          IF(KQ.EQ.0.OR.(MQGST.LE.2.AND.KQ.EQ.2)) GOTO 240

C...Pick up loose string end.
          KCS=4
          IF(KQ*SIGN(1,K(I,2)).LT.0) KCS=5
          IA=I
          IB=I
          I1BEG=I1
          NSTP=0
  170     NSTP=NSTP+1
          IF(NSTP.GT.4*N) THEN
            CALL PYERRM(14,'(PYPREP:) caught in infinite loop')
            MINT(51)=1
            RETURN
          ENDIF

C...Copy undecayed parton. Finished if reached string endpoint.
          IF(K(IA,1).EQ.3) THEN
            IF(I1.GE.MSTU(4)-MSTU32-5) THEN
              CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
              MINT(51)=1
              MSTU(24)=1
              RETURN
            ENDIF
            I1=I1+1
            K(I1,1)=2
            IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1
            K(I1,2)=K(IA,2)
            K(I1,3)=IA
            K(I1,4)=0
            K(I1,5)=0
            DO 180 J=1,5
              P(I1,J)=P(IA,J)
              V(I1,J)=V(IA,J)
  180       CONTINUE
            K(IA,1)=K(IA,1)+10
            IF(K(I1,1).EQ.1) GOTO 240
          ENDIF

C...Also finished (for now) if reached junction; then copy to end.
          IF(K(IA,1).EQ.42) THEN
            NCOPY=I1-I1BEG
            IF(I1.GE.MSTU(4)-MSTU32-NCOPY-5) THEN
              CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
              MINT(51)=1
              MSTU(24)=1
              RETURN
            ENDIF
            IF (MQGST.LE.2.AND.NCOPY.NE.0) THEN
              DO 200 ICOPY=1,NCOPY
                DO 190 J=1,5
                  K(MSTU(4)-MSTU32-ICOPY,J)=K(I1BEG+ICOPY,J)
                  P(MSTU(4)-MSTU32-ICOPY,J)=P(I1BEG+ICOPY,J)
                  V(MSTU(4)-MSTU32-ICOPY,J)=V(I1BEG+ICOPY,J)
  190           CONTINUE
  200         CONTINUE
            ENDIF
C...For junction-junction strings, find end leg and reorder junction
C...daughter pointers so MOD(K(I,4),MSTU(5)) always points to the
C...junction-junction string piece.
            IF (K(I,1).EQ.42.AND.MINT(33).EQ.0) THEN
              ITMP=MOD(K(IA,4),MSTU(5))
              IF (ITMP.NE.IB) THEN
                IF (MOD(K(IA,5),MSTU(5)).EQ.IB) THEN
                  K(IA,5)=K(IA,5)+(ITMP-IB)
                ELSE
                  K(IA,5)=K(IA,5)+(ITMP-IB)*MSTU(5)
                ENDIF
                K(IA,4)=K(IA,4)+(IB-ITMP)
              ENDIF
            ENDIF
            NPIECE=NPIECE+1
C...IPIECE:
C...0: endpoint in original ER
C...1:
C...2:
C...3: Parton immediately next to junction
C...4: Junction
            IPIECE(NPIECE,0)=I
            IPIECE(NPIECE,1)=MSTU32+1
            IPIECE(NPIECE,2)=MSTU32+NCOPY
            IPIECE(NPIECE,3)=IB
            IPIECE(NPIECE,4)=IA
            MSTU32=MSTU32+NCOPY
            I1=I1BEG
            GOTO 240
          ENDIF

C...GOTO next parton in colour space.
          IB=IA
          IF (MINT(33).EQ.0) THEN
            IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5
     &           )).NE.0) THEN
              IA=MOD(K(IB,KCS),MSTU(5))
              K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
              MREV=0
            ELSE
              IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
     &             MSTU(5)).EQ.0) KCS=9-KCS
              IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
              K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
              MREV=1
            ENDIF
            IF(IA.LE.0.OR.IA.GT.N) THEN
              CALL PYERRM(12,'(PYPREP:) colour rearrangement failed')
              IF(NERRPR.LT.5) THEN
                NERRPR=NERRPR+1
                WRITE(MSTU(11),*) 'started at:', I
                WRITE(MSTU(11),*) 'ended going from',IB,' to',IA
                WRITE(MSTU(11),*) 'MQGST =',MQGST
                CALL PYLIST(4)
              ENDIF
              MINT(51)=1
              RETURN
            ENDIF
            IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5)
     &           ,MSTU(5)).EQ.IB) THEN
              IF(MREV.EQ.1) KCS=9-KCS
              IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
              K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
            ELSE
              IF(MREV.EQ.0) KCS=9-KCS
              IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
              K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
            ENDIF
            IF(IA.NE.I) GOTO 170
C...Use colour tag information
          ELSE
C...First create colour tags starting on IB if none already present.
            IF (MCT(IB,KCS-3).EQ.0) THEN
              CALL PYCTTR(IB,KCS,IB)
              IF(MINT(51).NE.0) RETURN
            ENDIF
            JCT=MCT(IB,KCS-3)
            IFOUND=0
C...Find final state tag partner
            DO 210 IT=MAX(1,IP),N
              IF (IT.EQ.IB) GOTO 210
              IF (MCT(IT,6-KCS).EQ.JCT.AND.K(IT,1).LT.10.AND.K(IT,1).GT
     &             .0) THEN
                IFOUND=IFOUND+1
                IA=IT
              ENDIF
  210       CONTINUE
C...Just copy and goto next if exactly one partner found.
            IF (IFOUND.EQ.1) THEN
              GOTO 170
C...When no match found, match is presumably junction.
            ELSEIF (IFOUND.EQ.0.AND.MQGST.LE.2) THEN
C...Check whether this colour tag matches a junction
C...by seeing whether any parton with this colour tag has the same
C...mother as a junction.
C...NB: Only type 1 and 2 junctions handled presently.
              DO 230 IJU=1,NJUNC
                IJUMO=K(IJUNC(IJU,0),3)
                ITJUNC=MOD(K(IJUNC(IJU,0),4)/MSTU(5),MSTU(5))
C...Colours only connect to junctions, anti-colours to antijunctions:
                IF (MOD(ITJUNC+1,2)+1.NE.KCS-3) GOTO 230
                IMATCH=0
                DO 220 J1=MAX(1,IP),N
                  IF (K(J1,1).LE.0) GOTO 220
C...First scattering partons have IMO1 = 3 and 4.
                  IMO=K(J1,3)
                  IF (IMO.EQ.MINT(83)+3.OR.IMO.EQ.MINT(83)+4)
     &                 IMO=IMO-2
                  IF (MCT(J1,KCS-3).EQ.JCT.AND.IMO.EQ.IJUMO.AND.MOD(K(J1
     &                 ,3+ITJUNC)/MSTU(5),MSTU(5)).EQ.IJUNC(IJU,0))
     &                 IMATCH=1
C...Attempt at handling type > 3 junctions also. Not tested.
                  IF (ITJUNC.GE.3.AND.MCT(J1,6-KCS).EQ.JCT.AND.IMO.EQ
     &                 .IJUMO) IMATCH=1
  220           CONTINUE
                IF (IMATCH.EQ.0) GOTO 230
                IA=IJUNC(IJU,0)
                IFOUND=IFOUND+1
  230         CONTINUE

              IF (IFOUND.EQ.1) THEN
                GOTO 170
              ELSEIF (IFOUND.EQ.0) THEN
                WRITE(CHTMP,'(I6)') JCT
                CALL PYERRM(12,'(PYPREP:) no matching colour tag: '
     &               //CHTMP)
                IF(NERRPR.LT.5) THEN
                  NERRPR=NERRPR+1
                  CALL PYLIST(4)
                ENDIF
                MINT(51)=1
                RETURN
              ENDIF
            ELSEIF (IFOUND.GE.2) THEN
              WRITE(CHTMP,'(I6)') JCT
              CALL PYERRM(12
     &             ,'(PYPREP:) too many occurences of colour line: '//
     &             CHTMP)
              IF(NERRPR.LT.5) THEN
                NERRPR=NERRPR+1
                CALL PYLIST(4)
              ENDIF
              MINT(51)=1
              RETURN
            ENDIF
          ENDIF
          K(I1,1)=1
  240   CONTINUE
  250 CONTINUE

C...Junction systems remain.
      IJU=0
      IJUS=0
      IJUCNT=0
      MREV=0
      IJJSTR=0
  260 IJUCNT=IJUCNT+1
      IF (IJUCNT.LE.NJUNC) THEN
C...If we are not processing a j-j string, treat this junction as new.
        IF (IJJSTR.EQ.0) THEN
          IJU=IJUNC(IJUCNT,0)
          MREV=0
C...If junction has already been read, ignore it.
          IF (IJUNC(IJUCNT,4).EQ.1) GOTO 260
C...If we are on a j-j string, goto second j-j junction.
        ELSE
          IJUCNT=IJUCNT-1
          IJU=IJUS
        ENDIF
C...Mark selected junction read.
        DO 270 J=1,NJUNC
          IF (IJUNC(J,0).EQ.IJU) IJUNC(J,4)=1
  270   CONTINUE
C...Determine junction type
        ITJUNC = MOD(K(IJU,4)/MSTU(5),MSTU(5))
C...Type 1 and 2 junctions: ~chi -> q q q, ~chi -> qbar,qbar,qbar
C...Type 3 and 4 junctions: ~qbar -> q q , ~q -> qbar qbar
C...Type 5 and 6 junctions: ~g -> q q q, ~g -> qbar qbar qbar
        IF (ITJUNC.GE.1.AND.ITJUNC.LE.6) THEN
          IHK=0
  280     IHK=IHK+1
C...Find which quarks belong to given junction.
          IHF=0
          DO 290 IPC=1,NPIECE
            IF (IPIECE(IPC,4).EQ.IJU) THEN
              IHF=IHF+1
              IF (IHF.EQ.IHK) IEND=IPIECE(IPC,3)
            ENDIF
            IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJU) IEND=IPIECE(IPC,3)
  290     CONTINUE
C...IHK = 3 is special. Either normal string piece, or j-j string.
          IF(IHK.EQ.3) THEN
            IF (MREV.NE.1) THEN
              DO 300 IPC=1,NPIECE
C...If there is a j-j string starting on the present junction which has
C...zero length, insert next junction immediately.
                IF (IPIECE(IPC,0).EQ.IJU.AND.K(IPIECE(IPC,4),1)
     &          .EQ.42.AND.IPIECE(IPC,1)-1-IPIECE(IPC,2).EQ.0) THEN
                  IJJSTR = 1
                  GOTO 340
                ENDIF
  300         CONTINUE
              MREV = 1
C...If MREV is 1 and IHK is 3 we are finished with this system.
            ELSE
              MREV=0
              GOTO 260
            ENDIF
          ENDIF

C...If we've gotten this far, then either IHK < 3, or
C...an interjunction string exists, or just a third normal string.
          IJUNC(IJUCNT,IHK)=0
          IJJSTR = 0
C..Order pieces belonging to this junction. Also look for j-j.
          DO 310 IPC=1,NPIECE
            IF (IPIECE(IPC,3).EQ.IEND) IJUNC(IJUCNT,IHK)=IPC
            IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJUNC(IJUCNT,0)
     &      .AND.K(IPIECE(IPC,4),1).EQ.42) THEN
              IJUNC(IJUCNT,IHK)=IPC
              IJJSTR = 1
              MREV = 0
            ENDIF
  310     CONTINUE
C...Copy back chains in proper order. MREV=0/1 : descending/ascending
          IPC=IJUNC(IJUCNT,IHK)
C...Temporary solution to cover for bug.
          IF(IPC.LE.0) THEN
            CALL PYERRM(12,'(PYPREP:) fails to hook up junctions')
            MINT(51)=1
            RETURN
          ENDIF
          DO 330 ICP=IPIECE(IPC,1+MREV),IPIECE(IPC,2-MREV),1-2*MREV
            I1=I1+1
            DO 320 J=1,5
              K(I1,J)=K(MSTU(4)-ICP,J)
              P(I1,J)=P(MSTU(4)-ICP,J)
              V(I1,J)=V(MSTU(4)-ICP,J)
  320       CONTINUE
  330     CONTINUE
          K(I1,1)=2
C...Mark last quark.
          IF (MREV.EQ.1.AND.IHK.GE.2) K(I1,1)=1
C...Do not insert junctions at wrong places.
          IF(IHK.LT.2.OR.MREV.NE.0) GOTO 360
C...Insert junction.
  340     IJUS = IJU
          IF (IHK.EQ.3) THEN
C...Shift to end junction if a j-j string has been processed.
            IF (IJJSTR.NE.0) IJUS = IPIECE(IPC,4)
            MREV= 1
          ENDIF
          I1=I1+1
          DO 350 J=1,5
            K(I1,J)=0
            P(I1,J)=0.
            V(I1,J)=0.
  350     CONTINUE
          K(I1,1)=41
          K(IJUS,1)=K(IJUS,1)+10
          K(I1,2)=K(IJUS,2)
          K(I1,3)=IJUS
  360     IF (IHK.LT.3) GOTO 280
        ELSE
          CALL PYERRM(12,'(PYPREP:) Unknown junction type')
          MINT(51)=1
          RETURN
        ENDIF
        IF (IJUCNT.NE.NJUNC) GOTO 260
      ENDIF
      N=I1

C...Rearrange three strings from junction, e.g. in case one has been
C...shortened by shower, so the last is the largest-energy one.
      IF(NJUNC.GE.1) THEN
C...Find systems with exactly one junction.
        MJUN1=0
        NBEG=NOLD+1
        DO 470 I=NOLD+1,N
          IF(K(I,1).NE.1.AND.K(I,1).NE.41) THEN
          ELSEIF(K(I,1).EQ.41) THEN
            MJUN1=MJUN1+1
          ELSEIF(K(I,1).EQ.1.AND.MJUN1.NE.1) THEN
            MJUN1=0
            NBEG=I+1
          ELSE
            NEND=I
C...Sum up energy-momentum in each junction string.
            DO 370 J=1,5
              PJU(1,J)=0D0
              PJU(2,J)=0D0
              PJU(3,J)=0D0
  370       CONTINUE
            NJU=0
            DO 390 I1=NBEG,NEND
              IF(K(I1,2).NE.21) THEN
                NJU=NJU+1
                IJUR(NJU)=I1
              ENDIF
              DO 380 J=1,5
                PJU(MIN(NJU,3),J)=PJU(MIN(NJU,3),J)+P(I1,J)
  380         CONTINUE
  390       CONTINUE
C...Find which of them has highest energy (minus mass) in rest frame.
            DO 400 J=1,5
              PJU(4,J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
  400       CONTINUE
            PMJU=SQRT(MAX(0D0,PJU(4,4)**2-PJU(4,1)**2-PJU(4,2)**2-
     &      PJU(4,3)**2))
            DO 410 I2=1,3
              PJU(I2,6)=(PJU(4,4)*PJU(I2,4)-PJU(4,1)*PJU(I2,1)-
     &        PJU(4,2)*PJU(I2,2)-PJU(4,3)*PJU(I2,3))/PMJU-PJU(I2,5)
  410       CONTINUE
            IF(PJU(3,6).LT.MIN(PJU(1,6),PJU(2,6))) THEN
C...Decide how to rearrange so that new last has highest energy.
              IF(PJU(1,6).LT.PJU(2,6)) THEN
                IRNG(1,1)=IJUR(1)
                IRNG(1,2)=IJUR(2)-1
                IRNG(2,1)=IJUR(4)
                IRNG(2,2)=IJUR(3)+1
                IRNG(4,1)=IJUR(3)-1
                IRNG(4,2)=IJUR(2)
              ELSE
                IRNG(1,1)=IJUR(4)
                IRNG(1,2)=IJUR(3)+1
                IRNG(2,1)=IJUR(2)
                IRNG(2,2)=IJUR(3)-1
                IRNG(4,1)=IJUR(2)-1
                IRNG(4,2)=IJUR(1)
              ENDIF
              IRNG(3,1)=IJUR(3)
              IRNG(3,2)=IJUR(3)
C...Copy in correct order below bottom of current event record.
              I2=N
              DO 440 II=1,4
                DO 430 I1=IRNG(II,1),IRNG(II,2),
     &          SIGN(1,IRNG(II,2)-IRNG(II,1))
                  I2=I2+1
                  IF(I2.GE.MSTU(4)-MSTU32-5) THEN
                    CALL PYERRM(11,
     &              '(PYPREP:) no more memory left in PYJETS')
                    MINT(51)=1
                    MSTU(24)=1
                    RETURN
                  ENDIF
                  DO 420 J=1,5
                    K(I2,J)=K(I1,J)
                    P(I2,J)=P(I1,J)
                    V(I2,J)=V(I1,J)
  420             CONTINUE
                  IF(K(I2,1).EQ.1) K(I2,1)=2
  430           CONTINUE
  440         CONTINUE
              K(I2,1)=1
C...Copy back up, overwriting but now in correct order.
              DO 460 I1=NBEG,NEND
                I2=I1-NBEG+N+1
                DO 450 J=1,5
                  K(I1,J)=K(I2,J)
                  P(I1,J)=P(I2,J)
                  V(I1,J)=V(I2,J)
  450           CONTINUE
  460         CONTINUE
            ENDIF
            MJUN1=0
            NBEG=I+1
          ENDIF
  470   CONTINUE

C...Check whether q-q-j-j-qbar-qbar systems should be collapsed
C...to two q-qbar systems.
C...(MSTJ(19)=1 forces q-q-j-j-qbar-qbar.)
        IF (MSTJ(19).NE.1) THEN
          MJUN1  = 0
          JJGLUE = 0
          NBEG   = NOLD+1
C...Force collapse when MSTJ(19)=2.
          IF (MSTJ(19).EQ.2) THEN
            DELMJJ = 1D9
            DELMQQ = 0D0
          ENDIF
C...Find systems with exactly two junctions.
          DO 700 I=NOLD+1,N
C...Count junctions
            IF (K(I,1).EQ.41) THEN
              MJUN1 = MJUN1+1
C...Check for interjunction gluons
              IF (MJUN1.EQ.2.AND.K(I-1,1).NE.41) THEN
                JJGLUE = 1
              ENDIF
            ELSEIF(K(I,1).EQ.1.AND.(MJUN1.NE.2)) THEN
C...If end of system reached with either zero or one junction, restart
C...with next system.
              MJUN1  = 0
              JJGLUE = 0
              NBEG   = I+1
            ELSEIF(K(I,1).EQ.1) THEN
C...If end of system reached with exactly two junctions, compute string
C...length measure for the (q-q-j-j-qbar-qbar) topology and compare with
C...length measure for the (q-qbar)(q-qbar) topology.
              NEND=I
C...Loop down through chain.
              ISID=0
              DO 480 I1=NBEG,NEND
C...Store string piece division locations in event record
                IF (K(I1,2).NE.21) THEN
                  ISID       = ISID+1
                  IJCP(ISID) = I1
                ENDIF
  480         CONTINUE
C...Randomly choose between (1,3)(2,4) and (1,4)(2,3) topologies.
              ISW=0
              IF (PYR(0).LT.0.5D0) ISW=1
C...Randomly choose which qqbar string gets the jj gluons.
              IGS=1
              IF (PYR(0).GT.0.5D0) IGS=2
C...Only compute string lengths when no topology forced.
              IF (MSTJ(19).EQ.0) THEN
C...Repeat following for each junction
                DO 570 IJU=1,2
C...Initialize iterative procedure for finding JRF
                  IJRFIT=0
                  DO 490 IX=1,3
                    TJUOLD(IX)=0D0
  490             CONTINUE
                  TJUOLD(4)=1D0
C...Start iteration. Sum up momenta in string pieces
  500             DO 540 IJS=1,3
C...JD=-1 for first junction, +1 for second junction.
C...Find out where piece starts and ends and which direction to go.
                    JD=2*IJU-3
                    IF (IJS.LE.2) THEN
                      IA = IJCP((IJU-1)*7 - JD*(IJS+1)) + JD
                      IB = IJCP((IJU-1)*7 - JD*IJS)
                    ELSEIF (IJS.EQ.3) THEN
                      JD =-JD
                      IA = IJCP((IJU-1)*7 + JD*(IJS)) + JD
                      IB = IJCP((IJU-1)*7 + JD*(IJS+3))
                    ENDIF
C...Initialize junction pull 4-vector.
                    DO 510 J=1,5
                      PUL(IJS,J)=0D0
  510               CONTINUE
C...Initialize weight
                    PWT = 0D0
                    PWTOLD = 0D0
C...Sum up (weighted) momenta along each string piece
                    DO 530 ISP=IA,IB,JD
C...If present parton not last in chain
                      IF (ISP.NE.IA.AND.ISP.NE.IB) THEN
C...If last parton was a junction, store present weight
                        IF (K(ISP-JD,2).EQ.88) THEN
                          PWTOLD = PWT
C...If last parton was a quark, reset to stored weight.
                        ELSEIF (K(ISP-JD,2).NE.21) THEN
                          PWT = PWTOLD
                        ENDIF
                      ENDIF
C...Skip next parton if weight already large
                      IF (PWT.GT.10D0) GOTO 530
C...Compute momentum in TJUOLD frame:
                      TDP=TJUOLD(1)*P(ISP,1)+TJUOLD(2)*P(ISP,2)+TJUOLD(3
     &                     )*P(ISP,3)
                      BFC=TDP/(1D0+TJUOLD(4))+P(ISP,4)
                      DO 520 J=1,3
                        TMP=P(ISP,J)+TJUOLD(J)*BFC
                        PUL(IJS,J)=PUL(IJS,J)+TMP*EXP(-PWT)
  520                 CONTINUE
C...Boosted energy
                      TMP=TJUOLD(4)*P(ISP,4)+TDP
                      PUL(IJS,4)=PUL(IJS,J)+TMP*EXP(-PWT)
C...Update weight
                      PWT=PWT+TMP/PARJ(48)
C...Put |p| rather than m in 5th slot
                      PUL(IJS,5)=SQRT(PUL(IJS,1)**2+PUL(IJS,2)**2
     &                     +PUL(IJS,3)**2)
  530               CONTINUE
  540             CONTINUE
C...Compute boost
                  IJRFIT=IJRFIT+1
                  CALL PYJURF(PUL,T)
C...Combine new boost (T) with old boost (TJUOLD)
                  TMP=T(1)*TJUOLD(1)+T(2)*TJUOLD(2)+T(3)*TJUOLD(3)
                  DO 550 IX=1,3
                    TJUOLD(IX)=T(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+T(4
     &                   ))
  550             CONTINUE
                  TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)
     &                 **2)
C...If last boost small, accept JRF, else iterate.
C...Also prevent possibility of infinite loop.
                  IF (ABS((T(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
     &                 IJRFIT.LT.MSTJ(18))THEN
                    GOTO 500
                  ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
                    CALL PYERRM(1,'(PYPREP:) failed to converge on JRF')
                  ENDIF
C...Store final boost, with change of sign since TJJ motion vector.
                  DO 560 IX=1,3
                    TJJ(IJU,IX)=-TJUOLD(IX)
  560             CONTINUE
                  TJJ(IJU,4)=SQRT(1D0+TJJ(IJU,1)**2+TJJ(IJU,2)**2
     &                 +TJJ(IJU,3)**2)
  570           CONTINUE
C...String length measure for (q-qbar)(q-qbar) topology.
C...Note only momenta of nearest partons used (since rest of system
C...identical).
                IF (JJGLUE.EQ.0) THEN
                  DELMQQ=4D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)*FOUR(IJCP(3)
     &                 -1,IJCP(5-ISW)+1)
                ELSE
C...Put jj gluons on selected string (IGS selected randomly above).
                  IF (IGS.EQ.1) THEN
                    DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
     &                   ,IJCP(4+ISW)+1)*FOUR(IJCP(3)-1,IJCP(5-ISW)+1)
                  ELSE
                    DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)
     &                   *FOUR(IJCP(3)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
     &                   ,IJCP(5-ISW)+1)
                  ENDIF
                ENDIF
C...String length measure for q-q-j-j-q-q topology.
                T1G1=0D0
                T2G2=0D0
                T1T2=0D0
                T1P1=0D0
                T1P2=0D0
                T2P3=0D0
                T2P4=0D0
                ISGN=-1
C...Note only momenta of nearest partons used (since rest of system
C...identical).
                DO 580 IX=1,4
                  IF (IX.EQ.4) ISGN=1
                  T1P1=T1P1+ISGN*TJJ(1,IX)*P(IJCP(2)-1,IX)
                  T1P2=T1P2+ISGN*TJJ(1,IX)*P(IJCP(3)-1,IX)
                  T2P3=T2P3+ISGN*TJJ(2,IX)*P(IJCP(4)+1,IX)
                  T2P4=T2P4+ISGN*TJJ(2,IX)*P(IJCP(5)+1,IX)
                  IF (JJGLUE.EQ.0) THEN
C...Junction motion vector dot product gives length when inter-junction
C...gluons absent.
                    T1T2=T1T2+ISGN*TJJ(1,IX)*TJJ(2,IX)
                  ELSE
C...Junction motion vector dot products with gluon momenta give length
C...when inter-junction gluons present.
                    T1G1=T1G1+ISGN*TJJ(1,IX)*P(IJCP(3)+1,IX)
                    T2G2=T2G2+ISGN*TJJ(2,IX)*P(IJCP(4)-1,IX)
                  ENDIF
  580           CONTINUE
                DELMJJ=16D0*T1P1*T1P2*T2P3*T2P4
                IF (JJGLUE.EQ.0) THEN
                  DELMJJ=DELMJJ*(T1T2+SQRT(T1T2**2-1))
                ELSE
                  DELMJJ=DELMJJ*4D0*T1G1*T2G2
                ENDIF
              ENDIF
C...If delmjj > delmqq collapse string system to q-qbar q-qbar
C...(Always the case for MSTJ(19)=2 due to initialization above)
              IF (DELMJJ.GT.DELMQQ) THEN
C...Put new system at end of event record
                NCOP=N
                DO 650 IST=1,2
                  DO 600 ICOP=IJCP(IST),IJCP(IST+1)-1
                    NCOP=NCOP+1
                    DO 590 IX=1,5
                      P(NCOP,IX)=P(ICOP,IX)
                      K(NCOP,IX)=K(ICOP,IX)
  590               CONTINUE
  600             CONTINUE
                  IF (JJGLUE.NE.0.AND.IST.EQ.IGS) THEN
C...Insert inter-junction gluon string piece (reversed)
                    NJJGL=0
                    DO 620 ICOP=IJCP(4)-1,IJCP(3)+1,-1
                      NJJGL=NJJGL+1
                      NCOP=NCOP+1
                      DO 610 IX=1,5
                        P(NCOP,IX)=P(ICOP,IX)
                        K(NCOP,IX)=K(ICOP,IX)
  610                 CONTINUE
  620               CONTINUE
                    ENDIF
                  IFC=-2*IST+3
                  DO 640 ICOP=IJCP(IST+IFC*ISW+3)+1,IJCP(IST+IFC*ISW+4)
                    NCOP=NCOP+1
                    DO 630 IX=1,5
                      P(NCOP,IX)=P(ICOP,IX)
                      K(NCOP,IX)=K(ICOP,IX)
  630               CONTINUE
  640             CONTINUE
                  K(NCOP,1)=1
  650           CONTINUE
C...Copy system back in right order
                DO 670 ICOP=NBEG,NEND-2
                  DO 660 IX=1,5
                    P(ICOP,IX)=P(N+ICOP-NBEG+1,IX)
                    K(ICOP,IX)=K(N+ICOP-NBEG+1,IX)
  660             CONTINUE
  670           CONTINUE
C...Shift down rest of event record
                DO 690 ICOP=NEND+1,N
                  DO 680 IX=1,5
                    P(ICOP-2,IX)=P(ICOP,IX)
                    K(ICOP-2,IX)=K(ICOP,IX)
  680             CONTINUE
  690             CONTINUE
C...Update length of event record.
                N=N-2
              ENDIF
              MJUN1=0
              NBEG=I+1
            ENDIF
  700     CONTINUE
        ENDIF
      ENDIF

C...Done if no checks on small-mass systems.
      IF(MSTJ(14).LT.0) RETURN
      IF(MSTJ(14).EQ.0) GOTO 1140

C...Find lowest-mass colour singlet jet system.
      NS=N
  710 NSIN=N-NS
      PDMIN=1D0+PARJ(32)
      IC=0
      DO 770 I=MAX(1,IP),N
        IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
        ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
          NSIN=NSIN+1
          IC=I
          DO 720 J=1,4
            DPS(J)=P(I,J)
  720     CONTINUE
          MSTJ(93)=1
          DPS(5)=PYMASS(K(I,2))
        ELSEIF(K(I,1).EQ.2.AND.K(I,2).NE.21) THEN
          DO 730 J=1,4
            DPS(J)=DPS(J)+P(I,J)
  730     CONTINUE
          MSTJ(93)=1
          DPS(5)=DPS(5)+PYMASS(K(I,2))
        ELSEIF(K(I,1).EQ.2) THEN
          DO 740 J=1,4
            DPS(J)=DPS(J)+P(I,J)
  740     CONTINUE
        ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
          DO 750 J=1,4
            DPS(J)=DPS(J)+P(I,J)
  750     CONTINUE
          MSTJ(93)=1
          DPS(5)=DPS(5)+PYMASS(K(I,2))
          PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-
     &    DPS(5)
          IF(PD.LT.PDMIN) THEN
            PDMIN=PD
            DO 760 J=1,5
              DPC(J)=DPS(J)
  760       CONTINUE
            IC1=IC
            IC2=I
          ENDIF
          IC=0
        ELSE
          NSIN=NSIN+1
        ENDIF
  770 CONTINUE

C...Done if lowest-mass system above threshold for string frag.
      IF(PDMIN.GE.PARJ(32)) GOTO 1140

C...Fill small-mass system as cluster.
      NSAV=N
      PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
      K(N+1,1)=11
      K(N+1,2)=91
      K(N+1,3)=IC1
      P(N+1,1)=DPC(1)
      P(N+1,2)=DPC(2)
      P(N+1,3)=DPC(3)
      P(N+1,4)=DPC(4)
      P(N+1,5)=PECM

C...Set up history, assuming cluster -> 2 hadrons.
      NBODY=2
      K(N+1,4)=N+2
      K(N+1,5)=N+3
      K(N+2,1)=1
      K(N+3,1)=1
      IF(MSTU(16).NE.2) THEN
        K(N+2,3)=N+1
        K(N+3,3)=N+1
      ELSE
        K(N+2,3)=IC1
        K(N+3,3)=IC2
      ENDIF
      K(N+2,4)=0
      K(N+3,4)=0
      K(N+2,5)=0
      K(N+3,5)=0
      V(N+1,5)=0D0
      V(N+2,5)=0D0
      V(N+3,5)=0D0

C...Find total flavour content - complicated by presence of junctions.
      NQ=0
      NDIQ=0
      DO 780 I=IC1,IC2
        IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.K(I,2).NE.21) THEN
          NQ=NQ+1
          KFQ(NQ)=K(I,2)
          IF(ABS(K(I,2)).GT.1000) NDIQ=NDIQ+1
        ENDIF
  780 CONTINUE

C...If several diquarks, split up one to give even number of flavours.
      IF(NQ.EQ.3.AND.NDIQ.GE.2) THEN
        I1=3
        IF(ABS(KFQ(3)).LT.1000) I1=1
        KFQ(4)=SIGN(MOD(ABS(KFQ(I1))/100,10),KFQ(I1))
        KFQ(I1)=KFQ(I1)/1000
        NQ=4
        NDIQ=NDIQ-1
      ENDIF

C...If four quark ends, join two to diquark.
      IF(NQ.EQ.4.AND.NDIQ.EQ.0) THEN
        I1=1
        I2=2
        IF(KFQ(I1)*KFQ(I2).LT.0) I2=3
        IF(I2.EQ.3.AND.KFQ(I1)*KFQ(I2).LT.0) I2=4
        KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
        IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
        KFQ(I1)=SIGN(1000*MAX(ABS(KFQ(I1)),ABS(KFQ(I2)))+
     &  100*MIN(ABS(KFQ(I1)),ABS(KFQ(I2)))+KFLS,KFQ(I1))
        KFQ(I2)=KFQ(4)
        NQ=3
        NDIQ=1
      ENDIF

C...If two quark ends, plus quark or diquark, join quarks to diquark.
      IF(NQ.EQ.3) THEN
        I1=1
        I2=2
        IF(ABS(KFQ(I1)).GT.1000) I1=3
        IF(ABS(KFQ(I2)).GT.1000) I2=3
        KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
        IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
        KFQ(I1)=SIGN(1000*MAX(ABS(KFQ(I1)),ABS(KFQ(I2)))+
     &  100*MIN(ABS(KFQ(I1)),ABS(KFQ(I2)))+KFLS,KFQ(I1))
        KFQ(I2)=KFQ(3)
        NQ=2
        NDIQ=NDIQ+1
      ENDIF

C...Form two particles from flavours of lowest-mass system, if feasible.
      NTRY = 0
  790 NTRY = NTRY + 1

C...Open string with two specified endpoint flavours.
      IF(NQ.EQ.2) THEN
        KC1=PYCOMP(KFQ(1))
        KC2=PYCOMP(KFQ(2))
        IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 1140
        KQ1=KCHG(KC1,2)*SIGN(1,KFQ(1))
        KQ2=KCHG(KC2,2)*SIGN(1,KFQ(2))
        IF(KQ1+KQ2.NE.0) GOTO 1140
C...Start with qq, if there is one. Only allow for rank 1 popcorn meson
  800   K1=KFQ(1)
        IF(ABS(KFQ(2)).GT.1000) K1=KFQ(2)
        MSTU(125)=0
        CALL PYDCYK(K1,0,KFLN,K(N+2,2))
        CALL PYDCYK(KFQ(1)+KFQ(2)-K1,-KFLN,KFLDMP,K(N+3,2))
        IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 800

C...Open string with four specified flavours.
      ELSEIF(NQ.EQ.4) THEN
        KC1=PYCOMP(KFQ(1))
        KC2=PYCOMP(KFQ(2))
        KC3=PYCOMP(KFQ(3))
        KC4=PYCOMP(KFQ(4))
        IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) GOTO 1140
        KQ1=KCHG(KC1,2)*SIGN(1,KFQ(1))
        KQ2=KCHG(KC2,2)*SIGN(1,KFQ(2))
        KQ3=KCHG(KC3,2)*SIGN(1,KFQ(3))
        KQ4=KCHG(KC4,2)*SIGN(1,KFQ(4))
        IF(KQ1+KQ2+KQ3+KQ4.NE.0) GOTO 1140
C...Combine flavours pairwise to form two hadrons.
  810   I1=1
        I2=2
        IF(KQ1*KQ2.GT.0.OR.(ABS(KFQ(1)).GT.1000.AND.
     &  ABS(KFQ(2)).GT.1000)) I2=3
        IF(I2.EQ.3.AND.(KQ1*KQ3.GT.0.OR.(ABS(KFQ(1)).GT.1000.AND.
     &  ABS(KFQ(3)).GT.1000))) I2=4
        I3=3
        IF(I2.EQ.3) I3=2
        I4=10-I1-I2-I3
        CALL PYDCYK(KFQ(I1),KFQ(I2),KFLDMP,K(N+2,2))
        CALL PYDCYK(KFQ(I3),KFQ(I4),KFLDMP,K(N+3,2))
        IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 810

C...Closed string.
      ELSE
        IF(ABS(K(IC2,2)).NE.21) GOTO 1140
C...No room for popcorn mesons in closed string -> 2 hadrons.
        MSTU(125)=0
  820   CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP)
        CALL PYDCYK(KFLN,0,KFLM,K(N+2,2))
        CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2))
        IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 820
      ENDIF
      P(N+2,5)=PYMASS(K(N+2,2))
      P(N+3,5)=PYMASS(K(N+3,2))

C...If it does not work: try again (a number of times), give up (if no
C...place to shuffle momentum or too many flavours), or form one hadron.
      IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) THEN
        IF(NTRY.LT.MSTJ(17).OR.(NQ.EQ.4.AND.NTRY.LT.5*MSTJ(17))) THEN
          GOTO 790
        ELSEIF(NSIN.EQ.1.OR.NQ.EQ.4) THEN
          GOTO 1140
        ELSE
          GOTO 890
        END IF
      END IF

C...Perform two-particle decay of jet system.
C...First step: find reference axis in decaying system rest frame.
C...(Borrow slot N+2 for temporary direction.)
      DO 830 J=1,4
        P(N+2,J)=P(IC1,J)
  830 CONTINUE
      DO 850 I=IC1+1,IC2-1
        IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
     &  KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
          FRAC1=FOUR(IC2,I)/(FOUR(IC1,I)+FOUR(IC2,I))
          DO 840 J=1,4
            P(N+2,J)=P(N+2,J)+FRAC1*P(I,J)
  840     CONTINUE
        ENDIF
  850 CONTINUE
      CALL PYROBO(N+2,N+2,0D0,0D0,-DPC(1)/DPC(4),-DPC(2)/DPC(4),
     &-DPC(3)/DPC(4))
      THE1=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
      PHI1=PYANGL(P(N+2,1),P(N+2,2))

C...Second step: generate isotropic/anisotropic decay.
      PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
     &(P(N+2,5)-P(N+3,5))**2))/(2D0*PECM)
  860 UE(3)=PYR(0)
      IF(PARJ(21).LE.0.01D0) UE(3)=1D0
      PT2=(1D0-UE(3)**2)*PA**2
      IF(MSTJ(16).LE.0) THEN
        PREV=0.5D0
      ELSE
        IF(EXP(-PT2/(2D0*MAX(0.01D0,PARJ(21))**2)).LT.PYR(0)) GOTO 860
        PR1=P(N+2,5)**2+PT2
        PR2=P(N+3,5)**2+PT2
        ALAMBD=SQRT(MAX(0D0,(PECM**2-PR1-PR2)**2-4D0*PR1*PR2))
        PREVCF=PARJ(42)
        IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
        PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*ALAMBD*PARJ(40))))
      ENDIF
      IF(PYR(0).LT.PREV) UE(3)=-UE(3)
      PHI=PARU(2)*PYR(0)
      UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
      UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
      DO 870 J=1,3
        P(N+2,J)=PA*UE(J)
        P(N+3,J)=-PA*UE(J)
  870 CONTINUE
      P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
      P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)

C...Third step: move back to event frame and set production vertex.
      CALL PYROBO(N+2,N+3,THE1,PHI1,DPC(1)/DPC(4),DPC(2)/DPC(4),
     &DPC(3)/DPC(4))
      DO 880 J=1,4
        V(N+1,J)=V(IC1,J)
        V(N+2,J)=V(IC1,J)
        V(N+3,J)=V(IC2,J)
  880 CONTINUE
      N=N+3
      GOTO 1120

C...Else form one particle, if possible.
  890 NBODY=1
      K(N+1,5)=N+2
      DO 900 J=1,4
        V(N+1,J)=V(IC1,J)
        V(N+2,J)=V(IC1,J)
  900 CONTINUE

C...Select hadron flavour from available quark flavours.
  910 IF(NQ.EQ.2.AND.ABS(KFQ(1)).GT.100.AND.ABS(KFQ(2)).GT.100) THEN
        GOTO 1140
      ELSEIF(NQ.EQ.2) THEN
        CALL PYKFDI(KFQ(1),KFQ(2),KFLDMP,K(N+2,2))
      ELSE
        KFLN=1+INT((2D0+PARJ(2))*PYR(0))
        CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
      ENDIF
      IF(K(N+2,2).EQ.0) GOTO 910
      P(N+2,5)=PYMASS(K(N+2,2))

C...Use old algorithm for E/p conservation? (EN)
      IF (MSTJ(16).LE.0) GOTO 1080

C...Find the string piece closest to the cluster by a loop
C...over the undecayed partons not in present cluster. (EN)
      DGLOMI=1D30
      IBEG=0
      I0=0
      NJUNC=0
      DO 940 I1=MAX(1,IP),N-1
        IF(K(I1,1).EQ.1) NJUNC=0
        IF(K(I1,1).EQ.41) NJUNC=NJUNC+1
        IF(K(I1,1).EQ.41) GOTO 940
        IF(I1.GE.IC1-1.AND.I1.LE.IC2) THEN
          I0=0
        ELSEIF(K(I1,1).EQ.2) THEN
          IF(I0.EQ.0) I0=I1
          I2=I1
  920     I2=I2+1
          IF(K(I2,1).EQ.41) GOTO 940
          IF(K(I2,1).GT.10) GOTO 920
          IF(KCHG(PYCOMP(K(I2,2)),2).EQ.0) GOTO 920
          IF(K(I1,2).EQ.21.AND.K(I2,2).NE.21.AND.K(I2,1).NE.1.AND.
     &    NJUNC.EQ.0) GOTO 940
          IF(K(I1,2).NE.21.AND.K(I2,2).EQ.21.AND.NJUNC.NE.0) GOTO 940
          IF(K(I1,2).NE.21.AND.K(I2,2).NE.21.AND.(I1.GT.I0.OR.
     &    K(I2,1).NE.1)) GOTO 940

C...Define velocity vectors e1, e2, ecl and differences e3, e4.
          DO 930 J=1,3
            E1(J)=P(I1,J)/P(I1,4)
            E2(J)=P(I2,J)/P(I2,4)
            ECL(J)=P(N+1,J)/P(N+1,4)
            E3(J)=E2(J)-E1(J)
            E4(J)=ECL(J)-E1(J)
  930     CONTINUE

C...Calculate minimal D=(e4-alpha*e3)**2 for 0<alpha<1.
          E3S=E3(1)**2+E3(2)**2+E3(3)**2
          E4S=E4(1)**2+E4(2)**2+E4(3)**2
          E34=E3(1)*E4(1)+E3(2)*E4(2)+E3(3)*E4(3)
          IF(E34.LE.0D0) THEN
            DDMIN=E4S
          ELSEIF(E34.LT.E3S) THEN
            DDMIN=E4S-E34**2/E3S
          ELSE
            DDMIN=E4S-2D0*E34+E3S
          ENDIF

C...Is this the smallest so far?
          IF(DDMIN.LT.DGLOMI) THEN
            DGLOMI=DDMIN
            IBEG=I0
            IPCS=I1
          ENDIF
        ELSEIF(K(I1,1).EQ.1.AND.KCHG(PYCOMP(K(I1,2)),2).NE.0) THEN
          I0=0
        ENDIF
  940 CONTINUE

C... Check if there are any strings to connect to the new gluon. (EN)
      IF (IBEG.EQ.0) GOTO 1080

C...Delta_m = m_clus - m_had > 0: emit a 'gluon' (EN)
      IF (P(N+1,5).GE.P(N+2,5)) THEN

C...Construct 'gluon' that is needed to put hadron on the mass shell.
        FRAC=P(N+2,5)/P(N+1,5)
        DO 950 J=1,5
          P(N+2,J)=FRAC*P(N+1,J)
          PG(J)=(1D0-FRAC)*P(N+1,J)
  950   CONTINUE

C... Copy string with new gluon put in.
        N=N+2
        I=IBEG-1
  960   I=I+1
        IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 960
        IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 960
        N=N+1
        DO 970 J=1,5
          K(N,J)=K(I,J)
          P(N,J)=P(I,J)
          V(N,J)=V(I,J)
  970   CONTINUE
        K(I,1)=K(I,1)+10
        K(I,4)=N
        K(I,5)=N
        K(N,3)=I
        IF(I.EQ.IPCS) THEN
          N=N+1
          DO 980 J=1,5
            K(N,J)=K(N-1,J)
            P(N,J)=PG(J)
            V(N,J)=V(N-1,J)
  980     CONTINUE
          K(N,2)=21
          K(N,3)=NSAV+1
        ENDIF
        IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 960
        GOTO 1120

C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead,
C...from string piece endpoints.
      ELSE

C...Begin by copying string that should give energy to cluster.
        N=N+2
        I=IBEG-1
  990   I=I+1
        IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 990
        IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 990
        N=N+1
        DO 1000 J=1,5
          K(N,J)=K(I,J)
          P(N,J)=P(I,J)
          V(N,J)=V(I,J)
 1000   CONTINUE
        K(I,1)=K(I,1)+10
        K(I,4)=N
        K(I,5)=N
        K(N,3)=I
        IF(I.EQ.IPCS) I1=N
        IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 990
        I2=I1+1

C...Set initial Phad.
        DO 1010 J=1,4
          P(NSAV+2,J)=P(NSAV+1,J)
 1010   CONTINUE

C...Calculate Pg, a part of which will be added to Phad later. (EN)
 1020   IF(MSTJ(16).EQ.1) THEN
          ALPHA=1D0
          BETA=1D0
        ELSE
          ALPHA=FOUR(NSAV+1,I2)/FOUR(I1,I2)
          BETA=FOUR(NSAV+1,I1)/FOUR(I1,I2)
        ENDIF
        DO 1030 J=1,4
          PG(J)=ALPHA*P(I1,J)+BETA*P(I2,J)
 1030   CONTINUE
        PG(5)=SQRT(MAX(1D-20,PG(4)**2-PG(1)**2-PG(2)**2-PG(3)**2))

C..Solve 2nd order equation, use the best (smallest) solution. (EN)
        PMSCOL=P(NSAV+2,4)**2-P(NSAV+2,1)**2-P(NSAV+2,2)**2-
     &  P(NSAV+2,3)**2
        PCLPG=(P(NSAV+2,4)*PG(4)-P(NSAV+2,1)*PG(1)-
     &  P(NSAV+2,2)*PG(2)-P(NSAV+2,3)*PG(3))/PG(5)**2
        DELTA=SQRT(PCLPG**2+(P(NSAV+2,5)**2-PMSCOL)/PG(5)**2)-PCLPG

C...If all gluon energy eaten, zero it and take a step back.
        ITER=0
        IF(DELTA*ALPHA.GT.1D0.AND.I1.GT.NSAV+3.AND.K(I1,2).EQ.21) THEN
          ITER=1
          DO 1040 J=1,4
            P(NSAV+2,J)=P(NSAV+2,J)+P(I1,J)
            P(I1,J)=0D0
 1040     CONTINUE
          P(I1,5)=0D0
          K(I1,1)=K(I1,1)+10
          I1=I1-1
          IF(K(I1,1).EQ.41) ITER=-1
        ENDIF
        IF(DELTA*BETA.GT.1D0.AND.I2.LT.N.AND.K(I2,2).EQ.21) THEN
          ITER=1
          DO 1050 J=1,4
            P(NSAV+2,J)=P(NSAV+2,J)+P(I2,J)
            P(I2,J)=0D0
 1050     CONTINUE
          P(I2,5)=0D0
          K(I2,1)=K(I2,1)+10
          I2=I2+1
          IF(K(I2,1).EQ.41) ITER=-1
        ENDIF
        IF(ITER.EQ.1) GOTO 1020

C...If also all endpoint energy eaten, revert to old procedure.
        IF((1D0-DELTA*ALPHA)*P(I1,4).LT.P(I1,5).OR.
     &  (1D0-DELTA*BETA)*P(I2,4).LT.P(I2,5).OR.ITER.EQ.-1) THEN
          DO 1060 I=NSAV+3,N
            IM=K(I,3)
            K(IM,1)=K(IM,1)-10
            K(IM,4)=0
            K(IM,5)=0
 1060     CONTINUE
          N=NSAV
          GOTO 1080
        ENDIF

C... Construct the collapsed hadron and modified string partons.
        DO 1070 J=1,4
          P(NSAV+2,J)=P(NSAV+2,J)+DELTA*PG(J)
          P(I1,J)=(1D0-DELTA*ALPHA)*P(I1,J)
          P(I2,J)=(1D0-DELTA*BETA)*P(I2,J)
 1070   CONTINUE
          P(I1,5)=(1D0-DELTA*ALPHA)*P(I1,5)
          P(I2,5)=(1D0-DELTA*BETA)*P(I2,5)

C...Finished with string collapse in new scheme.
        GOTO 1120
      ENDIF

C... Use old algorithm; by choice or when in trouble.
 1080 CONTINUE
C...Find parton/particle which combines to largest extra mass.
      IR=0
      HA=0D0
      HSM=0D0
      DO 1100 MCOMB=1,3
        IF(IR.NE.0) GOTO 1100
        DO 1090 I=MAX(1,IP),N
          IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2
     &    .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 1090
          IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2))
          IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 1090
          IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 1090
          IF(MCOMB.EQ.2.AND.ABS(K(I,2)).GT.10.AND.ABS(K(I,2)).LE.100)
     &    GOTO 1090
          HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
          HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5)
          IF(HSR.GT.HSM) THEN
            IR=I
            HA=HCR
            HSM=HSR
          ENDIF
 1090   CONTINUE
 1100 CONTINUE

C...Shuffle energy and momentum to put new particle on mass shell.
      IF(IR.NE.0) THEN
        HB=PECM**2+HA
        HC=P(N+2,5)**2+HA
        HD=P(IR,5)**2+HA
        HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/
     &  (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
        HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
        DO 1110 J=1,4
          P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J)
          P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J)
 1110   CONTINUE
        N=N+2
      ELSE
        CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster')
        RETURN
      ENDIF

C...Mark collapsed system and store daughter pointers. Iterate.
 1120 DO 1130 I=IC1,IC2
        IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
     &  KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
          K(I,1)=K(I,1)+10
          IF(MSTU(16).NE.2) THEN
            K(I,4)=NSAV+1
            K(I,5)=NSAV+1
          ELSE
            K(I,4)=NSAV+2
            K(I,5)=NSAV+1+NBODY
          ENDIF
        ENDIF
        IF(K(I,1).EQ.41) K(I,1)=K(I,1)+10
 1130 CONTINUE
      IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 710

C...Check flavours and invariant masses in parton systems.
 1140 NP=0
      KFN=0
      KQS=0
      NJU=0
      DO 1150 J=1,5
        DPS(J)=0D0
 1150 CONTINUE
      DO 1180 I=MAX(1,IP),N
        IF(K(I,1).EQ.41) NJU=NJU+1
        IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 1180
        KC=PYCOMP(K(I,2))
        IF(KC.EQ.0) GOTO 1180
        KQ=KCHG(KC,2)*SIGN(1,K(I,2))
        IF(KQ.EQ.0) GOTO 1180
        NP=NP+1
        IF(KQ.NE.2) THEN
          KFN=KFN+1
          KQS=KQS+KQ
          MSTJ(93)=1
          DPS(5)=DPS(5)+PYMASS(K(I,2))
        ENDIF
        DO 1160 J=1,4
          DPS(J)=DPS(J)+P(I,J)
 1160   CONTINUE
        IF(K(I,1).EQ.1) THEN
          NFERR=0
          IF(NJU.EQ.0.AND.NP.NE.1) THEN
            IF(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0) NFERR=1
          ELSEIF(NJU.EQ.1) THEN
            IF(KFN.NE.3.OR.ABS(KQS).NE.3) NFERR=1
          ELSEIF(NJU.EQ.2) THEN
            IF(KFN.NE.4.OR.KQS.NE.0) NFERR=1
          ELSEIF(NJU.GE.3) THEN
            NFERR=1
          ENDIF
          IF(NFERR.EQ.1) THEN
            CALL PYERRM(2,'(PYPREP:) unphysical flavour combination')
            MINT(51)=1
            RETURN
          ENDIF
          IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
     &    (0.9D0*PARJ(32)+DPS(5))**2) CALL PYERRM(3,
     &    '(PYPREP:) too small mass in jet system')
          NP=0
          KFN=0
          KQS=0
          NJU=0
          DO 1170 J=1,5
            DPS(J)=0D0
 1170     CONTINUE
        ENDIF
 1180 CONTINUE

      RETURN
      END