C    %W% %G%
      subroutine rlsol
C
C     THIS SUBROUTINE CONTAINS SOLUTION LOGIC FOR THE
C     DEFAULT DISTANCE RELAY.  IT IS CALLED BY RELAY
C     IT CALLS TRPHIS AND LLDROP
C
      include 'tspinc/params.inc'
      include 'tspinc/prt.inc'
      include 'tspinc/vrgov.inc'
      include 'tspinc/busvolt.inc'
      include 'tspinc/bname.inc'
      include 'tspinc/buskv.inc'
      include 'tspinc/relays.inc'
      include 'tspinc/param.inc'
      include 'tspinc/matrow.inc'
      include 'tspinc/ldropn.inc'
      include 'tspinc/bypass.inc'

      dimension dfltd(30000), idflt(30000)
      equivalence (store, dfltd, idflt)
      character idpar * 1
C
C      DEFINE CONSTANTS FOR DEFAULT DISTANCE RELAY LOGIC
C      TAN60=TAN(60 DEG), A1=(.85/2)COS(75 DEG),
C      B1=(.85/2)SIN(75 DEG),
C
      data a1/0.1099980938/
      data b1/0.4105184763/
      data a2/0.1617619026/
      data b2/0.6037036416/
      data tan60/1.732050808/

      index = 0
      ij = 1
      lgnth = ndfltd
      nglth = lgnth
C
C     TEST FOR FIRST TEN CYCLE BYPASS
C
      if (mrelay .eq. 1) then
        if (to .le. 10.0) goto 240
      endif
      do while (lgnth .ne. 0)
        if (ij .eq. 2) then
          indexo = index
          index = index + nline*4
          ij = 2
          if (index .gt. nglth) goto 230
        elseif (ij .eq. 3) then
          goto 110
        endif
  100   indexo = index
        index = index + 3
        ij = 1
        if (index .gt. nglth) goto 230
        ibus = idflt(index-2)
        ckx = dfltd(index-1)
        nline = idflt(index)
        ei = eyr(ibus)
        fi = eyi(ibus)
        name1 = bname(ibus)
        bkv1 = buskv(ibus)
  110   do while (.true.)
          nline = nline - 1
          if (nline .lt. 0) goto 100
          indexo = index
          index = index + 4
          ij = 3
          if (index .gt. nglth) goto 220
          jbus = idflt(index-3)
          ntrip = idflt(index-2)
          ttimer = dfltd(index-1)
          rtimer = dfltd(index)
          if (ntrip .eq. 2) goto 210
          if (ntrip .ne. 3) then
            ej = eyr(jbus)
            fj = eyi(jbus)
            if (ttimer .eq. -1.) then
              oposit = ei*fj - ej*fi
              adjcnt = ei*ej + fi*fj
              oposit = abs(oposit)
              adjcnt = abs(adjcnt)
              if (oposit .le. tan60*adjcnt) goto 210
            endif
C
C            60 DEGREE TEST POSITIVE   CHECK FOR IMPEDANCE VALUES
C
            ilvolt = 0
            eij = ei - ej
            fij = fi - fj
            efsq = eij*eij + fij*fij
            if (efsq .lt. 0.0001) goto 210
            ckefi = ckx*ei - fi
            eckfi = ei + ckx*fi
            alph1 = (ckefi*eij+eckfi*fij)/efsq
            beta1 = (eckfi*eij-ckefi*fij)/efsq
            alf1sq = alph1*alph1
            bet1sq = beta1*beta1
            z21 = alf1sq + bet1sq - 2.*(alph1*a2+beta1*b2)
            iz2 = 1
            if (z21 .le. 0.) then
              iz2 = 2
              if (ckx .gt. ck230) goto 130
            endif
          elseif (rtimer .gt. to+0.0001) then
            goto 190
          else
            name2 = bname(jbus)
            bkv2 = buskv(jbus)
            write (outbuf, 10000) name1, bkv1, name2, bkv2, to
            call prtout(1)
10000       format ('0', 5x,
     &       'default distance relay reclosing between ', a8, 1x, f5.1,
     &       ' and ', a8, 1x, f5.1, ' at ', f7.2, ' cycles.')
            ircall = 8
            ibusn = ibus
            jbusn = jbus
            itparn = 99
            icden = 1
C
C           CALL TRPHIS TO FORM A TABLE OF LINES THAT HAVE BEEN TR
C
            call trphis(itparn, ibusn, jbusn, gijt, bijt, giot, biot,
     &       gjot, bjot, icden, idpar, jobdo, mcode)
            if (jobdo .ne. 0) call lldrop()
            ttimer =  - 1.0
            rtimer =  - 1.0
            ntrip = 1
            goto 200
          endif
  120     eji =  - eij
          fji =  - fij
          ckefj = ckx*ej - fj
          eckfj = ej + ckx*fj
          alph2 = (ckefj*eji+eckfj*fji)/efsq
          beta2 = (eckfj*eji-ckefj*fji)/efsq
          alf2sq = alph2*alph2
          bet2sq = beta2*beta2
          if (ilvolt .eq. 1) goto 150
          z22 = alf2sq + bet2sq - 2.*(alph2*a2+beta2*b2)
          if (z22 .gt. 0.) goto 140
          if (iz2 .eq. 2) then
            iz2 = 4
          else
            iz2 = 3
          endif
          if (ckx .le. ck230) goto 140
C
C          COMPUTE Z11
C
  130     z11 = alf1sq + bet1sq - 2.*(alph1*a1+beta1*b1)
          if (z11 .le. 0.) goto 180
          if (iz2 .gt. 2) goto 150
          ilvolt = 1
          goto 120
  140     if (iz2 .eq. 2 .or. iz2 .eq. 3) goto 170
          if (iz2 .eq. 4) goto 180
          goto 160
  150     ilvolt = 0
          z12 = alf2sq + bet2sq - 2.*(alph2*a1+beta2*b1)
          if (z12 .le. 0.) goto 180
          if (iz2 .ne. 1) goto 170
  160     if (ttimer .ne. -1.0) then
            name2 = bname(jbus)
            bkv2 = buskv(jbus)
            write (outbuf, 10010) name1, bkv1, name2, bkv2, to
            call prtout(1)
10010       format ('0', 5x, 'default distance relay between ', a8, 1x,
     &       f5.1, ' and ', a8, 1x, f5.1, ' has reset at ', f7.2,
     &       ' cycles.')
          endif
          ttimer =  - 1.0
          rtimer =  - 1.0
          goto 200
  170     if (ttimer .eq. -1.0) then
            ttimer = rdelay + to
          elseif (ttimer .le. to+0.0001) then
            goto 180
          endif
          if (ttimer .lt. dnxrly) dnxrly = ttimer
          goto 200
  180     name2 = bname(jbus)
          bkv2 = buskv(jbus)
          write (outbuf, 10020) name1, bkv1, name2, bkv2, to
          call prtout(1)
10020     format ('0', 5x, 'default distance relay between ', a8, 1x,
     &     f5.1, ' and ', a8, 1x, f5.1, ' tripped at ', f7.2,
     &     ' cycles.')
          ircall = 7
          ibusn = ibus
          jbusn = jbus
          if (ibus .ge. jbus) then
            ibusn = jbus
            jbusn = ibus
          endif
          itparn = 99
          icden =  - 1
C
C         CALL TRPHIS TO FORM A TABLE OF LINES THAT HAVE BEEN TRIP
C
          call trphis(itparn, ibusn, jbusn, gijt, bijt, giot, biot,
     &     gjot, bjot, icden, idpar, jobdo, mcode)
          if (jobdo .ne. 0) call lldrop()
          if (trclse .gt. 0.) then
            ntrip = 3
            rtimer = trclse + to
          else
            ntrip = 2
            goto 200
          endif
  190     if (rtimer .lt. dnxrly) dnxrly = rtimer
  200     dfltd(index) = rtimer
          dfltd(index-1) = ttimer
          idflt(index-2) = ntrip
  210     continue
        enddo
  220   nline = nline + 1
  230   index = indexo
        lgnth = lgnth - index
      enddo
  240 return
      end


!
!*******************************************************************************
!
subroutine run_fresco(ener, fresco_dir, len_fresco, fresco_name, iendf, fname, err_name, symb,      &
                      pindex, mass_proj, iZ, iA, namet, mass_target, beta, deformed, J_gs, K_band,  &
                      V_pot, R_pot, a_pot, RC, iradius, rela, ncc, nex, if_state,                   &
                      cc_state_par, cc_state_type, cc_state_k, cc_state_kpp,                        &
                      cc_state_j, cc_state_e, cc_state_str)
!
!*******************************************************************************
!
!  Discussion:
!
!    This routine is called from make_fresco_tco to run fresco for the
!    case requested, i.e., a particular optical potential at a given
!    incident energy
!
!   Dependencies:
!
!     Modules:
!
!        constants
!        particles_def
!        options
!
!     Subroutines:
!
!        None
!
!     External functions:
!
!        clebr
!        real(kind=8) :: pc_com
!
!     MPI routines:
!
!        None
!
!  Licensing:
!
!    SPDX-License-Identifier: MIT
!
!  Date:
!
!    11 May 2021
!
!  Author:
!
!      Erich Ormand, LLNL
!
!  Revised:
!      19 July 2021
!  Author:
!      Ian Thompson, LLNL
!  Changes:
!    1. Relativistic specification 'rela' from each optical potential routine
!    2. Now 5 (not 3) columns of potential forms available.
!       Array 'ipotk' specifies Fresco kind of each column.
!    3. Add opt_pot = 4 for the Capote/Soukhovitskii dispersive optical model potential
!
!*******************************************************************************
   use constants
   use particles_def
   use options
   implicit none
   real(kind=8), intent(in) :: ener
   character(len=132), intent(in) :: fresco_dir
   integer(kind=4), intent(in) :: len_fresco
   character(len=100), intent(in) :: fresco_name
   integer(kind=4), intent(in) :: iendf
   character(len=6), intent(in) :: fname
   character(len=100), intent(in) :: err_name
   character(len=2), intent(in) :: symb
   integer(kind=4), intent(in) :: pindex
   real(kind=8), intent(in) :: mass_proj
   integer(kind=4), intent(in) :: iZ, iA
   character(len=8), intent(in) :: namet
   real(kind=8), intent(in) :: mass_target
   real(kind=8), intent(in) :: beta(6)
   logical, intent(in) :: deformed
   real(kind=8), intent(in) :: J_gs
   real(kind=8), intent(in) :: K_band
   real(kind=8), intent(in) :: V_pot(2,5)
   real(kind=8), intent(in) :: R_pot(2,5)
   real(kind=8), intent(in) :: A_pot(2,5)
   real(kind=8), intent(in) :: RC
   integer(kind=4), intent(in) :: iradius
   integer(kind=4), intent(in) :: ncc, nex, if_state
   integer(kind=4), intent(in) :: cc_state_par(nex), cc_state_type(nex)
   integer(kind=4), intent(in) :: cc_state_k(nex), cc_state_kpp(nex)
   real(kind=8), intent(in) :: cc_state_j(nex), cc_state_e(nex)
   real(kind=8), intent(in) :: cc_state_str(nex)
!-------    End of in and out variables
!----------------------------------------------------------------------------------------
   integer(kind=4) :: ipot,ipk,ipotk(5)
   real(kind=8) :: th_min, th_max, th_inc
   integer(kind=4) :: zpart, apart
   real(kind=8) :: A, Z, Ap, AAp
   real(kind=8) :: ac
   real(kind=8) :: absend
   integer(kind=4) :: kp
   integer(kind=8) :: ifirst, ilast, ipot_end
   integer(kind=4) :: i, k
   character(len=2) :: opt_label,rela
   real(kind=8) :: K_state, J_state
   real(kind=8) :: xk_factor
   character(len=15) char_energy
   character(len=132) command, line
   integer(kind=4) :: istart, istop, iend_err
   real(kind=8) :: jtmin, jtmax
   real(kind=8) :: rmatch
   integer(kind=4) :: iter
   character(len=1) :: label
   integer(kind=4) :: len_dir
   real(kind=8) :: zzero
   real(kind=8) :: spin
   real(kind=8) :: mass_rel, e_rel, momentum, wave_number
   real(kind=8) :: hcm, hcm_check
!----------    External functions   -------------------
   real(kind=8) :: clebr
   real(kind=8) :: KE_com
   real(kind=8) :: pc_com
!---------------------------------------------------------------------
!---------------------------------------------------------------------

   write(char_energy,'(e15.7)')ener

   len_dir = index(fresco_dir,' ') - 1
   if(len_dir == 0)len_dir = 132

   zzero = 0.0d0
   jtmin = 0
   jtmax = particle(pindex)%lmax
   absend = 0.001d0
   rmatch = 20.0d0

   A = real(iA,kind=8)
   Z = real(iZ,kind=8)
   ac = A**(1.0d0/3.0d0)
!
!-------    Masses are passed in units of atomic masses, mass_u
!
   mass_rel = mass_proj*mass_target*mass_u/(mass_proj + mass_target)
!   e_rel = ener*mass_target/(mass_target + mass_proj)
   e_rel = KE_com(mass_proj*mass_u, mass_target*mass_u, ener)
!   momentum = dsqrt(2.0d0*e_rel*mass_rel)
   momentum = pc_com(mass_proj*mass_u, mass_target*mass_u, ener)
   wave_number = momentum/hbar_c
!---------------------------------------------------------------------
   hcm_check = 0.2/wave_number
   hcm = 0.1d0
   if(hcm_check < 0.1d0)then
      hcm = 0.05d0
   elseif(hcm_check < 0.05d0)then
      hcm = 0.01d0
   elseif(hcm_check < 0.01d0)then
      hcm = 0.005d0
   end if

   th_min = 0.0d0
   th_max = 180.0d0
   th_inc = 1.0d0

   label = particle(pindex)%label
   zpart = particle(pindex)%Z
   apart = particle(pindex)%A
   Ap = real(apart,kind=8)
   AAp = 0.0d0
   if(iradius == 1) AAp = Ap
   spin = particle(pindex)%spin
!---------    Coupled channels control
!---------    ncc = total number of coupled channles
!---------    nex = total number of excited states in calculaiton including CCBA states
!---------    if ncc /= nex run one iteration after coupled channels for DWBA states.
  iter = 0
  if(ncc /= nex)iter = 1

!----    Open and create fresco input file for this energy
   open(unit=20,file = fresco_dir(1:len_dir)//'/'//fresco_name(1:len_fresco)//'.in', status='unknown')
!----   write fresco input
   if(particle(pindex)%opt_pot < 10)then
      write(opt_label(1:1),'(i1)')particle(pindex)%opt_pot
      ipot_end = 1
   else
      write(opt_label(1:2),'(i2)')particle(pindex)%opt_pot
      ipot_end = 2
   end if

     write(20,'(a)') fname(1:iendf)//' with potential #'//opt_label(1:ipot_end)//', at E_lab ='//char_energy
     write(20,'(a)') 'NAMELIST'
     write(20,13) hcm, rmatch, rela
13   format(' &Fresco  hcm= ',f6.4, ' rmatch= ',f7.3,' rela="',a2,'"')
     absend = 1.0d-4
     if(ener <= 0.5d0)absend = 1.0d-6
     write(20,'(''    jtmin= '',f5.2,'' jtmax = '',f5.2,'' absend = '',f10.7)')jtmin,jtmax,absend
     write(20,14) th_min, th_inc, th_max, ncc
14      format('    thmin= ',f3.1,' thinc= ',f3.1,' thmax= ',f5.1,' iblock= ',i3)
     write(20,'(''    chans= 1 smats= 2 xstabl= 1 tcfile= 3 iter= '',i2)')iter
     write(20,15) ener
15      format('    elab=',e15.7,'  pel= 1 exl= 1 lab= 1 lin= 1 lex= 1 /')
     write(20,*)
     if(ncc == nex)then
        write(20,16) label, mass_proj, zpart, nex
16         format('&Partition  namep=''',a1,'       '' massp= ',f12.8,' zp= ',i3,' nex=',i3)
     else
        write(20,166) label, mass_proj, zpart, nex
166        format('&Partition  namep=''',a1,'       '' massp= ',f12.8,' zp= ',i3,' nex=',i3,4x,'mixpot=2')
     end if
     write(20,17) namet, mass_target, iZ
17      format('            namet=''',a8,''' masst= ',f12.8,' zt= ',i3,' qval=  0.000/')
     write(20,18)spin,1, cc_state_kpp(1), cc_state_j(1), cc_state_par(1), cc_state_e(1), K_band
18      format('&States jp= ',f3.1,' ptyp=',i2,' ep=  0.000000  cpot=',i3,' jt=',f4.1,' ptyt=',i2,' et=',f8.4,' kkt = ',f4.1,'/')

   do i = 2, ncc
      write(20,21)cc_state_kpp(i), cc_state_j(i), cc_state_par(i), cc_state_e(i),K_band
21    format('&States copyp= 1                       cpot=',i3,' jt=',f4.1,' ptyt=',i2,' et=',f8.4,' kkt = ',f4.1,'/')
   end do
   write(20,*)
   do i = ncc + 1, nex
      write(20,21)cc_state_kpp(i), cc_state_j(i), cc_state_par(i), cc_state_e(i),K_band
   end do

   write(20,'(''&Partition /'')')
   write(20,*)

30 format('&POT kp=',i3,' type =',i2,' shape=',i2,' p(1:3)=',3f10.5,'/')
31 format('&POT kp=',i3,' type =',i2,' shape=',i2,' p(1:6)=',6f10.5,'/')
32 format('&POT /'/)
!---------    Write data to generate potential
   kp = 1                           !   potential for coupled-channels states
!---------    First print Coulomb
   write(20,30) kp, 0, 0, A, AAp, RC
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!---------   Now loop over indvidual components of nuclear potentials
!---------   ipot = 1, 6,  giving ipk=ipotk(ipot) for Fresco kind
!---------   ipk = 1 : Volume
!---------   ipk = 2 : derivative - surface
!---------   ipk = 3 : Spin-orbit
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

       ipotk(:) = (/ 1, 2, 3, 1, 3/)
     do ipot = 1, 5
        ipk = ipotk(ipot)
        if(abs(V_pot(1,ipot)) > 1.0d-6)then
           write(20,31) kp,ipk,0,V_pot(1,ipot),R_pot(1,ipot),a_pot(1,ipot),0.,0.,0.
           if(ipk /= 3 .and. deformed )write(20,31)kp,11,ifresco_shape,(beta(k)*ac*R_pot(1,ipot),k=1,6)
        end if
        if(abs(V_pot(2,ipot)) > 1.0d-6)then
           write(20,31) kp,ipk,0,0.,0.,0.,V_pot(2,ipot),R_pot(2,ipot),a_pot(2,ipot)
           if(ipk /= 3 .and. deformed) write(20,31)kp,11,ifresco_shape,(beta(k)*ac*R_pot(2,ipot),k=1,6)
        end if
     end do
     if(ncc /= nex)then
        write(20,*)
        kp = 2
        write(20,30) kp,0,0,A,AAp,RC
        ipot = 1
        ipk = ipotk(ipot)
        write(20,31) kp,ipk,0,V_pot(1,ipot),R_pot(1,ipot),a_pot(1,ipot),V_pot(2,ipot),R_pot(2,ipot),a_pot(2,ipot)
        ipot = 2
        ipk = ipotk(ipot)
        if(abs(V_pot(1,ipot)) + abs(V_pot(2,ipot)) > 1.0d-6)then
           write(20,31) kp,-ipk,0,V_pot(1,ipot),R_pot(1,ipot),a_pot(1,ipot),V_pot(2,ipot),R_pot(2,ipot),a_pot(2,ipot)
        endif
        ipot = 4
        ipk = ipotk(ipot)
        if(abs(V_pot(1,ipot)) + abs(V_pot(2,ipot)) > 1.0d-6)then
            write(20,31) kp,-ipk,0,V_pot(1,ipot),R_pot(1,ipot),a_pot(1,ipot),V_pot(2,ipot),R_pot(2,ipot),a_pot(2,ipot)
        endif
        write(20,31)kp,13,10,0.0,0.5,0.5,0.5,0.0,0.0

 33  format('  &step ib=',i3,1x,'ia= ',i2,1x,'k=',i2,' str=',f10.6,1x,'/')
 34  format('  &step /')
        do i = ncc + 1, nex
           xk_factor = sqrt(2.0d0*J_gs + 1.0d0)
           if(cc_state_type(i) == 0)then
              K_state = real(cc_state_k(i),kind=8)
              J_state = real(cc_state_j(i),kind=8)
              xk_factor = sqrt(2.0d0*J_gs + 1.0d0)*clebr(J_gs,K_band,K_state,zzero,J_state,K_band)
           end if
           write(20,33)i,if_state,cc_state_k(i),cc_state_str(i)*ac*R_pot(1,1)*xk_factor*cc_scale
        end do
        write(20,34)
        ipot = 3
        ipk = ipotk(ipot)
        write(20,31) kp,ipk,0,V_pot(1,ipot),R_pot(1,ipot),a_pot(1,ipot),V_pot(2,ipot),R_pot(2,ipot),a_pot(2,ipot)
     end if
     write(20,*)
     write(20,32)
     write(20,'(''&Overlap /'')')
     write(20,'(''&Coupling /'')')

   close(unit=20)

!-------     Now run fresco
   write(6,*)'**********************************************'
   write(6,*)'Calling unix system command to execute fresco'

   line(1:132) = ' '
   ifirst = 1
   ilast = 12
   line(ifirst:ilast) = 'Calculating '
   ifirst = 13
   ilast = 13
   line(ifirst:ilast) = particle(pindex)%label
   ifirst = 14
   ilast = 16
   line(ifirst:ilast) = ' + '
   ifirst = 17
   if(iA < 10)then
      ilast = 18
      write(line(ifirst:ilast),'(i1)')iA
   elseif(iA < 100)then
      ilast = 19
      write(line(ifirst:ilast),'(i2)')iA
   elseif(iA < 1000)then
      ilast = 20
      write(line(ifirst:ilast),'(i3)')iA
   end if
   ifirst = ilast + 1
   if(symb(1:1).ne.' ')then
      ilast = ifirst + 1
      line(ifirst:ilast) = symb
   else
      ilast = ifirst
      line(ifirst:ilast) = symb(2:2)
   end if

   write(6,'(a)')line(1:ilast)//', at E_lab ='//char_energy

   iend_err = index(err_name,' ') - 1

   command(1:132) = ' '
   istart = 1
   istop = 10
   command(istart:istop) = 'frescox < '
   istart = istop + 1
   istop = istop + len_dir + 1 + len_fresco + 3
   command(istart:istop) = fresco_dir(1:len_dir)//'/'//fresco_name(1:len_fresco)//'.in'
   istart = istop + 1
   istop = istart + 2
   command(istart:istop) = ' > '
   istart = istop + 1
   istop = istart + len_dir + 1 + len_fresco + 4
   command(istart:istop) = fresco_dir(1:len_dir)//'/'//fresco_name(1:len_fresco)//'.out'
   istart = istop + 1
   istop = istart + 4
   command(istart:istop) = ' 2>> '
   istart = istop + 1
   istop = istart + len_dir + 1 + iend_err - 1
   command(istart:istop) = fresco_dir(1:len_dir)//'/'//err_name(1:iend_err)

   write(6,'(a)')command(1:istop)
   call system(command(1:istop))
   return

end subroutine run_fresco


      SUBROUTINE PHO_PARCOR(Mode,Irej)
C********************************************************************
C
C    conversion of string partons (using JETSET masses)
C
C    input:      MODE    >0 position index of corresponding string
C                        -1 initialization
C                        -2 output of statistics
C
C    output:     /POSTRG/
C                IREJ    1 combination of strings impossible
C                        0 successful combination
C
C********************************************************************
      IMPLICIT NONE
      DOUBLE PRECISION dele , DELM , DEPS , DT_RNDM , EPS , gam , gamb ,
     &                 pb1 , pb2 , pl , pp1 , pp2 , xm1 , xm2 , xmc ,
     &                 xml , xmp
      INTEGER i , i1 , i2 , ich , ifai , ii , ik , imode , ip1 , ip2 ,
     &        ipar , ipos , Irej , iter , k , k1 , k2 , kk , ks , l
      INTEGER Mode
      SAVE

      PARAMETER (DELM=0.005D0,DEPS=1.D-15,EPS=1.D-5)

C  input/output channels
      INCLUDE 'inc/poinou'
C  event debugging information
      INCLUDE 'inc/podebg'
C  internal rejection counters
      INCLUDE 'inc/poloop'
C  model switches and parameters
      INCLUDE 'inc/pomdls'

C  standard particle data interface

      INCLUDE 'inc/poevt1'
C  extension to standard particle data interface (PHOJET specific)
      INCLUDE 'inc/poevt2'

C  color string configurations including collapsed strings and hadrons
      INCLUDE 'inc/postrg'

      DIMENSION pp1(4) , pp2(4) , pb1(4) , pb2(4) , gam(3) , gamb(3) ,
     &          pl(4,100) , xmp(100) , xml(100)

      DOUBLE PRECISION PYMASS

      Irej = 0
      imode = Mode
C
      IF ( imode.GT.0 ) THEN
         ich = 0
         i1 = JMOhep(1,imode)
         i2 = ABS(JMOhep(2,imode))
C  copy to local field
         l = 0
         DO i = i1 , i2
            l = l + 1
            DO k = 1 , 4
               pl(k,l) = PHEp(k,i)
            END DO
            xmp(l) = PHEp(5,i)

            xml(l) = PYMASS(IDHep(i))

         END DO
         ipar = l
         xmc = PHEp(5,imode)
         IF ( IDEb(82).GE.20 ) THEN
            IF ( LPRi.GT.4 ) WRITE (LO,'(1X,A,I7,2I4)')
     &            'PHO_PARCOR: ini.momenta,masses(C/L),EV,ICH,L' ,
     &           KEVent , imode , l
            DO i = 1 , l
               IF ( LPRi.GT.4 ) WRITE (LO,'(1X,4E12.4,2X,2E12.4)')
     &              (pl(k,i),k=1,4) , xmp(i) , xml(i)
            END DO
         END IF
C
C  two parton configurations
C  -----------------------------------------
         IF ( ipar.EQ.2 ) THEN
            xm1 = xml(1)
            xm2 = xml(2)
            IF ( (xm1+xm2).GE.xmc ) THEN
               IF ( LPRi.GT.4 .AND. IDEb(82).GE.6 )
     &               WRITE (LO,'(1X,A,/,5X,I3,3E12.4)')
     &               'PHO_PARCOR: REJECTION I,XM1,XM2,XMC' , imode ,
     &              xm1 , xm2 , xmc
               GOTO 100
            END IF
C  conversion possible
            CALL PHO_MSHELL(pl(1,1),pl(1,2),xm1,xm2,pp1,pp2,Irej)
            IF ( Irej.NE.0 ) THEN
               IFAil(36) = IFAil(36) + 1
               IF ( LPRi.GT.4 .AND. IDEb(82).GE.6 )
     &               WRITE (LO,'(1X,A,I8,I4,E12.4)')
     &              'PHO_PARCOR: rejection by PHO_MSHELL EV,STRING,MASS'
     &              , KEVent , imode , xmc
               GOTO 100
            END IF
            ich = 1
            DO k = 1 , 4
               pl(k,1) = pp1(k)
               pl(k,2) = pp2(k)
               xmp(1) = xm1
               xmp(2) = xm2
            END DO
C
C  multi parton configurations
C  ---------------------------------
         ELSE
C
C  random selection of string side to start with
            IF ( DT_RNDM(xmc).LT.0.5D0 ) THEN
               k1 = 1
               k2 = ipar
               ks = 1
            ELSE
               k1 = ipar
               k2 = 1
               ks = -1
            END IF
            iter = 0
C
            DO WHILE ( iter.LT.4 )
               kk = k1
               k1 = k2
               k2 = kk
               ks = -ks
               iter = iter + 1
C  select method
               IF ( iter.GT.2 ) THEN
C
C
C  conversion according to remainder method
                  DO i = k1 , k2 , ks
                     xm1 = xml(i)
                     IF ( ABS(xm1-xmp(i)).GT.DELM ) THEN
                        ich = ich + 1
                        ifai = i
C  conversion necessary
                        DO k = 1 , 4
                           pb1(k) = pl(k,i)
                           pb2(k) = PHEp(k,imode) - pb1(k)
                        END DO
                        xm2 = pb2(4)**2 - pb2(1)**2 - pb2(2)**2 - pb2(3)
     &                        **2
                        IF ( xm2.LT.0.D0 ) THEN
                           IF ( LPRi.GT.4 .AND. IDEb(82).GE.10 )
     &                        WRITE (LO,'(1X,2A,/,5X,3I3,4E12.4)')
     &                         'PHO_PARCOR: ' ,
     &                        'int.rej. I,IPA,ICH,XML,XMP,XM2**2,MCHAIN'
     &                        , i , ipar , imode , xm1 , xmp(i) , xm2 ,
     &                        xmc
                           GOTO 20
                        END IF
                        xm2 = SQRT(xm2)
                        IF ( (xm1+xm2).GE.xmc ) THEN
                           IF ( LPRi.GT.4 .AND. IDEb(82).GE.10 )
     &                        WRITE (LO,'(1X,2A,/,5X,3I3,4E12.4)')
     &                         'PHO_PARCOR: ' ,
     &                        'int.rej. I,IPA,ICH,XML,XMP,XM2,XMC' , i ,
     &                        ipar , imode , xm1 , xmp(i) , xm2 , xmc
                           GOTO 20
                        END IF
C  conversion possible
                        CALL PHO_MSHELL(pb1,pb2,xm1,xm2,pp1,pp2,Irej)
                        IF ( Irej.NE.0 ) THEN
                           IFAil(36) = IFAil(36) + 1
                           IF ( LPRi.GT.4 .AND. IDEb(82).GE.6 )
     &                        WRITE (LO,'(1X,A,I8,3I4)')
     &                  'PHO_PARCOR: PHO_MSHELL rej. ITER,STRING,PARTON'
     &                  , iter , imode , i
                           GOTO 20
                        END IF
C  calculate Lorentz transformation
                        CALL PHO_GETLTR(pb2,pp2,gam,gamb,dele,Irej)
                        IF ( Irej.NE.0 ) THEN
                           IF ( LPRi.GT.4 .AND. IDEb(82).GE.6 )
     &                        WRITE (LO,'(1X,A,I8,3I4)')
     &                  'PHO_PARCOR: PHO_GETLTR rej. ITER,STRING,PARTON'
     &                  , iter , imode , i
                           GOTO 20
                        END IF
                        ifai = 0
C  transform remaining partons
                        DO l = k1 , k2 , ks
                           IF ( l.NE.i ) THEN
                              CALL PHO_MKSLTR(pl(1,l),pp2,gam,gamb)
                              DO k = 1 , 4
                               pl(k,l) = pp2(k)
                              END DO
                           ELSE
                              DO k = 1 , 4
                               pl(k,l) = pp1(k)
                              END DO
                           END IF
                        END DO
                        xmp(i) = xm1
                     END IF
                  END DO
               ELSE

C  conversion according to color flow method
                  ifai = 0
                  DO ii = k1 , k2 - ks , ks
                     DO ik = ii + ks , k2 , ks
                        xm1 = xml(ii)
                        xm2 = xml(ik)
C             IF(IDEB(82).GE.10) WRITE(LO,'(1X,A,2I3,4E12.4)')
C    &          'PHO_PARCOR:I,K,XM(1-4)',II,IK,XM1,XMP(II),XM2,XMP(IK)
                        IF ( (ABS(xm1-xmp(ii)).LE.DELM) .AND.
     &                       (ABS(xm2-xmp(ik)).LE.DELM) ) GOTO 5
                        CALL PHO_MSHELL(pl(1,ii),pl(1,ik),xm1,xm2,pp1,
     &                     pp2,Irej)
                        IF ( Irej.NE.0 ) THEN
                           IFAil(36) = IFAil(36) + 1
                           IF ( LPRi.GT.4 .AND. IDEb(82).GE.6 )
     &                        WRITE (LO,'(1X,2A,I8,3I4)')
     &                        'PHO_PARCOR: ' ,
     &                        'int.rej. by PHO_MSHELL EV,IC,I1,I2' ,
     &                        KEVent , imode , ii , ik
                           Irej = 0
                        ELSE
                           ich = ich + 1
                           DO kk = 1 , 4
                              pl(kk,ii) = pp1(kk)
                              pl(kk,ik) = pp2(kk)
                           END DO
                           xmp(ii) = xm1
                           xmp(ik) = xm2
                           GOTO 5
                        END IF
                     END DO
                     ifai = ii
 5                END DO
                  IF ( ifai.NE.0 ) GOTO 20
               END IF
               GOTO 50
 20         END DO
            GOTO 100
         END IF

C  register transformed partons
 50      Irej = 0
         IF ( ich.NE.0 ) THEN
            ip1 = NHEp + 1
            l = 0
            DO i = i1 , i2
               l = l + 1
               CALL PHO_REGPAR(-1,IDHep(i),0,imode,0,pl(1,l),pl(2,l),
     &            pl(3,l),pl(4,l),IPHist(1,i),IPHist(2,i),ICOlor(1,i),
     &            ICOlor(2,i),ipos,1)
            END DO
            ip2 = ipos
C  register string
            CALL PHO_REGPAR(-1,90,0,ip1,-ip2,PHEp(1,imode),PHEp(2,imode)
     &                      ,PHEp(3,imode),PHEp(4,imode),IPHist(1,imode)
     &                      ,IPHist(2,imode),ICOlor(1,imode),
     &                      ICOlor(2,imode),ipos,1)
C  update /POSTRG/
            i = IPHist(1,imode)
            NPOs(1,i) = ipos
            NPOs(2,i) = ip1
            NPOs(3,i) = -ip2
         END IF
C  debug output
         IF ( IDEb(82).GE.20 ) THEN
            IF ( LPRi.GT.4 ) WRITE (LO,'(1X,A,I7,2I4)')
     &            'PHO_PARCOR: fin.momenta,masses(C/L),(EV,ICH,L)' ,
     &           KEVent , imode , l
            DO i = 1 , l
               IF ( LPRi.GT.4 ) WRITE (LO,'(1X,4E12.4,2X,2E12.4)')
     &              (pl(k,i),k=1,4) , xmp(i) , xml(i)
            END DO
            IF ( LPRi.GT.4 ) WRITE (LO,'(1X,A,2I5)')
     &            'PHO_PARCOR: conversion done (old/new ICH)' , imode ,
     &           ipos
         END IF
         RETURN
C  rejection
 100     Irej = 1
         IF ( IDEb(82).GE.3 ) THEN
            IF ( LPRi.GT.4 ) WRITE (LO,'(/1X,A,/,5X,3I5,E12.4)')
     &            'PHO_PARCOR: rejection I,IPAR,ICHAIN,MCHAIN' , ifai ,
     &           ipar , imode , xmc
            IF ( IDEb(82).GE.5 ) THEN
               IF ( LPRi.GT.4 ) WRITE (LO,'(1X,A,I7,2I4)')
     &               'PHO_PARCOR: momenta,masses(C/L),(EV,ICH,L)' ,
     &              KEVent , imode , ipar
               DO i = 1 , ipar
                  IF ( LPRi.GT.4 ) WRITE (LO,'(1X,4E12.4,2X,2E12.4)')
     &                 (pl(k,i),k=1,4) , xmp(i) , xml(i)
               END DO
            END IF
         END IF
         RETURN

      ELSE IF ( imode.EQ.-1 ) THEN
C  initialization
         RETURN

      ELSE IF ( imode.EQ.-2 ) THEN
C  final output
         RETURN
      END IF
      END SUBROUTINE