!
!***********************************************************************
!                                                                      *
      PROGRAM rlevelsj
!                                                                      *
!     Purpose:                                                         *
!     Extract energy levels from rscf/rci output files (.m, .cm file)  *
!     and from jj2lsj output file (*.lsj.lbl).                         *
!     And then:                                                        *
!         (1) sort                                                     *
!         (2) difference with the lowest                               *
!         (3) difference with the nearby lower                         *
!     Files names are provided by user.                                *
!     Usage:                                                           *
!           $ grlevels file1 file2 file3 ...                           *
!           or                                                         *
!           $ grlevels                                                 *
!           file1                                                      *
!           file2                                                      *
!           file3                                                      *
!           ... (return to terminate)                                  *
!                                                                      *
!     Calls: LDLBL, indexS.                                            *
!                                                                      *
!     Xinghong He  98-10-16                                            *
!                                                                      *
!     Rewritten by  G. Gaigalas                                        *
!     for LSJ calssification of levels                                 *
!     NIST                                                 May 2011    *
!                                                                      *
!***********************************************************************
      IMPLICIT NONE
      INTEGER, PARAMETER:: JMax = 22      ! max J value, see JFraction !
      INTEGER, PARAMETER:: ndim = 20000   ! max number of states
      INTEGER, PARAMETER:: maxFile = 1000 ! max number of files
      DOUBLE PRECISION, PARAMETER:: Rydberg = 109737.31568508d0
      DOUBLE PRECISION, PARAMETER:: eV = 27.211386018D0
!
      CHARACTER(LEN=80) strInFile(maxFile), strFile
      CHARACTER*1 iaspa(ndim), PlusMinus(-1:1)        ! Parity
      CHARACTER*1 Lev_par(ndim)                       ! Parity
      CHARACTER*4 iatjp(ndim), JFraction(1:2*Jmax+1)  ! J
      CHARACTER*4 Lev_J(ndim)                         ! J
      CHARACTER g92mix*6
      CHARACTER*64 string_CSF(ndim), string_PRN(ndim) ! String in LSJ
      CHARACTER util_lbl_file*256
!
      INTEGER i, j, iargc, ios, ncountState, nFile, mFile
      INTEGER nelec, ncftot, nw, nvectot, nvecsiz, nblock, jblock
      INTEGER nb, ncfblk, nevblk, iiatjp, iiaspa
      INTEGER K, Iprint, IMaxCount
      INTEGER ivec(ndim), indx(ndim), Lev_POS(ndim)
!
      DOUBLE PRECISION eav, eval(ndim), evec, RLev_ENER(ndim),ZERO
!
      COMMON/JJ2LSJ/ Lev_POS,Lev_J,Lev_Par,RLev_ENER,string_CSF,     &
                      IMaxCount
!
      DATA PlusMinus/'-', ' ', '+'/
      DATA JFraction/'  0 ', ' 1/2', '  1 ', ' 3/2', '  2 ', ' 5/2', &
                     '  3 ', ' 7/2', '  4 ', ' 9/2', '  5 ', '11/2', &
                     '  6 ', '13/2', '  7 ', '15/2', '  8 ', '17/2', &
                     '  9 ', '19/2', ' 10 ',                         &
                             '21/2', ' 11 ', '23/2', ' 12 ', '25/2', &
                     ' 13 ', '27/2', ' 14 ', '29/2', ' 15 ', '31/2', &
                     ' 16 ', '33/2', ' 17 ', '35/2', ' 18 ', '37/2', &
                     ' 19 ', '39/2', ' 20 ', '41/2', ' 21 ', '43/2', &
                     ' 22 '/
!
      mFile = iargc()
      string_PRN = ''
      Iprint = 0
      ZERO = 0.0D00
      IF (mFile .EQ. 0) THEN                 ! Get file names interactively
         WRITE (0,*)'  You can also use command-line option:'
         WRITE (0,*)'    %grlevels file1 file2 (wild cards allowed)...'
         WRITE (0,*)'  Now, carry on'
         WRITE (0,*)
         WRITE (0,*)'Type the input file name, one for each line',  &
                  ' (NULL to terminate)'
         WRITE (0,*)
         i = 0
         DO  ! Don't know the exact number of files.
            WRITE (0,'(A12)', ADVANCE='NO') 'File name ? '
            READ (5, '(A80)') strFile
            strFile = ADJUSTL (strFile)
            IF (LEN_TRIM (strFile) .GT. 0) THEN ! a valid input
               i = i + 1
               IF (i .GT. maxFile) THEN      !  impose an upper limit
                  WRITE (0,*)'Too many files opened. processing first '&
                             , i-1, ' files.'
                  EXIT
               ENDIF
               strInFile(i) = strFile
            ELSE
               EXIT
            ENDIF
         ENDDO
         mFile = i
      ELSEIF (mFile .GT. 0 .AND. mFile .LE. maxFile) THEN
         DO i = 1, mFile
            CALL getarg (i, strInFile(i))
         ENDDO
      ELSE
         WRITE (0,*) 'More than ', maxFile, ' files entered,',         &
                  ' modify parameter maxFile'
      ENDIF
!
!     Open files, read energies, concatenate to a single place
!     Open mix file, check header
!
      ncountState = 0
      IMaxCount = 0
      DO nFile = 1, mFile
         strFile = strInFile(nFile)
         OPEN (3, FILE = strFile, FORM = 'UNFORMATTED', STATUS = 'OLD' &
            , IOSTAT = IOS)
         IF (IOS .NE. 0) THEN
           WRITE (0,*) 'Failed to open file "',                   &
                strFile(1:LEN_TRIM (strFile)), '", skipping...'
            CLOSE (3)
            CYCLE
         ENDIF
         READ (3) g92mix
         IF (g92mix .NE. 'G92MIX') THEN
            WRITE (0,*) 'Not a mixing coefficient file, skipping "',&
                      strFile(1:LEN_TRIM (strFile)), '"'
            CLOSE (3)
            CYCLE
         ENDIF
         READ (3) nelec, ncftot, nw, nvectot, nvecsiz, nblock
!
         PRINT *, 'nblock = ', nblock, '  ncftot = ', ncftot,      &
                      '  nw = ', nw, '  nelec = ', nelec

         DO jblock = 1, nblock
            READ (3) nb, ncfblk, nevblk, iiatjp, iiaspa
            IF (jblock .NE. nb) THEN
!
!     This error can occur anywhere and therefore cannot
!     be simply skipped - stop instead.
!
               WRITE (0,*) 'jblock .NE. nb, stopping...'
               CLOSE (3)
               STOP
            ENDIF
            IF (nevblk .LE. 0) CYCLE
            READ (3) (ivec(i+ncountState), i = 1, nevblk)
            READ (3) eav, (eval(i+ncountState), i = 1, nevblk)
            READ (3) (evec, i = 1, ncfblk*nevblk)
!
!     Assign J and parity to every individual state
!     Also add the average energy (back) to energy
!
            DO i = 1, nevblk
               iatjp(i+ncountState) = JFraction(iiatjp)
               iaspa(i+ncountState) = PlusMinus(iiaspa)
               eval(i+ncountState) = eval(i+ncountState) + eav
            END DO
!
!     Update ncountState
!
            ncountState = ncountState + nevblk
         END DO
         CLOSE (3)
!
!     Opens the file  *.lsj.lbl
!
         K = INDEX(strFile,' ')
         if(strFile(K-2:K-1) .EQ. '.m') then
            util_lbl_file = strFile(1:K-3)//'.lsj.lbl'
         else if(strFile(K-3:K-1) .EQ. '.cm') then
            util_lbl_file = strFile(1:K-4)//'.lsj.lbl'
         end if
         OPEN (31, FILE = util_lbl_file, FORM = 'FORMATTED',  &
            STATUS = 'OLD', IOSTAT = IOS)
         IF (IOS .NE. 0) THEN
!GG            WRITE (0,*) 'Failed to open file "',
!GG     &      util_lbl_file(1:LEN_TRIM (util_lbl_file)), '", skipping...'
            CLOSE (31)
            CYCLE
         END IF
         Iprint = 1
!
!     Defines the LSJ string for the levels
!
         CALL LDLBL
         CLOSE (31)
         do i = 1,ncountState
            do j = 1,IMaxCount
               if(DABS(DABS(eval(i))-DABS(RLev_ENER(j))) &
                                 .LT. 0.00000001) then
                   string_PRN(i) =  string_CSF(j)
                   exit
               end if
            end do
         end do
      END DO
      CALL indexS (ncountState, eval, .FALSE., indx)
!
!     The output of the levels
!
      PRINT *
      WRITE (6,1)
      WRITE (6,2) Rydberg
      if(Iprint .eq. 1) then
         WRITE (6,*) 'Splitting is the energy difference ',  &
                     'with the lower neighbor'
         WRITE (6,5)
         WRITE (6,*) 'No Pos  J Parity Energy Total    Levels', &
                     '     Splitting     Configuration'
         WRITE (6,*) '                     (a.u.)         (eV)', &
                     '         (eV)'
         WRITE (6,5)
         j = 1
         i = indx(j)
         WRITE (6,3) j,ivec(i),iatjp(i),iaspa(i),eval(i), &
            ZERO,ZERO,                                    &
            Trim(string_PRN(i))
         DO j = 2, ncountState
            i = indx(j)
            WRITE (6,3) j,ivec(i),iatjp(i),iaspa(i),eval(i),  &
            (eval(i)-eval(indx(1)))*eV,                       &
            (eval(i)-eval(indx(j-1)))*eV,                     &
            Trim(string_PRN(i))
         END DO
         WRITE (6,5)
      ELSE
         WRITE (6,*) 'No - Serial number of the state; ',    &
                     'Pos - Position of the state within the '
         WRITE (6,*) 'J/P block; Splitting is the energy difference ',&
                     'with the lower neighbor'
         WRITE (6,6)
         WRITE (6,*) 'No Pos  J Parity Energy Total    Levels',  &
                     '     Splitting '
         WRITE (6,*) '                     (a.u.)         (eV)', &
                     '         (eV)'
         WRITE (6,6)
         j = 1
         i = indx(j)
         WRITE (6,3) j,ivec(i),iatjp(i),iaspa(i),eval(i)
         DO j = 2, ncountState
            i = indx(j)
            WRITE (6,3) j,ivec(i),iatjp(i),iaspa(i),eval(i),  &
            (eval(i)-eval(indx(1)))*eV,                       &
            (eval(i)-eval(indx(j-1)))*eV
         END DO
         WRITE (6,6)
      END IF
   1  FORMAT (' Energy levels for ...')
   2  FORMAT (' Rydberg constant is ',F14.5)
   3  FORMAT (2I3,1X,A4,1x,A1,2X,F14.7,F15.5,F15.5,2X,A)
   5  FORMAT ('---------------------------------------------',&
              '---------------------------------------------')
   6  FORMAT ('------------------------------------------',   &
              '-------------------------------')
      STOP

      CONTAINS
!
!***********************************************************************
!                                                                      *
      SUBROUTINE indexS(n,a,ldown,indx)
!                                                                      *
!     Sort out the order of array a and store the index in indx        *
!                                                        (a pointer)   *
!     The input array a is unchanged  written in the bases of UpDown   *
!                                                                      *
!     !$Id: rlevels.f,v 1.2 2003/10/02 07:56:22 per Exp $              *
!     $Log: rlevels.f,v $                                              *
!     Revision 1.2  2003/10/02 07:56:22  per                           *
!     *** empty log message ***                                        *
!                                                                      *
!     Revision 1.1.1.1  2003/01/04 21:45:39  georgio                   *
!                                                                      *
!***********************************************************************
      IMPLICIT NONE
      LOGICAL          ldown              ! .TRUE. then Big ---> Small
      INTEGER          n, indx(n)
      DOUBLE PRECISION a(n)
      INTEGER          i, j, ipos, jpos, jhere
      DOUBLE PRECISION aimx
!
!     Initialize the index array
      DO i = 1, n
         indx(i) = i
      ENDDO
      IF (ldown) THEN
         DO i = 1, n
            ipos = indx(i)
            aimx = a(ipos)
            jhere = i
            DO j = i+1, n
               jpos = indx(j)
               IF(a(jpos) .GT. aimx) THEN
                  aimx = a(jpos)
                  jhere = j
               ENDIF
            ENDDO
            indx(i) = indx(jhere)
            indx(jhere) = ipos
         ENDDO
      ELSE
         DO i = 1, n
            ipos = indx(i)
            aimx = a(ipos)
            jhere = i
            DO j = i+1, n
               jpos = indx(j)
               IF(a(jpos) .LT. aimx) THEN
                  aimx = a(jpos)
                  jhere = j
               ENDIF
            ENDDO
            indx(i) = indx(jhere)
            indx(jhere) = ipos
         ENDDO
      ENDIF
      RETURN
      END SUBROUTINE  IndexS
!
!***********************************************************************
!                                                                      *
      SUBROUTINE LDLBL
!                                                                      *
!     Open, check and load data from the  .lsj.lbl   file of the       *
!     inital state.                                                    *
!                                                                      *
!     Calls:                                                           *
!                                                                      *
!     Written by G. Gaigalas,                                          *
!     NIST                                                  May 2011   *
!                                                                      *
!***********************************************************************
!
      IMPLICIT NONE
      INTEGER, PARAMETER :: ndim = 20000          ! max number of states
!
      CHARACTER*1 Lev_par(ndim)
      CHARACTER*4 Lev_J(ndim)
      CHARACTER*15 RECORD
      CHARACTER*64 string_CSF(ndim)
!
      INTEGER IOS, ITEST, Lev_POS(ndim), Icount, ImaxCount
      REAL WEIGHTS
      DOUBLE PRECISION RLev_ENER(ndim)
!
      COMMON/JJ2LSJ/ Lev_POS,Lev_J,Lev_Par,RLev_ENER,string_CSF, &
                      IMaxCount
!
      READ (31,'(1A15)',IOSTAT = IOS) RECORD
      ICount = 0
      IF (IOS .NE. 0) GO TO 1
      ICount = 1
      READ (31,'(1X,I2,1X,A4,5X,A1,8X,F16.9)',IOSTAT = IOS)  &
        Lev_Pos(ICount),Lev_J(ICount),Lev_Par(ICount),       &
        RLev_ENER(ICount)
      IF (IOS .NE. 0) GO TO 1
!
      READ (31,'(7X,F12.8,17X,A)') WEIGHTS,string_CSF(ICount)
!
    2 READ (31,'(1X,I2)',IOSTAT = IOS) ITEST
      IF (IOS .NE. 0) GO TO 1
      IF (ITEST .EQ. 0) GO TO 2
      BACKSPACE 31
      ICount = ICount + 1
      READ (31,'(1X,I2,1X,A4,5X,A1,8X,F16.9)',IOSTAT = IOS) &
        Lev_Pos(ICount),Lev_J(ICount),Lev_Par(ICount),      &
        RLev_ENER(ICount)
      IF (IOS .NE. 0) GO TO 1
      READ (31,'(7X,F12.8,17X,A)') WEIGHTS,string_CSF(ICount)
      GO TO 2
    1 CONTINUE
      IMaxCount = ICount + IMaxCount
      RETURN
      END  SUBROUTINE LDLBL
      END PROGRAM


!***********************************************************************
      SUBROUTINE IMPROVmpi (EOL, J, LSORT, DAMPMX)
!   The difference from the serial version is that it calls MPI        *
!   version subroutines (setlagmpi, cofpotmpi, matrixmpi, newcompi).   *
!                                                                      *
!   Improve the orbital J.                                             *
!                                                                      *
!   Call(s) to: [RSCF92]: DACON, DAMPCK, DAMPOR, LAGCON, matrixmpi,    *
!                         newcompi, ORTHOR, ROTATE, SETCOF, setlagmpi, *
!                         SOLVE, XPOT, YPOT.                           *
!               [LIB92]: ORTHSC, QUAD.                                 *
!                                                                      *
!   Written by Farid A Parpia, at Oxford    Last update: 22 Dec 1992   *
!   Modified by Xinghong He                 Last update: 05 Aug 1988   *
!   Modified for ifort -i8 by A. Kramida (AK) Last update 22 Mar 2016  *
!                                                                      *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  14:04:58   1/ 3/07
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE memory_man
      USE CORRE_C
      USE damp_C
      USE def_C
      USE grid_C
      USE int_C
      USE mpi_C
      USE orb_C
      USE orthct_C
      USE scf_C
      USE tatb_C
      USE wave_C
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE cofpotmpi_I
      USE defcor_I
      USE solve_I
      USE orthsc_I
!GG      USE matrixmpi_I
!GG      USE newcompi_I
      USE setlagmpi_I
      USE quad_I
      USE consis_I
      USE dampck_I
      USE dampor_I
      USE orthy_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: J
      REAL(DOUBLE), INTENT(INOUT) :: DAMPMX
      LOGICAL  :: EOL, LSORT
!-----------------------------------------------
!   L o c a l   P a r a m e t e r s
!-----------------------------------------------
      REAL(DOUBLE), PARAMETER :: P2 = 2.0D-01
      REAL(DOUBLE), PARAMETER :: P005 = 5.0D-03
      REAL(DOUBLE), PARAMETER :: P0001 = 1.0D-04
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: IPR, NPTS, INV, JP, NNP, I, NWWW
      INTEGER :: I_MPI, ndcof_max, ntot, i_last, iproc, ndcip, jproc
      INTEGER :: ifound, ind_buf, K
      REAL(DOUBLE) :: ED1, GAMAJ, ED2, WTAEV, DNORM, DNFAC, DEL1, DEL2, ODAMPJ
      LOGICAL :: FAIL, FIRST
      REAL(DOUBLE), DIMENSION(:), POINTER :: da_buffer
      INTEGER, DIMENSION(:), POINTER :: nda_buffer,ndcof_buffer
!-----------------------------------------------
!
!   C Froese Fischer's IPR and ED1 parameter
!
      DATA IPR/ 0/
      DATA ED1/ 0.D0/
      DATA FIRST/ .FALSE./
!
!
!-----------------------------------------------------------------------
!AK Handling the -i8 option of ifort and -fdefault-integer-8 option of gfortran
!      ISIZE = sizeof(NCF)
      I_MPI = MPI_INTEGER
!      if (ISIZE.EQ.8) I_MPI = MPI_INTEGER8
!
      GAMAJ = GAMA(J)
!
!   C Froese Fischer's parameters IPR, ED1, ED2 are set and
!   used in this routine and in DAMPCK
!
    1 CONTINUE
      ED2 = E(J)
!
!   Set up the exchange potential and arrays XU, XV as appropriate
!
!   Set coefficients for YPOT, XPOT, DACON
!   Compute direct potential, exchange potential
!   Add in Lagrange-multiplier contribution
!   Add in derivative-terms contribution
!
      NPTS = N
      CALL COFPOTmpi (EOL, J, NPTS)
!
!   Calculate deferred corrections
!
      CALL DEFCOR (J)
!
!   Solve the Dirac equation
!
!AK     NDCOF, NDA, and DA cannot be reduced by finding the max of NDCOF
!          and summing up DA from all nodes. The correct replacement is below
!cjb MPI_ALLREDUCE NDCOF
!      call MPI_ALLREDUCE(ndcof,ndcof_buffer,1,
!     :          I_MPI,MPI_MAX,MPI_COMM_WORLD,ierror)
!      if (ndcof_buffer .gt. ndcof) then
!        print *, 'improvmpi: ndcof, ndcof_buffer, myid=',
!     &                     ndcof, ndcof_buffer, myid
!        write (*,'(A35,4I10)') 'improv11: myid,NDCOF,ndcbfr=',
!     &    myid,NDCOF,ndcof_buffer
!        do indcof = ndcof+1, ndcof_buffer
!           da(indcof) = 0.0
!           nda(indcof) = 0
!        enddo
!        ndcof = ndcof_buffer
!      endif
      INV = 0
!cjb MPI_ALLREDUCE DA
!      if (ndcof.gt.0) then
!         call alloc(pda_buffer, ndcof, 8)
!         call alloc(pnda_buffer, ndcof, ISIZE)
!         call MPI_ALLREDUCE(da,da_buffer,ndcof,
!     :          MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierror)
!         da(1:ndcof) = da_buffer(1:ndcof)
!      nda(1:ndcof) = nda_buffer(1:ndcof)
!         call dalloc(pda_buffer)
!         call dalloc(pnda_buffer)
!      ENDIF
!AK      Consolidate NDA and DA from all nodes
      if (nprocs.gt.1) then
         call alloc(ndcof_buffer,nprocs,'ndcof_buffer','IMPROVmpi')
         call MPI_GATHER(ndcof, 1, I_MPI, ndcof_buffer,            &
              1, I_MPI, 0, MPI_COMM_WORLD, ierr)
         CALL MPI_Bcast (ndcof_buffer, nprocs, I_MPI, 0,           &
                               MPI_COMM_WORLD, ierr)
         ndcof_max = 0
         do i = 1, nprocs
            if (ndcof_buffer(i).gt.ndcof_max) ndcof_max=ndcof_buffer(i)
         ENDDO
         if (ndcof_max.gt.0) then
            ntot = ndcof_max*nprocs
            call alloc(nda_buffer,ntot,'nda_buffer','IMPROVmpi')
            call MPI_GATHER(nda, ndcof_max, I_MPI, nda_buffer,     &
                 ndcof_max, I_MPI, 0, MPI_COMM_WORLD, ierr)
            CALL MPI_Bcast (nda_buffer, ntot, I_MPI, 0,            &
                               MPI_COMM_WORLD, ierr)
            call alloc(da_buffer, ntot, 'da_buffer','IMPROVmpi')
            call MPI_GATHER(da, ndcof_max, MPI_DOUBLE_PRECISION,   &
              da_buffer, ndcof_max, MPI_DOUBLE_PRECISION, 0,       &
              MPI_COMM_WORLD, ierr)
            CALL MPI_Bcast (da_buffer, ntot, MPI_DOUBLE_PRECISION, &
                               0, MPI_COMM_WORLD, ierr)
            i_last = 0
            do iproc = 1, nprocs
               ndcip = ndcof_buffer(iproc)
               do jproc = 1, ndcip
                  ifound = 0
                  ind_buf = (iproc - 1)*ndcof_max + jproc
                  do k = 1, i_last
                     if (nda_buffer(ind_buf) .eq. NDA(k)) THEN
                        DA(k) = DA(k) + da_buffer(ind_buf)
                        ifound = k
                        exit
                     endif
                  enddo
                  if (ifound.eq.0) then
                     i_last = i_last + 1
                     do while (i_last .GT. NDDIM)
                        IF (NDDIM .GT. 0) THEN
                           NDDIM = 2*NDDIM
!GG                           CALL alcsca (PNTNDA, PNTRDA, NDDIM, 2)
                           CALL RALLOC(NDA,NDDIM,'NDA','IMPROVmpi')
                        ELSE
                          NDDIM = 64
!GG                           CALL alcsca (PNTNDA, PNTRDA, NDDIM, 1)
                           CALL ALLOC(NDA,NDDIM,'NDA','IMPROVmpi')
                        ENDIF
                     ENDdo
                     NDA(i_last) = nda_buffer(ind_buf)
                     DA(i_last) = da_buffer(ind_buf)
                  endif
               enddo
            enddo
            NDCOF = ndcof_max
            call dalloc(nda_buffer,'nda_buffer','IMPROVmpi')
            call dalloc(da_buffer,'da_buffer','IMPROVMPI')
         endif
         call dalloc(ndcof_buffer,'ndcof_buffer','IMPROVmpi')
      endif

      CALL SOLVE (J, FAIL, INV, JP, NNP)
!
!   Upon failure issue message; take corrective action if possible
!
      IF (FAIL) THEN
         IF (MYID == 0) WRITE (*, 300) NP(J), NH(J), METHOD(J)
         IF (METHOD(J) /= 2) THEN
            METHOD(J) = 2
!XHH orthsc does not have any argument
!    Orbital J [PF() and QF()]is not updated, why redo orthogonalization
            CALL ORTHSC
!CFF        ... avoid rediagonalization
!            IF (EOL) THEN
!               CALL MATRIXMPI
!               CALL NEWCOMPI (WTAEV)
!            ENDIF
            CALL SETLAGmpi (EOL)
            GO TO 1
         ELSE
            IF (MYID == 0) WRITE (*, 301)
            !CALL TIMER (0)
            ERROR STOP
         ENDIF
      ENDIF
!
!   Compute norm of radial function
!
      TA(1) = 0.D0
      TA(2:MTP0) = (P(2:MTP0)**2+Q(2:MTP0)**2)*RP(2:MTP0)
      MTP = MTP0

      CALL QUAD (DNORM)

!   Determine self-consistency [multiplied by SQRT(UCF(J))]

      CALL CONSIS (J)
!
!   Normalize
!
      DNFAC = 1.D0/DSQRT(DNORM)
      P0 = P0*DNFAC
      P(:MTP0) = P(:MTP0)*DNFAC
      Q(:MTP0) = Q(:MTP0)*DNFAC
!
!   Check if different method should be used or if improvement
!   count should be reduced
!
      DEL1 = DABS(1.D0 - ED2/E(J))
      IF (METHOD(J) == 1) THEN
         DEL2 = DMAX1(DABS(1.D0 - DSQRT(DNORM)),DABS(DNFAC - 1.D0))
         IF (DEL1<P005 .AND. DEL2>P2) THEN
            METHOD(J) = 2
            GO TO 1
         ENDIF
      ELSE
         IF (DEL1<P0001 .AND. NSIC>1) NSIC = NSIC - 1
      ENDIF
!
!   Damp the orbital --- if not converged
!
      IF (SCNSTY(J) > ACCY) THEN
         CALL DAMPCK (IPR, J, ED1, ED2)
         ODAMPJ = DABS(ODAMP(J))
      ELSE
         ODAMPJ = 0.D0                           ! take the whole new orbital
      ENDIF
      CALL DAMPOR (J, INV, ODAMPJ)

!   Orthogonalize all orbitals of the same kappa in the order
!   fixed, spectroscopic, correlation orbitals. The order of
!   orbitals in the latter two classes are sorted according
!   to their self-consistency and energy.

      IF (ORTHST) THEN
         !CALL orthor (J, inv)
         NWWW = NW
         CALL ORTHY (NWWW, J, LSORT)
      ENDIF
!
!   Print details of iteration
!
      IF (MYID == 0)                                                &
         WRITE (*, 302) NP(J),NH(J),E(J),METHOD(J),PZ(J),SCNSTY(J), &
!cjb DNORM-1 -> SQRT(DNORM)-1
!cjb                    DNORM - 1, ODAMPJ, JP, MF(J), INV, NNP
                        SQRT(DNORM)-1, ODAMPJ, JP, MF(J), INV, NNP
      DAMPMX = DMAX1(DAMPMX,DABS(ODAMPJ))

  300 FORMAT(/,' Failure; equation for orbital ',1I2,1A2,&
         ' could not be solved using method ',1I1)
  301 FORMAT(/,/,' ****** Error in SUBROUTINE IMPROV ******'/,&
         ' Convergence not obtained'/)
  302 FORMAT (1X,1I2,1A2,1P,1D16.7,1x,1I2,D11.3,1D10.2,1D10.2,&
              0P,F6.3,1x,1I5,1x,1I5,1x,1I2,1x,1I2)
      RETURN
      END SUBROUTINE IMPROVmpi


      SUBROUTINE DT_EVTPUT(Ist,Id,M1,M2,Px,Py,Pz,E,Idr,Idxr,Idc)

      IMPLICIT NONE
      DOUBLE PRECISION E , ptot , Px , Py , Pz , SQTINF , TINY10 ,
     &                 TINY2 , TINY3 , TINY4 , ZERO
      INTEGER i , Id , Idc , idchk , idmo1 , idmo2 , Idr , IDT_ICIHAD ,
     &        Idxr , Ist , M1 , M2 , mo1 , mo2
      SAVE

      INCLUDE 'inc/dtflka'

      PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3,TINY2=1.0D-2,
     &           SQTINF=1.0D+15,ZERO=0.0D0)

C event history

      INCLUDE 'inc/dtevt1'
C extended event history
      INCLUDE 'inc/dtevt2'
C Lorentz-parameters of the current interaction
      INCLUDE 'inc/dtltra'
C particle properties (BAMJET index convention)
      INCLUDE 'inc/dtpart'

C     IF (MODE.GT.100) THEN
C        WRITE(LOUT,'(1X,A,I5,A,I5)')
C    &        'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100
C        NHKK = NHKK-MODE+100
C        RETURN
C     ENDIF
      mo1 = M1
      mo2 = M2
      NHKk = NHKk + 1

      IF ( NHKk.GT.NMXHKK ) THEN

         IF ( LPRi.GT.4 ) WRITE (LOUt,99010) NHKk
99010    FORMAT (1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7,
     &           '! program execution stopped..')
         STOP
      END IF
      IF ( M1.LT.0 ) mo1 = NHKk + M1
      IF ( M2.LT.0 ) mo2 = NHKk + M2
      ISThkk(NHKk) = Ist
      IDHkk(NHKk) = Id
      JMOhkk(1,NHKk) = mo1
      JMOhkk(2,NHKk) = mo2
      JDAhkk(1,NHKk) = 0
      JDAhkk(2,NHKk) = 0
      IDRes(NHKk) = Idr
      IDXres(NHKk) = Idxr
      IDCh(NHKk) = Idc
C* here we need to do something..
      IF ( Id.EQ.88888 ) THEN
         idmo1 = ABS(IDHkk(mo1))
         idmo2 = ABS(IDHkk(mo2))
         IF ( (idmo1.LT.100) .AND. (idmo2.LT.100) ) NOBam(NHKk) = 3
         IF ( (idmo1.LT.100) .AND. (idmo2.GT.100) ) NOBam(NHKk) = 4
         IF ( (idmo1.GT.100) .AND. (idmo2.GT.100) ) NOBam(NHKk) = 5
         IF ( (idmo1.GT.100) .AND. (idmo2.LT.100) ) NOBam(NHKk) = 6
      ELSE
         NOBam(NHKk) = 0
      END IF
      IDBam(NHKk) = IDT_ICIHAD(Id)

      IF ( mo1.GT.0 ) THEN
         IF ( JDAhkk(1,mo1).NE.0 ) THEN
            JDAhkk(2,mo1) = NHKk
         ELSE
            JDAhkk(1,mo1) = NHKk
         END IF
      END IF
      IF ( mo2.GT.0 ) THEN
         IF ( JDAhkk(1,mo2).NE.0 ) THEN
            JDAhkk(2,mo2) = NHKk
         ELSE
            JDAhkk(1,mo2) = NHKk
         END IF
      END IF
C      IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN
C         PTOT   = SQRT(PX**2+PY**2+PZ**2)
C         AM0    = SQRT(ABS( (E-PTOT)*(E+PTOT) ))
C         AMRQ   = AAM(IDBAM(NHKK))
C         AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
C         IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND.
C     &       (PTOT.GT.ZERO)) THEN
C            DELTA = -AMDIF2/(2.0D0*(E+PTOT))
CC           DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT))
C            E     = E+DELTA
C            PTOT1 = PTOT-DELTA
C            PX    = PX*PTOT1/PTOT
C            PY    = PY*PTOT1/PTOT
C            PZ    = PZ*PTOT1/PTOT
C         ENDIF
C      ENDIF
      PHKk(1,NHKk) = Px
      PHKk(2,NHKk) = Py
      PHKk(3,NHKk) = Pz
      PHKk(4,NHKk) = E
      ptot = SQRT(Px**2+Py**2+Pz**2)
      IF ( (IDHkk(NHKk).GE.22) .AND. (IDHkk(NHKk).LE.24) ) THEN
         PHKk(5,NHKk) = PHKk(4,NHKk)**2 - ptot**2
         PHKk(5,NHKk) = SIGN(SQRT(ABS(PHKk(5,NHKk))),PHKk(5,NHKk))
      ELSE
         PHKk(5,NHKk) = (PHKk(4,NHKk)-ptot)*(PHKk(4,NHKk)+ptot)
C        IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4))
C    &      WRITE(LOUT,'(1X,A,G10.3)')
C    &        'EVTPUT: negative mass**2 ',PHKK(5,NHKK)
         PHKk(5,NHKk) = SQRT(ABS(PHKk(5,NHKk)))
      END IF
      idchk = Id/10000
      IF ( ((idchk.EQ.7) .OR. (idchk.EQ.8)) .AND. (Id.NE.80000) ) THEN
C special treatment for chains:
C    z coordinate of chain in Lab  = pos. of target nucleon
C    time of chain-creation in Lab = time of passage of projectile
C                                    nucleus at pos. of taget nucleus
C        VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2))
C        VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2))
         VHKk(1,NHKk) = VHKk(1,mo2)
         VHKk(2,NHKk) = VHKk(2,mo2)
         VHKk(3,NHKk) = VHKk(3,mo2)
         VHKk(4,NHKk) = VHKk(3,mo2)/BLAb - VHKk(3,mo1)/BGLab
C        WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2))
C        WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2))
         WHKk(1,NHKk) = WHKk(1,mo1)
         WHKk(2,NHKk) = WHKk(2,mo1)
         WHKk(3,NHKk) = WHKk(3,mo1)
         WHKk(4,NHKk) = -WHKk(3,mo1)/BLAb + WHKk(3,mo2)/BGLab
      ELSE IF ( mo1.GT.0 ) THEN
         DO i = 1 , 4
            VHKk(i,NHKk) = VHKk(i,mo1)
            WHKk(i,NHKk) = WHKk(i,mo1)
         END DO
      ELSE
         DO i = 1 , 4
            VHKk(i,NHKk) = ZERO
            WHKk(i,NHKk) = ZERO
         END DO
      END IF

      END SUBROUTINE


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

C...PY1ENT
C...Stores one parton/particle in commonblock PYJETS.

      SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI)

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

C...Commonblocks.
      include 'inc/pyjets'
      include 'inc/pydat1'
      include 'inc/pydat2'

C...Standard checks.
      MSTU(28)=0
      IF(MSTU(12).NE.12345) CALL PYLIST(0)
      IPA=MAX(1,ABS(IP))
      IF(IPA.GT.MSTU(4)) CALL PYERRM(21,
     &'(PY1ENT:) writing outside PYJETS memory')
      KC=PYCOMP(KF)
      IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code')

C...Find mass. Reset K, P and V vectors.
      PM=0D0
      IF(MSTU(10).EQ.1) PM=P(IPA,5)
      IF(MSTU(10).GE.2) PM=PYMASS(KF)
      DO 100 J=1,5
        K(IPA,J)=0
        P(IPA,J)=0D0
        V(IPA,J)=0D0
  100 CONTINUE

C...Store parton/particle in K and P vectors.
      K(IPA,1)=1
      IF(IP.LT.0) K(IPA,1)=2
      K(IPA,2)=KF
      P(IPA,5)=PM
      P(IPA,4)=MAX(PE,PM)
      PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
      P(IPA,1)=PA*SIN(THE)*COS(PHI)
      P(IPA,2)=PA*SIN(THE)*SIN(PHI)
      P(IPA,3)=PA*COS(THE)

C...Set N. Optionally fragment/decay.
      N=IPA
      IF(IP.EQ.0) CALL PYEXEC

      RETURN
      END


Subroutine crnd(irun, px, py, pz, srt, i1, i2, iblock, signn, sig, sigk, xsk1, xsk2, xsk3, xsk4, xsk5, nt, ipert1)
  Parameter (maxstr=150001, maxr=1, amn=0.939457, amp=0.93828, ap1=0.13496, aka=0.498, aphi=1.020, ap2=0.13957, am0=1.232, pi=3.1415926, cutoff=1.8966, avmass=0.9383)
  Parameter (mx=4, my=4, mz=8, mpx=4, mpy=4, mpz=10, mpzp=10)
  Parameter (xmd=1.8756, npdmax=10000)
  Common /aa/r(3, maxstr)
  Common /bb/p(3, maxstr)
  Common /cc/e(maxstr)
  Common /ee/id(maxstr), lb(maxstr)
  Common /ff/f(-mx:mx, -my:my, -mz:mz, -mpx:mpx, -mpy:mpy, -mpz:mpzp)
  Common /gg/dx, dy, dz, dpx, dpy, dpz
  Common /input/nstar, ndirct, dir
  Common /nn/nnn
  Common /bg/betax, betay, betaz, gamma
  Common /run/num
  Common /pa/rpion(3, maxstr, maxr)
  Common /pb/ppion(3, maxstr, maxr)
  Common /pc/epion(maxstr, maxr)
  Common /pd/lpion(maxstr, maxr)
  Common /input1/masspr, massta, iseed, iavoid, dt
  Common /leadng/lb1, px1, py1, pz1, em1, e1, xfnl, yfnl, zfnl, tfnl, px1n, py1n, pz1n, dp1n
  Common /rndf77/nseed
  Common /dpert/dpertt(maxstr, maxr), dpertp(maxstr), dplast(maxstr), dpdcy(maxstr), dpdpi(maxstr, maxr), dpt(maxstr, maxr), dpp1(maxstr, maxr), dppion(maxstr, maxr)
  Common /dpi/em2, lb2
  Common /para8/idpert, npertd, idxsec
  Dimension ppd(3, npdmax), lbpd(npdmax)
  Save
  n12 = 0
  m12 = 0
  iblock = 0
  ntag = 0
  em1 = e(i1)
  em2 = e(i2)
  pr = sqrt(px**2+py**2+pz**2)
  c2 = pz/pr
  x1 = ranart(nseed)
  ianti = 0
  If (lb(i1)<0 .And. lb(i2)<0) ianti = 1
  Call sbbdm(srt, sdprod, ianti, lbm, xmm, pfinal)
  If (idpert==1 .And. ipert1==1) Then
     If (srt<2.012) Return
     If ((iabs(lb(i1))==1 .Or. iabs(lb(i1))==2) .And. (iabs(lb(i2))>=6 .And. iabs(lb(i2))<=13)) Then
        Goto 108
     Else If ((iabs(lb(i2))==1 .Or. iabs(lb(i2))==2) .And. (iabs(lb(i1))>=6 .And. iabs(lb(i1))<=13)) Then
        Goto 108
     Else
        Return
     End If
  End If
  If (x1<=signn/sig) Then
     as = (3.65*(srt-1.8766))**6
     a = 6.0*as/(1.0+as)
     ta = -2.0*pr**2
     x = ranart(nseed)
     t1 = sngl(dlog(dble(1.-x)*dexp(dble(a)*dble(ta))+dble(x)))/a
     c1 = 1.0 - t1/ta
     t1 = 2.0*pi*ranart(nseed)
     iblock = 1
     Goto 107
  Else
     If (srt<2.04) Return
     If (((iabs(lb(i1))==2 .Or. iabs(lb(i2))==2) .And. (lb(i1)*lb(i2))==20) .Or. (lb(i1)*lb(i2))==13) Then
        If (x1<=((signn+sdprod)/sig)) Goto 108
     End If
     prf = sqrt(0.25*srt**2-avmass**2)
     If (em1>1.) Then
        deltam = em1
     Else
        deltam = em2
     End If
     renom = deltam*prf**2/denom(srt, 1.)/pr
     renomn = deltam*prf**2/denom(srt, 2.)/pr
     renom1 = deltam*prf**2/denom(srt, -1.)/pr
     If ((iabs(lb(i1))==2) .And. (iabs(lb(i2))==6)) renom = 0.
     If ((iabs(lb(i2))==2) .And. (iabs(lb(i1))==6)) renom = 0.
     If ((iabs(lb(i1))==1) .And. (iabs(lb(i2))==9)) renom = 0.
     If ((iabs(lb(i2))==1) .And. (iabs(lb(i1))==9)) renom = 0.
     Call m1535(iabs(lb(i1)), iabs(lb(i2)), srt, x1535)
     x1440 = (3./4.)*sigma(srt, 2, 0, 1)
     If (((iabs(lb(i1))==2) .And. (iabs(lb(i2))==6)) .Or. ((iabs(lb(i2))==2) .And. (iabs(lb(i1))==6)) .Or. ((iabs(lb(i1))==1) .And. (iabs(lb(i2))==9)) .Or. ((iabs(lb(i2))==1) .And. (iabs(lb(i1))==9))) Then
        If (x1<=((signn+sdprod)/sig)) Goto 108
        If ((sigk+signn+sdprod)/sig>=x1) Goto 306
     End If
     If (lb(i1)*lb(i2)==18 .And. (iabs(lb(i1))==2 .Or. iabs(lb(i2))==2)) Then
        signd = sigma(srt, 1, 1, 0) + 0.5*sigma(srt, 1, 1, 1)
        sigdn = 0.25*signd*renom
        If (x1<=((signn+sdprod)/sig)) Goto 108
        If (x1>(signn+sigdn+x1440+x1535+sigk+sdprod)/sig) Return
        If (sigk/(sigk+sigdn+x1440+x1535)>ranart(nseed)) Goto 306
        If (ranart(nseed)<sigdn/(sigdn+x1440+x1535)) Then
           m12 = 3
           Goto 206
        Else
           If (ranart(nseed)<x1440/(x1440+x1535)) Then
              m12 = 37
           Else
              Return
           End If
           Goto 204
        End If
     End If
     If (lb(i1)*lb(i2)==6 .And. ((iabs(lb(i1))==1) .Or. (iabs(lb(i2))==1))) Then
        signd = sigma(srt, 1, 1, 0) + 0.5*sigma(srt, 1, 1, 1)
        sigdn = 0.25*signd*renom
        If (x1<=((signn+sdprod)/sig)) Goto 108
        If (x1>(signn+sigdn+x1440+x1535+sigk+sdprod)/sig) Return
        If (sigk/(sigk+sigdn+x1440+x1535)>ranart(nseed)) Goto 306
        If (ranart(nseed)<sigdn/(sigdn+x1440+x1535)) Then
           m12 = 6
           Goto 206
        Else
           If (ranart(nseed)<x1440/(x1440+x1535)) Then
              m12 = 47
           Else
              Return
           End If
           Goto 204
        End If
     End If
     If (lb(i1)*lb(i2)==8 .And. (iabs(lb(i1))==1 .Or. iabs(lb(i2))==1)) Then
        signd = 1.5*sigma(srt, 1, 1, 1)
        sigdn = 0.25*signd*renom
        If (x1<=((signn+sdprod)/sig)) Goto 108
        If (x1>(signn+sigdn+x1440+x1535+sigk+sdprod)/sig) Return
        If (sigk/(sigk+sigdn+x1440+x1535)>ranart(nseed)) Goto 306
        If (ranart(nseed)<sigdn/(sigdn+x1440+x1535)) Then
           m12 = 4
           Goto 206
        Else
           If (ranart(nseed)<x1440/(x1440+x1535)) Then
              m12 = 39
           Else
              m12 = 40
           End If
           Goto 204
        End If
     End If
     If (lb(i1)*lb(i2)==14 .And. (iabs(lb(i1))==2 .Or. iabs(lb(i2))==2)) Then
        signd = 1.5*sigma(srt, 1, 1, 1)
        sigdn = 0.25*signd*renom
        If (x1<=((signn+sdprod)/sig)) Goto 108
        If (x1>(signn+sigdn+x1440+x1535+sigk+sdprod)/sig) Return
        If (sigk/(sigk+sigdn+x1440+x1535)>ranart(nseed)) Goto 306
        If (ranart(nseed)<sigdn/(sigdn+x1440+x1535)) Then
           m12 = 5
           Goto 206
        Else
           If (ranart(nseed)<x1440/(x1440+x1535)) Then
              m12 = 48
           Else
              m12 = 49
           End If
           Goto 204
        End If
     End If
     If (lb(i1)*lb(i2)==16 .And. (iabs(lb(i1))==2 .Or. iabs(lb(i2))==2)) Then
        signd = 0.5*sigma(srt, 1, 1, 1) + 0.25*sigma(srt, 1, 1, 0)
        sigdn = 0.5*signd*renom
        If (x1<=((signn+sdprod)/sig)) Goto 108
        If (x1>(signn+sigdn+2.*x1440+2.*x1535+sigk+sdprod)/sig) Return
        If (sigk/(sigk+sigdn+2*x1440+2*x1535)>ranart(nseed)) Goto 306
        If (ranart(nseed)<sigdn/(sigdn+2.*x1440+2.*x1535)) Then
           m12 = 1
           Goto 206
        Else
           If (ranart(nseed)<x1440/(x1440+x1535)) Then
              m12 = 41
              If (ranart(nseed)<=0.5) m12 = 43
           Else
              m12 = 42
              If (ranart(nseed)<=0.5) m12 = 44
           End If
           Goto 204
        End If
     End If
     If (lb(i1)*lb(i2)==7) Then
        signd = 0.5*sigma(srt, 1, 1, 1) + 0.25*sigma(srt, 1, 1, 0)
        sigdn = 0.5*signd*renom
        If (x1<=((signn+sdprod)/sig)) Goto 108
        If (x1>(signn+sigdn+2.*x1440+2.*x1535+sigk+sdprod)/sig) Return
        If (sigk/(sigk+sigdn+2*x1440+2*x1535)>ranart(nseed)) Goto 306
        If (ranart(nseed)<sigdn/(sigdn+2.*x1440+2.*x1535)) Then
           m12 = 2
           Goto 206
        Else
           If (ranart(nseed)<x1440/(x1440+x1535)) Then
              m12 = 50
              If (ranart(nseed)<=0.5) m12 = 51
           Else
              m12 = 52
              If (ranart(nseed)<=0.5) m12 = 53
           End If
           Goto 204
        End If
     End If
     If (lb(i1)*lb(i2)==10 .And. (iabs(lb(i1))==1 .Or. iabs(lb(i2))==1)) Then
        signd = (3./4.)*sigma(srt, 2, 0, 1)
        sigdn = signd*renomn
        If (x1<=((signn+sdprod)/sig)) Goto 108
        If (x1>(signn+sigdn+x1535+sigk+sdprod)/sig) Return
        If (sigk/(sigk+sigdn+x1535)>ranart(nseed)) Goto 306
        If (ranart(nseed)<sigdn/(sigdn+x1535)) Then
           m12 = 7
           Goto 206
        Else
           m12 = 54
           If (ranart(nseed)<=0.5) m12 = 55
        End If
        Goto 204
     End If
     If (lb(i1)*lb(i2)==22 .And. (iabs(lb(i1))==2 .Or. iabs(lb(i2))==2)) Then
        signd = (3./4.)*sigma(srt, 2, 0, 1)
        sigdn = signd*renomn
        If (x1<=((signn+sdprod)/sig)) Goto 108
        If (x1>(signn+sigdn+x1535+sigk+sdprod)/sig) Return
        If (sigk/(sigk+sigdn+x1535)>ranart(nseed)) Goto 306
        If (ranart(nseed)<sigdn/(sigdn+x1535)) Then
           m12 = 8
           Goto 206
        Else
           m12 = 56
           If (ranart(nseed)<=0.5) m12 = 57
        End If
        Goto 204
     End If
     If ((iabs(lb(i1))==12) .Or. (iabs(lb(i1))==13) .Or. (iabs(lb(i2))==12) .Or. (iabs(lb(i2))==13)) Then
        signd = x1535
        sigdn = signd*renom1
        If (x1<=((signn+sdprod)/sig)) Goto 108
        If (x1>(signn+sigdn+sigk+sdprod)/sig) Return
        If (sigk/(sigk+sigdn)>ranart(nseed)) Goto 306
        If (lb(i1)*lb(i2)==24) m12 = 10
        If (lb(i1)*lb(i2)==12) m12 = 12
        If (lb(i1)*lb(i2)==26) m12 = 11
        If (lb(i1)*lb(i2)==13) m12 = 9
        Goto 206
     End If
204  Continue
     dmax = srt - avmass - 0.005
     dmin = 1.078
     If ((m12==37) .Or. (m12==39) .Or. (m12==41) .Or. (m12==43) .Or. (m12==46) .Or. (m12==48) .Or. (m12==50) .Or. (m12==51)) Then
        If (dmax<1.44) Then
           fm = fns(dmax, srt, 0.)
        Else
           xdmass = 1.44
           fm = fns(xdmass, srt, 1.)
        End If
        If (fm==0.) fm = 1.E-09
        ntry2 = 0
11      dm = ranart(nseed)*(dmax-dmin) + dmin
        ntry2 = ntry2 + 1
        If ((ranart(nseed)>fns(dm,srt,1.)/fm) .And. (ntry2<=10)) Goto 11
        If (dm>2.14) Goto 11
        Goto 13
     Else
        If (dmax<1.535) Then
           fm = fd5(dmax, srt, 0.)
        Else
           xdmass = 1.535
           fm = fd5(xdmass, srt, 1.)
        End If
        If (fm==0.) fm = 1.E-09
        ntry1 = 0
12      dm = ranart(nseed)*(dmax-dmin) + dmin
        ntry1 = ntry1 + 1
        If ((ranart(nseed)>fd5(dm,srt,1.)/fm) .And. (ntry1<=10)) Goto 12
        If (dm>1.84) Goto 12
     End If
13   Continue
     prf = 0.
     pf2 = ((srt**2-dm**2+avmass**2)/(2.*srt))**2 - avmass**2
     If (pf2>0.) prf = sqrt(pf2)
     If (m12==37) Then
        If (iabs(lb(i1))==9) Then
           lb(i1) = 1
           e(i1) = amp
           lb(i2) = 11
           e(i2) = dm
        Else
           lb(i2) = 1
           e(i2) = amp
           lb(i1) = 11
           e(i1) = dm
        End If
        Goto 207
     End If
     If (m12==38) Then
        If (iabs(lb(i1))==9) Then
           lb(i1) = 1
           e(i1) = amp
           lb(i2) = 13
           e(i2) = dm
        Else
           lb(i2) = 1
           e(i2) = amp
           lb(i1) = 13
           e(i1) = dm
        End If
        Goto 207
     End If
     If (m12==39) Then
        If (iabs(lb(i1))==8) Then
           lb(i1) = 1
           e(i1) = amp
           lb(i2) = 11
           e(i2) = dm
        Else
           lb(i2) = 1
           e(i2) = amp
           lb(i1) = 11
           e(i1) = dm
        End If
        Goto 207
     End If
     If (m12==40) Then
        If (iabs(lb(i1))==8) Then
           lb(i1) = 1
           e(i1) = amp
           lb(i2) = 13
           e(i2) = dm
        Else
           lb(i2) = 1
           e(i2) = amp
           lb(i1) = 13
           e(i1) = dm
        End If
        Goto 207
     End If
     If (m12==41) Then
        If (iabs(lb(i1))==8) Then
           lb(i1) = 2
           e(i1) = amn
           lb(i2) = 11
           e(i2) = dm
        Else
           lb(i2) = 2
           e(i2) = amn
           lb(i1) = 11
           e(i1) = dm
        End If
        Goto 207
     End If
     If (m12==42) Then
        If (iabs(lb(i1))==8) Then
           lb(i1) = 2
           e(i1) = amn
           lb(i2) = 13
           e(i2) = dm
        Else
           lb(i2) = 2
           e(i2) = amn
           lb(i1) = 13
           e(i1) = dm
        End If
        Goto 207
     End If
     If (m12==43) Then
        If (iabs(lb(i1))==8) Then
           lb(i1) = 1
           e(i1) = amp
           lb(i2) = 10
           e(i2) = dm
        Else
           lb(i2) = 1
           e(i2) = amp
           lb(i1) = 10
           e(i1) = dm
        End If
        Goto 207
     End If
     If (m12==44) Then
        If (iabs(lb(i1))==8) Then
           lb(i1) = 1
           e(i1) = amp
           lb(i2) = 12
           e(i2) = dm
        Else
           lb(i2) = 1
           e(i2) = amp
           lb(i1) = 12
           e(i1) = dm
        End If
        Goto 207
     End If
     If (m12==46) Then
        If (iabs(lb(i1))==6) Then
           lb(i1) = 2
           e(i1) = amn
           lb(i2) = 10
           e(i2) = dm
        Else
           lb(i2) = 2
           e(i2) = amn
           lb(i1) = 10
           e(i1) = dm
        End If
        Goto 207
     End If
     If (m12==47) Then
        If (iabs(lb(i1))==6) Then
           lb(i1) = 2
           e(i1) = amn
           lb(i2) = 12
           e(i2) = dm
        Else
           lb(i2) = 2
           e(i2) = amn
           lb(i1) = 12
           e(i1) = dm
        End If
        Goto 207
     End If
     If (m12==48) Then
        If (iabs(lb(i1))==7) Then
           lb(i1) = 2
           e(i1) = amn
           lb(i2) = 11
           e(i2) = dm
        Else
           lb(i2) = 2
           e(i2) = amn
           lb(i1) = 11
           e(i1) = dm
        End If
        Goto 207
     End If
     If (m12==49) Then
        If (iabs(lb(i1))==7) Then
           lb(i1) = 2
           e(i1) = amn
           lb(i2) = 12
           e(i2) = dm
        Else
           lb(i2) = 2
           e(i2) = amn
           lb(i1) = 12
           e(i1) = dm
        End If
        Goto 207
     End If
     If (m12==50) Then
        If (iabs(lb(i1))==7) Then
           lb(i1) = 1
           e(i1) = amp
           lb(i2) = 10
           e(i2) = dm
        Else
           lb(i2) = 1
           e(i2) = amp
           lb(i1) = 10
           e(i1) = dm
        End If
        Goto 207
     End If
     If (m12==51) Then
        If (iabs(lb(i1))==7) Then
           lb(i1) = 2
           e(i1) = amn
           lb(i2) = 11
           e(i2) = dm
        Else
           lb(i2) = 2
           e(i2) = amn
           lb(i1) = 11
           e(i1) = dm
        End If
        Goto 207
     End If
     If (m12==52) Then
        If (iabs(lb(i1))==7) Then
           lb(i1) = 1
           e(i1) = amp
           lb(i2) = 12
           e(i2) = dm
        Else
           lb(i2) = 1
           e(i2) = amp
           lb(i1) = 12
           e(i1) = dm
        End If
        Goto 207
     End If
     If (m12==53) Then
        If (iabs(lb(i1))==7) Then
           lb(i1) = 2
           e(i1) = amn
           lb(i2) = 13
           e(i2) = dm
        Else
           lb(i2) = 2
           e(i2) = amn
           lb(i1) = 13
           e(i1) = dm
        End If
        Goto 207
     End If
     If (m12==54) Then
        If (iabs(lb(i1))==10) Then
           lb(i1) = 2
           e(i1) = amn
           lb(i2) = 13
           e(i2) = dm
        Else
           lb(i2) = 2
           e(i2) = amn
           lb(i1) = 13
           e(i1) = dm
        End If
        Goto 207
     End If
     If (m12==55) Then
        If (iabs(lb(i1))==10) Then
           lb(i1) = 1
           e(i1) = amp
           lb(i2) = 12
           e(i2) = dm
        Else
           lb(i2) = 1
           e(i2) = amp
           lb(i1) = 12
           e(i1) = dm
        End If
        Goto 207
     End If
     If (m12==56) Then
        If (iabs(lb(i1))==11) Then
           lb(i1) = 2
           e(i1) = amn
           lb(i2) = 13
           e(i2) = dm
        Else
           lb(i2) = 2
           e(i2) = amn
           lb(i1) = 13
           e(i1) = dm
        End If
        Goto 207
     End If
     If (m12==57) Then
        If (iabs(lb(i1))==11) Then
           lb(i1) = 1
           e(i1) = amp
           lb(i2) = 12
           e(i2) = dm
        Else
           lb(i2) = 1
           e(i2) = amp
           lb(i1) = 12
           e(i1) = dm
        End If
     End If
     Goto 207
206  If (m12==1) Then
        If (iabs(lb(i1))==8) Then
           lb(i2) = 2
           lb(i1) = 1
           e(i1) = amp
        Else
           lb(i1) = 2
           lb(i2) = 1
           e(i2) = amp
        End If
        Goto 207
     End If
     If (m12==2) Then
        If (iabs(lb(i1))==7) Then
           lb(i2) = 1
           lb(i1) = 2
           e(i1) = amn
        Else
           lb(i1) = 1
           lb(i2) = 2
           e(i2) = amn
        End If
        Goto 207
     End If
     If (m12==3) Then
        lb(i1) = 1
        lb(i2) = 1
        e(i1) = amp
        e(i2) = amp
        Goto 207
     End If
     If (m12==4) Then
        lb(i1) = 1
        lb(i2) = 1
        e(i1) = amp
        e(i2) = amp
        Goto 207
     End If
     If (m12==5) Then
        lb(i1) = 2
        lb(i2) = 2
        e(i1) = amn
        e(i2) = amn
        Goto 207
     End If
     If (m12==6) Then
        lb(i1) = 2
        lb(i2) = 2
        e(i1) = amn
        e(i2) = amn
        Goto 207
     End If
     If (m12==7) Then
        If (iabs(lb(i1))==1) Then
           lb(i1) = 1
           lb(i2) = 2
           e(i1) = amp
           e(i2) = amn
        Else
           lb(i1) = 2
           lb(i2) = 1
           e(i1) = amn
           e(i2) = amp
        End If
        Goto 207
     End If
     If (m12==8) Then
        If (iabs(lb(i1))==2) Then
           lb(i1) = 2
           lb(i2) = 1
           e(i1) = amn
           e(i2) = amp
        Else
           lb(i1) = 1
           lb(i2) = 2
           e(i1) = amp
           e(i2) = amn
        End If
        Goto 207
     End If
     If (m12==9) Then
        lb(i1) = 1
        lb(i2) = 1
        e(i1) = amp
        e(i2) = amp
        Goto 207
     End If
     If (m12==12) Then
        lb(i1) = 2
        lb(i2) = 1
        e(i1) = amn
        e(i2) = amp
        Goto 207
     End If
     If (m12==11) Then
        lb(i1) = 2
        lb(i2) = 1
        e(i1) = amn
        e(i2) = amp
        Goto 207
     End If
     If (m12==12) Then
        lb(i1) = 1
        lb(i2) = 2
        e(i1) = amp
        e(i2) = amn
     End If
207  pr = prf
     c1 = 1.0 - 2.0*ranart(nseed)
     If (srt<=2.14) c1 = 1.0 - 2.0*ranart(nseed)
     If (srt>2.14 .And. srt<=2.4) c1 = ang(srt, iseed)
     If (srt>2.4) Then
        xptr = 0.33*pr
        cc1 = ptr(xptr, iseed)
        scheck = pr**2 - cc1**2
        If (scheck<0) Then
           Write (99, *) 'scheck4: ', scheck
           scheck = 0.
        End If
        c1 = sqrt(scheck)/pr
     End If
     t1 = 2.0*pi*ranart(nseed)
     iblock = 3
  End If
  If (ianti==1 .And. lb(i1)>=1 .And. lb(i2)>=1) Then
     lb(i1) = -lb(i1)
     lb(i2) = -lb(i2)
  End If
107 If (px==0.0 .And. py==0.0) Then
     t2 = 0.0
  Else
     t2 = atan2(py, px)
  End If
  scheck = 1.0 - c1**2
  If (scheck<0) Then
     Write (99, *) 'scheck5: ', scheck
     scheck = 0.
  End If
  s1 = sqrt(scheck)
  scheck = 1.0 - c2**2
  If (scheck<0) Then
     Write (99, *) 'scheck6: ', scheck
     scheck = 0.
  End If
  s2 = sqrt(scheck)
  ct1 = cos(t1)
  st1 = sin(t1)
  ct2 = cos(t2)
  st2 = sin(t2)
  pz = pr*(c1*c2-s1*s2*ct1)
  ss = c2*s1*ct1 + s2*c1
  px = pr*(ss*ct2-s1*st1*st2)
  py = pr*(ss*st2+s1*st1*ct2)
  Return
306 Continue
  If (xsk5/sigk>ranart(nseed)) Then
     pz1 = p(3, i1)
     pz2 = p(3, i2)
     lb(i1) = 1 + int(2*ranart(nseed))
     lb(i2) = 1 + int(2*ranart(nseed))
     nnn = nnn + 1
     lpion(nnn, irun) = 29
     epion(nnn, irun) = aphi
     iblock = 222
     Goto 208
  End If
  iblock = 11
  If (ianti==1) iblock = -11
  pz1 = p(3, i1)
  pz2 = p(3, i2)
  nnn = nnn + 1
  lpion(nnn, irun) = 23
  epion(nnn, irun) = aka
  If (srt<=2.63) Then
     ic = 1
     lb(i1) = 1 + int(2*ranart(nseed))
     lb(i2) = 14
     Goto 208
  End If
  If (srt<=2.74 .And. srt>2.63) Then
     If (xsk1/(xsk1+xsk2)>ranart(nseed)) Then
        ic = 1
        lb(i1) = 1 + int(2*ranart(nseed))
        lb(i2) = 14
     Else
        lb(i1) = 1 + int(2*ranart(nseed))
        lb(i2) = 15 + int(3*ranart(nseed))
        ic = 2
     End If
     Goto 208
  End If
  If (srt<=2.77 .And. srt>2.74) Then
     If (xsk1/(xsk1+xsk2+xsk3)>ranart(nseed)) Then
        ic = 1
        lb(i1) = 1 + int(2*ranart(nseed))
        lb(i2) = 14
        Goto 208
     Else
        If (xsk2/(xsk2+xsk3)>ranart(nseed)) Then
           ic = 2
           lb(i1) = 1 + int(2*ranart(nseed))
           lb(i2) = 15 + int(3*ranart(nseed))
        Else
           ic = 3
           lb(i1) = 6 + int(4*ranart(nseed))
           lb(i2) = 14
        End If
        Goto 208
     End If
  End If
  If (srt>2.77) Then
     If (xsk1/(xsk1+xsk2+xsk3+xsk4)>ranart(nseed)) Then
        ic = 1
        lb(i1) = 1 + int(2*ranart(nseed))
        lb(i2) = 14
        Goto 208
     Else
        If (xsk3/(xsk2+xsk3+xsk4)>ranart(nseed)) Then
           ic = 3
           lb(i1) = 6 + int(4*ranart(nseed))
           lb(i2) = 14
           Goto 208
        Else
           If (xsk2/(xsk2+xsk4)>ranart(nseed)) Then
              lb(i1) = 1 + int(2*ranart(nseed))
              lb(i2) = 15 + int(3*ranart(nseed))
              ic = 2
           Else
              ic = 4
              lb(i1) = 6 + int(4*ranart(nseed))
              lb(i2) = 15 + int(3*ranart(nseed))
           End If
           Goto 208
        End If
     End If
  End If
208 Continue
  If (ianti==1 .And. lb(i1)>=1 .And. lb(i2)>=1) Then
     lb(i1) = -lb(i1)
     lb(i2) = -lb(i2)
     If (lpion(nnn,irun)==23) lpion(nnn, irun) = 21
  End If
  lbi1 = lb(i1)
  lbi2 = lb(i2)
  ntry1 = 0
128 Call bbkaon(ic, srt, px3, py3, pz3, dm3, px4, py4, pz4, dm4, ppx, ppy, ppz, icou1)
  ntry1 = ntry1 + 1
  If ((icou1<0) .And. (ntry1<=20)) Goto 128
  Call rotate(px, py, pz, px3, py3, pz3)
  Call rotate(px, py, pz, px4, py4, pz4)
  Call rotate(px, py, pz, ppx, ppy, ppz)
  e1cm = sqrt(dm3**2+px3**2+py3**2+pz3**2)
  p1beta = px3*betax + py3*betay + pz3*betaz
  transf = gamma*(gamma*p1beta/(gamma+1)+e1cm)
  pt1i1 = betax*transf + px3
  pt2i1 = betay*transf + py3
  pt3i1 = betaz*transf + pz3
  eti1 = dm3
  e2cm = sqrt(dm4**2+px4**2+py4**2+pz4**2)
  p2beta = px4*betax + py4*betay + pz4*betaz
  transf = gamma*(gamma*p2beta/(gamma+1.)+e2cm)
  pt1i2 = betax*transf + px4
  pt2i2 = betay*transf + py4
  pt3i2 = betaz*transf + pz4
  eti2 = dm4
  epcm = sqrt(aka**2+ppx**2+ppy**2+ppz**2)
  ppbeta = ppx*betax + ppy*betay + ppz*betaz
  transf = gamma*(gamma*ppbeta/(gamma+1.)+epcm)
  ppion(1, nnn, irun) = betax*transf + ppx
  ppion(2, nnn, irun) = betay*transf + ppy
  ppion(3, nnn, irun) = betaz*transf + ppz
  dppion(nnn, irun) = dpertp(i1)*dpertp(i2)
  rpion(1, nnn, irun) = r(1, i1)
  rpion(2, nnn, irun) = r(2, i1)
  rpion(3, nnn, irun) = r(3, i1)
  p(1, i1) = pt1i1
  p(2, i1) = pt2i1
  p(3, i1) = pt3i1
  e(i1) = eti1
  lb(i1) = lbi1
  p(1, i2) = pt1i2
  p(2, i2) = pt2i2
  p(3, i2) = pt3i2
  e(i2) = eti2
  lb(i2) = lbi2
  px1 = p(1, i1)
  py1 = p(2, i1)
  pz1 = p(3, i1)
  em1 = e(i1)
  id(i1) = 2
  id(i2) = 2
  id1 = id(i1)
  If (lpion(nnn,irun)/=29) iblock = 11
  lb1 = lb(i1)
  lb2 = lb(i2)
  am1 = em1
  am2 = em2
  e1 = sqrt(em1**2+px1**2+py1**2+pz1**2)
  Return
108 Continue
  If (idpert==1 .And. ipert1==1 .And. npertd>=1) Then
     ndloop = npertd
  Else If (idpert==2 .And. npertd>=1) Then
     ndloop = npertd + 1
  Else
     ndloop = 1
  End If
  dprob1 = sdprod/sig/float(npertd)
  Do idloop = 1, ndloop
     Call bbdangle(pxd, pyd, pzd, nt, ipert1, ianti, idloop, pfinal, dprob1, lbm)
     Call rotate(px, py, pz, pxd, pyd, pzd)
     xmass = xmd
     e1dcm = sqrt(xmass**2+pxd**2+pyd**2+pzd**2)
     p1dbeta = pxd*betax + pyd*betay + pzd*betaz
     transf = gamma*(gamma*p1dbeta/(gamma+1.)+e1dcm)
     pxi1 = betax*transf + pxd
     pyi1 = betay*transf + pyd
     pzi1 = betaz*transf + pzd
     If (ianti==0) Then
        lbd = 42
     Else
        lbd = -42
     End If
     If (idpert==1 .And. ipert1==1 .And. npertd>=1) Then
        nnn = nnn + 1
        ppion(1, nnn, irun) = pxi1
        ppion(2, nnn, irun) = pyi1
        ppion(3, nnn, irun) = pzi1
        epion(nnn, irun) = xmd
        lpion(nnn, irun) = lbd
        rpion(1, nnn, irun) = r(1, i1)
        rpion(2, nnn, irun) = r(2, i1)
        rpion(3, nnn, irun) = r(3, i1)
        dppion(nnn, irun) = sdprod/sig/float(npertd)
     Else If (idpert==2 .And. idloop<=npertd) Then
        ppd(1, idloop) = pxi1
        ppd(2, idloop) = pyi1
        ppd(3, idloop) = pzi1
        lbpd(idloop) = lbd
     Else
        e(i1) = xmm
        e2picm = sqrt(xmm**2+pxd**2+pyd**2+pzd**2)
        p2pibeta = -pxd*betax - pyd*betay - pzd*betaz
        transf = gamma*(gamma*p2pibeta/(gamma+1.)+e2picm)
        pxi2 = betax*transf - pxd
        pyi2 = betay*transf - pyd
        pzi2 = betaz*transf - pzd
        p(1, i1) = pxi2
        p(2, i1) = pyi2
        p(3, i1) = pzi2
        lb(i1) = lbm
        px1 = p(1, i1)
        py1 = p(2, i1)
        pz1 = p(3, i1)
        em1 = e(i1)
        id(i1) = 2
        id1 = id(i1)
        e1 = sqrt(em1**2+px1**2+py1**2+pz1**2)
        lb1 = lb(i1)
        p(1, i2) = pxi1
        p(2, i2) = pyi1
        p(3, i2) = pzi1
        lb(i2) = lbd
        lb2 = lb(i2)
        e(i2) = xmd
        eti2 = e(i2)
        id(i2) = 2
        If (idpert==2 .And. idloop==ndloop) Then
           Do ipertd = 1, npertd
              nnn = nnn + 1
              ppion(1, nnn, irun) = ppd(1, ipertd)
              ppion(2, nnn, irun) = ppd(2, ipertd)
              ppion(3, nnn, irun) = ppd(3, ipertd)
              epion(nnn, irun) = xmd
              lpion(nnn, irun) = lbpd(ipertd)
              rpion(1, nnn, irun) = r(1, i1)
              rpion(2, nnn, irun) = r(2, i1)
              rpion(3, nnn, irun) = r(3, i1)
              dppion(nnn, irun) = 1./float(npertd)
           End Do
        End If
     End If
  End Do
  iblock = 501
  Return
End Subroutine crnd