      SUBROUTINE BEDLOAD(NX,NS)
C
C CHANGE RECORD
C **  SUBROUTINE CALSND CALCULATES NONCOHESIVER SEDIMENT SETTLING,
C **  DEPOSITION AND RESUSPENSION AND IS CALLED FOR SSEDTOX
C
      USE GLOBAL

	IMPLICIT NONE
	INTEGER::L,NSB,LUTMP,LDTMP,LS,LN,NX,NS
	REAL::SLOPE,UVARTMP,VVARTMP,ASNDFBL,SNDBTMP,SNDFBLM
	REAL::FLUXFAC,SNDFBLTOT,VCELLCTRM,QSBLLDXY,FSBDLD
	REAL::UCELLCTRM,SHIELDS,BDLDTMPB,CSHIELDSC,FSEDMODE
	REAL::BDLDTMPA,CSHIELDS,TMPVAL,BDLDTMPP,BDLDTMP,VELMAG
C
C **  BED LOAD TRANSPORT HORIZONTAL LOOP
C **  INITIALIZE BED LOAD TRANSPORTS
C
      DO L=1,LC
        QSBDLDP(L)=0.
        QSBDLDX(L,NX)=0.
        QSBDLDY(L,NX)=0.
        QSBDLDOT(L,NX)=0.
        QSBDLDIN(L,NX)=0.
        SNDFBL(L,NX)=0.
        RBPSBL(L)=1.0
      ENDDO
      IF(ISBDLDBC.EQ.0)RETURN
C
C **  CALCULATE CELL CENTER TRANSPORT RATES USING GENERIC BED LOAD EQUAT
C
      IF(ISBDLD(NS).EQ.0)THEN
        DO L=2,LA
          IF(LMASKDRY(L))THEN
            CSHIELDS=TCSHIELDS(NS)
            IF(ISEDEFF.EQ.2)THEN
              TMPVAL=1.+(COEHEFF2-1.)
     &            *( 1.-EXP(-COEHEFF*FRACCOH(L,KBT(L))) )
              CSHIELDS=TMPVAL*CSHIELDS
            ENDIF
            BDLDTMPP=SBDLDP
            BDLDTMP=SQRT(GPDIASED)*DIASED/DSEDGMM
            IF(BDLDTMPP.GT.0.0)THEN
              FACBEDL(L)=FSEDMODE(WSETA(L,0,NS),USTAR(L),USTARSND(L),
     &                   RSNDM(NX),ISNDM1(NX),ISNDM2(NX),1)
              SHIELDS=TAUBSND(L)/GPDIASED
              IF(SHIELDS.GT.CSHIELDS)THEN
                IF(SBDLDA.GT.0.0)THEN
                  BDLDTMPA=(SBDLDG1*SHIELDS-SBDLDG2*CSHIELDS)**SBDLDA
                ELSE
                  BDLDTMPA=1.0
                ENDIF
                IF(SBDLDB.GT.0.0)THEN
                  BDLDTMPB=(SBDLDG3*SQRT(SHIELDS)
     &                -SBDLDG4*SQRT(CSHIELDS))**SBDLDB
                ELSE
                  BDLDTMPB=1.0
                ENDIF
                QSBDLDP(L)=FACBEDL(L)*VFRBED(L,KBT(L),NS)*BDLDTMP*
     &              BDLDTMPP*BDLDTMPA*BDLDTMPB
                IF(ISEDEFF.EQ.1)THEN
                  TMPVAL=EXP(-COEHEFF*FRACCOH(L,KBT(L)))
                  QSBDLDP(L)=TMPVAL*QSBDLDP(L)
                ENDIF
              ENDIF
            ENDIF
          ENDIF
        ENDDO
      ENDIF
C
C **  CALCULATE CELL CENTER TRANSPORT RATES USING VAN RIJN BED LOAD EQUA
C
      IF(ISBDLD(NS).EQ.1)THEN
        DO L=2,LA
          IF(LMASKDRY(L))THEN
            CSHIELDS=TCSHIELDS(NS)
            IF(ISEDEFF.EQ.2)THEN
              TMPVAL=1.+(COEHEFF2-1.)
     &            *( 1.-EXP(-COEHEFF*FRACCOH(L,KBT(L))) )
              CSHIELDS=TMPVAL*CSHIELDS
            ENDIF
            IF(ISNDAL.EQ.1)THEN
              TMPVAL=LOG10(19.*DIASED/SEDDIA50(L,KBT(L)))
              TMPVAL=1.66667/(TMPVAL**2)
              CSHIELDSC=CSHIELDS50(L)*TMPVAL
            ELSE
              CSHIELDSC=TCSHIELDS(NS)
            END IF
            IF(ISEDEFF.EQ.2)THEN
              TMPVAL=1.+(COEHEFF2-1.)
     &            *( 1.-EXP(-COEHEFF*FRACCOH(L,KBT(L))) )
              CSHIELDSC=TMPVAL*CSHIELDS
            ENDIF
            BDLDTMPP=FSBDLD(DIASED,GPDIASED,SEDDIA50(L,KBT(L)),HP(L),
     &          PEXP(L,NX),PHID(L,NX),CSHIELDS,SBDLDP,ISBDLD(NS))
            IF(ISNDAL.EQ.1)THEN
              BDLDTMPP=((DIASED/SEDDIA50(L,KBT(L)))**0.3)*BDLDTMPP
            ENDIF
            BDLDTMP=SQRT(GPDIASED)*DIASED/DSEDGMM
            FACBEDL(L)=FSEDMODE(WSETA(L,0,NS),USTAR(L),USTARSND(L),
     &                 RSNDM(NX),ISNDM1(NX),ISNDM2(NX),1)
            SHIELDS=TAUBSND(L)/GPDIASED
            IF(SHIELDS.GT.CSHIELDSC.OR.ISBDLD(NS).GT.1)THEN
              BDLDTMPA=(SBDLDG1*SHIELDS-SBDLDG2*CSHIELDSC)**SBDLDA
              QSBDLDP(L)=FACBEDL(L)*VFRBED(L,KBT(L),NS)*BDLDTMP*
     &            BDLDTMPP*BDLDTMPA
              IF(ISEDEFF.EQ.1)THEN
                TMPVAL=EXP(-COEHEFF*FRACCOH(L,KBT(L)))
                QSBDLDP(L)=TMPVAL*QSBDLDP(L)
              ENDIF
            ENDIF
          ENDIF
        ENDDO
      ENDIF
C
C **  CALCULATE CELL CENTER TRANSPORT RATES USING ENGELUND-HANSEN
C
      IF(ISBDLD(NS).EQ.2)THEN
        IF(IBLTAUC(NS).EQ.0) CSHIELDS=0.
        IF(IBLTAUC(NS).EQ.1) CSHIELDS=TCSHIELDS(NS)
        DO L=2,LA
          IF(LMASKDRY(L))THEN
            IF(IBLTAUC(NS).EQ.2)
     &          CSHIELDS=SEDDIA50(L,KBT(L))*CSHIELDS50(L)/DIASED
            IF(IBLTAUC(NS).EQ.3)
     &          CSHIELDS=0.03*((PHID(L,NX)/PEXP(L,NX))**0.6)
            IF(ISEDEFF.EQ.2)THEN
              TMPVAL=1.+(COEHEFF2-1.)
     &            *( 1.-EXP(-COEHEFF*FRACCOH(L,KBT(L))) )
              CSHIELDS=TMPVAL*CSHIELDS
            ENDIF
            SHIELDS=TAUBSND(L)/GPDIASED
            IF(SHIELDS.GE.CSHIELDS)THEN
              BDLDTMPP=FSBDLD(DIASED,GPDIASED,SEDDIA50(L,KBT(L)),HP(L),
     &            PEXP(L,NX),PHID(L,NX),CSHIELDS,SBDLDP,ISBDLD(NS))
              IF(HGDH(L).GT.0.0) BDLDTMPP=BDLDTMPP/(HGDH(L)**0.333)
              BDLDTMP=SQRT(GPDIASED)*DIASED/DSEDGMM
              FACBEDL(L)=FSEDMODE(WSETA(L,0,NS),USTAR(L),USTARSND(L),
     &                   RSNDM(NX),ISNDM1(NX),ISNDM2(NX),1)
              BDLDTMPA=(SBDLDG1*SHIELDS)**SBDLDA
              QSBDLDP(L)=FACBEDL(L)*VFRBED(L,KBT(L),NS)*BDLDTMP*
     &            BDLDTMPP*BDLDTMPA
              IF(ISEDEFF.EQ.1)THEN
                TMPVAL=EXP(-COEHEFF*FRACCOH(L,KBT(L)))
                QSBDLDP(L)=TMPVAL*QSBDLDP(L)
              ENDIF
            ENDIF
          ENDIF
        ENDDO
      ENDIF
C
C **  CALCULATE CELL CENTER TRANSPORT RATES USING WU, WANG, AND JIA
C
      IF(ISBDLD(NS).EQ.3)THEN
        DO L=2,LA
          IF(LMASKDRY(L))THEN
            CSHIELDS=TCSHIELDS(NS)
            BDLDTMPP=FSBDLD(DIASED,GPDIASED,SEDDIA50(L,KBT(L)),HP(L),
     &          PEXP(L,NX),PHID(L,NX),CSHIELDS,SBDLDP,ISBDLD(NS))
            CSHIELDS=0.03*((PHID(L,NX)/PEXP(L,NX))**0.6)
            IF(ISEDEFF.EQ.2)THEN
              TMPVAL=1.+(COEHEFF2-1.)
     &            *( 1.-EXP(-COEHEFF*FRACCOH(L,KBT(L))) )
              CSHIELDS=TMPVAL*CSHIELDS
            ENDIF
            BDLDTMP=SQRT(GPDIASED)*DIASED/DSEDGMM
            FACBEDL(L)=FSEDMODE(WSETA(L,0,NS),USTAR(L),USTARSND(L),
     &                 RSNDM(NX),ISNDM1(NX),ISNDM2(NX),1)
            SHIELDS=TAUBSND(L)/GPDIASED
            IF(SHIELDS.GT.CSHIELDS)THEN
              BDLDTMPA=(SBDLDG1*SHIELDS-SBDLDG2*CSHIELDS)**SBDLDA
              QSBDLDP(L)=FACBEDL(L)*VFRBED(L,KBT(L),NS)*BDLDTMP*
     &            BDLDTMPP*BDLDTMPA
              IF(ISEDEFF.EQ.1)THEN
                TMPVAL=EXP(-COEHEFF*FRACCOH(L,KBT(L)))
                QSBDLDP(L)=TMPVAL*QSBDLDP(L)
              ENDIF
            ENDIF
          ENDIF
        ENDDO
      ENDIF
C
C **  CALCULATE CELL FACE TRANSPORT RATES BY DOWN WIND PROJECTION
C
      IF(ISBLFUC.EQ.0)THEN
        DO L=2,LA
          QSBDLDOT(L,NX)=0.
          QSBDLDIN(L,NX)=0.
          IF(LMASKDRY(L))THEN
            LN=LNC(L)
            IF(UCELLCTR(L).GE.0.0.AND.VCELLCTR(L).GE.0.0)THEN
              QSBDLDX(LEAST(L),NX)=SUB(LEAST(L))*QSBDLDP(L)*UCELLCTR(L)
              QSBDLDY(LN ,NX)=SVB(LN )*QSBDLDP(L)*VCELLCTR(L)
            ENDIF
            IF(UCELLCTR(L).GE.0.0.AND.VCELLCTR(L).LT.0.0)THEN
              QSBDLDX(LEAST(L),NX)=SUB(LEAST(L))*QSBDLDP(L)*UCELLCTR(L)
              QSBDLDY(L  ,NX)=SVB(L  )*QSBDLDP(L)*VCELLCTR(L)
            ENDIF
            IF(UCELLCTR(L).LT.0.0.AND.VCELLCTR(L).GE.0.0)THEN
              QSBDLDX(L  ,NX)=SUB(L  )*QSBDLDP(L)*UCELLCTR(L)
              QSBDLDY(LN ,NX)=SVB(LN )*QSBDLDP(L)*VCELLCTR(L)
            ENDIF
            IF(UCELLCTR(L).LT.0.0.AND.VCELLCTR(L).LT.0.0)THEN
              QSBDLDX(L  ,NX)=SUB(L  )*QSBDLDP(L)*UCELLCTR(L)
              QSBDLDY(L  ,NX)=SVB(L  )*QSBDLDP(L)*VCELLCTR(L)
            ENDIF
          ENDIF
        ENDDO
      ENDIF
C
C **  CALCULATE CELL FACE TRANSPORT RATES BY DOWN WIND PROJECTION
C **  WITH CORNER EFFECTS CORRECTION
C
      IF(ISBLFUC.EQ.1)THEN
        DO L=2,LA
          QSBDLDOT(L,NX)=0.
          QSBDLDIN(L,NX)=0.
          IF(LMASKDRY(L))THEN
            LN=LNC(L)
            IF(UCELLCTR(L).GE.0.0.AND.VCELLCTR(L).GE.0.0)THEN
              UCELLCTRM=SUB(LEAST(L))*ABS(UCELLCTR(L))
              VCELLCTRM=SVB(LN )*ABS(VCELLCTR(L))
              QSBDLDX(LEAST(L),NX)=SUB(LEAST(L))*QSBDLDP(L)*UCELLCTR(L)
              QSBDLDY(LN ,NX)=SVB(LN )*QSBDLDP(L)*VCELLCTR(L)
              IF(UCELLCTRM.LT.1.0E-9)THEN
                QSBDLDY(LN ,NX)=SVB(LN )*SIGN(QSBDLDP(L),VCELLCTR(L))
              ENDIF
              IF(VCELLCTRM.LT.1.0E-9)THEN
                QSBDLDX(LEAST(L),NX)=SUB(LEAST(L))*SIGN(QSBDLDP(L),UCELLCTR(L))
              ENDIF
            ENDIF
            IF(UCELLCTR(L).GE.0.0.AND.VCELLCTR(L).LT.0.0)THEN
              UCELLCTRM=SUB(LEAST(L))*ABS(UCELLCTR(L))
              VCELLCTRM=SVB(L  )*ABS(VCELLCTR(L))
              QSBDLDX(LEAST(L),NX)=SUB(LEAST(L))*QSBDLDP(L)*UCELLCTR(L)
              QSBDLDY(L  ,NX)=SVB(L  )*QSBDLDP(L)*VCELLCTR(L)
              IF(UCELLCTRM.LT.1.0E-9)THEN
                QSBDLDY(L  ,NX)=SVB(L  )*SIGN(QSBDLDP(L),VCELLCTR(L))
              ENDIF
              IF(VCELLCTRM.LT.1.0E-9)THEN
                QSBDLDX(LEAST(L),NX)=SUB(LEAST(L))*SIGN(QSBDLDP(L),UCELLCTR(L))
              ENDIF
            ENDIF
            IF(UCELLCTR(L).LT.0.0.AND.VCELLCTR(L).GE.0.0)THEN
              UCELLCTRM=SUB(L  )*ABS(UCELLCTR(L))
              VCELLCTRM=SVB(LN )*ABS(VCELLCTR(L))
              QSBDLDX(L  ,NX)=SUB(L  )*QSBDLDP(L)*UCELLCTR(L)
              QSBDLDY(LN ,NX)=SVB(LN )*QSBDLDP(L)*VCELLCTR(L)
              IF(UCELLCTRM.LT.1.0E-9)THEN
                QSBDLDY(LN ,NX)=SVB(LN )*SIGN(QSBDLDP(L),VCELLCTR(L))
              ENDIF
              IF(VCELLCTRM.LT.1.0E-9)THEN
                QSBDLDX(L  ,NX)=SUB(L  )*SIGN(QSBDLDP(L),UCELLCTR(L))
              ENDIF
            ENDIF
            IF(UCELLCTR(L).LT.0.0.AND.VCELLCTR(L).LT.0.0)THEN
              UCELLCTRM=SUB(L  )*ABS(UCELLCTR(L))
              VCELLCTRM=SVB(L  )*ABS(VCELLCTR(L))
              QSBDLDX(L  ,NX)=SUB(L  )*QSBDLDP(L)*UCELLCTR(L)
              QSBDLDY(L  ,NX)=SVB(L  )*QSBDLDP(L)*VCELLCTR(L)
              IF(UCELLCTRM.LT.1.0E-9)THEN
                QSBDLDY(L  ,NX)=SVB(L  )*SIGN(QSBDLDP(L),VCELLCTR(L))
              ENDIF
              IF(VCELLCTRM.LT.1.0E-9)THEN
                QSBDLDX(L  ,NX)=SUB(L  )*SIGN(QSBDLDP(L),UCELLCTR(L))
              ENDIF
            ENDIF
          ENDIF
        ENDDO
      ENDIF
C
C **  CALCULATE CELL FACE TRANSPORT RATES BY AVERAGING
C **  VECTOR COMPONENTS FROM CELL CENTERS TO FACES
C
      IF(ISBLFUC.EQ.2)THEN
        DO L=2,LA
          QSBDLDOT(L,NX)=0.
          QSBDLDIN(L,NX)=0.
          LS=LSC(L)
          QSBDLDX(L,NX)=0.5*SUB(L)*(QSBDLDP(L)*UCELLCTR(L)
     &        +QSBDLDP(LWEST(L))*UCELLCTR(LEAST(L)))
          QSBDLDY(L,NX)=0.5*SVB(L)*(QSBDLDP(L)*VCELLCTR(L)
     &        +QSBDLDP(LS )*UCELLCTR(LS ))
        ENDDO
      ENDIF
C
C **  CONVERT TRANSPORT VECTORS TO FACE VECTORS
C
      DO L=2,LA
        IF(LMASKDRY(L))THEN
          QSBDLDX(L,NX)=SUB(L)*DYU(L)*QSBDLDX(L,NX)
          QSBDLDY(L,NX)=SVB(L)*DXV(L)*QSBDLDY(L,NX)
        ENDIF
      ENDDO
C
C **  ELIMINATE BEDLOAD TRANSPORT UP ADVERSE SLOPES IN DIRECTION OF FLOW
C
      IF(BLBSNT.GT.0.0)THEN
        DO L=2,LA
          IF(LMASKDRY(L))THEN
            IF(QSBDLDX(L,NX).GT.0.0)THEN
              SLOPE=(BELV(L)-BELV(LWEST(L)))*DXIU(L)
              IF(SLOPE.GT.BLBSNT) QSBDLDX(L,NX)=0.0
            ENDIF
            IF(QSBDLDX(L,NX).LT.0.0)THEN
              SLOPE=(BELV(LWEST(L))-BELV(L))*DXIU(L)
              IF(SLOPE.GT.BLBSNT) QSBDLDX(L,NX)=0.0
            ENDIF
            IF(QSBDLDY(L,NX).GT.0.0)THEN
              SLOPE=(BELV(L)-BELV(LSC(L)))*DYIV(L)
              IF(SLOPE.GT.BLBSNT) QSBDLDY(L,NX)=0.0
            ENDIF
            IF(QSBDLDY(L,NX).LT.0.0)THEN
              SLOPE=(BELV(LSC(L))-BELV(L))*DYIV(L)
              IF(SLOPE.GT.BLBSNT) QSBDLDY(L,NX)=0.0
            ENDIF
          ENDIF
        ENDDO
      ENDIF
C
C **  INSERT OUTFLOW OR RECIRCULATION BOUNDARY CONDITION FOR BED
C **  BED LOAD TRANSPORT
C     HAMRICK FIXED TO ADD MULTIPLICATION BY WIDTH OF OUT AND INFLOW SEC
C     IN 0819 CODE PATCH
C
      IF(NSBDLDBC.GT.0) THEN
        QSBLLDXY=0.0
        DO NSB=1,NSBDLDBC
          LUTMP=LSBLBCU(NSB)
          LDTMP=LSBLBCD(NSB)
          IF(LDTMP.GT.0) THEN
C           OUTFLOW ON POSITIVE X FACE RECIRCULATED TO NEGATIVE X FACE
            IF(ISDBLDIR(NSB).EQ.1)THEN
	        IF(UCELLCTR(LUTMP).GT.0.0)THEN
                QSBDLDOT(LUTMP,NX)=
     &                DYP(LUTMP)*QSBDLDP(LUTMP)*UCELLCTR(LUTMP)
                QSBDLDIN(LDTMP,NX)=QSBDLDOT(LUTMP,NX)
              ENDIF
            ENDIF
C           OUTFLOW ON NEGATIVE X FACE RECIRCULATED TO POSITIVE X FACE
            IF(ISDBLDIR(NSB).EQ.-1)THEN
	        IF(UCELLCTR(LUTMP).LT.0.0)THEN
                QSBDLDOT(LUTMP,NX)=
     &                -DYP(LUTMP)*QSBDLDP(LUTMP)*UCELLCTR(LUTMP)
                QSBDLDIN(LDTMP,NX)=QSBDLDOT(LUTMP,NX)
              ENDIF
            ENDIF
C           OUTFLOW ON POSITIVE Y FACE RECIRCULATED TO NEGATIVE Y FACE
            IF(ISDBLDIR(NSB).EQ.2)THEN
	        IF(VCELLCTR(LUTMP).GT.0.0)THEN
                QSBDLDOT(LUTMP,NX)=
     &                DXP(LUTMP)*QSBDLDP(LUTMP)*VCELLCTR(LUTMP)
                QSBDLDIN(LDTMP,NX)=QSBDLDOT(LUTMP,NX)
              ENDIF
            ENDIF
C           OUTFLOW ON NEGATIVE Y FACE RECIRCULATED TO POSITIVE Y FACE
            IF(ISDBLDIR(NSB).EQ.-2)THEN
	        IF(VCELLCTR(LUTMP).LT.0.0)THEN
                QSBDLDOT(LUTMP,NX)=
     &                -DXP(LUTMP)*QSBDLDP(LUTMP)*VCELLCTR(LUTMP)
                QSBDLDIN(LDTMP,NX)=QSBDLDOT(LUTMP,NX)
              ENDIF
            ENDIF
          ELSE
C           OUTFLOW ON POSITIVE X FACE
            IF(ISDBLDIR(NSB).EQ.1)THEN
	        IF(UCELLCTR(LUTMP).GT.0.0)THEN
                QSBDLDOT(LUTMP,NX)=
     &                DYP(LUTMP)*QSBDLDP(LUTMP)*UCELLCTR(LUTMP)
              ENDIF
            ENDIF
C           OUTFLOW ON NEGATIVE X FACE
            IF(ISDBLDIR(NSB).EQ.-1)THEN
	        IF(UCELLCTR(LUTMP).LT.0.0)THEN
                QSBDLDOT(LUTMP,NX)=
     &                -DYP(LUTMP)*QSBDLDP(LUTMP)*UCELLCTR(LUTMP)
              ENDIF
            ENDIF
C           OUTFLOW ON POSITIVE X FACE
            IF(ISDBLDIR(NSB).EQ.2)THEN
	        IF(VCELLCTR(LUTMP).GT.0.0)THEN
                QSBDLDOT(LUTMP,NX)=
     &                DXP(LUTMP)*QSBDLDP(LUTMP)*VCELLCTR(LUTMP)
              ENDIF
            ENDIF
C           OUTFLOW ON NEGATIVE Y FACE
            IF(ISDBLDIR(NSB).EQ.-2)THEN
	        IF(VCELLCTR(LUTMP).LT.0.0)THEN
                QSBDLDOT(LUTMP,NX)=
     &                -DXP(LUTMP)*QSBDLDP(LUTMP)*VCELLCTR(LUTMP)
              ENDIF
            ENDIF
          ENDIF
        ENDDO
      ENDIF
C
C **  LIMIT OUTGOING FLUXES IN EACH CELL
C
      DO L=2,LA
        IF(LMASKDRY(L))THEN
          LN=LNC(L)
          IF(UCELLCTR(L).GE.0.0.AND.VCELLCTR(L).GE.0.0)THEN
            SNDFBL(L,NX)=DXYIP(L)*(QSBDLDX(LEAST(L),NX)+QSBDLDY(LN,NX)
     &          +QSBDLDOT(L,NX))
            ASNDFBL=ABS(SNDFBL(L,NX))
            SNDBTMP=SNDB(L,KBT(L),NX)-DELT*SNDFBL(L,NX)
            IF(SNDBTMP.LT.0.0.AND.ASNDFBL.GT.0.0)THEN
              SNDFBLM=0.5*SNDB(L,KBT(L),NX)/DELT
              FLUXFAC=SNDFBLM/SNDFBL(L,NX)
              QSBDLDX(LEAST(L),NX)=FLUXFAC*QSBDLDX(LEAST(L),NX)
              QSBDLDY(LN ,NX)=FLUXFAC*QSBDLDY(LN ,NX)
              QSBDLDOT(L ,NX)=FLUXFAC*QSBDLDOT(L ,NX)
            ENDIF
          ENDIF
          IF(UCELLCTR(L).GE.0.0.AND.VCELLCTR(L).LT.0.0)THEN
            SNDFBL(L,NX)=DXYIP(L)*(-QSBDLDY(L,NX)+QSBDLDX(LEAST(L),NX)
     &          +QSBDLDOT(L,NX))
            ASNDFBL=ABS(SNDFBL(L,NX))
            SNDBTMP=SNDB(L,KBT(L),NX)-DELT*SNDFBL(L,NX)
            IF(SNDBTMP.LT.0.0.AND.ASNDFBL.GT.0.0)THEN
              SNDFBLM=0.5*SNDB(L,KBT(L),NX)/DELT
              FLUXFAC=SNDFBLM/SNDFBL(L,NX)
              QSBDLDX(LEAST(L),NX)=FLUXFAC*QSBDLDX(LEAST(L),NX)
              QSBDLDY(L  ,NX)=FLUXFAC*QSBDLDY(L  ,NX)
              QSBDLDOT(L ,NX)=FLUXFAC*QSBDLDOT(L ,NX)
            ENDIF
          ENDIF
          IF(UCELLCTR(L).LT.0.0.AND.VCELLCTR(L).GE.0.0)THEN
            SNDFBL(L,NX)=DXYIP(L)*(-QSBDLDX(L,NX)+QSBDLDY(LN,NX)
     &          +QSBDLDOT(L,NX))
            ASNDFBL=ABS(SNDFBL(L,NX))
            SNDBTMP=SNDB(L,KBT(L),NX)-DELT*SNDFBL(L,NX)
            IF(SNDBTMP.LT.0.0.AND.ASNDFBL.GT.0.0)THEN
              SNDFBLM=0.5*SNDB(L,KBT(L),NX)/DELT
              FLUXFAC=SNDFBLM/SNDFBL(L,NX)
              QSBDLDX(L ,NX)=FLUXFAC*QSBDLDX(L ,NX)
              QSBDLDY(LN,NX)=FLUXFAC*QSBDLDY(LN,NX)
              QSBDLDOT(L ,NX)=FLUXFAC*QSBDLDOT(L ,NX)
            ENDIF
          ENDIF
          IF(UCELLCTR(L).LT.0.0.AND.VCELLCTR(L).LT.0.0)THEN
            SNDFBL(L,NX)=DXYIP(L)*(-QSBDLDX(L,NX)-QSBDLDY(L,NX)
     &          +QSBDLDOT(L,NX))
            ASNDFBL=ABS(SNDFBL(L,NX))
            SNDBTMP=SNDB(L,KBT(L),NX)-DELT*SNDFBL(L,NX)
            IF(SNDBTMP.LT.0.0.AND.ASNDFBL.GT.0.0)THEN
              SNDFBLM=0.5*SNDB(L,KBT(L),NX)/DELT
              FLUXFAC=SNDFBLM/SNDFBL(L,NX)
              QSBDLDX(L,NX)=FLUXFAC*QSBDLDX(L,NX)
              QSBDLDY(L,NX)=FLUXFAC*QSBDLDY(L,NX)
              QSBDLDOT(L ,NX)=FLUXFAC*QSBDLDOT(L ,NX)
            ENDIF
          ENDIF
        ENDIF
      ENDDO
C
      IF(NSBDLDBC.GT.0) THEN
        DO NSB=1,NSBDLDBC
          LUTMP=LSBLBCU(NSB)
          LDTMP=LSBLBCD(NSB)
          IF(LDTMP.GT.0) THEN
            QSBDLDOT(LUTMP,NX)=QSBDLDIN(LDTMP,NX)
          ENDIF
        ENDDO
      ENDIF
C
C **  CALCULATE EQUIVALENT CONCENTRATIONS
C
      DO L=2,LA
        LN=LNC(L)
        CQBEDLOADX(L,NX)=0.0
        CQBEDLOADY(L,NX)=0.0
        IF(LMASKDRY(L))THEN
          UVARTMP=0.5*(RSSBCW(L)*U(L,1)+RSSBCE(L)*U(LEAST(L),1))
          VVARTMP=0.5*(RSSBCS(L)*V(L,1)+RSSBCN(L)*V(LN ,1))
          VELMAG=SQRT(UVARTMP*UVARTMP+VVARTMP*VVARTMP)
          IF(VELMAG.GT.0.0) THEN
            CQBEDLOADX(L,NX)=QSBDLDP(L)/(HP(L)*VELMAG)
            CQBEDLOADY(L,NX)=0.
          ENDIF
        ENDIF
      ENDDO
C
C **  INSERT OUTFLOW OR RECIRCULATION BOUNDARY CONDITION FOR BED
C **  LOAD TRANSPORT
C
      QSBLLDXY=0.0
      IF(NSBDLDBC.GT.0) THEN
        DO NSB=1,NSBDLDBC
          LUTMP=LSBLBCU(NSB)
          LDTMP=LSBLBCD(NSB)
          IF(LDTMP.EQ.0) THEN
            QSBLLDXY=QSBLLDXY+QSBDLDOT(LUTMP,NX)
          ENDIF
        ENDDO
      ENDIF
C
C **  CALCULATE MASS PER UNIT AREA CHANGE IN BED CONCENTRATION DUE TO
C **  TO NET BED LOAD
C
      SNDFBLTOT=0.0
      DO L=2,LA
        IF(LMASKDRY(L))THEN
          LN=LNC(L)
          SNDFBL(L,NX)=DXYIP(L)*(QSBDLDX(LEAST(L),NX)
     &        -QSBDLDX(L,NX)+QSBDLDY(LN,NX)-QSBDLDY(L,NX)
     &        +QSBDLDOT(L,NX)-QSBDLDIN(L,NX))
          SNDFBLTOT=SNDFBLTOT+DXYP(L)*SNDFBL(L,NX)
        ENDIF
      ENDDO
 8999 FORMAT(' BL ',3I5,5E14.5)
 8862 FORMAT(' SNDFBLTOT,QSBLLDXY',3I5,5E14.5)
      RETURN
      END


!***********************************************************************
!                                                                      *
      SUBROUTINE SPME(I, J, HCOUL, HBAB, HMAG)
!                                                                      *
!   This routine calculates the reduced matrix elements for pair I,J   *
!   in either Coulomb/Babuskin gauge or for magnetic case.             *
!                                                                      *
!   These are defined in the  Brink and Satchler sense --- i.e. com-   *
!   patible with Pyper et al.'s MCT paper but not with Grant's radi-   *
!   ative transitions paper.                                           *
!                                                                      *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  14:05:40   1/ 6/07
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE bess_C
      USE biorb_C
      USE debug_C
      USE def_C
      USE grid_C
      USE orb_C
      USE osc_C
      USE tatb_C
      USE wave_C
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE clrx_I
      USE quad_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER, INTENT(IN) :: I,J
      REAL(DOUBLE), INTENT(OUT) :: HCOUL, HBAB, HMAG
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: NKJI, NKJJ, IPJ, NAKI, NAKJ, II, LP, LM
      REAL(DOUBLE) :: EPS, HGAUGE, TJI, TJJ, FACT, FORM, FL, FLP, DFKI, DFKJ, &
         CLP, CLM, CIPLP, CIMLP, CIPLM, CIMLM, VALUE, CJL, CIP, TAROM, ESTHER, &
         TEKEL, PERES, TAMAR, ENOCH, SETH, SHEM, DARIUS, CYRUS, DANIEL, BOAZ, &
         ESAU, AARON, GIMEL
!-----------------------------------------------

!
      EPS = 1.0D-10
!
      IF (LDBPR(12) .OR. LDBPR(13) .OR. LDBPR(14) .OR. LDBPR(15)) WRITE (99, &
         303) I, J
!
      HMAG = 0.0D00
      HCOUL = 0.0D00
      HGAUGE = 0.0D00
      HBAB = 0.0D00
!
!  Evaluate factor multiplying Mbar(a,b)
!
      NKJI = NKJ(I)
      NKJJ = NKJ(J)
      TJI = DBLE(NKJI)
      TJJ = DBLE(NKJJ)
      FACT = 1.0D00
      IPJ = (NKJI + 1)/2 + NKJJ
      IF (MOD(IPJ,2) /= 0) FACT = -FACT
      NAKI = NAK(I)
      NAKJ = NAK(J)
      FORM = FACT*SQRT(TJJ + 1.0D00)*CLRX(NAKJ,LK,NAKI)
      FL = DBLE(LK)
      FLP = FL + 1.0D00
      DFKI = DBLE(NAKI)
      DFKJ = DBLE(NAKJ)
!
      MTP = MIN(MFII(NNII(I)),MFFF(NNFF(J)))
!
      IF (KK == 0) THEN
!
         IF (ABS(FORM) > EPS) THEN
!
!  To pick the right initial and final state radial functions convert
!  from orbital order of the merged list to the orbital orders of the
!  initial and final state lists, respectively.
!  N(I) -> NNII(I), N(J) -> NNFF(J)
!
            DO II = 1, N
               TB(II) = PFII(II,NNII(I))*QFFF(II,NNFF(J)) + QFII(II,NNII(I))*&
                  PFFF(II,NNFF(J))
               TC(II) = PFII(II,NNII(I))*QFFF(II,NNFF(J)) - QFII(II,NNII(I))*&
                  PFFF(II,NNFF(J))
! zou
               TB(II) = TB(II)*C/CVAC
               TC(II) = TC(II)*C/CVAC
               TD(II) = PFII(II,NNII(I))*PFFF(II,NNFF(J)) + QFII(II,NNII(I))*&
                  QFFF(II,NNFF(J))*(C/CVAC)**2
!           TD(II) = PFII(II,NNII(I))*PFFF(II,NNFF(J)) +
!    :               QFII(II,NNII(I))*QFFF(II,NNFF(J))
! zou
            END DO
            LP = LK + 1
            LM = LK - 1
!
!  Calculate Coulomb coefficients
!
            CLP = SQRT(FL/FLP)
            CLM = -SQRT(FLP/FL)
            CIPLP = CLP*(DFKI - DFKJ)
            CIMLP = CLP*FLP
            CIPLM = CLM*(DFKI - DFKJ)
            CIMLM = -CLM*FL
!
!  Tabulate Coulomb integrand
!
            TA(1) = 0.0D00
            TA(2:MTP) = RP(2:MTP)*(BJ(2:MTP,3)*(CIPLP*TB(2:MTP)+CIMLP*TC(2:MTP)&
               )+BJ(2:MTP,1)*(CIPLM*TB(2:MTP)+CIMLM*TC(2:MTP)))
            CALL QUAD (VALUE)
            HCOUL = FORM*VALUE
!
!  Calculate gauge dependent coefficients
!
            CJL = -(FL + FLP)
            CIP = DFKI - DFKJ
!
!  Tabulate gauge dependent integrand
!
            TA(1) = 0.0D00
            TA(2:MTP) = RP(2:MTP)*(BJ(2:MTP,2)*(CJL*TD(2:MTP))+BJ(2:MTP,3)*(CIP&
               *TB(2:MTP)+FLP*TC(2:MTP))+BJ(2:MTP,1)*(CIP*TB(2:MTP)-FL*TC(2:MTP&
               )))
!
!  Print gauge dependent integrand if requested
!
            IF (LDBPR(13)) WRITE (99, 300) I, J, (II,TA(II),II=1,N)
            CALL QUAD (VALUE)
            HGAUGE = FORM*VALUE
            HBAB = HCOUL + SQRT(FLP/FL)*HGAUGE
!
!  Print Coulomb and gauge dependent integrals if requested
!
            IF (LDBPR(12)) WRITE (99, 301) I, J, HCOUL, HGAUGE, HBAB
!
!  Calculate the contibutions from various terms if requested
!
            IF (LDBPR(14) .OR. LDBPR(15)) THEN
!
               TA(1) = 0.0D00
               TA(2:MTP) = TD(2:MTP)*BJ(2:MTP,2)*RP(2:MTP)
               IF (LDBPR(15)) WRITE (99, 304) (II,TA(II),II=1,N)
               CALL QUAD (TAROM)
               IF (LDBPR(14)) WRITE (99, 305) TAROM
               ESTHER = -CJL
               IF (LDBPR(14)) WRITE (99, 306) ESTHER
               TEKEL = ESTHER*TAROM
               IF (LDBPR(14)) WRITE (99, 307) TEKEL
!
               TA(1) = 0.0D00
               TA(2:MTP) = -TB(2:MTP)*BJ(2:MTP,3)*RP(2:MTP)
               IF (LDBPR(15)) WRITE (99, 304) (II,TA(II),II=1,N)
               CALL QUAD (PERES)
               IF (LDBPR(14)) THEN
                  WRITE (99, 308) PERES
                  WRITE (99, 306) CIP
               ENDIF
               TAMAR = CIP*PERES
               IF (LDBPR(14)) WRITE (99, 307) TAMAR
!
               TA(1) = 0.0D00
               TA(2:MTP) = -TB(2:MTP)*BJ(2:MTP,1)*RP(2:MTP)
               IF (LDBPR(15)) WRITE (99, 304) (II,TA(II),II=1,N)
               CALL QUAD (ENOCH)
               IF (LDBPR(14)) THEN
                  WRITE (99, 309) ENOCH
                  WRITE (99, 306) CIP
               ENDIF
               SETH = CIP*ENOCH
               IF (LDBPR(14)) WRITE (99, 307) SETH
!
               TA(1) = 0.0D00
               TA(2:MTP) = BJ(2:MTP,1)*TC(2:MTP)*RP(2:MTP)
               IF (LDBPR(15)) WRITE (99, 304) (II,TA(II),II=1,N)
               CALL QUAD (SHEM)
               IF (LDBPR(14)) THEN
                  WRITE (99, 310) SHEM
                  WRITE (99, 306) FL
               ENDIF
               DARIUS = FL*SHEM
               IF (LDBPR(14)) WRITE (99, 307) DARIUS
!
               TA(1) = 0.0D00
               TA(2:MTP) = -BJ(2:MTP,3)*TC(2:MTP)*RP(2:MTP)
               IF (LDBPR(15)) WRITE (99, 304) (II,TA(II),II=1,N)
               CALL QUAD (CYRUS)
               IF (LDBPR(14)) WRITE (99, 311) CYRUS
               DANIEL = FLP
               IF (LDBPR(14)) WRITE (99, 306) DANIEL
               BOAZ = DANIEL*CYRUS
               IF (LDBPR(14)) WRITE (99, 307) BOAZ
!
               ESAU = TAMAR + SETH + DARIUS + BOAZ
               IF (LDBPR(14)) WRITE (99, 312) ESAU, TEKEL
               AARON = ESAU + TEKEL
               GIMEL = -VALUE
               IF (LDBPR(14)) THEN
                  WRITE (99, 313) AARON, GIMEL
                  WRITE (99, 314)
                  WRITE (99, 315) PERES, CIP, TAMAR
                  WRITE (99, 316) ENOCH, CIP, SETH
                  WRITE (99, 317) SHEM, FL, DARIUS
                  WRITE (99, 318) CYRUS, DANIEL, BOAZ
                  WRITE (99, 319) ESAU
                  WRITE (99, 320) TAROM, ESTHER, TEKEL
                  WRITE (99, 321) GIMEL, AARON
               ENDIF
!
            ENDIF
!
         ENDIF
!
         IF (LDBPR(12)) WRITE (99, 301) I, J, HCOUL, HGAUGE, HBAB
!
      ELSE
!
!   Tabulate magnetic integrand
!
         IF (ABS(FORM) > EPS) THEN
!
            TA(1) = 0.0D00
            DO II = 2, MTP
!zou
               TA(II) = (PFII(II,NNII(I))*QFFF(II,NNFF(J))+QFII(II,NNII(I))*&
                  PFFF(II,NNFF(J)))*BJ(II,2)*RP(II)*C/CVAC
!           TA(II) =  (PFII(II,NNII(I))*QFFF(II,NNFF(J)) +
!    :      QFII(II,NNII(I))*PFFF(II,NNFF(J)))*BJ(II,2)*RP(II)
!zou
            END DO
            CALL QUAD (VALUE)
            IF (LDBPR(14)) WRITE (99, 322) VALUE
            HMAG = -VALUE*(FL + FLP)*(DFKI + DFKJ)*FORM/SQRT(FL*FLP)
!
         ENDIF
!
         IF (LDBPR(12)) WRITE (99, 302) HMAG
!
      ENDIF
!
      RETURN
!
  300 FORMAT(/,1X,20X,'Local form of gauge dependent integral for',' orbitals',&
         I3,' and',I3,/,/,100(1X,7(I3,2X,1P,D11.3,2X),/))
  301 FORMAT(/,1X,'Orbital pair (',I2,',',I2,') integrals:','Coul. gauge ',1P,D&
         13.3,3X,'Gauge contribution',D13.3,3X,'Bab.gauge',D13.3)
  302 FORMAT(/,1X,'Magnetic single particle matrix element ',1P,D13.3)
  303 FORMAT(/,1X,30('+'),'   SPME called for orbitals ',I4,'   and',I4,3X,30(&
         '+'))
  304 FORMAT(/,100(1X,7(I3,2X,1P,D11.3,2X),/),/)
  305 FORMAT(/,' Integral J(L)  =  ',1P,D28.12)
  306 FORMAT(' Factor multiplying this ',1P,D20.12)
  307 FORMAT(' Resultant contribution  ',1P,D20.12,/)
  308 FORMAT(' I + (L+1) integral  = ',1P,D24.12)
  309 FORMAT(' I + (L-1) integral  = ',1P,D24.12)
  310 FORMAT(' I - (L-1) integral  = ',1P,D24.12)
  311 FORMAT(' I - (L+1) integral  = ',1P,D24.12)
  312 FORMAT(' These last four add up to ',1P,D20.12,&
         '    compared to the first which is ',D20.12)
  313 FORMAT(' These all add up to ',1P,D20.12,' which should equal ',D20.12)
  314 FORMAT(/,18X,'Integral',11X,'Coefficient',8X,'Contribution')
  315 FORMAT(' I + (L+1)',1P,3D20.10)
  316 FORMAT(' I + (L-1)',1P,3D20.10)
  317 FORMAT(' I - (L-1)',1P,3D20.10)
  318 FORMAT(' I - (L+1)',1P,3D20.10)
  319 FORMAT(54X,16('-'),/,50X,1P,D20.10)
  320 FORMAT(' J (L)',4X,1P,3D20.10)
  321 FORMAT(54X,16('-'),/,' Correct figure',1P,D20.10,15X,D20.10)
  322 FORMAT(' I + (L)  integral',1P,D20.10)
      RETURN
!
      END SUBROUTINE SPME


MODULE m_pbecor2
!---------------------
! slimmed down version of gcor used in pw91 routines, to interpolate
! lsd correlation energy, as given by (10) of
! j. p. perdew and y. wang, phys. rev. b {\bf 45}, 13244 (1992).
! k. burke, may 11, 1996.
!---------------------
CONTAINS
   SUBROUTINE pbecor2( &
      a,a1,b1,b2,b3,b4,rtrs, &
      gg,ggrs)
      IMPLICIT NONE

      REAL, INTENT (IN)  :: a,a1,b1,b2,b3,b4,rtrs
      REAL, INTENT (OUT) :: gg,ggrs

      REAL :: q0,q1,q2,q3
!     ..
      q0 = -2.e0*a* (1.e0+a1*rtrs*rtrs)
      q1 = 2.e0*a*rtrs* (b1+rtrs* (b2+rtrs* (b3+b4*rtrs)))
      q2 = log(1.e0+1.e0/q1)
      gg = q0*q2
      q3 = a* (b1/rtrs+2.e0*b2+rtrs* (3.e0*b3+4.e0*b4*rtrs))
      ggrs = -2.e0*a*a1*q2 - q0*q3/ (q1* (1.e0+q1))

   END SUBROUTINE pbecor2
END MODULE m_pbecor2


      DOUBLE PRECISION FUNCTION DKI(I,J,K,L,M,N,IP,IQ,R,Z)
      DOUBLE PRECISION AI, R, Z, RD, ABS1, AMKL, AKKL, AMMN, AKMN, ARR
      DOUBLE PRECISION DKINT, DK89, DK100, DK211
      DOUBLE PRECISION XX, AMM
      DIMENSION  R(1) , Z(1)
      IF (R(I) .EQ. R(J)) GO TO 20
      RD = R(J)
      IF (R(J) .EQ. 0.0D0) RD = R(I)
      ABS1 =  DABS( (R(I) - R(J)) / RD )
      IF (ABS1 .LE. 0.1D-3) GO TO 20
      AMKL = (R(L)*Z(K)-R(K)*Z(L)) / (R(L)-R(K))
      AKKL = (Z(L)-Z(K)) / (R(L)-R(K))
      AMMN = (R(N)*Z(M)-R(M)*Z(N)) / (R(N)-R(M))
      AKMN = (Z(N)-Z(M)) / (R(N)-R(M))
      IF (AKMN .NE. AKKL .OR. AMMN .NE. AMKL) GO TO 30
   20 AI = 0.0D0
      GO TO  510
   30 CONTINUE
      ISS = IABS(IP)
      IRR = IABS(IQ)
      IF (IQ + 1) 100,300,50
   50 CONTINUE
      MM = IP
      NN = IQ + 1
      AI =DKINT(I,J,AMMN,AKMN,MM,NN,R,Z) -DKINT(I,J,AMKL,AKKL,MM,NN,R,Z)
      GO TO  510
  100 CONTINUE
      IF (IP .LT. 0) GO TO 200
      MM = IP
      NN = IRR - 1
      AI =DK89(I,AMKL,AKKL,MM,NN,R)  -  DK89(I,AMMN,AKMN,MM,NN,R)
     1   -DK89(J,AMKL,AKKL,MM,NN,R)  +  DK89(J,AMMN,AKMN,MM,NN,R)
      ARR = IRR
      AI = (1.0D0 / (1.0D0 - ARR)) * AI
      GO TO  510
  200 CONTINUE
      MM = ISS
      NN = IRR - 1
      AI =DK100(I,AMKL,AKKL,MM,NN,R) -DK100(I,AMMN,AKMN,MM,NN,R)
     1   -DK100(J,AMKL,AKKL,MM,NN,R) +DK100(J,AMMN,AKMN,MM,NN,R)
      ARR = IRR
      AI = (1.0D0 / (1.0D0 - ARR)) * AI
      GO TO  510
  300 CONTINUE
      IF (IP + 1) 400,500,301
  301 CONTINUE
      MM = IP + 1
      AMM=MM
      XX=R(I)**MM/AMM
      AI=   (
     *  +XX*DLOG(DABS(AMKL+AKKL*R(I)))-AKKL/AMM*DK89(I,AMKL,AKKL,MM,1,R)
     *  -XX*DLOG(DABS(AMMN+AKMN*R(I)))+AKMN/AMM*DK89(I,AMMN,AKMN,MM,1,R)
     *      )
      XX=R(J)**MM/AMM
      AI=   (
     *  -XX*DLOG(DABS(AMKL+AKKL*R(J)))+AKKL/AMM*DK89(J,AMKL,AKKL,MM,1,R)
     *  +XX*DLOG(DABS(AMMN+AKMN*R(J)))-AKMN/AMM*DK89(J,AMMN,AKMN,MM,1,R)
     *      ) + AI
      GO TO  510
  400 CONTINUE
      MM = ISS - 1
      AMM=MM
      XX=AMM*R(I)**MM
      AI=   (
     * -DLOG(DABS(AMKL+AKKL*R(I)))/XX+AKKL/AMM*DK100(I,AMKL,AKKL,MM,1,R)
     * +DLOG(DABS(AMMN+AKMN*R(I)))/XX-AKMN/AMM*DK100(I,AMMN,AKMN,MM,1,R)
     *      )
      XX=AMM*R(J)**M
      AI=   (
     * +DLOG(DABS(AMKL+AKKL*R(J)))/XX-AKKL/AMM*DK100(J,AMKL,AKKL,MM,1,R)
     * -DLOG(DABS(AMMN+AKMN*R(J)))/XX+AKMN/AMM*DK100(J,AMMN,AKMN,MM,1,R)
     *      ) + AI
      GO TO  510
  500 CONTINUE
      AI = DK211(I,AMKL,AKKL,R) - DK211(I,AMMN,AKMN,R)
     1   - DK211(J,AMKL,AKKL,R) + DK211(J,AMMN,AKMN,R)
  510 CONTINUE
      DKI = AI
      RETURN
      END