      SUBROUTINE zrrst(
       !------------------!
       ! file/record info !
       !------------------!
     * IFLTAB, ! file table
     * CPATH,  ! pathname
       !--------------!
       ! general info !
       !--------------!
     * IETIM,  ! effective time (minutes since 31Dec1899 00:00)
     * CLOC,   ! location string
     * CATIM,  ! activated time string
     * CHPARM, ! height parameter string
     * CHUNIT, ! height units string
     * CFPARM, ! flow parameter string
     * CFUNIT, ! flow units string
     * CCMT,   ! comment string
     * COPT,   ! option string
     * LSNUM,  ! flag specifying if rating has serial number
     * ISNUM,  ! rating serial number
     * LDATUM, ! flag specifying if rating has datum elevation
     * DATUM,  ! rating datum elevation
       !------------------!
       ! base rating info !
       !------------------!
     * LSTAGE, ! flag for stage heights (vs elevation heights)
     * IBHI,   ! height interpolation type for base curve
     * IBHU,   ! height underflow handling type for base curve
     * HUV,    ! height underflow value (may or may not be used)
     * IBHO,   ! height overflow handling type for base curve
     * HOV,    ! height overflow value (may or may not be used)
     * IBFI,   ! flow interpolation type for base curve
     * IBFU,   ! flow underflow handling type for base curve
     * FUV,    ! flow underflow value (may or may not be used)
     * IBFO,   ! flow overflow handling type for base curve
     * FOV,    ! flow overflow value (may or may not be used)
     * KBASE,  ! dimenson of height & flow arrays (must be at least
               ! nbase)
     * NBASE,  ! number of points in base curve
     * HEIGHT, ! stages or elevations
     * FLOW,   ! flows
       !------------!
       ! shift info !
       !------------!
     * KSHIFT, ! dimension of arrays related to shifts (must be at
               ! least nshift)
     * NSHIFT, ! number of constant or variable shifts
     * ISTI,   ! interpolation type for shift effective times
     * ISTU,   ! underflow handling type for shift effective times
     * ISTO,   ! overflow handling type for shift effective times
     * ISBI,   ! interpolation type for shift breakpoints for each shift
     * ISBU,   ! underflow handling type for shift breakpoints for each
               ! shift
     * SBUV,   ! shift breakpoints underflow values for each shift
     * ISBO,   ! overflow handling type for shift breakpoints for each
               ! shift
     * SBOV,   ! shift breakpoints overflow values for each shift
     * ISHI,   ! interpolation type for shift heights for each shift
     * ISHU,   ! underflow handling type for shift heights for each
               ! shift
     * SHUV,   ! shift heights underflow values for each shift
     * ISHO,   ! overflow handling type for shift heights for each shift
     * SHOV,   ! shift heights overflow values for each shift
     * LATMSK, ! masks specifying whether each shift has activated time
     * JBDATE, ! julian base date for shift times
     * IETIME, ! effective times for shifts (minutes relative to jbdate)
     * IATIME, ! activated times for shifts (minutes relative to jbdate)
     * NSHFTP, ! number of variable shift breakpoints for each shift
               ! (0 = constant shift)
     * KSHVAL, ! dimension of shifts array (must be at least nshval)
     * NSHVAL, ! total number of number of shift point values
     * SHIFTS, ! shift points (for each shift, constant shift or
               ! break(1), height(1),...break(n),height(n))
       !-------------!
       ! offset info !
       !-------------!
     * LCOFF,  ! flag specifying whether a constant offset is used
     * COFVAL, ! constant offset value
     * KOFF,   ! dimension of offset array (must be at least noff * 2)
     * NOFF,   ! number of variable offset breakpoint, height pairs
     * IOBI,   ! interpolation type for variable offset breakpoints
     * IOBU,   ! underflow handling type for variable offset breakpoints
     * OBUV,   ! offset breakpoint underflow value (may or may not be
               ! used)
     * IOBO,   ! overflow handling type for variable offset breakpoints
     * OBOV,   ! offset breakpoint oferflow value (may or may not be
               ! used)
     * IOHI,   ! interpolation type for variable offset heights
     * IOHU,   ! underflow handling type for variable offset heights
     * OHUV,   ! offset height underflow value (may or may not be used)
     * IOHO,   ! overflow handling type for variable offset heights
     * OHOV,   ! offset height oferflow value (may or may not be used)
     * OFFSET, ! variable offset values (break(1), height(1),...
               ! break(n),height(n))
       !-----------!
       ! misc info !
       !-----------!
     * IHORIZ, ! horizontal axis
     * ISTAT   ! success/failure status
     * )
c
c     Retrieve STREAM RATING
c
c     Mike Perryman
c     Nov, 2003
c
      PARAMETER (KUHEAD=400)
      PARAMETER (KCHEAD=1)

      INTEGER*4 IFLTAB(*), IETIM, ISNUM, IBHI, IBHO, IBHU, IBFI, IBFO,
     * IBFU, NBASE, NSHIFT, ISTI, ISTU, ISTO, ISBI(*), ISBU(*), ISBO(*),
     * ISHI(*), ISHU(*), ISHO(*), JBDATE, IETIME(*), IATIME(*),
     * NSHFTP(*), NOFF, IOBI, IOBU, IOBO, IOHI, IOHU, IOHO, IHORIZ,
     * ISTAT, NPATH, NVALS, JTYPE, NGBFU, NCHEAD, ICHEAD(KCHEAD),
     * NUHEAD, IUHEAD(KUHEAD), NATIME, NA, NB, NC, ND, NE, NF

      CHARACTER CPATH*(*), CLOC*(*), CATIM*(*), CHPARM*(*), CHUNIT*(*),
     * CFPARM*(*), CFUNIT*(*), CCMT*(*), COPT*(*), CA*80, CB*80, CC*80,
     * CD*80, CE*80, CF*80, CTEMP1*80

      LOGICAL*4 LSNUM, LDATUM, LSTAGE, LATMSK(*), LCOFF, LFOUND

      REAL*4 DATUM, HUV, HOV, FUV, FOV, HEIGHT(*), FLOW(*), SBUV(*),
     * SBOV(*), SHUV(*), SHOV(*), SHIFTS(*), COFVAL, OBUV, OBOV, OHUV,
     * OHOV, OFFSET(*), RCHEAD(KCHEAD), RUHEAD(KUHEAD)

      EQUIVALENCE (IUHEAD, RUHEAD)
      EQUIVALENCE (ICHEAD, RCHEAD)

      INCLUDE 'zdsskz.h'
      INCLUDE 'zdssiz.h'
      INCLUDE 'zdssmz.h'
      INCLUDE 'zdssbf.h'
      INCLUDE 'zdssrst.h'

      CALL CHRLNB(CPATH, NPATH)

      !---------------------!
      ! debug entry message !
      !---------------------!
      IF (MLEVEL .GE. 7) THEN
         WRITE(MUNIT, 10) KBASE, KSHIFT, KOFF, CPATH(1:NPATH)
      END IF
   10 FORMAT (T5, '----- Enter zrrst -----', /,
     * T11, 'KBASE:', I6, ', KSHIFT:', I4, ', KOFF:', I4, /,
     * T11, 'Pathname: ', A)
      !-------------------------------------------------------------!
      ! determine whether the record exists and is of expected type !
      !-------------------------------------------------------------!
      CALL zdtype(IFLTAB, CPATH, NVALS, LFOUND, CTEMP1, JTYPE)
      IF (.NOT. LFOUND) GO TO 9990
      IF (JTYPE .NE. 560) GO TO 9980
      IF (NVALS .GT. MXVAL) GO TO 9970
      !--------------------------------------------------------!
      ! get the effective time from the d part of the pathname !
      !--------------------------------------------------------!
      CALL zufpn(CA, NA, CB, NB, CC, NC, CD, ND, CE, NE, CF, NF,
     * CPATH, NPATH, ISTAT)
      IF (ISTAT .NE. 0 .OR. ND .LT. 7) GO TO 9960
      CALL RATTIM(CD, ND, IETIM, ISTAT)
      IF (ISTAT .NE. 0) GO TO 9960
      !-----------------!
      ! read the record !
      !-----------------!
      CALL zreadx(IFLTAB, CPATH(1:NPATH), IGBUFF, NGBUFF, NGBFU,
     * RCHEAD, KCHEAD, NCHEAD, RUHEAD, KUHEAD, NUHEAD, RVALS, MXVAL,
     * NVALS, 0, LFOUND)
      IF (.NOT. LFOUND) GO TO 9990
      !-------------------------------------!
      ! un-stuff the record internal header !
      !-------------------------------------!
      IF (NGBFU .LT. 16) GO TO 9950
      NBASE  = IGBUFF(1)
      NSHIFT = IGBUFF(2)
      NATIME = IGBUFF(3)
      IHORIZ = IGBUFF(4)
      LSTAGE = IGBUFF(5) .EQ. 1
      IBHI   = IGBUFF(6)
      IBHO   = IGBUFF(7)
      IBHU   = IGBUFF(8)
      IBFI   = IGBUFF(9)
      IBFO   = IGBUFF(10)
      IBFU   = IGBUFF(11)
      ISTI   = IGBUFF(12)
      ISTU   = IGBUFF(13)
      ISTO   = IGBUFF(14)
      JBDATE = IGBUFF(15)
      NOFF   = IGBUFF(16)
      IF (NBASE  .GT. KBASE ) GO TO 9940
      IF (NSHIFT .GT. KSHIFT) GO TO 9930
      IF (NOFF   .GT. KOFF * 2) GO TO 9920
      !---------------------------------!
      ! un-stuff the record user header !
      !---------------------------------!
      CALL UNSTUFFUSERHEADER('LOC', CLOC, IPOS, RUHEAD, NUHEAD,
     * ISTAT)
      CALL UNSTUFFUSERHEADER('ATIM', CATIM, IPOS, RUHEAD, NUHEAD,
     * ISTAT)
      CALL UNSTUFFUSERHEADER('HPARM', CHPARM, IPOS, RUHEAD, NUHEAD,
     * ISTAT)
      CALL UNSTUFFUSERHEADER('HUNIT', CHUNIT, IPOS, RUHEAD, NUHEAD,
     * ISTAT)
      CALL UNSTUFFUSERHEADER('FPARM', CFPARM, IPOS, RUHEAD, NUHEAD,
     * ISTAT)
      CALL UNSTUFFUSERHEADER('FUNIT', CFUNIT, IPOS, RUHEAD, NUHEAD,
     * ISTAT)
      CALL UNSTUFFUSERHEADER('COMMENT', CCMT, IPOS, RUHEAD, NUHEAD,
     * ISTAT)
      CALL UNSTUFFUSERHEADER('OPTION', COPT, IPOS, RUHEAD, NUHEAD,
     * ISTAT)
      CALL UNSTUFFUSERHEADER('SERIAL', CTEMP1, IPOS, RUHEAD, NUHEAD,
     * ISTAT)
      CALL CHRLNB(CTEMP1, NTEMP1)
      IF (NTEMP1 .GT. 0) THEN
         LSNUM = .TRUE.
      ELSE
         LSNUM = .FALSE.
      END IF
      CALL UNSTUFFUSERHEADER('DATUM', CTEMP1, IPOS, RUHEAD, NUHEAD,
     * ISTAT)
      CALL CHRLNB(CTEMP1, NTEMP1)
      IF (NTEMP1 .GT. 0) THEN
         LDATUM = .TRUE.
      ELSE
         LDATUM = .FALSE.
      END IF
      CALL UNSTUFFUSERHEADER('OFFSET', CTEMP1, IPOS, RUHEAD, NUHEAD,
     * ISTAT)
      CALL CHRLNB(CTEMP1, NTEMP1)
      IF (NTEMP1 .GT. 0) THEN
         LCOFF = .TRUE.
      ELSE
         LCOFF = .FALSE.
      END IF
      !---------------------------------!
      ! un-stuff the record data values !
      !---------------------------------!
      HUV    = RVALS(1)
      HOV    = RVALS(2)
      FUV    = RVALS(3)
      FOV    = RVALS(4)
      ISNUM  = IVALS(5)
      DATUM  = RVALS(6)
      COFVAL = RVALS(7)
      IDX = 8

      DO I = 1, NBASE
         HEIGHT(I) = RVALS(IDX+2*(I-1)+0)
         FLOW(I)   = RVALS(IDX+2*(I-1)+1)
      END DO
      IDX = IDX + NBASE * 2

      NATMSK = (NSHIFT - 1) / 32 + 1
      DO I = 1, NATMSK
         IATMSK(I) = IVALS(IDX+I-1)
      END DO
      IDX = IDX + NATMSK

      IOFFSET = 0
      DO I = 1, NSHIFT
         IBIT = I - 1
         IWORD = IBIT / 32
         IBIT = IBIT - (IWORD * 32)
         IWORD = IWORD + 1
         IF (IAND(IATMSK(IWORD), 2 ** IBIT) .NE. 0) THEN
            LATMSK(I) = .TRUE.
            IATIME(I) = IVALS(IDX + IOFFSET)
            IOFFSET = IOFFSET + 1
         ELSE
            LATMSK(I) = .FALSE.
         END IF
      END DO
      IF (IOFFSET .NE. NATIME) GO TO 9880
      IDX = IDX + NATIME

      NSHVAL = 0
      DO I = 1, NSHIFT
         IETIME(I) = IVALS(IDX+12*(I-1)+0)
         NSHFTP(I) = IVALS(IDX+12*(I-1)+1)
         ISBI(I)   = IVALS(IDX+12*(I-1)+2)
         ISBU(I)   = IVALS(IDX+12*(I-1)+3)
         SBUV(I)   = RVALS(IDX+12*(I-1)+4)
         ISBO(I)   = IVALS(IDX+12*(I-1)+5)
         SBOV(I)   = RVALS(IDX+12*(I-1)+6)
         ISHI(I)   = IVALS(IDX+12*(I-1)+7)
         ISHU(I)   = IVALS(IDX+12*(I-1)+8)
         SHUV(I)   = RVALS(IDX+12*(I-1)+9)
         ISHO(I)   = IVALS(IDX+12*(I-1)+10)
         SHOV(I)   = RVALS(IDX+12*(I-1)+11)
         IF (NSHFTP(I) .EQ. 0) THEN
            NSHVAL = NSHVAL + 1
         ELSE
            NSHVAL = NSHVAL + 2 * NSHFTP(I)
         END IF
      END DO
      IDX = IDX + NSHIFT * 12
      IF (KSHVAL .LT. NSHVAL) GO TO 9870

      DO I = 1, NSHVAL
         SHIFTS(I) = RVALS(IDX+I-1)
      END DO
      IDX = IDX + NSHVAL

      IF (NOFF .GT. 0) THEN
         IOBI = IVALS(IDX+0)
         IOBU = IVALS(IDX+1)
         OBUV = RVALS(IDX+2)
         IOBO = IVALS(IDX+3)
         OBOV = RVALS(IDX+4)
         IOHI = IVALS(IDX+5)
         IOHU = IVALS(IDX+6)
         OHUV = RVALS(IDX+7)
         IOHO = IVALS(IDX+8)
         OHOV = RVALS(IDX+9)
         IDX = IDX + 10
         DO I = 1, NOFF * 2
             OFFSET(I) = RVALS(IDX+I-1)
         END DO
      END IF

      ISTAT = 0
      GO TO 9999
      !----------------!
      ! error handlers !
      !----------------!
 9870 CONTINUE
      IF (MLEVEL .GT. 1) WRITE (MUNIT, 9871) NSHVAL, KSHVAL,
     * CPATH(1:NPATH)
 9871 FORMAT (/, ' -----DSS---zrrst:  ERROR;  Record has more shift',
     * ' values than dimensioned with KSHVAL.',/,
     * T11, ' Number of shift values: ', I4, /,
     * T11, ' KSHVAL:                 ', I4, /,
     * T11, ' Pathname: ', a, /)
      ISTAT = -11
      GO TO 9999

 9880 CONTINUE
      IF (MLEVEL .GT. 1) WRITE (MUNIT, 9881) NATIME, IOFFSET,
     * CPATH(1:NPATH)
 9881 FORMAT (/, ' -----DSS---zrrst:  ERROR;  Number of shift',
     * ' activated times in record does not agree with the',/
     * ' number of shift activated times specified in the header.', /
     * T11, ' Number specified in header: ', I4, /,
     * T11, ' Number in record:           ', I4, /,
     * T11, ' Pathname: ', a, /)
      ISTAT = -10
      GO TO 9999

 9890 CONTINUE
      IF (MLEVEL .GT. 1) WRITE (MUNIT, 9891) CTEMP1(1:NTEMP1),
     * CPATH(1:NPATH)
 9891 FORMAT (/, ' -----DSS---zrrst:  ERROR;  Cannot read real',
     * ' value for constant offset from user header item.' ,/,
     * T11, ' User header label: OFFSET', /,
     * T11, ' User header item:  ', A, /,
     * T11, ' Pathname: ', A, /)
      ISTAT = -9
      GO TO 9999

 9900 CONTINUE
      IF (MLEVEL .GT. 1) WRITE (MUNIT, 9901) CTEMP1(1:NTEMP1),
     * CPATH(1:NPATH)
 9901 FORMAT (/, ' -----DSS---zrrst:  ERROR;  Cannot read real',
     * ' value for datum elevation from user header item.' ,/,
     * T11, ' User header label: DATUM', /,
     * T11, ' User header item:  ', A, /,
     * T11, ' Pathname: ', A, /)
      ISTAT = -9
      GO TO 9999

 9910 CONTINUE
      IF (MLEVEL .GT. 1) WRITE (MUNIT, 9911) CTEMP1(1:NTEMP1),
     * CPATH(1:NPATH)
 9911 FORMAT (/, ' -----DSS---zrrst:  ERROR;  Cannot read integer',
     * ' value for serial number from user header item.' ,/,
     * T11, ' User header label: SERIAL', /,
     * T11, ' User header item:  ', A, /,
     * T11, ' Pathname: ', A, /)
      ISTAT = -9
      GO TO 9999

 9920 CONTINUE
      IF (MLEVEL .GT. 1) WRITE (MUNIT, 9921) NOFF * 2, KOFF,
     * CPATH(1:NPATH)
 9921 FORMAT (/, ' -----DSS---zrrst:  ERROR;  Record has more values',
     * ' for variable offsets than dimensioned with KOFF.',/,
     * T11, ' Number of values: ', I4, /,
     * T11, ' KOFF:             ', I4, /,
     * T11, ' Pathname: ', A, /)
      ISTAT = -8
      GO TO 9999

 9930 CONTINUE
      IF (MLEVEL .GT. 1) WRITE (MUNIT, 9931) NSHIFT, KSHIFT,
     * CPATH(1:NPATH)
 9931 FORMAT (/, ' -----DSS---zrrst:  ERROR;  Record has more shifts',
     * ' than dimensioned with KSHIFT.',/,
     * T11, ' Number of shifts: ', I4, /,
     * T11, ' KSHIFT:           ', I4, /,
     * T11, ' Pathname: ', A, /)
      ISTAT = -7
      GO TO 9999

 9940 CONTINUE
      IF (MLEVEL .GT. 1) WRITE (MUNIT, 9941) NBASE, KBASE,
     * CPATH(1:NPATH)
 9941 FORMAT (/, ' -----DSS---zrrst:  ERROR;  Record has more values',
     * ' in base curve than dimensioned with KBASE.',/,
     * T11, ' Number of values: ', I4, /,
     * T11, ' KBASE:            ', I4, /,
     * T11, ' Pathname: ', A, /)
      ISTAT = -6
      GO TO 9999

 9950 CONTINUE
      IF (MLEVEL .GT. 1) WRITE (MUNIT, 9951) NGBFU, 16, CPATH(1:NPATH)
 9951 FORMAT (/, ' -----DSS---zrrst:  ERROR;  Record has fewer values',
     * ' in then interal header than expected.',/,
     * T11, ' Number of values: ', I3, /,
     * T11, ' Expected:         ', I3, /,
     * T11, ' Pathname: ', A, /)
      ISTAT = -5
      GO TO 9999

 9960 CONTINUE
      IF (MLEVEL .GT. 1) WRITE (MUNIT, 9961) CPATH(1:NPATH)
 9961 FORMAT (/, ' -----DSS---zrrst:  ERROR;  Cannot determine',
     * ' effective time of rating from pathname.',/,
     * T11, ' Pathname: ', A, /)
      ISTAT = -4
      GO TO 9999

 9970 CONTINUE
      IF (MLEVEL .GT. 1) WRITE (MUNIT, 9971) NVALS, MXVAL,
     * CPATH(1:NPATH)
 9971 FORMAT (/, ' -----DSS---zrrst:  ERROR;  Record has more values',
     * ' than current limit.',/,
     * T11, ' Number of values: ', I6, /,
     * T11, ' Current limit:    ', I6, /,
     * T11, ' Pathname: ', A, /)
      ISTAT = -3
      GO TO 9999

 9980 CONTINUE
      IF (MLEVEL .GT. 1) WRITE (MUNIT, 9981) JTYPE, 560, CPATH(1:NPATH),
     * CPATH(1:NPATH)
 9981 FORMAT (/, ' -----DSS---zrrst:  ERROR;  The Record type does',
     * ' not match the expected record type.', /,
     * T11, ' Expected type:', I4, /,
     * T11, ' Record type:  ', I4, /,
     * T11, ' Pathname: ', A, /)
      ISTAT = -2
      GO TO 9999

 9990 CONTINUE
      IF (MLEVEL .GT. 1) WRITE (MUNIT, 9991) CPATH(1:NPATH)
 9991 FORMAT (/, ' -----DSS---zrrst:  ERROR;  Record does not exist.', /
     * T11, ' Pathname: ', A, /)
      ISTAT = 1
      GO TO 9999

 9998 FORMAT (t5, '----- Exit zrrst, Number data values retrieved:', I5,
     * ', Number shifts retrieved:', I4, ', Status:', I4, /)

      !-------------------!
      ! normal exit point !
      !-------------------!
 9999 CONTINUE
      !--------------------!
      ! debug exit message !
      !--------------------!
      IF (MLEVEL .GT. 7) WRITE (MUNIT, 9998) NBASE, NSHIFT, ISTAT
      RETURN
      END
C=======================================================================

      SUBROUTINE UNSTUFFUSERHEADER(LABEL, ITEM, IPOS, RUHEAD, NUHEAD,
     * ISTAT)

      CHARACTER LABEL*(*), ITEM*(*), LOCALLABEL*60, CCHUNK*60
      REAL*4 RUHEAD(*)
      LOGICAL LEXITLOOP
      INTEGER*4 NUHEAD, ISTAT

      CALL zustfh(LABEL, CCHUNK, 1, IPOS, RUHEAD, NUHEAD, ISTAT)
      ITEM = CCHUNK(1:60)
      I = 2
      LEXITLOOP = .FALSE.
      DO WHILE (.NOT. LEXITLOOP)
         WRITE(LOCALLABEL(1:), *)LABEL, I
         CALL zustfh(LOCALLABEL, CCHUNK,1, IPOS, RUHEAD, NUHEAD, ISTAT)
         CALL CHRLNB(CCHUNK, NCHUNK)
         IF (NCHUNK .GE. 1) THEN
            ITEM((I-1)*60+1:I*60) = CCHUNK(1:60)
            I = I + 1
         ELSE
            LEXITLOOP = .TRUE.
         END IF
      END DO

      CALL CHRLNB(ITEM, NITEM)
      DO I = 1, NITEM
         IF (ITEM(I:I) .EQ. '~') ITEM(I:I) = ':'
         IF (ITEM(I:I) .EQ. '`') ITEM(I:I) = ';'
      END DO
      RETURN
      END


subroutine phenolcn(aepa,antss,pdepth,bhfwsf,blstrs,cliname,cname,daa,dae,dap,  &
                  & daynum,ddae,ddap,dents,dgdde,dgdds,doughs,dummy2,ears,      &
                  & emrgflg,ems,first7,gdda,gdde,gdds,gddwsf,gmethod,hrs,ies,   &
                  & lf12s,lf4s,lnpout,mats,milks,pchron,pdate,seedbed,silks,    &
                  & tsints,year,endphenol)
!
!  the phenolcn subroutine ... finish description here.
!
!  inputs: antss(c,r),
!          daynum(r), dae(r), dap(r),
!          ddae(c), ddap(c), dgdde(c), dgdds(c),
!          ems(c), first7(c,r),
!          gdde(r), gdds(r),
!          hrs(c,r), ies(c,r),
!          mats(c,r), pchron(r),

! outputs: antss(c,r), ddae((20)c),
!          ddap(20)(c), dgdde(20)(c), dgdds(20)(c),
!          first7(c,r),
!          hrs(c,r), ies(c,r), mats(c,r),
!
implicit none
!
include 'file.fi'
!
! Dummy arguments
!
real :: aepa,bhfwsf,gdda,gdde,gdds,pchron,pdepth
character(80) :: cliname
character(80) :: cname,seedbed
integer :: daa,dae,dap,daynum,emrgflg,first7,gmethod,pdate,year
logical :: endphenol
integer,dimension(4) :: antss,blstrs,dents,doughs,ears,ems,hrs,ies,lf12s,lf4s,  &
                      & mats,milks,silks,tsints
integer,dimension(20) :: ddae,ddap
real,dimension(20) :: dgdde,dgdds
real,dimension(30) :: dummy2
real,dimension(15,5) :: gddwsf
real,dimension(100,2) :: lnpout
!
! Local variables
!
real :: adjgdd
integer :: i,j,row
integer,dimension(4) :: pdatearr
!
!debe changed upgm variable name 'bc0growdepth' to phenologymms variable name
!of 'pdepth' to maintain consistency with phenologymms code.
!debe added for writing out phenology info to a file.
!
!debe changed dimensions of dummy 2 arrays for stressed and non-stressed
! values.
!debe added bhfwsf to the call to each crop's phenol subroutine to
! implement daily water stress effect on time of reaching a growth stage
!debe added initialized gddwsf array.
!
!debe added this variable to stop the call to phenol
!debe added cliname to write the climate location name to phenol.out

!   local variables
!
!     + + + argument definitions + + +
!     adjgdd - the adjusted gdd required to enter a growth stage.
!     aepa - the parameter for duration of anthesis (i.e., gdd from start
!            to end of anthesis.
!     antss - tasseling, the start of anthesis growth stage. this array
!             includes daynum, year, month and day of when this stage was
!             reached.
!     bhfwsf - water stress factor ratio (0-1).  this is read in daily.
!     blstrs - blister growth stage. this array includes daynum, year, month
!              and day of when this stage was reached.
!     cliname - the name of the location for the climate data.
!     cname - crop name.
!     daa - days after anthesis.
!     dae - days after emergence.
!     dap - days after planting.
!     daynum - the current day numbered from jan 1.
!     ddae - an array holding the dae for each growth stage.
!     ddap - an array holding the dap for each growth stage.
!     dents - the dent growth stage in corn. this array includes daynum,
!             year, month and day of when this stage was reached.
!     dgdde - an array holding the gdde for each growth stage.
!     dgdds - an array holding the gdds for each growth stage.
!     doughs - the dough growth stage in corn. this array includes daynum,
!              year, month and day of when this stage was reached.
!     dummy2 - an array to hold the gdd values, both under stressed
!              and non- stressed conditions,required to reach each growth
!              stage of the current crop.
!     ears - the ear initiation stage in corn. this array includes daynum,
!            year, month and day of when this stage was reached.
!     emrgflg - a flag to determine if the new emerge subroutine should be
!               called (emrgflg=1) or to proceed with the weps/upgm method
!               of achieving emergence (emrgflg=0).
!     ems - day when emergence occurred. this array includes daynum, year,
!             month and day of when this event occurred.
!     endphenol - a flag to indicate if this subroutine should be called
!                 again on the next day.
!     first7 - used to set the value of aepa the first time phenolcn is called.
!     gdda - growing degree days from anthesis.
!     gdde - growing degree days from emergence.
!     gdds - growing degree days from seeding.
!     gddwsf - an array to hold the gn and gs gdd values plus the high and
!              low water stress factor values.  these are used in calculating
!              the slope of the line for each growth stage and this is then
!              used to calculate the adjusted gdd value for the current
!              growth stage.
!              column one contains the gn values and is y2.
!              column two contains the gs value and is y1.
!              column three contains wsfhi (high water stress) and is x1.
!              column four contains wsflo (low water stress) and is x2.
!              column five contains the adjgdd value for the stage.
!     gmethod - selects the method whereby gdd will be calculated.  a value
!               of 1 corresponds to method 1 in phenologymms and is used
!               for crops such as winter wheat, winter barley and proso
!               millet. a value of 2 corresponds to method 2 in
!               phenologymms and is used for crops such as corn, sorghum
!               and sunflower.  a value of 3 is the way that weps/upgm
!               calculated ggd for the day.
!     hrs - time to harvest ripe growth stage. this array includes daynum,
!           year, month and day of when this stage was reached.
!     ies - start of internode elongation growth stage. this array includes
!           daynum, year, month and day of when this stage was reached.
!     lf12s - the 12 leaf growth stage. this array includes daynum,
!             year, month and day of when this stage was reached.
!     lf4s - the 4 leaf growth stage. this array includes daynum, year,
!            month and day of when this stage was reached.
!     lnpout - an array used in writing out daynum and the number of leaves
!              on that day.  the values are written each time a new leaf has
!              appeared.
!     mats - physiological maturity growth stage. this array includes daynum,
!            year, month and day of when this stage was reached.
!     milks - the milk growth stage. this array includes daynum, year, month
!             and day of when this stage was reached.
!     pchron - phyllochron value which is the number of gdd per leaf.
!     pdate - planting date.
!     pdepth - depth of growing point at time of planting (m).
!              bc0growdepth is assed into pdepth.
!     seedbed - contains the soil moisture condition of the seedbed.
!     silks - the silking growth stage. this array includes daynum, year,
!             month and day of when this stage was reached.
!     tsints - tassel initiation growth stage. this array includes daynum,
!              year, month and day of when this stage was reached.
!     year - year.

!     + + + local variable definitions + + +
!     i - this tells which row is to be read in from the dummy2 array.
!     j - a counter variable for outputting the leaf number array.
!     pdatearr - the planting date array. it contains the daynum,
!                year, month and day that planting occurred.
!     row - this holds the row to be filled in the gddwsf array in the
!           water_stress subroutine.

! note: check what aepa should be set to for corn.
!  aepa = anthesis end parameter
if (first7==0) then
  aepa = 120.        ! this is the value for crops which use method 1
                     ! for gdd calculation.
                ! note: need to change this value because corn uses method 2.
  first7 = 1
end if

!debe try pdatearr filling here so that year will not be 0
! fill pdatearr
if (year>=1) then           !debe try to make upgm work with years gt 2
  pdatearr(1) = pdate
  pdatearr(2) = year
  call date1(pdatearr)
end if

! emergence has occurred so fill the first row in the gddwsf array (only
! print for the first period from e to 4th leaf stage):
if ((ems(1)/=999).and.(lf4s(1)==999)) then
  row = 1
  i = 1
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
end if

!
! *******   fill growth stage arrays   *******

!debe added code to change the adjusted value in gddwsf only when
! the growth stage has been reached.

!debe adjusted the code for stages that needed to be accumulating
! gdd's simultaneously. that is they are not dependent on the previous
! stage's completion before the stage can begin.
!note: use 'elseif' only when the stage is dependent upon the completion
! of the previous stage before it can begin. otherwise use 'endif' and
! end the 'if' block for that stage.
!
!  4th leaf stage - v4:
if (lf4s(1)==999) then
  row = 2
  i = 2
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
  if (gdde>=gddwsf(2,5)) then
     lf4s(1) = daynum
     lf4s(2) = year
     call date1(lf4s)
     ddap(2) = dap
     ddae(2) = dae
     dgdds(2) = gdds
     dgdde(2) = gdde
     print *,'lf4s = ',lf4s
  end if

!  tassel initiation growth stage:
else if (tsints(1)==999) then
  row = 3
  i = 3
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
  if (gdde>=(gddwsf(2,5)+gddwsf(3,5))) then
     tsints(1) = daynum
     tsints(2) = year
     call date1(tsints)
     ddap(3) = dap
     ddae(3) = dae
     dgdds(3) = gdds
     dgdde(3) = gdde
     print *,'tsints = ',tsints
  end if
end if

! ear formation stage
if (ears(1)==999) then
  row = 4
  i = 4
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
  if (gdde>=(gddwsf(2,5)+gddwsf(4,5))) then
     ears(1) = daynum
     ears(2) = year
     call date1(ears)
     ddap(4) = dap
     ddae(4) = dae
     dgdds(4) = gdds
     dgdde(4) = gdde
     print *,'ears = ',ears
  end if
end if

!  start of internode elongation:
if (ies(1)==999) then
  row = 5
  i = 5
!  print*, 'in phenolcn before call to water_stress in ies, dummy2(5) = ', &
 ! & dummy2(5)
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
  if ((gdde>=gddwsf(2,5)+gddwsf(5,5))) then
     ies(1) = daynum
     ies(2) = year
     call date1(ies)
     ddap(5) = dap
     ddae(5) = dae
     dgdds(5) = gdds
     dgdde(5) = gdde
     print *,'ies = ',ies
  end if
end if

!  12th leaf stage v12
if (lf12s(1)==999) then
  row = 6
  i = 6
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
  if (gdde>=(gddwsf(2,5)+gddwsf(6,5))) then
     lf12s(1) = daynum
     lf12s(2) = year
     call date1(lf12s)
     ddap(6) = dap
     ddae(6) = dae
     dgdds(6) = gdds
     dgdde(6) = gdde
     print *,'lf12s = ',lf12s
  end if

!  tasseling stage and silking stages occur about the same day.
!
!debe use elseif because this stage is dependent upon the completion of
! the previous stage.
else if (antss(1)==999) then
  row = 7
  i = 7
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
  if (gdde>=(gddwsf(2,5)+gddwsf(6,5)+gddwsf(7,5))) then
     antss(1) = daynum
     antss(2) = year
     call date1(antss)
     ddap(7) = dap
     ddae(7) = dae
     dgdds(7) = gdds
     dgdde(7) = gdde
     print *,'antss = ',antss
  end if
end if

!  silking growth stage.  this is the first reproductive stage r1.
if (silks(1)==999) then
  row = 8
  i = 8
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
  if (gdde>=(gddwsf(2,5)+gddwsf(6,5)+gddwsf(8,5))) then
     silks(1) = daynum
     silks(2) = year
     call date1(silks)
     ddap(8) = dap
     ddae(8) = dae
     dgdds(8) = gdds
     dgdde(8) = gdde
     print *,'silks = ',silks
  end if

!  blister growth stage - r2
else if (blstrs(1)==999) then
  row = 9
  i = 9
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
  if (gdde>=(gddwsf(2,5)+gddwsf(6,5)+gddwsf(8,5)+gddwsf(9,5))) then
     blstrs(1) = daynum
     blstrs(2) = year
     call date1(blstrs)
     ddap(9) = dap
     ddae(9) = dae
     dgdds(9) = gdds
     dgdde(9) = gdde
     print *,'blstrs = ',blstrs
  end if

!  milk growth stage - r3
else if (milks(1)==999) then
  row = 10
  i = 10
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
  if (gdde>=(gddwsf(2,5)+gddwsf(6,5)+gddwsf(8,5)+gddwsf(9,5)+gddwsf(10,5))) then
     milks(1) = daynum
     milks(2) = year
     call date1(milks)
     ddap(10) = dap
     ddae(10) = dae
     dgdds(10) = gdds
     dgdde(10) = gdde
     print *,'milks = ',milks
  end if

!  dough growth stage - r4
else if (doughs(1)==999) then
  row = 11
  i = 11
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
  if (gdde>=(gddwsf(2,5)+gddwsf(6,5)+gddwsf(8,5)+gddwsf(9,5)+gddwsf(10,5)       &
    & +gddwsf(11,5))) then
     doughs(1) = daynum
     doughs(2) = year
     call date1(doughs)
     ddap(11) = dap
     ddae(11) = dae
     dgdds(11) = gdds
     dgdde(11) = gdde
     print *,'doughs = ',doughs
  end if

!  dent growth stage - r5
else if (dents(1)==999) then
  row = 12
  i = 12
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
  if (gdde>=(gddwsf(2,5)+gddwsf(6,5)+gddwsf(8,5)+gddwsf(9,5)+gddwsf(10,5)       &
    & +gddwsf(11,5)+gddwsf(12,5))) then
     dents(1) = daynum
     dents(2) = year
     call date1(dents)
     ddap(12) = dap
     ddae(12) = dae
     dgdds(12) = gdds
     dgdde(12) = gdde
     print *,'dents = ',dents
  end if

! physiological maturity growth stage - r6
else if (mats(1)==999) then
  row = 13
  i = 13
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
  if (gdde>=(gddwsf(2,5)+gddwsf(6,5)+gddwsf(8,5)+gddwsf(9,5)+gddwsf(10,5)       &
    & +gddwsf(11,5)+gddwsf(12,5)+gddwsf(13,5))) then
     mats(1) = daynum
     mats(2) = year
     call date1(mats)
     ddap(13) = dap
     ddae(13) = dae
     dgdds(13) = gdds
     dgdde(13) = gdde
     print *,'mats = ',mats
  end if

! harvest ready growth stage
else if (hrs(1)==999) then
  row = 14
  i = 14
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
  if (gdde>=(gddwsf(2,5)+gddwsf(6,5)+gddwsf(8,5)+gddwsf(9,5)+gddwsf(10,5)       &
    & +gddwsf(11,5)+gddwsf(12,5)+gddwsf(13,5)+gddwsf(14,5))) then
     hrs(1) = daynum
     hrs(2) = year
     call date1(hrs)
     ddap(14) = dap
     ddae(14) = dae
     dgdds(14) = gdds
     dgdde(14) = gdde
     print *,'hrs = ',hrs
  end if
end if

! *******   output data   *******
! output information from each crop's phenol subroutine.
! print to the screen:

if (hrs(1)/=999) then
  print *,'crop is: ',cname
  print *,'gdds = ',gdds
  print *,'dap = ',dap
  print *,'gdde = ',gdde
  print *,'dae = ',dae
  print *,'gdda = ',gdda
  print *,'daa = ',daa
  print *,'year = ',year

!  heading for leaf number table
  write (luophenol,1000) cname

!  write out a table with leaf numbers by doy
  do j = 1,60
!
!  write only the integer values that are greater than 0
     if ((lnpout(j,2)<dgdde(7)/pchron).and.(lnpout(j,2)>0.0))                   &
       & write (luophenol,1100) lnpout(j,1),lnpout(j,2)
  end do
!
! convert integer antss(1) to a real number
  write (luophenol,1100) real(antss(1)),dgdde(7)/pchron

  write (luophenol,1200)
                   ! leaf number table
!
!debe add items to print to the output file phenol.out
  write (luophenol,1300) cname,cliname,pdepth,pdatearr(1),pdatearr(3),          &
                       & pdatearr(4),gmethod,emrgflg,seedbed,bhfwsf

  write (luophenol,1400) pdatearr(1),pdatearr(3),pdatearr(4),ems(1),ems(3),     &
                       & ems(4),ddap(1),dgdds(1),lf4s(1),lf4s(3),lf4s(4),ddap(2)&
                       & ,ddae(2),dgdds(2),dgdde(2),dgdde(2)/pchron,tsints(1),  &
                       & tsints(3),tsints(4),ddap(3),ddae(3),dgdds(3),dgdde(3), &
                       & dgdde(3)/pchron,ears(1),ears(3),ears(4),ddap(4),ddae(4)&
                       & ,dgdds(4),dgdde(4),dgdde(4)/pchron,ies(1),ies(3),ies(4)&
                       & ,ddap(5),ddae(5),dgdds(5),dgdde(5),dgdde(5)/pchron,    &
                       & lf12s(1),lf12s(3),lf12s(4),ddap(6),ddae(6),dgdds(6),   &
                       & dgdde(6),dgdde(6)/pchron,antss(1),antss(3),antss(4),   &
                       & ddap(7),ddae(7),dgdds(7),dgdde(7),dgdde(7)/pchron,     &
                       & silks(1),silks(3),silks(4),ddap(8),ddae(8),dgdds(8),   &
                       & dgdde(8),dgdde(7)/pchron,blstrs(1),blstrs(3),blstrs(4),&
                       & ddap(9),ddae(9),dgdds(9),dgdde(9),dgdde(7)/pchron,     &
                       & milks(1),milks(3),milks(4),ddap(10),ddae(10),dgdds(10),&
                       & dgdde(10),dgdde(7)/pchron,doughs(1),doughs(3),doughs(4)&
                       & ,ddap(11),ddae(11),dgdds(11),dgdde(11),dgdde(7)/pchron,&
                       & dents(1),dents(3),dents(4),ddap(12),ddae(12),dgdds(12),&
                       & dgdde(12),dgdde(7)/pchron,mats(1),mats(3),mats(4),     &
                       & ddap(13),ddae(13),dgdds(13),dgdde(13),dgdde(7)/pchron, &
                       & hrs(1),hrs(3),hrs(4),ddap(14),ddae(14),dgdds(14),      &
                       & dgdde(14),dgdde(7)/pchron

! debe added writing out and formatting of the gddwsf array
  write (luophenol,1500) gddwsf(1,1),gddwsf(1,2),gddwsf(1,3),gddwsf(1,4),       &
                       & gddwsf(1,5),gddwsf(2,1),gddwsf(2,2),gddwsf(2,3),       &
                       & gddwsf(2,4),gddwsf(2,5),gddwsf(3,1),gddwsf(3,2),       &
                       & gddwsf(3,3),gddwsf(3,4),gddwsf(3,5),gddwsf(4,1),       &
                       & gddwsf(4,2),gddwsf(4,3),gddwsf(4,4),gddwsf(4,5),       &
                       & gddwsf(5,1),gddwsf(5,2),gddwsf(5,3),gddwsf(5,4),       &
                       & gddwsf(5,5),gddwsf(6,1),gddwsf(6,2),gddwsf(6,3),       &
                       & gddwsf(6,4),gddwsf(6,5),gddwsf(7,1),gddwsf(7,2),       &
                       & gddwsf(7,3),gddwsf(7,4),gddwsf(7,5),gddwsf(8,1),       &
                       & gddwsf(8,2),gddwsf(8,3),gddwsf(8,4),gddwsf(8,5),       &
                       & gddwsf(9,1),gddwsf(9,2),gddwsf(9,3),gddwsf(9,4),       &
                       & gddwsf(9,5),gddwsf(10,1),gddwsf(10,2),gddwsf(10,3),    &
                       & gddwsf(10,4),gddwsf(10,5),gddwsf(11,1),gddwsf(11,2),   &
                       & gddwsf(11,3),gddwsf(11,4),gddwsf(11,5),gddwsf(12,1),   &
                       & gddwsf(12,2),gddwsf(12,3),gddwsf(12,4),gddwsf(12,5),   &
                       & gddwsf(13,1),gddwsf(13,2),gddwsf(13,3),gddwsf(13,4),   &
                       & gddwsf(13,5),gddwsf(14,1),gddwsf(14,2),gddwsf(14,3),   &
                       & gddwsf(14,4),gddwsf(14,5),gddwsf(15,1),gddwsf(15,2),   &
                       & gddwsf(15,3),gddwsf(15,4),gddwsf(15,5)

  endphenol = .true.

end if
 1000 format (46x,a14)
 1100 format (40x,f5.1,6x,f4.1)
 1200 format (/1x) ! write a blank line after outputting the leaf nubmer table

 1300 format ('crop name =',2x,a15,/x,'climate location =',2x,a128,/x,          &
             &'planting depth =',2x,f5.3,'(m)',/x,'planting date =',2x,i3,':',  &
            & i2,'/',i2,/x,'gdd method =',2x,i1,/x,'emergence method used =',2x,&
            & i1,/x,'seedbed soil moisture =',2x,a17,/x,'water stress factor =',&
            & 2x,f3.1,/x)

 1400 format (' phenological event',7x,'day of year',2x,'date',2x,'dap',5x,     &
            & 'dae',5x,'gdd ap',5x,'gdd ae',5x,'nolvs',/1x'planting date',18x,  &
            & i4,2x,i2,'/',i2,/1x,'emergence',22x,i4,2x,i2,'/',i2,1x,i4,13x,    &
            & f6.1,/1x,'leaf 4 (v4)',20x,i4,2x,i2,'/',i2,1x,i4,4x,i4,5x,f6.1,5x,&
            & f6.1,4x,f6.1,/1x,'tassel initiation',14x,i4,2x,i2,'/',i2,1x,i4,4x,&
            & i4,5x,f6.1,5x,f6.1,4x,f6.1,/1x,'ear initiation',17x,i4,2x,i2,'/', &
            & i2,1x,i4,4x,i4,5x,f6.1,5x,f6.1,4x,f6.1,/1x,                       &
             &'internode elongation begins',4x,i4,2x,i2,'/',i2,1x,i4,4x,i4,5x,  &
            & f6.1,5x,f6.1,4x,f6.1,/1x,'leaf 12 (v12)',18x,i4,2x,i2,'/',i2,1x,  &
            & i4,4x,i4,5x,f6.1,5x,f6.1,4x,f6.1,/1x,'tasseling',22x,i4,2x,i2,'/',&
            & i2,1x,i4,4x,i4,5x,f6.1,5x,f6.1,4x,f6.1,/1x,'silking (r1)',19x,i4, &
            & 2x,i2,'/',i2,1x,i4,4x,i4,5x,f6.1,5x,f6.1,4x,f6.1,/1x,             &
             &'blister (r2)',19x,i4,2x,i2,'/',i2,1x,i4,4x,i4,5x,f6.1,5x,f6.1,4x,&
            & f6.1,/1x,'milk (r3)',22x,i4,2x,i2,'/',i2,1x,i4,4x,i4,5x,f6.1,5x,  &
            & f6.1,4x,f6.1,/1x,'dough (r4)',21x,i4,2x,i2,'/',i2,1x,i4,4x,i4,5x, &
            & f6.1,5x,f6.1,4x,f6.1,/1x,'dent (r5)',22x,i4,2x,i2,'/',i2,1x,i4,4x,&
            & i4,5x,f6.1,5x,f6.1,4x,f6.1,/1x,'maturity (r6)',18x,i4,2x,i2,'/',  &
            & i2,1x,i4,4x,i4,5x,f6.1,5x,f6.1,4x,f6.1,/1x,'harvest ready',18x,i4,&
            & 2x,i2,'/',i2,1x,i4,4x,i4,5x,f6.1,5x,f6.1,4x,f6.1)
!     . bhfwsf

!  heading for gddwsf array
 1500 format (/2x,39x,'gddwsf array',/1x,'phenological event',12x,'gn gdd',2x,  &
             &'gs gdd',2x,'wsfhi',2x,'wsflo',2x,'adjgdd',/1x,'emergence',22x,   &
            & f5.1,3x,f5.1,3x,f3.1,4x,f3.1,4x,f5.1,/1x,'4th leaf',23x,f5.1,3x,  &
            & f5.1,3x,f3.1,4x,f3.1,4x,f5.1,/1x,'tassel initiation',14x,f5.1,3x, &
            & f5.1,3x,f3.1,4x,f3.1,4x,f5.1,/1x,'ear formation',18x,f5.1,3x,f5.1,&
            & 3x,f3.1,4x,f3.1,4x,f5.1,/1x,'start of internode elongation',2x,   &
            & f5.1,3x,f5.1,3x,f3.1,4x,f3.1,4x,f5.1,/1x,'12th leaf',22x,f5.1,3x, &
            & f5.1,3x,f3.1,4x,f3.1,4x,f5.1,/1x,'tasseling',22x,f5.1,3x,f5.1,3x, &
            & f3.1,4x,f3.1,4x,f5.1,/1x,'silking',24x,f5.1,3x,f5.1,3x,f3.1,4x,   &
            & f3.1,4x,f5.1,/1x,'blister',24x,f5.1,3x,f5.1,3x,f3.1,4x,f3.1,4x,   &
            & f5.1,/1x,'milk',27x,f5.1,3x,f5.1,3x,f3.1,4x,f3.1,4x,f5.1,/1x,     &
             &'dough',26x,f5.1,3x,f5.1,3x,f3.1,4x,f3.1,4x,f5.1,/1x,'dent',27x,  &
            & f5.1,3x,f5.1,3x,f3.1,4x,f3.1,4x,f5.1,/1x,'physiological maturity',&
            & 9x,f5.1,3x,f5.1,3x,f3.1,4x,f3.1,4x,f5.1,/1x,'harvest ready',18x,  &
            & f5.1,3x,f5.1,3x,f3.1,4x,f3.1,4x,f5.1,/1x,'row 15',25x,f5.1,3x,    &
            & f5.1,3x,f3.1,4x,f3.1,6x,f3.1,/1x)
!
end subroutine phenolcn


  subroutine pauli1(p1,p2,ip1,ip2,n1,n2,v,np,mv,tint,ip, results)

! ====================================================================
!
!   Check Pauli principle for collision of
!   projectile nucleon (N1,P1,IP1) with target nucleon N2
!   boost NP secondary particles into observer's system, if
!   the collision is allowed
!   Number of cascade particles MV ==> MV + NP
!
!   Edited by CMJ (3/10/17): Added error protection
!
! ====================================================================

    use, intrinsic:: iso_fortran_env, only: int32, real64
    use modifiedDCMClass, only: mDCMResults

!    implicit none
    implicit real(real64) (a-h,o-z), integer(int32) (i-n)
    type(mDCMResults), intent(inout) :: results

    real(real64) ::  masn
    common/ncasca/ncas,ncpri
    common/tprod/tprod(5999)
    common/porig/iori(3,5999)
    common/idn12/id1,id2
    common/nucoll/ nucoll,mvcoll(5999)
    common/cslid/clider(5999)
    common/resultlaq/an1,an2,zn1,zn2,enext1,enext2,pnucl1(3), &
         & pnucl2(3),amnuc1(3),amnuc2(3)
    common/hcasc/anucl1,anucl2,znucl1,znucl2,t0,eps1,eps2, &
         & vpi,a1,a2,c1,c2,d1,d2,r0n1,r0n2,tf01,tf02,rm1,rm2 &
         & /center/xc(2,300),yc(2,300),zc(2,300),iz(2,300)
    common/memorylaq/pmemo(9,5999),imemo(5,5999)
    common/activ/mpa(300),myp(5999),myt(5999),myy(5999)
    common /holpt/ ph1(3),ph2(3),rh1(3),rh2(3),ehol1,ehol2,tfp,tft
    common/nucsp/vpr(3),vta(3),radp(3),radt(3),vev(3),vre(3),gev,gre &
         & ,vep(3),vet(3),gep,get
    common /rint/ rint
    common /idpme/ idpme(5999)
    common /sori/ sori(5999),ssor
    common /hadr1/hadr1(4,5999),hadr2(4,5999),hadi1(4),hadi2(4)
    dimension p1(9),p2(9),ip1(5),ip2(5),ps(3),v(3),pn1(3), &
         & pn2(3),p(3),pl(3),bpr(3),bta(3),rl(3)
    masn=0.940
!----> do  9  l=1,3
    do   l=1,3
       bpr(l)=-vpr(l)
9      bta(l)=-vta(l)
    end do
    tfr1=tfp
    tfr2=tft
    if(np-2)10,10,13
!----> do 11 l=1,9
10  do l=1,9
11     pmemo(l,mv+2)=pmemo(l,mv+3)
    end do
!----> do 12 l=1,5
    do l=1,5
12     imemo(l,mv+2)=imemo(l,mv+3)
    end do
    clider(mv+2)=clider(mv+3)
    idpme(mv+2)=idpme(mv+3)
    go to 16
!----> do 14 l=1,9
13  do l=1,9
       temp=pmemo(l,mv+2)
       pmemo(l,mv+2)=pmemo(l,mv+3)
14     pmemo(l,mv+3)=temp
    end do
!----> do 15 l=1,5
    do l=1,5
       itemp=imemo(l,mv+2)
       imemo(l,mv+2)=imemo(l,mv+3)
15     imemo(l,mv+3)=itemp
    end do
    temc=clider(mv+2)
    clider(mv+2)=clider(mv+3)
    clider(mv+3)=temc
    idte=idpme(mv+2)
    idpme(mv+2)=idpme(mv+3)
    idpme(mv+3)=idte
!----> do 18 l=1,2
16  do l=1,2
       if(imemo(3,mv+l).ne.0.or.imemo(5,mv+l).ne.0.or.imemo(2,mv+l).ne.0) &
            & go  to  18
       ps(1)=pmemo(4,mv+l)
       ps(2)=pmemo(5,mv+l)
       ps(3)=pmemo(6,mv+l)
       call kinemq(ps,v,pl,ctl,stl,cfl,sfl,tl,masn)
       call kinemq(pl,bpr,pn1,ct1,st1,cf1,sf1,t1,masn)
       iforb=1
       if(t1 <= tfr1)  go  to  19
       call kinemq(pl,bta,pn2,ct2,st2,cf2,sf2,t2,masn)
       iforb=2
       if(t2 <= tfr2)  go  to  19 !ton21.07.97
18     continue
    end do
    go  to  20
19  ip=0
    if(ncas >= ncpri) then
       if(iforb == 1) write(16,302) t1,tfr1
       if(iforb == 2) write(16,303) t2,tfr2
302    format(1x,'pauli1 forbided: t1=',f6.3,' < tfr1=',f6.3)
303    format(1x,'pauli1 forbided: t2=',f6.3,' < tfr2=',f6.3)
    endif
    return
20  continue
    nucoll=nucoll+1
    na1=an1+0.1
    na2=an2+0.1
24  e1=ip1(1)
    e2=ip2(1)
    j2=an2+0.1
    xc(2,n2)=xc(2,j2)
    yc(2,n2)=yc(2,j2)
    zc(2,n2)=zc(2,j2)
    iz(2,n2)=iz(2,j2)
    zn2=zn2-e2
    an2=an2-1.
    j1=an1+0.1
    xc(1,n1)=xc(1,j1)
    yc(1,n1)=yc(1,j1)
    zc(1,n1)=zc(1,j1)
    iz(1,n1)=iz(1,j1)
    zn1=zn1-e1
    an1=an1-1.
    mpa(n1)=mpa(j1)
    call  recul(1,ph1(1),ph1(2),ph1(3),rh1(1),rh1(2),rh1(3))
    call  recul(2,ph2(1),ph2(2),ph2(3),rh2(1),rh2(2),rh2(3))
    enext1=enext1+tfr1-ehol1
    enext2=enext2+tfr2-ehol2
    l=1
    np1=np
25  m=mv+l
    el=imemo(1,m)
    ql=imemo(4,m)
    p(1)=pmemo(4,m)
    p(2)=pmemo(5,m)
    p(3)=pmemo(6,m)
    call  kinemq(p,v,pl,ctl,stl,cfl,sfl,tl,pmemo(9,m))
    pmemo(4,m)=pl(1)
    pmemo(5,m)=pl(2)
    pmemo(6,m)=pl(3)
    pmemo(8,m)=tl
    call  kinemr(v,m,rl,taul)
    call  tmatur(np,v,m,p1,p2,mv,p,taul,tmat)
    pmemo(7,m)=tmat
    tprod(m)=tint
    mvcoll(m)=nucoll
    iori(1,m)=id1
    iori(2,m)=id2
    iori(3,m)=0
    do j=1,4
       hadr1(j,m)=hadi1(j)
       hadr2(j,m)=hadi2(j)
    enddo
    sori(m)=ssor
    if(imemo(5,m) == 0)    go  to  125
    taum0= dble(imemo(5,m))/1000.
    temp1 = pmemo(9,m)
!      call err_chk(1,'LaqPauli.f',"144",1,temp1)
    tauml=taum0*(1.+pmemo(8,m)/temp1)
    imemo(5,m)=intg((tauml+pmemo(7,m))*1000.)
    if(imemo(5,m) == 0)  imemo(5,m)=1
125 continue
    elm=pmemo(8,m)+pmemo(9,m)
!      PMEMO(1,M)=(P1(1)+P2(1))/2.+RL(1)-PMEMO(4,M)/ELM*TAUL
!      PMEMO(2,M)=(P1(2)+P2(2))/2.+RL(2)-PMEMO(5,M)/ELM*TAUL
!      PMEMO(3,M)=(P1(3)+P2(3))/2.+RL(3)-PMEMO(6,M)/ELM*TAUL
    dr=rint*rndm(-1.0_real64)**(1./3.) ! rndm assumed > 0; no err_chk.
    fi=6.283185*rndm(-1.0_real64)
    ct=1.-2.*rndm(-1.0_real64)
    temp1 = 1.-ct**2
!      call err_chk(1,'LaqPauli.f',"157",2,temp1)
    st=sqrt(temp1)
    dx=dr*st*cos(fi)
    dy=dr*st*sin(fi)
    dz=dr*ct
    pmemo(1,m)=(p1(1)+p2(1))/2.+dx
    pmemo(2,m)=(p1(2)+p2(2))/2.+dy
    pmemo(3,m)=(p1(3)+p2(3))/2.+dz
    myp(m)=1
    myt(m)=1
    myy(m)=1
    if(imemo(2,m).ne.0)  myp(m)=0
    if(imemo(2,m).ne.0)  myt(m)=0
    if(imemo(2,m).ne.0)  myy(m)=0
    if(ncas >= ncpri)  write(16,301) &
         & m,(pmemo(k,m),k=1,9),(imemo(k,m),k=1,5),clider(m),idpme(m)
301 format(1x,'newp',i5,9(1x,f 8.3),2x,4i2,i15,f6.3,i5)
    if(l-np1)  36,37,37
36  l=l+1
    go to 25
37  ip=1
    mv=mv+np1
    results%projExc%numTotal=results%projExc%numTotal+1.
    results%projExc%numHoles=results%projExc%numHoles+1.
    results%targExc%numTotal=results%targExc%numTotal+1.
    results%targExc%numHoles=results%targExc%numHoles+1.
!      IF(AN1.LT.ZN1.OR.ZN1.LT.0..OR.AN2.LT.ZN2.OR.ZN2.LT.0.)
!     *write(16,300) AN1,ZN1,AN2,ZN2
300 format(2x,'pauli1',4(2x,f5.0))
    return
  end

! ====================================================
!
! ====================================================

! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  subroutine pauli2(p1,p2,p3,ip1,ip2,ip3,n1,n2,n3,v,np,mv,tint, &
       & ip,obr1, results)

    use, intrinsic:: iso_fortran_env, only: int32, real64
    use modifiedDCMClass, only: mDCMResults

!    implicit none
    implicit real(real64) (a-h,o-z), integer(int32) (i-n)
    type(mDCMResults), intent(inout) :: results

!   Check Pauli principle for collision of
!   cascade particle  (N1,P1,IP1) with projectile nucleon N2
!   (and N3 for absorption by NN pair), and
!   boost NP secondary particles into observer's system, if
!   the collision is allowed
!   Number of cascade particles MV ==> MV + NP - 1
!   Calculate the excitation energy and recoil momentum of
!   projectile nucleus
!

    real(real64) ::  masn
    common/ncasca/ncas,ncpri
    common/tprod/tprod(5999)
    common/porig/iori(3,5999)
    common/idn12/id1,id2
    common/cslid/clider(5999)
    common/nucoll/ nucoll,mvcoll(5999)
    common/resultlaq/an1,an2,zn1,zn2,enext1,enext2,pnucl1(3), &
         & pnucl2(3),amnuc1(3),amnuc2(3)
    common/hcasc/anucl1,anucl2,znucl1,znucl2,t0,eps1,eps2, &
         & vpi,a1,a2,c1,c2,d1,d2,r0n1,r0n2,tf01,tf02,rm1,rm2 &
         & /center/xc(2,300),yc(2,300),zc(2,300),iz(2,300)
    common/memorylaq/pmemo(9,5999),imemo(5,5999)
    common/activ/mpa(300),myp(5999),myt(5999),myy(5999)
    common/nucsp/vpr(3),vta(3),radp(3),radt(3),vev(3),vre(3),gev,gre &
         & ,vep(3),vet(3),gep,get
    common /rint/ rint
    common /holpt/ ph1(3),ph2(3),rh1(3),rh2(3),ehol1,ehol2,tfp,tft
    common /idpme/ idpme(5999)
    common /sori/ sori(5999),ssor
    common /hadr1/hadr1(4,5999),hadr2(4,5999),hadi1(4),hadi2(4)
    common /barpot/ pot
    common/tefabs/ tefabs,ehol3,tfr3
    common /parinc/ pinc(3),einc
    dimension b(3),p1(9),p2(9),ip1(5),ip2(5),ps(3),v(3),pn1(3), &
         & pn2(3),p(3),pl(3),p3(9),ip3(5),rl(3)
    masn=0.940
    an10=an1
    zn10=zn1
    enex10=enext1
    esum=0.
    b(1)=vpr(1)
    b(2)=vpr(2)
    b(3)=vpr(3)
    temp1 = 1.-vpr(1)**2-vpr(2)**2-vpr(3)**2
!      call err_chk(1,'LaqPauli.f',"244",2,temp1)
    temp2 = sqrt(temp1)
!      call err_chk(1,'LaqPauli.f',"246",1,temp2)
    gpr=1./temp2
    temp1 = p2(1)**2+p2(2)**2+p2(3)**2
!      call err_chk(1,'LaqPauli.f',"249",2,temp1)
    r1=sqrt(temp1)
    iabs=0
    tfr1=tfp
    if(np-2)32,10,13
!----> do 11 l=1,9
10  do l=1,9
11     pmemo(l,mv+2)=pmemo(l,mv+3)
    end do
!----> do 12 l=1,5
    do l=1,5
12     imemo(l,mv+2)=imemo(l,mv+3)
    end do
    if(ip1(4) == 0.and.(imemo(4,mv+1)+imemo(4,mv+2)) == 2)  iabs=1
    clider(mv+2)=clider(mv+3)
    idpme(mv+2)=idpme(mv+3)
    go to 16
!----> do 14 l=1,9
13  do l=1,9
       temp=pmemo(l,mv+2)
       pmemo(l,mv+2)=pmemo(l,mv+3)
14     pmemo(l,mv+3)=temp
    end do
!----> do 15 l=1,5
    do l=1,5
       itemp=imemo(l,mv+2)
       imemo(l,mv+2)=imemo(l,mv+3)
15     imemo(l,mv+3)=itemp
    end do
    temc=clider(mv+2)
    clider(mv+2)=clider(mv+3)
    clider(mv+3)=temc
    idte=idpme(mv+2)
    idpme(mv+2)=idpme(mv+3)
    idpme(mv+3)=idte
16  if(imemo(4,mv+1).ne.1)     go  to  17
    if(imemo(3,mv+1).ne.0.or.imemo(5,mv+1).ne.0.or.imemo(2,mv+1).ne.0) &
         & go  to  17
    ps(1)=pmemo(4,mv+1)
    ps(2)=pmemo(5,mv+1)
    ps(3)=pmemo(6,mv+1)
    call cinema(ps,v,pn1,ct1,st1,cf1,sf1,t1,masn)
    tn=t1
    if(t1-tfr1)   31,31,17 !ton21.07.97
17  if(imemo(4,mv+2).ne.1)  go  to  32
18  if(imemo(3,mv+2).ne.0.or.imemo(5,mv+2).ne.0.or.imemo(2,mv+2).ne.0) &
         & go  to  32
    ps(1)=pmemo(4,mv+2)
    ps(2)=pmemo(5,mv+2)
    ps(3)=pmemo(6,mv+2)
    call cinema(ps,v,pn2,ct2,st2,cf2,sf2,t2,masn)
    tn=t2
    if(t2-tfr1) 31,31,32 !ton21.07.97
31  ip=0
    an1=an10
    zn1=zn10
    enext1=enex10
    if(ncas >= ncpri) write(16,302) tn,tfr1
302 format(1x,'pauli2 forbided: tn=',f6.3,' < tfr1=',f6.3)
    return
32  continue
    e2=ip2(1)
    if((an1-1.) < (zn1-e2).or.(zn1-e2) < 0.) go  to  31
    if(iabs == 1.and.np.ne.1)  then
       e3=ip3(1)
       if((an1-1.) < (zn1-e3).or.(zn1-e3) < 0.) go to 31
    endif
    nucoll=nucoll+1
    ibar=0
    if(ip1(4) == -1.and.ip1(3) == 0.and.ip1(5) == 0) ibar=1
    j1=an1+0.1
    if(iabs == 1.and.j1 == n3)   j1=j1-1
    xc(1,n2)=xc(1,j1)
    yc(1,n2)=yc(1,j1)
    zc(1,n2)=zc(1,j1)
    iz(1,n2)=iz(1,j1)
    mpa(n2)=mpa(j1)
    zn1=zn1-e2
    an1=an1-1.
    call  recul(1,ph1(1),ph1(2),ph1(3),rh1(1),rh1(2),rh1(3))
!     ENEXT1=ENEXT1+TFR1-EHOL1
    if(np == 1)  go  to  51
    if(iabs.ne.1)  go  to  51
! *************************************************
! 16.01.97
!     ENEXT1=ENEXT1+TFR3-EHOL3-(TEFABS-EHOL1-EHOL3)-VPI
    results%projExc%numTotal=results%projExc%numTotal+1.
    results%projExc%numHoles=results%projExc%numHoles+1.
    e3=ip3(1)
    call recul(1,p3(4),p3(5),p3(6),p3(1),p3(2),p3(3))
    j1=an1+0.1
    if(j1 < n3)   j1=n3
    xc(1,n3)=xc(1,j1)
    yc(1,n3)=yc(1,j1)
    zc(1,n3)=zc(1,j1)
    iz(1,n3)=iz(1,j1)
    mpa(n3)=mpa(j1)
    zn1=zn1-e3
    an1=an1-1.
51  continue
    l=1
    np1=np
    vpi1=vpi
    nabsn=0
    iflag=0
33  m=mv+l
    el=imemo(1,m)
    ql=imemo(4,m)
    p(1)=pmemo(4,m)
    p(2)=pmemo(5,m)
    p(3)=pmemo(6,m)
    call cinema(p,v,pl,ctl,stl,cfl,sfl,tl,pmemo(9,m))
!
    if(ncas >= ncpri)  write(16,299) &
         & m,pl,tl+pmemo(9,m),(imemo(k,m),k=1,5),idpme(m)
299 format(1x,'newp2 in cms:',i5,4(1x,f8.3),2x,4i2,i15,i5)
!
    tl0=tl
! 16.01.97
    if(imemo(4,m) < 0.or.imemo(3,m).ne.0.or.imemo(2,m).ne.0) &
         & go  to  46
    if(imemo(4,m).ne.0)                go  to  105
    if(imemo(5,m).ne.0)                go  to  46
    if(imemo(1,m))  103,105,104
103 if((zn1*(an1-1.)/2.) < 1.1)       go  to  46
    go  to  105
104 if(((an1-1.)*(an1-zn1)/2.) < 1.1) go  to  46
105 continue
    tl0=tl-ql*(tfr1+eps1)-(1.-ql)*vpi
    if(iabs == 1.and.iflag == 1) tl0=tl-ql*(tfr3+eps1)-(1.-ql)*vpi
    iflag=iflag+1
!   kkg  17.06.02
    if(imemo(5,m).ne.0)  then
       if(tl0 <= 0) then
          if(ncas >= ncpri) write(16,303) tl,tfr1+eps1
303       format(1x,'pauli2 forbided: tdelta=',f6.3,'< tfr1+eps1=',f6.3)
          go  to  31
! NVM          return
       else
          go  to  46
       endif
    endif
!
35  continue
    temp1 = znucl1
!      call err_chk(1,'LaqPauli.f',"386",1,temp1)
    cut=eps1*ql+obr1*el*zn1/temp1           !  04/29/04
!     CUT=0.001*QL+OBR1*EL*ZN1/ZNUCL1         !  06/26/02, 12/13/04
    if(el)  101,102,102
101 cut=0.
102 continue
    if(tl0)  36,100,100
100 continue
    if(tl0-cut) 36,36,46
36  continue
    if((an1+ql) < (zn1+el).or.(zn1+el) < 0.)  then
       tl0=tl
       go  to  46
    endif
!     ENEXT1=ENEXT1+TL0+EPS1*QL+(.14+VPI)*(1.-QL)
    call  recul(1,pl(1),pl(2),pl(3),p1(1),p1(2),p1(3))
    nabsn=nabsn+imemo(4,m)
    if((an1+ql) < (zn1+el).or.(zn1+el) < 0.) go  to  31
    an1=an1+ql
    zn1=zn1+el
    if(imemo(4,m)-1) 141,37,141
37  if(nabsn-1) 38,38,39
38  j1=an1+.1
    xc(1,j1)=p2(1)
    yc(1,j1)=p2(2)
    zc(1,j1)=p2(3)
    go to 40
141 j1=an1+0.1
!----> do  108  k=1,j1
    do   k=1,j1
       if(imemo(1,m))  106,41,107
106    if(iz(1,k).ne.1)   go  to  108
       iz(1,k)=0
       go  to  41
107    if(iz(1,k).ne.0)   go  to  108
       iz(1,k)=1
       go  to  41
108    continue
    end do
    go  to  41
39  j1=an1+.1
    xc(1,j1)=p1(1)
    yc(1,j1)=p1(2)
    zc(1,j1)=p1(3)
40  iz(1,j1)=imemo(1,m)
    mpa(j1)=1
    results%projExc%numTotal=results%projExc%numTotal+1.
    results%projExc%numProtons=results%projExc%numProtons+el
41  if(l-np1) 42,45,45
!----> do 43 k=1,9
42  do k=1,9
43     pmemo(k,m)=pmemo(k,mv+np1)
    end do
!----> do 44 k=1,5
    do k=1,5
44     imemo(k,m)=imemo(k,mv+np1)
    end do
    clider(m)=clider(mv+np1)
    idpme(m)=idpme(mv+np1)
    np1=np1-1
    go to 33
45  np1=np1-1
    go to 48
46  continue
    if(imemo(4,m) == -1.and.imemo(3,m) == 0.and.imemo(5,m) == 0.and. &
         & ibar == 1)       then
       tl0=tl-pot
       if(tl0 <= 0.)  then
!        ENEXT1=ENEXT1+TL+0.940
          an1=an1-1.
          zn1=zn1+el
          call  recul(1,pl(1),pl(2),pl(3),p1(1),p1(2),p1(3))
          go  to  41
       endif
    endif
    temp1 = tl0*(tl0+2.*pmemo(9,m))
!      call err_chk(1,'LaqPauli.f',"456",2,temp1)
    pm=sqrt(temp1)
    pn2(1)=pm*stl*cfl
    pn2(2)=pm*stl*sfl
    pn2(3)=pm*ctl
!
    esum=esum+tl0+pmemo(9,m)
!
    call cinema(pn2,b,ps,ct,st,cf,sf,ttl,pmemo(9,m))
    pmemo(4,m)=ps(1)
    pmemo(5,m)=ps(2)
    pmemo(6,m)=ps(3)
    pmemo(8,m)=ttl
    call  kinemr(b,m,rl,taul)
    call  tmatur(np,v,m,p1,p2,mv,p,taul,tmat)
    pmemo(7,m)=tmat
    tprod(m)=tint
    mvcoll(m)=nucoll
    if(idpme(n1) == idpme(m).and.np == 2) then
! rescattering (elastic or charge exchange)  of the N1 particle
       iori(1,m)=iori(1,n1)
       iori(2,m)=iori(2,n1)
       iori(3,m)=iori(3,n1)+1
       do j=1,4
          hadr1(j,m)=hadr1(j,n1)
          hadr2(j,m)=hadr2(j,n1)
       enddo
       sori(m)=sori(n1)
    else
! production of a new particle M
       iori(1,m)=id1
       iori(2,m)=id2
       iori(3,m)=0
       do j=1,4
          hadr1(j,m)=hadi1(j)
          hadr2(j,m)=hadi2(j)
       enddo
       sori(m)=ssor
    endif
    myp(m)=1
    myt(m)=1
    myy(m)=1
    if(imemo(2,m).ne.0)  myp(m)=0
    if(imemo(2,m).ne.0)  myt(m)=0
    if(imemo(2,m).ne.0)  myy(m)=0
    if(imemo(5,m) == 0)  go  to  146
    taum0= dble(imemo(5,m))/1000.
    temp1 = pmemo(9,m)
!      call err_chk(1,'LaqPauli.f',"504",1,temp1)
    tauml=taum0*(1.+pmemo(8,m)/temp1)
    imemo(5,m)=intg((tauml+pmemo(7,m))*1000.)
    if(imemo(5,m) == 0)  imemo(5,m)=1
146 continue
    x=(p1(1)+p2(1))/2.
    y=(p1(2)+p2(2))/2.
    z=(p1(3)+p2(3))/2.
    vrk=x*vpr(1)+y*vpr(2)+z*vpr(3)
    dr=rint*rndm(-1.0_real64)**(1./3.)
    fi=6.283185*rndm(-1.0_real64)
    ct=1.-2.*rndm(-1.0_real64)
    temp1 = 1.-ct**2
!      call err_chk(1,'LaqPauli.f',"517",2,temp1)
    st=sqrt(temp1)
    dx=dr*st*cos(fi)
    dy=dr*st*sin(fi)
    dz=dr*ct
    temp2 = gpr+1.
!      call err_chk(1,'LaqPauli.f',"523, 524, 525",1,temp2)
    pmemo(1,m)=radp(1)+x-vpr(1)*vrk*gpr/temp2+dx
    pmemo(2,m)=radp(2)+y-vpr(2)*vrk*gpr/temp2+dy
    pmemo(3,m)=radp(3)+z-vpr(3)*vrk*gpr/temp2+dz
    if(ncas >= ncpri)  write(16,301) &
         & m,(pmemo(k,m),k=1,9),(imemo(k,m),k=1,5),clider(m),idpme(m)
301 format(1x,'newp',i5,9(1x,f 8.3),2x,4i2,i15,f6.3,i5)
    if(l-np1) 47,48,48
47  l=l+1
    go to 33
48  ip=1
    mv=mv+np1-1
!----> do 53 k=1,9
52  do k=1,9
53     pmemo(k,n1)=pmemo(k,mv+1)
    end do
!----> do 54 k=1,5
    do k=1,5
54     imemo(k,n1)=imemo(k,mv+1)
    end do
    myp(n1)=myp(mv+1)
    myt(n1)=myt(mv+1)
    myy(n1)=myy(mv+1)
    tprod(n1)=tprod(mv+1)
    mvcoll(n1)=mvcoll(mv+1)
    iori(1,n1)=iori(1,mv+1)
    iori(2,n1)=iori(2,mv+1)
    iori(3,n1)=iori(3,mv+1)
    do j=1,4
       hadr1(j,1)=hadr1(j,mv+1)
       hadr2(j,1)=hadr2(j,mv+1)
    enddo
    sori(n1)=sori(mv+1)
    clider(n1)=clider(mv+1)
    idpme(n1)=idpme(mv+1)
    call eraij(n1)
    if(np1 == 0)              call repij(n1,mv+1)
    results%projExc%numTotal=results%projExc%numTotal+1.
    results%projExc%numHoles=results%projExc%numHoles+1.
!
    enext1=enex10+einc-esum+(an10-an1)*(0.940-eps1)
!
    return
  end

! =========================================
!
! =========================================

! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  subroutine pauli3(p1,p2,p3,ip1,ip2,ip3,n1,n2,n3,v,np,mv,tint, &
       & ip,obr2, results)

    use, intrinsic:: iso_fortran_env, only: int32, real64
    use modifiedDCMClass, only: mDCMResults

!    implicit none
    implicit real(real64) (a-h,o-z), integer(int32) (i-n)
    type(mDCMResults), intent(inout) :: results

!   Check Pauli principle for collision of
!   cascade particle  (N1,P1,IP1) with target nucleon N2
!   (and N3 for absorption by NN pair), and
!   boost NP secondary particles into observer's system, if
!   the collision is allowed
!   Number of cascade particles MV ==> MV + NP - 1
!   Calculate the excitation energy and recoil momentum of
!   target nucleus
!
!
    real(real64) ::  masn
    common/ncasca/ncas,ncpri
    common/tprod/tprod(5999)
    common/porig/iori(3,5999)
    common/idn12/id1,id2
    common/cslid/clider(5999)
    common/nucoll/ nucoll,mvcoll(5999)
    common/resultlaq/an1,an2,zn1,zn2,enext1,enext2,pnucl1(3), &
         & pnucl2(3),amnuc1(3),amnuc2(3)
    common/hcasc/anucl1,anucl2,znucl1,znucl2,t0,eps1,eps2, &
         & vpi,a1,a2,c1,c2,d1,d2,r0n1,r0n2,tf01,tf02,rm1,rm2 &
         & /center/xc(2,300),yc(2,300),zc(2,300),iz(2,300)
    common/memorylaq/pmemo(9,5999),imemo(5,5999)
    common/activ/mpa(300),myp(5999),myt(5999),myy(5999)
    common/nucsp/vpr(3),vta(3),radp(3),radt(3),vev(3),vre(3),gev,gre &
         & ,vep(3),vet(3),gep,get
    common /rint/ rint
    common /holpt/ ph1(3),ph2(3),rh1(3),rh2(3),ehol1,ehol2,tfp,tft
    common /idpme/ idpme(5999)
    common /sori/ sori(5999),ssor
    common /hadr1/hadr1(4,5999),hadr2(4,5999),hadi1(4),hadi2(4)
    common /barpot/ pot
    common/tefabs/ tefabs,ehol3,tfr3
    common /parinc/ pinc(3),einc
    dimension b(3),p1(9),p2(9),ip1(5),ip2(5),ps(3),v(3),pn1(3), &
         & pn2(3),p(3),pt(3),pl(3),p3(9),ip3(5),rl(3)
    masn=0.940
    an20=an2
    zn20=zn2
    enex20=enext2
    esum=0.
    b(1)=vta(1)
    b(2)=vta(2)
    b(3)=vta(3)
    temp1 = 1.-vta(1)**2-vta(2)**2-vta(3)**2
!      call err_chk(1,'LaqPauli.f',"619",2,temp1)
    temp2 = sqrt(temp1)
!      call err_chk(1,'LaqPauli.f',"621",1,temp2)
    gta=1./temp2
    temp3 = p2(1)**2+p2(2)**2+p2(3)**2
!      call err_chk(1,'LaqPauli.f',"624",2,temp3)
    r2=sqrt(temp3)
    iabs=0
    tfr2=tft
    if(np-2)32,10,13
!----> do 11 l=1,9
10  do l=1,9
11     pmemo(l,mv+2)=pmemo(l,mv+3)
    end do
!----> do 12 l=1,5
    do l=1,5
12     imemo(l,mv+2)=imemo(l,mv+3)
    end do
    if(ip1(4) == 0.and.(imemo(4,mv+1)+imemo(4,mv+2)) == 2)  iabs=1
    clider(mv+2)=clider(mv+3)
    idpme(mv+2)=idpme(mv+3)
    go to 16
!----> do 14 l=1,9
13  do l=1,9
       temp=pmemo(l,mv+2)
       pmemo(l,mv+2)=pmemo(l,mv+3)
14     pmemo(l,mv+3)=temp
    end do
!----> do 15 l=1,5
    do l=1,5
       itemp=imemo(l,mv+2)
       imemo(l,mv+2)=imemo(l,mv+3)
15     imemo(l,mv+3)=itemp
    end do
    temc=clider(mv+2)
    clider(mv+2)=clider(mv+3)
    clider(mv+3)=temc
    idte=idpme(mv+2)
    idpme(mv+2)=idpme(mv+3)
    idpme(mv+3)=idte
16  if(imemo(4,mv+1).ne.1)   go  to  17
    if(imemo(3,mv+1).ne.0.or.imemo(5,mv+1).ne.0.or.imemo(2,mv+1).ne.0) &
         & go  to  17
    ps(1)=pmemo(4,mv+1)
    ps(2)=pmemo(5,mv+1)
    ps(3)=pmemo(6,mv+1)
    call cinema(ps,v,pn1,ct1,st1,cf1,sf1,tn,masn)
    if(tn-tfr2) 31,31,17 !ton21.07.97
17  if(imemo(4,mv+2).ne.1)  go  to  32
18  if(imemo(3,mv+2).ne.0.or.imemo(5,mv+2).ne.0.or.imemo(2,mv+2).ne.0) &
         & go  to  32
    ps(1)=pmemo(4,mv+2)
    ps(2)=pmemo(5,mv+2)
    ps(3)=pmemo(6,mv+2)
    call cinema(ps,v,pn2,ct2,st2,cf2,sf2,tn,masn)
    if(tn-tfr2) 31,31,32 !ton21.07.97
31  ip=0
    an2=an20
    zn2=zn20
    enext2=enex20
    if(ncas >= ncpri) write(16,302) tn,tfr2
302 format(1x,'pauli3 forbided: tn=',f6.3,' < tfr2=',f6.3)
    return
32  continue
    ibar=0
    if(ip1(4) == -1.and.ip1(3) == 0.and.ip1(5) == 0) ibar=1
    e2=ip2(1)
    if((an2-1.) < (zn2-e2).or.(zn2-e2) < 0.) go  to  31
    if(iabs == 1.and.np.ne.1)  then
       e3=ip3(1)
       if((an2-1.) < (zn2-e3).or.(zn2-e3) < 0.) go to 31
    endif
    nucoll=nucoll+1
    j2=an2+0.1
    if(iabs == 1.and.j2 == n3)   j2=j2-1
25  xc(2,n2)=xc(2,j2)
    yc(2,n2)=yc(2,j2)
    zc(2,n2)=zc(2,j2)
    iz(2,n2)=iz(2,j2)
    zn2=zn2-e2
    an2=an2-1.
    call  recul(2,ph2(1),ph2(2),ph2(3),rh2(1),rh2(2),rh2(3))
!     ENEXT2=ENEXT2+TFR2-EHOL2
    if(np == 1) go  to  51
    if(iabs.ne.1)  go  to  51
! *************************************************
! 16.01.97
!     ENEXT2=ENEXT2+TFR3-EHOL3-(TEFABS-EHOL2-EHOL3)-VPI
    results%targExc%numTotal=results%targExc%numTotal+1.
    results%targExc%numHoles=results%targExc%numHoles+1.
    call recul(2,p3(4),p3(5),p3(6),p3(1),p3(2),p3(3))
    e3=ip3(1)
    j2=an2+0.1
    if(j2 < n3)   j2=n3
132 xc(2,n3)=xc(2,j2)
    yc(2,n3)=yc(2,j2)
    zc(2,n3)=zc(2,j2)
    iz(2,n3)=iz(2,j2)
    zn2=zn2-e3
    an2=an2-1.
51  continue
    l=1
    np1=np
    vpi1=vpi
    nabsn=0
    iflag=0
33  m=mv+l
    el=imemo(1,m)
    ql=imemo(4,m)
    p(1)=pmemo(4,m)
    p(2)=pmemo(5,m)
    p(3)=pmemo(6,m)
    call cinema(p,v,pl,ctl,stl,cfl,sfl,tl,pmemo(9,m))
!
    if(ncas >= ncpri)  write(16,299) &
         & m,pl,tl+pmemo(9,m),(imemo(k,m),k=1,5),idpme(m)
299 format(1x,'newp3 in cms:',i5,4(1x,f8.3),2x,4i2,i15,i5)
!
    tl0=tl
! 16.01.97
    if(imemo(4,m) < 0.or.imemo(3,m).ne.0.or.imemo(2,m).ne.0) &
         & go  to  46
    if(imemo(4,m).ne.0)                go  to  105
    if(imemo(5,m).ne.0)                go  to  46
    if(imemo(1,m))  103,105,104
103 if((zn2*(an2-1.)/2.) < 1.1)       go  to  46
    go  to  105
104 if(((an2-1.)*(an2-zn2)/2.) < 1.1) go  to  46
105 continue
    tl0=tl-ql*(tfr2+eps2)-(1.-ql)*vpi
    if(iabs == 1.and.iflag == 1) &
         & tl0=tl-ql*(tfr3+eps2)-(1.-ql)*vpi
    iflag=iflag+1
!   kkg  17.06.02
    if(imemo(5,m).ne.0)  then
       if(tl0 <= 0) then
          if(ncas >= ncpri) write(16,303) tl,tfr2+eps2
303       format(1x,'pauli3 forbided: tdelta=',f6.3,'< tfr2+eps2=',f6.3)
          go  to  31
! NVM:          return
       else
          go  to  46
       endif
    endif
!
35  continue
    temp1 = znucl2
!      call err_chk(1,'LaqPauli.f',"758",1,temp1)
    cut=eps2*ql+obr2*el*zn2/temp1         !  04/29/04
!     CUT=0.001*QL+OBR2*EL*ZN2/ZNUCL2      ! 06/26/02, 12/13/04
    if(el)  101,102,102
101 cut=0.
102 continue
    if(tl0)  36,100,100
100 continue
    if(tl0-cut) 36,36,46
36  continue
    if((an2+ql) < (zn2+el).or.(zn2+el) < 0.)  then
       tl0=tl
       go  to  46
    endif
!     ENEXT2=ENEXT2+TL0+EPS2*QL+(.14+VPI)*(1.-QL)
    call recul(2,pl(1),pl(2),pl(3),p1(1),p1(2),p1(3))
    nabsn=nabsn+imemo(4,m)
    if((an2+ql) < (zn2+el).or.(zn2+el) < 0.) go  to  31
    an2=an2+ql
    zn2=zn2+el
    if(imemo(4,m)-1)  141,37,141
37  if(nabsn-1) 38,38,39
38  j2=an2+.1
    xc(2,j2)=p2(1)
    yc(2,j2)=p2(2)
    zc(2,j2)=p2(3)
    go to 40
141 j2=an2+0.1
!----> do  108  k=1,j2
    do   k=1,j2
       if(imemo(1,m))  106,41,107
106    if(iz(2,k).ne.1)   go  to  108
       iz(2,k)=0
       go  to  41
107    if(iz(2,k).ne.0)   go  to  108
       iz(2,k)=1
       go  to  41
108    continue
    end do
    go  to  41
39  j2=an2+.1
    xc(2,j2)=p1(1)
    yc(2,j2)=p1(2)
    zc(2,j2)=p1(3)
40  iz(2,j2)=imemo(1,m)
    results%targExc%numTotal=results%targExc%numTotal+1.
    results%targexc%numProtons=results%targexc%numProtons+el
41  if(l-np1) 42,45,45
!----> do 43 k=1,9
42  do k=1,9
43     pmemo(k,m)=pmemo(k,mv+np1)
    end do
!----> do 44 k=1,5
    do k=1,5
44     imemo(k,m)=imemo(k,mv+np1)
    end do
    clider(m)=clider(mv+np1)
    idpme(m)=idpme(mv+np1)
    np1=np1-1
    go to 33
45  np1=np1-1
    go to 48
46  continue
    if(imemo(4,m) == -1.and.imemo(3,m) == 0.and.imemo(5,m) == 0.and. &
         & ibar == 1)       then
       tl0=tl-pot
       if(tl0 <= 0.)  then
!        ENEXT2=ENEXT2+TL+0.940
          an2=an2-1.
          zn2=zn2+el
          call  recul(2,pl(1),pl(2),pl(3),p1(1),p1(2),p1(3))
          go  to  41
       endif
    endif
    temp1 = tl0*(tl0+2.*pmemo(9,m))
!      call err_chk(1,'LaqPauli.f',"827",2,temp1)
    pm0=sqrt(temp1)
    temp1 = tl*(tl+2.*pmemo(9,m))
!      call err_chk(1,'LaqPauli.f',"830",2,temp1)
    temp2 = sqrt(temp1)
!      call err_chk(1,'LaqPauli.f',"832",1,temp2)
    dpm=pm0/temp2
    pt(1)=pl(1)*dpm
    pt(2)=pl(2)*dpm
    pt(3)=pl(3)*dpm
!
    esum=esum+tl0+pmemo(9,m)
!
    call cinema(pt,b,ps,ctl,stl,cfl,sfl,ttl,pmemo(9,m))
    pmemo(4,m)=ps(1)
    pmemo(5,m)=ps(2)
    pmemo(6,m)=ps(3)
    pmemo(8,m)=ttl
    call  kinemr(b,m,rl,taul)
    call  tmatur(np,v,m,p1,p2,mv,p,taul,tmat)
    pmemo(7,m)=tmat
    tprod(m)=tint
    mvcoll(m)=nucoll
    if(idpme(n1) == idpme(m).and.np == 2) then
! rescattering (elastic or charge exchange)  of the N1 particle
       iori(1,m)=iori(1,n1)
       iori(2,m)=iori(2,n1)
       iori(3,m)=iori(3,n1)+1
       do j=1,4
          hadr1(j,m)=hadr1(j,n1)
          hadr2(j,m)=hadr2(j,n1)
       enddo
       sori(m)=sori(n1)
    else
! production of a new particle M
       iori(1,m)=id1
       iori(2,m)=id2
       iori(3,m)=0
       do j=1,4
          hadr1(j,m)=hadi1(j)
          hadr2(j,m)=hadi2(j)
       enddo
       sori(m)=ssor
    endif
    myp(m)=1
    myt(m)=1
    myy(m)=1
    if(imemo(2,m).ne.0)  myp(m)=0
    if(imemo(2,m).ne.0)  myt(m)=0
    if(imemo(2,m).ne.0)  myy(m)=0
    if(imemo(5,m) == 0)  go  to  146
    taum0= dble(imemo(5,m))/1000.
    temp1 = pmemo(9,m)
!      call err_chk(1,'LaqPauli.f',"880",1,temp1)
    tauml=taum0*(1.+pmemo(8,m)/temp1)
    imemo(5,m)=intg((tauml+pmemo(7,m))*1000.)
    if(imemo(5,m) == 0)  imemo(5,m)=1
146 continue
    x=(p1(1)+p2(1))/2.
    y=(p1(2)+p2(2))/2.
    z=(p1(3)+p2(3))/2.
    vrk=x*vta(1)+y*vta(2)+z*vta(3)
    dr=rint*rndm(-1.0_real64)**(1./3.)
    fi=6.283185*rndm(-1.0_real64)
    ct=1.-2.*rndm(-1.0_real64)
    temp1 = 1.-ct**2
!      call err_chk(1,'LaqPauli.f',"893",2,temp1)
    st=sqrt(temp1)
    dx=dr*st*cos(fi)
    dy=dr*st*sin(fi)
    dz=dr*ct
    temp1 = gta+1.
!      call err_chk(1,'LaqPauli.f',"899, 900, 901",1,temp1)
    pmemo(1,m)=radt(1)+x-vta(1)*vrk*gta/temp1+dx
    pmemo(2,m)=radt(2)+y-vta(2)*vrk*gta/temp1+dy
    pmemo(3,m)=radt(3)+z-vta(3)*vrk*gta/temp1+dz
    if(ncas >= ncpri)  write(16,301) &
         & m,(pmemo(k,m),k=1,9),(imemo(k,m),k=1,5),clider(m),idpme(m)
301 format(1x,'newp',i5,9(1x,f 8.3),2x,4i2,i15,f6.3,i5)
    if(l-np1) 47,48,48
47  l=l+1
    go to 33
48  ip=1
    mv=mv+np1-1
!----> do 53 k=1,9
52  do k=1,9
53     pmemo(k,n1)=pmemo(k,mv+1)
    end do
!----> do 54 k=1,5
    do k=1,5
54     imemo(k,n1)=imemo(k,mv+1)
    end do
    myt(n1)=myt(mv+1)
    myy(n1)=myy(mv+1)
    tprod(n1)=tprod(mv+1)
    mvcoll(n1)=mvcoll(mv+1)
    iori(1,n1)=iori(1,mv+1)
    iori(2,n1)=iori(2,mv+1)
    iori(3,n1)=iori(3,mv+1)
    do j=1,4
       hadr1(j,n1)=hadr1(j,mv+1)
       hadr2(j,n1)=hadr2(j,mv+1)
    enddo
    sori(n1)=sori(mv+1)
    clider(n1)=clider(mv+1)
    idpme(n1)=idpme(mv+1)
    call eraij(n1)
    if(np1 == 0)              call repij(n1,mv+1)
    results%targExc%numTotal=results%targExc%numTotal+1.
    results%targExc%numHoles=results%targExc%numHoles+1.
!
    enext2=enex20+einc-esum+(an20-an2)*(0.940-eps2)
!
    return
  end subroutine pauli3

! =========================================
!
! =========================================

! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  subroutine  paulid(mv,md,nre,ifd,np,ip)
!
!   Check Pauli principle for decay of
!   cascade particle  MD
!   boost NP secondary particles into observer's system, if
!   the collision is allowed
!   Number of cascade particles MV ==> MV + NP - 1
!

    use, intrinsic:: iso_fortran_env, only: int32, real64

!    implicit none
    implicit real(real64) (a-h,o-z), integer(int32) (i-n)
    common/ncasca/ncas,ncpri
    common/actim/tint/tprod/tprod(5999)
    common/porig/iori(3,5999)
    common/idn12/id1,id2
    common/cslid/clider(5999)
    common/nucoll/ nucoll,mvcoll(5999)
    common/activ/mpa(300),myp(5999),myt(5999),myy(5999)
    common /memorylaq/ pme(9,5999),ime(5,5999)
    common /hcasc/ an1,an2,zn1,zn2,t0,eps1,eps2,vpi,a1,a2,c1,c2,d1,d2, &
         & r0n1,r0n2,tf01,tf02,rm1,rm2
    common /nucsp/vpr(3),vta(3),radp(3),radt(3),vev(3),vre(3),gev,gre, &
         & vep(3),vet(3),gep,get
    common/idpme/ idpme(5999)
    common /sori/ sori(5999),ssor
    common /hadr1/hadr1(4,5999),hadr2(4,5999),hadi1(4),hadi2(4)
    dimension  ps(3),vn(3),rn(3),pl(3),pin(9),iin(5)
    mvn=0
    resm=pme(9,md)
!----> do  108  l=1,np
    do   l=1,np
!----> do   8  k=1,3
       do    k=1,3
          pme(k,mv+l)=pme(k,md)
8         continue
       end do
       if(ime(3,mv+l) == 0.and.ime(4,mv+l) == 1)  mvn=mv+l
108    continue
    end do
    if(ifd == 0)  go  to  113
    if(mvn == 0)  go  to  113
!----> do  9  k=1,9
    do   k=1,9
9      pin(k)=pme(k,mvn)
    end do
!----> do 10  k=1,5
    do  k=1,5
10     iin(k)=ime(k,mvn)
    end do
!----> do  13  nu=1,2
    do   nu=1,2
       if(nu == 1.and.an1 < 2.1)   go  to  13
       if(nu == 2.and.an2 < 2.1)   go  to  13
!----> do  12  k=1,3
       do   k=1,3
          pl(k)=pme(k+3,mvn)
          if(nu == 2)  go  to  11
          vn(k)=-vpr(k)
          rn(k)=radp(k)
          go  to  12
11        vn(k)=-vta(k)
          rn(k)=radt(k)
12        continue
       end do
       temp1 = 1.-vn(1)**2-vn(2)**2-vn(3)**2
!      call err_chk(1,'LaqPauli.f',"997",2,temp1)
       temp2 = sqrt(temp1)
!      call err_chk(1,'LaqPauli.f',"999",1,temp2)
       gn=1./temp2
       temp3 = gn+1.
!      call err_chk(1,'LaqPauli.f',"1002",1,temp3)
       gg=gn*gn/temp3
       vr=(pme(1,mvn)-rn(1))*vn(1)+ &
            & (pme(2,mvn)-rn(2))*vn(2)+ &
            & (pme(3,mvn)-rn(3))*vn(3)
       pin(1)=pme(1,mvn)-rn(1)+vn(1)*vr*gg
       pin(2)=pme(2,mvn)-rn(2)+vn(2)*vr*gg
       pin(3)=pme(3,mvn)-rn(3)+vn(3)*vr*gg
       temp1 =pin(1)**2+pin(2)**2+pin(3)**2
!      call err_chk(1,'LaqPauli.f',"1011",2,temp1)
       rmod=sqrt(temp1)
       if(nu == 1.and.rmod > rm1)  go  to  13
       if(nu == 2.and.rmod > rm2)  go  to  13
       call  cinema(pl,vn,ps,cts,sts,cfs,sfs,ts,pin(9))
       pin(4)=ps(1)
       pin(5)=ps(2)
       pin(6)=ps(3)
       pin(8)=ts
       if(nu == 1) tf=potenq(pin,iin,a1,c1,d1,tf01,vpi,eps1)-eps1
       if(nu == 2) tf=potenq(pin,iin,a2,c2,d2,tf02,vpi,eps2)-eps2
       if(ts > tf)   go  to  13
       ip=0
       tau0= taun(nre)
       temp2 = pme(9,md)
!      call err_chk(1,'LaqPauli.f',"1026",1,temp2)
       taul=tau0*(1.+pme(8,md)/temp2)
       pme(7,md)=0.
       ime(5,md)=intg((taul+pme(7,md))*1000.)
       if(ime(5,md) == 0)  ime(5,md)=1
       if(ncas >= ncpri) write(16,600) ts,tf,nu,ime(5,md)
600    format(1x,'paulid forbided: tn=',f6.3,' < tf=',f6.3,' nu=',i2,1x, &
            & 'ime(5,md)=',i10)
       return
13     continue
    end do
113 ip=1
    nucoll=nucoll+1
!----> do  114  l=1,np
    do   l=1,np
       pme(7,mv+l)=0.
       tprod(mv+l)=tint
! for decay of L particle the IORI(2,...)=0 !
       iori(1,mv+l)=id1
       iori(2,mv+l)=0
       iori(3,mv+l)=0
       do j=1,3
          hadr1(j,mv+l)=pme(j+3,md)
          hadr2(j,mv+l)=0.
       enddo
       hadr1(4,mv+l)=pme(9,md)
       hadr2(4,mv+l)=0.
       sori(mv+l)=resm
       clider(mv+l)=1.
       mvcoll(mv+l)=nucoll
       myp(mv+l)=ifd
       myt(mv+l)=ifd
       myy(mv+l)=ifd
       if(ime(2,mv+l).ne.0) myp(mv+l)=0
       if(ime(2,mv+l).ne.0) myt(mv+l)=0
       if(ime(2,mv+l).ne.0) myy(mv+l)=0
       mvl=mv+l
       if(ncas >= ncpri)  write(16,301) &
            & mvl,(pme(k,mv+l),k=1,9),(ime(k,mv+l),k=1,5),idpme(mv+l)
301    format(1x,'newp',i5,9(1x,f 8.3),2x,4i2,i15,i5)
114    continue
    end do
!----> do  14  k=1,9
    do   k=1,9
14     pme(k,md)=pme(k,mv+np)
    end do
!----> do  15  k=1,5
    do   k=1,5
15     ime(k,md)=ime(k,mv+np)
    end do
    myp(md)=ifd
    myt(md)=ifd
    myy(md)=ifd
    if(ime(2,md).ne.0)  myp(md)=0
    if(ime(2,md).ne.0)  myt(md)=0
    if(ime(2,md).ne.0)  myy(md)=0
    tprod(md)=tint
! for decay of MD particle the IORI(2,...)=0 !
    iori(1,md)=id1
    iori(2,md)=0
    iori(3,md)=0
    do j=1,4
       hadr1(j,md)=hadr1(j,mv+np)
       hadr2(j,md)=hadr2(j,mv+np)
    enddo
    sori(md)=resm
    mvcoll(md)=nucoll
    clider(md)=1.
    idpme(md)=idpme(mv+np)
    call eraij(md)
    mv=mv+np-1
    return
  end

! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  subroutine pauli4(p1,p2,ip1,ip2,n1,n2,v,np,mv,tint,ip)

    use, intrinsic:: iso_fortran_env, only: int32, real64

!    implicit none
    implicit real(real64) (a-h,o-z), integer(int32) (i-n)
!
!   Check Pauli principle for collision of
!   cascade particle  (N1,P1,IP1) with cascade particle  (N2,P2,IP2)
!   (and N3 for absorption by NN pair), and
!   boost NP secondary particles into observer's system, if
!   the collision is allowed
!   Number of cascade particles MV ==> MV + NP - 2
!
    real(real64) ::  masn
    common/hcasc/anucl1,anucl2,znucl1,znucl2,t0,eps1,eps2, &
         & vpi,a1,a2,c1,c2,d1,d2,r0n1,r0n2,tf01,tf02,rm1,rm2
    common/ncasca/ncas,ncpri
    common/tprod/tprod(5999)
    common/porig/iori(3,5999)
    common/idn12/id1,id2
    common/cslid/clider(5999)
    common/nucoll/ nucoll,mvcoll(5999)
    common/memorylaq/pme(9,5999),ime(5,5999)
    common/activ/mpa(300),myp(5999),myt(5999),myy(5999)
    common/nucsp/vpr(3),vta(3),radp(3),radt(3),vev(3),vre(3),gev,gre &
         & ,vep(3),vet(3),gep,get
    common /rint/ rint
    common /idpme/ idpme(5999)
    common /sori/ sori(5999),ssor
    common /hadr1/hadr1(4,5999),hadr2(4,5999),hadi1(4),hadi2(4)
    dimension p1(9),p2(9),ip1(5),ip2(5),ps(3),v(3),pn1(3), &
         & pn2(3),p(3),pl(3),bpr(3),bta(3),rl(3)
    masn=0.940
!----> do  9  l=1,3
    do   l=1,3
       bpr(l)=-vpr(l)
9      bta(l)=-vta(l)
    end do
    x=(p1(1)+p2(1))/2.
    y=(p1(2)+p2(2))/2.
    z=(p1(3)+p2(3))/2.
    if((iabs(ip1(4))+iabs(ip2(4))) <= 0)  go  to  19
    if(np-2)19,10,13
!----> do 11 l=1,9
10  do l=1,9
11     pme(l,mv+2)=pme(l,mv+3)
    end do
!----> do 12 l=1,5
    do l=1,5
12     ime(l,mv+2)=ime(l,mv+3)
    end do
    clider(mv+2)=clider(mv+3)
    idpme(mv+2)=idpme(mv+3)
    go to 16
!----> do 14 l=1,9
13  do l=1,9
       temp=pme(l,mv+2)
       pme(l,mv+2)=pme(l,mv+3)
14     pme(l,mv+3)=temp
    end do
!----> do 15 l=1,5
    do l=1,5
       itemp=ime(l,mv+2)
       ime(l,mv+2)=ime(l,mv+3)
15     ime(l,mv+3)=itemp
    end do
    temc=clider(mv+2)
    clider(mv+2)=clider(mv+3)
    clider(mv+3)=temc
    idte=idpme(mv+2)
    idpme(mv+2)=idpme(mv+3)
    idpme(mv+3)=idte
!----> do 17 l=1,2
16  do l=1,2
       if(ime(3,mv+l).ne.0.or.ime(5,mv+l).ne.0.or.ime(4,mv+l).ne.1) &
            & go  to  17
       ps(1)=pme(4,mv+l)
       ps(2)=pme(5,mv+l)
       ps(3)=pme(6,mv+l)
       call kinemq(ps,v,pl,ctl,stl,cfl,sfl,tl,masn)
       if(anucl1 < 2.1)  go  to  117
       call kinemq(pl,bpr,pn1,ct1,st1,cf1,sf1,t1,masn)
       call rpts(x,y,z,xp,yp,zp,1)
       tfr1=tfermiq(xp,yp,zp,1)
       iforb=1
       if(t1 <= tfr1)  go  to  18
117    call kinemq(pl,bta,pn2,ct2,st2,cf2,sf2,t2,masn)
       call rpts(x,y,z,xt,yt,zt,2)
       tfr2=tfermiq(xt,yt,zt,2)
       iforb=2
       if(t2 <= tfr2)  go  to  18
17     continue
    end do
    go  to  19
18  ip=0
    if(ncas >= ncpri) then
       if(iforb == 1) write(16,302) t1,tfr1
       if(iforb == 2) write(16,303) t2,tfr2
302    format(1x,'pauli4 forbided: t1=',f6.3,' < tfr1=',f6.3)
303    format(1x,'pauli4 forbided: t2=',f6.3,' < tfr2=',f6.3)
    endif
    return
19  ip=1
    nucoll=nucoll+1
!----> do  21  l=1,np
    do   l=1,np
       m=mv+l
       p(1)=pme(4,m)
       p(2)=pme(5,m)
       p(3)=pme(6,m)
       call  kinemq(p,v,pl,ctl,stl,cfl,sfl,tl,pme(9,m))
       pme(4,m)=pl(1)
       pme(5,m)=pl(2)
       pme(6,m)=pl(3)
       pme(8,m)=tl
       call  kinemr(v,m,rl,taul)
       call  tmatur(np,v,m,p1,p2,mv,p,taul,tmat)
       pme(7,m)=tmat
       tprod(m)=tint
       iori(1,m)=id1
       iori(2,m)=id2
       iori(3,m)=0
       do j=1,4
          hadr1(j,m)=hadi1(j)
          hadr2(j,m)=hadi2(j)
       enddo
       sori(m)=ssor
       if(idpme(n1) == idpme(m).and.np == 2) then
! for rescattering of the N1 particle
          iori(1,m)=iori(1,n1)
          iori(2,m)=iori(2,n1)
          iori(3,m)=iori(3,n1)+1
          do j=1,4
             hadr1(j,m)=hadr1(j,n1)
             hadr2(j,m)=hadr2(j,n1)
          enddo
          sori(m)=sori(n1)
       endif
       if(idpme(n2) == idpme(m).and.np == 2) then
! for rescattering of the N2 particle
          iori(1,m)=iori(1,n2)
          iori(2,m)=iori(2,n2)
          iori(3,m)=iori(3,n2)+1
          do j=1,4
             hadr1(j,m)=hadr1(j,n2)
             hadr2(j,m)=hadr2(j,n2)
          enddo
          sori(m)=sori(n2)
       endif
       mvcoll(m)=nucoll
       myp(m)=1
       myt(m)=1
       myy(m)=1
       if(ime(2,m).ne.0)    myp(m)=0
       if(ime(2,m).ne.0)    myt(m)=0
       if(ime(2,m).ne.0)    myy(m)=0
       if(ime(5,m) == 0)    go  to  20
       taum0= dble(ime(5,m))/1000.
       temp1 = pme(9,m)
!      call err_chk(1,'LaqPauli.f','1236',1,temp1)
       tauml=taum0*(1.+pme(8,m)/temp1)
       ime(5,m)=intg((tauml+pme(7,m))*1000.)
       if(ime(5,m) == 0)  ime(5,m)=1
20     continue
       dr=rint*rndm(-1.0_real64)**(1./3.)
       fi=6.283185*rndm(-1.0_real64)
       ct=1.-2.*rndm(-1.0_real64)
       temp1 = 1.-ct**2
!      call err_chk(1,'LaqPauli.f','1245',2,temp1)
       st=sqrt(temp1)
       dx=dr*st*cos(fi)
       dy=dr*st*sin(fi)
       dz=dr*ct
       pme(1,m)=(p1(1)+p2(1))/2.+dx
       pme(2,m)=(p1(2)+p2(2))/2.+dy
       pme(3,m)=(p1(3)+p2(3))/2.+dz
       if(ncas >= ncpri)  write(16,301) &
            & m,(pme(k,m),k=1,9),(ime(k,m),k=1,5),clider(m),idpme(m)
301    format(1x,'newp',i5,9(1x,f 8.3),2x,4i2,i15,f6.3,i5)
21     continue
    end do
    m1=mv+np-1
    m2=mv+np
!----> do  22  k=1,9
    do   k=1,9
       pme(k,n1)=pme(k,m1)
22     pme(k,n2)=pme(k,m2)
    end do
    myp(n1)=myp(m1)
    myt(n1)=myt(m1)
    myy(n1)=myy(m1)
    tprod(n1)=tprod(m1)
    iori(1,n1)=iori(1,m1)
    iori(2,n1)=iori(2,m1)
    iori(3,n1)=iori(3,m1)
    sori(n1)=sori(m1)
    mvcoll(n1)=mvcoll(m1)
    clider(n1)=clider(m1)
    idpme(n1)=idpme(m1)
!----> do  23  k=1,5
    do   k=1,5
       ime(k,n1)=ime(k,m1)
23     ime(k,n2)=ime(k,m2)
    end do
    myp(n2)=myp(m2)
    myt(n2)=myt(m2)
    myy(n2)=myy(m2)
    tprod(n2)=tprod(m2)
    iori(1,n2)=iori(1,m2)
    iori(2,n2)=iori(2,m2)
    iori(3,n2)=iori(3,m2)
    sori(n2)=sori(m2)
    mvcoll(n2)=mvcoll(m2)
    clider(n2)=clider(m2)
    idpme(n2)=idpme(m2)
    call eraij(n1)
    call eraij(n2)
    if(np == 1) call repij(n1,m1)
    mv=mv+np-2
    return
  end


      SUBROUTINE PHO_EIKON(Ip,Ifhard,B)
C*********************************************************************
C
C     calculation of unitarized amplitudes
C
C     input: IP               particle combination
C            IFHARD           -1  ignore previously calculated Born
C                                 cross sections
C                             0   calculate hard Born cross sections or
C                                 take them from interpolation table
C                                 (if available)
C                             1   take hard cross sections from /POSBRN/
C            B                impact parameter (mb**(1/2))
C                   /POSBRN/  input cross sections
C                   /GLOCMS/  cm energy
C                   /POPREG/  soft and hard parameters
C
C     output: /POINT4/
C             AMPEL           purely elastic amplitude
C             AMPVM           quasi-elastically vectormeson prod.
C             AMLMSD(2)       amplitudes of low mass sing. diffr.
C             AMHMSD(2)       amplitudes of high mass sing. diffr.
C             AMLMDD          amplitude of low mass double diffr.
C             AMHMDD          amplitude of high mass double diffr.
C
C*********************************************************************
      IMPLICIT NONE
      DOUBLE PRECISION B , DEPS , elast , EXPMAX , FIVE , pvold ,
     &                 rmass1 , rmass2 , THOUS , xmass1 , xmass2 ,
     &                 xmpom , xmvdm
      INTEGER i , idxmold , Ifhard , IFIVE , IFOUR , Ip , ipold , ISIX ,
     &        ITHREE , ITWO
      SAVE

      PARAMETER (ITWO=2,ITHREE=3,IFOUR=4,IFIVE=5,ISIX=6,FIVE=5.D0,
     &           THOUS=1.D3,EXPMAX=70.D0,DEPS=1.D-20)

C  input/output channels
      INCLUDE 'inc/poinou'
C  event debugging information
      INCLUDE 'inc/podebg'
C  current beam selection
      INCLUDE 'inc/pobeam'
C  complex Born graph amplitudes used for unitarization
      INCLUDE 'inc/point4'
C  cross sections
      INCLUDE 'inc/pocsec'
C  Born graph cross sections and slopes
      INCLUDE 'inc/posbrn'
C  scaled cross sections and slopes
      INCLUDE 'inc/pozbrn'
C  Born graph cross sections after applying diffraction model
      INCLUDE 'inc/point1'
C  global event kinematics and particle IDs
      INCLUDE 'inc/pogcms'
C  data of c.m. system of Pomeron / Reggeon exchange
      INCLUDE 'inc/popcms'
C  Reggeon phenomenology parameters
      INCLUDE 'inc/popreg'
C  parameters of 2x2 channel model
      INCLUDE 'inc/po2cha'
C  model switches and parameters
      INCLUDE 'inc/pomdls'
C  unitarized amplitudes for different diffraction channels
      INCLUDE 'inc/point5'

      COMPLEX*16 czero , cone , b24 , auxp , auxr , auxh , auxd ,
     &           auxt1 , auxt2 , auxl , ampr , ampo , ampp , ampq

      DIMENSION pvold(2)

      DATA elast/0.D0/
      DATA ipold/ - 1/
      DATA idxmold/ - 1/
      DATA pvold/ - 1.D0 , -1.D0/
      DATA xmpom/0.766D0/
      DATA xmvdm/0.766D0/

C  calculation of scaled cross sections and slopes

C  test for redundant calculation
      IF ( (ECM.NE.elast) .OR. (Ifhard.EQ.-1) .OR.
     &     (PVIrt(1).NE.pvold(1)) .OR. (PVIrt(2).NE.pvold(2)) .OR.
     &     (Ip.NE.ipold) .OR. (IDXmpar.NE.idxmold) ) THEN
C  effective particle masses, VDM assumption
         xmass1 = PMAss(1)
         xmass2 = PMAss(2)
         rmass1 = RMAss(1)
         rmass2 = RMAss(2)
         IF ( IFPap(1).EQ.22 ) THEN
            xmass1 = xmvdm
         ELSE IF ( IFPap(1).EQ.990 ) THEN
            xmass1 = xmpom
         END IF
         IF ( IFPap(2).EQ.22 ) THEN
            xmass2 = xmvdm
         ELSE IF ( IFPap(2).EQ.990 ) THEN
            xmass2 = xmpom
         END IF
C  different particle combinations
         IF ( Ip.EQ.3 ) THEN
            xmass1 = xmass2
            rmass1 = rmass2
         ELSE IF ( Ip.EQ.4 ) THEN
            xmass1 = xmpom
            rmass1 = xmass1
         END IF
         IF ( Ip.GT.1 ) THEN
            xmass2 = xmpom
            rmass2 = xmass2
         END IF
C  update pomeron CM system
         PMAssp(1) = xmass1
         PMAssp(2) = xmass2
         ECMp = ECM

         czero = DCMPLX(0.D0,0.D0)
         cone = DCMPLX(1.D0,0.D0)
         elast = ECM
         pvold(1) = PVIrt(1)
         pvold(2) = PVIrt(2)
         ipold = Ip
         idxmold = IDXmpar

C  purely elastic scattering
         CALL PHO_BORNCS(Ip,Ifhard,xmass1,xmass2,xmass1,xmass2)
         ZXP(1,1) = ZIGp
         BXP(1,1) = BPOm
         ZXR(1,1) = ZIGr
         BXR(1,1) = BREg
         ZXH(1,1) = ZIGhr
         BXH(1,1) = BHAr
         ZXD(1,1) = ZIGhd
         BXD(1,1) = BHAd
         ZXT1a(1,1) = ZIGt1(1)
         BXT1a(1,1) = BTR1(1)
         ZXT1b(1,1) = ZIGt1(2)
         BXT1b(1,1) = BTR1(2)
         ZXT2a(1,1) = ZIGt2(1)
         BXT2a(1,1) = BTR2(1)
         ZXT2b(1,1) = ZIGt2(2)
         BXT2b(1,1) = BTR2(2)
         ZXL(1,1) = ZIGl
         BXL(1,1) = BLOo
         ZXDpe(1,1) = ZIGdp(1)
         BXDpe(1,1) = BDP(1)
         ZXDpa(1,1) = ZIGdp(2)
         BXDpa(1,1) = BDP(2)
         ZXDpb(1,1) = ZIGdp(3)
         BXDpb(1,1) = BDP(3)
         ZXDpd(1,1) = ZIGdp(4)
         BXDpd(1,1) = BDP(4)
         SBOpom(1) = SIGp
         SBOreg(1) = SIGr
         SBOhar(1) = SIGhr
         SBOhad(1) = SIGhd
         SBOtr1(1,1) = SIGt1(1)
         SBOtr1(1,2) = SIGt1(2)
         SBOtr2(1,1) = SIGt2(1)
         SBOtr2(1,2) = SIGt2(2)
         SBOlpo(1) = SIGl
         SBOdpo(1,1) = SIGdp(1)
         SBOdpo(1,2) = SIGdp(2)
         SBOdpo(1,3) = SIGdp(3)
         SBOdpo(1,4) = SIGdp(4)

C  low mass single diffractive scattering 1
         CALL PHO_BORNCS(Ip,1,xmass1,xmass2,rmass1,xmass2)
         ZXP(1,2) = ZIGp
         BXP(1,2) = BPOm
         ZXR(1,2) = ZIGr
         BXR(1,2) = BREg
         ZXH(1,2) = ZIGhr
         BXH(1,2) = BHAr
         ZXD(1,2) = ZIGhd
         BXD(1,2) = BHAd
         ZXT1a(1,2) = ZIGt1(1)
         BXT1a(1,2) = BTR1(1)
         ZXT1b(1,2) = ZIGt1(2)
         BXT1b(1,2) = BTR1(2)
         ZXT2a(1,2) = ZIGt2(1)
         BXT2a(1,2) = BTR2(1)
         ZXT2b(1,2) = ZIGt2(2)
         BXT2b(1,2) = BTR2(2)
         ZXL(1,2) = ZIGl
         BXL(1,2) = BLOo
         ZXDpe(1,2) = ZIGdp(1)
         BXDpe(1,2) = BDP(1)
         ZXDpa(1,2) = ZIGdp(2)
         BXDpa(1,2) = BDP(2)
         ZXDpb(1,2) = ZIGdp(3)
         BXDpb(1,2) = BDP(3)
         ZXDpd(1,2) = ZIGdp(4)
         BXDpd(1,2) = BDP(4)
         SBOpom(2) = SIGp
         SBOreg(2) = SIGr
         SBOhar(2) = SIGhr
         SBOhad(2) = 0.D0
         SBOtr1(2,1) = SIGt1(1)
         SBOtr1(2,2) = SIGt1(2)
         SBOtr2(2,1) = SIGt2(1)
         SBOtr2(2,2) = SIGt2(2)
         SBOlpo(2) = SIGl
         SBOdpo(2,1) = SIGdp(1)
         SBOdpo(2,2) = SIGdp(2)
         SBOdpo(2,3) = SIGdp(3)
         SBOdpo(2,4) = SIGdp(4)

C  low mass single diffractive scattering 2
         CALL PHO_BORNCS(Ip,1,xmass1,xmass2,xmass1,rmass2)
         ZXP(1,3) = ZIGp
         BXP(1,3) = BPOm
         ZXR(1,3) = ZIGr
         BXR(1,3) = BREg
         ZXH(1,3) = ZIGhr
         BXH(1,3) = BHAr
         ZXD(1,3) = ZIGhd
         BXD(1,3) = BHAd
         ZXT1a(1,3) = ZIGt1(1)
         BXT1a(1,3) = BTR1(1)
         ZXT1b(1,3) = ZIGt1(2)
         BXT1b(1,3) = BTR1(2)
         ZXT2a(1,3) = ZIGt2(1)
         BXT2a(1,3) = BTR2(1)
         ZXT2b(1,3) = ZIGt2(2)
         BXT2b(1,3) = BTR2(2)
         ZXL(1,3) = ZIGl
         BXL(1,3) = BLOo
         ZXDpe(1,3) = ZIGdp(1)
         BXDpe(1,3) = BDP(1)
         ZXDpa(1,3) = ZIGdp(2)
         BXDpa(1,3) = BDP(2)
         ZXDpb(1,3) = ZIGdp(3)
         BXDpb(1,3) = BDP(3)
         ZXDpd(1,3) = ZIGdp(4)
         BXDpd(1,3) = BDP(4)
         SBOpom(3) = SIGp
         SBOreg(3) = SIGr
         SBOhar(3) = SIGhr
         SBOhad(3) = 0.D0
         SBOtr1(3,1) = SIGt1(1)
         SBOtr1(3,2) = SIGt1(2)
         SBOtr2(3,1) = SIGt2(1)
         SBOtr2(3,2) = SIGt2(2)
         SBOlpo(3) = SIGl
         SBOdpo(3,1) = SIGdp(1)
         SBOdpo(3,2) = SIGdp(2)
         SBOdpo(3,3) = SIGdp(3)
         SBOdpo(3,4) = SIGdp(4)

C  low mass double diffractive scattering
         CALL PHO_BORNCS(Ip,1,xmass1,xmass2,rmass1,rmass2)
         ZXP(1,4) = ZIGp
         BXP(1,4) = BPOm
         ZXR(1,4) = ZIGr
         BXR(1,4) = BREg
         ZXH(1,4) = ZIGhr
         BXH(1,4) = BHAr
         ZXD(1,4) = ZIGhd
         BXD(1,4) = BHAd
         ZXT1a(1,4) = ZIGt1(1)
         BXT1a(1,4) = BTR1(1)
         ZXT1b(1,4) = ZIGt1(2)
         BXT1b(1,4) = BTR1(2)
         ZXT2a(1,4) = ZIGt2(1)
         BXT2a(1,4) = BTR2(1)
         ZXT2b(1,4) = ZIGt2(2)
         BXT2b(1,4) = BTR2(2)
         ZXL(1,4) = ZIGl
         BXL(1,4) = BLOo
         ZXDpe(1,4) = ZIGdp(1)
         BXDpe(1,4) = BDP(1)
         ZXDpa(1,4) = ZIGdp(2)
         BXDpa(1,4) = BDP(2)
         ZXDpb(1,4) = ZIGdp(3)
         BXDpb(1,4) = BDP(3)
         ZXDpd(1,4) = ZIGdp(4)
         BXDpd(1,4) = BDP(4)
         SBOpom(4) = SIGp
         SBOreg(4) = SIGr
         SBOhar(4) = SIGhr
         SBOhad(4) = 0.D0
         SBOtr1(4,1) = SIGt1(1)
         SBOtr1(4,2) = SIGt1(2)
         SBOtr2(4,1) = SIGt2(1)
         SBOtr2(4,2) = SIGt2(2)
         SBOlpo(4) = SIGl
         SBOdpo(4,1) = SIGdp(1)
         SBOdpo(4,2) = SIGdp(2)
         SBOdpo(4,3) = SIGdp(3)
         SBOdpo(4,4) = SIGdp(4)

C  calculate Born graph cross sections
         SBOpom(0) = 0.D0
         SBOreg(0) = 0.D0
         SBOhar(0) = 0.D0
         SBOhad(0) = 0.D0
         SBOtr1(0,1) = 0.D0
         SBOtr1(0,2) = 0.D0
         SBOtr2(0,1) = 0.D0
         SBOtr2(0,2) = 0.D0
         SBOlpo(0) = 0.D0
         SBOdpo(0,1) = 0.D0
         SBOdpo(0,2) = 0.D0
         SBOdpo(0,3) = 0.D0
         SBOdpo(0,4) = 0.D0
         DO i = 1 , 4
            SBOpom(0) = SBOpom(0) + ELAfac(i)*SBOpom(i)
            SBOreg(0) = SBOreg(0) + ELAfac(i)*SBOreg(i)
            SBOhar(0) = SBOhar(0) + ELAfac(i)*SBOhar(i)
            SBOhad(0) = SBOhad(0) + ELAfac(i)*SBOhad(i)
            SBOtr1(0,1) = SBOtr1(0,1) + ELAfac(i)*SBOtr1(i,1)
            SBOtr1(0,2) = SBOtr1(0,2) + ELAfac(i)*SBOtr1(i,2)
            SBOtr2(0,1) = SBOtr2(0,1) + ELAfac(i)*SBOtr2(i,1)
            SBOtr2(0,2) = SBOtr2(0,2) + ELAfac(i)*SBOtr2(i,2)
            SBOlpo(0) = SBOlpo(0) + ELAfac(i)*SBOlpo(i)
            SBOdpo(0,1) = SBOdpo(0,1) + ELAfac(i)*SBOdpo(i,1)
            SBOdpo(0,2) = SBOdpo(0,2) + ELAfac(i)*SBOdpo(i,2)
            SBOdpo(0,3) = SBOdpo(0,3) + ELAfac(i)*SBOdpo(i,3)
            SBOdpo(0,4) = SBOdpo(0,4) + ELAfac(i)*SBOdpo(i,4)
         END DO

         SIGpom = SBOpom(0)
         SIGreg = SBOreg(0)
         SIGtr1(1) = SBOtr1(0,1)
         SIGtr1(2) = SBOtr1(0,2)
         SIGtr2(1) = SBOtr2(0,1)
         SIGtr2(2) = SBOtr2(0,2)
         SIGloo = SBOlpo(0)
         SIGdpo(1) = SBOdpo(0,1)
         SIGdpo(2) = SBOdpo(0,2)
         SIGdpo(3) = SBOdpo(0,3)
         SIGdpo(4) = SBOdpo(0,4)
         SIGhar = SBOhar(0)
         SIGdir = SBOhad(0)
      END IF

      b24 = DCMPLX(B**2,0.D0)/4.D0

      AMPel = czero
      ampr = czero
      ampo = czero
      ampp = czero
      ampq = czero
      AMLmsd(1) = czero
      AMLmsd(2) = czero
      AMHmsd(1) = czero
      AMHmsd(2) = czero
      AMLmdd = czero
      AMHmdd = czero

C  different models

      IF ( ISWmdl(1).LT.3 ) THEN
C  pomeron
         auxp = ZXP(1,1)*EXP(-b24/BXP(1,1))
C  reggeon
         auxr = ZXR(1,1)*EXP(-b24/BXR(1,1))
C  hard resolved processes
         auxh = ZXH(1,1)*EXP(-b24/BXH(1,1))
C  hard direct processes
         auxd = ZXD(1,1)*EXP(-b24/BXD(1,1))
C  triple-Pomeron: baryon high mass diffraction
         auxt1 = ZXT1a(1,1)*EXP(-b24/BXT1a(1,1)) + ZXT1b(1,1)
     &           *EXP(-b24/BXT1b(1,1))
C  triple-Pomeron: photon/meson high mass diffraction
         auxt2 = ZXT2a(1,1)*EXP(-b24/BXT2a(1,1)) + ZXT2b(1,1)
     &           *EXP(-b24/BXT2b(1,1))
C  loop-Pomeron
         auxl = ZXL(1,1)*EXP(-b24/BXL(1,1))
      END IF

      IF ( ISWmdl(1).EQ.0 ) THEN
         AMPel = 0.5D0*((VDMq2f(1)+VDMq2f(2)+VDMq2f(3)+VDMq2f(4))
     &           *(cone-EXP(-auxr-auxp-auxh+auxt1+auxt2+auxl))
     &           +(cone-(VDMq2f(1)-VDMq2f(2)-VDMq2f(3)-VDMq2f(4)))*auxd)
         ampr = 0.5D0*SQRT(VDMq2f(1))
     &          *(cone-EXP(-auxr-auxp-auxh+auxt1+auxt2+auxl))
         ampo = 0.5D0*SQRT(VDMq2f(2))
     &          *(cone-EXP(-auxr-auxp-auxh+auxt1+auxt2+auxl))
         ampp = 0.5D0*SQRT(VDMq2f(3))
     &          *(cone-EXP(-auxr-auxp-auxh+auxt1+auxt2+auxl))
         ampq = 0.5D0*SQRT(VDMq2f(4))
     &          *(cone-EXP(-auxr-auxp-auxh+auxt1+auxt2+auxl))

      ELSE IF ( ISWmdl(1).EQ.1 ) THEN
         ampr = 0.5D0*SQRT(VDMq2f(1))
     &          *(cone-EXP(-auxr-auxp-auxh*VDMq2f(1)))
         ampo = 0.5D0*SQRT(VDMq2f(2))
     &          *(cone-EXP(-3.D0*auxr-auxp-auxh*VDMq2f(2)))
         ampp = 0.5D0*SQRT(VDMq2f(3))*(cone-EXP(-auxp-auxh*VDMq2f(3)))
         ampq = 0.5D0*SQRT(VDMq2f(4))
     &          *(cone-EXP(-auxr-auxp-auxh*VDMq2f(4)))
         AMPel = SQRT(VDMq2f(1))*ampr + SQRT(VDMq2f(2))
     &           *ampo + SQRT(VDMq2f(3))*ampp + SQRT(VDMq2f(4))
     &           *ampq + auxd/2.D0

C  simple analytic two channel model (version A)
      ELSE IF ( ISWmdl(1).EQ.3 ) THEN
         CALL PHO_CHAN2A(B)

      ELSE
         IF ( LPRi.GT.4 ) WRITE (LO,'(1X,A,I2)')
     &         'EIKON: ERROR: unsupported model ISWMDL(1) ' , ISWmdl(1)
         STOP
      END IF

      END SUBROUTINE