C           SUBROUTINE FIT2
      SUBROUTINE FIT2
      REAL MFSTOP
      LOGICAL PREVER
      COMMON /SNTCP/G,AJ,PRPC,ICASE,PREVER,MFSTOP,JUMP,LOPIN,ISCASE,
     1KN,GAMF,IP,SCRIT,PTRN,ISECT,KSTG,WTOL,RHOTOL,PRTOL,TRLOOP,LSTG,
     2LBRC,IBRC,ICHOKE,ISORR,CHOKE,PT0PS1(6,8),PTRS2(6,8),TRDIAG,SC,RC,
     3DELPR,PASS,IPC,LOPC,ISS
C
      COMMON/GEBE/DRBARR,DRBARS,E1,E2,E3,E4,E5,E6,HBRRH,HBRSH,IAFE
     1,IALF,IBT2,ICPR,ICPS,ISR2,ISTR,ISTS,L,R1,R3,R4,R5,
     2TALF,WGT0(8),WT(7),HBARS,HBARR,I
C
      COMMON /SINIT/H1(6,8),H2(6,8),DP0(6,8),DP1(6,8),DP1A(6,8),DP2(6,8)
     1,DP2A(6,8),CSALF1(6,8),ALF1(6,8),CSBET2(6,8),BET2(6,8),RADSD(6,8),
     2RADRD(6,8),ANN1(6,8),ANN2(6,8),ANN2A(6,8),ANN1A(6,8),U1A(6,8),
     3U2(6,8),ANN0(6,8),PT0(6,8),TT0(6,8),ALPHA0(6,8),PTP(6,8)
C
      COMMON /SINPUT/
     1PTPS,PTIN,TTIN,WAIR,FAIR,DELC,DELL,DELA,AACS,VCTD,STG,SECT,EXPN,
     2EXPP,EXPRE,RG,RPM,PAF,SLI,STGCH,ENDJOB,XNAME(20),TITLE(20),
     3PCNH(6),GAM(6,8),DR(6,8),DT(6,8),RWG(6,8),ALPHAS(6,8),ALPHA1(6,8),
     4ETARS(6,8),ETAS(6,8),CFS(6,8),ANDO(6,8),BETA1(6,8),BETA2(6,8),ETAR
     5R(6,8),ETAR(6,8),CFR(6,8),TFR(6,8),ANDOR(6,8),OMEGAS(6,8),AS0(6,8)
     6,ASMP0(6,8),ACMN0(6,8),A1(6,8),A2(6,8),A3(6,8),A4(6,8),A5(6,8),A6(
     76,8),OMEGAR(6,8),BSIA(6,8),BSMPIA(6,8),BCMNIA(6,8),B1(6,8),B2(6,8)
     8,B3(6,8),B4(6,8),B5(6,8),B6(6,8),SESTHI(8),RERTHI(8)
     9,fairx(5,8),wairx(5,8),rg1(8),rg1a(8),rg2(8),rg2a(8)
C
      REAL M0
      COMMON /SSTA01/CP0(8),w0(6),               PS0(6,8),V0(6,8),TS0(6,
     18),VU0(6,8),VZ0(6,8),RHOS0(6,8),PS1(6,8),WGT1(8),TA1(8),WG1(6,8),
     2            DPDR1(6,8),SI(6,8),  CP1(8),PHI1(6,8),TS1(6,8),V1(6,8)
     3,RHOS1(6,8),ALF1E(6,8),VU1(6,8),VZ1(6,8),M0(6,8)
C
      REAL MR1A
      COMMON /SSTA1A/VU1A(6,8),WG1A(6,8),WGT1A(8),VZ1A(6,8),  CP1A(8),
     1PS1A(6,8),RU1A(6,8),R1A(6,8),BET1A(6,8),RI(6,8),TTR1A(6,8),PTR1A(6
     2,8),MR1A(6,8)
C
      COMMON /SSTA2/V2(6,8),TTR2(6,8),PTR2(6,8),WG2(6,8),WGT2(8),TA2(8),
     1           PS2(6,8),PHI2(6,8)
C
      REAL MR2,M2     ,MF2
      COMMON /SFLOW2/TS2(6,8),CP2(8),R2(6,8),RHOS2(6,8),BET2E(6,8),RU2(6
     1,8),VU2(6,8),DPDR2(6,8),VZ2(6,8),MR2(6,8),MF2(6,8),M2(6,8)
C
      REAL M2A,MF2A
      COMMON /SSTA2A/WG2A(6,8),WGT2A(8),VU2A(6,8),VZ2A(6,8),PS2A(6,8),
     1ALF2A(6,8),TT2A(6,8),PT2A(6,8),TTBAR(8),PTBAR(8),STT0(8),SPT0(8),
     2M2A(6,8),MF2A(6,8),CP2A(8),V2A(6,8),TS2A(6,8),TAS(8),PAS(8),GAMS(8
     3),CPO(8),DELHVD(6,8)
C
      COMMON /SOVRAL/DELHT(6,8),DELHTI(6,8),DELHSI(6,8),DEHATI(6,8),
     1ETATT(6,8),ETATS(6,8),ETATAT(6,8),delhtu(6,8)
C
      COMMON /BDINST/
     1IFMI01(4),IFMI02(4),IFMI03(4),IFMI04(4),IFMI05(4),IFMI06(4),
     2IFMI07(4),IFMI08(4),IFMI09(4),IFMI10(4),IFMI11(4),IFMI12(4),
     3IFMI13(4),IFMI14(4),IFMI15(4),IFMI16(4),IFMI17(4),IFMI18(4),
     4IFMI19(4),IFMI20(4),IFMI21(4),IFMI22(4),IFMI23(4),IFMI24(4),
     5IFMI25(4),IFMI26(4),IFMI27(4),IFMI28(4),IFMI29(4),IFMI30(4),
     6IFMI31(4),IFMI32(4),IFMI33(4),IFMI34(4),IFMI35(4),IFMI36(4),
     7IFMI37(4),IFMI38(4),IFMI39(4),IFMI40(4),IFMI41(4),IFMI42(4),
     8IFMI43(4),IFMI44(4),IFMI45(4),IFMI46(4),IFMI47(4),IFMI48(4),
     9IFMI49(4),IFMI50(4),IFMI51(4),IFMI52(4),IFMI53(4),IFMI54(4),
     1IFMI55(4),IFMI56(4),IFMI57(4),IFMI58(4),IFMI59(4),IFMI60(4),
     2IFMI61(4)
C
      COMMON  /C1FIT1/STDP0(7),STTT0(7),STPT0(7),STALF(7)
     1,STSI(7),STV0(7),STVU0(7),STVZ0(7),STTS0(7),
     2STPS0(7),STDEN0(7),STM0(7),STDP1(7),STTT1(7),
     3STALFE(7),STDELA(7),STV1(7),STVU1(7),STVZ1(7),
     4STTS1(7),STPS1(7),STDEN1(7),STM1(7),ZWIINC(7),
     5CPS(7),STDP1A(7),STTTR1(7),STPTR1(7),STBET1(7),
     6STRI(7),STR1A(7),STRU1A(7),STMR1A(7),STU1A(7),
     7STDP2(7),STBET2(7),SDBETA(7),SR2(7),SRU2(7),
     8SMR2(7),SU2(7),RX(7),STDELH(7),STPSI(7),
     9SETATT(7),SETATS(7),SETAAT(7),RZWINC(7),CPR(7),
     1STDP2A(7),STPT2(7),STTT2(7),STV2(7),STVU2(7),
     2STALF2(7),STMF2(7),STVZ2(7),STTS2(7),STPS2(7),
     3STDEN2(7),STM2(7),lj,jj,K
C
      COMMON   /C2FIT1/DBARS(7),FTANS(7),FAXS(7),DBARR(7),
     1FTANR(7),FAXR(7)
      COMMON RES(8),DALF(6),DSTS(6),DALFE(6),DCPS(6),DSTR(6),
     *DBT2(6),DCPR(6),DSR2(6)
      COMMON/TPT1/PT1(6),TT1(6,8)
      COMMON/DESOPT/RVU1(6,8),RVU2(6,8),WG,EPR
      dimension tangms(6,8),tangmr(6,8),tangm1(6,8),tangm2(6,8),tang0(6)
      common/slope/tangms,tangmr,tangm1,tangm2,tang0,iar,icyl
C
      DIMENSION IFMI1(4,61),Y(7,61)
      EQUIVALENCE (IFMI1(1,1),IFMI01(1)),(Y(1,1),STDP0(1))
C
C
      DATA DOR/57.29578/
C        STATION    0        STATOR  INLET
C
C
      STTT0(L)=TT0(I,K)
      STPT0(L)=PTP(I,K)
      STVZ0(L)=VZ0(I,K)
      STVU0(L)=VU0(I,K)*R1
      STV0(L)=SQRT(VZ0(I,K)*VZ0(I,K)+STVU0(L)*STVU0(L))
      STTS0(L)=TT0(I,K)-STV0(L)*STV0(L)/(2.*G*AJ*CP0(K))
      STPS0(L)=PS0(I,K)*(STTS0(L)/TS0(I,K))**E2
      rg0=rg
      if (k.gt.1) rg0=rg2a(k-1)
      STDEN0(L)=144.*STPS0(L)/(rg0*STTS0(L))
      STALF(L)=0.
      STSI(L)=0.
      DRP=1.
      DO 200 ID=1,ISECT
      IF(ID.GT.IALF)GO TO 210
      STALF(L)=STALF(L)+DALF(ID)*DRP*DOR
210   IF(ID.GT.ISTS)GO TO 200
      STSI(L)=STSI(L)+DSTS(ID)*DRP*DOR
200   DRP=DRP*STDP0(L)
      STVZ0(L)=STV0(L)*COS(STALF(L)/57.29578)
      STVU0(L)=STV0(L)*SIN(STALF(L)/57.29578)
      AS0H=SQRT(GAM(1,K)*G*rg0*STTS0(L))
      STM0(L)=STV0(L)/AS0H
C        STATION    1        STATOR  EXIT
      STTT1(L)=TT1(I,K)
      STVZ1(L)=VZ1(I,K)
      STVU1(L)=VU1(I,K)*R2(1,1)
      STV1(L)=SQRT(VZ1(I,K)*VZ1(I,K)+STVU1(L)*STVU1(L))
      STTS1(L)=TT0(I,K)-STV1(L)*STV1(L)/(2.*G*AJ*CP1(K))
      STPS1(L)=PS1(I,K)*(STTS1(L)/TS1(I,K))**E3
      STDEN1(L)=144.*STPS1(L)/STTS1(L)/rg1(k)
      DRP=1.
      STALFE(L)=0.
      CPS(L)=0.
      DO 220 ID=1,ISECT
      IF(ID.GT.IAFE)GOTO 230
      STALFE(L)=STALFE(L)+DALFE(ID)*DRP*DOR
230   IF(ID.GT.ICPS)GO TO 220
      CPS(L)=CPS(L)+DCPS(ID)*DRP
220   DRP=DRP*STDP1(L)
      STVZ1(L)=STV1(L)*COS(STALFE(L)/57.29578)
      STVU1(L)=STV1(L)*SIN(STALFE(L)/57.29578)
      STDELA(L)=STALF(L)+STALFE(L)
      AS1H=SQRT(GAM(2,K)*G*rg1(k)*STTS1(L))
      STM1(L)=STV1(L)/AS1H
      ZS =-2.*STALFE(L)/ 57.2958 -1.570796
      ZWIINC(L)=-2.*COS(ZS)/(1.+ANN0(I,  K)/ANN1(I,  K))
     1*(STVU0(L )*STVZ1(L )/STVZ0(L )/STVU1(L )
     2*ANN1(I,  K)/ANN0(I,  K)+1.)
C        STATION   1A        ROTOR    INLET
      VU1AH=STVU1(L)*STDP1(L)/STDP1A(L)
      VZ1AH=STVZ1(L)*ANN1(I,K)/ANN1A(I,K)
      STRU1A(L)=VU1AH-U1A(I,K)/R3
      STBET1(L)=57.29578*ATAN(STRU1A(L)/VZ1AH)
      T=TALF-(TALF/R3 - SIN(RADRD(I,K))/COS(RADRD(I,K)))/R3
      DRP=1.
      STRI(L)=0.
      DO 240 ID=1,ISTR
      STRI(L)=STRI(L)+DSTR(ID)*DRP*DOR
240   DRP=DRP*STDP1A(L)
      STR1A(L)=SQRT(STRU1A(L)**2+VZ1AH**2)
      V1A1AH=VZ1AH**2+VU1AH**2
      DELTSH=(V1(I,K)*V1(I,K)-V1A1AH)/(2.*G*AJ*CP1A(K))
      TS1AH=TS1(I,K)+DELTSH
      STMR1A(L)=STR1A(L)/SQRT(GAM(3,K)*G*rg1a(k)*TS1AH)
      TTRSH=1.+STMR1A(L)*STMR1A(L)*(GAM(3,K)-1.)/2.
      STTTR1(L)=TS1AH*TTRSH
C     IF (RI(I,K))2,2,7
C     replaced by ........
      IF (RI(I,K).LE.0) THEN
         EXPRI=EXPN
C        GO TO 2
      ELSE
         EXPRI=EXPP
C        GO TO 7
      ENDIF
C
C2     EXPRI=EXPN
C     GO TO 11
C7     EXPRI=EXPP
11    PTRSH=(1.+(TTRSH-1.)*ETARR(I,K)*COS(RI(I,K))**EXPRI)**E4
      PS1AH=PS1(I,K)*(1.+DELTSH/TS1(I,K))**E4
      STPTR1(L)=PS1AH*PTRSH
      STU1A(L)=U1A(I,K)/R3
C        STATION    2        ROTOR    EXIT
      VU2H=VU2(I,K)*R4
      V2V2H=VZ2(I,K)*VZ2(I,K)+VU2H*VU2H
      SU2(L)=U2(I,K)/R4
      DRP=1.
      STBET2(L)=0.
      R2EX=0.
      CPR(L)=0.
      DO 250 ID=1,ISECT
      IF(ID.GT.IBT2)GO TO 260
      STBET2(L)=STBET2(L)+DBT2(ID)*DRP*DOR
260   IF(ID.GT.ICPR)GO TO 270
      CPR(L)=CPR(L)+DCPR(ID)*DRP
270   IF(ID.GT.ISR2)GO TO 250
      R2EX=R2EX+DSR2(ID)*DRP
250   DRP=DRP*STDP2(L)
C     IF ((SU2(L)*COS(STBET2(L)/DOR))**2-V2V2H) 320,320,310
C310   STBET2(L)= DOR*STBET2(L)/ABS(STBET2(L))*ATAN(SQRT(SU2(L)**2
C     1/V2V2H-1.))
C320   U2SNB2=SU2(L)*SIN(STBET2(L)/DOR)
C     replaced by ..........
      IF ((SU2(L)*COS(STBET2(L)/DOR))**2-V2V2H .GT.0.) THEN
         STBET2(L)= DOR*STBET2(L)/ABS(STBET2(L))*ATAN(SQRT(SU2(L)**2
     1/V2V2H-1.))
      ENDIF
      U2SNB2=SU2(L)*SIN(STBET2(L)/DOR)
      SGNDF=R2EX-U2SNB2
      SR2(L)=U2SNB2+SGNDF/ABS(SGNDF)*SQRT(ABS(V2V2H-(SU2(L)
     1*COS(STBET2(L)/57.29578))**2+.0001))
      SRU2(L)=SR2(L)*SIN(STBET2(L)/57.29578)
      VZ2H=SR2(L)*COS(STBET2(L)/57.29578)
      VU2H=SRU2(L)-SU2(L)
      SDBETA(L)=STBET1(L)+STBET2(L)
      DELTSH=(V2(I,K)*V2(I,K)-V2V2H)/(2.*G*AJ*CP2(K))
      TS2H=TS2(I,K)+DELTSH
      SMR2(L)=SR2(L)/SQRT(GAM(4,K)*G*rg2(k)*TS2H)
      PS2H=PS2(I,K)*(TS2H/TS2(I,K))**E5
      RX(L)=1.-(1.-(STPS1(L)/PTP(I,K))**E1)/(1.-(PS2H/PTP(I,K))**E1)
      STDELH(L)=(STU1A(L)*VU1AH+SU2(L)*VU2H)*TFR(I,K)/(   G*AJ)
      STPSI(L)=   G*AJ*STDELH(L)/(STU1A(L)**2+SU2(L)**2)
      SETATT(L)=STDELH(L)/DELHTI(I,K)
      SETATS(L)=STDELH(L)/DELHSI(I,K)
      SETAAT(L)=STDELH(L)/DEHATI(I,K)
      ZR =-2.*STBET2(L)/57.2958 -1.570796
      RZWINC(L )=-2.*COS(ZR)/(1.+ANN1A(I,  K)/ANN2(I,  K))*
     2(STRU1A(L )*VZ2(I,  K)/VZ1(I,  K)/SRU2(L )
     2*ANN2(I,  K)/ANN1A(I,  K)+1.)
      STPT2(L)=PT2A(I,K)
      STTT2(L)=TT2A(I,K)
      STVZ2(L)=VZ2H*ANN2(I,K)/ANN2A(I,K)
      STVU2(L)=VU2H*STDP2(L)/STDP2A(L)
      V2A2AH=STVU2(L)**2+STVZ2(L)**2
      STV2(L)=SQRT(V2A2AH)
      STALF2(L)=ATAN2(STVU2(L),STVZ2(L))*57.29578
      DELTS2=(V2A(I,K)**2-V2A2AH)/(2.*G*AJ*CP2A(K))
      STTS2(L)=TS2A(I,K)+DELTS2
      STPS2(L)=PS2A(I,K)*(1.+DELTS2/TS2A(I,K))**E6
      STDEN2(L)=144.*STPS2(L)/(rg2(k)*STTS2(L))
      STM2(L)=STV2(L)/SQRT(GAM(4,K)*G*rg2(k)*STTS2(L))
      STMF2(L)=STM2(L)*COS(STALF2(L)/57.2958)
      DBARS(L )=DRBARS+HBRSH*(STDP1(L )-DR(2,K))*2.0
      HBRS=H1(I  ,K)*HBRSH*2.
      HBRR=H2(I  ,K)*HBRRH*2.

C array index error here 12/10/03 RWC
      if (k.eq.1) then
          ll=l
          if(l.gt.6) then
            ll=1
          endif
        cat0=cos(atan(tang0(ll)))
      else
          ll=l
          if(l.gt.6) ll=1
        cat0=cos(atan(tangm2(ll,k-1)))
      end if

      cat1=cos(atan(tangm1(ll,k)))
      cat2=cos(atan(tangm2(ll,k)))
      FAXS(L )=((STPS0(L )-STPS1(L ))*(ANN1(I  ,K) +ANN0(I  ,K))*72.
     1+WG1(I  ,K)/G*(STVZ0(L )*cat0-STVZ1(L )*cat1))/HBRS
      FTANS(L )=-WG1(I  ,K)*(STDP1(L )*STVU1(L )+STDP0(L )
     1*STVU0(L ))/DBARS(L )/G/HBRS
      DBARR(L )=DRBARR+HBRRH*(STDP2(L )-DR(4,K))*2.0
      FTANR(L)=WG2(I,K)*(STDP2A(L)*VU2H+STDP1(L)*VU1AH)
     1/DBARR(L )/G/HBRR*TFR(I  ,K)
      FAXR(L)=((PS1AH-PS2H)*(ANN1A(I,K)+ANN2(I,K))*72.+
     1WG2(I,K)/G*(VZ1AH*cat1-VZ2H*cat2))/HBRR
      RETURN
      END


      SUBROUTINE DT_DIFINI

C***********************************************************************
C Initialization of common /DTDIKI/                                    *
C This version dated 12.02.95 is written by S. Roesler                 *
C***********************************************************************

      IMPLICIT NONE
      INTEGER k
      DOUBLE PRECISION OHALF , ONE , ZERO
      SAVE

      INCLUDE 'inc/dtflka'

      PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)

C kinematics of diffractive interactions (DTUNUC 1.x)
      INCLUDE 'inc/dtdiki'

      DO k = 1 , 4
         PPOm(k) = ZERO
         PSC(k) = ZERO
         PPF(k) = ZERO
         PTF(k) = ZERO
         PPLm1(k) = ZERO
         PPLm2(k) = ZERO
         PTLm1(k) = ZERO
         PTLm2(k) = ZERO
      END DO
      DO k = 1 , 2
         XPH(k) = ZERO
         XPPo(k) = ZERO
         XTH(k) = ZERO
         XTPo(k) = ZERO
         IFPpo(k) = 0
         IFTpo(k) = 0
      END DO
      IDPr = 0
      IDXpr = 0
      IDTr = 0
      IDXtr = 0

      END SUBROUTINE


!!  Copyright (C)  Stichting Deltares, 2012-2016.
!!
!!  This program is free software: you can redistribute it and/or modify
!!  it under the terms of the GNU General Public License version 3,
!!  as published by the Free Software Foundation.
!!
!!  This program is distributed in the hope that it will be useful,
!!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!!  GNU General Public License for more details.
!!
!!  You should have received a copy of the GNU General Public License
!!  along with this program. If not, see <http://www.gnu.org/licenses/>.
!!
!!  contact: delft3d.support@deltares.nl
!!  Stichting Deltares
!!  P.O. Box 177
!!  2600 MH Delft, The Netherlands
!!
!!  All indications and logos of, and references to registered trademarks
!!  of Stichting Deltares remain the property of Stichting Deltares. All
!!  rights reserved.

      SUBROUTINE DLTEST(
! trisula parameters:
     *                  lundia    ,timest    ,
     *                  icx       ,icy       ,jstart    ,nmmaxj    ,
     *                  nmmax     ,kmax      ,
     *                  qxk       ,qyk       ,qzk       ,
     *                  kcs       ,kfs       ,kfu       ,kfv       ,
     *                  gvu       ,guv       ,gzz       ,
     *                  r1        ,
     *                  aak       ,bbk       ,cck       ,
     *                  bdddx     ,bddx      ,bdx       ,
     *                  buuux     ,buux      ,bux       ,
     *                  uvdwk     ,vvdwk     ,
     *                  aakl      ,bbkl      ,cckl      ,ddkl      ,
! delwaq parameters:
     *                  nosys     ,notot     ,vol0      ,vol1      ,
     *                  intsrt    ,
     *                  difx      ,dify      ,difz      )
!
!
!     Deltares     SECTOR WATERRESOURCES AND ENVIRONMENT
!
!     CREATED             : August 1996 by E. de Goede
!
!     FUNCTION            : TRISULA transport scheme implemented in DELWAQ
!                           A choice between central and upwind differences
!                           in the vertical has been implemented.
!                           (INTSRT = 19 OR 20)
!                           (this option is not available in TRISULA)
!
!     PARAMETERS          :
!
!     NAME    KIND      FUNCT.  DESCRIPTION
!     ----    -----     ------  -----------
!     DIFX    REAL      INPUT   flux in x-direction due to diffusive transport
!     DIFY    REAL      INPUT   flux in y-direction due to diffusive transport
!     DIFZ    REAL      INPUT   flux in z-direction due to diffusive transport
!     GUV     REAL      INPUT   Grid distance in the eta-/y-direction
!                               at v-velocity point
!     GVU     REAL      INPUT   Grid distance in the ksi-/x-direction
!                               at u-velocity point
!     GZZ     REAL      INPUT   Grid distance in the z-direction
!                               at w-velocity point
!       remark: GZZ is not an original TRISULA array
!     ICX     INTEGER   INPUT   Increment in the X-dir., if ICX= NMAX
!                               then computation proceeds in the X-
!                               dir. If icx=1 then computation pro-
!                               ceeds in the Y-dir.
!     ICY     INTEGER   INPUT   Increment in the Y-dir. (see ICX)
!     INTSRT  INTEGER   INPUT   integration option number
!     JSTART  INTEGER   INPUT   start pointer   (jstart=1-2*nmax)
!       remark: in TRISULA j instead of jstart
!     KCS     INTEGER   INPUT   Mask array for the zeta points
!                                      (time independent)
!                                      =0 inactive point
!                                      =1 active   point
!                                      =2 open boundary point
!     KFS     INTEGER   INPUT   Mask array for the zeta points
!                                  (time dependent)
!                                  =0 dry      point
!                                  =1 active   point
!     KFU     INTEGER   INPUT   Mask array for the u-velocity point
!                                      (time dependent)
!                                      =0 dry      point
!                                      =1 active   point
!     KFV     INTEGER   INPUT   Mask array for the v-velocity point
!                                      (time dependent)
!                                      =0 dry      point
!                                      =1 active   point
!     KMAX    INTEGER   INPUT   nr of layers in third dimension (=noq3)
!     LUNDIA  INTEGER   INPUT   integer number for monitoring file
!     NMMAX   INTEGER   INPUT   nmax * mmax (= noq2 * noq1)
!     NMMAXJ  INTEGER   INPUT   end pointer   (nmmaxj=(mmax+2)*nmax)
!     NOSYS   INTEGER   INPUT   number of active substances
!     NOTOT   INTEGER   INPUT   number of total substances
!     QXK     REAL      INPUT   flux in x-direction due to advective transport
!     QYK     REAL      INPUT   flux in y-direction due to advective transport
!     QZK     REAl      INPUT   flux in z-direction due to advective transport
!     R1      REAL      IN/OUT  concentration array
!     TIMEST  REAL      INPUT   time step
!     VOL0    REAL      INPUT   volumes at old time level
!     VOL1    REAL      INPUT   volumes at new time level
! work arrays:
!     AAK     real      INPUT   work array for (n,m,k+1)
!     AAKL    real      INPUT   work array for (n,m,k+1,l)
!     BBK     real      INPUT   work array for (n,m,k)
!     BBKL    real      INPUT   work array for (n,m,k,l)
!     CCK     real      INPUT   work array for (n,m,k-1)
!     CCKL    real      INPUT   work array for (n,m,k-1,l)
!     on input AAKLK/BBKL/CCKL contain additional dispersions + velocities
!     for the vertical direction
!     DDKL    real      INPUT   work array for (n,m,k,l)
!     on input DDKL contains processes and waste loads and
!     additional dispersions and velocities in horizontal direction
!     BDDDX   real      INPUT   work array for (n,m-3,k)
!     BDDX    real      INPUT   work array for (n,m-2,k)
!     BDX     real      INPUT   work array for (n,m-1,k)
!     BUX     real      INPUT   work array for (n,m+1,k)
!     BUUX    real      INPUT   work array for (n,m+2,k)
!     BUUUX   real      INPUT   work array for (n,m+3,k)
!     UVDWK   real      INPUT   work array
!     VVDWK   real      INPUT   work array
!
      INTEGER   kfu    (jstart:nmmaxj),
     *          kfv    (jstart:nmmaxj),
     *          kfs    (jstart:nmmaxj),
     *          kcs    (jstart:nmmaxj)
!
      DIMENSION  qxk    (jstart:nmmaxj, kmax),
     *           qyk    (jstart:nmmaxj, kmax),
     *           qzk    (jstart:nmmaxj, 0:kmax),
     *           difx   (jstart:nmmaxj, kmax),
     *           dify   (jstart:nmmaxj, kmax),
     *           difz   (jstart:nmmaxj, 0:kmax),
     *           r1     (jstart:nmmaxj, kmax, notot),
     *           vol0   (jstart:nmmaxj, kmax),
     *           vol1   (jstart:nmmaxj, kmax),
     *           guv    (jstart:nmmaxj),
     *           gvu    (jstart:nmmaxj),
     *           gzz    (jstart:nmmaxj, 0:kmax)
!
! work arrays:
      DIMENSION  bdddx  (jstart:nmmaxj, kmax),
     *           bddx   (jstart:nmmaxj, kmax),
     *           bdx    (jstart:nmmaxj, kmax),
     *           bux    (jstart:nmmaxj, kmax),
     *           buux   (jstart:nmmaxj, kmax),
     *           buuux  (jstart:nmmaxj, kmax),
     *           uvdwk  (jstart:nmmaxj, kmax),
     *           vvdwk  (jstart:nmmaxj, kmax),
     *           aak    (jstart:nmmaxj, kmax),
     *           bbk    (jstart:nmmaxj, kmax),
     *           cck    (jstart:nmmaxj, kmax),
     *           aakl   (jstart:nmmaxj, kmax, nosys),
     *           bbkl   (jstart:nmmaxj, kmax, nosys),
     *           cckl   (jstart:nmmaxj, kmax, nosys),
     *           ddkl   (jstart:nmmaxj, kmax, nosys)
      write(lundia, * )       timest,icx,icy,jstart,nmmaxj,kmax
      write(lundia, * )       notot,nosys,intsrt,nmmax
      write(lundia,'(A)') 'kfu'
      write(lundia,'(10i10)') (kfu(i),i=jstart,nmmaxj)
      write(lundia,'(A)') 'kfv'
      write(lundia,'(10i10)') (kfv(i),i=jstart,nmmaxj)
      write(lundia,'(A)') 'kfs'
      write(lundia,'(10i10)') (kfs(i),i=jstart,nmmaxj)
      write(lundia,'(A)') 'kcs'
      write(lundia,'(10i10)') (kcs(i),i=jstart,nmmaxj)
      write(lundia,'(A)') 'qxk'
      write(lundia,'(10e13.6)') ((qxk(i,k),i=jstart,nmmaxj),k=1,kmax)
      write(lundia,'(A)') 'qyk'
      write(lundia,'(10e13.6)') ((qyk(i,k),i=jstart,nmmaxj),k=1,kmax)
      write(lundia,'(A)') 'qzk'
      write(lundia,'(10e13.6)') ((qzk(i,k),i=jstart,nmmaxj),k=0,kmax)
      write(lundia,'(A)') 'difx'
      write(lundia,'(10e13.6)') ((difx(i,k),i=jstart,nmmaxj),k=1,kmax)
      write(lundia,'(A)') 'dify'
      write(lundia,'(10e13.6)') ((dify(i,k),i=jstart,nmmaxj),k=1,kmax)
      write(lundia,'(A)') 'difz'
      write(lundia,'(10e13.6)') ((difz(i,k),i=jstart,nmmaxj),k=0,kmax)
      write(lundia,'(A)') 'r1'
      write(lundia,'(10e13.6)') (((r1(i,k,j),i=jstart,nmmaxj),k=1,kmax),
     +                             j=1,notot)
      write(lundia,'(A)') 'vol0'
      write(lundia,'(10e13.6)') ((vol0(i,k),i=jstart,nmmaxj),k=1,kmax)
      write(lundia,'(A)') 'vol1'
      write(lundia,'(10e13.6)') ((vol1(i,k),i=jstart,nmmaxj),k=1,kmax)
      write(lundia,'(A)') 'guv'
      write(lundia,'(10e13.6)') (guv(i),i=jstart,nmmaxj)
      write(lundia,'(A)') 'gvu'
      write(lundia,'(10e13.6)') (gvu(i),i=jstart,nmmaxj)
      write(lundia,'(A)') 'gzz'
      write(lundia,'(10e13.6)') ((gzz(i,k),i=jstart,nmmaxj),k=0,kmax)
      write(lundia,'(A)') 'bdddx'
      write(lundia,'(10e13.6)') ((bdddx(i,k),i=jstart,nmmaxj),k=1,kmax)
      write(lundia,'(A)') 'bddx'
      write(lundia,'(10e13.6)') ((bddx (i,k),i=jstart,nmmaxj),k=1,kmax)
      write(lundia,'(A)') 'bdx'
      write(lundia,'(10e13.6)') ((bdx  (i,k),i=jstart,nmmaxj),k=1,kmax)
      write(lundia,'(A)') 'bux'
      write(lundia,'(10e13.6)') ((bux  (i,k),i=jstart,nmmaxj),k=1,kmax)
      write(lundia,'(A)') 'buux'
      write(lundia,'(10e13.6)') ((buux (i,k),i=jstart,nmmaxj),k=1,kmax)
      write(lundia,'(A)') 'buuux'
      write(lundia,'(10e13.6)') ((buuux(i,k),i=jstart,nmmaxj),k=1,kmax)
      write(lundia,'(A)') 'uvdwk'
      write(lundia,'(10e13.6)') ((uvdwk(i,k),i=jstart,nmmaxj),k=1,kmax)
      write(lundia,'(A)') 'vvdwk'
      write(lundia,'(10e13.6)') ((vvdwk(i,k),i=jstart,nmmaxj),k=1,kmax)
      write(lundia,'(A)') 'aak'
      write(lundia,'(10e13.6)') ((aak  (i,k),i=jstart,nmmaxj),k=1,kmax)
      write(lundia,'(A)') 'bbk'
      write(lundia,'(10e13.6)') ((bbk  (i,k),i=jstart,nmmaxj),k=1,kmax)
      write(lundia,'(A)') 'cck'
      write(lundia,'(10e13.6)') ((cck  (i,k),i=jstart,nmmaxj),k=1,kmax)
      write(lundia,'(A)') 'aakl'
      write(lundia,'(10e13.6)') (((aakl(i,k,j),i=jstart,nmmaxj),
     +                            k=1,kmax),j=1,nosys)
      write(lundia,'(A)') 'bbkl'
      write(lundia,'(10e13.6)') (((bbkl(i,k,j),i=jstart,nmmaxj),
     +                            k=1,kmax),j=1,nosys)
      write(lundia,'(A)') 'cckl'
      write(lundia,'(10e13.6)') (((cckl(i,k,j),i=jstart,nmmaxj),
     +                            k=1,kmax),j=1,nosys)
      write(lundia,'(A)') 'ddkl'
      write(lundia,'(10e13.6)') (((ddkl(i,k,j),i=jstart,nmmaxj),
     +                            k=1,kmax),j=1,nosys)
      stop
      return
      end


      SUBROUTINE PHO_STRING(Imode,Irej)
C********************************************************************
C
C    calculation of string combinatorics, Lorentz boosts and
C                   particle codes
C
C                - splitting of gluons
C                - strings will be built up from pairs of partons
C                  according to their color labels
C                  with IDHEP(..) = -1
C                - there can be other particles between to string partons
C                  (these will be unchanged by string construction)
C                - string mass fine correction
C
C    input:      IMODE    1  complete string processing
C                        -1 initialization
C                        -2 output of statistics
C
C    output:     /POSTRG/
C                IREJ    1 combination of strings impossible
C                        0 successful combination
C                       50 rejection due to user cutoffs
C
C********************************************************************
      IMPLICIT NONE
      DOUBLE PRECISION DEPS , EPS , p1 , p2 , p3 , p4 , sprob
      INTEGER i , i1 , i2 , iba1 , icg1 , icg2 , ich1 , icol1 , iddfs1 ,
     &        iddfs2 , iddpos , idev , idif1 , idif2 , igen , ii ,
     &        Imode , IPHO_BAR3 , IPHO_CHR3 , ipos
      INTEGER iq1 , iq2 , Irej , itemp , jm1 , jm2 , k , khdirs ,
     &        khpoms , kspoms , ksregs , lhdir , lhpom , lspom , lsreg ,
     &        mhard , msoft , nhepo , nrpom
      SAVE

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

C  input/output channels
      INCLUDE 'inc/poinou'
C  event debugging information
      INCLUDE 'inc/podebg'
C  general process information
      INCLUDE 'inc/poprcs'
C  current beam selection
      INCLUDE 'inc/pobeam'
C  internal rejection counters
      INCLUDE 'inc/poloop'
C  model switches and parameters
      INCLUDE 'inc/pomdls'
C  hard cross sections and MC selection weights
      INCLUDE 'inc/pohrcs'

C  standard particle data interface

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

C  color string configurations including collapsed strings and hadrons
      INCLUDE 'inc/postrg'
C  table of particle indices for recursive PHOJET calls
      INCLUDE 'inc/porecu'
C  some constants
      INCLUDE 'inc/pocons'

      Irej = 0
      IF ( Imode.EQ.-1 ) THEN
         CALL PHO_POMCOR(-1)
         CALL PHO_MASCOR(-1)
         CALL PHO_PARCOR(-1,Irej)

         RETURN
      ELSE IF ( Imode.EQ.-2 ) THEN
         CALL PHO_POMCOR(-2)
         CALL PHO_MASCOR(-2)
         CALL PHO_PARCOR(-2,Irej)

         RETURN
      END IF

C  generate enhanced graphs
      IF ( IPOix2.GT.0 ) THEN
 50      i1 = MAX(1,IPOix1)
         i2 = IPOix2
         IF ( ISWmdl(14).EQ.1 ) IPOix1 = 0
         kspoms = KSPom - 1
         ksregs = KSReg
         khpoms = KHPom
         khdirs = KHDir
         iddfs1 = IDIfr1
         iddfs2 = IDIfr2
         iddpos = IDDpom
         DO i = i1 , i2
            IPOix3 = i
            KSPom = 0
            KSReg = 0
            KHPom = 0
            KHDir = 0
            IF ( IPOres(i).EQ.8 ) THEN
               KSPom = 2
               lspom = 2
               lhpom = 0
               lsreg = 0
               lhdir = 0
               igen = ABS(IPHist(2,IPOpos(1,i)))
               CALL PHO_STDPAR(IPOpos(1,i),IPOpos(2,i),igen,lspom,lsreg,
     &            lhpom,lhdir,Irej)
               IF ( Irej.NE.0 ) THEN
                  IF ( IDEb(4).GE.2 ) THEN
                     IF ( LPRi.GT.4 ) WRITE (LO,'(/1X,A,I5)')
     &                     'PHO_STRING: sec.rejection by PHO_STDPAR' ,
     &                    Irej
                     CALL PHO_PREVNT(-1)
                  END IF
                  RETURN
               END IF
               KSPom = kspoms + lspom
               KSReg = ksregs + lsreg
               KHPom = khpoms + lhpom
               KHDir = khdirs + lhdir
            ELSE IF ( IPOres(i).EQ.4 ) THEN
               itemp = ISWmdl(17)
               ISWmdl(17) = 0
               CALL PHO_CDIFF(IPOpos(1,i),IPOpos(2,i),msoft,mhard,1,
     &                        Irej)
               ISWmdl(17) = itemp
               IF ( Irej.NE.0 ) THEN
                  IF ( IDEb(4).GE.2 ) THEN
                     IF ( LPRi.GT.4 ) WRITE (LO,'(/1X,A,I5)')
     &                     'PHO_STRING: sec.rejection by PHO_CDIFF' ,
     &                    Irej
                     CALL PHO_PREVNT(-1)
                  END IF
                  RETURN
               END IF
               KSDpo = KSDpo + 1
               KSPom = kspoms + KSPom
               KSReg = ksregs + KSReg
               KHPom = khpoms + KHPom
               KHDir = khdirs + KHDir
            ELSE
               idif1 = 1
               idif2 = 1
               IF ( IPOres(i).EQ.5 ) THEN
                  idif2 = 0
                  KSTrg = KSTrg + 1
               ELSE IF ( IPOres(i).EQ.6 ) THEN
                  idif1 = 0
                  KSTrg = KSTrg + 1
               ELSE
                  KSLoo = KSLoo + 1
               END IF
               itemp = ISWmdl(16)
               ISWmdl(16) = 0
               sprob = 1.D0
               CALL PHO_DIFDIS(idif1,idif2,IPOpos(1,i),IPOpos(2,i),
     &            sprob,0,msoft,mhard,Irej)
               ISWmdl(16) = itemp
               IF ( Irej.NE.0 ) THEN
                  IF ( IDEb(4).GE.2 ) THEN
                     IF ( LPRi.GT.4 ) WRITE (LO,'(/1X,A,I5)')
     &                     'PHO_STRING: sec.rejection by PHO_DIFDIS' ,
     &                    Irej
                     CALL PHO_PREVNT(-1)
                  END IF
                  RETURN
               END IF
               KSPom = kspoms + KSPom
               KSReg = ksregs + KSReg
               KHPom = khpoms + KHPom
               KHDir = khdirs + KHDir
            END IF
            IDIfr1 = iddfs1
            IDIfr2 = iddfs2
            IDDpom = iddpos
         END DO
         IF ( IPOix2.GT.i2 ) THEN
            IPOix1 = i2 + 1
            GOTO 50
         END IF
      END IF

C  optional: split gluons to q-qbar pairs
      IF ( ISWmdl(9).GT.0 ) THEN
         nhepo = NHEp
         DO i = 3 , nhepo
            IF ( (ISThep(i).EQ.-1) .AND. (IDHep(i).EQ.21) ) THEN
               icg1 = ICOlor(1,i)
               icg2 = ICOlor(2,i)
               iq1 = 0
               iq2 = 0
               DO k = 3 , nhepo
                  IF ( ICOlor(1,k).EQ.-icg1 ) THEN
                     iq1 = k
                     IF ( iq1*iq2.NE.0 ) GOTO 60
                  ELSE IF ( ICOlor(1,k).EQ.-icg2 ) THEN
                     iq2 = k
                     IF ( iq1*iq2.NE.0 ) GOTO 60
                  END IF
               END DO
               IF ( LPRi.GT.4 ) WRITE (LO,'(/1X,2A,3I6)')
     &               'PHO_STRING:ERROR:(1) ' ,
     &              'no matching color found (IG,ICG1,ICG2)' , i ,
     &              icg1 , icg2
               CALL PHO_ABORT
 60            CALL PHO_GLU2QU(i,iq1,iq2,Irej)
               IF ( Irej.NE.0 ) THEN
                  IF ( IDEb(19).GE.5 ) THEN
                     IF ( LPRi.GT.4 ) WRITE (LO,'(/,1X,A)')
     &                     'PHO_STRING: no gluon splitting possible'
                     CALL PHO_PREVNT(0)
                  END IF
                  RETURN
               END IF
            END IF
         END DO
      END IF

C  construct strings and write entries sorted by strings

      ISTr = ISTr + 1
      nhepo = NHEp
      DO i = 3 , nhepo

         IF ( ISTr.GT.MSTR ) THEN
            IF ( LPRi.GT.4 ) WRITE (LO,'(1X,2A,2I4)') 'PHO_STRING: ' ,
     &           'event has too many strings (ISTR,MSTR):' , ISTr , MSTR
            CALL PHO_PREVNT(0)
            Irej = 1
            RETURN
         END IF

         IF ( ISThep(i).EQ.1 ) THEN
C  hadrons / resonances / clusters
            NPOs(1,ISTr) = i
            NPOs(2,ISTr) = 0
            NPOs(3,ISTr) = 0
            NPOs(4,ISTr) = ABS(IPHist(2,i))
            NCOde(ISTr) = -99
            IPHist(1,i) = ISTr
C**anfe For (semi-) stable particles set IDs to 0 to keep
C       printouts consistent
            IPAr1(ISTr) = 0
            IPAr2(ISTr) = 0
            IPAr3(ISTr) = 0
            IPAr4(ISTr) = 0
            ISTr = ISTr + 1
         ELSE IF ( (ISThep(i).EQ.-1) .AND. (IDHep(i).NE.21) ) THEN
C  quark /diquark terminated strings
            icol1 = -ICOlor(1,i)
            p1 = PHEp(1,i)
            p2 = PHEp(2,i)
            p3 = PHEp(3,i)
            p4 = PHEp(4,i)
            ich1 = IPHO_CHR3(i,2)
            iba1 = IPHO_BAR3(i,2)
            CALL PHO_REGPAR(-1,IDHep(i),IMPart(i),i,0,p1,p2,p3,p4,
     &                      IPHist(1,i),IPHist(2,i),ICOlor(1,i),
     &                      ICOlor(2,i),ipos,1)
            jm1 = ipos

            nrpom = 0
 80         DO k = 3 , nhepo
               IF ( ISThep(k).EQ.-1 ) THEN
                  IF ( IDHep(k).EQ.21 ) THEN
                     IF ( ICOlor(1,k).EQ.icol1 ) THEN
                        icol1 = -ICOlor(2,k)
                        GOTO 100
                     ELSE IF ( ICOlor(2,k).EQ.icol1 ) THEN
                        icol1 = -ICOlor(1,k)
                        GOTO 100
                     END IF
                  ELSE IF ( ICOlor(1,k).EQ.icol1 ) THEN
                     icol1 = 0
                     GOTO 100
                  END IF
               END IF
            END DO
            IF ( LPRi.GT.4 ) WRITE (LO,'(/1X,A,I5)')
     &            'PHO_STRING:ERROR:(2) no matching color found for' ,
     &           -icol1
            CALL PHO_ABORT
 100        p1 = p1 + PHEp(1,k)
            p2 = p2 + PHEp(2,k)
            p3 = p3 + PHEp(3,k)
            p4 = p4 + PHEp(4,k)
            nrpom = MAX(nrpom,IPHist(1,k))
            ich1 = ich1 + IPHO_CHR3(k,2)
            iba1 = iba1 + IPHO_BAR3(k,2)
            CALL PHO_REGPAR(-1,IDHep(k),IMPart(k),k,0,PHEp(1,k),
     &                      PHEp(2,k),PHEp(3,k),PHEp(4,k),IPHist(1,k),
     &                      IPHist(2,k),ICOlor(1,k),ICOlor(2,k),ipos,1)
C  further parton involved?
            IF ( icol1.NE.0 ) GOTO 80
            jm2 = ipos
C  register string
            igen = IPHist(2,k)
            CALL PHO_REGPAR(-1,90,0,jm1,-jm2,p1,p2,p3,p4,ISTr,igen,ich1,
     &                      iba1,ipos,1)
C  store additional string information
            NPOs(1,ISTr) = ipos
            NPOs(2,ISTr) = jm1
            NPOs(3,ISTr) = -jm2
            NPOs(4,ISTr) = ABS(IPHist(2,k))
C  calculate CPC string codes
            CALL PHO_ID2STR(IDHep(jm1),IDHep(jm2),NCOde(ISTr),
     &                      IPAr1(ISTr),IPAr2(ISTr),IPAr3(ISTr),
     &                      IPAr4(ISTr))
            ISTr = ISTr + 1
         END IF
      END DO

      DO i = 3 , nhepo

         IF ( ISTr.GT.MSTR ) THEN
            IF ( LPRi.GT.4 ) WRITE (LO,'(1X,2A,2I4)') 'PHO_STRING: ' ,
     &           'event has too many strings (ISTR,MSTR):' , ISTr , MSTR
            CALL PHO_PREVNT(0)
            Irej = 1
            RETURN
         END IF

         IF ( ISThep(i).EQ.-1 ) THEN
C  gluon loop-strings
            icol1 = -ICOlor(1,i)
            p1 = PHEp(1,i)
            p2 = PHEp(2,i)
            p3 = PHEp(3,i)
            p4 = PHEp(4,i)
            iba1 = 0
            ich1 = 0
            CALL PHO_REGPAR(-1,IDHep(i),IMPart(i),i,0,p1,p2,p3,p4,
     &                      IPHist(1,i),IPHist(2,i),ICOlor(1,i),
     &                      ICOlor(2,i),ipos,1)
            jm1 = ipos
C
            nrpom = 0
            DO WHILE ( ICOlor(2,i).NE.icol1 )
               DO k = i , nhepo
                  IF ( ISThep(k).EQ.-1 ) THEN
                     IF ( ICOlor(1,k).EQ.icol1 ) THEN
                        icol1 = -ICOlor(2,k)
                        GOTO 110
                     ELSE IF ( ICOlor(2,k).EQ.icol1 ) THEN
                        icol1 = -ICOlor(1,k)
                        GOTO 110
                     END IF
                  END IF
               END DO
               IF ( LPRi.GT.4 ) WRITE (LO,'(/1X,A,I5)')
     &               'PHO_STRING:ERROR:(3) no matching color found for'
     &              , -icol1
               CALL PHO_ABORT
 110           p1 = p1 + PHEp(1,k)
               p2 = p2 + PHEp(2,k)
               p3 = p3 + PHEp(3,k)
               p4 = p4 + PHEp(4,k)
               nrpom = MAX(nrpom,IPHist(1,k))
               CALL PHO_REGPAR(-1,IDHep(k),IMPart(k),k,0,PHEp(1,k),
     &            PHEp(2,k),PHEp(3,k),PHEp(4,k),IPHist(1,k),IPHist(2,k),
     &            ICOlor(1,k),ICOlor(2,k),ipos,1)
C  further parton involved?
               IF ( icol1.EQ.0 ) GOTO 120
            END DO
 120        jm2 = ipos
C  register string
            igen = IPHist(2,k)
            CALL PHO_REGPAR(-1,90,0,jm1,-jm2,p1,p2,p3,p4,ISTr,igen,ich1,
     &                      iba1,ipos,1)
C  store additional string information
            NPOs(1,ISTr) = ipos
            NPOs(2,ISTr) = jm1
            NPOs(3,ISTr) = -jm2
            NPOs(4,ISTr) = ABS(IPHist(2,k))
C  calculate CPC string codes
            CALL PHO_ID2STR(IDHep(jm1),IDHep(jm2),NCOde(ISTr),
     &                      IPAr1(ISTr),IPAr2(ISTr),IPAr3(ISTr),
     &                      IPAr4(ISTr))
            ISTr = ISTr + 1
         END IF
      END DO

      ISTr = ISTr - 1

      IF ( IDEb(19).GE.17 ) THEN
         IF ( LPRi.GT.4 ) WRITE (LO,'(1X,A)')
     &         'PHO_STRING: after string construction'
         CALL PHO_PREVNT(0)
      END IF

C  pomeron corrections
      CALL PHO_POMCOR(Irej)
      IF ( Irej.NE.0 ) THEN
         IFAil(38) = IFAil(38) + 1
         IF ( IDEb(19).GE.3 ) THEN
            IF ( LPRi.GT.4 ) WRITE (LO,'(1X,A,I6)')
     &            'PHO_STRING: rejection by PHO_POMCOR (IREJ)' , Irej
            CALL PHO_PREVNT(-1)
         END IF
         RETURN
      END IF

C  string mass corrections
      CALL PHO_MASCOR(Irej)
      IF ( Irej.NE.0 ) THEN
         IFAil(34) = IFAil(34) + 1
         IF ( IDEb(19).GE.3 ) THEN
            IF ( LPRi.GT.4 ) WRITE (LO,'(1X,A,I6)')
     &            'PHO_STRING: rejection by PHO_MASCOR (IREJ)' , Irej
            CALL PHO_PREVNT(-1)
         END IF
         RETURN
      END IF

C  parton mass corrections
      DO i = 1 , ISTr
         IF ( NCOde(i).GE.0 ) THEN
            CALL PHO_PARCOR(NPOs(1,i),Irej)
            IF ( Irej.NE.0 ) THEN
               IFAil(35) = IFAil(35) + 1
               IF ( IDEb(19).GE.3 ) THEN
                  IF ( LPRi.GT.4 ) WRITE (LO,'(1X,A,I6)')
     &                  'PHO_STRING: rejection by PHO_PARCOR (IREJ)' ,
     &                 Irej
                  CALL PHO_PREVNT(-1)
               END IF
               RETURN
            END IF
         END IF
      END DO

C  statistics of hard processes
      DO i = 3 , NHEp
         IF ( ISThep(i).EQ.25 ) THEN
            k = IMPart(i)
            ii = IDHep(i)
            MH_acc_2(k,ii,IDXmpar) = MH_acc_2(k,ii,IDXmpar) + 1
         END IF
      END DO

C  debug: write out strings
      IF ( IDEb(19).GE.5 ) THEN
         IF ( IDEb(19).GE.10 ) CALL PHO_CHECK(1,idev)
         IF ( IDEb(19).GE.15 ) THEN
            CALL PHO_PREVNT(0)
         ELSE
            CALL PHO_PRSTRG
         END IF
      END IF

      END SUBROUTINE


c     Josh - argument iPl has been added to arguments of xsect
      subroutine xsect (ipr2, dx, x0, ri, ne, ne1, ik0, em, edge,
     1                  ihole, emu, corr, dgc0, dpc0, jnew,
     2                  ixc, lreal, rmt, rnrm, xmu,
     2                  iPl,
     3                  vtot, vvalgs, edens, dmag, edenvl,
     4                  dgcn, dpcn, adgc, adpc, xsec, xsnorm, rkk,
     5                  iz, xion, iunf, xnval,
     5                  izstd, iorb, l2lp,
     6                  ipol, ispin, le2, angks, ptz)

c gamach, eorb, ifxc, kappa

c     right know the same self-energy is used for calculation
c     of the central atom part (xsec) and dipole m.e. for
c     scattering (rkk). You may want to run xsect separately
c     for xsec and for rkk, if you want to use different self-energy
c     for central and scattering parts.  ala. fix later

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

c     INPUT
c     dx, x0, ri(nr)
c                  Loucks r-grid, ri=exp((i-1)*dx-x0)
c     ne, em(ne)   number of energy points, real energy grid
c     edge         chemical potential (energy for k=0)
c     ihole        hole code
c     emu          position of chemical potential in absorption specrum
c     dgc0(nr)     dirac upper component, ground state hole orbital
c     dpc0(nr)     dirac lower component, ground state hole orbital
c     ixc          0  Hedin-Lunqist + const real & imag part
c                  1  Dirac-Hara + const real & imag part
c                  2  ground state + const real & imag part
c                  3  Dirac-Hara + HL imag part + const real & imag part
c                  5  Dirac-Fock exchange with core electrons +
c                     ixc=0 for valence electron density
c     lreal        logical, true for real phase shifts only
c     rmt          r muffin tin
c     xmu          fermi level
c     vi0          const imag part to add to complex potential
c     gamach       core hole lifetime
c     vtot(nr)     total potential, including gsxc, final state
c     edens(nr)    density, hole orbital, final state
c     dmag(251)     density magnetization
c     edenvl      valence charge density
c     dgcn(dpcn)   large (small) dirac components for central atom
c     adgc(adpc)   their development coefficients
c
c     OUTPUT
c     xsec(ne)    atomic absorption cross section to multiply \chi
c                 (atomic background for XMCD)
c     xsnorm(ne)  atomic  absorption cross section (norm for XMCD)
c     rkk(ne, 8)  normalized reduced matrix elements for construction
c                 of termination matrix in genfmt.

      include '../HEADERS/const.h'
      include '../HEADERS/dim.h'
      complex*16 ptz
      dimension ptz(-1:1, -1:1)

      complex*16 em(nex)
      dimension ri(nrptx), vtot(nrptx), edens(nrptx),dmag(nrptx)
      dimension dgc0(nrptx), dpc0(nrptx), vvalgs(nrptx), edenvl(nrptx)
      dimension dgcn(nrptx,30), dpcn(nrptx,30)
c      dimension eorb(30), kappa(30)
      dimension adgc(10,30), adpc(10,30), xnval(30), iorb(-4:3)
      complex*16 rkk(nex, 8), xsec(nex)
      complex*16 bmat(-lx:lx,0:1,8, -lx:lx,0:1,8)
      dimension kind(8), lind(8)
      dimension xsnorm(nex)

      dimension xp(nrptx), xq(nrptx)

c     work space for xcpot
      dimension vxcrmu(nrptx), vxcimu(nrptx), gsrel(nrptx)
      dimension vvxcrm(nrptx), vvxcim(nrptx)

c     work space for fovrg
      complex*16 p(nrptx), q(nrptx), pn(nrptx), qn(nrptx), fscf(nrptx)
      complex*16 pp(nrptx), qp(nrptx), pnp(nrptx), qnp(nrptx)
c     storage for calculation of cross term (SPIN 1 only)
      complex*16 xrcold(nrptx) , xncold(nrptx)

      complex*16  p2, ck, xkmt
c      complex*16  xkmtp, xm1, xm2, xm3, xm4, yvec(nrptx,1)
      complex*16  pu, qu, dum1, factor
      complex*16  xfnorm, xirf, xirf1
      complex*16  temp, aa, bb, cc, rkk1, rkk0, phold
      complex*16  phx(8), ph0
      complex*16  eref

      complex*16 jl,jlp1,nl,nlp1
      complex*16  v(nrptx), vval(nrptx)
      complex*16  xrc(nrptx), xnc(nrptx)
      character*512 slog
      logical ltrace
c     nesvi:
      complex*16 xrhoce(nex), xrhopr(nex), chia(nex), cchi(nex)
      dimension omega1(nex), bf(0:2, nrptx)

      dimension pat(nrptx),qat(nrptx)
      complex*16 intr(nrptx),var(nrptx)
c     to pass energy levels and projected DOS
c      dimension neg(30), rhoj(nex,30)
      dimension eng(nex, 30)
c     Josh - Added iPl switch for PLASMON card
c          - and WpCorr = Wi/Wp, Gamma, AmpFac
c          - to describe Im[eps^-1]
      integer iPl, ipole
      double precision WpCorr(MxPole), Gamma(MxPole), AmpFac(MxPole)
c     Josh END

c     explicitly intialize some things
      rkk0  = (0.,0.)
      rkk1  = (0.,0.)
      phold = (0.,0.)

      do i=1,MxPole
         WpCorr(1) = -1.d30
      enddo

      call setkap(ihole, kinit, linit)
c      PRINT*, 'dx=',dx
c     set imt and jri (use general Loucks grid)
c     rmt is between imt and jri (see function ii(r) in file xx.f)
      imt = int((log(rmt) + x0) / dx)  +  1
      jri = imt+1
      jri1 = jri+1
      if (jri1 .gt. nrptx)  call par_stop('jri .gt. nrptx in phase')

c     nesvi: define jnrm
      inrm = int((log(rnrm) + x0) / dx) + 1
      jnrm = inrm + 1

c     We'll need <i|i> later to normalize dipole matrix elements
c     <i|r|f>.  NB, dgc and dpc are r*wave_fn, so use '0' in somm to
c     get integral  psi**2 r**2 dr.
c     Square the dgc0 and dpc0 arrays before integrating.
c     <i|i> == xinorm.
c     dgc and dpc should be normalized <i|i>=1, check this here
      do i = 1, nrptx
         xp(i) = dpc0(i)**2
         xq(i) = dgc0(i)**2
      enddo
c     nb, xinorm is used for exponent on input to somm
      xinorm = 2*linit + 2
      call somm (ri, xp, xq, dx, xinorm, 0, jnrm)
      del = abs (abs(xinorm) - 1)
      if (del .gt. 1.e-2) then
         write(slog,'(a,i8,1p2e13.5)') ' ihole, xinorm ', ihole , xinorm
         call wlog(slog)
c        if using real phase shifts, don't expect great results
         if (lreal.lt.2)  then
           call wlog(' There may be convergence problems.')
           call wlog(' Xinorm should be 1. If you set the RGRID, '//
     1               'minor interpolation errors ')
           call wlog(' that will not affect final results may occur')
         endif
      endif

c     use ixc for testing
      index = ixc
c       Always use ground state self energy for xsection, quick fix
c       JJR, Jan 93
c       change for testing broadened plasmon pole 6/93
c       index = 2
c   ALA found that it is better to use index=ixc and real part of
c   self-energy for atomic xsection. 12/96
      ltrace = .true.
      call bcoef(kinit, ipol, ptz, le2, ltrace, ispin, angks,
     1           kind, lind, bmat)
c     set spin index to use bmat
      isp = 0
      if (ispin.eq.1) isp = nspx - 1

c     zero rkk and phx
      do ie = 1,nex
         do k1 = 1,8
            rkk(ie,k1) = 0
         enddo
      enddo
      do k1 = 1,8
         phx(k1) = 0
      enddo

      ifirst = 0
c     Josh - if PLASMON card is set, and using HL exc,
c          - read pole information from epsinv.dat
      IF( (iPl.gt.0).and.(ixc.eq.0) ) THEN
         open(file='exc.dat', unit=47, status='old',iostat=ios)
         call chopen (ios, 'exc.dat', 'ffmod2(xsect)')
         DO ipole = 1, MxPole
            call rdcmt(47,'#*cC')
            read(47,*,END=35) WpCorr(ipole), Gamma(ipole), AmpFac(ipole)
            Gamma(ipole)  = Gamma(ipole)/hart
            WpCorr(ipole) = (WpCorr(ipole)/hart) /
     &           SQRT(3.d0/((3 / (4*pi*edens(jri+1))) ** third)**3)
         END DO
 35      CONTINUE
         WpCorr(ipole) = -1.d30
         CLOSE(47)
      END IF
c$$$      IF(ixc.eq.0) THEN
c$$$c        Write wp as calculated from density to sigma.dat
c$$$         open(file='mpse.dat', unit=45, status='replace',iostat=ios)
c$$$         call chopen (ios, 'sigma.dat', 'ffmod2(xsect)')
c$$$         write(45,*) '# ', 'rs      wp(Hartrees)'
c$$$         write(45,*) '# ', (3 / (4*pi*edens(jri+1))) ** third,
c$$$     &        SQRT(3.d0/((3 / (4*pi*edens(jri+1))) ** third)**3)*hart
c$$$         write(45,'(a)')
c$$$     &        '# E-EFermi (eV)   Re[Sigma(E)] (eV)   Im[Sigma(E)] (eV)'
c$$$     &        // '   Re[Z]   Im[Z]   Mag[Z]   Phase[Z]   Lambda(E) (/A)'
c$$$      END IF
c     Josh END

      do 400 ie = 1, ne
         iph = 0
c        Josh - xcpot now has new arguments:
c             - iPl, WpCorr, Gamma, AmpFac
         call xcpot (iph, ie, index, lreal, ifirst, jri,
     1               em(ie), xmu,
     2               vtot, vvalgs, edens, dmag, edenvl,
     3               eref, v, vval, iPl, WpCorr, AmpFac,
     4               vxcrmu, vxcimu, gsrel, vvxcrm, vvxcim,rnrm)
c         call xcpot (iph, ie, index, lreal, ifirst, jri,
c     1               em(ie), xmu,
c     2               vtot, vvalgs, edens, dmag, edenvl,
c     3               eref, v, vval, iPl, WpCorr, Gamma, AmpFac,
c     4               vxcrmu, vxcimu, gsrel, vvxcrm, vvxcim,rnrm)

c       set the method to calculate atomic cross section
c       p2 is (complex momentum)**2 referenced to energy dep xc
        p2 = em(ie) - eref
        p2f = edge - dble(eref)
        ck = sqrt (2*p2 + (p2*alphfs)**2)
        xkmt = rmt * ck

        if (mod(index,10) .lt. 5) then
           ncycle = 0
        else
c          fix later . may be ncycle can be less
           ncycle = 3
        endif
        omega = (dble(em(ie)) - edge) + emu
        omega = max (omega, 0.001d0 / hart)
c       nesvi: add omega1(ie)- need it later
        omega1(ie) = omega

c       remember the bessel functions for multipole matrix elements
        xk0 = omega * alphfs
        ilast = jnrm+6
        if (ilast.lt.jnew) ilast = jnew
        if (ilast.gt.nrptx) ilast = nrptx
        do i = 1, ilast
           temp = xk0 * ri(i)
           if (abs(temp).lt.1.d0) then
c           use series expansion
              do ll = 0,2
                 call bjnser(temp,ll, xirf, dum1,1)
                 bf(ll,i) = dble(xirf)
              enddo
           else
c           use formula
              x = dble(temp)
              sinx = sin(x)
              cosx = cos(x)
              bf(0,i) = sinx/x
              bf(1,i) = sinx/x**2 - cosx/x
              bf(2,i) = sinx*(3/x**3-1/x) - 3*cosx/x**2
           endif
        enddo

c       notice for spin-dep case xsnorm and xsec are spin-dep
c       and kept separately (see call to xsect in subroutine xsph)
        xsnorm(ie) = 0
        xsec(ie) = 0
        if (dble(em(ie)).lt.-10.d0) goto 400
        if (dimag(p2).le.0.d0 .and. dble(p2).le.0.d0) goto 400

c       matrix elements for multipole (E1,E2,M1) transitions
c       The terms up to (k/c)^2 for absorption are kept.
c       L3 edge: kdif=1 (3d5/2)      kdif=2 (3d3/2), kdif=3(4s)
c       L2 edge: kdif=1 (no transition), 2 (4s),      3 (3d3/2)
        do 350 mult = 0, 2
          if (mult.eq.0) then
c           E1 transitions
            kx = 1
            ks = 2
          else
c           M1 transitions
            kx = 1
            ks = 6
c           E2 transitions
            if (mult.eq.2) kx = 2
          endif
c         skip unnecessary calculations
          if (mult.gt.0 .and. (mult.ne.le2)) goto 350

c         set ilast larger than jri for better interpolation for pu
c         also need 5 points after jri for irregular solution
          ilast = jnrm + 6
          if (ilast.lt.jnew) ilast = jnew

cc        calculate screened dipole field
          ww = dble(emu+p2-edge)
          if (mult.eq.0 .and. izstd.gt.0) then
c            if (ie.eq.1) call correorb(iz, ihole, rmt, jri, dx,ri,
c     1                   p2f,edge, v, dgcn, dpcn, adgc, adpc,
c     2                   eorb, neg, eng, rhoj, kappa, norbp)
            maxsize = 1
            matsize = 0
            sfun = 1.d0
c            call phiscf (ifxc, rmt, ilast, jri, p2, p2f, emu, dx,
c    1                  ri, v, edens, dgcn, dpcn, adgc, adpc,
c     2                  iz, ihole, neg, eng, rhoj,kappa, norbp, fscf,
c     3                  yvec, maxsize, matsize, sfun)
            wse = dble(p2-eng(1,ihole))
          else
            do i = 1, nrptx
               fscf(i) = 1.d0
            enddo
            wse = ww
          endif

c         ww = 1
c         ww = wse / ww
          ww = sqrt(wse/ww)

          do 300 kdif = -kx, kx
            if (omega.le.0.0) goto 300
            ind = kdif + ks
            ikap = kind (ind)
            if (ikap .eq. 0) goto 300
c           use l2lp =0 to include both transitions l-->l+/-1
c           if (l2lp.ne.0) only dipole transitions are calculated.
c            l-->l+1 transitions
            if (l2lp.eq.1 .and. ((kinit.lt.0 .and. ind.ge.3) .or.
     1          (kinit.gt.0 .and. ind.ne.3)) ) goto 300
c            l-->l-1 transitions
            if (l2lp.eq.-1 .and. ((kinit.lt.0 .and. ind.ne.3) .or.
     1          (kinit.gt.0 .and. ind.ge.3)) ) goto 300

            iold = 0
            ic3=0
c           start cycle  do ic3=0,1
c           return for ic3=1 calculations only for |ispin|=1
c           where the central atom cross terms are needed
  100       continue

            irr = -1
c           ic3p=1 to test K2Cr2O7  L3 XES
            ic3p = ic3
            call dfovrg ( ncycle, ikap, rmt, ilast, jri, p2, dx,
     1      ri, v, vval, dgcn, dpcn, adgc, adpc,
     2               xnval, pu, qu, p, q,
     3               iz, ihole, xion, iunf, irr, ic3p)
            lfin = lind (ind)
            ilp = lfin - 1
            if (ikap .lt. 0) ilp = lfin + 1
            call exjlnl (xkmt, lfin, jl, nl)
            call exjlnl (xkmt, ilp, jlp1, nlp1)
            call phamp(rmt,pu,qu, ck, jl,nl,jlp1,nlp1, ikap, ph0,temp)

            sign = -1.0
            if (ikap.gt.0) sign = 1.0
            factor = ck*alphfs
            factor = sign * factor/(1+sqrt(1+factor**2))
            dum1 = 1/ sqrt(1+factor**2)
            xfnorm = 1 / temp *dum1
c           normalization factor
c           xfnorm = dum1*rmt*(jl*cos(delta) - nl*sin(delta))/ Rl(rmt)
c           dum1 is relativistic correction to normalization
c           normalize regular solution
            do i = 1,ilast
              p(i)=p(i)*xfnorm
              q(i)=q(i)*xfnorm
           enddo

cc          calculate xirf including fscf - TDLDA result
           do id = 1, 2
               if (id.eq.1) then
                  do j = 1,ilast
                     pp(j)  = p(j)*dble(fscf(j))
                     qp(j)  = q(j)*dble(fscf(j))
                  enddo
               else
                  do j = 1,ilast
                     pp(j)  = p(j)*dimag(fscf(j))
                     qp(j)  = q(j)*dimag(fscf(j))
                  enddo
              endif
              ifl = 1
              if (izstd.gt.0) ifl = -1
              xirf1 = 0
              call radint(ifl, mult, bf, kinit, dgc0,dpc0, ikap, pp,qp,
     1        pn,qn,ri,dx, ilast,iold, xrc,xnc, xrcold,xncold, xirf1)
c             if (ifl.lt.0) xirf1 = xirf1 * xk0 * ww
              if (ifl.lt.0) xirf1 = xirf1 * xk0
              if (id.eq.1) then
                 xirf = xirf1
              else
                 if (abs(xirf) .eq. 0.d0) then
                    xirf = xirf1
                 elseif (abs(xirf1) .eq. 0.d0) then
                    xirf = xirf
                 elseif (abs(xirf1) .lt. abs(xirf)) then
                    dum = abs(xirf1) / abs(xirf)
                    xirf = xirf * sqrt(1.d0 + dum**2)
                 else
                    dum = abs(xirf) / abs(xirf1)
                    xirf = xirf1 * sqrt(1.d0 + dum**2)
                 endif
              endif
           enddo

c           note that for real potential  xirf is real or reduced matrix
c           element for dipole transition is pure imaginary.
            if (ic3.eq.0) then
c              can remember only E2 or M1 matrix elements
               if (mult.eq.0 .or. le2.eq.mult) then
                 rkk(ie,ind)=xirf
                 phx(ind) = ph0
               endif
c              for f' want to include both E2 and M1 for xsnorm and xsec
c              but now only one of them is included (fix later)
               xsnorm(ie)=xsnorm(ie) +
     1         ( dble(xirf)**2 + dimag(xirf)**2 )/ (2*kx+1)
               aa =  - coni*xirf**2
               xsec(ie) = xsec(ie) -  aa * bmat(0,isp,ind, 0,isp,ind)
            elseif (iold.eq.1) then
                rkk1=xirf
                phold = ph0
            elseif (iold.eq.2) then
                rkk0=xirf
            endif

c           get irregular solution and atomic cross-section xsec
c           find irregular solution

            if(dimag(em(ie)).gt.0.d0) then
              irr = 1
c             set pu, qu - initial condition for irregular solution
              pu = (nl*cos(ph0)+jl*sin(ph0)) *rmt * dum1
              qu=(nlp1*cos(ph0)+jlp1*sin(ph0))*factor *rmt * dum1

c             test on bessel functions
c             if (ikap.gt.0) print*,'test1',xkmt**2*(jl*nlp1-nl*jlp1)

              call dfovrg (ncycle, ikap, rmt, ilast, jri, p2, dx,
     1              ri, v,vval, dgcn, dpcn, adgc, adpc,
     1              xnval, pu, qu, pn, qn,
     1              iz, ihole, xion, iunf, irr, ic3p)
cc            set N- irregular solution , which is outside
cc            N=(nlp1*cos(ph0)+jlp1*sin(ph0))*factor *rmt * dum1
cc            N = i*R - H*exp(i*ph0)
              temp = exp(coni*ph0)
              do i = 1, ilast
                pn(i) = coni * p(i) - temp * pn(i)
                qn(i) = coni * q(i) - temp * qn(i)
              enddo
            else
              do i = 1, ilast
                 pn(i) = 0
                 qn(i) = 0
              enddo
            endif

c           combine regular and irregular solution into the
c           central atom absorption coefficient xsec (mu = dimag(xsec))
c           thus for real energy dimag(xsec)=xsnorm

c           also include TDLDA effects
            do id = 1, 2
               if (id.eq.1) then
                  do j = 1,ilast
                     pp(j)  = p(j)*dble(fscf(j))
                     qp(j)  = q(j)*dble(fscf(j))
                     pnp(j)  = pn(j)*dble(fscf(j))
                     qnp(j)  = qn(j)*dble(fscf(j))
                  enddo
               else
                  do j = 1,ilast
                     pp(j)  = p(j)*dimag(fscf(j))
                     qp(j)  = q(j)*dimag(fscf(j))
                     pnp(j)  = pn(j)*dimag(fscf(j))
                     qnp(j)  = qn(j)*dimag(fscf(j))
                  enddo
               endif

c           TDLDA theory is written for the r-form of matrix elements
c           so one might want to use ifl=-1,-2 for these calculations
c           on the other hand want ifl=1,2 for DANES calculations
c           since it is more reliable at high energies and gives
c           better results for Cu test.
               ifl = 2
               if (izstd.gt.0) ifl = -2

               call radint(ifl,mult, bf, kinit, dgc0, dpc0, ikap, pp,
     $              qp, pnp, qnp, ri,dx, ilast,iold, xrc, xnc,
     $              xrcold, xncold, xirf1)
               if (ifl.lt.0) xirf1 = xirf1 * xk0**2 * ww**2
               if (id.eq.1) then
                  xirf = xirf1
               else
                  if (abs(xirf) .eq. 0.d0) then
                     xirf = xirf1
                  elseif (abs(xirf1) .eq. 0.d0) then
                     xirf = xirf
                  elseif (abs(xirf1) .lt. abs(xirf)) then
                     dum = abs(xirf1) / abs(xirf)
                     xirf = xirf * sqrt(1.d0 + dum**2)
                  else
                     dum = abs(xirf) / abs(xirf1)
                     xirf = xirf1 * sqrt(1.d0 + dum**2)
                  endif
               endif
            enddo

            if (ic3.eq.0) then
               xsec(ie) = xsec(ie) - xirf * bmat(0,isp,ind, 0,isp,ind)
            endif

c           ------start of density of states part-------------
c           added by nesvi 07/12/00
c
c           Calculate rhoc00 and rho_projected on
c           the same grid as xsect. Need this to calculate the smooth
c           atomic ratio rho_0/mu_0 or rho_proj/mu_0.
c           The atomic functions are normalized to 1 inside Norman radius.
c           This procedure can be called 'Renormalized atomic sphere method".
c           It gives very reasonable numbers for hole counts. In order to
c           get Mulliken counts one can extend integration limits till very
c           large R, but it's currently not recommended because of the problems
c           with the wave function's tails above Rnm.

            jproj =  iorb(ikap)
            if (jproj.eq.0 .and. ikap.lt.0) jproj = iorb(-ikap-1)
            kdif1 = -1
            if(kinit.gt.0) kdif1 =  1

            if (kdif .eq. kdif1 .and. ic3.eq.0 .and. jproj.gt.0) then
c              calculate rhoc00 (rho_0)

               temp = (2*lfin+1.0d0) / (1+factor**2) /pi *4*ck /hart
               do i = 1, ilast
                  xrc(i) = pn(i)*p(i) - coni*p(i)*p(i)
     1                 + qn(i)*q(i) - coni*q(i)*q(i)
               enddo
               xirf = 1
c              integration is till Norman radius, not Rmt as in xsect
               i0 = jnrm + 1
               call csomm2 (ri, xrc, dx, xirf, rnrm, i0)
               xrhoce(ie) = - xirf * temp

c              calculate rho_projected:

c              pat, qat - atomic functions that we make projection on.
               do i=1,nrptx
                  pat(i) = dgcn(i,jproj)
                  qat(i) = dpcn(i,jproj)
               enddo

c     normalize pat and qat in the Norman radius sphere: <n|n>=1,
c     (renormalized atomic sphere method)

               do i = 1, ilast
                  xp(i) = pat(i)**2 + qat(i)**2
                  xq(i) = 0
               enddo
c     nb, xinorm is used for exponent on input to somm
               xinorm = 2*lfin + 2
               call somm2 (ri, xp, dx, xinorm, rnrm, 0, i0)
c              call somm (ri, xp, xq, dx, xinorm, 0, jnrm)

               xinorm = sqrt(xinorm)
               do i=1,nrptx
                  pat(i) = pat(i) / xinorm
                  qat(i) = qat(i) / xinorm
               enddo

c              calculate overlap integral between f and atomic function
c              (integral Rl(r)*Psi_at(r)dr from 0 till r')
c              intr(i) is that overlap integral. Later it
c              will be multiplied by pr(i)*Psi_at(r') and integrated
c              till Norman radius.

               do i=1,ilast
                  var(i)=pat(i)*p(i)+qat(i)*q(i)
c                 factor of 2 -integration r< r>  -->2 r r'
               enddo

c              integration by trapezoid method
               intr(1)=var(1)*ri(1)
               do i=2,ilast
                  intr(i)=intr(i-1)+ (var(i)+var(i-1))*(ri(i)-ri(i-1))
               enddo

c         now calculate rho_projected - xrhopr
               temp = (2*lfin+1.0d0) / (1+factor**2) /pi *4*ck /hart
c              temp = abs(ikap) / (1+factor**2) /pi *4*ck /hart
               do i = 1, ilast
                  xrc(i) = pn(i)*pat(i)*intr(i)+
     1                 qn(i)*qat(i)*intr(i)
                  xrc(i) = xrc(i) - coni*(p(i)*pat(i)*intr(i) +
     1                 q(i)*qat(i)*intr(i))
               enddo

               xirf =  1
               call csomm2 (ri, xrc, dx, xirf, rnrm, i0)
               xrhopr(ie) = - xirf * temp

            endif
c           ----------end of density of states part---

            if (iold.gt.0) then
c             calculate cross term contribution to XMCD
c             in both cases coupling between neighbors
c             need to remove SO interaction (ic3=1) in order
c             to avoid unphysical peak in Gd XMCD. a.l. ankudinov
              k1 = ind - 1
              if (k1.ge.1 .and.k1.le.8) then
              if (lind(k1).eq.lind(ind) .and. lind(k1).gt.0) then
                aa = exp( coni*(ph0 - phold))
                bb = 1/aa
                cc = - ( bmat(0,isp,k1, 0,isp,ind) +
     1                 bmat(0,isp,ind, 0,isp,k1) ) / 2.d0
                xsec(ie) = xsec(ie) - coni * rkk1 * rkk0 * (bb+aa) * cc
cc              combine regular and irregular solution into the
cc              central atom absorption coefficient (mu=dimag(xsec))
cc              thus for real energy dimag(xsec)=xsnorm
                call radint (3, mult, bf, kinit, dgc0, dpc0, ikap, p, q,
     1            pn, qn, ri, dx, ilast, iold, xrc, xnc, xrcold, xncold,
     2            xirf)
                xsec(ie) = xsec(ie) + xirf * cc * bb

                call radint (4, mult, bf, kinit, dgc0, dpc0, ikap, p, q,
     1            pn, qn, ri, dx, ilast, iold, xrc, xnc, xrcold, xncold,
     2             xirf)
                xsec(ie) = xsec(ie) + xirf * cc * aa
              endif
              endif
            endif
cc          end of |ispin=1| cross term calculations

c           prepare for ic3=1 cross term calculations if needed
            if (ic3.eq.0 .and. abs(ispin).eq.1) then
              iold = 0
              if (ind.lt.8 .and. lind(ind).gt.0) then
                k1 = ind + 1
                if (lind(k1).eq.lind(ind)) iold = 1
              endif
              if (ind.gt.1 .and. lind(ind).gt.0) then
                k1 = ind - 1
                if (lind(k1).eq.lind(ind)) iold = 2
              endif
c             need to remove SO interaction to calculate cross term
c             big effect for Gd XMCD calculations
              if (iold.gt.0) then
c               repeat calculation for current kdif with SO turned off
                ic3 = 1
                goto 100
              endif
            endif

  300     continue
  350   continue

        if (omega.gt.0.0) then
c         prefac = (8 * pi / 3)  * alphfs * omega  -- nonrelativistic
c         relativistic is (for alpha form)
          prefac = 4 * pi * alpinv / omega * bohr**2
          xsnorm(ie) =  xsnorm(ie) * prefac * 2*abs(ck)
          xnorm= sqrt( xsnorm(ie) )
          xsec(ie) = xsec(ie) * prefac* 2*ck

c         put complex sqrt(prefactor) into reduced matrix elements rkk
          ck = sqrt ( prefac * (2*ck))
c         guarantee that we have the right root
          if (dimag(ck) .lt. 0) ck = -ck
c         add central atom phase shift here.
          do kdif = 1 , 8
             rkk(ie,kdif)= rkk(ie,kdif) * ck/xnorm * exp(coni*phx(kdif))
          enddo
        endif
 400  continue
c     end of energy cycle

c     Josh - Close sigma.dat
      close(45)
c     Josh END

      if (ipr2.ge.3) then
c       calculate mu_0/rho_0 for XMCD normalization.
        do ie=1,ne
           chia(ie) = 0
        enddo
        vrcorr = 0
        vicorr = 0
        call xscorr(1, em, ne1, ne, ik0, xrhoce,xsnorm,chia,
     1     vrcorr, vicorr, cchi)
        do ie = 1, ne1
            xrhoce(ie)  = coni* dimag(xrhoce(ie)+cchi(ie))
         enddo
        call xscorr(1, em, ne1, ne, ik0, xrhopr,xsnorm,chia,
     1     vrcorr, vicorr, cchi)
        do ie = 1, ne1
           xrhopr(ie)  = coni* dimag(xrhopr(ie)+cchi(ie))
        enddo
        call xscorr(1, em, ne1, ne, ik0, xsec,xsnorm,chia,
     1     vrcorr, vicorr, cchi)
        do ie = 1, ne1
           cchi(ie)  = coni* dimag(xsec(ie)+cchi(ie))
        enddo

        open(unit=3,file='ratio.dat',status='unknown', iostat=ios)
        open(unit=4,file='ratiop.dat',status='unknown', iostat=ios)
c       normalize to xsec at 50 ev above edge
        edg50 = emu +50.0 / hart
        call terp (omega1, xsnorm, ne1, 1, edg50, xsedge)
        write(3,440) xsedge, emu * hart
  440   format ('# Normalization factor:', e12.4,
     1     ' Angstrom**2. Fermi level at ', f7.1, ' eV.')
        write(3,450)
  450   format ('#   Energy      rho_0        mu_0       rho_0/mu_0 ')

        write(4,440) xsedge, emu * hart
        write(4,455)
  455   format ('#   Energy      rho_proj      mu_0      rho_proj/mu_0',
     1   '    mu_deloc ')

        do ie=1,ne1
           if (dimag(cchi(ie)).eq.0.d0 .and. ie.lt.ik0) then
              cchi(ie)=cchi(ik0)
              xrhoce(ie)=xrhoce(ik0)
              xrhopr(ie)=xrhopr(ik0)
           endif
           ratio = dimag(xrhoce(ie)) / dimag(cchi(ie)) * xsedge
           ratiop = dimag(xrhopr(ie)) / dimag(cchi(ie)) * xsedge

           write(3,460)  dble(em(ie))*hart, dimag(xrhoce(ie)),
     1          dimag(cchi(ie))/xsedge, ratio*corr
c          corr is the ratio N_av/N_j, responsible for difference in
c          counts due to variation of wave function due to spin-orbit
  460      format(f12.6, 2x, e12.6,2x,e12.6,2x,e12.6,1x,e12.6)
           write(4,465)  dble(em(ie))*hart, dimag(xrhopr(ie)),
     1          dimag(cchi(ie))/xsedge, ratiop,
     2          dimag(xrhoce(ie)-xrhopr(ie))/ratio
c     also write contribution to mu_0 from delocalized states defined as
c     (rho-rho_proj)/ratio
  465      format(f12.6, 2x, e12.6,2x,e12.6,2x,e12.6,1x,e12.6,2x,e12.6)

        enddo
        close(unit=3)
        close(unit=4)
      endif

      return
      end


      SUBROUTINE HDLIN (X,Y,Z,NP,NC,
     1           XCC,ICOUNT,IRCT,X21,Y21,Z21,IIA,XE,YE,XU,YU,XI,YI,ZI,
     2           DI,IBEG,IEND,ICT,ICCT,
     3           IND,NIND,XXX,CCC,IN,IN1,IN2,TGM,TGMT,TGI,ZM,ZMI,RV,
     4           RVI,NNO,NOCT,YMIN,ZMIN,COORD,SNDT,NEH,KEEP)
C
C
C     THIS SUBROUTINE IS THE EXECUTIVE.
C
C
      DIMENSION     X(1),Y(1),Z(1),I2(2),I3(2),RRX(20),NGX(15),H(15),
     1              U(6),V(6),W(6),X1(10),Y1(10)
      DIMENSION     XCC(1),ICOUNT(1),IRCT(1),X21(1),Y21(1),Z21(1),
     1              IIA(1),XE(1),YE(1),XU(1),YU(1),XI(1),YI(1),ZI(1),
     2              DI(1),IBEG(1),IEND(1),ICT(1),ICCT(1)
      DIMENSION     IND(1),NIND(1),XXX(1),CCC(1),IN(1),IN1(1),IN2(1),
     1              TGM(1),TGMT(1),TGI(1),ZM(1),ZMI(1),RV(1),RVI(1),
     2              NNO(1),NOCT(1),YMIN(1),ZMIN(1),COORD(1),SNDT(1),
     3              NEH(1),KEEP(1)
      COMMON /GO3 / L0,L1,L00,L01,L2,L3,L4,L5,L6,L7,L8,L9,L10,L11,L12,
     1              L13
      COMMON /HDSC/ SCX,YAW,ROLL,PIT,LZ,VP,JJJ,ICORE
      COMMON /HEDG/ JAT,ME,JT,VX,VX1,VX2,VX3,NN
C
      IF (VP .LT. 0.) GO TO 20
      HXX = .015
      AVA = .0
      HX1 = .001
      LC  = 10**6
      IXXX= 0
      IF (SCX .LT. 0.) IXXX = 1
      SCX = ABS(SCX)
C
C     INITIALIZE VARIABLES.
C
      LZ  = LZ*5
      SW1 = 0
      SW  = 0
      IDAV= 0
C
C     CALCULATE MAXIMUM ALLOWABLE ELEMENTS.
C
      IABC = ICORE/(25+LZ+4*JJJ)
      SCT  = 1.
      VP   = VP/SCT
      VPX  = ABS(VP)
      ISAVE= NC
      NC   = IABC
      L5   = 0
      L6   = NC
      L7   = 2*NC
      L8   = 3*NC
      L2   = 4*NC
      L3   = 5*NC
      L4   = 6*NC
      L00  = 7*NC
      L01  = 8*NC
      L1   = 9*NC
      L0   = 10*NC
      L9   = 11*NC
      L10  = 12*NC
      L11  = 13*NC
      L15  = 14*NC
      L16  = 15*NC
      L17  = 16*NC
      L18  = 19*NC
      L12  = 20*NC
      L13  = 25*NC
      L14  = L13 + LZ*NC
      DO 10 J = 1,NC
      RVI(L8+J) = 10**6
      TGM(L5+J) = 10**6
      RV (L7+J) =-RVI(L8+J)
      TGI(L6+J) =-TGM(L5+J)
      NOCT(L9+J)= 0
      ZM  (L2+J)= RV(L7+J)
      ZMI(L3+J) = RVI(L8+J)
      NIND(L16+J) = 0
      IND (L15+J) = J
      KEEP(L18+J) = 0
   10 CONTINUE
      NC  = ISAVE
      IK  = 0
      IKT = 0
      KR  = JJJ
      PI  = 3.1416/180.
      U(6)= SCX
      V(6)= SCX
      VP  =-VP
C
C     STORE EULERIAN ANGLES.
C
      XX   = YAW*PI
      YY   = ROLL*PI
      ZZ   = PIT*PI
      COSY = COS(YY)
      SINY = SIN(YY)
      COSZ = COS(ZZ)
      SINZ = SIN(ZZ)
      COSX = COS(XX)
      SINX = SIN(XX)
   20 CONTINUE
      NT  = NP-1
      IKK = IK+1
      IK  = IK+1
C
C     SET ERROR CODES, IF NECESSARY.
C
      IF (IKK .LE. IABC) GO TO 30
      SW = 1
   30 CONTINUE
      IF (NC .EQ. 0) GO TO 40
      IDAV = 1
      NC   =-SW1
      IF (SW .EQ. 0.) GO TO 50
      ICORE = (25+LZ+4*JJJ)*IKK
      NC    =-(SW+SW1)
   40 CONTINUE
   50 CONTINUE
      DO 60 J = 1,NP
      X21(J) = X(J)
      Y21(J) = Y(J)
      Z21(J) = Z(J)
   60 CONTINUE
C
C     STORE COORDINATES AND SET PEN POSITION WHENEVER ABS(Z)=9999.
C
      DO 70 J = 1,NT
      IIA(J) = 0
      IF (Z21(J) .NE. 9999.) GO TO 70
      IIA(J) = 1
      IXU = J - 2
      IBB = J - ISIGN(1,IXU)
      X21(J) = X21(IBB)
      Y21(J) = Y21(IBB)
      Z21(J) = Z21(IBB)
   70 CONTINUE
      IIA(NP) = 1
      Z21(NP) = Z21(NT)
      Y21(NP) = Y21(NT)
      X21(NP) = X21(NT)
      JXX = IKK
      I   = 1
      VL  = ABS(VP)
C
C     LOOP THAT DOES THE THREE DIMENSIONAL TRANSFORMATION ON THE
C     COORDINATES.
C
      JV = L14 + (IKK-1)*4*JJJ
      JT = 1
      DO 90 J = 1,NP
      XJ = X21(J)/SCT
      YJ = Y21(J)/SCT
      ZJ = Z21(J)/SCT
      U(I) = ZJ*(COSY*SINX) + XJ*(COSY*COSX) - YJ*SINY
      TW = YJ*COSY*COSZ
      TZ = XJ*( SINZ*SINX+SINY*COSZ*COSX)
      TY = ZJ*(-SINZ*COSX+SINY*COSZ*SINX)
      V(I) = TZ + TW + TY
      PT = YJ*COSY*SINZ
      PK = ZJ*( COSZ*COSX+SINY*SINZ*SINX)
      PS = XJ*(-COSZ*SINX+SINY*SINZ*COSX)
      ZJ = PK + PS + PT
      IF (ZJ .LT. VL) GO TO 80
      SW1 = 2
      VPX = AMAX1(ZJ,VPX)
      VPX = VPX + (.5/SCT)
   80 CONTINUE
      T = SW + SW1
      IF (T .NE. 0.) GO TO 90
C
C     CALCULATES PERSPECTIVE BASED ON VALUE VP(DV) FROM CALLING PROGRAM.
C
      HH = VL/(VL-ZJ)
      X21(J) = U(I)*HH
      Y21(J) = V(I)*HH
      Z21(J) = ZJ*HH
C
C     CALCULATES MAX/MIN VALUES OF EACH ELEMENT ON THE X,Y,Z DIMENSION
C
      RV (L7+JXX) = AMAX1(RV (L7+JXX),Y21(J))
      RVI(L8+JXX) = AMIN1(RVI(L8+JXX),Y21(J))
      TGI(L6+JXX) = AMAX1(TGI(L6+JXX),X21(J))
      TGM(L5+JXX) = AMIN1(TGM(L5+JXX),X21(J))
      ZM (L2+JXX) = AMAX1(ZM (L2+JXX),Z21(J))
      ZMI(L3+JXX) = AMIN1(ZMI(L3+JXX),Z21(J))
      COORD(JT+JV  ) = X21(J)
      COORD(JT+JV+1) = Y21(J)
      COORD(JT+JV+2) = Z21(J)
      COORD(JT+3+JV) = IIA(J)
      JT = JT + 4
   90 CONTINUE
      IF (IDAV .EQ. 1) VP = VPX*SCT
      IF (T   .NE. 0.) GO TO 400
      NOCT(L9+IKK) = NOCT(L9+IKK) + NP
      NS  = NP
      AVA = AVA + (TGI(L6+JXX)-TGM(L5+JXX))*(RV(L7+JXX)-RVI(L8+JXX))
      IF (IXXX .EQ. 1) GO TO 95
C
C     CALL SUBROUTINE WHICH CALCULATES BOTH THE EQUATIONS OF THE LINE
C     SEGMENTS AND POLYGONS.
C
      CALL HDCOEF (X21,Y21,Z21,XXX,JXX,NS,CCC,LZ)
C
C     CHECKS TO SEE IF ALL ELEMENTS(SETS) HAVE BEEN PASSED.
C
   95 CONTINUE
      IF (IDAV .EQ. 1) GO TO 100
      GO TO 400
  100 CONTINUE
      AVA = AVA/IKK
      DO 1301 J = 1,100
      ICCT(J) = 0
      ICT (J) = 0
      IRCT(J) = J - 1
      IBEG(J) = 1
      IEND(J) = 0
 1301 CONTINUE
      IAUG  = 50 + (IKK/10000)*2
      AMAXX =-999999.
      AMAXY =-999999.
      AMINX = 999999.
      AMINY = 999999.
      DO 1400 J = 1,IKK
      AMAXX = AMAX1(AMAXX,TGI(L6+J))
      AMAXY = AMAX1(AMAXY,RV (L7+J))
      AMINX = AMIN1(AMINX,TGM(L5+J))
      AMINY = AMIN1(AMINY,RVI(L8+J))
 1400 CONTINUE
      TMAX = (AMAXX-AMINX)*(AMAXY-AMINY)
      IBL  = TMAX/AVA
      IBL  = IBL/4
C
C     DETERMINES THE NUMBER OF GRID POINTS IN THE GRID.
C
C
      EN = IKK
      K  = (ALOG(EN)/ALOG(2.)) + .01
      K  = K + IAUG
      K  = MIN0(K,IBL)
      IF (K .LE. 1) K = 1
      T  = K
      R  = T**.5
      KS = R + .5
      S  = T/KS
      MS = S + .5
      N  = KS*MS
      MND= N + 1
      XMD= MND
      T  = 3./(MND-1)
      IGY= T*IKK
      K  = KS
      K1 = MS
      CRX= (AMAXX-AMINX)/K
      CRY= (AMAXY-AMINY)/K1
C
C
C     DETERMINES THE RELEVANT ELEMENTS VIA THE GRID BLOCKS.
C
C
      DO 3 J = 1,IKK
      IA = 0
      XMAT = TGI(L6+J)
      XMIT = TGM(L5+J)
      YMAT =  RV(L7+J)
      YMIT = RVI(L8+J)
      M = 0
      DO 1 I = 1,K1
      DO 2 L = 1,K
      M  = M + 1
      S  = XMAT - ((L-1)*CRX+AMINX)
      S1 = XMAT - (L*CRX+AMINX)
      R  = XMIT - ((L-1)*CRX+AMINX)
      R1 = XMIT - (L*CRX+AMINX)
      A  = YMAT - ((I-1)*CRY+AMINY)
      A1 = YMAT - (I*CRY+AMINY)
      B  = YMIT - ((I-1)*CRY+AMINY)
      B1 = YMIT - (I*CRY+AMINY)
      IF (S.LE.0. .OR. R1.GE.0.) GO TO 2
      IF (A.LE.0. .OR. B1.GE.0.) GO TO 2
      IF (S*S1.GT.0. .OR. R*R1.GT.0.) GO TO 4
      IF (A*A1.GT.0. .OR. B*B1.GT.0.) GO TO 4
      NIND(L16+J) = M
      GO TO 3
    4 CONTINUE
      IA = IA + 1
      IF (IA .LE. 4) GO TO 8000
      NIND(J+L16) = 0
      GO TO 8001
 8000 CONTINUE
      NIND(L16+J) = NIND(L16+J) + M*(MND**(IA-1))
 8001 CONTINUE
      IF (ICCT(M) .LT. 0) GO TO 2
      ICCT(M) = ICCT(M) + 1
      JK      = (M-1)*IGY+ICCT(M) + L17
      NEH(JK) = J
      IF (ICCT(M) .GE. IGY) ICCT(M) = -1
    2 CONTINUE
    1 CONTINUE
    3 CONTINUE
      CALL HDVS1 (NIND(L16+1),IK,IND(L15+1))
      SW = 0
      L  = 1
      DO 5 I = 1,IKK
   11 CONTINUE
      IF (NIND(L16+I) .NE. IRCT(L)) GO TO 6
      SW = SW + 1
      IF (SW .EQ. 1.) LT = I
      ICT(L) = ICT(L) + 1
      GO TO 5
    6 CONTINUE
      IF (SW .NE. 0.) GO TO 8
      L = L + 1
      GO TO 11
    8 CONTINUE
      IBEG(L) = LT
      IEND(L) = LT + ICT(L) - 1
      SW = 0
      IF (NIND(L16+I) .GE. MND) GO TO 2110
      L = L + 1
      GO TO 11
    5 CONTINUE
      IBEG(L) = LT
      IEND(L) = LT + ICT(L) - 1
 2110 CONTINUE
      DO 2111 J = 1,IKK
      SNDT(L4+J) = IND(L15+J)
 2111 CONTINUE
      CALL HDVSR (SNDT(L4+1),IK,NIND(L16+1))
      EN  = IKK
      IGX = (ALOG(EN)/ALOG(2.)) + 1.
      DO 105 J = 1,IGX
      RRX(J) = 2**(IGX-J)
  105 CONTINUE
      U(6) = SCX
      V(6) = SCX
      W(6) = SCX
      IKT  = NC
      T    = AMINY
      T1   = AMINX
      V(5) = T
      U(5) = T1
      IJ   = 0
      X1(3)= U(5)
      Y1(3)= V(5)
      X1(4)= U(6)
      Y1(4)= V(6)
      X1(4)= X1(4)/SCT
      Y1(4)= Y1(4)/SCT
      DO 115 J = 1,IKK
      IN(L11 +J) = J
      IN1(L0 +J) = J
      IN2(L00+J) = J
      TGMT(L10+J) = TGM(L5+J)
      YMIN(L1 +J) = RVI(L8+J)
      ZMIN(L01+J) = ZM(L2+J)
  115 CONTINUE
C
C     CALL SUBROUTINE WHICH WILL SORT ON X,Y AND Z.
C
      CALL HDVSR (TGMT(L10+1),IK,IN(L11+1))
      CALL HDVSR (YMIN(L1+1),IK,IN1(L0+1))
      CALL HDVSR (ZMIN(L01+1),IK,IN2(L00+1))
      H(8) = 0
      DO 395 J = 1,IKK
      KS = IKK
      JJ = L14 + (J-1)*4*JJJ
      JH = 1
      II = 0
      IXR= NOCT(L9+J)
      NIT= 0
      JT = L12 + 5*(J-1)
      JO = L13 + LZ*(J-1)
      IF (IXXX .EQ. 1) GO TO 200
      NS = XXX(5+JT)
      NG = NS*5
      A3 = XXX(1+JT)
      B3 = XXX(2+JT)
      C3 = XXX(3+JT)
      D3 = XXX(4+JT)
      I  = 0
      DO 121 IX = 1,NG,5
      IF (IXR .LE. 3) GO TO 121
      I = I + 1
      XE(I) = CCC(IX+3+JO)
      IF (CCC(IX+JO) .NE. 0.) GO TO 120
      XE(I) =-CCC(IX+2+JO)
      YE(I) = CCC(IX+3+JO)
      GO TO 121
  120 CONTINUE
      YE(I) =-CCC(IX+2+JO) - CCC(IX+1+JO)*XE(I)
  121 CONTINUE
C
C     THIS LOOP DETERMINES THE RELEVANT ELEMENTS AS THEY RELATE TO A
C     PARTICULAR ELEMENT.  THAT IS, EACH ELEMENT HAS ASSOCIATED WITH IT
C     THOSE OTHER ELEMENTS WHICH COULD POSSIBLY HIDE SOME PORTION
C     OF THE GIVEN ELEMENT.
C
      K  = 2**IGX
      K1 = K
      K2 = K
C
C     DO LOGARITHMIC SEARCH TO DETERMINE RELEVANT ELEMENTS.
C
      S = -1
      DO 131 I = 1,IGX
      K = K + SIGN(RRX(I),S)
      IF (K .GT. IKK) K = IKK
      S  = TGI(L6+J) - TGMT(L10+K  )
      S1 = TGI(L6+J) - TGMT(L10+K-1)
      IF (S*S1 .LE. 0.) GO TO 132
  131 CONTINUE
      K = IKK
  132 CONTINUE
      S = -1
      DO 133 I = 1,IGX
      K1 = K1 + SIGN(RRX(I),S)
      IF (K1 .GT. IKK) K1 = IKK
      S  = RV(L7+J) - YMIN(L1+K1  )
      S1 = RV(L7+J) - YMIN(L1+K1-1)
      IF (S*S1 .LE. 0.) GO TO 134
  133 CONTINUE
      K1 = IKK
  134 CONTINUE
      S = -1
      DO 135 I = 1,IGX
      K2 = K2 + SIGN(RRX(I),S)
      IF (K2 .LE.   1) K2 = 2
      IF (K2 .GT. IKK) K2 = IKK
      S  = ZMI(L3+J) - ZMIN(L01+K2  )
      S1 = ZMI(L3+J) - ZMIN(L01+K2-1)
      IF (S*S1 .LE. 0.) GO TO 136
  135 CONTINUE
      K2 = 1
  136 CONTINUE
      I1 = IKK - K2 + 1
C
C     RETRIEVE THE RELEVANT ELEMENTS DETERMINED FROM SCHEME 1.
C
      IF  (NIND(L16+J) .EQ. 0) GO TO 1270
      IR = NIND(L16+J)
      VX = NIND(L16+J)
      T  = ALOG(VX)
      IF (NIND(L16+J) .LE. LC) GO TO 1800
      E  = LC
      LG = NIND(L16+J)/LC
      MU = MOD(IR,LC)
      UX = LG + (MU/E)
      T  = ALOG(UX) + ALOG(E)
 1800 CONTINUE
      IXT = 0
      IEXP= (T/ALOG(XMD)) + 1
      DO 8004 L = 1,IEXP
      IV = IR/(MND**(IEXP-L))
      IR = IR - IV*(MND**(IEXP-L))
      IV = IV + 1
      IF (ICCT(IV-1) .EQ. 0) GO TO 4000
      IF (ICCT(IV-1) .GT. 0) GO TO 4001
      GO TO 1270
 4001 CONTINUE
      KE = ICCT(IV-1)
      IL = 0
      JTT= (IV-2)*IGY + L17
      DO 4003 I = 1,KE
      KV = NEH(I+JTT)
      IF (KEEP(L18+KV) .EQ. J) GO TO 4003
      IL = IL + 1
      NNO(L4+IXT+IL) = KV
      KEEP(L18+KV) = J
 4003 CONTINUE
      IXT = IXT + IL
 4000 CONTINUE
      IX  = IBEG(IV)
      IX1 = IEND(IV)
      DO 1170 I = IX,IX1
 1170 NNO(L4+IXT+I-IX+1) = IND(L15+I)
      IXT = IXT + IX1 - IX + 1
 8004 CONTINUE
      KS = IXT
 1270 CONTINUE
      IM = MIN0(I1,K,K1)
C
C     PICK MINIMUM COUNT FROM BOTH SCHEMES.
C
      IF (KS .LT. IM) GO TO 129
      IF (IM .EQ. I1) GO TO 1000
      IF (IM .EQ.  K) GO TO 1001
      IF (IM .EQ. K1) GO TO 1002
 1000 CONTINUE
      KS = I1
      DO 1003 I = 1,KS
 1003 NNO(L4+I) = IN2(L00+IKK-I+1)
      GO TO 129
 1001 CONTINUE
      KS = K
      DO 1004 I = 1,KS
 1004 NNO(L4+I) = IN(L11+I)
      GO TO 129
 1002 CONTINUE
      KS = K1
      DO 1006 I = 1,KS
 1006 NNO(L4+I) = IN1(L0+I)
  129 CONTINUE
      DO 170 I = 1,KS
      IT = 0
      JB = NNO(L4+I)
      IF (J .EQ. JB) GO TO 170
      JK = L13 + LZ*(JB-1)
      JS = L12 +  5*(JB-1)
      IF (TGM(L5+J).GE.TGI(L6+JB) .OR. TGI(L6+J).LE.TGM(L5+JB))
     1    GO TO 170
      IF (RV(L7+J).LE.RVI(L8+JB) .OR. RVI(L8+J).GE.RV(L7+JB)) GO TO 170
      IF (ZMI(L3+J) .GE. ZM(L2+JB)) GO TO 170
      NV = XXX(5+JS)
      IF (XXX(JS+3) .EQ. 0.) GO TO 170
      IF (XXX(3+JT) .EQ. 0.) GO TO 165
      NB = 5*NV
C
C
C     TEST TO SEE IF ALL VERTICES LIE EITHER BEHIND OR IN FRONT OF
C     THE GIVEN POLYGON.
C
C
      M = 0
      DO 145 IX = 1,NB,5
      M = M + 1
      A = CCC(IX+3+JK)
      IF (CCC(IX+JK) .NE. 0.) GO TO 130
      A =-CCC(IX+2+JK)
      B = CCC(IX+3+JK)
      GO TO 140
  130 CONTINUE
      B =-CCC(IX+2+JK) - CCC(IX+1+JK)*A
  140 CONTINUE
      XU(M) = A
      YU(M) = B
      VX  = XXX(4+JS)
      VX1 = XXX(2+JS)*B
      VX2 = XXX(1+JS)*A
      ZS  =-(VX+VX1+VX2)/XXX(3+JS)
      VX  = XXX(4+JT)
      VX1 = XXX(2+JT)*B
      VX2 = XXX(1+JT)*A
      ZS1 =-(VX+VX1+VX2)/XXX(3+JT)
      IF (ABS(ZS-ZS1) .LT. HXX) GO TO 145
      IT = IT + 1
      ICOUNT(IT) = 0
      IF (ZS .GT. ZS1) ICOUNT(IT) = 1
  145 CONTINUE
C
C
C     TESTS FOR SEMI-RELEVANT PLANES.  THAT IS,NEGATIVE INDEXES
C     INDICATE ELEMENT IS TO BE USED FOR VISIBILITY TEST, BUT NOT FOR
C     INTERSECTION LINE DETERMINATION.
C
C
      IF (IT .EQ. 0) GO TO 170
      L = 0
      DO 150 M = 1,IT
  150 L = L + ICOUNT(M)
      IF (L  .EQ.  0) GO TO 170
      IF (L  .EQ. IT) JB = -JB
      IF (II .NE.  0) GO TO 165
C
C
C     INTERROGATE THE RELATIONSHIP OF THE CANDIDATE POLYGON TO THE
C     GIVEN POLYGON BY DETERMINING IF THE PROJECTION OF ONE POLYGON
C     CAN BE SEPARATED BY AN EDGE FROM THE OTHER'S PROJECTION
C
C
      C3 = XXX(3+JT)
      C4 = XXX(3+JS)
      SD = 0
      I3(1) = JK
      I3(2) = JO
      I2(1) = NV*5
      I2(2) = NS*5
      DO 164 KU = 1,2
      IS = I3(KU)
      IB = I2(KU)
      DO 163 L = 1,IB,5
  151 CONTINUE
      IF (SD .EQ. 1.) GO TO 152
      A = XXX(2+JT)*C4 - XXX(2+JS)*C3
      B = XXX(1+JT)*C4 - XXX(1+JS)*C3
      C = XXX(4+JT)*C4 - XXX(4+JS)*C3
      GO TO 153
  152 CONTINUE
      A = CCC(L+IS  )
      B = CCC(L+IS+1)
      C = CCC(L+IS+2)
  153 CONTINUE
      IF (A.EQ.0. .AND. B.EQ.0.) GO TO 162
      IF (A .NE. 0.) GO TO 154
      A = 0
      C = C/B
      B = 1
      GO TO 155
  154 CONTINUE
      B = B/A
      C = C/A
      A = 1
  155 CONTINUE
      M = 0
      R1= 0
      DO 158 IX = 1,NV
      M = M + 1
      YG= YU(M)
      IF (A .NE. 0.) GO TO 156
      DY = -C/B
      YG = XU(M)
      GO TO 157
  156 CONTINUE
      DY = -C - B*XU(M)
  157 IF (ABS(DY-YG) .LT. HXX) GO TO 158
      R = YG - DY
      IF (R*R1 .LT. 0.) GO TO 162
      R1 = R
  158 CONTINUE
      M  = 0
      R2 = 0
      DO 161 IX = 1,NS
      M  = M + 1
      YG = YE(M)
      IF (A .NE. 0.) GO TO 159
      DY = -C/B
      YG = XE(M)
      GO TO 160
  159 CONTINUE
      DY = -C - B*XE(M)
  160 IF (ABS(DY-YG) .LT. HXX) GO TO 161
      R  = YG - DY
      IF (R*R2 .LT. 0.) GO TO 162
      R2 = R
  161 CONTINUE
      IF (R1*R2 .LT. 0.) GO TO 170
  162 CONTINUE
      IF (SD .NE. 0.) GO TO 163
      SD = 1
      GO TO 151
  163 CONTINUE
  164 CONTINUE
  165 CONTINUE
      II = II + 1
      NNO(L4+II) = JB
  170 CONTINUE
      JS  = 1
      JAT =-4
      JT  = L12 + (J-1)*5
      NN  = XXX(JT+5)
      VX  = XXX(JT+4)
      VX1 = XXX(2+JT)
      VX2 = XXX(1+JT)
      VX3 = XXX(3+JT)
      IF (IXR .LE. 2) GO TO 200
      IF (II  .EQ. 0) GO TO 190
C
C     CALL SUBROUTINE WHICH SOLVES FOR THE LINES OF INTERSECTION,IF ANY,
C     OF THE JTH ELEMENT WITH OTHER ELEMENTS.
C
      CALL HDSOLV(IXR,J,XXX,CCC,II,NNO,NIT,X21,Y21,Z21,IIA,NC,ZM,ZMI,LZ)
  190 CONTINUE
  200 CONTINUE
      DO 210 JM = 1,IXR
      X21(JM) = COORD(JH  +JJ)
      Y21(JM) = COORD(JH+1+JJ)
      Z21(JM) = COORD(JH+2+JJ)
      IIA(JM) = COORD(JH+3+JJ)
      JH = JH + 4
  210 CONTINUE
      IXR = IXR + 3*NIT
      IF (II   .EQ. 0) GO TO 220
      IF (IXXX .NE. 1) GO TO 240
  220 CONTINUE
      DO 230 JM = 1,IXR
      X1(2) = X21(JM)
      Y1(2) = Y21(JM)
      IM = IIA(JM)
      CALL HDPLT (X1,Y1,IJ,IM)
  230 CONTINUE
      GO TO 390
  240 CONTINUE
      JX = 1
  250 CONTINUE
C
C     PLOTS IF IIA(JX+1) IS EQUAL TO 1.
C
      IF (IIA(JX).EQ.0 .AND. IIA(JX+1).EQ.0) GO TO 260
      IM    = IIA(JX+1)
      X1(2) = X21(JX+1)
      Y1(2) = Y21(JX+1)
      CALL HDPLT (X1,Y1,IJ,IM)
      JX = JX + 2
      IF (JX .GE. IXR) GO TO 390
      GO TO 250
  260 CONTINUE
      JAT = JAT + 5
      ME  = 0
C
C     CALL SUBROUTINE WHICH DETERMINES THE POINTS OF INTERSECTIONS
C     OF THE LINES OF THE JTH SET WITH THE RELEVANT LINES AND PLANES
C     OF OTHER ELEMENTS.
C
      CALL HDCHK (XXX,CCC,NNO,II,XI,YI,NGX,ZM,ZMI,RV,RVI,TGM,TGI,ZI,LZ,
     1            XCC)
      IF (JS .NE. 1) STOP 'MY GOSH. JS IS NOT 1 /HDLIN'
      NG = NGX(JS) + 2
      XI(1)  = X21(JX)
      YI(1)  = Y21(JX)
      ZI(1)  = Z21(JX)
      XI(NG) = X21(JX+1)
      YI(NG) = Y21(JX+1)
      ZI(NG) = Z21(JX+1)
      IF (NG .LE. 3) GO TO 340
C
C     THE FOLLOWING CODE SORTS THE INTERSECTION POINTS IN ASCENDING
C     ORDER OF OCCURENCE AND THEN SHRINKS THE LIST IF REDUNDANCY EXIST.
C
      NI  = NG - 2
      NII = NI
      DO 270 M = 1,NG
      DI(M) = (XI(M)-XI(1))**2
      PPPPP = (YI(M)-YI(1))**2
      DI(M) = DI(M) + PPPPP
  270 CONTINUE
      DO 290 M = 2,NI
      DO 280 MX= 2,NII
      IF (DI(MX) .LE. DI(MX+1)) GO TO 280
      HOLD   = DI(MX)
      HOLD1  = XI(MX)
      HOLD2  = YI(MX)
      HOLD3  = ZI(MX)
      XI(MX) = XI(MX+1)
      YI(MX) = YI(MX+1)
      ZI(MX) = ZI(MX+1)
      DI(MX) = DI(MX+1)
      DI(MX+1) = HOLD
      XI(MX+1) = HOLD1
      YI(MX+1) = HOLD2
      ZI(MX+1) = HOLD3
  280 CONTINUE
      NII = NII - 1
  290 CONTINUE
      LX  = 1
      NPX = NG
  300 NPX = NPX - 1
      I   = LX
      DO 320 M = I,NPX
      RX  = 0
      T   = XI(M) - XI(M+1)
      T1  = YI(M) - YI(M+1)
      T   = (T**2+T1**2)**.5
      IF (T .GT. HX1) GO TO 320
      IX  = M
      IX1 = NPX
      DO 310 MX = IX,IX1
      XI(MX) = XI(MX+1)
      YI(MX) = YI(MX+1)
      ZI(MX) = ZI(MX+1)
  310 CONTINUE
      RX = 1
      LX = M
      IF (LX .EQ. NPX) GO TO 330
      GO TO 300
  320 CONTINUE
  330 CONTINUE
      IF (RX .EQ. 1.) NPX = NPX - 1
      NG = NPX + 1
  340 CONTINUE
C
C     THIS CODE DETERMINES THE HDSTUS(VISIBILITY) OF EVERY OTHER POINT
C     AS SUGGESTED BY THE THEOREM IN THE TECHNICAL REPORT.
C
      DO 350 L = 1,NG,2
C
      OJ  = XI(L)
      TMJ = YI(L)
      ZJ  = ZI(L)
      CALL HDSTUS (OJ,TMJ,XXX,TGM,RV,RVI,TGI,ZM,NNO,II,H,IM,JXT,ZJ,NC,
     1             ZMI,CCC,LZ)
      DI(L) = IM
  350 CONTINUE
      DO 370 L = 1,NG,2
      IF (L .EQ. NG  ) GO TO 370
      IF (L .EQ. NG-1) GO TO 360
      C = DI(L) + DI(L+2)
      IF (C .NE. 2.) GO TO 360
      DI(L+1) = DI(L)
      GO TO 370
  360 OJ  = XI(L+1)
      TMJ = YI(L+1)
      ZJ  = ZI(L+1)
      CALL HDSTUS (OJ,TMJ,XXX,TGM,RV,RVI,TGI,ZM,NNO,II,H,IM,JXT,ZJ,NC,
     1             ZMI,CCC,LZ)
      DI(L+1) = IM
  370 CONTINUE
C
C     THE FOLLOWING CODE ACTUALLY PLOTS THE POINTS ON A GIVEN LINE
C     GOVERNED BY THE VALUE(IM) RETURNED BY HDSTUS SUBROUTINE.
C     1 MEANS INVISIBLE,...0 MEANS VISIBLE.
C
      DO 380 L = 1,NG
      X1(2) = XI(L)
      Y1(2) = YI(L)
      IM = DI(L)
      CALL HDPLT (X1,Y1,IJ,IM)
      IF (L .EQ. NG) GO TO 380
      C = DI(L) + DI(L+1)
      IF (C .GT. 0.) GO TO 380
      H(8) = 1
      OJ   = (XI(L)+XI(L+1))/2
      TMJ  = (YI(L)+YI(L+1))/2
      ZJ   = (ZI(L)+ZI(L+1))/2
      CALL HDSTUS (OJ,TMJ,XXX,TGM,RV,RVI,TGI,ZM,NNO,II,H,IM,JXT,ZJ,NC,
     1             ZMI,CCC,LZ)
      H(8) = 0
      X1(2)= OJ
      Y1(2)= TMJ
      CALL HDPLT (X1,Y1,IJ,IM)
  380 CONTINUE
      JX = JX + 1
      GO TO 250
  390 CONTINUE
C
C     DECREMENTS THE COUNT OF THE NUMBER OF LINES IN THE JTH SET
C     SINCE THE LINES OF INTERSECTIONS WERE ADDED TO THIS ELEMENT
C     BY THE SUBROUTINE SOLVE.
C
      XXX(5+JT) = XXX(5+JT) - NIT
  395 CONTINUE
  400 CONTINUE
      RETURN
      END


!
!     ------------------------------------------------------------------
!     N O R T B P
!     ------------------------------------------------------------------
!
      SUBROUTINE NORTBP(JA, JB)
      use inout_C
      use ovrlap_C
      use ndims_C
      use non30_C
      use nor_C
!
!...Translated by Pacific-Sierra Research 77to90  4.3E  13:25:16  11/20/01
!...Switches:
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER , INTENT(IN) :: JA
      INTEGER , INTENT(IN) :: JB
!-----------------------------------------------
!   L o c a l   P a r a m e t e r s
!-----------------------------------------------
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER , DIMENSION(2) :: ILNO, IRNO
      INTEGER :: N1, N2, IL, IR, I, NI, J, NJ, NA, NB, NC, K, ISTO, &
                 NMU, NMUP, NNU, NNUP
!-----------------------------------------------
!
!      COMMON /INOUT/IREAD,IWRITE,ISCW,iuc(2),iuw(2),iul(2),iuj(2),iut(2)
!      POINTER (QIORTH,IORTH(1))
!      COMMON/OVRLAP/MU,NU,MUP,NUP,NONORT,NOVLPS,IROWMU,IROWNU,ICOLMU,
!     : ICOLNU,NORTH,IORDER,NCALLS,LMU,LNU,LMUP,LNUP,JMU,JNU,JMUP,JNUP,
!     : QIORTH
!      POINTER(QNOC,NOCCSH(1)),(QNELCSH,NELCSH(8,1)),
!     :       (QNOCORB,NOCORB(8,1)),(QJ1,J1QNRD(15,1))
!      POINTER(QIAJCMP,IAJCMP(1)),(QLJCOMP,LJCOMP(1)),
!     :       (QNJCOMP,NJCOMP(1)),(QIAJCLD,IAJCLD(1)),
!     :       (QLJCLSD,LJCLSD(1))
!      COMMON /NDIMS/ QNOC,QNELCSH,QNOCORB,QJ1,NCFG
!      COMMON /NON30/ QIAJCMP,QNJCOMP,QLJCOMP,QIAJCLD,QLJCLSD,MAXORB
!      COMMON /NOR/NCOM,NCLOSI,NCLOSF,NORBI,NORBF,IWAR
!
  101 FORMAT(/,&
         ' INCORRECT NON-ORTHOGONALITY SET UP IN THE MATRIX ELEMENT  -  (',I2,&
         '/V/',I2,')')
!
      N1 = NOCCSH(JA)
      N2 = NOCCSH(JB)
      IWAR = 0
      JMU = 0
      JNU = 0
      JMUP = 0
      JNUP = 0
      IL = 0
      IR = 0
!
! --- BEGIN SEARCH FOR NON-ORTHOGONAL SUBSHELLS IN THIS MATRIX ELEMENT
!
      DO I = 1, N1
         NI = NOCORB(I,JA)
         L2: DO J = 1, N2
            NJ = NOCORB(J,JB)
            IF (NI == NJ) CYCLE  L2
            NA = MIN0(NI,NJ)
            IF (NA <= NCOM) CYCLE  L2
            NB = MAX0(NI,NJ)
!
!   THE FOLLOWING CARD IS NOT THE SAME THAN IN NORTBP OF NON
!
            NC = NORBF*(NA - NCOM - 1) + NB - NCOM - NORBI
            IF (IORTH(NC) /= 1) CYCLE  L2
            IF (IL == 0) GO TO 4
            IF (ILNO(IL) == I) GO TO 14
            IF (IL == 2) GO TO 100
    4       CONTINUE
            IL = IL + 1
            ILNO(IL) = I
   14       CONTINUE
            IF (IR == 0) GO TO 7
            DO K = 1, IR
               IF (IRNO(K) /= J) CYCLE
               CYCLE  L2
            END DO
            IF (IR == 2) GO TO 100
    7       CONTINUE
            IR = IR + 1
            IRNO(IR) = J
         END DO L2
      END DO
      IF (IL /= 0) THEN
         IF (IR /= 1) THEN
            IF (IRNO(1) > IRNO(2)) THEN
               ISTO = IRNO(1)
               IRNO(1) = IRNO(2)
               IRNO(2) = ISTO
            ENDIF
         ENDIF
         JMU = ILNO(1)
         IF (IL /= 1) JNU = ILNO(2)
         JMUP = IRNO(1)
         IF (IR == 1) GO TO 10
         JNUP = IRNO(2)
         GO TO 10
      ENDIF
      NOVLPS = 0
      RETURN
  100 CONTINUE
      WRITE (IWRITE, 101) JA, JB
      IWAR = 1
      RETURN
   10 CONTINUE
      NMU = NOCORB(JMU,JA)
      NMUP = NOCORB(JMUP,JB)
      LMU = LJCOMP(NMU)
      LMUP = LJCOMP(NMUP)
      IF (JNU/=0 .OR. JNUP/=0) THEN
         IF (JNU == 0) JNU = JMU
         IF (JNUP == 0) JNUP = JMUP
         NNU = NOCORB(JNU,JA)
         NNUP = NOCORB(JNUP,JB)
         LNU = LJCOMP(NNU)
         LNUP = LJCOMP(NNUP)
         NOVLPS = 2
         RETURN
      ENDIF
      NOVLPS = 1
      RETURN
      END SUBROUTINE NORTBP


      BLOCK DATA DT_ZK

      IMPLICIT NONE
      SAVE

C decay channel information for HADRIN
      INCLUDE 'inc/hnaddh'
C decay channel information for HADRIN
      INCLUDE 'inc/hnaddn'

C     Particle masses in GeV                                           *
      DATA AMZ/3*2.2D0 , 0.9576D0 , 3*1.887D0 , 2.4D0 , 2.03D0 ,
     &     2*1.44D0 , 2*1.7D0 , 3*0.D0/
C     Resonance width Gamma in GeV                                     *
      DATA GAZ/3*.2D0 , .1D0 , 4*.2D0 , .18D0 , 2*.2D0 , 2*.15D0 ,
     &     3*0.D0/
C     Mean life time in seconds                                        *
      DATA TAUz/16*0.D0/
C     Charge of particles and resonances                               *
      DATA ICHz/0 , 1 , 3*0 , 1 , -1 , 0 , 1 , -1 , 0 , 0 , 1 , 3*0/
C     Baryonic charge                                                  *
      DATA IBArz/2 , 7*0 , 1 , -1 , -1 , 1 , 1 , 3*0/
C     First number of decay channels used for resonances               *
C     and decaying particles                                           *
      DATA K1Z/308 , 310 , 313 , 317 , 322 , 365 , 393 , 421 , 425 ,
     &     434 , 440 , 446 , 449 , 3*460/
C     Last number of decay channels used for resonances                *
C     and decaying particles                                           *
      DATA K2Z/309 , 312 , 316 , 321 , 364 , 392 , 420 , 424 , 433 ,
     &     439 , 445 , 448 , 451 , 3*460/
C     Weight of decay channel                                          *
      DATA WTZ/.17D0 , .83D0 , 2*.33D0 , .34D0 , .17D0 , 2*.33D0 ,
     &     .17D0 , .01D0 , .13D0 , .36D0 , .27D0 , .23D0 , .0014D0 ,
     &     .0029D0 , .0014D0 , .0029D0 , 4*.0007D0 , .0517D0 , .0718D0 ,
     &     .0144D0 , .0431D0 , .0359D0 , .0718D0 , .0014D0 , .0273D0 ,
     &     .0014D0 , .0431D0 , 2*.0129D0 , .0259D0 , .0517D0 , .0359D0 ,
     &     .0014D0 , 2*.0144D0 , .0129D0 , .0014D0 , .0259D0 , .0359D0 ,
     &     .0072D0 , .0474D0 , .0948D0 , .0259D0 , .0072D0 , .0144D0 ,
     &     .0287D0 , .0431D0 , .0144D0 , .0287D0 , .0474D0 , .0144D0 ,
     &     .0075D0 , .0057D0 , .0019D0 , .0038D0 , .0095D0 , 2*.0014D0 ,
     &     .0191D0 , .0572D0 , .1430D0 , 2*.0029D0 , 5*.0477D0 ,
     &     .0019D0 , .0191D0 , .0686D0 , .0172D0 , .0095D0 , .1888D0 ,
     &     .0172D0 , .0191D0 , .0381D0 , 2*.0571D0 , .0190D0 , .0057D0 ,
     &     .0019D0 , .0038D0 , .0095D0 , .0014D0 , .0014D0 , .0191D0 ,
     &     .0572D0 , .1430D0 , 2*.0029D0 , 5*.0477D0 , .0019D0 ,
     &     .0191D0 , .0686D0 , .0172D0 , .0095D0 , .1888D0 , .0172D0 ,
     &     .0191D0 , .0381D0 , 2*.0571D0 , .0190D0 , 4*.25D0 , 2*.2D0 ,
     &     .12D0 , .1D0 , .07D0 , .07D0 , .14D0 , 2*.05D0 , .0D0 ,
     &     .3334D0 , .2083D0 , 2*.125D0 , .2083D0 , .0D0 , .125D0 ,
     &     .2083D0 , .3334D0 , .2083D0 , .125D0 , .3D0 , .05D0 , .65D0 ,
     &     .3D0 , .05D0 , .65D0 , 9*1.D0/
C     Particle numbers in decay channel                                *
      DATA NZK1/8 , 1 , 2 , 9 , 1 , 2 , 9 , 2 , 9 , 7 , 13 , 31 , 15 ,
     &     24 , 23 , 13 , 23 , 13 , 2*23 , 14 , 13 , 23 , 31 , 98 ,
     &     2*33 , 32 , 23 , 14 , 13 , 35 , 2*23 , 14 , 13 , 33 , 23 ,
     &     98 , 31 , 23 , 14 , 13 , 35 , 2*33 , 32 , 23 , 35 , 33 , 32 ,
     &     98 , 5*35 , 4*13 , 23 , 13 , 98 , 32 , 33 , 23 , 13 , 23 ,
     &     13 , 14 , 13 , 32 , 13 , 98 , 23 , 13 , 2*32 , 13 , 33 , 32 ,
     &     98 , 2*35 , 4*14 , 23 , 14 , 98 , 2*34 , 23 , 14 , 23 ,
     &     2*14 , 13 , 34 , 14 , 98 , 23 , 14 , 2*34 , 14 , 33 , 32 ,
     &     98 , 2*35 , 104 , 61 , 105 , 62 , 1 , 17 , 21 , 17 , 22 ,
     &     2*21 , 22 , 21 , 2 , 67 , 68 , 69 , 2 , 2*9 , 68 , 69 , 70 ,
     &     2 , 9 , 2*24 , 15 , 2*25 , 16 , 9*0/
      DATA NZK2/2*8 , 1 , 8 , 9 , 2*8 , 2*1 , 7 , 14 , 13 , 16 , 25 ,
     &     23 , 14 , 23 , 14 , 31 , 33 , 32 , 34 , 35 , 31 , 23 , 31 ,
     &     33 , 34 , 31 , 32 , 34 , 31 , 33 , 32 , 2*33 , 35 , 31 , 33 ,
     &     31 , 33 , 32 , 34 , 35 , 31 , 33 , 34 , 35 , 31 , 4*33 , 32 ,
     &     3*35 , 2*23 , 13 , 31 , 32 , 33 , 13 , 31 , 32 , 2*31 , 32 ,
     &     33 , 32 , 32 , 35 , 31 , 2*32 , 33 , 31 , 33 , 35 , 33 ,
     &     3*32 , 35 , 2*23 , 14 , 31 , 34 , 33 , 14 , 31 , 33 , 2*31 ,
     &     34 , 32 , 33 , 34 , 35 , 31 , 2*34 , 33 , 31 , 33 , 35 , 33 ,
     &     2*34 , 33 , 35 , 1 , 2 , 8 , 9 , 25 , 13 , 35 , 2*32 , 33 ,
     &     31 , 13 , 23 , 31 , 13 , 23 , 14 , 79 , 80 , 31 , 13 , 23 ,
     &     14 , 78 , 79 , 8 , 1 , 8 , 1 , 8 , 1 , 9*0/
      DATA NZK3/23 , 14 , 2*13 , 23 , 13 , 2*23 , 14 , 0 , 7 , 14 ,
     &     4*0 , 2*23 , 10*0 , 33 , 2*31 , 0 , 33 , 34 , 32 , 34 , 0 ,
     &     35 , 0 , 31 , 3*35 , 0 , 3*31 , 35 , 31 , 33 , 34 , 31 , 33 ,
     &     34 , 31 , 33 , 35 , 0 , 23 , 14 , 6*0 , 32 , 3*33 , 32 , 34 ,
     &     0 , 35 , 0 , 2*35 , 2*31 , 35 , 32 , 34 , 31 , 33 , 32 , 0 ,
     &     23 , 13 , 6*0 , 34 , 2*33 , 34 , 33 , 34 , 0 , 35 , 0 ,
     &     2*35 , 2*31 , 35 , 2*34 , 31 , 2*34 , 25*0 , 23 , 2*14 , 23 ,
     &     2*13 , 9*0/
C     Particle  names                                                  *
      DATA ANAmz/'NNPI' , 'ANPPI' , 'ANNPI' , ' ETS  ' , ' PAP  ' ,
     &     ' PAN  ' , 'APN' , 'DEO   ' , 'S+2030' , 'AN*-14' ,
     &     'AN*014' , 'KONPI ' , 'AKOPPI' , 3*'BLANK'/
C     Name of decay channel                                            *
      DATA ZKNam4/'NNPI0' , 'PNPI-' , 'APPPI+' , 'ANNPI+' , 'ANPPI0' ,
     &     'APNPI+' , 'ANNPI0' , 'APPPI0' , 'ANPPI-'/
      DATA ZKNam5/' GAGA ' , 'P+P-GA' , 'ETP+P-' , 'K+K-  ' , 'K0AK0 ' ,
     &     ' POPO ' , ' P+P- ' , 'POPOPO' , 'P+P0P-' , 'P0ET  ' ,
     &     '&0R0  ' , 'P-R+  ' , 'P+R-  ' , 'POOM  ' , ' ETET ' ,
     &     'ETSP0 ' , 'R0ET  ' , ' R0R0 ' , 'R+R-  ' , 'P0ETR0' ,
     &     'P-ETR+' , 'P+ETR-' , ' OMET ' , 'P0R0R0' , 'P0R+R-' ,
     &     'P-R+R0' , 'P+R-R0' , 'R0OM  ' , 'P0ETOM' , 'ETSR0 ' ,
     &     'ETETET' , 'P0R0OM' , 'P-R+OM' , 'P+R-OM' , 'OMOM  ' ,
     &     'R0ETET' , 'R0R0ET' , 'R+R-ET' , 'P0OMOM' , 'OMETET' ,
     &     'R0R0R0' , 'R+R0R-' , 'ETSRET' , 'OMR0R0' , 'OMR+R-' ,
     &     'OMOMET' , 'OMOMR0' , 'OMOMOM' , ' P+PO ' , 'P+POPO' ,
     &     'P+P+P-' , 'P+ET  ' , 'P0R+  ' , 'P+R0  ' , 'ETSP+ ' ,
     &     'R+ET  ' , ' R0R+ ' , 'POETR+' , 'P+ETR0' , 'POR+R-' ,
     &     'P+R0R0' , 'P-R+R+' , 'P+R-R+' , 'R+OM  ' , 'P+ETOM' ,
     &     'ETSR+ ' , 'POR+OM' , 'P+R0OM' , 'R+ETET' , 'R+R0ET' ,
     &     'P+OMOM' , 'R0R0R+' , 'R+R+R-' , 'ETSR+E' , 'OMR+R0' ,
     &     'OMOMR+' , 'P-PO  ' , 'P-POPO' , 'P-P-P+' , 'P-ET  ' ,
     &     'POR-  ' , 'P-R0  ' , 'ETSP- ' , 'R-ET  ' , 'R-R0  ' ,
     &     'POETR-' , 'P-ETR0' , 'POR-R0' , 'P-R+R-' , 'P-R0R0'/
      DATA ZKNam6/'P+R-R-' , 'R-OM  ' , 'P-ETOM' , 'ETSR- ' , 'POR-OM' ,
     &     'P-R0OM' , 'R-ETET' , 'R-R0ET' , 'P-OMOM' , 'R0R0R-' ,
     &     'R+R-R-' , 'ETSR-E' , 'OMR0R-' , 'OMOMR-' , 'PAN-14' ,
     &     'APN+14' , 'NAN014' , 'ANN014' , 'PAKO  ' , 'LPI+  ' ,
     &     'SI+OM' , 'LAMRO+' , 'SI0RO+' , 'SI+RO0' , 'SI+ETA' ,
     &     'SI0PI+' , 'SI+PI0' , 'APETA ' , 'AN=P+ ' , 'AN-PO ' ,
     &     'ANOPO ' , 'APRHOO' , 'ANRHO-' , 'ANETA ' , 'AN-P+ ' ,
     &     'AN0PO ' , 'AN+P- ' , 'APRHO+' , 'ANRHO0' , 'KONPIO' ,
     &     'KOPPI-' , 'K+NPI-' , 'AKOPPO' , 'AKONP+' , 'K-PPI+' ,
     &     9*'BLANK'/
C=                                               end*block.zk      *
      END BLOCK DATA