      SUBROUTINE NOISE96S(RUN,ECUT,IMBACUT,NSIGMA,
     &                    ISLFL,DELFL,NCELLS,IERR)
C
C---------------------------------------------------------------------
C
C Input parameters :
C
C INPUT :
C          RUN     : RUN NUMBER  (input RUN<1000 for MC)
C          ECUT(1) : ENERGY THRESHOLD FOR EMC CELLS IN GEV (DEFAULT: 0.08)
C          ECUT(2) : ENERGY THRESHOLD FOR HAC CELLS IN GEV (DEFAULT: 0.14)
C
C          IMBACUT : Cut of relative imbalance (absolute value)
C                    Imbacut < 0 : choose default value    (DEFAULT: 0.7)
C                    for isolated cells with E < 0.7 GEV
C                    -----------------------------------
C                    If you don't dare to apply an imbalance cut choose
C                    a high value, i.e. Imbacut = 2.
C
C          NSIGMA  : Number of standard deviation from the mean
C                    value of noise (only apply to noisy cells
C                    which cannot be corrected by using the cell's
C                    imbalance information).
C
C          ISLFL   : ISLAND FLAG
C          DELFL   : DELETE FLAG
C
C OUTPUT : NCELLS : NUMBER OF NOISE CELLS 'TOUCHED' BY THIS ROUTINE
C
C          IERR  :       0 : NORMAL
C                       -1 : ERROR (CalTru_CellNr not exist)
C                       -2 : ERROR (relation CalTru_CConSa not ok)
C                        1 : CALTRU TABLE EMPTY
C
C
C ISLFL : FALSE  :  CELLS WITH A COMMON BORDER ARE CONSIDERED TO BE ADJACENT
C                  (CONDENSATE ALGORITHM)
C                   THIS IS RECOMMENDED FOR DIS
C         TRUE   : CELLS WITH A COMMON EDGE ARE CONSIDERED TO BE ADJACENT TOO
C                  (ISLAND ALGORITHM)
C                  THIS MIGHT BE USEFUL FOR PEOPLE WORKING WITH ISLANDS, BUT
C                  IS LESS RESTRICTIVE
C DELFL : TRUE   : NOISE CELLS ARE REMOVED FROM CALTRU
C         FALSE  : NOISE CELLS ARE NOT REMOVED FROM CALTRU BUT STORED IN THE
C                  COMMON /NOISECM95/
C
C COMMON /NOISECM95/ : POINTER TO NOISE CELLS   : NOISEID(I) I=1,NCELLS
C
C**********************************************************************
C  NB:  before using condensates/ cluster they have to be refilled
C        using, e.g. the s/r PCCNDS,PCSLCT and PCIDCO/PCIDCL
C                 ( --> description in PHANTOM documentation )
C**********************************************************************
C
C-----------------------------------------------------------------------------
C
C AUTHOR : Reinhold Seifert  (VXDESY::SEIFERT) ----> for Noise94
C DATE   : Sep 22, 1995
C
C-----------------------------------------------------------------------------
C --DATE--:--NAME--:--MODIFICATIONS-------------------------------------------
C OCT '96    Ming     adapt for '95
C
c     The file 'noscell95.list', which will be read by this code,
c     contains the list of identified noisy cells, some information
c     about its noise distribution, and the method of treating these
c     noisy cells. These information will be read into the array
c     'cellinfo'.
c
c     cellinfo(1,i) -> cell id
c     cellinfo(2,i) -> run range start \  run range in which the
c     cellinfo(3,i) -> run range end   /  cell is noisy.
c     cellinfo(4,i) -> noise max energy
c     cellinfo(5,i) -> noise mean
c     cellinfo(6,i) -> noise width
c     cellinfo(7,i) -> noise code ... 1 2 3 4
c
c     *** NOTE *** The treatments for the identified noisy cells should
c                  only be done on the DATA and NOT MC events (since most
c                  of the identified noisy cells were only noisy for part
c                  of the runs taken in 1995). In order to distinguish between
c                  data and MC, the user can simply input a run number that
c                  is less than 1000 (run<1000).
c
c                  This code should only be valid for '95 analysis since
c                  the noisy cells vary in different years.
C-----------------------------------------------------------------------------
C --DATE--:--NAME--:--MODIFICATIONS-------------------------------------------
C May '97    Savin     adapt for '96
C----------------------------------------------------------------------------

      IMPLICIT NONE

#include "partap.inc"
#include "caltru.inc"
#include "cconsa.inc"

      INTEGER RUN

      REAL    ECUT(2)
      REAL    DECUT(2)
      DATA    DECUT /0.080, 0.140/

      REAL      IMBACUT
      REAL     DIMBACUT
      DATA     DIMBACUT /0.7/

C     LIMIT THE IMBALANCE CUT ON CELLS .LT. ELIMCUT
      REAL     ELIMCUT
      DATA     ELIMCUT /1.000/

      INTEGER  NCELLS,IERR
      LOGICAL  ISLFL, DELFL

      REAL     CALCUT(3)
      DATA     CALCUT /0.060, 0.100, 0.110/

C     cut in noise width
      INTEGER  NSIGMA

      INTEGER    MAXCELL
      PARAMETER (MAXCELL=5918)
      REAL       ENERGY(MAXCELL), IMBALA(MAXCELL)
      INTEGER    CELLNR(MAXCELL)
      LOGICAL    CORREC(MAXCELL)

      INTEGER   NCELLMAX,     NISLANDMAX
      PARAMETER (NCELLMAX=600, NISLANDMAX=200)
      INTEGER   NISLAND, CELNUM, ERRIS, ISLAND(NCELLMAX),
     &          POSERNR(NCELLMAX), NUM_CELLS(NISLANDMAX)
      REAL      E_CELL(NCELLMAX)
      LOGICAL   CHECK

      INTEGER    EMC,   HAC,   HAC0,   HAC12
      PARAMETER (EMC=1, HAC=2, HAC0=2, HAC12=3)

      REAL     ECSECT, CENE, CIMB
      INTEGER  NUM, SEC
      INTEGER  I, J, Ncc

      LOGICAL  ok, FLAG, COR
      LOGICAL  ISOLA

      LOGICAL  FIRST
      DATA     FIRST /.TRUE./

      real    cellinfo(7,1000)
      integer numcell,chkflg
      real    rddata(7)

      integer maximumid
      parameter (maximumid=1000)
      integer noiseid(maximumid)
      common/noisecm95/noiseid

c .............................................................................
      IF( IMBACUT.LT.0. ) IMBACUT=DIMBACUT
      if( ECUT(1).LT.0. ) ECUT(1)=DECUT(1)
      if( ECUT(2).LT.0. ) ECUT(2)=DECUT(2)

      IF (FIRST) THEN

        FIRST=.FALSE.
        WRITE(*,*)            '  '
        WRITE(*,'(A40)')      '  ********************************** '
        WRITE(*,*)            '  '
        WRITE(*,'(A40)')      '  NOISE95 suppression V1.0           '
        WRITE(*,*)            '  '
        WRITE(*,'(A30,F6.3)') '  ENERGYCUT EMC            ', ECUT(1)
        WRITE(*,'(A30,F6.3)') '  ENERGYCUT HAC            ', ECUT(2)
        WRITE(*,'(A30,F6.3)') '  IMBALANCE CUT            ', IMBACUT
        WRITE(*,'(A30,F6.3)') '  ENERGY LIMIT FOR IMBACUT ', ELIMCUT
        WRITE(*,'(A30,L5)')   '  ISLAND FLAG              ', ISLFL
        WRITE(*,'(A30,L5)')   '  DELETE FLAG              ', DELFL
        WRITE(*,*)            '  '
        WRITE(*,'(A40)')      '  ********************************** '
        WRITE(*,*)            '  '
        numcell = 0
        do i=1,6
          do j=1,1000
            cellinfo(i,j) = 0.
          enddo
        enddo
        write(6,*)'ch#   run-begin  run-end  Emax  <E>  width  code'
C------  A.Savin
        if(run.gt.10000 .and. run.lt.20000)then
        open(15,file=
     &'/zow/userc/savin/NOISE96/noscell95.list',status='old')
        goto 10
        endif
        if(run.gt.20000 .and. run.lt.30000)then
C_AB        open(15,file=
C_AB     &'/zow/userc/savin/NOISE96/noscell96.list',status='old')
        open(15,file=
     &'/zow/userc/savin/NOISE96/noscell96.03-60.list',status='old')
        goto 10
        endif
        write(6,*) 'Run_nr ',run,' CANNOT OPEN NOSCELL FILE !'
        goto 30
C------
10      read(15,*,end=20) (rddata(i),i=1,7)
        numcell = numcell + 1
        do i=1,7
          cellinfo(i,numcell) = rddata(i)
        enddo
        write(6,*)(cellinfo(i,numcell),i=1,7)
        goto 10
20      close(15)
30      continue

      ENDIF

      IF (COUTAB(CALTRU).EQ.0) THEN
        IERR = 1
        RETURN
      ENDIF

      IERR   = 0
      NCELLS = 0
      CALL VZERO(NUM_CELLS,NISLANDMAX)
      CALL VZERO(NOISEID,MAXIMUMID)

      IF (ISLFL) THEN

        IF (COUTAB(CALTRU).GT.NCELLMAX) THEN
          WRITE(*,'(A50)')
     +      ' WARNING: TOO MANY CELLS FOR THE ISLAND ALGORITHM'
          WRITE(*,'(A12,I3,A16)')
     +      ' ONLY FIRST ', NCELLMAX, ' CELLS ACCEPTED '
        ENDIF

        CELNUM = MIN(COUTAB(CALTRU),NCELLMAX)
        DO I = 1, CELNUM
          CALL FETTAB(CALTRU,ID,I)
          POSERNR(I) = CALTRU_CELLNR
          E_CELL(I)  = CALTRU_E
        ENDDO

        CALL ISLANDS(NISLAND,ISLAND,POSERNR,E_CELL,CELNUM,ERRIS)
        IF (ERRIS.GT.0) PRINT*, 'WARNING: ERROR IN SUBROUTINE ISLANDS'

        DO I = 1, CELNUM
          NUM_CELLS(ISLAND(I)) = NUM_CELLS(ISLAND(I)) + 1
        ENDDO

      ENDIF

      DO  I = COUTAB(CALTRU), 1, -1

        CALL FETTAB(CALTRU,ID,I)

        CHECK = .TRUE.
        IF (ISLFL) THEN
          DO J = 1, NISLAND
            IF (NUM_CELLS(J).GT.1) THEN
              IF (ISLAND(I).EQ.J)  CHECK =.FALSE.
            ENDIF
          ENDDO
        ENDIF

        ISOLA=.FALSE.
        IF( (CALTRU_CCONSA.EQ.INULL).OR.(CALTRU_CCONSA.EQ.IANY) )THEN
           ISOLA=.TRUE.
        ELSE
           call natrel(caltru,caltru_cconsa,cconsa,ok)
           if( ok )then
            Ncc=cconsa_Ncemc+cconsa_NcHac1+cconsa_NcHac2
            if( Ncc.eq.1 ) ISOLA=.TRUE.
           else
            print*,' NOISE95M: error: not ok realtion caltru_cconsa'
            IERR=-2
            RETURN
           endif
        ENDIF

C
C is this an isolated cell?
C
        ISOLA = ISOLA.AND.CHECK

C
C determine the energy cuts to be used
C
        NUM = ISHFT(IAND(CALTRU_CELLNR,15),-1)
        IF     ((NUM.GT.0).AND.(NUM.LE.4)) THEN
          SEC = EMC
        ELSE IF (NUM.LE.5) THEN
          SEC = HAC0
        ELSE IF (NUM.LE.7) THEN
          SEC = HAC12
        ELSE
          IERR = -1
          RETURN
        ENDIF
C       if not isolated cell -- apply standard CalTru cuts
C                               ( only used for bad PMT list )
        IF( .not.ISOLA )THEN
          ECSECT = CALCUT(SEC)
        ELSE
          IF( SEC.EQ.HAC0 .OR. SEC.EQ.HAC12 ) SEC = HAC
          ECSECT = ECUT(SEC)
        ENDIF

c
c check if this cell is a known "noisy" cell
c
        FLAG = .FALSE.
        chkflg = 0
        if (run.gt.1000) then                 ! this is DATA (not MC)
          do j=1,numcell
            if ((caltru_cellnr.eq.cellinfo(1,j)).and.
     &          (run.ge.cellinfo(2,j)).and.
     &          (run.le.cellinfo(3,j))) then
              if (cellinfo(7,j).eq.2) then      ! cut at n sigma
                chkflg = 2
                if (caltru_e.lt.
     &              (cellinfo(5,j)+nsigma*cellinfo(6,j))) then
                  cene = 0.
                  FLAG = .TRUE.
                else
                cene = caltru_e
                endif
              endif
C ---------- A.Savin
C              if (cellinfo(7,j).eq.3) then      ! imb correction
              if (cellinfo(7,j).eq.3 .and.
     & caltru_e.le.cellinfo(4,j) ) then      ! imb correction
C     & caltru_e.le.2 ) then      ! imb correction
                chkflg = 3
                if (caltru_imbal.gt.0) then
                  cene = caltru_e - caltru_imbal
                  FLAG = .TRUE.
                elseif (caltru_imbal.lt.0) then
                  cene = caltru_e + caltru_imbal
                  FLAG = .TRUE.
                else
                  cene = caltru_e
                endif
              endif
              if (cellinfo(7,j).eq.4) then      ! cut at Emax
                chkflg = 4
                if (caltru_e.lt.cellinfo(4,j)) then
                  cene = 0.
                  FLAG = .TRUE.
                else
                  cene = caltru_e
                endif
              endif
            endif
          enddo
        endif

C
C       go ahead for isolated cells
C
        COR = .FALSE.
        IF( ISOLA )THEN

C
C IMBALANCE CUT
C
C         PROTECT AGAINST ZERO

C------ A.Savin ------
CC          CIMB = 2.
CC          IF( CALTRU_E.NE.0. ) CIMB = ABS(CALTRU_IMBAL/CALTRU_E)
CC          IF( CIMB.GT.IMBACUT .AND. CALTRU_E.LT.ELIMCUT )THEN
CC
          CIMB = 0.
          IF( CALTRU_E.NE.0. ) CIMB = ABS(CALTRU_IMBAL)
          IF(CIMB.GT.0.49*CALTRU_E+0.03 .and.
     &  CALTRU_E.LT.ELIMCUT ) then
           COR=.TRUE.
          ENDIF
C---------------------
C
C
C ENERGY CUT
C
          IF( CALTRU_E.LT.ECSECT )THEN
           COR=.TRUE.
          ENDIF
        ENDIF

C
C SOMETHING TO CORRECT?

        IF( FLAG )THEN
          IF( CENE.LT.ECSECT )THEN
            COR = .TRUE.
          ELSE
           CALTRU_E     = CENE
           if (chkflg.eq.3) then
             CALTRU_IMBAL = 0.
           endif
           CALL REPTAB(CALTRU)
          ENDIF
        ENDIF

        IF( COR )THEN
          IF( DELFL ) CALL DELTAB(CALTRU)
        ENDIF

        IF( FLAG .OR. COR )THEN
C         SAMPLE THE 'TOUCHED' CELLS
          NCELLS = NCELLS + 1
          IF (NCELLS.LE.MAXIMUMID) THEN
             NOISEID(NCELLS) = CALTRU_ID
          ELSE
             WRITE(*,'(A28)') ' TOO MANY NOISE CELLS FOUND '
          ENDIF
        ENDIF

      ENDDO

      END
C     ------------------------------------------------------------
C
C
C
C


      SUBROUTINE PHO_SDECAY(Npos,Isp,Ilev)
C**********************************************************************
C
C     decay of single resonance of /POEVT1/:
C       decay in helicity frame according to polarization, isotropic
C       decay and decay with limited transverse phase space possible
C
C     ATTENTION:
C     reference to particle number of CPC has to exist
C
C     input:   NPOS    position in /POEVT1/
C              ISP     0  decay according to phase space
C                      1  decay according to transversal polarization
C                      2  decay according to longitudinal polarization
C                      3  decay with limited phase space
C              ILEV    decay mode to use
C                      1 strong only
C                      2 strong and ew of tau, charm, and bottom
C                      3 strong and electro-weak decays
C                      negative: remove mother resonance after decay
C
C     output:  /POEVT1/,/POEVT2/ final particles according to decay mode
C
C**********************************************************************
      IMPLICIT NONE
      DOUBLE PRECISION amist , amsum , cx , cxs , cy , cys , cz , czs ,
     &                 DEPS , DT_RNDM , ee , EPS , gam , gbet ,
     &                 PHO_PMASS , ptot , wghd , wgsum , xi , xx
      DOUBLE PRECISION yy , zz
      INTEGER i , id , idabs , idcpc , ik , Ilev , imo1 , imo2 , imode ,
     &        iph1 , iph2 , IPHO_ANTI , ipos , Isp , k , kch , l , Npos
      SAVE

      PARAMETER (EPS=1.D-15,DEPS=1.D-10)

C  input/output channels
      INCLUDE 'inc/poinou'
C  event debugging information
      INCLUDE 'inc/podebg'
C  model switches and parameters
      INCLUDE 'inc/pomdls'
C  some constants
      INCLUDE 'inc/pocons'

C  standard particle data interface

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

C  general particle data
      INCLUDE 'inc/popar2'
C  particle decay data
      INCLUDE 'inc/popar3'
C  auxiliary data for three particle decay
      INCLUDE 'inc/po3dcy'

      DIMENSION wghd(20) , kch(20) , id(3)

      imode = ABS(Ilev)
      IF ( LPRi.GT.4 .AND. IDEb(36).GE.15 ) WRITE (LO,'(1X,A,3I5)')
     &      'PHO_SDECAY: NPOS,ISP,ILEV' , Npos , Isp , Ilev

C  comment entry
      IF ( ISThep(Npos).GT.11 ) RETURN

C  particle stable?
      idcpc = IMPart(Npos)
      IF ( idcpc.EQ.0 ) RETURN
      idabs = ABS(idcpc)
      IF ( IDEc_list(1,idabs).EQ.0 ) RETURN

C  different decay modi (times)
      IF ( imode.EQ.1 ) THEN
         IF ( IDEc_list(1,idabs).NE.1 ) RETURN
      ELSE IF ( imode.EQ.2 ) THEN
         IF ( IDEc_list(1,idabs).GT.2 ) RETURN
      ELSE IF ( imode.EQ.3 ) THEN
         IF ( IDEc_list(1,idabs).GT.3 ) RETURN
      ELSE
         IF ( LPRi.GT.4 ) WRITE (LO,'(/1X,A,I5)')
     &         'PHO_SDECAY: invalid mode (ILEV)' , Ilev
         CALL PHO_ABORT
      END IF

C  decay products, check for mass limitations
      k = 0
      wgsum = 0.D0
      amist = PHEp(5,Npos)
      DO i = IDEc_list(2,idabs) , IDEc_list(3,idabs)
         amsum = 0.D0
         DO l = 1 , 3
            id(l) = ISEc_list(l,i)
            IF ( id(l).NE.0 ) amsum = amsum + PHO_PMASS(id(l),0)
         END DO
         IF ( amsum.LT.amist ) THEN
            k = k + 1
            wghd(k) = WG_sec_list(i)
            kch(k) = i
         END IF
      END DO
      IF ( k.EQ.0 ) THEN
         IF ( LPRi.GT.4 ) WRITE (LO,'(/1X,A,I6,3E12.4)')
     &         'PHO_SDECAY: particle mass too small (NPOS,MA,DCYM)' ,
     &        Npos , amist , amsum
         CALL PHO_PREVNT(0)
         RETURN
      END IF

C  sample new decay channel
      xi = (DT_RNDM(amsum)-EPS)*wgsum
      k = 0
      wgsum = 0.D0
 100  k = k + 1
      wgsum = wgsum + wghd(k)
      IF ( xi.GT.wgsum ) GOTO 100
      ik = kch(k)
      id(1) = ISEc_list(1,ik)
      id(2) = ISEc_list(2,ik)
      id(3) = ISEc_list(3,ik)
      IF ( idcpc.LT.0 ) THEN
         id(1) = IPHO_ANTI(id(1))
         id(2) = IPHO_ANTI(id(2))
         IF ( id(3).NE.0 ) id(3) = IPHO_ANTI(id(3))
      END IF

C  rotation
      ptot = SQRT(PHEp(1,Npos)**2+PHEp(2,Npos)**2+PHEp(3,Npos)**2)
      cxs = PHEp(1,Npos)/ptot
      cys = PHEp(2,Npos)/ptot
      czs = PHEp(3,Npos)/ptot
C  boost
      gbet = ptot/amist
      gam = PHEp(4,Npos)/amist

      IF ( id(3).EQ.0 ) THEN
C  two particle decay
         CALL PHO_SDECY2(amist,PHO_PMASS(id(1),0),PHO_PMASS(id(2),0),
     &                   Isp)
      ELSE
C  three particle decay
         CALL PHO_SDECY3(amist,PHO_PMASS(id(1),0),PHO_PMASS(id(2),0),
     &                   PHO_PMASS(id(3),0),Isp)
      END IF

      IF ( Ilev.LT.0 ) THEN
         IF ( NHEp.NE.Npos ) THEN
            IF ( LPRi.GT.4 ) WRITE (LO,'(/1X,2A,2I5)')
     &            'PHO_SDECAY:ERROR: ' ,
     &           'cannot remove resonance (NPOS,NHEP)' , Npos , NHEp
            CALL PHO_ABORT
         END IF
         imo1 = JMOhep(1,Npos)
         imo2 = JMOhep(2,Npos)
         NHEp = NHEp - 1
      ELSE
         imo1 = Npos
         imo2 = 0
      END IF
      iph1 = IPHist(1,Npos)
      iph2 = IPHist(2,Npos)

C  back transformation and registration
      DO i = 1 , 3
         IF ( id(i).NE.0 ) THEN
            CALL PHO_LTRANS(gam,gbet,cxs,cys,czs,COD(i),COF(i),SIF(i),
     &                      PCM(i),ECM(i),ptot,cx,cy,cz,ee)
            xx = ptot*cx
            yy = ptot*cy
            zz = ptot*cz
            CALL PHO_REGPAR(1,0,id(i),imo1,imo2,xx,yy,zz,ee,iph1,iph2,0,
     &                      0,ipos,1)
         END IF
      END DO

C400  CONTINUE
C  debug output
      IF ( IDEb(36).GE.20 ) THEN
         IF ( LPRi.GT.4 ) WRITE (LO,'(2(/1X,A))')
     &        'PHO_SDECAY: /POEVT1/' , '--------------------'
         CALL PHO_PREVNT(0)
      END IF

      END SUBROUTINE


      subroutine libpotph(phpad, verbse,
     1       ntitle, title,                                             ! TITLE
     2       nat, rat, iphat,                                           ! ATOMS
     3       nph, iz, potlbl, lmaxsc, lmaxph, xnatph, spinph,           ! POTENTIALS
     4       ihole,                                                     ! HOLE/EDGE
     5       rfms1, lfms1, nscmt, ca1, nmix, ecv, icoul,                ! SCF
     6       ipol, evec, elpty, xivec,                                  ! POLARIZATION, ELLIPTICITY
     7       ispin, spvec, angks,                                       ! SPIN
     8       ptz, gamach,                                               ! computed
     9       ixc, vr0, vi0, ixc0,                                       ! EXCHANGE
     _       iafolp, folp, xion, rgrd, iunf,                            ! AFOLP, FOLP, ION, RGRID, UNFREEZEF
     1       inters, totvol, jumprm, nohole,                            ! INTERSTITIAL, JUMPRM, NOHOLE
     2       iplsmn)                                                    ! PLASMON

c##****f* feff85exafs/libpotph
c##  NAME
c##     libpotph
c##
c##  SYNOPSIS
c##     libpotph(ntitle, title, nat, rat, iphat, nph, iz, potlbl, lmaxsc,
c##    $         lmaxph, xnatph, spinph, ihole, rfms1, lfms1, nscmt, ca1,
c##    $         nmix, ecv, icoul, ipol, evec, elpty, xivec, ispin, spvec,
c##    $         angks, ptz, gamach, ixc, vr0, vi0, ixc0, iafolp, folp,
c##    $         xion, rgrd, iunf, inters, totvol, jumprm, nohole)
c##
c##  FUNCTION
c##     compute potentials and phases from an input atoms list
c##
c##  INPUTS
c##    phpad         path/name of output phases.pad file
c##    verbse        boolean flag, true=write screen messages
c##    ntitle        number of header lines                               TITLE
c##    titles        (nheadx) array of header string                      TITLE
c##    nat           number of atoms in cluster                           ATOMS
c##    rat           (3,natx) cartesian coordinates of atoms in cluster   ATOMS
c##    iphat         (natx) unique potential indeces of atoms in cluster  ATOMS
c##    nph           number of unique potentials                          POTENTIALS
c##    iz            (0:nphx) Z numbers of unique potentials              POTENTIALS
c##    potlbl        (0:nphx) labels of unique potentials                 POTENTIALS
c##    lmaxsc        (0:nphx) l max for SCF for each potential            POTENTIALS
c##    lmaxph        (0:nphx) l max for FMS for each potential            POTENTIALS
c##    xnatph        (0:nphx) stoichiometry of each potential             POTENTIALS
c##    spinph        (0:nphx) spin on each unique potential               POTENTIALS
c##    ihole         edge index, 1=K, 4=L3, etc                           HOLE/EDGE
c##    rscf          cluster radius for self-consistent calculation       SCF
c##    lscf          0=solid, 1=molecule                                  SCF
c##    nscmt         max number of self-consistency iterations            SCF
c##    ca            self-consistency convergence accelerator             SCF
c##    nmix          number of mixing iterations before Broyden           SCF
c##    ecv           core/valence separation energy                       SCF
c##    icoul         obsolete param. for handling Coulomb potential       SCF
c##    ipol          1=do polarization calculation                        POLARIZATION
c##    evec          (3) polarization array                               POLARIZATION
c##    elpty         eccentricity of elliptical light                     ELLIPTICITY
c##    xivec         (3) ellipticity array                                ELLIPTICITY
c##    ispin         +/-2 = do spin calculation                           SPIN
c##    spvec         (3) spin array                                       SPIN
c##    angks         angle between spin and incidient beam                SPIN
c##    ixc           exchange index                                       EXCHANGE
c##    vr0           Fermi level offset                                   EXCHANGE
c##    vi0           constant broadening                                  EXCHANGE
c##    ixc0          exchange index for background function               EXCHANGE
c##    iafolp        1=do automated overlapping                           FOLP & AFOLP
c##    folp          (0:nphx) overlapping fractions                       FOLP & AFOLP
c##    xion          (0:nphx) potential ionizations                       ION
c##    rgrd          radial grid used for the potentials/phases           RGRID
c##    iunf          1=unfreeze f electrons                               UNFREEZEF
c##    inters                                                             INTERSTITIAL
c##    totvol                                                             INTERSTITIAL
c##    jumprm        1=remove potential jumps at muffin tin radii         JUMPRM
c##    nohole        1=compute without core-hole                          NOHOLE
c##    iplsmn        1=compute multi-pole self-energy                     PLASMON
c##
c##  RESULT
c##    ptz           (-1:1,-1:1) polarization tensor
c##    gamach        tabulated core-hole lifetime
c##
c##  BUGS
c##    Report bugs and other issues at https://github.com/xraypy/feff85exafs
c##
c##  LICENSE
c##    See src/HEADERS/license.h for the terms of the parts of feff85exafs derived directly from Feff
c##
c##    nxjson.c and nxjson.h are Copyright (c) 2013 Yaroslav Stavnichiy <yarosla@gmail.com>.  See
c##    https://bitbucket.org/yarosla/nxjson/src
c##
c##    The C wrapper around this subroutine is released to the public domain
c##
c##  SEE ALSO
c##    The pot and xsph stand-alone programs, the libfeffphases.c wrapper
c##
c##****

      implicit double precision (a-h, o-z)

      include '../HEADERS/const.h'
      include '../HEADERS/dim.h'
      include '../HEADERS/parallel.h'

c     dimension/types of atoms & global.json things
      integer nat, iphat(natx), nabs, iphabs, ipol, ispin, le2, iabs
      double precision evec(3), xivec(3), spvec(3), elpty,angks,rclabs
      complex*16 ptz(-1:1, -1:1)
      double precision rat(3,natx)

c     name of output phase.pad file
      character*256 phpad
      logical verbse

c     dimension/type os mod1/pot things
      integer  iatph(0:nphx)
c      integer ibounc(natx)
      character*80 title(nheadx)
c      character*80 head(nheadx)
c      integer lhead(nheadx)
c      integer mpot, mphase
      integer nph, ntitle, ihole, ipr1, iafolp, ixc,
     1       iunf, nmix, nohole, jumprm, inters, nscmt, icoul, lfms1
      integer iz(0:nphx), lmaxsc(0:nphx)
      real rfms1
      double precision gamach, rgrd, ca1, ecv, totvol
      dimension xnatph(0:nphx), folp(0:nphx), xion(0:nphx)

c     dimension/type os mod2/xpsh things
      integer ipr2, ixc0, ispec, lreal, lfms2, l2lp, iplsmn
c      integer iGrid
      double precision xkstep, xkmax, vixan
      double precision vr0, vi0, spinph(0:nphx)
      real rfms2
      integer lmaxph(0:nphx)
      character*6  potlbl(0:nphx)
      integer izstd, ifxc, ipmbse, itdlda, nonlocal

c     for OVERLAP option -- DISABLED IN FEFF85EXAFS
      dimension novr(0:nphx), iphovr(novrx,0:nphx), nnovr(novrx,0:nphx)
      dimension rovr(novrx,0:nphx)

      parameter (big = 1.0d5)

c**********************************************************************
c     these parameters pass stuff from pot to wrpot and xsph
      double precision rnrmav, xmu, vint, rhoint, emu, s02, erelax
      double precision wp, rs, xf, qtotel
c     r mesh index just inside rmt
      dimension imt(0:nphx)
c     r mesh index just inside rnorman
      dimension inrm(0:nphx)
c     muffin tin radius
      dimension rmt(0:nphx)
c     norman radius
      dimension rnrm(0:nphx), qnrm(0:nphx)
c     folp(0:nphx)  - overlap factor for rmt calculation
      dimension folpx(0:nphx)
c     need irregular solution for complex potential. fix later
      dimension dgc0(251), dpc0(251)
c     additional data needed for relativistic version
      dimension dgc(251,30,0:nphx+1), dpc(251,30,0:nphx+1)
      dimension adgc(10,30,0:nphx+1), adpc(10,30,0:nphx+1)
c     Overlap calculation results
c     overlapped density*4*pi
      dimension edens(251,0:nphx)
c     overlapped coul pot
      dimension vclap(251,0:nphx)
c     overlapped total potential
      dimension vtot (251,0:nphx)
      dimension edenvl(251,0:nphx)
      dimension vvalgs (251,0:nphx)
      dimension dmag(251,0:nphx+1)
      dimension xnval(30,0:nphx+1)
      dimension eorb(30,0:nphx+1)
      dimension kappa(30,0:nphx+1), iorb(-4:3,0:nphx+1)
      dimension xnmues(0:lx,0:nphx)
c     Josh use nhtmp to save nohole value
      integer nhtmp

      logical write_loss, write_opcons, write_exc, verbose
      integer npoles
      double precision eps0
      double precision wpcorr(MxPole), delta(MxPole), ampfac(MxPole)

c      print *, "libpotph: >", phpad(1:istrln(phpad)), "<"
c*****************************************************************************
c     the following parameters are for features not present or not used
c     in feff85exafs
c     they are all set to default/turned-off values

c     CONTROL and PRINT (ipr1=1 for misc.dat)
c      mpot     = 1
c      mphase   = 1
      ipr1     = 0
      ipr2     = 0
c     ispec=0 for EXAFS, >0 other spectroscopies
      ispec    = 0
c     CFAVERAGE
      nabs     = 1
      iphabs   = 0
      rclabs   = big
c     MULTIPOLE
      le2      = 0
      l2lp     = 0
c     FMS
      rfms2    = real(-1.)
      lfms2    = 0
c     XANES
      vixan    = dble(0) / hart
      xkstep   = dble(0.07) * bohr
      xkmax    = dble(20) * bohr
c     RPHASES
      lreal    = 0
c     PMBSE
      ifxc     = 0
      ipmbse   = 0
      nonlocal = 0
c      ibasis   = 0
c     TDLDA
      izstd    = 0
      itdlda   = 0
c     PLASMON
c      iGrid    = 0

c     OVERLAP
      do 20 i=0,nphx
         novr(i) = 0;
         do 10 j=1,novrx
            iphovr(j,i) = 0
            nnovr(j,i)  = 0
            rovr(j,i)   = dble(0.)
 10      continue
 20   continue
c      do 30 i=1,natx
c         ibounc(i) = 1
c     30   continue

c     multi-pole stuff
      write_loss   = .false.
      write_opcons = .false.
      write_exc    = .false.
      verbose      = .false.
      npoles       = 100
      eps0         = -1.d0
      do 40 i=1,MxPole
         wpcorr(i) = 0.d0
c        gamma ?
         delta(i)  = 0.d0
         ampfac(i) = 0.d0
 40   continue

c*****************************************************************************

c$$$         print *, 1, rat(1,1), rat(2,1), rat(3,1), iphat(1)
c$$$         print *, 2, rat(1,2), rat(2,2), rat(3,2), iphat(2)
c$$$         print *, 3, rat(1,3), rat(2,3), rat(3,3), iphat(3)
c$$$         print *, 13, rat(1,13), rat(2,13), rat(3,13), iphat(13)
c$$$         print *, 23, rat(1,23), rat(2,23), rat(3,23), iphat(23)
c$$$         print *, 177, rat(1,177), rat(2,177), rat(3,177), iphat(177)
c$$$

c     iabs != 0 has something to do with CFAVERAGE, outside scope of feff85exafs
      iabs = 1

      call ffsort(iabs, nat, rat, iphat,
     1       nabs, iphabs, rclabs, ipol, ispin, le2,
     2       elpty, angks, evec, xivec, spvec, ptz,
     3       iatph)

      call pot(verbse, rgrd, nohole,
     $       inters, totvol, ecv, nscmt, nmix, ntitle, title,
     $       nat, nph, ihole, iafolp, ixc, iphat, rat, iatph, xnatph,
     $       novr, iphovr, nnovr, rovr, folp, xion, iunf, iz, ipr1,
     $       ispec, jumprm, lmaxsc, icoul, ca1, rfms1, lfms1,
     $
     -       rnrmav, xmu, vint, rhoint,
     1       emu, s02, erelax, wp, rs, xf, qtotel,
     2       imt, rmt, inrm, rnrm, folpx,
     3       dgc0, dpc0, dgc, dpc, adgc, adpc,
     4       edens, vclap, vtot, edenvl, vvalgs, dmag, xnval,
     5       eorb, kappa, iorb, qnrm, xnmues, nhtmp
     6       )
c     return stuff for passing to xsph and skipping pot.pad

c     could make a conditional call to wrpot here

      if (iplsmn .gt. 0) then
c         call feffloss(nph, iz, xnatph, rnrm, npoles, eps0,
c     1          write_opcons, write_loss, write_exc, verbose,
c     2          wpcorr, gamma, ampfac, delta)
      end if
c     need to send <<wpcorr, gamma, ampfac, delta>> into xsph, then into
c     phase and xsect for use when iplsmn is > 0

c               wrxsec
      call xsph(.false., verbse, phpad,
     -       ipr2, ispec, vixan, xkstep, xkmax, gamach, rgrd,
     1       nph, lmaxph, potlbl, spinph, iatph, nat, rat, iphat,
     2       ixc, vr0, vi0, ixc0, lreal, rfms2, lfms2, l2lp,
     3       ipol, ispin, le2, angks, ptz, iplsmn,
     4       izstd, ifxc, ipmbse, itdlda, nonlocal,
     _
     1       ntitle, title, rnrmav, xmu, vint, rhoint,
     2       emu, s02, erelax, wp, ecv, rs, xf, qtotel,
     3       imt, rmt, inrm, rnrm, folp, folpx, xnatph,
     4       dgc0, dpc0, dgc, dpc, adgc, adpc,
     5       edens, vclap, vtot, edenvl, vvalgs, dmag, xnval,
     6       iorb, nohole, ihole,
     7       inters, totvol, iafolp, xion, iunf, iz, jumprm)
c     second block is the parameters from rdpot, skipping pot.pad

      return
      end


      SUBROUTINE MOLDAT
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INCLUDE 'SIZES'
      COMMON /GEOKST/ NATOMS,LABELS(NUMATM),
     1                NA(NUMATM),NB(NUMATM),NC(NUMATM)
     2       /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM),
     3                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA,
     4                NCLOSE,NOPEN,NDUMY,FRACT
     5       /KEYWRD/ KEYWRD
     6       /NATORB/ NATORB(107)
     7       /CORE  / CORE(107)
     8       /BETAS / BETAS(107),BETAP(107),BETAD(107)
     9       /MOLORB/ USPD(MAXORB),PSPD(MAXORB)
     1       /VSIPS / VS(107),VP(107),VD(107)
     2       /ONELEC/ USS(107),UPP(107),UDD(107)
     3       /ATHEAT/ ATHEAT
     4       /POLVOL/ POLVOL(107)
     5       /MULTIP/ DD(107),QQ(107),AM(107),AD(107),AQ(107)
     6       /TWOELE/ GSS(107),GSP(107),GPP(107),GP2(107),HSP(107)
     7                ,GSD(107),GPD(107),GDD(107)
     8       /ALPHA / ALP(107)
      COMMON /GAUSS / FN1(107),FN2(107)
      COMMON /MNDO/  USSM(107), UPPM(107), UDDM(107), ZSM(107),
     1ZPM(107), ZDM(107), BETASM(107), BETAPM(107), BETADM(107),
     2ALPM(107), EISOLM(107), DDM(107), QQM(107), AMM(107),
     3ADM(107), AQM(107), GSSM(107), GSPM(107), GPPM(107),
     4GP2M(107), HSPM(107), POLVOM(107)
      COMMON /GEOM  / GEO(3,NUMATM)
      PARAMETER (MDUMY=MAXPAR**2-MPACK)
      COMMON /SCRACH/ RXYZ(MPACK), XDUMY(MDUMY)
*
*  COMMON BLOCKS FOR MINDO/3
*
      COMMON /ONELE3 /  USS3(18),UPP3(18)
     1       /ATOMI3 /  EISOL3(18),EHEAT3(18)
     2       /EXPON3 /  ZS3(18),ZP3(18)
*
*  END OF MINDO/3 COMMON BLOCKS
*
      COMMON /EXPONT/ ZS(107),ZP(107),ZD(107)
      COMMON /ATOMIC/ EISOL(107),EHEAT(107)
      DIMENSION COORD(3,NUMATM)
      CHARACTER*80 KEYWRD
      LOGICAL DEBUG, UHF,EXCI, TRIP, MINDO3, BIRAD,PARAM,AM1, OPEN
      DEBUG = (INDEX(KEYWRD,'MOLDAT').NE.0)
      MINDO3= (INDEX(KEYWRD,'MINDO').NE.0)
      UHF=(INDEX(KEYWRD,'UHF') .NE. 0)
      AM1= (INDEX(KEYWRD,'AM1')+INDEX(KEYWRD,'PARAM').NE.0)
      KHARGE=0
      I=INDEX(KEYWRD,'CHARGE')
      IF(I.NE.0) KHARGE=READA(KEYWRD,I)
      NELECS=-KHARGE
      NDORBS=0
      ATHEAT=0.D0
      EAT=0.D0
      NUMAT=0
      IF (   .NOT.   AM1   ) THEN
*
*    SWITCH IN MNDO PARAMETERS
*
         DO 10 I=1,107
            IF(.NOT.MINDO3) POLVOL(I)=POLVOM(I)
            FN1(I)=0.D0
            ZS(I)=ZSM(I)
            ZP(I)=ZPM(I)
            ZD(I)=ZDM(I)
            USS(I)=USSM(I)
            UPP(I)=UPPM(I)
            UDD(I)=UDDM(I)
            BETAS(I)=BETASM(I)
            BETAP(I)=BETAPM(I)
            BETAD(I)=BETADM(I)
            ALP(I)=ALPM(I)
            EISOL(I)=EISOLM(I)
            DD(I)=DDM(I)
            QQ(I)=QQM(I)
            AM(I)=AMM(I)
            AD(I)=ADM(I)
            AQ(I)=AQM(I)
            GSS(I)=GSSM(I)
            GPP(I)=GPPM(I)
            GSP(I)=GSPM(I)
            GP2(I)=GP2M(I)
            HSP(I)=HSPM(I)
   10    CONTINUE
      ENDIF
      IF( MINDO3 ) THEN
         DO 20 I=1,17
            IF(I.EQ.2.OR.I.EQ.10)GOTO 20
            USS(I)=USS3(I)
            UPP(I)=UPP3(I)
            EISOL(I)=EISOL3(I)
            EHEAT(I)=EHEAT3(I)
            ZS(I)=ZS3(I)
            ZP(I)=ZP3(I)
   20    CONTINUE
      ENDIF
      IF(USS(1) .GT. -1.D0) THEN
         WRITE(6,'(''  THE HAMILTONIAN REQUESTED IS NOT AVAILABLE IN''
     1,'' THIS PROGRAM'')')
         STOP
      ENDIF
      IA=1
      IB=0
      NHEAVY=0
      DO 70 II=1,NATOMS
         IF(LABELS(II).EQ.99.OR.LABELS(II).EQ.107) GOTO 70
         NUMAT=NUMAT+1
         NAT(NUMAT)=LABELS(II)
         NFIRST(NUMAT)=IA
         NI=NAT(NUMAT)
         ATHEAT=ATHEAT+EHEAT(NI)
         EAT   =EAT   +EISOL(NI)
         NELECS=NELECS+NINT(CORE(NI))
         IB=IA+NATORB(NI)-1
         NMIDLE(NUMAT)=IB
         IF(NATORB(NI).EQ.9)NDORBS=NDORBS+5
         IF(NATORB(NI).EQ.9)NMIDLE(NUMAT)=IA+3
         NLAST(NUMAT)=IB
         USPD(IA)=USS(NI)
         IF(IA.EQ.IB) GOTO 60
         K=IA+1
         K1=IA+3
         DO 30 J=K,K1
            USPD(J)=UPP(NI)
   30    CONTINUE
         NHEAVY=NHEAVY+1
   40    IF(K1.EQ.IB)GOTO 60
         K=K1+1
         DO 50 J=K,IB
   50    USPD(J)=UDD(NI)
   60    CONTINUE
   70 IA=IB+1
      ATHEAT=ATHEAT-EAT*23.061D0
      NORBS=NLAST(NUMAT)
      IF(NORBS.GT.MAXORB)THEN
         WRITE(6,'(//10X,''**** MAX. NUMBER OF ORBITALS:'',I4,/
     1            10X,''NUMBER OF ORBITALS IN SYSTEM:'',I4)')
     2MAXORB,NORBS
         STOP
      ENDIF
      NLIGHT=NUMAT-NHEAVY
      N2EL=50*NHEAVY*(NHEAVY-1)+10*NHEAVY*NLIGHT+(NLIGHT*(NLIGHT-1))/2
      IF(N2EL.GT.N2ELEC)THEN
         WRITE(6,'(//10X,''**** MAX. NUMBER OF TWO-ELECTRON INTEGRALS:''
     1,I8,/
     2            10X,''NUMBER OF TWO ELECTRON INTEGRALS IN SYSTEM:'',
     3I8)')
     4N2ELEC,N2EL
         STOP
      ENDIF
C
C   NOW TO CALCULATE THE NUMBER OF LEVELS OCCUPIED
      TRIP=(INDEX(KEYWRD,'TRIPLET').NE.0)
      EXCI=(INDEX(KEYWRD,'EXCITED').NE.0)
      BIRAD=(EXCI.OR.INDEX(KEYWRD,'BIRAD').NE.0)
      IF(INDEX(KEYWRD,'C.I.') .NE. 0 .AND. UHF ) THEN
         WRITE(6,'(//10X,''C.I. NOT ALLOWED WITH UHF '')')
         STOP
      ENDIF
C
C NOW TO WORK OUT HOW MANY ELECTRONS ARE IN EACH TYPE OF SHELL
C
      NALPHA=0
      NBETA=0
      NCLOSE=0
      NOPEN=0
      IF( UHF ) THEN
         FRACT=1.D0
         NBETA=NELECS/2
         IF( TRIP ) THEN
            IF(NBETA*2 .NE. NELECS) THEN
               WRITE(6,'(//10X,''TRIPLET SPECIFIED WITH ODD NUMBER'',
     1            '' OF ELECTRONS, CORRECT FAULT '')')
               STOP
            ELSE
               WRITE(6,'(//'' TRIPLET STATE CALCULATION'')')
               NBETA=NBETA-1
            ENDIF
         ENDIF
         NALPHA=NELECS-NBETA
         WRITE(6,'(//10X,''UHF CALCULATION, NO. OF ALPHA ELECTRONS ='',I
     13,/27X,''NO. OF BETA  ELECTRONS ='',I3)')NALPHA,NBETA
      ELSE
C
C   NOW TO DETERMINE OPEN AND CLOSED SHELLS
C
         OPEN=.FALSE.
         IELEC=0
         ILEVEL=0
         IF( TRIP .OR. EXCI .OR. BIRAD ) THEN
            IF( (NELECS/2)*2 .NE. NELECS) THEN
               WRITE(6,'(//10X,''SYSTEM SPECIFIED WITH ODD NUMBER'',
     1            '' OF ELECTRONS, CORRECT FAULT '')')
               STOP
            ENDIF
            IF(BIRAD)WRITE(6,'(//'' SYSTEM IS A BIRADICAL'')')
            IF(TRIP )WRITE(6,'(//'' TRIPLET STATE CALCULATION'')')
            IF(EXCI )WRITE(6,'(//'' EXCITED STATE CALCULATION'')')
            IELEC=2
            ILEVEL=2
         ELSEIF((NELECS/2)*2.NE.NELECS) THEN
            IELEC=1
            ILEVEL=1
         ENDIF
         IF(INDEX(KEYWRD,'QUART').NE.0) THEN
            WRITE(6,'(//'' QUARTET STATE CALCULATION'')')
            IELEC=3
            ILEVEL=3
         ENDIF
         IF(INDEX(KEYWRD,'QUINT').NE.0) THEN
            WRITE(6,'(//'' QUINTET STATE CALCULATION'')')
            IELEC=4
            ILEVEL=4
         ENDIF
         IF(INDEX(KEYWRD,'SEXT').NE.0) THEN
            WRITE(6,'(//'' SEXTET STATE CALCULATION'')')
            IELEC=5
            ILEVEL=5
         ENDIF
         I=INDEX(KEYWRD,'OPEN(')
         IF(I.NE.0)THEN
            IELEC=READA(KEYWRD,I)
            ILEVEL=READA(KEYWRD,I+7)
         ENDIF
         NCLOSE=NELECS/2
         NOPEN = NELECS-NCLOSE*2
         IF( IELEC.NE.0 )THEN
            IF((NELECS/2)*2.EQ.NELECS .NEQV.
     1                  (IELEC/2)*2.EQ.IELEC) THEN
               WRITE(6,'('' IMPOSSIBLE NUMBER OF OPEN SHELL ELECTR
     1ONS'')')
               STOP
            ENDIF
            NCLOSE=NCLOSE-IELEC/2
            NOPEN=ILEVEL
            FRACT=IELEC*1.D0/ILEVEL
            WRITE(6,'('' THERE ARE'',I3,'' DOUBLY FILLED LEVELS'')
     1')NCLOSE
         ENDIF
         IF( .NOT. PARAM)WRITE(6,'(//10X,''RHF CALCULATION, NO. OF '',
     1''DOUBLY OCCUPIED LEVELS ='',I3)')NCLOSE
         IF(NOPEN.NE.0.AND.ABS(FRACT-1.D0).LT.1.D-4)
     1WRITE(6,'(/27X,''NO. OF SINGLY OCCUPIED LEVELS ='',I3)')NOPEN
         IF(NOPEN.NE.0.AND.ABS(FRACT-1.D0).GT.1.D-4)
     1WRITE(6,'(/27X,''NO. OF LEVELS WITH OCCUPANCY'',F6.3''  ='',I3)')
     2FRACT,NOPEN
         NOPEN=NOPEN+NCLOSE
      ENDIF
C#      WRITE(6,'(''  NOPEN,NCLOSE,NALPHA,NBETA,FRACT'',4I4,F12.5)')
C#     1 NOPEN, NCLOSE, NLAPHA, NBETA, FRACT
      YY=FLOAT(KHARGE)/(NORBS+1.D-10)
      L=0
      DO 100 I=1,NUMAT
         NI=NAT(I)
         XX=1.D0
         IF(NI.GT.2) XX=0.25D0
         W=CORE(NI)*XX-YY
         IA=NFIRST(I)
         IC=NMIDLE(I)
         IB=NLAST(I)
         DO 80 J=IA,IC
            L=L+1
   80    PSPD(L)=W
         DO 90 J=IC+1,IB
            L=L+1
   90    PSPD(L)=0.D0
  100 CONTINUE
C
C   WRITE OUT THE INTERATOMIC DISTANCES
C
      CALL GMETRY(GEO,COORD)
      RMIN=100.D0
      L=0
      DO 110 I=1,NUMAT
         DO 110 J=1,I
            L=L+1
            RXYZ(L)=SQRT((COORD(1,I)-COORD(1,J))**2+
     1                     (COORD(2,I)-COORD(2,J))**2+
     2                     (COORD(3,I)-COORD(3,J))**2)
            IF(RMIN.GT.RXYZ(L) .AND. I .NE. J .AND.
     1 (NAT(I).LT.103 .OR. NAT(J).LT.103)) THEN
               IMINR=I
               JMINR=J
               RMIN=RXYZ(L)
            ENDIF
  110 CONTINUE
      IF (INDEX(KEYWRD,'PARAM')+INDEX(KEYWRD,'NOINTER') .EQ. 0) THEN
         WRITE(6,'(//10X,''  INTERATOMIC DISTANCES'')')
         CALL VECPRT(RXYZ,NUMAT)
      ENDIF
      IF(RMIN.LT.0.8D0.AND.INDEX(KEYWRD,'GEO-OK') .EQ.0) THEN
         WRITE(6,120)IMINR,JMINR,RMIN
  120    FORMAT(//,'   ATOMS',I3,' AND',I3,' ARE SEPARATED BY',F8.4,
     1' ANGSTROMS.',/'   TO CONTINUE CALCULATION SPECIFY "GEO-OK"')
         STOP
      ENDIF
      IF(.NOT. DEBUG) RETURN
      WRITE(6,130)NUMAT,NORBS,NDORBS,NATOMS
  130 FORMAT('   NUMBER OF REAL ATOMS:',I4,/
     1      ,'   NUMBER OF ORBITALS:  ',I4,/
     2      ,'   NUMBER OF D ORBITALS:',I4,/
     3      ,'   TOTAL NO. OF ATOMS:  ',I4)
      WRITE(6,140)(USPD(I),I=1,NORBS)
  140 FORMAT('   ONE-ELECTRON DIAGONAL TERMS',/,10(/,10F8.3))
      WRITE(6,150)(PSPD(I),I=1,NORBS)
  150 FORMAT('   INITIAL P FOR ALL ATOMIC ORBITALS',/,10(/,10F8.3))
      RETURN
      END


Subroutine hijing(frame, bmin0, bmax0)
  Parameter (maxptn=400001)
  Parameter (maxstr=150001)
  Parameter (maxidl=4001)
  Double Precision gx0, gy0, gz0, ft0, px0, py0, pz0, e0, xmass0
  Double Precision gx5, gy5, gz5, ft5, px5, py5, pz5, e5, xmass5
  Double Precision ataui, zt1, zt2, zt3
  Double Precision xnprod, etprod, xnfrz, etfrz, dnprod, detpro, dnfrz, detfrz
  Double Precision vxp0, vyp0, vzp0, xstrg0, ystrg0, xstrg, ystrg
  Character frame*8
  Dimension scip(300, 300), rnip(300, 300), sjip(300, 300), jtp(3), ipcol(90000), itcol(90000)
  Common /hparnt/hipr1(100), ihpr2(50), hint1(100), ihnt2(50)
  Common /hjcrdn/yp(3, 300), yt(3, 300)
  Common /hjglbr/nelt, ninthj, nelp, ninp
  Common /hmain1/eatt, jatt, natt, nt, np, n0, n01, n10, n11
  Common /hmain2/katt(maxstr, 4), patt(maxstr, 4)
  Common /hstrng/nfp(300, 15), pp(300, 15), nft(300, 15), pt(300, 15)
  Common /hjjet1/npj(300), kfpj(300, 500), pjpx(300, 500), pjpy(300, 500), pjpz(300, 500), pjpe(300, 500), pjpm(300, 500), ntj(300), kftj(300, 500), pjtx(300, 500), pjty(300, 500), pjtz(300, 500), pjte(300, 500), pjtm(300, 500)
  Common /hjjet2/nsg, njsg(maxstr), iasg(maxstr, 3), k1sg(maxstr, 100), k2sg(maxstr, 100), pxsg(maxstr, 100), pysg(maxstr, 100), pzsg(maxstr, 100), pesg(maxstr, 100), pmsg(maxstr, 100)
  Common /hjjet4/ndr, iadr(maxstr, 2), kfdr(maxstr), pdr(maxstr, 5)
  Common /xydr/rtdr(maxstr, 2)
  Common /rndf77/nseed
  Common /lujets/n, k(9000, 5), p(9000, 5), v(9000, 5)
  Common /ludat1/mstu(200), paru(200), mstj(200), parj(200)
  Common /arprc/itypar(maxstr), gxar(maxstr), gyar(maxstr), gzar(maxstr), ftar(maxstr), pxar(maxstr), pyar(maxstr), pzar(maxstr), pear(maxstr), xmar(maxstr)
  Common /para1/mul
  Common /prec1/gx0(maxptn), gy0(maxptn), gz0(maxptn), ft0(maxptn), px0(maxptn), py0(maxptn), pz0(maxptn), e0(maxptn), xmass0(maxptn), ityp0(maxptn)
  Common /prec2/gx5(maxptn), gy5(maxptn), gz5(maxptn), ft5(maxptn), px5(maxptn), py5(maxptn), pz5(maxptn), e5(maxptn), xmass5(maxptn), ityp5(maxptn)
  Common /ilist7/lstrg0(maxptn), lpart0(maxptn)
  Common /ilist8/lstrg1(maxptn), lpart1(maxptn)
  Common /srec1/nsp, nst, nsi
  Common /srec2/ataui(maxstr), zt1(maxstr), zt2(maxstr), zt3(maxstr)
  Common /frzout/xnprod(30), etprod(30), xnfrz(30), etfrz(30), dnprod(30), detpro(30), dnfrz(30), detfrz(30)
  Common /anim/nevent, isoft, isflag, izpc
  Double Precision pxsgs, pysgs, pzsgs, pesgs, pmsgs, gxsgs, gysgs, gzsgs, ftsgs
  Common /soft/pxsgs(maxstr, 3), pysgs(maxstr, 3), pzsgs(maxstr, 3), pesgs(maxstr, 3), pmsgs(maxstr, 3), gxsgs(maxstr, 3), gysgs(maxstr, 3), gzsgs(maxstr, 3), ftsgs(maxstr, 3), k1sgs(maxstr, 3), k2sgs(maxstr, 3), njsgs(maxstr)
  Common /noprec/nnozpc, itypn(maxidl), gxn(maxidl), gyn(maxidl), gzn(maxidl), ftn(maxidl), pxn(maxidl), pyn(maxidl), pzn(maxidl), een(maxidl), xmn(maxidl)
  Common /lastt/itimeh, bimp
  Common /arevt/iaevt, iarun, miss
  Common /phidcy/iphidcy, pttrig, ntrig, maxmiss, ipi0dcy
  Common /para7/ioscar, nsmbbbar, nsmmeson
  Common /phihj/iphirp, phirp
  Common /precpa/vxp0(maxptn), vyp0(maxptn), vzp0(maxptn), xstrg0(maxptn), ystrg0(maxptn), xstrg(maxptn), ystrg(maxptn), istrg0(maxptn), istrg(maxptn)
  Save
  bmax = min(bmax0, hipr1(34)+hipr1(35))
  bmin = min(bmin0, bmax)
  If (ihnt2(1)<=1 .And. ihnt2(3)<=1) Then
    bmin = 0.0
    bmax = 2.5*sqrt(hipr1(31)*0.1/hipr1(40))
  End If
  yp(1, 1) = 0.0
  yp(2, 1) = 0.0
  yp(3, 1) = 0.0
  If (ihnt2(1)<=1) Goto 14
  Do kp = 1, ihnt2(1)
    5 r = hirnd(1)
    x = ranart(nseed)
    cx = 2.0*x - 1.0
    sx = sqrt(1.0-cx*cx)
    phi = ranart(nseed)*2.0*hipr1(40)
    yp(1, kp) = r*sx*cos(phi)
    yp(2, kp) = r*sx*sin(phi)
    yp(3, kp) = r*cx
    If (hipr1(29)==0.0) Goto 10
    Do kp2 = 1, kp - 1
      dnbp1 = (yp(1,kp)-yp(1,kp2))**2
      dnbp2 = (yp(2,kp)-yp(2,kp2))**2
      dnbp3 = (yp(3,kp)-yp(3,kp2))**2
      dnbp = dnbp1 + dnbp2 + dnbp3
      If (dnbp<hipr1(29)*hipr1(29)) Goto 5
    End Do
  10 End Do
  If (ihnt2(1)==2) Then
    rnd1 = max(ranart(nseed), 1.0E-20)
    rnd2 = max(ranart(nseed), 1.0E-20)
    rnd3 = max(ranart(nseed), 1.0E-20)
    r = -(log(rnd1)*4.38/2.0+log(rnd2)*0.85/2.0+4.38*0.85*log(rnd3)/(4.38+0.85))
    x = ranart(nseed)
    cx = 2.0*x - 1.0
    sx = sqrt(1.0-cx*cx)
    phi = ranart(nseed)*2.0*hipr1(40)
    r = r/2.
    yp(1, 1) = r*sx*cos(phi)
    yp(2, 1) = r*sx*sin(phi)
    yp(3, 1) = r*cx
    yp(1, 2) = -yp(1, 1)
    yp(2, 2) = -yp(2, 1)
    yp(3, 2) = -yp(3, 1)
  End If
  Do i = 1, ihnt2(1) - 1
    Do j = i + 1, ihnt2(1)
      If (yp(3,i)>yp(3,j)) Goto 12
      y1 = yp(1, i)
      y2 = yp(2, i)
      y3 = yp(3, i)
      yp(1, i) = yp(1, j)
      yp(2, i) = yp(2, j)
      yp(3, i) = yp(3, j)
      yp(1, j) = y1
      yp(2, j) = y2
      yp(3, j) = y3
    12 End Do
  End Do
  14 yt(1, 1) = 0.0
  yt(2, 1) = 0.0
  yt(3, 1) = 0.0
  If (ihnt2(3)<=1) Goto 24
  Do kt = 1, ihnt2(3)
    15 r = hirnd(2)
    x = ranart(nseed)
    cx = 2.0*x - 1.0
    sx = sqrt(1.0-cx*cx)
    phi = ranart(nseed)*2.0*hipr1(40)
    yt(1, kt) = r*sx*cos(phi)
    yt(2, kt) = r*sx*sin(phi)
    yt(3, kt) = r*cx
    If (hipr1(29)==0.0) Goto 20
    Do kt2 = 1, kt - 1
      dnbt1 = (yt(1,kt)-yt(1,kt2))**2
      dnbt2 = (yt(2,kt)-yt(2,kt2))**2
      dnbt3 = (yt(3,kt)-yt(3,kt2))**2
      dnbt = dnbt1 + dnbt2 + dnbt3
      If (dnbt<hipr1(29)*hipr1(29)) Goto 15
    End Do
  20 End Do
  If (ihnt2(3)==2) Then
    rnd1 = max(ranart(nseed), 1.0E-20)
    rnd2 = max(ranart(nseed), 1.0E-20)
    rnd3 = max(ranart(nseed), 1.0E-20)
    r = -(log(rnd1)*4.38/2.0+log(rnd2)*0.85/2.0+4.38*0.85*log(rnd3)/(4.38+0.85))
    x = ranart(nseed)
    cx = 2.0*x - 1.0
    sx = sqrt(1.0-cx*cx)
    phi = ranart(nseed)*2.0*hipr1(40)
    r = r/2.
    yt(1, 1) = r*sx*cos(phi)
    yt(2, 1) = r*sx*sin(phi)
    yt(3, 1) = r*cx
    yt(1, 2) = -yt(1, 1)
    yt(2, 2) = -yt(2, 1)
    yt(3, 2) = -yt(3, 1)
  End If
  Do i = 1, ihnt2(3) - 1
    Do j = i + 1, ihnt2(3)
      If (yt(3,i)<yt(3,j)) Goto 22
      y1 = yt(1, i)
      y2 = yt(2, i)
      y3 = yt(3, i)
      yt(1, i) = yt(1, j)
      yt(2, i) = yt(2, j)
      yt(3, i) = yt(3, j)
      yt(1, j) = y1
      yt(2, j) = y2
      yt(3, j) = y3
    22 End Do
  End Do
  24 miss = -1
  50 miss = miss + 1
  If (miss>maxmiss) Then
    Write (6, *) 'infinite loop happened in  HIJING'
    Stop
  End If
  itest = 0
  natt = 0
  jatt = 0
  eatt = 0.0
  Call hijini
  nlop = 0
  60 nt = 0
  np = 0
  n0 = 0
  n01 = 0
  n10 = 0
  n11 = 0
  nelt = 0
  ninthj = 0
  nelp = 0
  ninp = 0
  nsg = 0
  ncolt = 0
  bb = sqrt(bmin**2+ranart(nseed)*(bmax**2-bmin**2))
  phi = 0.
  If (iphirp==1) phi = 2.0*hipr1(40)*ranart(nseed)
  phirp = phi
  bbx = bb*cos(phi)
  bby = bb*sin(phi)
  hint1(19) = bb
  hint1(20) = phi
  Do jp = 1, ihnt2(1)
    Do jt = 1, ihnt2(3)
      scip(jp, jt) = -1.0
      b2 = (yp(1,jp)+bbx-yt(1,jt))**2 + (yp(2,jp)+bby-yt(2,jt))**2
      r2 = b2*hipr1(40)/hipr1(31)/0.1
      rrb1 = min((yp(1,jp)**2+yp(2,jp)**2)/1.2**2/real(ihnt2(1))**0.6666667, 1.0)
      rrb2 = min((yt(1,jt)**2+yt(2,jt)**2)/1.2**2/real(ihnt2(3))**0.6666667, 1.0)
      aphx1 = hipr1(6)*4.0/3.0*(ihnt2(1)**0.3333333-1.0)*sqrt(1.0-rrb1)
      aphx2 = hipr1(6)*4.0/3.0*(ihnt2(3)**0.3333333-1.0)*sqrt(1.0-rrb2)
      hint1(18) = hint1(14) - aphx1*hint1(15) - aphx2*hint1(16) + aphx1*aphx2*hint1(17)
      If (ihpr2(14)==0 .Or. (ihnt2(1)==1 .And. ihnt2(3)==1)) Then
        gs = 1.0 - exp(-(hipr1(30)+hint1(18))*romg(r2)/hipr1(31))
        rantot = ranart(nseed)
        If (rantot>gs) Goto 70
        Goto 65
      End If
      gstot0 = 2.0*(1.0-exp(-(hipr1(30)+hint1(18))/hipr1(31)/2.0*romg(0.0)))
      r2 = r2/gstot0
      gs = 1.0 - exp(-(hipr1(30)+hint1(18))/hipr1(31)*romg(r2))
      gstot = 2.0*(1.0-sqrt(1.0-gs))
      rantot = ranart(nseed)*gstot0
      If (rantot>gstot) Goto 70
      If (rantot>gs) Then
        Call hijcsc(jp, jt)
        Goto 70
      End If
      65 scip(jp, jt) = r2
      rnip(jp, jt) = rantot
      sjip(jp, jt) = hint1(18)
      ncolt = ncolt + 1
      ipcol(ncolt) = jp
      itcol(ncolt) = jt
    70 End Do
  End Do
  bimp = bb
  Write (6, *) '#impact parameter,nlop,ncolt=', bimp, nlop, ncolt
  If (ncolt==0) Then
    nlop = nlop + 1
    If (nlop<=20 .Or. (ihnt2(1)==1 .And. ihnt2(3)==1)) Goto 60
    Return
  End If
  If (ihpr2(3)/=0) Then
    nhard = 1 + int(ranart(nseed)*(ncolt-1)+0.5)
    nhard = min(nhard, ncolt)
    jphard = ipcol(nhard)
    jthard = itcol(nhard)
  End If
  If (ihpr2(9)==1) Then
    nmini = 1 + int(ranart(nseed)*(ncolt-1)+0.5)
    nmini = min(nmini, ncolt)
    jpmini = ipcol(nmini)
    jtmini = itcol(nmini)
  End If
  Do jp = 1, ihnt2(1)
    Do jt = 1, ihnt2(3)
      If (scip(jp,jt)==-1.0) Goto 200
      nfp(jp, 11) = nfp(jp, 11) + 1
      nft(jt, 11) = nft(jt, 11) + 1
      If (nfp(jp,5)<=1 .And. nft(jt,5)>1) Then
        np = np + 1
        n01 = n01 + 1
      Else If (nfp(jp,5)>1 .And. nft(jt,5)<=1) Then
        nt = nt + 1
        n10 = n10 + 1
      Else If (nfp(jp,5)<=1 .And. nft(jt,5)<=1) Then
        np = np + 1
        nt = nt + 1
        n0 = n0 + 1
      Else If (nfp(jp,5)>1 .And. nft(jt,5)>1) Then
        n11 = n11 + 1
      End If
      jout = 0
      nfp(jp, 10) = 0
      nft(jt, 10) = 0
      If (ihpr2(8)==0 .And. ihpr2(3)==0) Goto 160
      If (nfp(jp,6)<0 .Or. nft(jt,6)<0) Goto 160
      r2 = scip(jp, jt)
      hint1(18) = sjip(jp, jt)
      tt = romg(r2)*hint1(18)/hipr1(31)
      tts = hipr1(30)*romg(r2)/hipr1(31)
      njet = 0
      If (ihpr2(3)/=0 .And. jp==jphard .And. jt==jthard) Then
        Call jetini(jp, jt, 1)
        Call hijhrd(jp, jt, 0, jflg, 0)
        hint1(26) = hint1(47)
        hint1(27) = hint1(48)
        hint1(28) = hint1(49)
        hint1(29) = hint1(50)
        hint1(36) = hint1(67)
        hint1(37) = hint1(68)
        hint1(38) = hint1(69)
        hint1(39) = hint1(70)
        If (abs(hint1(46))>hipr1(11) .And. jflg==2) nfp(jp, 7) = 1
        If (abs(hint1(56))>hipr1(11) .And. jflg==2) nft(jt, 7) = 1
        If (max(abs(hint1(46)),abs(hint1(56)))>hipr1(11) .And. jflg>=3) iasg(nsg, 3) = 1
        ihnt2(9) = ihnt2(14)
        ihnt2(10) = ihnt2(15)
        Do i05 = 1, 5
          hint1(20+i05) = hint1(40+i05)
          hint1(30+i05) = hint1(50+i05)
        End Do
        jout = 1
        If (ihpr2(8)==0) Goto 160
        rrb1 = min((yp(1,jp)**2+yp(2,jp)**2)/1.2**2/real(ihnt2(1))**0.6666667, 1.0)
        rrb2 = min((yt(1,jt)**2+yt(2,jt)**2)/1.2**2/real(ihnt2(3))**0.6666667, 1.0)
        aphx1 = hipr1(6)*4.0/3.0*(ihnt2(1)**0.3333333-1.0)*sqrt(1.0-rrb1)
        aphx2 = hipr1(6)*4.0/3.0*(ihnt2(3)**0.3333333-1.0)*sqrt(1.0-rrb2)
        hint1(65) = hint1(61) - aphx1*hint1(62) - aphx2*hint1(63) + aphx1*aphx2*hint1(64)
        ttrig = romg(r2)*hint1(65)/hipr1(31)
        njet = -1
        xr1 = -alog(exp(-ttrig)+ranart(nseed)*(1.0-exp(-ttrig)))
        106 njet = njet + 1
        xr1 = xr1 - alog(max(ranart(nseed),1.0E-20))
        If (xr1<ttrig) Goto 106
        xr = 0.0
        107 njet = njet + 1
        xr = xr - alog(max(ranart(nseed),1.0E-20))
        If (xr<tt-ttrig) Goto 107
        njet = njet - 1
        Goto 112
      End If
      If (ihpr2(9)==1 .And. jp==jpmini .And. jt==jtmini) Goto 110
      If (ihpr2(8)>0 .And. rnip(jp,jt)<=exp(-tt)*(1.0-exp(-tts))) Goto 160
      110 xr = -alog(exp(-tt)+ranart(nseed)*(1.0-exp(-tt)))
      111 njet = njet + 1
      xr = xr - alog(max(ranart(nseed),1.0E-20))
      If (xr<tt) Goto 111
      112 njet = min(njet, ihpr2(8))
      If (ihpr2(8)<0) njet = abs(ihpr2(8))
      Do ijet = 1, njet
        Call jetini(jp, jt, 0)
        Call hijhrd(jp, jt, jout, jflg, 1)
        If (jflg==0) Goto 160
        If (jflg<0) Then
          If (ihpr2(10)/=0) Write (6, *) 'error occured in HIJHRD'
          Goto 50
        End If
        jout = jout + 1
        If (abs(hint1(46))>hipr1(11) .And. jflg==2) nfp(jp, 7) = 1
        If (abs(hint1(56))>hipr1(11) .And. jflg==2) nft(jt, 7) = 1
        If (max(abs(hint1(46)),abs(hint1(56)))>hipr1(11) .And. jflg>=3) iasg(nsg, 3) = 1
      End Do
      160 Continue
      Call hijsft(jp, jt, jout, ierror)
      If (ierror/=0) Then
        If (ihpr2(10)/=0) Write (6, *) 'error occured in HIJSFT'
        Goto 50
      End If
      jatt = jatt + jout
    200 End Do
  End Do
  Call minijet_out(bb, phirp)
  If (pttrig>0 .And. ntrig==0) Goto 50
  Do jp = 1, ihnt2(1)
    If (nfp(jp,5)>2) Then
      ninp = ninp + 1
    Else If (nfp(jp,5)==2 .Or. nfp(jp,5)==1) Then
      nelp = nelp + 1
    End If
  End Do
  Do jt = 1, ihnt2(3)
    If (nft(jt,5)>2) Then
      ninthj = ninthj + 1
    Else If (nft(jt,5)==2 .Or. nft(jt,5)==1) Then
      nelt = nelt + 1
    End If
  End Do
  If ((ihpr2(8)/=0 .Or. ihpr2(3)/=0) .And. ihpr2(4)>0 .And. ihnt2(1)>1 .And. ihnt2(3)>1) Then
    Do i = 1, ihnt2(1)
      If (nfp(i,7)==1) Call quench(i, 1)
    End Do
    Do i = 1, ihnt2(3)
      If (nft(i,7)==1) Call quench(i, 2)
    End Do
    Do isg = 1, nsg
      If (iasg(isg,3)==1) Call quench(isg, 3)
    End Do
  End If
  If (isoft==1) Then
    isflag = 1
    nsp = ihnt2(1)
    nst = ihnt2(3)
    nsi = nsg
    istr = 0
    npar = 0
    Do i = 1, ihnt2(1)
      istr = istr + 1
      Do j = 1, npj(i)
        If (kfpj(i,j)==21) Then
          npar = npar + 1
          lstrg0(npar) = istr
          lpart0(npar) = j
          ityp0(npar) = kfpj(i, j)
          gx0(npar) = dble(yp(1,i)+0.5*bb*cos(phirp))
          gy0(npar) = dble(yp(2,i)+0.5*bb*sin(phirp))
          gz0(npar) = 0D0
          ft0(npar) = 0D0
          px0(npar) = dble(pjpx(i,j))
          py0(npar) = dble(pjpy(i,j))
          pz0(npar) = dble(pjpz(i,j))
          xmass0(npar) = dble(pjpm(i,j))
          e0(npar) = dsqrt(px0(npar)**2+py0(npar)**2+pz0(npar)**2+xmass0(npar)**2)
        End If
      End Do
    End Do
    Do i = 1, ihnt2(3)
      istr = istr + 1
      Do j = 1, ntj(i)
        If (kftj(i,j)==21) Then
          npar = npar + 1
          lstrg0(npar) = istr
          lpart0(npar) = j
          ityp0(npar) = kftj(i, j)
          gx0(npar) = dble(yt(1,i)-0.5*bb*cos(phirp))
          gy0(npar) = dble(yt(2,i)-0.5*bb*sin(phirp))
          gz0(npar) = 0D0
          ft0(npar) = 0D0
          px0(npar) = dble(pjtx(i,j))
          py0(npar) = dble(pjty(i,j))
          pz0(npar) = dble(pjtz(i,j))
          xmass0(npar) = dble(pjtm(i,j))
          e0(npar) = dsqrt(px0(npar)**2+py0(npar)**2+pz0(npar)**2+xmass0(npar)**2)
        End If
      End Do
    End Do
    Do i = 1, nsg
      istr = istr + 1
      Do j = 1, njsg(i)
        If (k2sg(i,j)==21) Then
          npar = npar + 1
          lstrg0(npar) = istr
          lpart0(npar) = j
          ityp0(npar) = k2sg(i, j)
          gx0(npar) = 0.5D0*dble(yp(1,iasg(i,1))+yt(1,iasg(i,2)))
          gy0(npar) = 0.5D0*dble(yp(2,iasg(i,1))+yt(2,iasg(i,2)))
          gz0(npar) = 0D0
          ft0(npar) = 0D0
          px0(npar) = dble(pxsg(i,j))
          py0(npar) = dble(pysg(i,j))
          pz0(npar) = dble(pzsg(i,j))
          xmass0(npar) = dble(pmsg(i,j))
          e0(npar) = dsqrt(px0(npar)**2+py0(npar)**2+pz0(npar)**2+xmass0(npar)**2)
        End If
      End Do
    End Do
    mul = npar
    Call hjana1
    If (ioscar==3) Write (95, *) iaevt, mul
    Call zpcmn
    Write (14, 395) iaevt, miss, mul, bimp, nelp, ninp, nelt, ninthj
    Do i = 1, mul
      If (dmax1(abs(gx5(i)),abs(gy5(i)),abs(gz5(i)),abs(ft5(i)))<9999) Then
        Write (14, 210) ityp5(i), px5(i), py5(i), pz5(i), xmass5(i), gx5(i), gy5(i), gz5(i), ft5(i)
      Else
        Write (14, 211) ityp5(i), px5(i), py5(i), pz5(i), xmass5(i), gx5(i), gy5(i), gz5(i), ft5(i)
      End If
    End Do
    itest = itest + 1
    Do i = 1, mul
      If (lstrg1(i)<=nsp) Then
        nstrg = lstrg1(i)
        npart = lpart1(i)
        kfpj(nstrg, npart) = ityp5(i)
        pjpx(nstrg, npart) = sngl(px5(i))
        pjpy(nstrg, npart) = sngl(py5(i))
        pjpz(nstrg, npart) = sngl(pz5(i))
        pjpe(nstrg, npart) = sngl(e5(i))
        pjpm(nstrg, npart) = sngl(xmass5(i))
      Else If (lstrg1(i)<=nsp+nst) Then
        nstrg = lstrg1(i) - nsp
        npart = lpart1(i)
        kftj(nstrg, npart) = ityp5(i)
        pjtx(nstrg, npart) = sngl(px5(i))
        pjty(nstrg, npart) = sngl(py5(i))
        pjtz(nstrg, npart) = sngl(pz5(i))
        pjte(nstrg, npart) = sngl(e5(i))
        pjtm(nstrg, npart) = sngl(xmass5(i))
      Else
        nstrg = lstrg1(i) - nsp - nst
        npart = lpart1(i)
        k2sg(nstrg, npart) = ityp5(i)
        pxsg(nstrg, npart) = sngl(px5(i))
        pysg(nstrg, npart) = sngl(py5(i))
        pzsg(nstrg, npart) = sngl(pz5(i))
        pesg(nstrg, npart) = sngl(e5(i))
        pmsg(nstrg, npart) = sngl(xmass5(i))
      End If
    End Do
    Call hjana2
  Else If (isoft==2) Then
    nsp = ihnt2(1)
    nst = ihnt2(3)
    nsi = nsg
    npar = 0
    istr = 0
    mstj(1) = 0
    ihpr2(1) = 0
    isflag = 0
    If (ihpr2(20)/=0) Then
      Do ntp = 1, 2
        Do jjtp = 1, ihnt2(2*ntp-1)
          istr = istr + 1
          Call hijfrg(jjtp, ntp, ierror)
          If (ntp==1) Then
            npj(jjtp) = max0(n-2, 0)
          Else
            ntj(jjtp) = max0(n-2, 0)
          End If
          Do ii = 1, n
            npar = npar + 1
            lstrg0(npar) = istr
            lpart0(npar) = ii
            ityp0(npar) = k(ii, 2)
            gz0(npar) = 0D0
            ft0(npar) = 0D0
            px0(npar) = dble(p(ii,1))
            py0(npar) = dble(p(ii,2))
            pz0(npar) = dble(p(ii,3))
            xmass0(npar) = dble(p(ii,5))
            e0(npar) = dsqrt(px0(npar)**2+py0(npar)**2+pz0(npar)**2+xmass0(npar)**2)
            If (ntp==1) Then
              gx0(npar) = dble(yp(1,jjtp)+0.5*bb*cos(phirp))
              gy0(npar) = dble(yp(2,jjtp)+0.5*bb*sin(phirp))
              iityp = ityp0(npar)
              nstrg = lstrg0(npar)
              If (iityp==2112 .Or. iityp==2212) Then
              Else If ((iityp==1 .Or. iityp==2) .And. (ii==1 .Or. ii==n)) Then
                pp(nstrg, 6) = sngl(px0(npar))
                pp(nstrg, 7) = sngl(py0(npar))
                pp(nstrg, 14) = sngl(xmass0(npar))
              Else If ((iityp==1103 .Or. iityp==2101 .Or. iityp==2103 .Or. iityp==2203. .Or. iityp==3101 .Or. iityp==3103. .Or. iityp==3201 .Or. iityp==3203 .Or. iityp==3303) .And. (ii==1 .Or. ii==n)) Then
                pp(nstrg, 8) = sngl(px0(npar))
                pp(nstrg, 9) = sngl(py0(npar))
                pp(nstrg, 15) = sngl(xmass0(npar))
              Else
                npart = lpart0(npar) - 1
                kfpj(nstrg, npart) = ityp0(npar)
                pjpx(nstrg, npart) = sngl(px0(npar))
                pjpy(nstrg, npart) = sngl(py0(npar))
                pjpz(nstrg, npart) = sngl(pz0(npar))
                pjpe(nstrg, npart) = sngl(e0(npar))
                pjpm(nstrg, npart) = sngl(xmass0(npar))
              End If
            Else
              gx0(npar) = dble(yt(1,jjtp)-0.5*bb*cos(phirp))
              gy0(npar) = dble(yt(2,jjtp)-0.5*bb*sin(phirp))
              iityp = ityp0(npar)
              nstrg = lstrg0(npar) - nsp
              If (iityp==2112 .Or. iityp==2212) Then
              Else If ((iityp==1 .Or. iityp==2) .And. (ii==1 .Or. ii==n)) Then
                pt(nstrg, 6) = sngl(px0(npar))
                pt(nstrg, 7) = sngl(py0(npar))
                pt(nstrg, 14) = sngl(xmass0(npar))
              Else If ((iityp==1103 .Or. iityp==2101 .Or. iityp==2103 .Or. iityp==2203. .Or. iityp==3101 .Or. iityp==3103. .Or. iityp==3201 .Or. iityp==3203 .Or. iityp==3303) .And. (ii==1 .Or. ii==n)) Then
                pt(nstrg, 8) = sngl(px0(npar))
                pt(nstrg, 9) = sngl(py0(npar))
                pt(nstrg, 15) = sngl(xmass0(npar))
              Else
                npart = lpart0(npar) - 1
                kftj(nstrg, npart) = ityp0(npar)
                pjtx(nstrg, npart) = sngl(px0(npar))
                pjty(nstrg, npart) = sngl(py0(npar))
                pjtz(nstrg, npart) = sngl(pz0(npar))
                pjte(nstrg, npart) = sngl(e0(npar))
                pjtm(nstrg, npart) = sngl(xmass0(npar))
              End If
            End If
          End Do
        End Do
      End Do
      Do isg = 1, nsg
        istr = istr + 1
        Call hijfrg(isg, 3, ierror)
        njsg(isg) = n
        Do ii = 1, n
          npar = npar + 1
          lstrg0(npar) = istr
          lpart0(npar) = ii
          ityp0(npar) = k(ii, 2)
          gx0(npar) = 0.5D0*dble(yp(1,iasg(isg,1))+yt(1,iasg(isg,2)))
          gy0(npar) = 0.5D0*dble(yp(2,iasg(isg,1))+yt(2,iasg(isg,2)))
          gz0(npar) = 0D0
          ft0(npar) = 0D0
          px0(npar) = dble(p(ii,1))
          py0(npar) = dble(p(ii,2))
          pz0(npar) = dble(p(ii,3))
          xmass0(npar) = dble(p(ii,5))
          e0(npar) = dsqrt(px0(npar)**2+py0(npar)**2+pz0(npar)**2+xmass0(npar)**2)
        End Do
      End Do
    End If
    mul = npar
    Call hjana1
    If (ioscar==3) Write (95, *) iaevt, mul
    Call zpcmn
    Write (14, 395) iaevt, miss, mul, bimp, nelp, ninp, nelt, ninthj
    itest = itest + 1
    Do i = 1, mul
      If (dmax1(abs(gx5(i)),abs(gy5(i)),abs(gz5(i)),abs(ft5(i)))<9999) Then
        Write (14, 210) ityp5(i), px5(i), py5(i), pz5(i), xmass5(i), gx5(i), gy5(i), gz5(i), ft5(i)
      Else
        Write (14, 211) ityp5(i), px5(i), py5(i), pz5(i), xmass5(i), gx5(i), gy5(i), gz5(i), ft5(i)
      End If
    End Do
    Do nmom = 1, 5
      Do nstrg = 1, nsp
        pp(nstrg, nmom) = 0.
      End Do
      Do nstrg = 1, nst
        pt(nstrg, nmom) = 0.
      End Do
    End Do
    Do i = 1, mul
      iityp = ityp5(i)
      If (lstrg1(i)<=nsp) Then
        nstrg = lstrg1(i)
        If (iityp==2112 .Or. iityp==2212) Then
          pp(nstrg, 1) = sngl(px5(i))
          pp(nstrg, 2) = sngl(py5(i))
          pp(nstrg, 3) = sngl(pz5(i))
          pp(nstrg, 4) = sngl(e5(i))
          pp(nstrg, 5) = sngl(xmass5(i))
        Else If ((iityp==1 .Or. iityp==2) .And. (lpart1(i)==1 .Or. lpart1(i)==(npj(nstrg)+2))) Then
          pp(nstrg, 6) = sngl(px5(i))
          pp(nstrg, 7) = sngl(py5(i))
          pp(nstrg, 14) = sngl(xmass5(i))
          pp(nstrg, 1) = pp(nstrg, 1) + sngl(px5(i))
          pp(nstrg, 2) = pp(nstrg, 2) + sngl(py5(i))
          pp(nstrg, 3) = pp(nstrg, 3) + sngl(pz5(i))
          pp(nstrg, 4) = pp(nstrg, 4) + sngl(e5(i))
          pp(nstrg, 5) = sqrt(pp(nstrg,4)**2-pp(nstrg,1)**2-pp(nstrg,2)**2-pp(nstrg,3)**2)
        Else If ((iityp==1103 .Or. iityp==2101 .Or. iityp==2103 .Or. iityp==2203. .Or. iityp==3101 .Or. iityp==3103. .Or. iityp==3201 .Or. iityp==3203 .Or. iityp==3303) .And. (lpart1(i)==1 .Or. lpart1(i)==(npj(nstrg)+2))) Then
          pp(nstrg, 8) = sngl(px5(i))
          pp(nstrg, 9) = sngl(py5(i))
          pp(nstrg, 15) = sngl(xmass5(i))
          pp(nstrg, 1) = pp(nstrg, 1) + sngl(px5(i))
          pp(nstrg, 2) = pp(nstrg, 2) + sngl(py5(i))
          pp(nstrg, 3) = pp(nstrg, 3) + sngl(pz5(i))
          pp(nstrg, 4) = pp(nstrg, 4) + sngl(e5(i))
          pp(nstrg, 5) = sqrt(pp(nstrg,4)**2-pp(nstrg,1)**2-pp(nstrg,2)**2-pp(nstrg,3)**2)
        Else
          npart = lpart1(i) - 1
          kfpj(nstrg, npart) = ityp5(i)
          pjpx(nstrg, npart) = sngl(px5(i))
          pjpy(nstrg, npart) = sngl(py5(i))
          pjpz(nstrg, npart) = sngl(pz5(i))
          pjpe(nstrg, npart) = sngl(e5(i))
          pjpm(nstrg, npart) = sngl(xmass5(i))
        End If
      Else If (lstrg1(i)<=nsp+nst) Then
        nstrg = lstrg1(i) - nsp
        If (iityp==2112 .Or. iityp==2212) Then
          pt(nstrg, 1) = sngl(px5(i))
          pt(nstrg, 2) = sngl(py5(i))
          pt(nstrg, 3) = sngl(pz5(i))
          pt(nstrg, 4) = sngl(e5(i))
          pt(nstrg, 5) = sngl(xmass5(i))
        Else If ((iityp==1 .Or. iityp==2) .And. (lpart1(i)==1 .Or. lpart1(i)==(ntj(nstrg)+2))) Then
          pt(nstrg, 6) = sngl(px5(i))
          pt(nstrg, 7) = sngl(py5(i))
          pt(nstrg, 14) = sngl(xmass5(i))
          pt(nstrg, 1) = pt(nstrg, 1) + sngl(px5(i))
          pt(nstrg, 2) = pt(nstrg, 2) + sngl(py5(i))
          pt(nstrg, 3) = pt(nstrg, 3) + sngl(pz5(i))
          pt(nstrg, 4) = pt(nstrg, 4) + sngl(e5(i))
          pt(nstrg, 5) = sqrt(pt(nstrg,4)**2-pt(nstrg,1)**2-pt(nstrg,2)**2-pt(nstrg,3)**2)
        Else If ((iityp==1103 .Or. iityp==2101 .Or. iityp==2103 .Or. iityp==2203. .Or. iityp==3101 .Or. iityp==3103. .Or. iityp==3201 .Or. iityp==3203 .Or. iityp==3303) .And. (lpart1(i)==1 .Or. lpart1(i)==(ntj(nstrg)+2))) Then
          pt(nstrg, 8) = sngl(px5(i))
          pt(nstrg, 9) = sngl(py5(i))
          pt(nstrg, 15) = sngl(xmass5(i))
          pt(nstrg, 1) = pt(nstrg, 1) + sngl(px5(i))
          pt(nstrg, 2) = pt(nstrg, 2) + sngl(py5(i))
          pt(nstrg, 3) = pt(nstrg, 3) + sngl(pz5(i))
          pt(nstrg, 4) = pt(nstrg, 4) + sngl(e5(i))
          pt(nstrg, 5) = sqrt(pt(nstrg,4)**2-pt(nstrg,1)**2-pt(nstrg,2)**2-pt(nstrg,3)**2)
        Else
          npart = lpart1(i) - 1
          kftj(nstrg, npart) = ityp5(i)
          pjtx(nstrg, npart) = sngl(px5(i))
          pjty(nstrg, npart) = sngl(py5(i))
          pjtz(nstrg, npart) = sngl(pz5(i))
          pjte(nstrg, npart) = sngl(e5(i))
          pjtm(nstrg, npart) = sngl(xmass5(i))
        End If
      Else
        nstrg = lstrg1(i) - nsp - nst
        npart = lpart1(i)
        k2sg(nstrg, npart) = ityp5(i)
        pxsg(nstrg, npart) = sngl(px5(i))
        pysg(nstrg, npart) = sngl(py5(i))
        pzsg(nstrg, npart) = sngl(pz5(i))
        pesg(nstrg, npart) = sngl(e5(i))
        pmsg(nstrg, npart) = sngl(xmass5(i))
      End If
    End Do
    mstj(1) = 1
    ihpr2(1) = 1
    isflag = 1
    hipr1(1) = 0.94
    Call hjana2
  Else If (isoft==3 .Or. isoft==4 .Or. isoft==5) Then
    isflag = 0
    If (ihpr2(20)/=0) Then
      Do isg = 1, nsg
        Call hijfrg(isg, 3, ierror)
        nsbst = 1
        idstr = 92
        If (ihpr2(21)==0) Then
          Call luedit(2)
        Else
          551 nsbst = nsbst + 1
          If (k(nsbst,2)<91 .Or. k(nsbst,2)>93) Goto 551
          idstr = k(nsbst, 2)
          nsbst = nsbst + 1
        End If
        If (frame=='LAB') Then
          Call hboost
        End If
        nsbstr = 0
        Do i = nsbst, n
          If (k(i,2)==idstr) Then
            nsbstr = nsbstr + 1
            Goto 560
          End If
          k(i, 4) = nsbstr
          natt = natt + 1
          katt(natt, 1) = k(i, 2)
          katt(natt, 2) = 20
          katt(natt, 4) = k(i, 1)
          If (k(i,3)==0) Then
            katt(natt, 3) = 0
          Else If (k(i,3)/=0 .And. k(k(i,3),2)==idstr) Then
            katt(natt, 3) = 0
          Else
            katt(natt, 3) = natt - i + k(i, 3) + nsbstr - k(k(i,3), 4)
          End If
          patt(natt, 1) = p(i, 1)
          patt(natt, 2) = p(i, 2)
          patt(natt, 3) = p(i, 3)
          patt(natt, 4) = p(i, 4)
          eatt = eatt + p(i, 4)
          gxar(natt) = 0.5*(yp(1,iasg(isg,1))+yt(1,iasg(isg,2)))
          gyar(natt) = 0.5*(yp(2,iasg(isg,1))+yt(2,iasg(isg,2)))
          gzar(natt) = 0.
          ftar(natt) = 0.
          itypar(natt) = k(i, 2)
          pxar(natt) = p(i, 1)
          pyar(natt) = p(i, 2)
          pzar(natt) = p(i, 3)
          pear(natt) = p(i, 4)
          xmar(natt) = p(i, 5)
          xstrg0(natt) = dble(gxar(natt))
          ystrg0(natt) = dble(gyar(natt))
          istrg0(natt) = isg
        560 End Do
      End Do
      jtp(1) = ihnt2(1)
      jtp(2) = ihnt2(3)
      Do ntp = 1, 2
        Do jjtp = 1, jtp(ntp)
          Call hijfrg(jjtp, ntp, ierror)
          nsbst = 1
          idstr = 92
          If (ihpr2(21)==0) Then
            Call luedit(2)
          Else
            581 nsbst = nsbst + 1
            If (k(nsbst,2)<91 .Or. k(nsbst,2)>93) Goto 581
            idstr = k(nsbst, 2)
            nsbst = nsbst + 1
          End If
          If (frame=='LAB') Then
            Call hboost
          End If
          nftp = nfp(jjtp, 5)
          If (ntp==2) nftp = 10 + nft(jjtp, 5)
          nsbstr = 0
          Do i = nsbst, n
            If (k(i,2)==idstr) Then
              nsbstr = nsbstr + 1
              Goto 590
            End If
            k(i, 4) = nsbstr
            natt = natt + 1
            katt(natt, 1) = k(i, 2)
            katt(natt, 2) = nftp
            katt(natt, 4) = k(i, 1)
            If (k(i,3)==0) Then
              katt(natt, 3) = 0
            Else If (k(i,3)/=0 .And. k(k(i,3),2)==idstr) Then
              katt(natt, 3) = 0
            Else
              katt(natt, 3) = natt - i + k(i, 3) + nsbstr - k(k(i,3), 4)
            End If
            patt(natt, 1) = p(i, 1)
            patt(natt, 2) = p(i, 2)
            patt(natt, 3) = p(i, 3)
            patt(natt, 4) = p(i, 4)
            eatt = eatt + p(i, 4)
            If (ntp==1) Then
              gxar(natt) = yp(1, jjtp) + 0.5*bb*cos(phirp)
              gyar(natt) = yp(2, jjtp) + 0.5*bb*sin(phirp)
            Else
              gxar(natt) = yt(1, jjtp) - 0.5*bb*cos(phirp)
              gyar(natt) = yt(2, jjtp) - 0.5*bb*sin(phirp)
            End If
            gzar(natt) = 0.
            ftar(natt) = 0.
            itypar(natt) = k(i, 2)
            pxar(natt) = p(i, 1)
            pyar(natt) = p(i, 2)
            pzar(natt) = p(i, 3)
            pear(natt) = p(i, 4)
            xmar(natt) = p(i, 5)
            xstrg0(natt) = dble(gxar(natt))
            ystrg0(natt) = dble(gyar(natt))
            istrg0(natt) = ntp*10000 + jjtp
          590 End Do
        End Do
      End Do
    End If
    If (ndr>=1) Then
      Do i = 1, ndr
        natt = natt + 1
        katt(natt, 1) = kfdr(i)
        katt(natt, 2) = 40
        katt(natt, 3) = 0
        patt(natt, 1) = pdr(i, 1)
        patt(natt, 2) = pdr(i, 2)
        patt(natt, 3) = pdr(i, 3)
        patt(natt, 4) = pdr(i, 4)
        eatt = eatt + pdr(i, 4)
        gxar(natt) = rtdr(i, 1)
        gyar(natt) = rtdr(i, 2)
        gzar(natt) = 0.
        ftar(natt) = 0.
        itypar(natt) = katt(natt, 1)
        pxar(natt) = patt(natt, 1)
        pyar(natt) = patt(natt, 2)
        pzar(natt) = patt(natt, 3)
        pear(natt) = patt(natt, 4)
        xmar(natt) = pdr(i, 5)
      End Do
    End If
    Call embedhighpt
    Call hjana1
    Call htop
    nsp = 0
    nst = 0
    nsg = natt
    nsi = nsg
    If (ioscar==3) Write (95, *) iaevt, mul
    Call zpcmn
    Write (14, 395) iaevt, miss, mul, bimp, nelp, ninp, nelt, ninthj
    itest = itest + 1
    Do i = 1, mul
      If (dmax1(abs(gx5(i)),abs(gy5(i)),abs(gz5(i)),abs(ft5(i)))<9999) Then
        Write (14, 210) ityp5(i), px5(i), py5(i), pz5(i), xmass5(i), gx5(i), gy5(i), gz5(i), ft5(i)
      Else
        Write (14, 211) ityp5(i), px5(i), py5(i), pz5(i), xmass5(i), gx5(i), gy5(i), gz5(i), ft5(i)
      End If
    End Do
    Do i = 1, maxstr
      Do j = 1, 3
        k1sgs(i, j) = 0
        k2sgs(i, j) = 0
        pxsgs(i, j) = 0D0
        pysgs(i, j) = 0D0
        pzsgs(i, j) = 0D0
        pesgs(i, j) = 0D0
        pmsgs(i, j) = 0D0
        gxsgs(i, j) = 0D0
        gysgs(i, j) = 0D0
        gzsgs(i, j) = 0D0
        ftsgs(i, j) = 0D0
      End Do
    End Do
    Do i = 1, mul
      iityp = ityp5(i)
      nstrg = lstrg1(i)
      npart = lpart1(i)
      k2sgs(nstrg, npart) = ityp5(i)
      pxsgs(nstrg, npart) = px5(i)
      pysgs(nstrg, npart) = py5(i)
      pzsgs(nstrg, npart) = pz5(i)
      pmsgs(nstrg, npart) = xmass5(i)
      e5(i) = dsqrt(px5(i)**2+py5(i)**2+pz5(i)**2+xmass5(i)**2)
      pesgs(nstrg, npart) = e5(i)
      gxsgs(nstrg, npart) = gx5(i)
      gysgs(nstrg, npart) = gy5(i)
      gzsgs(nstrg, npart) = gz5(i)
      ftsgs(nstrg, npart) = ft5(i)
    End Do
    Call hjana2
  End If
  If (isoft==3 .Or. isoft==4 .Or. isoft==5) Then
    natt = 0
    eatt = 0.
    Call ptoh
    Do i = 1, nnozpc
      natt = natt + 1
      katt(natt, 1) = itypn(i)
      patt(natt, 1) = pxn(i)
      patt(natt, 2) = pyn(i)
      patt(natt, 3) = pzn(i)
      patt(natt, 4) = een(i)
      eatt = eatt + een(i)
      gxar(natt) = gxn(i)
      gyar(natt) = gyn(i)
      gzar(natt) = gzn(i)
      ftar(natt) = ftn(i)
      itypar(natt) = itypn(i)
      pxar(natt) = pxn(i)
      pyar(natt) = pyn(i)
      pzar(natt) = pzn(i)
      pear(natt) = een(i)
      xmar(natt) = xmn(i)
    End Do
    Goto 565
  End If
  If (ihpr2(20)/=0) Then
    Do isg = 1, nsg
      Call hijfrg(isg, 3, ierror)
      If (mstu(24)/=0 .Or. ierror>0) Then
        mstu(24) = 0
        mstu(28) = 0
        If (ihpr2(10)/=0) Then
          Write (6, *) 'error occured ISG, repeat the event'
          Write (6, *) isg
        End If
        Goto 50
      End If
      nsbst = 1
      idstr = 92
      If (ihpr2(21)==0) Then
        Call luedit(2)
      Else
        351 nsbst = nsbst + 1
        If (k(nsbst,2)<91 .Or. k(nsbst,2)>93) Goto 351
        idstr = k(nsbst, 2)
        nsbst = nsbst + 1
      End If
      If (frame=='LAB') Then
        Call hboost
      End If
      nsbstr = 0
      Do i = nsbst, n
        If (k(i,2)==idstr) Then
          nsbstr = nsbstr + 1
          Goto 360
        End If
        k(i, 4) = nsbstr
        natt = natt + 1
        katt(natt, 1) = k(i, 2)
        katt(natt, 2) = 20
        katt(natt, 4) = k(i, 1)
        If (k(i,3)==0) Then
          katt(natt, 3) = 0
        Else If (k(i,3)/=0 .And. k(k(i,3),2)==idstr) Then
          katt(natt, 3) = 0
        Else
          katt(natt, 3) = natt - i + k(i, 3) + nsbstr - k(k(i,3), 4)
        End If
        patt(natt, 1) = p(i, 1)
        patt(natt, 2) = p(i, 2)
        patt(natt, 3) = p(i, 3)
        patt(natt, 4) = p(i, 4)
        eatt = eatt + p(i, 4)
        lsg = nsp + nst + isg
        gxar(natt) = sngl(zt1(lsg))
        gyar(natt) = sngl(zt2(lsg))
        gzar(natt) = sngl(zt3(lsg))
        ftar(natt) = sngl(ataui(lsg))
        itypar(natt) = k(i, 2)
        pxar(natt) = p(i, 1)
        pyar(natt) = p(i, 2)
        pzar(natt) = p(i, 3)
        pear(natt) = p(i, 4)
        xmar(natt) = p(i, 5)
      360 End Do
    End Do
    jtp(1) = ihnt2(1)
    jtp(2) = ihnt2(3)
    Do ntp = 1, 2
      Do jjtp = 1, jtp(ntp)
        Call hijfrg(jjtp, ntp, ierror)
        If (mstu(24)/=0 .Or. ierror>0) Then
          mstu(24) = 0
          mstu(28) = 0
          If (ihpr2(10)/=0) Then
            Write (6, *) 'error occured P&T, repeat the event'
            Write (6, *) ntp, jjtp
          End If
          Goto 50
        End If
        nsbst = 1
        idstr = 92
        If (ihpr2(21)==0) Then
          Call luedit(2)
        Else
          381 nsbst = nsbst + 1
          If (k(nsbst,2)<91 .Or. k(nsbst,2)>93) Goto 381
          idstr = k(nsbst, 2)
          nsbst = nsbst + 1
        End If
        If (frame=='LAB') Then
          Call hboost
        End If
        nftp = nfp(jjtp, 5)
        If (ntp==2) nftp = 10 + nft(jjtp, 5)
        nsbstr = 0
        Do i = nsbst, n
          If (k(i,2)==idstr) Then
            nsbstr = nsbstr + 1
            Goto 390
          End If
          k(i, 4) = nsbstr
          natt = natt + 1
          katt(natt, 1) = k(i, 2)
          katt(natt, 2) = nftp
          katt(natt, 4) = k(i, 1)
          If (k(i,3)==0) Then
            katt(natt, 3) = 0
          Else If (k(i,3)/=0 .And. k(k(i,3),2)==idstr) Then
            katt(natt, 3) = 0
          Else
            katt(natt, 3) = natt - i + k(i, 3) + nsbstr - k(k(i,3), 4)
          End If
          patt(natt, 1) = p(i, 1)
          patt(natt, 2) = p(i, 2)
          patt(natt, 3) = p(i, 3)
          patt(natt, 4) = p(i, 4)
          eatt = eatt + p(i, 4)
          If (ntp==1) Then
            lsg = jjtp
          Else
            lsg = jjtp + nsp
          End If
          gxar(natt) = sngl(zt1(lsg))
          gyar(natt) = sngl(zt2(lsg))
          gzar(natt) = sngl(zt3(lsg))
          ftar(natt) = sngl(ataui(lsg))
          itypar(natt) = k(i, 2)
          pxar(natt) = p(i, 1)
          pyar(natt) = p(i, 2)
          pzar(natt) = p(i, 3)
          pear(natt) = p(i, 4)
          xmar(natt) = p(i, 5)
        390 End Do
      End Do
    End Do
  End If
  Do i = 1, ndr
    natt = natt + 1
    katt(natt, 1) = kfdr(i)
    katt(natt, 2) = 40
    katt(natt, 3) = 0
    patt(natt, 1) = pdr(i, 1)
    patt(natt, 2) = pdr(i, 2)
    patt(natt, 3) = pdr(i, 3)
    patt(natt, 4) = pdr(i, 4)
    eatt = eatt + pdr(i, 4)
    gxar(natt) = rtdr(i, 1)
    gyar(natt) = rtdr(i, 2)
    gzar(natt) = 0.
    ftar(natt) = 0.
    itypar(natt) = katt(natt, 1)
    pxar(natt) = patt(natt, 1)
    pyar(natt) = patt(natt, 2)
    pzar(natt) = patt(natt, 3)
    pear(natt) = patt(natt, 4)
    xmar(natt) = pdr(i, 5)
  End Do
  565 Continue
  dengy = eatt/(ihnt2(1)*hint1(6)+ihnt2(3)*hint1(7)) - 1.0
  If (abs(dengy)>hipr1(43) .And. ihpr2(20)/=0 .And. ihpr2(21)==0) Then
    If (ihpr2(10)/=0) Write (6, *) 'Energy not conserved, repeat the event'
    Write (6, *) 'violated:EATT(GeV),NATT,B(fm)=', eatt, natt, bimp
    Goto 50
  End If
  Write (6, *) 'satisfied:EATT(GeV),NATT,B(fm)=', eatt, natt, bimp
  Write (6, *) ' '
  Write (94, *) iaevt, miss, ihnt2(1), ihnt2(3), bimp
  Do jp = 1, ihnt2(1)
    Write (94, 243) yp(1, jp) + 0.5*bb*cos(phirp), yp(2, jp) + 0.5*bb*sin(phirp), jp, nfp(jp, 5), yp(3, jp), nfp(jp, 3), nfp(jp, 4)
  End Do
  Do jt = 1, ihnt2(3)
    Write (94, 243) yt(1, jt) - 0.5*bb*cos(phirp), yt(2, jt) - 0.5*bb*sin(phirp), -jt, nft(jt, 5), yt(3, jt), nft(jt, 3), nft(jt, 4)
  End Do
  Return
  210 Format (I6, 2(1X,F8.3), 1X, F10.3, 1X, F6.3, 4(1X,F8.2))
  211 Format (I6, 2(1X,F8.3), 1X, F10.3, 1X, F6.3, 4(1X,E8.2))
  395 Format (3I8, F10.4, 4I5)
  243 Format (F10.3, 1X, F10.3, 2(1X,I5), 1X, F10.3, 2(1X,I5))
End Subroutine hijing