c $VERSION "08/16/95 @(#)curadia.f	7.1"
      subroutine radiat(kstrt,coszen,radabv,fbeam,ihr,ioutpt,thetas,
     1iprofl,phis,clump,path,cosdlt)
c thetas and phis in above stm were added by Chen, 9/7/89.
c****************************radiat*************************************
      parameter(mh=98)
      dimension u(3,20), d(3,20), radabv(3), sup(20), sdn(20), adum(20)
     &,fbeam(3)
     &,theta(10)
     &,tbeam(20),beam(3)
     4,dave(3,20),shade(3,20),smsup3(20)
     5,path(mh)
     6,tlayer(20),rlayer(20)
c smsup(20) in dimension stm was added by Chen, 9/30/89.
c tlayer(20) and rlayer(20) in dim stm added by MCA, 4/2195.
c	-------
c	| path added - path length of sunbeam through canopy
c	| LMM 93/9/31
      common/balan/dsdum(3,20),dstng(20),dstng2(20)
c     ---------
c     | rad1 cmn added rlleaf, tlleaf, rldead and tldead LMM 94/9/6
      common /rad1/emis,emisol,rsoil(3),rleaf(3,20),tleaf(3,20)
     &,aleaf(3,20),expdif,rlayr(3,20),tlayr(3,20),rllive(3),tllive(3)
     &,rldead(3),tldead(3)
      common /rad2/dstrad(3,10,20),dstnet(10,20),frarea(10,20)
     &,templf(10,20),tsoil(mh)
      common/rad4/d,u,bmflx(3,20),rnet(50),rndiv(50),tsfc,rnlam(3,20)
      common /rad5/ sourup(3,20,mh),sourdn(3,20,mh)
      common/leaf1/delt(10,20),psilf,tran(10,20)
      common/leaf2/evap(10,20),gevap(10,20),heat(10,20),gheat(10,20)
     &,alam ,tlfavg(20),tgheat(20),tgvap1(20),tgvap2(20)
      common/resis1/rhleaf(20),rsleaf(10,20),rsnovp(10,20),hpsi
      common/misc1/pi,pid180,pid2,sigma,iwrite(9,99),kmax
c pid2,kmax in /misc1/ were added by Chen, 9/4/89.
      common/misc2/itot,itotp1,jtot,fr(10),ct(10),totlai,df,dt
     &,clai(20),distls(10,mh),jdead
c distls(10,mh) in /misc2/ was added by Chen, 9/4/89.
      common/misc6/xint(mh),nxintz,xintz(90),nalpha,ispher
c xintz, extin. coef. at different zenith averaged over azimuth, and
c nxtintz, dimension of xintz, Chen, 05/25/89.
      common/indax3/xmeuaz,xneuaz,beta0,nbeta,fraz(50),fradeg(360)
c /misc6/ and /indax3/ were added by Chen, 9/7/89.
      common /time/month,jday,iyear,icumdy,timloc(mh)
      common/prof1/tair(20),eair(20),phim,phih,refhtt,refhte,relh(20)
     &,nlabcy,nlbcpy
      common/misc4/z(50),zmid(50),jzcpy,jzcpy1,jzsfc,jzsfm1,jzbot,jzcrit
     &,jzbm1
      common/prof2/tn(mh,50),akcpy(50),cpcpy(50),u1(50),q(50),et(50),
     1en(mh,50),qcond(50),econd(50),tcheck(50),esat(50),qwater(50)
      common/photo3/csleaf(10,20),psleaf(10,20),cileaf(10,20),rgas
     &,rdrk(10,20),hsleaf(10,20),csfclf(10,20)
c  loop over wavelength, 1=vis; 2=nearir; 3=thermal
      do  5900 k=kstrt, kmax
      iter = 0
c in above stm original 3 was replaced by kmax.
      do 540 j=2,jtot
        tlayer(j)=tlayr(k,j)
        rlayer(j)=rlayr(k,j)
 540  continue
        tlayer(1)=0.
        rlayer(1)=rsoil(k)
c  separate solar and thermal
 545  if(k-3) 550, 4000,4000
 550  continue
c  if fbeam or coszen lt .01, don't calculate beam factors
c
	if (coszen.lt.0.01) then
c	    ----------
c	    | Night Time
c
	    do630j=1,jtot
		adum(j)=0.
		d(k,j)=0.
		u(k,j)=0.
		do625i=1,itotp1
		    dstrad(k,i,j)=0.
 625  		    frarea(i,j)=0.
		frarea(itotp1,j)=1.
 630  	    continue
   	    expdir=0.
      	    do 631, j=1,jtot
      	      	tbeam(j)=0.
      		bmflx(k,j)=0.
      		sup(j)=0.
      		sdn(j)=0.
 631  	    continue
c	    ------------------>>>>
	    GOTO 5000
c	    ------------------>>>>
	endif
 	if ((fbeam(k).lt..01) .or. (path(ihr).lt.-.9)) then
c	    ----------
c	    | No direct due to cloud cover or
c	    | slope interception, zero out varaibles
c
   	    expdir=0.
      	    do590j=1,jtot
      	      	tbeam(j)=0.
      		bmflx(k,j)=0.
      		sup(j)=0.
      		sdn(j)=0.
 590  	    continue
	else
c	    ----------
c	    |  calculate direct interception for a layer
 565  	    expdir=exp(-clump*xint(ihr)*df*path(ihr))
c	    |  xint(ihr) in above stm replaced original 0.5. Chen, 9/7/89.
c	    |  calculate all beam sources
c	    |  added path LMM 93/8/31
c
	    tbeam(jtot)=fbeam(k)
	    sdn(1)=0.
	    do 800 j=2,jtot
		jj=jtot-j+1
		jjp1=jj+1
		tbeam(jj)=1.e-20
		if(tbeam(jjp1).gt.1.e-20)tbeam(jj)=tbeam(jjp1)*expdir
		sup(jjp1)=sourup(k,jjp1,ihr)*tbeam(jjp1)
		sdn(jjp1)=sourdn(k,jjp1,ihr)*tbeam(jjp1)
c 	        xup=(tbeam(jjp1)-tbeam(jj))*rleaf(k)
c	        xdn=(tbeam(jjp1)-tbeam(jj))*tleaf(k)
c		write(19,*)jjp1,sup(jjp1),sdn(jjp1),xup,xdn
 800  	   continue
	endif
c
 	sup(1)=tbeam(1)*rsoil(k)
c   calc up and down fluxes with diffuse only equations and add
c    source terms to down terms as they are computed.
	aux1=0.
	do 603 j=1,jtot
	aux2=tbeam(j)
	x=sdn(j)+sup(j)
	aux=(aux2-aux1)*(1.-aleaf(k,j))
	if(j.eq.1) aux=(aux2-aux1)*rsoil(k)
	aux1=aux2
603	continue
      d(k,jtot)=1.-fbeam(k)
      adum(1)=rsoil(k)
      do 600 j=2,jtot
        tlay2=tlayer(j)*tlayer(j)
        jm1=j-1
 600    adum(j)=adum(jm1)*tlay2/(1.-adum(jm1)*rlayer(j))+rlayer(j)
      do 700 j=2,jtot
        jj=jtot-j+1
        jjp1=jj+1
        d(k,jj)=d(k,jjp1)*tlayer(jjp1)/(1.-adum(jj)*rlayer(jjp1))
     &           +sdn(jjp1)
 700    u(k,jjp1)=adum(jjp1)*d(k,jjp1)+sup(jjp1)
      u(k,1)=rsoil(k)*d(k,1)+sup(1)
c
c  calculate total diffuse up and down considering beam sources.
 1045 iter=0
 900  irept=0
      iter=iter+1
      do 1000 j=2,jtot
        jj=jtot-j+1
        jjp1=jj+1
        down=tlayer(jjp1)*d(k,jjp1)+u(k,jj)*rlayer(jjp1)+sdn(jjp1)
        if(abs(down-d(k,jj))-.0001)1000, 1000, 950
 950    irept=1
 1000   d(k,jj)=down
      u(k,1)=(d(k,1)+tbeam(1))*rsoil(k)
      do 1200 jj=2,jtot
        jjm1=jj-1
        up=rlayer(jj)*d(k,jj)+u(k,jjm1)*tlayer(jj)+sup(jj)
        if(abs(up-u(k,jj))-.0001) 1100,1100,1050
 1050   irept=1
 1100   u(k,jj)=up
 1200 continue
c
c  calculate the diffuse and direct rad absorbed by layer j
	do 1203 j=2,jtot
	a=d(k,j)-u(k,j)+tbeam(j)-(d(k,j-1)-u(k,j-1)+tbeam(j-1))
	adif=(d(k,j)+u(k,j-1))*(1-expdif)*aleaf(k,j)
	adir=(tbeam(j)-tbeam(j-1))*aleaf(k,j)
	ad=adif+adir
1203	continue
 1260 if(irept) 900, 2000, 900
c  calculate fraction of leaf area in class i that is associated with
c  light incident in class i.
c  frarea(i,j) sums to 1. over leaf angl classes including shaded
 2000 jtotm1=jtot-1
      do 3000 j=2,jtot
      jm1=j-1
      if(tbeam(jtot)-.0001)2050,2100,2100
 2050 sunlit=0.
      go to 2200
 2100 if (path(ihr).gt.-.9 ) then
	  sunlit=(tbeam(j)-tbeam(jm1))/(tbeam(jtot)*df)/
     &			(xint(ihr)*path(ihr))
      else
	  sunlit = 0.0
      endif
c in above stm original 2.* was replaced by /xint(ihr), Chen, 9/7/89.
c	--------
c	| path added LMM 93/9/31
c
 2200 do 2500 i=1,itot
       frarea(i,j)=sunlit*distls(i,ihr)
c in above stm original fr(i) was replaced by distls(i,ihr), Chen.
 2500 continue
      frarea(itotp1,j)=1-sunlit
 3000 continue
c      beam(k)= fbeam(k)*radabv(k)/coszen
c
c	--------
c	| since fbeam and radabv are modified by slope,
c	| need to use cosdlt which is the angle between the
c	| sun and the slope to get the beam intensity. LMM
	beam(k)= fbeam(k)*radabv(k)/cosdlt
      d(k,1)=d(k,1)*radabv(k)
      u(k,1)=u(k,1)*radabv(k)
      bmflx(k,1)=tbeam(1)*radabv(k)
      do2600j=2,jtot
      jm1=j-1
c  convert to flux densities
      u(k,j)=u(k,j)*radabv(k)
      d(k,j)=d(k,j)*radabv(k)
 2600 bmflx(k,j)=tbeam(j)*radabv(k)
      do3100j=2,jtot
      jm1=j-1
      dsdum(k,j)=0.
c  next line calculates diffuse rad above layer
c      dstrad(k,itotp1,j)=(u(k,jm1)+d(k,j))*(1.-expdif)/df
c above stm was commented because it did not include the multiple
c scattering within the layer j. the absorbed diffuse radiation by
c layer j is (u(k,jm1)+d(k,j))*(1-tlayer-rlayer), and the absorbed
c direct radiation is (bmflx(k,j)-bmflx(jm1))*aleaf(k,j). due to the
c multiple scattering within the layer, the total absorption caused
c by direct radiation is (bmflx(k,j)-bmflx(k,jm1))-s(k,j). therefore
c (bmflx(k,j)-bmflx(k,jm1)-s(k,j)-(bmflx(k,j)-bmflx(k,jm1))*aleaf(k)
c =(bmflx(k,j)-bmflx(k,jm1))*(1-aleaf(k))-s(k,j) is the additional
c contribution to absorption, which can be included for simplicity
c in diffuse absorption as follows: (Chen, 10/3/89)
	adif1=(u(k,jm1)+d(k,j))*(1.-tlayer(j)-rlayer(j))
	adif2=(bmflx(k,j)-bmflx(k,jm1))*(1.-aleaf(k,j))
     1        -(sdn(j)+sup(j))*radabv(k)
	dstrad(k,itotp1,j)=(adif1+adif2)/df/aleaf(k,j)
c  next line calculated average diffuse rad at midpoint of layer.
c     dstrad(k,itotp1,j)=(d(k,j)+d(k,jm1)+u(k,jm1)+u(k,j))*.5
c    &*(1.-expdif)/df
      dsdum(k,j)=dsdum(k,j)+dstrad(k,itotp1,j)*frarea(itotp1,j)*df
     &*aleaf(k,j)
	proj=0.
      do 2700 i=1,itot
      dstrad(k,i,j)=dstrad(k,itotp1,j)+ beam(k)*ct(i)
 2700 dsdum(k,j)=dsdum(k,j)+dstrad(k,i,j)*frarea(i,j)*df*aleaf(k,j)
      rnldiv=d(k,j)-u(k,j)+bmflx(k,j)-(d(k,jm1)-u(k,jm1)+bmflx(k,jm1))
c     if(ihr.gt.5)write(15,2701)ihr,j,dsdum(k,j),rnldiv
 2701 format(' solar ',2i3,2f7.2)
 3100 continue
      go to 5000
 4000 continue
c  treat thermal wavelengths.
c  compute thermal source terms
c  check to see if solar has been executed(day or night)
      sdn(1)=0.
      do4009 j=1,jtot
	  adum(j)=0.
 4009     bmflx(3,j)=0.
      if(kstrt-3)4020,4010,4010
c  check if night or recycling of leaf energy balance
 4010 if(coszen-.01)4012,4012,4020
 4012 do4015j=2,jtot
      sdn(j)=emis*sigma*(templf(itotp1,j)+273.)**4
      do4014 i=1,itotp1
      frarea(i,j)=0.
      dstrad(3,i,j)=sdn(j)
      dstrad(1,i,j)=0.
 4014 dstrad(2,i,j)=0.
      frarea(itotp1,j)=1.
      d(1,j)=0.0
      d(2,j)=0.0
      tbeam(j)=0.0
      bmflx(1,j)=0.0
      bmflx(2,j)=0.0
      sdn(j)=sdn(j)*(1.-expdif)
 4015 sup(j)=sdn(j)
      d(1,1)=0.0
      d(2,1)=0.0
      tbeam(1)=0.0
      bmflx(1,1)=0.0
      bmflx(2,1)=0.0
      expdir=0.
      go to 4200
 4020 do 4100 j=2,jtot
      source=0.
      do 4050 i=1,itotp1
c      if(iday.eq.2)write(*,*)emis,sigma,templf(i,j)
      dstrad(3,i,j)=emis*sigma*(templf(i,j)+273.)**4
      source=source+frarea(i,j)*dstrad(3,i,j)
 4050 continue
      sdn(j)=source*(1.-expdif)
 4100 sup(j)=source*(1.-expdif)
c  thermal boundary conditions
 4200 continue
c  tsfc is soil sfc temp for each iteration.  its calc'd in main
c    program after profl2 is called.
      esoil =emisol*sigma*(tn(ihr,jzsfc+1)+273.)**4
      d(k,jtot)=radabv(3)
c  compute thermal layer properties
c     tlayer=expdif
c     rlayer=(1.-expdif)*(1.-emis)
c  assume thermal reflectance =0 and call u+d
      do 4500 j=2,jtot
      jm1=j-1
      jj=jtot-j+1
      jjp1=jj+1
 4500 d(k,jj)=tlayer(jjp1)*d(k,jjp1)+sdn(jjp1)
      sup(1)=d(k,1)*(1.-emisol)
      u(k,1)=esoil+sup(1)
      do4600j=2,jtot
      jm1=j-1
 4600 u(k,j)=tlayer(j)*u(k,jm1)+sup(j)
c  iterate 2 times with refl=1-emis
 4580 do 4900 jjj=1,2
      do 4800 j=2,jtot
      jm1=j-1
      jj=jtot-j+1
      jjp1=jj+1
 4800 d(k,jj)=tlayer(jjp1)*d(k,jjp1)+u(k,jj)*rlayer(jjp1)
     &         +sdn(jjp1)
      sup(1)=d(k,1)*(1.-emisol)
      u(k,1)=esoil+sup(1)
      do4810j=2,jtot
      jm1=j-1
 4810 u(k,j)=rlayer(j)*d(k,j)+u(k,jm1)*tlayer(j)+sup(j)
 4900 continue
c
c  sum up thermal contribution to dstnet to be sure it matches u and d
c    thermal. dstnet is calc'd below.
      do4910j=2,jtot
      dsdum(k,j)=0.
      jm1=j-1
      do4905i=1,itotp1
      xxx=(1.-expdif)/df
c     dumean=(d(k,j)+d(k,jm1)+u(k,jm1)+u(k,j))*.5
c     dsdum(k,j)=dsdum(k,j)+(dumean*emis-2.*dstrad(k,i,j))*xxx
c    &*df*frarea(i,j)
c above 3 lines were commented, and following added, Chen 10/3/89.
      dsdum(k,j)=dsdum(k,j)-2.*dstrad(k,i,j)*xxx*df*frarea(i,j)
 4905 continue
      dsdum(k,j)=dsdum(k,j)+(d(k,j)+u(k,jm1))*
     &                             (1.-tlayer(j)-rlayer(j))
c above stm was added by Chen, 10/3/89.
      rnldiv=d(k,j)-u(k,j)-(d(k,jm1)-u(k,jm1))
c     write(15,4915)ihr,j,dsdum(k,j),rnldiv,sdn(j),sup(j)
 4915 format(' thermal ',2i3,4f8.2)
 4910 continue
c
c                                                  label file write 4
c
 5000 continue
      if(ioutpt.eq.0)go to 5030
      if(k-2)5005,5006,5007
 5005 if(iwrite(5,1).eq.1)write(21,5010)k,icumdy,ihr
 5010 format(' 150',i1,i3,i2,4x,/14x,'  iter  expdir expdif  clump')
      go to 5009
 5006 if(iwrite(5,2).eq.1)write(21,5011)k,icumdy,ihr
 5011 format(' 150',i1,i3,i2,4x,/14x,'  iter  expdir expdif  clump')
       go to 5009
 5007 if(iwrite(5,3).eq.1)write(21,5012)k,icumdy,ihr
 5012 format(' 150',i1,i3,i2,4x,/14x,'  iter  expdir expdif  clump')
 5009 continue
      qiter=iter
      if(iwrite(5,1).eq.1.and.k.eq.1)go to 5014
      if(iwrite(5,2).eq.1.and.k.eq.2)go to 5014
      if(iwrite(5,3).eq.1.and.k.eq.3)go to 5014
      go to 5024
 5014 write(21,5015)k,icumdy,ihr,qiter,expdir,expdif,clump
 5015 format(' 250',i1,i3,i2,4x,9f7.2)
      write(21,5025)k,icumdy,ihr
 5025 format(' 150',i1,i3,i2,4x,/14x,' clai   rlayer tlayer',
     1'   d      u    tbeam  bmflx  rn123   rnet ')
 5024 continue
c                                                       file write 4
c
 5030 do5040j=1,jtot
      jout=jtot-j+1
      clai(jout)=(j-1)*df
      if(k.eq.1.or.k.eq.2)rnlam(k,jout)=d(k,jout)-u(k,jout)
     1 +bmflx(k,jout)
      if(k.eq.3)rnlam(k,jout)=d(k,jout)-u(k,jout)
c +smsup3(jout) in above stm was added by Chen, 9/30/89.
      rnet(jout)=rnlam(1,jout)+rnlam(2,jout)+rnlam(3,jout)
      if(iwrite(5,1).eq.1.and.k.eq.1)go to 5038
      if(iwrite(5,2).eq.1.and.k.eq.2)go to 5038
      if(iwrite(5,3).eq.1.and.k.eq.3)go to 5038
      go to 5040
 5038 if(ioutpt.eq.1)write(21,5026)k,icumdy,ihr,jout,clai(jout)
     1,rlayer(jout),tlayer(jout),d(k,jout),u(k,jout),tbeam(jout)
     2,bmflx(k,jout),rnlam(k,
     3jout),rnet(jout)
 5026 format(' 250',i1,i3,i2,2x,i2,  9f7.2)
 5040 continue
c     if(ihr.ge.20)write(25,5069)ihr,ihr,rnet(1),d(3,1),u(3,1)
 5069 format(1x,2i3,3e10.4)
      do5970j=2,jtot
      jm1=j-1
c	write(6,*)'j,dsdum1,2,3=',j,dsdum(1,j),dsdum(2,j),dsdum(3,j)
c	write(6,*)'j,absor1,2,3=',j,rnlam(1,j)-rnlam(1,jm1),rnlam(2,j)
c     1  -rnlam(2,jm1),rnlam(3,j)-rnlam(3,jm1)
 5970 rndiv(j)=rnet(j)-rnet(jm1)
      rndiv(1)=rnet(1)
 5900 continue
 5200 do6500j=2,jtot
      jm1=j-1
      dstng(j)=0.
      do 6000i=1,itotp1
c  calc thermal dif at layer midpoint
      dstnet(i,j)=dstrad(1,i,j)*aleaf(1,j)+dstrad(2,i,j)*aleaf(2,j)+
c     &((d(3,j)+d(3,jm1)+u(3,jm1)+u(3,j))*.5*emis
c     &-2.*dstrad(3,i,j))*(1.-expdif)/df
c above two line were replaced by the following two, Chen, 10/3/89.
     & (d(3,j)+u(3,jm1))*(1.-tlayr(3,j)-rlayr(3,j))/df
     & -2.*dstrad(3,i,j)*(1.-expdif)/df
      dstng(j)=dstng(j)+dstnet(i,j)*df*frarea(i,j)
 6000 continue
      dstng2(j)=dsdum(1,j)+dsdum(2,j)+dsdum(3,j)
c     write(16,6002)ihr,j,rndiv(j),dstng(j),dstng2(j)
c	write(6,*)'j,rndiv,dstng,dstng2=',j,rndiv(j),dstng(j),dstng2(j)
 6002 format(' total ',2i3,3f8.2)
 6500 continue
c                                                  label file write 5
c
      if(ioutpt.eq.0)go to 6550
      if(iwrite(8,1).eq.1)write(21,5050)icumdy,ihr
 5050 format(' 1801',i3,i2,4x,/14x,' dstnet dstvis dstnir dstthr prarea
     1  ps1 ')
      if(iwrite(8,2).eq.1)write(21,5052)icumdy,ihr
 5052 format(' 1802',i3,i2,4x,/14x,' templf  delt   evap   heat   gevap'
     1' gheat rsleaf rsnovp ')
c                                                       file write 5
c
      jtotm1=jtot-1
      do5100iout=1,itotp1
      do5100j=1,jtotm1
      jout=jtot-j+1
      prarea=frarea(iout,jout)*100.
      if(iwrite(8,1).eq.1)write(21,5051)icumdy,ihr,iout,jout,dstnet(iout
     1,jout),dstrad(1,iout,jout),dstrad(2,iout,jout),dstrad(3,iout,jout)
     2,prarea,psleaf(iout,jout)
 5051 format(' 2801',i3,i2,i2,i2,  9f7.2)
      if(iwrite(8,2).eq.1)write(21,5053)icumdy,ihr,iout,jout,templf(iout
     1,jout),delt(iout,jout),evap(iout,jout),heat(iout,jout),
     2gevap(iout,jout),gheat(iout,jout),rsleaf(iout,jout),
     3rsnovp(iout,jout)
 5053 format(' 2802',i3,i2,i2,i2,  6f7.2,2f7.1)
 5100 continue
 5150 continue
c  calc average flux density downward for shaded leaves. this
c    is for simplified model using only sunlit and shaded leaves.
c    must ave all d(k,j) above lai of interest
      do5190k=1,2
      do5190j=1,jtot
 5190 dave(k,j)=0.
      do5350k=1,2
      jtotm1=jtot-1
      do5350j=1,jtotm1
      jout=jtot-j+1
c     shade(k,jout)=d(k,jtot)*exp(-.5*clai(jout)**.7)+radabv(k)*fbeam(k)
c    1*.1*(1.-.1*clai(jout))*exp(-coszen)
c above stm was commented and following three were added by Chen, 9/7/89.
	if(coszen.lt.01)goto 5355
c above stm was added by chen, 01/23/90.
      x=0.5
      if(ispher.ne.1) x=xintz(int(thetas/(pi/2.)*90)+1)
      shade(k,jout)=d(k,jtot)*exp(-clump*x*clai(jout)**.7)
     1   +radabv(k)*fbeam(k)*.1*(1.-.1*clai(jout))*exp(-coszen)
 5355	continue
c above stm was added by chen, 01/23/90.
      do5300l=1,j
      lout=jtot-l+1
 5300 dave(k,jout)=dave(k,jout)+(d(k,lout)+d(k,lout-1))/2.
      dave(k,jout)=dave(k,jout)/j
 5350 continue
c     write(27,5373)ihr
 5373 format(1x,' ihr=',i3)
      do5375j=1,jtotm1
      jout=jtot-j+1
c     write(27,5376)clai(jout-1),dave(1,jout),shade(1,jout),dave(2,jout)
c    1,shade(2,jout)
 5376 format(1x,f5.2,4f6.1)
 5375 continue
 6550 continue
 7700 continue
      return
      end


       subroutine rdffdt(ffname,mtitle,mleg,mpts, ntitle, nleg, npts,
     $      title, reff, rwignr, degen, xyz, ipot, iz,
     $      qf,amplit,phase,cphase,sphase,xlamb,realp)
c
c//////////////////////////////////////////////////////////////////////
c Copyright (c) 1997--2000 Matthew Newville, The University of Chicago
c Copyright (c) 1992--1996 Matthew Newville, University of Washington
c
c Permission to use and redistribute the source code or binary forms of
c this software and its documentation, with or without modification is
c hereby granted provided that the above notice of copyright, these
c terms of use, and the disclaimer of warranty below appear in the
c source code and documentation, and that none of the names of The
c University of Chicago, The University of Washington, or the authors
c appear in advertising or endorsement of works derived from this
c software without specific prior written permission from all parties.
c
c THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
c EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
c MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
c IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
c CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
c TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
c SOFTWARE OR THE USE OR OTHER DEALINGS IN THIS SOFTWARE.
c//////////////////////////////////////////////////////////////////////
c
c  read a feffnnnn.dat file
       implicit none
       integer  i, ier1, ier2, ier3, ier4, ix, ileg, nwords
       integer      mtitle, mleg, mpts, ntitle, nleg, npts, istrln
       character*(*) ffname, title(mtitle), filnam*128
       integer       ipot(0:mleg), iz(0:mleg)
       double precision  reff, rwignr, degen, xyz(3,0:mleg)
       double precision  qf(*), amplit(*), phase(*)
       double precision  cphase(*), sphase(*)
       double precision  xlamb(*), realp(*), zero, xlmin

       character*40 stat*5, line*90, words(16), messg*80
       integer  iunit, iex, ierr
       parameter (zero = 0, xlmin = 1.d-8)
       double precision cdel, afeff,phfeff, redfac, xk, xlmda,  preal
       external istrln
       data  stat /'old'/

       iunit = 0
       xk    = zero
       filnam = ffname
       call openfl(iunit, filnam , stat, iex, ierr)
       if ((iex.lt.0).or.(ierr.lt.0))
     $      call warn(3, ' error reading file: '//filnam)
c  read top of feff.dat, keeping first mtitle comment lines
       ntitle = 0
 150   continue
       ntitle = ntitle + 1
       read(iunit,999) line
       call sclean(line)
       call triml(line)
       if (line(3:6) .eq. '----')  goto 200
       if (ntitle.le.mtitle) title(ntitle) = line
       go to 150
 200   continue
c   read and save reff and degen: feff version 5.03 and higher
       read(iunit,999) line
       call sclean(line)
       nwords = 4
       call bwords(line(2:), nwords, words)
       call str2in(words(1), nleg,   ier1)
       if (nleg .gt. mleg) then
          write(messg,'(2x,a,i2)')
     $         'too many legs in path. current limit is', mleg
          call echo(messg)
          call warn(2,'   '//filnam)
       end if
       call str2dp(words(2), degen,  ier2)
       call str2dp(words(3), reff,   ier3)
       call str2dp(words(4), rwignr, ier4)
       if ( (ier1.ne.0).or.(ier2.ne.0).or.(ier3.ne.0).or.
     $      (ier4.ne.0) )   then
          call warn(3, '   bad data in feffnnnn.dat file: '//filnam)
       end if
c   skip label and read and save path coordinates information
       read(iunit,999) line
       call sclean(line)
       nwords = 5
       do 300  ileg = 0, nleg - 1
          read(iunit,999) line
          call sclean(line)
          call bwords(line(2:), nwords, words)
          do 270 ix = 1, 3
             call str2dp( words(ix), xyz(ix,ileg),ierr )
 270      continue
          call str2in( words(4), ipot(ileg), ierr )
          call str2in( words(5), iz(ileg), ierr )
 300   continue
c      fill in last coordinate = first coordinate
       do 350  ix = 1, 3
          xyz(ix,nleg) = xyz(ix,0)
 350   continue
       iz(nleg)   = iz(0)
       ipot(nleg) = ipot(0)
c
c  skip one line then
c  read in q, amplit, phase, and real and imag parts of p
       read(iunit,999) line
       call sclean(line)
       nwords  = 7
       do 500 i = 1, mpts + 1
c
c          read(iunit,*, end = 505) xk, cdel, afeff, phfeff,
c     $        redfac, xlmda, preal

          if (i.gt.mpts) then
             call echo('  not enough memory for feff file: '//filnam)
             write(messg,'(2x,a,i3,a)') 'results above k = ',
     $            int(xk), ' will not be reliable'
             call warn(3, messg)
          end if

          read(iunit,999,end=505) line
          call sclean(line)
          if (istrln(line).ge.1)  then
             call bwords(line, nwords, words)
             if (nwords .lt. 7) then
                call echo(' invalid feff file: '//filnam)
                go to 505
             end if
             call str2dp(words(1), qf(i),     ier1)
             call str2dp(words(2), cphase(i), ier1)
             call str2dp(words(3), amplit(i), ier1)
             call str2dp(words(4), sphase(i), ier1)
             call str2dp(words(5), redfac,    ier1)
             call str2dp(words(6), xlmda,     ier1)
             call str2dp(words(7), realp(i),  ier1)

             amplit(i) = amplit(i) * redfac
             xlamb(i)  = max(xlmin, xlmda)
          end if
 500   continue
 505   continue
       npts = i - 1
       close(iunit)
c
c  make sure no 2pi jumps in phase
       phase(1)  = cphase(1) + sphase(1)
       do 800  i = 2, npts
          call pijump ( cphase(i), cphase(i-1))
          call pijump ( sphase(i), sphase(i-1))
          phase(i)  = cphase(i) + sphase(i)
 800   continue
c
c  check that qf is monotonically increasing, filling in the high k
c  points if needed (feff provides monotonically increasing data, so the
c  first npts of qf are ok -- we just want to fill in the rest
c  of the points for later extrapolations)
       do 850  i = npts,  mpts
          if (qf(i).lt.qf(i-1)) then
             qf(i)=2*qf(i-1)-qf(i-2)
             amplit(i) = zero
             cphase(i) = zero
             sphase(i) = zero
             phase(i)  = zero
             realp(i)  = zero
             xlamb(i)  = 1.d10
          end if
 850   continue
c      done
       return
 999   format(a)
c end subroutine rdffdt
       end
       subroutine rdfb1(ffname,iunit,mtitle,mleg,mpts,npack,
     $      ntitle,npot,npts,rnrmav,l0,title,izpot,phc,ck,xk)
c
c  read top of feff.bin
       implicit none
       integer npot, npts, mtitle, mleg, mpts, iunit, ivers
       character*(*) ffname, filnam*128, title(mtitle), baddat*256
       integer izpot(0:mleg), l0, ntext,i, ntitle,ier1, ier2, ier3
       integer mptsx
       parameter(mptsx= 128)
       complex*16       phc(*), ck(*)
       double precision xk(*), ere(mptsx), rnrmav
       integer  mwords, ierr, nwords, npack
       character*128 str
       parameter (mwords = 20 )
       character*30 words(mwords)
       if (npack.le.3) npack  = 8
       filnam = ffname
       baddat  = '   bad data in feff.bin file: '//filnam
 10    format(a)
c first line identifies file (only)
       read(iunit,10) str
       call sclean(str)
       if ((str(1:10).ne.'#_feff.bin'))  call echo(baddat)
       ivers = 1
ccc       if (str(1:14).eq.'#_feff.bin fil')   ivers = 1
       if (str(1:14).eq.'#_feff.bin v02')   ivers = 2

c second line contains ntitle, npot, npts
       read(iunit,10) str
       call sclean(str)
       if ((str(1:2).ne.'#_'))  call echo(baddat)
       nwords = 3
       call bwords(str(3:),nwords,words)
       if (nwords.ne.3)     call echo(baddat)
       call str2in(words(1), ntext, ier1)
       call str2in(words(2), npot,  ier2)
       call str2in(words(3), npts,  ier3)
       if ((ier1.ne.0).or.(ier2.ne.0).or.(ier3.ne.0))
     $      call echo(baddat)
c title lines
       ntitle = min(ntext,mtitle)
       do 20  i = 1, ntext
          read(iunit,10) str
          call sclean(str)
          if (str(1:2).ne.'#"')  call echo(baddat)
          if (i.le.ntitle) title(i) = str(3:)
 20    continue
c line with several numbers, only rnrmav and l0 are needed for exafs
       read(iunit,10) str
       call sclean(str)
       if (str(1:2).ne.'#&')   call echo(baddat)
       nwords = 8
       call bwords(str(3:),nwords,words)
       if (ivers.eq.1) then
           if (nwords.ne.8)   call echo(baddat)
           call str2dp(words(3), rnrmav, ier1)
           call str2in(words(8), l0, ier2)
           if ((ier1.ne.0).or.(ier2.ne.0))  call echo(baddat)
        elseif (ivers.eq.2) then
           if (nwords.ne.5)   call echo(baddat)
           call str2dp(words(2), rnrmav, ierr)
           call str2in(words(5), l0, ier2)
           if ((ier1.ne.0).or.(ier2.ne.0))  call echo(baddat)
        end if
c read pot labels and atomic numbers
       read(iunit,10) str
       call sclean(str)
       if (str(1:2).ne.'#@')   call echo(baddat)
       nwords = min(mwords, 2 * npot + 2 )
       call bwords(str(3:), nwords, words)
       if (nwords.ne.(2 + 2*npot))  call echo(baddat)
       do 30 i = 0, npot
          call str2in(words(2+npot+i),izpot(i),ier1)
          if (ier1.ne.0)    call echo(baddat)
 30    continue
c
c read packed arrays
       call rdpadc(iunit,npack,phc, npts)
       call rdpadr(iunit,npack,ere, npts)
       call rdpadc(iunit,npack,ck,  npts)
       call rdpadr(iunit,npack,xk,  npts)
c done
       return
       end


      SUBROUTINE PHO_DIFDIS(Idif1,Idif2,Imoth1,Imoth2,Sprob,Imode,Msoft,
     &                      Mhard,Irej)
C***********************************************************************
C
C     sampling of diffractive events of different kinds,
C                            (produced particles stored in /POEVT1/)
C
C     input:   IDIF1/2   diffractive process particle 1/2
C                          0   elastic/quasi-elastic scattering
C                          1   diffraction dissociation
C              IMOTH1/2  index of mother particles in /POEVT1/
C              SPROB     suppression factor (survival probability) for
C                        resolved diffraction dissociation
C              IMODE     mode of operation
C                          0  sampling of diffractive cut
C                          1  sampling of enhanced cut
C                          2  sampling of diffractive cut without
C                             scattering (needed for double-pomeron)
C                         -1  initialization
C                         -2  output of statistics
C
C     output:   MSOFT    number of generated soft strings
C               MHARD    number of generated hard strings
C               IDIF1/2  diffraction label for particle 1/2 in /PROCES/
C                          0   quasi elastic scattering
C                          1   low-mass diffractive dissociation
C                          2   soft high-mass diffractive dissociation
C                          3   hard resolved diffractive dissociation
C                          4   hard direct diffractive dissociation
C               IREJ     rejection label
C                          0  successful generation of partons
C                          1  failure
C
C***********************************************************************
      IMPLICIT NONE
      DOUBLE PRECISION am12 , am22 , anorf , DEPS , DT_RNDM , EPS ,
     &                 PHO_DFMASS , PHO_PMASS , PHO_XLAM , pimass ,
     &                 pref2 , ptot1 , slwght , Sprob , ss , thrm1 ,
     &                 thrm2 , tt , xmmin , xmnew
      INTEGER i , i1 , i2 , icpos , idbam , Idif1 , Idif2 , idir ,
     &        idpdg , ifl1p , ifl2p , igen , Imode , Imoth1 , Imoth2 ,
     &        ip , ipar , ipars1 , ipars2 , ipois1
      INTEGER ipois2 , ipois3 , ipos , iposp , iproc , irbam , Irej ,
     &        irpdg , isam , isp , isth1 , isth2 , itry , itrym , ivec ,
     &        jda11 , jda12 , jda21 , jda22 , jsam
      INTEGER k , khdirs , khpoms , ksam , kspoms , ksregs , Mhard ,
     &        Msoft , ncor , nheps , nslp
      SAVE

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

C  input/output channels
      INCLUDE 'inc/poinou'
C  event debugging information
      INCLUDE 'inc/podebg'
C  general process information
      INCLUDE 'inc/poprcs'
C  internal rejection counters
      INCLUDE 'inc/poloop'
C  global event kinematics and particle IDs
      INCLUDE 'inc/pogcms'
C  c.m. kinematics of diffraction
      INCLUDE 'inc/podcms'
C  obsolete cut-off information
      INCLUDE 'inc/pocut1'
C  some constants
      INCLUDE 'inc/pocons'
C  model switches and parameters
      INCLUDE 'inc/pomdls'
C  Reggeon phenomenology parameters
      INCLUDE 'inc/popreg'
C  parameters of 2x2 channel model
      INCLUDE 'inc/po2cha'
C  table of particle indices for recursive PHOJET calls
      INCLUDE 'inc/porecu'

C  standard particle data interface

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

C  event weights and generated cross section
      INCLUDE 'inc/powght'

      DOUBLE PRECISION p1 , p2 , xmass , amp , pp , pd1 , pd2
      DIMENSION p1(5) , p2(5) , xmass(2) , amp(2) , pp(7,2) , pd1(7) ,
     &          pd2(7)
      DIMENSION idpdg(2) , idbam(2) , ipar(2) , iposp(2,2) , irpdg(2) ,
     &          ivec(2) , irbam(2) , ifl1p(2) , ifl2p(2) , isam(2) ,
     &          jsam(2) , ksam(2) , idir(2) , iproc(2)

      IF ( Imode.EQ.-1 ) THEN
C  initialization
         RETURN
      ELSE IF ( Imode.EQ.-2 ) THEN
C  output of statistics
         RETURN
      END IF

      Irej = 0
C  mass cuts
      pimass = 0.140D0
C  debug output
      IF ( IDEb(45).GE.10 ) THEN
         IF ( LPRi.GT.4 ) WRITE (LO,'(1X,2A,/16X,7I6)')
     &         'PHO_DIFDIS: (1) ' ,
     &        'IDIF1,IDIF2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE' , Idif1 ,
     &        Idif2 , Imoth1 , Imoth2 , Msoft , Mhard , Imode
      END IF
      ipar(1) = Idif1
      ipar(2) = Idif2
C  save current status
      Msoft = 0
      Mhard = 0
      khpoms = KHPom
      kspoms = KSPom
      ksregs = KSReg
      khdirs = KHDir
      ipois1 = IPOix1
      ipois2 = IPOix2
      ipois3 = IPOix3
      jda11 = JDAhep(1,Imoth1)
      jda21 = JDAhep(2,Imoth1)
      jda12 = JDAhep(1,Imoth2)
      jda22 = JDAhep(2,Imoth2)
      isth1 = ISThep(Imoth1)
      isth2 = ISThep(Imoth2)
      nheps = NHEp
C  get mother data
      NPOsd(1) = Imoth1
      NPOsd(2) = Imoth2
      DO i = 1 , 2
         idpdg(i) = IDHep(NPOsd(i))
         idbam(i) = IMPart(NPOsd(i))
         iposp(1,i) = ICOlor(1,NPOsd(i))
         iposp(2,i) = ICOlor(2,NPOsd(i))
         amp(i) = PHO_PMASS(idbam(i),0)
         IF ( idpdg(i).EQ.22 ) THEN
            PMAssd(i) = 0.765D0
            PVIrtd(i) = PHEp(5,NPOsd(i))**2
         ELSE
            PMAssd(i) = PHO_PMASS(idbam(i),0)
            PVIrtd(i) = 0.D0
         END IF
      END DO
C  get CM system
      p1(1) = PHEp(1,Imoth1) + PHEp(1,Imoth2)
      p1(2) = PHEp(2,Imoth1) + PHEp(2,Imoth2)
      p1(3) = PHEp(3,Imoth1) + PHEp(3,Imoth2)
      p1(4) = PHEp(4,Imoth1) + PHEp(4,Imoth2)
      ss = (p1(4)+p1(3))*(p1(4)-p1(3)) - p1(1)**2 - p1(2)**2
      ECMd = SQRT(ss)
      IF ( LPRi.GT.4 .AND. IDEb(45).GE.15 ) WRITE (LO,'(1X,A,E12.4)')
     &      'PHO_DIFDIS: availabe energy' , ECMd
C  check total available energy
      IF ( (amp(1)+amp(2)+0.1D0).GE.ECMd ) THEN
         IF ( LPRi.GT.4 .AND. IDEb(45).GE.2 )
     &         WRITE (LO,'(1X,2A,/5X,A,1P,3E11.3)') 'PHO_DIFDIS: ' ,
     &        'not enough energy for inelastic diffraction' ,
     &        'ECM, particle masses:' , ECMd , amp
         IFAil(7) = IFAil(7) + 1
         Irej = 1
         RETURN
      END IF
C  boost into CMS
      DO i = 1 , 4
         GAMbed(i) = p1(i)/ECMd
      END DO
      CALL PHO_ALTRA(GAMbed(4),-GAMbed(1),-GAMbed(2),-GAMbed(3),
     &               PHEp(1,Imoth1),PHEp(2,Imoth1),PHEp(3,Imoth1),
     &               PHEp(4,Imoth1),ptot1,p1(1),p1(2),p1(3),p1(4))
C  rotation angles
      CODd = p1(3)/ptot1
      SIDd = SQRT(p1(1)**2+p1(2)**2)/ptot1
      COFd = 1.D0
      SIFd = 0.D0
      IF ( ptot1*SIDd.GT.1.D-5 ) THEN
         COFd = p1(1)/(SIDd*ptot1)
         SIFd = p1(2)/(SIDd*ptot1)
         anorf = SQRT(COFd*COFd+SIFd*SIFd)
         COFd = COFd/anorf
         SIFd = SIFd/anorf
      END IF
C  initial particles in CMS
      PDCms(1,1) = 0.D0
      PDCms(2,1) = 0.D0
      PDCms(3,1) = ptot1
      PDCms(4,1) = p1(4)
      PDCms(1,2) = 0.D0
      PDCms(2,2) = 0.D0
      PDCms(3,2) = -ptot1
      PDCms(4,2) = ECMd - p1(4)
C  get new CM momentum
      am12 = PMAssd(1)**2
      am22 = PMAssd(2)**2
      PCMd = PHO_XLAM(ss,am12,am22)/(2.D0*ECMd)

C  coherence constraint (min/max diffractive mass allowed)
      IF ( Imode.EQ.2 ) THEN
         thrm1 = PARmdl(71)/SQRT(1-PARmdl(72))
         thrm1 = MAX(thrm1,PARmdl(70)*PARmdl(71))
         thrm2 = SQRT(1-PARmdl(72))*ECMd
         thrm2 = MIN(thrm2,ECMd/PARmdl(70))
      ELSE
         thrm1 = PARmdl(46)
         thrm2 = PARmdl(45)*ECMd
C  check kinematic limits
         IF ( thrm2.LE.(4.D0*PARmdl(162)) ) ipar(1) = MIN(ipar(1),1)
         IF ( thrm2.LE.(4.D0*PARmdl(163)) ) ipar(2) = MIN(ipar(2),1)
      END IF

C  check energy vs. coherence constraints
      IF ( MAX(PARmdl(162),PMAssd(1)+thrm1).GE.thrm2 ) ipar(1) = 0
      IF ( MAX(PARmdl(163),PMAssd(2)+thrm1).GE.thrm2 ) ipar(2) = 0

C  no phase space available
      IF ( ipar(1)+ipar(2).EQ.0 ) THEN
         IF ( LPRi.GT.4 .AND. IDEb(45).GE.2 )
     &         WRITE (LO,'(1X,2A,1P,E11.3,2(/5X,A,2E11.3))')
     &         'PHO_DIFDIS: ' ,
     &        'not enough phase space for ine. diffraction (Ecm)' ,
     &        ECMd , 'side 1: min. mass, upper mass limit:' ,
     &        MAX(PARmdl(162),PMAssd(1)+thrm1) , thrm2 ,
     &        'side 2: min. mass, upper mass limit:' ,
     &        MAX(PARmdl(163),PMAssd(2)+thrm1) , thrm2
         IFAil(7) = IFAil(7) + 1
         Irej = 1
         RETURN
      END IF

      itry = 0
      itrym = 10
      ipars1 = ipar(1)
      ipars2 = ipar(2)

C  main rejection loop
C -------------------------------
 100  itry = itry + 1
      IF ( itry.GT.1 ) THEN
         IFAil(13) = IFAil(13) + 1
         IF ( itry.GE.itrym ) THEN
            IF ( LPRi.GT.4 .AND. IDEb(45).GE.2 )
     &            WRITE (LO,'(1X,A,I10,2I3)')
     &            'PHO_DIFDIS: rejection (KEVE,IPAR1/2) ' , KEVent ,
     &           ipar
            IFAil(7) = IFAil(7) + 1
            Irej = 1
            RETURN
         END IF
      END IF
      KSPom = kspoms
      KHPom = khpoms
      KHDir = khdirs
      KSReg = ksregs
      ipar(1) = ipars1
      ipar(2) = ipars2
C  reset mother-daugther relations
      NHEp = nheps
      JDAhep(1,Imoth1) = jda11
      JDAhep(2,Imoth1) = jda21
      JDAhep(1,Imoth2) = jda12
      JDAhep(2,Imoth2) = jda22
      ISThep(Imoth1) = isth1
      ISThep(Imoth2) = isth2
      IPOix1 = ipois1
      IPOix2 = ipois2
      IPOix3 = ipois3
C
      nslp = 0
      ncor = 0

C  calculation of kinematics
 200  DO i = 1 , 2
C  sampling of masses
         irpdg(i) = 0
         irbam(i) = 0
         ifl1p(i) = idpdg(i)
         ifl2p(i) = idbam(i)
         ivec(i) = 0
         idir(i) = 0
         isam(i) = 0
         jsam(i) = 0
         ksam(i) = 0
         IF ( ipar(i).EQ.0 ) THEN
C  vector meson dominance assumed
            xmass(i) = amp(i)
            CALL PHO_VECRES(ivec(i),xmass(i),ifl1p(i),ifl2p(i))
C  diffraction dissociation
         ELSE IF ( ipar(i).EQ.1 ) THEN
            xmmin = MAX(PARmdl(161+i),PMAssd(i)+thrm1)
            pref2 = PMAssd(i)**2
            xmass(i) = PHO_DFMASS(xmmin,thrm2,pref2,PVIrtd(i),ISWmdl(22)
     &                 )
         ELSE
            IF ( LPRi.GT.4 ) WRITE (LO,'(/1X,A,2I3)')
     &            'PHO_DIFDIS:ERROR:invalid IPAR1,IPAR2' , ipar(1) ,
     &           ipar(2)
            CALL PHO_ABORT
         END IF
      END DO

C  sampling of momentum transfer
      CALL PHO_DIFSLP(ipar(1),ipar(2),ivec(1),ivec(2),xmass(1),xmass(2),
     &                thrm2,tt,slwght,Irej)
      IF ( Irej.NE.0 ) THEN
         nslp = nslp + 1
         IF ( nslp.LT.100 ) GOTO 200
         IF ( LPRi.GT.4 ) WRITE (LO,'(1X,2A,/10X,2I3,2E12.3)')
     &         'PHO_DIFDIS: ' ,
     &        'too many slope rejections:IPAR1,IPAR2,M1,M2' , ipar ,
     &        xmass
         Irej = 5
         RETURN
      END IF

C  correct for t-M^2 correlation in diffraction
      IF ( DT_RNDM(tt).GT.slwght ) THEN
         ncor = ncor + 1
         IF ( ncor.LT.100 ) GOTO 200
         IF ( LPRi.GT.4 ) WRITE (LO,'(1X,2A,I10)') 'PHO_DIFDIS: ' ,
     &        'too many rejections due to t-M**2 correlation (EVE)' ,
     &        KEVent
         Irej = 5
         RETURN
      END IF

C  debug output
      IF ( IDEb(45).GE.5 ) THEN
         IF ( LPRi.GT.4 ) WRITE (LO,'(1X,A,/5X,2I3,3E12.3)')
     &         'PHO_DIFDIS: IPAR1,IPAR2,XMASS1,XMASS2,TT' , ipar ,
     &        xmass , tt
      END IF
C  not double pomeron scattering
      IF ( Imode.NE.2 ) THEN
C  sample diffractive interaction processes
         DO i = 1 , 2
            IF ( ipar(i).NE.0 ) THEN
C  find particle combination
               IF ( idpdg(i).EQ.IFPap(1) ) THEN
                  ip = 2
               ELSE IF ( idpdg(i).EQ.IFPap(2) ) THEN
                  ip = 3
               ELSE IF ( idpdg(i).EQ.990 ) THEN
                  ip = 4
               ELSE
                  ip = i + 1
               END IF
C  sample dissociation process
               CALL PHO_DIFPRO(ip,ISWmdl(16),idpdg(i),990,xmass(i),
     &            PVIrtd(i),0.D0,Sprob,iproc(i),isam(i),jsam(i),ksam(i),
     &            idir(i))
               IF ( (iproc(i).NE.1) .AND. (iproc(i).NE.8) ) THEN
C  diffractive pomeron-hadron interaction
                  ipar(i) = 10 + iproc(i)
C  store process label
               ELSE IF ( idir(i).GT.0 ) THEN
                  ipar(i) = 4
               ELSE IF ( ksam(i).GT.0 ) THEN
                  ipar(i) = 3
               ELSE IF ( isam(i).GT.0 ) THEN
                  ipar(i) = 2
               ELSE
                  ipar(i) = 1
C  mass fine correction
                  CALL PHO_MASSAD(idpdg(i),ifl1p(i),ifl2p(i),PMAssd(i),
     &               xmass(i),xmnew,irpdg(i),irbam(i))
                  xmass(i) = xmnew
               END IF
C  debug output
               IF ( LPRi.GT.4 .AND. IDEb(45).GE.15 )
     &               WRITE (LO,'(1X,A,/10X,I3,E12.4,5I3)')
     &               'PHO_DIFDIS: IP,XMASS,IPROC,ISAM,JSAM,KSAM,IDIR' ,
     &              ip , xmass(i) , iproc(i) , isam(i) , jsam(i) ,
     &              ksam(i) , idir(i)
            END IF
         END DO
      END IF
C  actualize debug information
      IF ( Imode.EQ.1 ) THEN
         IDIfr1 = ipar(1)
         IDIfr2 = ipar(2)
      END IF
C  calculate new momenta in CMS
      CALL PHO_DIFKIN(xmass(1),xmass(2),tt,p1,p2,Irej)
      IF ( Irej.NE.0 ) GOTO 100
      DO i = 1 , 4
         pp(i,1) = p1(i)
         pp(i,2) = p2(i)
      END DO

C  comment line for diffraction
      icpos = 0
      CALL PHO_REGPAR(30,IPRoce,Imode,NPOsd(1),NPOsd(2),xmass(1),
     &                xmass(2),tt,ECMd,ipar(1),ipar(2),idpdg(1),idpdg(2)
     &                ,icpos,1)
C  write diffractive strings/particles
      DO i = 1 , 2
         i1 = i
         i2 = 3 - i1
         DO k = 1 , 4
            pd1(k) = pp(k,i1)
            pd2(k) = pp(k,i2)
         END DO
         pp(6,i1) = SIGN(PHEp(5,NPOsd(i1))**2,PHEp(5,NPOsd(i1)))
         pp(7,i1) = tt
         igen = IPHist(2,NPOsd(i1))
         IF ( igen.EQ.0 ) igen = -i1*10
         CALL PHO_DIFPAR(NPOsd(i1),NPOsd(i2),igen,ifl1p(i1),ifl2p(i1),
     &                   ipar(i1),pd1,pd2,iposp(1,i1),iposp(2,i1),Imode,
     &                   Irej)
         IF ( Irej.NE.0 ) THEN
            IFAil(7+i) = IFAil(7+i) + 1
            IF ( LPRi.GT.4 .AND. IDEb(45).GE.3 )
     &            WRITE (LO,'(1X,A,2I3,E11.3)')
     &            'PHO_DIFDIS: rejection by PHO_DIFPAR (I,IPAR,XM)' ,
     &           i , ipar(i) , xmass(i)
            GOTO 100
         END IF
         ICOlor(i1,icpos) = iposp(1,i1)
      END DO
C  double-pomeron scattering?
      IF ( Imode.NE.2 ) THEN

C  diffractive final states
         DO i = 1 , 2
 220        IF ( ipar(i).NE.0 ) THEN
               IF ( (iproc(i).EQ.1) .OR. (iproc(i).EQ.8) ) THEN
                  IF ( isam(i)+jsam(i)+ksam(i).EQ.0 ) jsam(i) = 1
                  IF ( idir(i).GT.0 ) THEN
                     ipar(i) = 4
                  ELSE IF ( ksam(i).GT.0 ) THEN
                     ipar(i) = 3
                  ELSE IF ( isam(i).GT.0 ) THEN
                     ipar(i) = 2
                  ELSE
                     ipar(i) = 1
                  END IF
               ELSE
                  ipar(i) = 10 + iproc(i)
               END IF
               IPHist(i,icpos) = ipar(i)
C  update debug informantion
               KSPom = isam(i)
               KSReg = jsam(i)
               KHPom = ksam(i)
               KHDir = idir(i)
               IDIfr1 = ipar(1)
               IDIfr2 = ipar(2)
               IF ( (irpdg(i).NE.0) .AND. (ISWmdl(23).GT.0) ) THEN

C  resonance decay, pi+pi- background
                  p1(1) = PHEp(1,iposp(1,i)) + PHEp(1,iposp(2,i))
                  p1(2) = PHEp(2,iposp(1,i)) + PHEp(2,iposp(2,i))
                  p1(3) = PHEp(3,iposp(1,i)) + PHEp(3,iposp(2,i))
                  p1(4) = PHEp(4,iposp(1,i)) + PHEp(4,iposp(2,i))
                  CALL PHO_REGPAR(1,irpdg(i),irbam(i),iposp(1,i),
     &               iposp(2,i),p1(1),p1(2),p1(3),p1(4),0,2,0,0,ipos,1)
C  decay
                  IF ( idpdg(i).EQ.22 ) THEN
                     IPHist(2,ipos) = 3
                     IF ( ISWmdl(21).GE.0 ) THEN
                        isp = IPAmdl(3)
                        IF ( ISWmdl(21).GE.2 ) isp = IPAmdl(4)
                        CALL PHO_SDECAY(ipos,isp,2)
                     END IF
                  ELSE
                     CALL PHO_SDECAY(ipos,IPAmdl(3),2)
                  END IF
                  Irej = 0

C  particle-pomeron scattering
               ELSE IF ( ipar(i).LE.4 ) THEN
C  non-diffractive particle-pomeron scattering
                  igen = IPHist(2,NPOsd(i))
                  IF ( igen.EQ.0 ) THEN
                     IF ( i.EQ.1 ) THEN
                        igen = 5
                     ELSE
                        igen = 6
                     END IF
                  END IF
                  CALL PHO_STDPAR(iposp(1,i),iposp(2,i),igen,isam(i),
     &               jsam(i),ksam(i),idir(i),Irej)
               ELSE
C  diffractive particle-pomeron scattering
                  IPOix2 = IPOix2 + 1
                  IPOres(IPOix2) = iproc(i)
                  IPOpos(1,IPOix2) = iposp(1,i)
                  IPOpos(2,IPOix2) = iposp(2,i)
               END IF
C  vector meson production
            ELSE IF ( idpdg(i).EQ.22 ) THEN
               IF ( ISWmdl(21).GE.0 ) THEN
                  isp = IPAmdl(3)
                  IF ( ISWmdl(21).GE.1 ) isp = IPAmdl(4)
                  CALL PHO_SDECAY(iposp(1,i),isp,2)
               END IF
C  hadronic state of multi-pomeron coupling
            ELSE IF ( idpdg(i).EQ.990 ) THEN
               CALL PHO_SDECAY(iposp(1,i),0,2)
            END IF

C  rejection?
            IF ( Irej.NE.0 ) THEN
               IFAil(20+i) = IFAil(20+i) + 1
               IF ( ipar(i).GT.1 ) THEN
                  IF ( ipar(i).EQ.3 ) IFAil(7+2*i) = IFAil(7+2*i) + 1
                  IF ( ipar(i).EQ.4 ) IFAil(8+2*i) = IFAil(8+2*i) + 1
                  IF ( idir(i).GT.0 ) THEN
                     idir(i) = 0
                  ELSE IF ( ksam(i).GT.0 ) THEN
                     ksam(i) = ksam(i) - 1
                  ELSE IF ( isam(i).GT.0 ) THEN
                     isam(i) = isam(i) - 1
                  END IF
                  GOTO 220
               ELSE
                  IF ( LPRi.GT.4 .AND. IDEb(45).GE.2 )
     &                  WRITE (LO,'(1X,A,2I3,E11.3)')
     &                  'PHO_DIFDIS: rejection PHO_STDPAR (I,IPAR,XM)' ,
     &                 i , ipar(i) , xmass(i)
                  GOTO 100
               END IF
            END IF
         END DO

         Idif1 = ipar(1)
         Idif2 = ipar(2)
C  update debug information
         KSPom = kspoms + isam(1) + isam(2)
         KSReg = ksregs + jsam(1) + jsam(2)
         KHPom = khpoms + ksam(1) + ksam(2)
         KHDir = khdirs + idir(1) + idir(2)
      END IF

C  debug output
      IF ( IDEb(45).GE.10 ) THEN
         IF ( LPRi.GT.4 ) WRITE (LO,'(1X,2A,/18X,7I6)')
     &         'PHO_DIFDIS: (2) ' ,
     &        'IPAR1,IPAR2,IMOTH1,IMOTH2,MSOFT,MHARD,IMODE' , ipar ,
     &        NPOsd , Msoft , Mhard , Imode
      END IF
      IF ( IDEb(45).GE.15 ) THEN
         IF ( LPRi.GT.4 ) WRITE (LO,'(2(/1X,A))')
     &         'PHO_DIFDIS: output of /POEVT1/' ,
     &        '------------------------------'
         CALL PHO_PREVNT(0)
      END IF

      END SUBROUTINE