      BLOCK DATA INIDAT
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      PARAMETER (NBB=512)
      PARAMETER(NC1 = 78885)
      PARAMETER (N1D=5000)
      COMMON /PART/ FIRST, KNEW,KTEST
      COMMON  PBUF(NBB,5),Q(NC1),TEMP(2*N1D),TBUF(5,NBB)
      COMMON/POTEN1/ SS(NC1),W(NC1),AX(NC1)
      COMMON/POTEN2/ AX1(NC1),AY(NC1),AY1(NC1)
      COMMON/POTEN3/ AZ(NC1),AZ1(NC1)
      COMMON/CURR/ CX(NC1),CY(NC1),CZ(NC1)
      COMMON/EFIELD/EX(NC1),EY(NC1),EZ(NC1),BX(NC1),BY(NC1),BZ(NC1)
      COMMON/QBK/ QBK(NC1)
C 11-Apr-91 Intergraph; ANSI FORTRAN-77 Changes
      DIMENSION X(NBB),Y(NBB),VX(NBB),VY(NBB),VZ(NBB)
      EQUIVALENCE (X(1),PBUF(1,1)),(Y(1),PBUF(1,2)),(VX(1),PBUF(1,3)),
     *  (VY(1),PBUF(1,4)),(VZ(1),PBUF(1,5))

      COMMON/PARCM/NX,NY,L3,L4,KBND,NX2,NX1,NY1,NY2,IBCDL,IBCDR,
     *   IBCDT,IBCDB,KBR,LSTL,LSTR,NINJL,NINJR,KBNDY,INOP,
     *   XMAX,YMAX,DT,QMULT,WMULT,XLEFT,XRIGHT,
     *   HX,HY,HXI,HYI,VMPX1,VMPY1,
     *   VMPZ1,ELOST,QLOSTL,QLOSTR,QLOSTT,QLOSTB,
     *   YTOP,YBOT,DRINJ,DLINJ,VRINJ,VLINJ,
     *   TRPAR,TLPAR,DTLPAR,DTRPAR,QINJL,QINJR,EINJ
C
      PARAMETER (NYY=514)
      PARAMETER(NNS=25)
      PARAMETER (NDIM=503)
      PARAMETER(NNS1=NNS+1,NNS2=NNS*2)
C
      PARAMETER(NCL=3*NYY)
C
      COMMON/FKICK/XKICK,DXKICK, YK1,YK2,FNKICK,VMPXH,VMPYH,EHEAT
     1 ,VOSC,DELE,DLASER,TWIDTH,TPEAK,XLASER
      COMMON/PARAM/IT,NC,NB,NP,IMPSW,NRAND,KJSMTH,KQSMTH,
     *    KEI,KEE,KSP,NPTIME,
     *    NSP,NPX(NNS),NPY(NNS),NSPEC(NNS),IDNX(NNS1),IDNY(NNS1),
     *    IBCNDL(NNS),IBCNDR(NNS),IBCNDT(NNS),IBCNDB(NNS),
     *    LOADED(NNS),LOSTL(NNS),LOSTR(NNS),INJL(NNS),INJR(NNS)
      COMMON/PARAMR/ PI,T,AA,SINA,SINP,TDLAZ,AMPH,PHAS,VEA,FNK,
     *    TAU,TAU1,TAU2,EXC,EYC,EZC,BXC,BYC,BZC,WSPEC(NNS),QSPEC(NNS),
     *    AYL(NCL),AYR(NCL),AYLD(NCL),AYRD(NCL),
     *    AZL(NCL),AZR(NCL),AZLD(NCL),AZRD(NCL),
     *    VMPX(NNS),VMPY(NNS),VMPZ(NNS),
     *    XDRIFT(NNS),YDRIFT(NNS),ZDRIFT(NNS),
     *    XN(NNS2),DENX(NNS2),YN(NNS2),DENY(NNS2),
     *    XLJ(NNS),XRJ(NNS),XTJ(NNS),XBJ(NNS),FEREM,AFRACR,
     *    DINJR(NNS),DINJL(NNS),VINJR(NNS),VINJL(NNS),
     *    TINJR(NNS),TINJL(NNS),IBATCH(NNS)
      COMMON /PARAM1/ EKX(NNS),EKY(NNS),EKZ(NNS),EKJ(NNS),
     *    VLIMA,VLIMB,VXAVGA,VXAVGB,VYAVGA,
     *    VYAVGB,VZAVGA,VZAVGB,TFIN,EFIN,
     *    TDEC(NDIM),EDEC(NDIM,6),ELOSTB,AVPOYN,APOYNT(N1D),
     *    EPOUTR(50),EPOUTL(50),EPOUTB(50),EPOUTT(50),
     *    EPINR(50),EPINL(50),EPINB(50),EPINT(50),
     *    DEP,TEP,EPMAX,KSPLIT,NPTSA,NPTSB,NPLOT,NENRG,NHIST,NFT1,NFT2,
     *    NENRG2,KDIAG,LDEC,NEP
C
      PARAMETER (NNS3=NNS-2)
      DATA PI /3.141592653589793D0/, T /0.D0/, IT /0/
      DATA KNEW /1/, FIRST / 0.D0/, KTEST /0/
C
C     NUMERICAL PARAMETERS
C
      DATA NX /32/,NY /4/,DT /.15D0/,IMPSW /1/,KJSMTH /1/,KQSMTH /1/
      DATA NRAND /-2/, NPTIME /0/
C
C     PHYSICAL PARAMETERS
C
      DATA XMAX /8.D0/, YMAX /1.D0/,KBND /0/,KBNDY/0/,KEI /0/,KEE /1/
C
C     INPUT E.M. WAVE PARAMETERS
C
      DATA AA, SINA, SINP /0.D0,0.D0,1.D0/, AMPH /0.D0/, TDLAZ /10.D0/
      DATA VEA, FNK /0.D0,1.0D0/
C
C     INPUT FOR PARTICLE HEATING
C
      DATA DXKICK,YK1,YK2/0.D0,0.D0,0.D0/
      DATA FNKICK/1.D0/,XKICK/0.D0/,VOSC/0.D0/,TPEAK/0.D0/,TWIDTH/1.D0/
      DATA VMPXH/0.D0/, VMPYH/0.D0/,DELE/0.D0/,DLASER/0.D0/,XLASER/0.D0/
C
C     EXTERNAL FIELD PARAMETERS
C
      DATA EXC, EYC, EZC, BXC, BYC, BZC /6*0.D0/
C
C     PARTICLE PARAMETERS
C
      DATA NSP /1/
      DATA NPX /NNS*120/, NPY /NNS*30/, NSPEC /NNS*0/
     1 QSPEC /-1.D0,1.D0,NNS3*0.D0/, WSPEC /1.D0,100.D0,NNS3*0.D0/,
     1 VMPX   /NNS*.1D0/, VMPY  /NNS*0.D0/, VMPZ   /NNS*0.D0/,
     1 XDRIFT /NNS*0.D0/, YDRIFT/NNS*0.D0/, ZDRIFT /NNS*0.D0/
      DATA IDNX /NNS1*2/, XN /NNS2*0.D0/, DENX /NNS2*1.D0/,
     1     IDNY /NNS1*2/, YN /NNS2*0.D0/, DENY /NNS2*1.D0/
C
C     PARTICLE BOUNDARY CONDITIONS
C
      DATA IBCNDL /NNS*1 /, IBCNDR /NNS*1/,
     1     IBCNDT /NNS*1 /, IBCNDB /NNS*1/,
     1     XLJ    /NNS*0.D0/, XRJ    /NNS*0.D0/,
     1     XTJ    /NNS*0.D0/, XBJ    /NNS*0/
      DATA FEREM /.7D0/, AFRACR /1.D0/
      DATA TAU/0.D0/,TAU1/1.D0/,TAU2/0.D0/
C
C     DIAGNOSTIC PARAMETERS
C
      DATA KSPLIT /2/, VLIMA /1.D0/, VLIMB /.1D0/, NPTSA /1/,  NPTSB /1/
      DATA NPLOT /0/,  NENRG /0/,  NHIST /0/
      DATA NFT1  /1/,  NFT2  /0/
      DATA EPMAX /0.D0/
      DATA TFIN  /0.D0/, EFIN  /0.D0/, NENRG2 /3/
C
C     OTHER INITIALIZED VARIABLES
C
      DATA NEP /50/, TEP /0.D0/
      DATA LDEC, TDEC(1), EDEC(1,1) /3,0.D0,0.D0/
      DATA AVPOYN /0.D0/, EKJ/NNS*0.D0/
      DATA APOYNT /N1D*0.D0/
      DATA EPOUTR, EPOUTL, EPINR, EPINL /200*0.D0/
      DATA EHEAT/0.D0/, EINJ/0/
      DATA ELOSTB /0.D0/, KDIAG /0/
      END

       SUBROUTINE GENPRB
       IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      PARAMETER ( NYY = 514 )
      PARAMETER ( NNS = 25 )
      PARAMETER ( NNS1 = NNS + 1, NNS2 = NNS * 2 )
      PARAMETER ( NCL = 3 * NYY )
      PARAMETER ( N1D = 5000 )
      PARAMETER ( NDIM = 503 )
      COMMON/PARCM/NX,NY,L3,L4,KBND,NX2,NX1,NY1,NY2,IBCDL,IBCDR,
     *   IBCDT,IBCDB,KBR,LSTL,LSTR,NINJL,NINJR,KBNDY,INOP,
     *   XMAX,YMAX,DT,QMULT,WMULT,XLEFT,XRIGHT,
     *   HX,HY,HXI,HYI,VMPX1,VMPY1,
     *   VMPZ1,ELOST,QLOSTL,QLOSTR,QLOSTT,QLOSTB,
     *   YTOP,YBOT,DRINJ,DLINJ,VRINJ,VLINJ,
     *   TRPAR,TLPAR,DTLPAR,DTRPAR,QINJL,QINJR,EINJ
      COMMON/PARAM/IT,NC,NB,NP,IMPSW,NRAND,KJSMTH,KQSMTH,
     *    KEI,KEE,KSP,NPTIME,
     *    NSP,NPX(NNS),NPY(NNS),NSPEC(NNS),IDNX(NNS1),IDNY(NNS1),
     *    IBCNDL(NNS),IBCNDR(NNS),IBCNDT(NNS),IBCNDB(NNS),
     *    LOADED(NNS),LOSTL(NNS),LOSTR(NNS),INJL(NNS),INJR(NNS)
      COMMON/PARAMR/ PI,T,AA,SINA,SINP,TDLAZ,AMPH,PHAS,VEA,FNK,
     *    TAU,TAU1,TAU2,EXC,EYC,EZC,BXC,BYC,BZC,WSPEC(NNS),QSPEC(NNS),
     *    AYL(NCL),AYR(NCL),AYLD(NCL),AYRD(NCL),
     *    AZL(NCL),AZR(NCL),AZLD(NCL),AZRD(NCL),
     *    VMPX(NNS),VMPY(NNS),VMPZ(NNS),
     *    XDRIFT(NNS),YDRIFT(NNS),ZDRIFT(NNS),
     *    XN(NNS2),DENX(NNS2),YN(NNS2),DENY(NNS2),
     *    XLJ(NNS),XRJ(NNS),XTJ(NNS),XBJ(NNS),FEREM,AFRACR,
     *    DINJR(NNS),DINJL(NNS),VINJR(NNS),VINJL(NNS),
     *    TINJR(NNS),TINJL(NNS),IBATCH(NNS)
      COMMON /PARAM1/ EKX(NNS),EKY(NNS),EKZ(NNS),EKJ(NNS),
     *    VLIMA,VLIMB,VXAVGA,VXAVGB,VYAVGA,
     *    VYAVGB,VZAVGA,VZAVGB,TFIN,EFIN,
     *    TDEC(NDIM),EDEC(NDIM,6),ELOSTB,AVPOYN,APOYNT(N1D),
     *    EPOUTR(50),EPOUTL(50),EPOUTB(50),EPOUTT(50),
     *    EPINR(50),EPINL(50),EPINB(50),EPINT(50),
     *    DEP,TEP,EPMAX,KSPLIT,NPTSA,NPTSB,NPLOT,NENRG,NHIST,NFT1,NFT2,
     *    NENRG2,KDIAG,LDEC,NEP
      COMMON /NSTEPS/ NTIMES

      READ(5,*)
      READ(5,*) NTIMES
      READ(5,*)
      READ(5,*) NPX(1), NPY(1)
      READ(5,*)
      READ(5,*) NPLOT
      READ(5,*)
      READ(5,*) NX, NY
      READ(5,*)
      READ(5,*) XMAX, YMAX
C     NPLOT = 10
C     XMAX = 125.0
C     YMAX = 4.0
C     NX = 2500
C     NY = 80
      DT = .03D0
      KBOUND = 0
      NSP = 1
C     NPY(1) = 200
C     NPX(1) = 10000
C USE IMPSW = -1 IF KEE = KEI = 1 OR 0
C     IMPSW = -1
      KEE = 2
      KEI = 2
      VMPX(1) = .1D0
      VMPY(1) = .2D0
      VMPZ(1) = .2D0
      VLIMB = 1.D0
      VLIMA = 1.D0
      QSPEC(1) = -1.D0
      WSPEC(1) = 1.D0
      RETURN
      END
C
      SUBROUTINE INIT
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      PARAMETER ( NBB = 512 )
      PARAMETER( NC1 = 78885)
      PARAMETER ( N1D = 5000 )
      COMMON  PBUF(NBB,5), Q(NC1), TEMP(2*N1D), TBUF(5,NBB)
      COMMON /POTEN1/ SS(NC1), W(NC1), AX(NC1)
      COMMON /POTEN2/ AX1(NC1),AY(NC1),AY1(NC1)
      COMMON /POTEN3/ AZ(NC1),AZ1(NC1)
      COMMON /CURR/ CX(NC1),CY(NC1),CZ(NC1)
      COMMON /EFIELD/EX(NC1),EY(NC1),EZ(NC1),BX(NC1),BY(NC1),BZ(NC1)
      COMMON /QBK/ QBK(NC1)
      DIMENSION X(NBB),Y(NBB),VX(NBB),VY(NBB),VZ(NBB)
      EQUIVALENCE (X(1),PBUF(1,1)), (Y(1),PBUF(1,2)), (VX(1),PBUF(1,3)),
     *  (VY(1),PBUF(1,4)), (VZ(1),PBUF(1,5))

      COMMON/PARCM/NX,NY,L3,L4,KBND,NX2,NX1,NY1,NY2,IBCDL,IBCDR,
     *   IBCDT,IBCDB,KBR,LSTL,LSTR,NINJL,NINJR,KBNDY,INOP,
     *   XMAX,YMAX,DT,QMULT,WMULT,XLEFT,XRIGHT,
     *   HX,HY,HXI,HYI,VMPX1,VMPY1,
     *   VMPZ1,ELOST,QLOSTL,QLOSTR,QLOSTT,QLOSTB,
     *   YTOP,YBOT,DRINJ,DLINJ,VRINJ,VLINJ,
     *   TRPAR,TLPAR,DTLPAR,DTRPAR,QINJL,QINJR,EINJ
C
      PARAMETER (NYY=514)
      PARAMETER (NNS=25)
      PARAMETER (NDIM=503)
      PARAMETER (NNS1=NNS+1, NNS2=NNS*2)
C
      PARAMETER(NCL=3*NYY)
C
      COMMON/FKICK/XKICK,DXKICK, YK1,YK2,FNKICK,VMPXH,VMPYH,EHEAT
     1 ,VOSC,DELE,DLASER,TWIDTH,TPEAK,XLASER
      COMMON/PARAM/IT,NC,NB,NP,IMPSW,NRAND,KJSMTH,KQSMTH,
     *    KEI,KEE,KSP,NPTIME,
     *    NSP,NPX(NNS),NPY(NNS),NSPEC(NNS),IDNX(NNS1),IDNY(NNS1),
     *    IBCNDL(NNS),IBCNDR(NNS),IBCNDT(NNS),IBCNDB(NNS),
     *    LOADED(NNS),LOSTL(NNS),LOSTR(NNS),INJL(NNS),INJR(NNS)
      COMMON/PARAMR/ PI,T,AA,SINA,SINP,TDLAZ,AMPH,PHAS,VEA,FNK,
     *    TAU,TAU1,TAU2,EXC,EYC,EZC,BXC,BYC,BZC,WSPEC(NNS),QSPEC(NNS),
     *    AYL(NCL),AYR(NCL),AYLD(NCL),AYRD(NCL),
     *    AZL(NCL),AZR(NCL),AZLD(NCL),AZRD(NCL),
     *    VMPX(NNS),VMPY(NNS),VMPZ(NNS),
     *    XDRIFT(NNS),YDRIFT(NNS),ZDRIFT(NNS),
     *    XN(NNS2),DENX(NNS2),YN(NNS2),DENY(NNS2),
     *    XLJ(NNS),XRJ(NNS),XTJ(NNS),XBJ(NNS),FEREM,AFRACR,
     *    DINJR(NNS),DINJL(NNS),VINJR(NNS),VINJL(NNS),
     *    TINJR(NNS),TINJL(NNS),IBATCH(NNS)
      COMMON /PARAM1/ EKX(NNS),EKY(NNS),EKZ(NNS),EKJ(NNS),
     *    VLIMA,VLIMB,VXAVGA,VXAVGB,VYAVGA,
     *    VYAVGB,VZAVGA,VZAVGB,TFIN,EFIN,
     *    TDEC(NDIM),EDEC(NDIM,6),ELOSTB,AVPOYN,APOYNT(N1D),
     *    EPOUTR(50),EPOUTL(50),EPOUTB(50),EPOUTT(50),
     *    EPINR(50),EPINL(50),EPINB(50),EPINT(50),
     *    DEP,TEP,EPMAX,KSPLIT,NPTSA,NPTSB,NPLOT,NENRG,NHIST,NFT1,NFT2,
     *    NENRG2,KDIAG,LDEC,NEP
C
      DIMENSION DNX(N1D), DNY(512)
      EQUIVALENCE(DNX,TEMP), (DNY,TEMP(N1D))
      EXTERNAL RANF
c specmod
	DOUBLE PRECISION RRR
	DATA RRR /0.0D0/
C
      NX1=NX+1
      NX2=NX+2
      NY1=NY+1
      NY2=NY+2
      NX2NY2=NX2*NY2
      HX=XMAX/NX
      HY=YMAX/NY
      HXI=1.D0/HX
      HYI=1.D0/HY
      NBUF=1
      LEN=200000
      QLOSTL=0.D0
      QLOSTR=0.D0
      QLOSTB=0.D0
      QLOSTT=0.D0
      IF(NFT2.EQ.0) NFT2=NX
      NFT2=MIN0(NX-NFT1+1,NFT2)
      IF (NENRG.EQ.0) NENRG=NPLOT
      IF (NHIST.EQ.0) NHIST=NPLOT
C
      FKX=2.D0*PI*FNK/XMAX
      PHAS=0.D0
        IF(VOSC.EQ.0) XLASER=0.D0
C
C   SET RANDOM NO. GENRATOR
C
      IF(NRAND.GE.-1) THEN
             ICNT=NRAND
             NRAND=-2
             IF(ICNT.GT.0) THEN
                   DO 10 I=1,ICNT
10                 DUM=RANF(0.0D0)
             ELSE IF(ICNT.LT.0) THEN
                   RR=RANF(-1.0D0)
             ELSE IF(ICNT.EQ.0) THEN
                   DUM=RANF(RRR)
             END IF
      END IF
   40 IF (NSP.LE.0) RETURN
      IT=0
      T=0.D0
      TDEC(1)=0.D0
      LDEC=3
      NP=0
      DO 50 ISP=1,NSP
      IF (VMPZ(ISP).EQ.0.) VMPZ(ISP)=VMPX(ISP)
      IF (VMPY(ISP).EQ.0.) VMPY(ISP)=VMPX(ISP)
      NSPEC(ISP)=MAX0(NSPEC(ISP),NPX(ISP)*NPY(ISP))
   50 NP=NP+NSPEC(ISP)
      WRITE (9,250) NP
      CALL SETB(NP,NSP,NB,5)
      NP1=0
      KSP=0
      QAV=0.D0
      Q1=0.D0
 60   CONTINUE
      Q1=0.D0
      IF (NP1.EQ.0) THEN
           KSP=KSP+1
           IF (KSP.GT.NSP) GO TO 180
           IF (KSP.GT.10) STOP
            IF(QSPEC(KSP).LT.0.) KEJ=KEE
            IF(QSPEC(KSP).GT.0.) KEJ=KEI
           IF (NPX(KSP)*NPY(KSP).GT.0) THEN
                 JSX=2
                 JSY=2
                 DNSUM=0
                 DNY(1)=0.D0
                 DO 80 J=2,NY1
                 DNT=0.D0
                 DO 70 I=2,NX1
                 XX=(I-1.5D0)*HX
                 YY=(J-1.5D0)*HY
                 DN=DENS(XX,YY)
                 DNSUM=DNSUM+DN*HX*HY
 70              DNT=DNT+DN*HX
 80              DNY(J)=DNY(J-1)+DNT*HY
                 DO 90 J=2,NY1
 90              DNY(J)=DNY(J)/DNSUM
                 QSPEC(KSP)=SIGN(DNSUM/(HX*HY*NPX(KSP)*NPY(KSP))
     1                  ,QSPEC(KSP))
                 IF((IBCNDL(KSP).EQ.6) .OR. (IBCNDL(KSP) .EQ. 7)) THEN
                    TINJ=TAU
                    VAV=VAVG(VMPX(KSP),XDRIFT(KSP))
                    IF(KEJ.EQ.2) VAV = VAV/DSQRT(1.D0+VAV**2)
                    NMAX=DENITL(YMAX)*TPART(TINJ)*VAV/
     1                (DABS(QSPEC(KSP))*HX*HY)
                    WRITE (9,111) KSP,NMAX
 111           FORMAT('SPECIES (',I5,') MAY REQUIRE ',I10,' PARTICLES')
                 ENDIF
           ELSE
C              IF SPECIES IS TO BE INJECTED, DEFINE QSPEC WITH DENS(0,Y)
C
              IF((IBCNDL(KSP).EQ.6) .OR. (IBCNDL(KSP) .EQ. 7)) THEN
                   TINJ=TAU
                   VAV=VAVG(VMPX(KSP),XDRIFT(KSP))
                   IF(KEJ.EQ.2) VAV = VAV/DSQRT(1.D0+VAV**2)
                   QSPEC(KSP)=SIGN(DENITL(YMAX)*TPART(TINJ)
     1                 *VAV/(NSPEC(KSP)*HX*HY),QSPEC(KSP))
C                   QSPEC(KSP)=SIGN(DBLE(NX*NY)/DBLE(NSPEC(KSP))
C     1             ,QSPEC(KSP))
C                   QSPEC(KSP) = 1.5D0 * DINJL(KSP) * QSPEC(KSP)
C                   QSPEC(KSP)=(1.0D0+ERF(XDRIFT(KSP)/VMPX(KSP)))*QSPEC(KS
              END IF
           ENDIF
           WRITE (9,260) KSP,QSPEC(KSP)
           QMULT=QSPEC(KSP)
           WMULT=WSPEC(KSP)
           NP1X=NPX(KSP)
           NP1Y=NPY(KSP)
           NP1=NP1X*NP1Y
           VMPX1=VMPX(KSP)
           VMPY1=VMPY(KSP)
           XDRIF=XDRIFT(KSP)
           YDRIF=YDRIFT(KSP)
           VMPZ1=VMPZ(KSP)
           ZDRIF=ZDRIFT(KSP)
           IF (XRJ(KSP).EQ.0.D0) XRJ(KSP)=XMAX
           IF (XTJ(KSP).EQ.0.D0) XTJ(KSP)=YMAX
           WRITE (9,270) NP1,QMULT,WMULT,VMPX1,VMPY1,XDRIF,YDRIF
           NP1XA=0
           IF(NP1X.NE.0) P1XINV=1.D0/NP1X
           IF(NP1Y.NE.0) P1YINV=1.D0/NP1Y
           NP1Y=NP1Y+1
           IF (VEA.NE.0) VSA=DSIGN(1.0D0,QMULT)*VEA/WMULT
           END IF
      L3=1
      L4=MIN0(NP1,NB)
      ISP=KSP
      IF (NP1.GT.0) THEN
      DO 170 L=L3,L4
      IF (NP1XA.EQ.0) THEN
           NP1XA=NP1X
           NP1Y=NP1Y-1
           JSX=2
           PP=1-(NP1Y-.5D0)*P1YINV
           DO 150 J=JSY,NY1
           JSY=J
           IF(PP.LT.DNY(J)) GO TO 160
 150       CONTINUE
 160       CONTINUE
           YSAV=(PP-DNY(JSY-1))*HY/(DNY(JSY)-DNY(JSY-1))+(JSY-2)*HY
           DNX(1)=0.D0
           DO 125 I=2,NX1
           XX=(I-1.5D0)*HX
 125       DNX(I)=DNX(I-1)+DENS(XX,YSAV)*HX*HY
           DO 126  I=2,NX1
 126       DNX(I)=DNX(I)/DNX(NX1)
      END IF
      VMAG=DSQRT(-DLOG(1.D0-.99999D0*RANF(0.0D0)))
      TH=2.D0*PI*RANF(0.0D0)
      VX(L)=VMPX1*VMAG*DCOS(TH)+XDRIF
      VY(L)=VMPY1*VMAG*DSIN(TH)+YDRIF
      VMAG=DSQRT(-DLOG(1.D0-.99999D0*RANF(0.0D0)))
      TH=2.D0*PI*RANF(0.0D0)
      VZ(L)=VMPZ1*VMAG*DCOS(TH)+ZDRIF
      Q1=Q1+QMULT
      PP=1.D0-(NP1XA-.5D0)*P1XINV
      DO 130 J=JSX,NX1
      JSX=J
      IF (PP.LT.DNX(J)) GO TO 140
  130 CONTINUE
  140 CONTINUE
      X(L)=(PP-DNX(JSX-1))*HX/(DNX(JSX)-DNX(JSX-1))+(JSX-2)*HX
      Y(L)=YSAV
C     IF(VEA.NE.0.D0)VY(L)=VY(L)+VSA*DCOS(FKX*X(L))
      IF (VEA.NE.0.D0) VZ(L)=VZ(L)+VSA*DCOS(FKX*X(L))
C
C
      NP1XA=NP1XA-1
      NP1=NP1-1
  170 CONTINUE
      QAV=QAV+Q1
      ENDIF
      IF (L4.EQ.0) THEN
            L4=2
            X(1)=-1.D0
            X(2)=-1.D0
      ENDIF
      CALL PUTB(PBUF(1,1),L4,ISP,TBUF)
      GO TO 60
  180 CONTINUE
      IF (EPMAX.EQ.0.D0) EPMAX=25.D0*.5D0*WSPEC(1)*VMPX(1)**2
      DEP=DABS(QSPEC(1))*EPMAX/NEP
      DO 190 IJ=1,NX2NY2
      Q(IJ)=0.D0
      AX(IJ)=0.D0
      AX1(IJ)=0.D0
      AY(IJ)=0.D0
      AY1(IJ)=0.D0
      AZ(IJ)=0.D0
      AZ1(IJ)=0.D0
      EX(IJ)=0.D0
      EY(IJ)=0.D0
      EZ(IJ)=0.D0
      BX(IJ)=0.D0
      BY(IJ)=0.D0
      BZ(IJ)=0.D0
  190 CONTINUE
      DO 210 I=2,NX1
      Q1=0.D0
      DO 200 J=2,NY1
      XX=(I-1.5D0)*HX
      YY=(J-1.5D0)*HY
      L=I+(J-1)*NX2
      DO 200 KSP=1,NSP
      TM=DENS(XX,YY)*DSIGN(1.0D0,QSPEC(KSP))
      IF (NPX(KSP)*NPY(KSP).EQ.0) TM=0.D0
      Q(L) = Q(L) - TM
      Q1=Q1+TM
  200 CONTINUE
      QAV=QAV-Q1
  210 CONTINUE
      WRITE (9,280) QAV
      CALL ECWR (Q,QBK,NX2NY2)
      IF (KBND.EQ.1.AND.IMPSW.EQ.0) CALL INIBND
      IF (VEA.NE.0.) THEN
C
C     INITIALIZE WAVE
C
           AMAG=-VEA
           FKX=2.D0*PI*FNK/XMAX
           WKA=DSQRT(1.D0+FKX**2)
           XX=0.D0
           DO 230 IX=1,NX2
           AYA=AMAG*DCOS(FKX*XX)
           AYB=AMAG*DCOS(FKX*XX+WKA*DT)
           IJ=IX
           DO 220 IY=1,NY2
C          AY(IJ)=AYA
C          AY1(IJ)=AYB
           AZ(IJ)=AYA
           AZ1(IJ)=AYB
  220      IJ=IJ+NX2
  230      XX=XX+HX
      END IF
      WRITE (9,290)
      IF (KEE.EQ.0) WRITE(9,320)
      IF (KEE.EQ.1) WRITE(9,321)
      IF (KEE.EQ.2) WRITE(9,322)
      DTSAV=DT
      DT=0.D0
      CALL TRANS
C     WRITE (9,300)
      DT=DTSAV
      CALL FIELD
C     WRITE (9,310)
      L3=-1
      CALL DIAGNS
      RETURN
C
  250 FORMAT (/10H TOTAL OF ,I8,10H PARTICLES)
  260 FORMAT (' KSP = ',I5,' QSPEC(KSP) = ',E15.5)
  270 FORMAT (/' NP1=',I7,' QMULT=',F6.1,' WMULT=',F6.1,' VMPX=',F8.3,
     1' VMPY=',F8.3/'  XDRIFT=',F8.3,' YDRIFT=',F8.3,/)
  280 FORMAT (' NET CHARGE IN SYSTEM = ',E15.5)
  290 FORMAT (' INIT CALL TO TRANS')
  300 FORMAT (' INIT CALL TO FIELD')
  310 FORMAT (' INIT CALL TO DIAGNOS')
  320 FORMAT (' ELECTROSTATIC PARTICLE PUSH')
  321 FORMAT (' NONRELATIVISTIC ELECTROMAGNETIC PARTICLE PUSH')
  322 FORMAT ('    RELATIVISTIC ELECTROMAGNETIC PARTICLE PUSH')
      END

      FUNCTION IP2(X)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      IP2=INT(DLOG(X)/DLOG(2.D0)+.01D0)
      RETURN
      END

      FUNCTION DENS(X,Y)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      PARAMETER (N1D=5000)
      COMMON/PARCM/NX,NY,L3,L4,KBND,NX2,NX1,NY1,NY2,IBCDL,IBCDR,
     *   IBCDT,IBCDB,KBR,LSTL,LSTR,NINJL,NINJR,KBNDY,INOP,
     *   XMAX,YMAX,DT,QMULT,WMULT,XLEFT,XRIGHT,
     *   HX,HY,HXI,HYI,VMPX1,VMPY1,
     *   VMPZ1,ELOST,QLOSTL,QLOSTR,QLOSTT,QLOSTB,
     *   YTOP,YBOT,DRINJ,DLINJ,VRINJ,VLINJ,
     *   TRPAR,TLPAR,DTLPAR,DTRPAR,QINJL,QINJR,EINJ
C
      PARAMETER (NYY=514)
      PARAMETER(NNS=25)
      PARAMETER (NDIM=503)
      PARAMETER(NNS1=NNS+1,NNS2=NNS*2)
C
      PARAMETER(NCL=3*NYY)
C
      COMMON/FKICK/XKICK,DXKICK, YK1,YK2,FNKICK,VMPXH,VMPYH,EHEAT
     1 ,VOSC,DELE,DLASER,TWIDTH,TPEAK,XLASER
      COMMON/PARAM/IT,NC,NB,NP,IMPSW,NRAND,KJSMTH,KQSMTH,
     *    KEI,KEE,KSP,NPTIME,
     *    NSP,NPX(NNS),NPY(NNS),NSPEC(NNS),IDNX(NNS1),IDNY(NNS1),
     *    IBCNDL(NNS),IBCNDR(NNS),IBCNDT(NNS),IBCNDB(NNS),
     *    LOADED(NNS),LOSTL(NNS),LOSTR(NNS),INJL(NNS),INJR(NNS)
      COMMON/PARAMR/ PI,T,AA,SINA,SINP,TDLAZ,AMPH,PHAS,VEA,FNK,
     *    TAU,TAU1,TAU2,EXC,EYC,EZC,BXC,BYC,BZC,WSPEC(NNS),QSPEC(NNS),
     *    AYL(NCL),AYR(NCL),AYLD(NCL),AYRD(NCL),
     *    AZL(NCL),AZR(NCL),AZLD(NCL),AZRD(NCL),
     *    VMPX(NNS),VMPY(NNS),VMPZ(NNS),
     *    XDRIFT(NNS),YDRIFT(NNS),ZDRIFT(NNS),
     *    XN(NNS2),DENX(NNS2),YN(NNS2),DENY(NNS2),
     *    XLJ(NNS),XRJ(NNS),XTJ(NNS),XBJ(NNS),FEREM,AFRACR,
     *    DINJR(NNS),DINJL(NNS),VINJR(NNS),VINJL(NNS),
     *    TINJR(NNS),TINJL(NNS),IBATCH(NNS)
      COMMON /PARAM1/ EKX(NNS),EKY(NNS),EKZ(NNS),EKJ(NNS),
     *    VLIMA,VLIMB,VXAVGA,VXAVGB,VYAVGA,
     *    VYAVGB,VZAVGA,VZAVGB,TFIN,EFIN,
     *    TDEC(NDIM),EDEC(NDIM,6),ELOSTB,AVPOYN,APOYNT(N1D),
     *    EPOUTR(50),EPOUTL(50),EPOUTB(50),EPOUTT(50),
     *    EPINR(50),EPINL(50),EPINB(50),EPINT(50),
     *    DEP,TEP,EPMAX,KSPLIT,NPTSA,NPTSB,NPLOT,NENRG,NHIST,NFT1,NFT2,
     *    NENRG2,KDIAG,LDEC,NEP
C
       DENS=DENSX(X)*DENSY(Y)
C      DENS=0.
C      R=SQRT((X-.5*XMAX)**2+(Y-YMAX*.5)**2)
C      IF (R.LT.XMAX*.1) DENS=1.
C      IF(R.GT..4*XMAX.AND. R.LT..5*XMAX) DENS=1.
C      IF(X.GT..45*XMAX.AND.X.LT..55*XMAX.AND.Y.LT.YMAX*.5) DENS=1.
      RETURN
      END

      FUNCTION DENSX (X)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      PARAMETER (N1D=5000)
      COMMON/PARCM/NX,NY,L3,L4,KBND,NX2,NX1,NY1,NY2,IBCDL,IBCDR,
     *   IBCDT,IBCDB,KBR,LSTL,LSTR,NINJL,NINJR,KBNDY,INOP,
     *   XMAX,YMAX,DT,QMULT,WMULT,XLEFT,XRIGHT,
     *   HX,HY,HXI,HYI,VMPX1,VMPY1,
     *   VMPZ1,ELOST,QLOSTL,QLOSTR,QLOSTT,QLOSTB,
     *   YTOP,YBOT,DRINJ,DLINJ,VRINJ,VLINJ,
     *   TRPAR,TLPAR,DTLPAR,DTRPAR,QINJL,QINJR,EINJ
C
      PARAMETER (NYY=514)
      PARAMETER(NNS=25)
      PARAMETER (NDIM=503)
      PARAMETER(NNS1=NNS+1,NNS2=NNS*2)
C
      PARAMETER(NCL=3*NYY)
C
      COMMON/FKICK/XKICK,DXKICK, YK1,YK2,FNKICK,VMPXH,VMPYH,EHEAT
     1 ,VOSC,DELE,DLASER,TWIDTH,TPEAK,XLASER
      COMMON/PARAM/IT,NC,NB,NP,IMPSW,NRAND,KJSMTH,KQSMTH,
     *    KEI,KEE,KSP,NPTIME,
     *    NSP,NPX(NNS),NPY(NNS),NSPEC(NNS),IDNX(NNS1),IDNY(NNS1),
     *    IBCNDL(NNS),IBCNDR(NNS),IBCNDT(NNS),IBCNDB(NNS),
     *    LOADED(NNS),LOSTL(NNS),LOSTR(NNS),INJL(NNS),INJR(NNS)
      COMMON/PARAMR/ PI,T,AA,SINA,SINP,TDLAZ,AMPH,PHAS,VEA,FNK,
     *    TAU,TAU1,TAU2,EXC,EYC,EZC,BXC,BYC,BZC,WSPEC(NNS),QSPEC(NNS),
     *    AYL(NCL),AYR(NCL),AYLD(NCL),AYRD(NCL),
     *    AZL(NCL),AZR(NCL),AZLD(NCL),AZRD(NCL),
     *    VMPX(NNS),VMPY(NNS),VMPZ(NNS),
     *    XDRIFT(NNS),YDRIFT(NNS),ZDRIFT(NNS),
     *    XN(NNS2),DENX(NNS2),YN(NNS2),DENY(NNS2),
     *    XLJ(NNS),XRJ(NNS),XTJ(NNS),XBJ(NNS),FEREM,AFRACR,
     *    DINJR(NNS),DINJL(NNS),VINJR(NNS),VINJL(NNS),
     *    TINJR(NNS),TINJL(NNS),IBATCH(NNS)
      COMMON /PARAM1/ EKX(NNS),EKY(NNS),EKZ(NNS),EKJ(NNS),
     *    VLIMA,VLIMB,VXAVGA,VXAVGB,VYAVGA,
     *    VYAVGB,VZAVGA,VZAVGB,TFIN,EFIN,
     *    TDEC(NDIM),EDEC(NDIM,6),ELOSTB,AVPOYN,APOYNT(N1D),
     *    EPOUTR(50),EPOUTL(50),EPOUTB(50),EPOUTT(50),
     *    EPINR(50),EPINL(50),EPINB(50),EPINT(50),
     *    DEP,TEP,EPMAX,KSPLIT,NPTSA,NPTSB,NPLOT,NENRG,NHIST,NFT1,NFT2,
     *    NENRG2,KDIAG,LDEC,NEP
C
      DENSX=DENPT(X,IDNX,XN,DENX,XMAX,KSP)
      RETURN
      END

      FUNCTION DENSY (Y)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      PARAMETER (N1D=5000)
      COMMON/PARCM/NX,NY,L3,L4,KBND,NX2,NX1,NY1,NY2,IBCDL,IBCDR,
     *   IBCDT,IBCDB,KBR,LSTL,LSTR,NINJL,NINJR,KBNDY,INOP,
     *   XMAX,YMAX,DT,QMULT,WMULT,XLEFT,XRIGHT,
     *   HX,HY,HXI,HYI,VMPX1,VMPY1,
     *   VMPZ1,ELOST,QLOSTL,QLOSTR,QLOSTT,QLOSTB,
     *   YTOP,YBOT,DRINJ,DLINJ,VRINJ,VLINJ,
     *   TRPAR,TLPAR,DTLPAR,DTRPAR,QINJL,QINJR,EINJ
C
      PARAMETER (NYY=514)
      PARAMETER(NNS=25)
      PARAMETER (NDIM=503)
      PARAMETER(NNS1=NNS+1,NNS2=NNS*2)
C
      PARAMETER(NCL=3*NYY)
C
      COMMON/FKICK/XKICK,DXKICK, YK1,YK2,FNKICK,VMPXH,VMPYH,EHEAT
     1 ,VOSC,DELE,DLASER,TWIDTH,TPEAK,XLASER
      COMMON/PARAM/IT,NC,NB,NP,IMPSW,NRAND,KJSMTH,KQSMTH,
     *    KEI,KEE,KSP,NPTIME,
     *    NSP,NPX(NNS),NPY(NNS),NSPEC(NNS),IDNX(NNS1),IDNY(NNS1),
     *    IBCNDL(NNS),IBCNDR(NNS),IBCNDT(NNS),IBCNDB(NNS),
     *    LOADED(NNS),LOSTL(NNS),LOSTR(NNS),INJL(NNS),INJR(NNS)
      COMMON/PARAMR/ PI,T,AA,SINA,SINP,TDLAZ,AMPH,PHAS,VEA,FNK,
     *    TAU,TAU1,TAU2,EXC,EYC,EZC,BXC,BYC,BZC,WSPEC(NNS),QSPEC(NNS),
     *    AYL(NCL),AYR(NCL),AYLD(NCL),AYRD(NCL),
     *    AZL(NCL),AZR(NCL),AZLD(NCL),AZRD(NCL),
     *    VMPX(NNS),VMPY(NNS),VMPZ(NNS),
     *    XDRIFT(NNS),YDRIFT(NNS),ZDRIFT(NNS),
     *    XN(NNS2),DENX(NNS2),YN(NNS2),DENY(NNS2),
     *    XLJ(NNS),XRJ(NNS),XTJ(NNS),XBJ(NNS),FEREM,AFRACR,
     *    DINJR(NNS),DINJL(NNS),VINJR(NNS),VINJL(NNS),
     *    TINJR(NNS),TINJL(NNS),IBATCH(NNS)
      COMMON /PARAM1/ EKX(NNS),EKY(NNS),EKZ(NNS),EKJ(NNS),
     *    VLIMA,VLIMB,VXAVGA,VXAVGB,VYAVGA,
     *    VYAVGB,VZAVGA,VZAVGB,TFIN,EFIN,
     *    TDEC(NDIM),EDEC(NDIM,6),ELOSTB,AVPOYN,APOYNT(N1D),
     *    EPOUTR(50),EPOUTL(50),EPOUTB(50),EPOUTT(50),
     *    EPINR(50),EPINL(50),EPINB(50),EPINT(50),
     *    DEP,TEP,EPMAX,KSPLIT,NPTSA,NPTSB,NPLOT,NENRG,NHIST,NFT1,NFT2,
     *    NENRG2,KDIAG,LDEC,NEP
C
      DENSY=DENPT(Y,IDNY,YN,DENY,YMAX,KSP)
      RETURN
      END

      FUNCTION DENPT (XX,IDN,XN,DEN,XL,KSP)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION IDN(*), XN(*), DEN(*)
      J1=1
      J2=IDN(1)
      JM=KSP
      IF (KSP.EQ.1) GO TO 20
      DO 10 I=2,JM
      J1=J1+IDN(I-1)
      J2=J2+IDN(I)
   10 CONTINUE
   20 CONTINUE
      IF (XN(J2).EQ.0) XN(J2)=XL
      IF (XX.GE.XN(J1).AND.XX.LE.XN(J2)) GO TO 30
      DENPT=0.
      RETURN
   30 CONTINUE
      IF (XX.EQ.XN(J1)) DENPT=DEN(J1)
      J1=J1+1
      DO 40 J=J1,J2
      IF (XX.EQ.XN(J)) DENPT=DEN(J)
      IF (XX.GT.XN(J-1).AND.(XX.LT.XN(J))) DENPT=(DEN(J)-DEN(J-1))*(XX
     1 -XN(J))/(XN(J)-XN(J-1))+DEN(J)
   40 CONTINUE
      RETURN
      END

      SUBROUTINE TRANS
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      PARAMETER (NBB=512)
      PARAMETER(NC1 = 78885)
      PARAMETER (N1D=5000)
      COMMON /HTIM/ PSHCPT, PSHELT, FIOCPT, FIOELT
      COMMON  PBUF(NBB,5),Q(NC1),TEMP(2*N1D),TBUF(5,NBB)
      COMMON/POTEN1/ SS(NC1),W(NC1),AX(NC1)
      COMMON/POTEN2/ AX1(NC1),AY(NC1),AY1(NC1)
      COMMON/POTEN3/ AZ(NC1),AZ1(NC1)
      COMMON/CURR/ CX(NC1),CY(NC1),CZ(NC1)
      COMMON/EFIELD/EX(NC1),EY(NC1),EZ(NC1),BX(NC1),BY(NC1),BZ(NC1)
      COMMON/QBK/ QBK(NC1)
      DIMENSION X(NBB),Y(NBB),VX(NBB),VY(NBB),VZ(NBB)
      EQUIVALENCE (X(1),PBUF(1,1)),(Y(1),PBUF(1,2)),(VX(1),PBUF(1,3)),
     *  (VY(1),PBUF(1,4)),(VZ(1),PBUF(1,5))

      COMMON/PARCM/NX,NY,L3,L4,KBND,NX2,NX1,NY1,NY2,IBCDL,IBCDR,
     *   IBCDT,IBCDB,KBR,LSTL,LSTR,NINJL,NINJR,KBNDY,INOP,
     *   XMAX,YMAX,DT,QMULT,WMULT,XLEFT,XRIGHT,
     *   HX,HY,HXI,HYI,VMPX1,VMPY1,
     *   VMPZ1,ELOST,QLOSTL,QLOSTR,QLOSTT,QLOSTB,
     *   YTOP,YBOT,DRINJ,DLINJ,VRINJ,VLINJ,
     *   TRPAR,TLPAR,DTLPAR,DTRPAR,QINJL,QINJR,EINJ
C
      PARAMETER (NYY=514)
      PARAMETER(NNS=25)
      PARAMETER (NDIM=503)
      PARAMETER(NNS1=NNS+1,NNS2=NNS*2)
C
      PARAMETER(NCL=3*NYY)
C
      COMMON/FKICK/XKICK,DXKICK, YK1,YK2,FNKICK,VMPXH,VMPYH,EHEAT
     1 ,VOSC,DELE,DLASER,TWIDTH,TPEAK,XLASER
      COMMON/PARAM/IT,NC,NB,NP,IMPSW,NRAND,KJSMTH,KQSMTH,
     *    KEI,KEE,KSP,NPTIME,
     *    NSP,NPX(NNS),NPY(NNS),NSPEC(NNS),IDNX(NNS1),IDNY(NNS1),
     *    IBCNDL(NNS),IBCNDR(NNS),IBCNDT(NNS),IBCNDB(NNS),
     *    LOADED(NNS),LOSTL(NNS),LOSTR(NNS),INJL(NNS),INJR(NNS)
      COMMON/PARAMR/ PI,T,AA,SINA,SINP,TDLAZ,AMPH,PHAS,VEA,FNK,
     *    TAU,TAU1,TAU2,EXC,EYC,EZC,BXC,BYC,BZC,WSPEC(NNS),QSPEC(NNS),
     *    AYL(NCL),AYR(NCL),AYLD(NCL),AYRD(NCL),
     *    AZL(NCL),AZR(NCL),AZLD(NCL),AZRD(NCL),
     *    VMPX(NNS),VMPY(NNS),VMPZ(NNS),
     *    XDRIFT(NNS),YDRIFT(NNS),ZDRIFT(NNS),
     *    XN(NNS2),DENX(NNS2),YN(NNS2),DENY(NNS2),
     *    XLJ(NNS),XRJ(NNS),XTJ(NNS),XBJ(NNS),FEREM,AFRACR,
     *    DINJR(NNS),DINJL(NNS),VINJR(NNS),VINJL(NNS),
     *    TINJR(NNS),TINJL(NNS),IBATCH(NNS)
      COMMON /PARAM1/ EKX(NNS),EKY(NNS),EKZ(NNS),EKJ(NNS),
     *    VLIMA,VLIMB,VXAVGA,VXAVGB,VYAVGA,
     *    VYAVGB,VZAVGA,VZAVGB,TFIN,EFIN,
     *    TDEC(NDIM),EDEC(NDIM,6),ELOSTB,AVPOYN,APOYNT(N1D),
     *    EPOUTR(50),EPOUTL(50),EPOUTB(50),EPOUTT(50),
     *    EPINR(50),EPINL(50),EPINB(50),EPINT(50),
     *    DEP,TEP,EPMAX,KSPLIT,NPTSA,NPTSB,NPLOT,NENRG,NHIST,NFT1,NFT2,
     *    NENRG2,KDIAG,LDEC,NEP
C
C
      NX1=NX+1
      NX2=NX+2
      NY1=NY+1
      NY2=NY+2
      NX2NY2=NX2*NY2
      KDIAG=0
C
      DO 10 IJ=1,NX2NY2
      Q(IJ)=0.D0
      CX(IJ)=0.D0
      CY(IJ)=0.D0
      CZ(IJ)=0.D0
   10 CONTINUE
       CALL ECRD (Q,QBK,NX2NY2)
      CALL LASPOW
           NTHOLS=0
C
30    CONTINUE
      CALL GETB(PBUF,L4,KSP0,TBUF)
      L3=1
      IF(KSP0.EQ.0) GO TO 100
      IF(KSP.NE.IABS(KSP0))THEN
           KSP=IABS(KSP0)
           QMULT=QSPEC(KSP)
           WMULT=WSPEC(KSP)*DABS(QMULT)
           VMPX1=VMPX(KSP)
           VMPY1=VMPY(KSP)
           VMPZ1=VMPZ(KSP)
           IBCDL=IBCNDL(KSP)
           IBCDR=IBCNDR(KSP)
           IBCDT=IBCNDT(KSP)
           IBCDB=IBCNDB(KSP)
           XLEFT=XLJ(KSP)
           XRIGHT=XRJ(KSP)
           CALL SETINJ
      ENDIF
      ELOST=0.D0
      IF (KDIAG.EQ.0) THEN
           IF (QMULT.LT.0.D0) KBR=KEE+1
           IF (QMULT.GT.0.D0) KBR=KEI+1
           DTSAV=DT
           IF ((QMULT.GT.0.D0).AND.(IT.LT.NPTIME)) DT=0.D0
           IF(KBR.EQ.1) THEN
               CALL PARMVE
           ELSE IF (KBR.EQ.2) THEN
               CALL PARMOV
           ELSE IF (KBR.EQ.3) THEN
               CALL PARMVR
           ELSE
                 STOP 'KBR'
           ENDIF
           IF(XLASER.GT.0.AND.IT.NE.0.AND.QMULT.LT.0.D0) CALL LASER
           IF(KSP0.LT.0) CALL LASDEN
           IF(IBCDL.GE.6.OR.IBCDR.GE.6) THEN
                CALL INJCON(NTHOLS)
                IF(KSP0.LT.0) CALL INJBAT(KSP0,NTHOLS)
                IF(KSP0.EQ.0) GO TO 100
           ENDIF
           ELOSTB=ELOSTB+ELOST
           DT=DTSAV
      ENDIF
      CALL PDIAG
      GO TO 30
  100  KSP=0
      IF(KDIAG.EQ.0) THEN
           IF(NPLOT.NE.0) THEN
               IF(MOD(IT,NPLOT).EQ.0) THEN
                    KDIAG=-1
                    GO TO 30
               ENDIF
           ENDIF
      ELSE
           IF(KDIAG.LT.0) KDIAG=0
      ENDIF
      CALL INJCHK(NTHOLS)
C
C     ADD CONTRIBUTION FROM GHOST CELLS TO REAL CELLS AND SET B.C.
C
      CALL CELBND(Q,NX,NY,NX2,KBND,KBNDY,HX,HY,0,0,KQSMTH,TEMP)
      CALL CELBND(CX,NX,NY,NX2,KBND,KBNDY,HX,HY,1,0,KJSMTH,TEMP)
      CALL CELBND(CY,NX,NY,NX2,KBND,KBNDY,HX,HY,0,1,KJSMTH,TEMP)
      CALL CELBND(CZ,NX,NY,NX2,KBND,KBNDY,HX,HY,0,0,KJSMTH,TEMP)
      RETURN
      END

      SUBROUTINE CELBND(Q,NX,NY,NXD,KBNDX,KBNDY,
     1  HX,HY,ISYMX,ISYMY,KSMTH,SCRTCH)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
C     ROUTINE TO ADD GHOST CELLS OF Q INTO INTERNAL CELLS AND
C       SET GHOST CELLS USING APPROPRIATE BOUNDARY CONDITIONS
C
C       NX IS THE NUMBER OF CELLS IN X (NOT INCLUDING GHOST CELLS)
C       NY IS THE NUMBER OF CELLS IN Y (NOT INCLUDING GHOST CELLS)
C
C       KBNDX = 0 : PERIODIC IN X
C               1 : APERIODIC IN X
C       KBNDY = 0 : PERIODIC IN Y
C               1 : APERIODIC IN Y
C
C       ISYMX = 0 : MAKE FUNCTION Q CONTINUOUS AT X BOUNDARY
C               1 : MAKE FUNCTION Q 0 AT X BOUNDARY
C       ISYMY = 0 : MAKE FUNCTION Q CONTINUOUS AT Y BOUNDARY
C               1 : MAKE FUNCTION 0 AT Y BOUNDARY
C
C       BOUNDARIES ARE DEFINED AT CELL EDGES, Q HAS VALUES AT CELL
C         CENTERS
C
C       KSMTH = 1 : SMOOTH FUNCTION Q
C
      DIMENSION Q(NXD,*),SYMX(4),ASYMX(4),SYMY(4),ASYMY(4),SCRTCH(*)
      DATA  SYMX/0.D0,1.D0,0.D0,1.D0/, SYMY/0.D0,1.D0,0.D0,1.D0/
      DATA ASYMX/1.D0,0.D0,1.D0,0.D0/,ASYMY/1.D0,0.D0,1.D0,0.D0/
      NX1=NX+1
      NY1=NY+1
      NY2=NY+2
      NX2=NX+2
      SYMX(2)=1.D0
      SYMY(2)=1.D0
      ISYMMX = MIN0(IABS(ISYMX),1)
      ISYMMY = MIN0(IABS(ISYMY),1)
      IF (KBNDX.EQ.0) THEN
         ISYMMX = 0
         SYMX(2)= 0.D0
      ENDIF
      IF (KBNDY.EQ.0) THEN
         ISYMMY = 0
         SYMY(2)= 0.D0
      ENDIF
C
C          ADD IN GHOST CELLS ALONG X BOUNDARIES
C
      IF (KBNDX.EQ.0) THEN
C
C          PERIODIC BOUNDARY CONDITIONS IN X
C
         DO 150 J=1,NY2
            Q(2,J)   = Q(2,J)   + Q(NX2,J)
            Q(NX1,J) = Q(NX1,J) + Q(1,J)
  150    CONTINUE
      ELSE
C
C          APERIODIC BOUNDARY CONDITIONS IN X
C
         DO 155 J=1,NY2
            Q(2,J)   = Q(2,J)   + Q(1,J)
            Q(NX1,J) = Q(NX1,J) + Q(NX2,J)
  155    CONTINUE
      ENDIF
C
C     ADD IN GHOST CELLS ALONG Y BOUNDARIES
C
      IF (KBNDY.EQ.0) THEN
C
C           PERIODIC IN Y
C
         DO 160 I=2,NX1
            Q(I,2)   = Q(I,2)   + Q(I,NY2)
            Q(I,NY1) = Q(I,NY1) + Q(I,1)
  160    CONTINUE
      ELSE
C
C           APERIODIC IN Y
C
         DO 165 I=2,NX1
            Q(I,2)   = Q(I,2)   + Q(I,1)
            Q(I,NY1) = Q(I,NY1) + Q(I,NY2)
  165    CONTINUE
      ENDIF
C
C     IMPOSE BOUNDARY CONDITIONS
C
      IF (KBNDX.EQ.0) THEN
C
C          PERIODIC IN X
C
         DO 170 J=2,NY1
            Q(1,J)   = Q(NX1,J)
            Q(NX2,J) = Q(2,J)
  170    CONTINUE
      ELSE
C
C          APERIODIC IN X
C
         FAC=(1.D0-2.D0*ISYMMX)
         DO 175 J=2,NY1
            Q(1,J)   = FAC * Q(2,J)
            Q(NX2,J) = FAC * Q(NX1,J)
  175    CONTINUE
      ENDIF
      IF (KBNDY.EQ.0) THEN
C
C          PERIODIC IN Y
C
         DO 200 I=1,NX2
            Q(I,1)   =  Q(I,NY1)
            Q(I,NY2) =  Q(I,2)
  200    CONTINUE
      ELSE
C
C          APERIODIC IN Y
C
         FAC=(1-2*ISYMMY)
         DO 205 I=1,NX2
            Q(I,1)   = FAC * Q(I,2)
            Q(I,NY2) = FAC * Q(I,NY1)
  205    CONTINUE
      ENDIF
C
      IF(KSMTH.NE.0) THEN
        IF(ISYMMX.EQ.0.AND.ISYMMY.EQ.0) THEN
           CALL SMOOTH (NX2,NY2,HX,HY,Q,SYMX,SYMY,SCRTCH)
        ELSE IF (ISYMMX.EQ.0.AND.ISYMMY.EQ.1) THEN
           CALL SMOOTH (NX2,NY2,HX,HY,Q,SYMX,ASYMY,SCRTCH)
        ELSE IF (ISYMMX.EQ.1.AND.ISYMMY.EQ.0) THEN
           CALL SMOOTH (NX2,NY2,HX,HY,Q,ASYMX,SYMY,SCRTCH)
        ELSE IF (ISYMMX.EQ.1.AND.ISYMMX.EQ.1) THEN
           CALL SMOOTH (NX2,NY2,HX,HY,Q,ASYMX,ASYMY,SCRTCH)
        ENDIF
      ENDIF
      RETURN
      END

      SUBROUTINE BCND
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      PARAMETER (NBB=512)
      PARAMETER(NC1 = 78885)
      PARAMETER (N1D=5000)
      COMMON  PBUF(NBB,5),Q(NC1),TEMP(2*N1D),TBUF(5,NBB)
      COMMON/POTEN1/ SS(NC1),W(NC1),AX(NC1)
      COMMON/POTEN2/ AX1(NC1),AY(NC1),AY1(NC1)
      COMMON/POTEN3/ AZ(NC1),AZ1(NC1)
      COMMON/CURR/ CX(NC1),CY(NC1),CZ(NC1)
      COMMON/EFIELD/EX(NC1),EY(NC1),EZ(NC1),BX(NC1),BY(NC1),BZ(NC1)
      COMMON/QBK/ QBK(NC1)
      DIMENSION X(NBB),Y(NBB),VX(NBB),VY(NBB),VZ(NBB)
      EQUIVALENCE (X(1),PBUF(1,1)),(Y(1),PBUF(1,2)),(VX(1),PBUF(1,3)),
     *  (VY(1),PBUF(1,4)),(VZ(1),PBUF(1,5))

      COMMON/PARCM/NX,NY,L3,L4,KBND,NX2,NX1,NY1,NY2,IBCDL,IBCDR,
     *   IBCDT,IBCDB,KBR,LSTL,LSTR,NINJL,NINJR,KBNDY,INOP,
     *   XMAX,YMAX,DT,QMULT,WMULT,XLEFT,XRIGHT,
     *   HX,HY,HXI,HYI,VMPX1,VMPY1,
     *   VMPZ1,ELOST,QLOSTL,QLOSTR,QLOSTT,QLOSTB,
     *   YTOP,YBOT,DRINJ,DLINJ,VRINJ,VLINJ,
     *   TRPAR,TLPAR,DTLPAR,DTRPAR,QINJL,QINJR,EINJ
C
      COMMON /PARBD1/ JB, LB,IB(NBB),IBEG,IEND
      DIMENSION GA(NBB), XH(NBB), YH(NBB), VXH(NBB)
      COMMON /SCR/ SCR(NBB,18)
      EQUIVALENCE (GA,SCR(1,12)), (XH,SCR(1,2)), (YH,SCR(1,3)), (VXH,SCR
     1 (1,1))
      PARAMETER (NYY=514)
      PARAMETER(NNS=25)
      PARAMETER (NDIM=503)
      PARAMETER(NNS1=NNS+1,NNS2=NNS*2)
C
      PARAMETER(NCL=3*NYY)
C
      COMMON/FKICK/XKICK,DXKICK, YK1,YK2,FNKICK,VMPXH,VMPYH,EHEAT
     1 ,VOSC,DELE,DLASER,TWIDTH,TPEAK,XLASER
      COMMON/PARAM/IT,NC,NB,NP,IMPSW,NRAND,KJSMTH,KQSMTH,
     *    KEI,KEE,KSP,NPTIME,
     *    NSP,NPX(NNS),NPY(NNS),NSPEC(NNS),IDNX(NNS1),IDNY(NNS1),
     *    IBCNDL(NNS),IBCNDR(NNS),IBCNDT(NNS),IBCNDB(NNS),
     *    LOADED(NNS),LOSTL(NNS),LOSTR(NNS),INJL(NNS),INJR(NNS)
      COMMON/PARAMR/ PI,T,AA,SINA,SINP,TDLAZ,AMPH,PHAS,VEA,FNK,
     *    TAU,TAU1,TAU2,EXC,EYC,EZC,BXC,BYC,BZC,WSPEC(NNS),QSPEC(NNS),
     *    AYL(NCL),AYR(NCL),AYLD(NCL),AYRD(NCL),
     *    AZL(NCL),AZR(NCL),AZLD(NCL),AZRD(NCL),
     *    VMPX(NNS),VMPY(NNS),VMPZ(NNS),
     *    XDRIFT(NNS),YDRIFT(NNS),ZDRIFT(NNS),
     *    XN(NNS2),DENX(NNS2),YN(NNS2),DENY(NNS2),
     *    XLJ(NNS),XRJ(NNS),XTJ(NNS),XBJ(NNS),FEREM,AFRACR,
     *    DINJR(NNS),DINJL(NNS),VINJR(NNS),VINJL(NNS),
     *    TINJR(NNS),TINJL(NNS),IBATCH(NNS)
      COMMON /PARAM1/ EKX(NNS),EKY(NNS),EKZ(NNS),EKJ(NNS),
     *    VLIMA,VLIMB,VXAVGA,VXAVGB,VYAVGA,
     *    VYAVGB,VZAVGA,VZAVGB,TFIN,EFIN,
     *    TDEC(NDIM),EDEC(NDIM,6),ELOSTB,AVPOYN,APOYNT(N1D),
     *    EPOUTR(50),EPOUTL(50),EPOUTB(50),EPOUTT(50),
     *    EPINR(50),EPINL(50),EPINB(50),EPINT(50),
     *    DEP,TEP,EPMAX,KSPLIT,NPTSA,NPTSB,NPLOT,NENRG,NHIST,NFT1,NFT2,
     *    NENRG2,KDIAG,LDEC,NEP
C
      YBOT=0.D0
      YTOP=YMAX
      XLEF2=2.D0*XLEFT
      XRIT2=2.D0*XRIGHT
      YTOP2=2.D0*YTOP
      YBOT2=YBOT
C     WRITE (6,*) (X(L),Y(L),VX(L),L=L3,L4)
      DO 90 L=1,JB
      LB=IB(L)
C     WRITE (6,*) 'L,JB,LB,X(LB)= ',L,JB,LB,X(LB),Y(LB),VX(LB),VY(LB)
      IF(X(LB).NE.-1..AND.X(LB).NE.-2.) THEN
            IF (KBND.NE.0) THEN
C
C     X BOUNDARY CONDITION
C
                IF(X(LB).GT.XRIGHT) THEN
                       CALL BCNDR
                ELSE IF(X(LB).LT.XLEFT) THEN
                       CALL BCNDL
                ENDIF
            ELSE
              IF(X(LB).GT.XMAX) THEN
                        X(LB)=X(LB)-XMAX
                   IF (XH(LB).GE.XMAX) THEN
                        XH(LB)=XH(LB)-XMAX
                   ENDIF
              ELSE IF (X(LB).LT.0.D0) THEN
                        X(LB)=X(LB)+XMAX
                   IF (XH(LB).LT.0.D0) THEN
                        XH(LB)=XH(LB)+XMAX
                   ENDIF
              ENDIF
            ENDIF
            IF(KBNDY.EQ.0) THEN
C
C              Y BOUNDARY CONDITIONS
C
                IF (Y(LB).GE.YMAX) THEN
                       Y(LB)=Y(LB)-YMAX
                   IF (YH(LB).GE.YMAX) THEN
                       YH(LB)=YH(LB)-YMAX
                   ENDIF
                ELSE IF (Y(LB).LT.0.D0) THEN
                       Y(LB)=Y(LB)+YMAX
                   IF (YH(LB).LT.0.D0) THEN
                       YH(LB)=YH(LB)+YMAX
                    ENDIF
                ENDIF
            ELSE
                IF(Y(LB).GT.YTOP) THEN
                         CALL BCNDT
                ELSE IF(Y(LB).LT.YBOT) THEN
                         CALL BCNDB
                ENDIF
            ENDIF
      ENDIF
 90   CONTINUE
      IF(DT.EQ.0) RETURN
      IF(IBCDL.LT.6.AND.IBCDR.LT.6) RETURN
      CALL INJALL
      LOSTL(KSP) = LSTL
      LOSTR(KSP) = LSTR
      IF(TRPAR .GT. TINJR(KSP))TINJR(KSP) = TRPAR
      IF(TLPAR .GT. TINJL(KSP))TINJL(KSP) = TLPAR
      INJR (KSP) = NINJR
      INJL (KSP) = NINJL
      RETURN
      END

      SUBROUTINE BCNDS
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      PARAMETER (NBB=512)
      PARAMETER(NC1 = 78885)
      PARAMETER (N1D=5000)
      COMMON  PBUF(NBB,5),Q(NC1),TEMP(2*N1D),TBUF(5,NBB)
      COMMON/POTEN1/ SS(NC1),W(NC1),AX(NC1)
      COMMON/POTEN2/ AX1(NC1),AY(NC1),AY1(NC1)
      COMMON/POTEN3/ AZ(NC1),AZ1(NC1)
      COMMON/CURR/ CX(NC1),CY(NC1),CZ(NC1)
      COMMON/EFIELD/EX(NC1),EY(NC1),EZ(NC1),BX(NC1),BY(NC1),BZ(NC1)
      COMMON/QBK/ QBK(NC1)
      DIMENSION X(NBB),Y(NBB),VX(NBB),VY(NBB),VZ(NBB)
      EQUIVALENCE (X(1),PBUF(1,1)),(Y(1),PBUF(1,2)),(VX(1),PBUF(1,3)),
     *  (VY(1),PBUF(1,4)),(VZ(1),PBUF(1,5))

      COMMON/PARCM/NX,NY,L3,L4,KBND,NX2,NX1,NY1,NY2,IBCDL,IBCDR,
     *   IBCDT,IBCDB,KBR,LSTL,LSTR,NINJL,NINJR,KBNDY,INOP,
     *   XMAX,YMAX,DT,QMULT,WMULT,XLEFT,XRIGHT,
     *   HX,HY,HXI,HYI,VMPX1,VMPY1,
     *   VMPZ1,ELOST,QLOSTL,QLOSTR,QLOSTT,QLOSTB,
     *   YTOP,YBOT,DRINJ,DLINJ,VRINJ,VLINJ,
     *   TRPAR,TLPAR,DTLPAR,DTRPAR,QINJL,QINJR,EINJ
C
      COMMON /PARBD1/ JB, LB,IB(NBB),IBEG,IEND
      DIMENSION XH(NBB), VXH(NBB),YH(NBB), VYH(NBB)
      COMMON /SCR/ SCR(NBB,18)
      EQUIVALENCE (SCR(1,1),VXH), (SCR(1,2),XH), (YH,SCR(1,3))
      PARAMETER (NYY=514)
      PARAMETER(NNS=25)
      PARAMETER (NDIM=503)
      PARAMETER(NNS1=NNS+1,NNS2=NNS*2)
C
      PARAMETER(NCL=3*NYY)
C
      COMMON/FKICK/XKICK,DXKICK, YK1,YK2,FNKICK,VMPXH,VMPYH,EHEAT
     1 ,VOSC,DELE,DLASER,TWIDTH,TPEAK,XLASER
      COMMON/PARAM/IT,NC,NB,NP,IMPSW,NRAND,KJSMTH,KQSMTH,
     *    KEI,KEE,KSP,NPTIME,
     *    NSP,NPX(NNS),NPY(NNS),NSPEC(NNS),IDNX(NNS1),IDNY(NNS1),
     *    IBCNDL(NNS),IBCNDR(NNS),IBCNDT(NNS),IBCNDB(NNS),
     *    LOADED(NNS),LOSTL(NNS),LOSTR(NNS),INJL(NNS),INJR(NNS)
      COMMON/PARAMR/ PI,T,AA,SINA,SINP,TDLAZ,AMPH,PHAS,VEA,FNK,
     *    TAU,TAU1,TAU2,EXC,EYC,EZC,BXC,BYC,BZC,WSPEC(NNS),QSPEC(NNS),
     *    AYL(NCL),AYR(NCL),AYLD(NCL),AYRD(NCL),
     *    AZL(NCL),AZR(NCL),AZLD(NCL),AZRD(NCL),
     *    VMPX(NNS),VMPY(NNS),VMPZ(NNS),
     *    XDRIFT(NNS),YDRIFT(NNS),ZDRIFT(NNS),
     *    XN(NNS2),DENX(NNS2),YN(NNS2),DENY(NNS2),
     *    XLJ(NNS),XRJ(NNS),XTJ(NNS),XBJ(NNS),FEREM,AFRACR,
     *    DINJR(NNS),DINJL(NNS),VINJR(NNS),VINJL(NNS),
     *    TINJR(NNS),TINJL(NNS),IBATCH(NNS)
      COMMON /PARAM1/ EKX(NNS),EKY(NNS),EKZ(NNS),EKJ(NNS),
     *    VLIMA,VLIMB,VXAVGA,VXAVGB,VYAVGA,
     *    VYAVGB,VZAVGA,VZAVGB,TFIN,EFIN,
     *    TDEC(NDIM),EDEC(NDIM,6),ELOSTB,AVPOYN,APOYNT(N1D),
     *    EPOUTR(50),EPOUTL(50),EPOUTB(50),EPOUTT(50),
     *    EPINR(50),EPINL(50),EPINB(50),EPINT(50),
     *    DEP,TEP,EPMAX,KSPLIT,NPTSA,NPTSB,NPLOT,NENRG,NHIST,NFT1,NFT2,
     *    NENRG2,KDIAG,LDEC,NEP
C
C     DATA W1 /0./, W2 /0./, W3 /0./, W4 /0./, XLEF2 /0./, XRIT2 /0./, H
C    1 /0./, HH /0./, HHH /0./, EXA /0./, EYA /0./, EZA /0./, BXA /0./,
C    2 BYA /0./, BZA /0./, G /0./, VXH /0./, XMULT /0./, YMULT /0./,
C    3 ZMULT /0./, XH /0./, YH /0./, L /0./
C
C  BOUNDARY CONDITIONS FOR PARTICLES
C
C     IBCDL=0 PERIODIC
C     IBCDL=1 REFLECTING
C     IBCDL=2  RECREATE/ABSORB
C     IBCDL=3  REFLECT/ABSORB
C     IBCDL=4 ABSORB
C     IBCDR=5 RECREATE AFRACR WITH INITIAL TEMP
C         AND REDUCE ENERGY OF REMAINING BY FEREM AND RANDOMIZE ANGLE
C     IBCDR=6 ABSORB/INJECT PARTICLES AT PROPER TIME
C     IBCDR=7 ABSORB/INJECT TO KEEP CHARGE BALANCED
C     SAME FOR IBCDR
      ENTRY BCNDR
      L=LB
      IF (QLOSTR/QMULT.LT.-.75D0) THEN
C
C           ABSORB PARTICLE
C
            QLOSTR=QLOSTR+QMULT
            X(L)=-2.D0
            EPOUT=VX(L)**2+VY(L)**2+VZ(L)**2
            IF (KBR.EQ.3) EPOUT=2.D0*(DSQRT(EPOUT+1.D0)-1.D0)
            LSTR=LSTR+1
            EPOUT=EPOUT*WMULT
            ELOST=ELOST+EPOUT
            IEPO=IBIN(EPOUT)
            EPOUTR(IEPO)=EPOUTR(IEPO)+EPOUT
      ELSE
      IF(IBCDR.EQ.1.OR.IBCDR.EQ.3) THEN
C
C           REFLECT PARTICLE
C
           X(L)=2.D0*XRIGHT-X(L)
           VX(L)=-VX(L)
           IF (XH(L).LT.XRIGHT) RETURN
           XH(L)=2.D0*XRIGHT-XH(L)
           VXH(L)=-VXH(L)
      ELSE IF(IBCDR.EQ.2) THEN
C
C     RECREATE PARTICLE
C
           CALL RECRE(1.0D0,0.0D0,L,X,VX,VY,VZ,XH,VXH,XRIGHT,
     1        -VMPX1,VMPY1,VMPZ1,EPOUTR,EPINR)
C
      ELSE IF(IBCDR.EQ.4.OR.IBCDR.GE.6) THEN
C
C          ABSORB PARTICLE
C
            QLOSTR=QLOSTR+QMULT
            X(L)=-2.D0
            EPOUT=VX(L)**2+VY(L)**2+VZ(L)**2
            IF (KBR.EQ.3) EPOUT=2.D0*(DSQRT(EPOUT+1.D0)-1.D0)
            EPIN=0.D0
            LSTR=LSTR+1
            EPOUT=EPOUT*WMULT
            ELOST=ELOST+EPOUT
           IEPO=IBIN(EPOUT)
            EPOUTR(IEPO)=EPOUTR(IEPO)+EPOUT
      ELSE IF(IBCDR.EQ.5) THEN
C
C         RECREATE AFRACR OF ELECTRONS
C
           CALL RECRE(AFRACR,FEREM,L,X,VX,VY,VZ,XH,VXH,XRIGHT,
     1       -VMPX1,VMPY1,VMPZ1,EPOUTR,EPINR)
C

      ENDIF
      ENDIF
      RETURN
      ENTRY BCNDL
      L=LB
      IF (QLOSTL/QMULT.LT.-.75D0) THEN
C
C           ABSORB PARTICLE
C
            QLOSTL=QLOSTL+QMULT
            X(L)=-1.D0
            EPOUT=VX(L)**2+VY(L)**2+VZ(L)**2
            IF (KBR.EQ.3) EPOUT=2.D0*(DSQRT(EPOUT+1.D0)-1.D0)
            EPOUT=EPOUT*WMULT
            LSTL=LSTL+1
            ELOST=ELOST+EPOUT
            IEPO=IBIN(EPOUT)
            EPOUTL(IEPO)=EPOUTL(IEPO)+EPOUT
      ELSE
      IF(IBCDL.EQ.1.OR.IBCDL.EQ.3) THEN
C
C           REFLECT PARTICLE
C
           X(L)=2.D0*XLEFT-X(L)
           VX(L)=-VX(L)
           IF (XH(L).LT.XLEFT) RETURN
           XH(L)=2.D0*XLEFT-XH(L)
           VXH(L)=-VXH(L)
      ELSE IF(IBCDL.EQ.2) THEN
C
C     RECREATE PARTICLE
C
           CALL RECRE(1.0D0,0.0D0,L,X,VX,VY,VZ,XH,VXH,XLEFT,
     1        VMPX1,VMPY1,VMPZ1,EPOUTL,EPINL)
C
      ELSE IF(IBCDL.EQ.4.OR.IBCDL.GE.6) THEN
C
C          ABSORB PARTICLE
C
            QLOSTL=QLOSTL+QMULT
            X(L)=-1.D0
            EPOUT=VX(L)**2+VY(L)**2+VZ(L)**2
            IF (KBR.EQ.3) EPOUT=2.D0*(DSQRT(EPOUT+1.D0)-1.D0)
            LSTL=LSTL+1
            EPOUT=EPOUT*WMULT
            ELOST=ELOST+EPOUT
            IEPO=IBIN(EPOUT)
            EPOUTL(IEPO)=EPOUTL(IEPO)+EPOUT
      ELSE IF(IBCDL.EQ.5) THEN
C
C         RECREATE AFRACR OF ELECTRONS
C
           CALL RECRE(AFRACR,FEREM,L,X,VX,VY,VZ,XH,VXH,XLEFT,
     1       VMPX1,VMPY1,VMPZ1,EPOUTL,EPINL)
C
      ENDIF
      ENDIF
      RETURN
      ENTRY BCNDT
      L=LB
      IF (QLOSTT/QMULT.LT.-.75D0) THEN
C
C           ABSORB PARTICLE
C
            QLOSTT=QLOSTT+QMULT
            X(L)=-1.D0
            EPOUT=VX(L)**2+VY(L)**2+VZ(L)**2
            IF (KBR.EQ.3) EPOUT=2.D0*(DSQRT(EPOUT+1.D0)-1.D0)
            EPOUT=EPOUT*WMULT
            ELOST=ELOST+EPOUT
            IEPO=IBIN(EPOUT)
            EPOUTT(IEPO)=EPOUTT(IEPO)+EPOUT
      ELSE
      IF(IBCDT.EQ.1.OR.IBCDT.EQ.3) THEN
C
C           REFLECT PARTICLE
C
           Y(L)=2.D0*YTOP-Y(L)
           VY(L)=-VY(L)
           IF (YH(L).LT.YTOP) RETURN
           YH(L)=2.D0*YTOP-YH(L)
C          VYH(L)=-VYH(L)
      ELSE IF(IBCDT.EQ.2) THEN
C
C     RECREATE PARTICLE
C
           CALL RECRE(1.0D0,0.0D0,L,Y,VY,VX,VZ,YH,VYH,YTOP,
     1        -VMPY1,VMPX1,VMPZ1,EPOUTT,EPINT)
C
      ELSE IF(IBCDT.EQ.4) THEN
C
C          ABSORB PARTICLE
C
            QLOSTT=QLOSTT+QMULT
            X(L)=-1.D0
            EPOUT=VX(L)**2+VY(L)**2+VZ(L)**2
            IF (KBR.EQ.3) EPOUT=2.D0*(DSQRT(EPOUT+1.D0)-1.D0)
            EPOUT=EPOUT*WMULT
            ELOST=ELOST+EPOUT
            IEPO=IBIN(EPOUT)
            EPOUTT(IEPO)=EPOUTT(IEPO)+EPOUT
      ELSE IF(IBCDT.EQ.5) THEN
C
C         RECREATE AFRACR OF ELECTRONS
C
           CALL RECRE(AFRACR,FEREM,L,Y,VY,VX,VZ,YH,VYH,YTOP,
     1        -VMPY1,VMPX1,VMPZ1,EPOUTT,EPINT)
C
      ENDIF
      ENDIF
      RETURN
      ENTRY BCNDB
      L=LB
      IF (QLOSTB/QMULT.LT.-.75D0) THEN
C
C           ABSORB PARTICLE
C
            QLOSTB=QLOSTB+QMULT
            X(L)=-1.D0
            EPOUT=VX(L)**2+VY(L)**2+VZ(L)**2
            IF (KBR.EQ.3) EPOUT=2.D0*(DSQRT(EPOUT+1.D0)-1.D0)
            EPOUT=EPOUT*WMULT
            ELOST=ELOST+EPOUT
            IEPO=IBIN(EPOUT)
            EPOUTB(IEPO)=EPOUTB(IEPO)+EPOUT
      ELSE
      IF(IBCDB.EQ.1.OR.IBCDB.EQ.3) THEN
C
C           REFLECT PARTICLE
C
           Y(L)=2.D0*YBOT-Y(L)
           VY(L)=-VY(L)
           IF (YH(L).LT.YBOT) RETURN
           YH(L)=2.D0*YBOT-YH(L)
C          VYH(L)=-VYH(L)
      ELSE IF(IBCDB.EQ.2) THEN
C
C     RECREATE PARTICLE
C
           CALL RECRE(1.0D0,0.0D0,L,Y,VY,VX,VZ,YH,VYH,YBOT,
     1        VMPY1,VMPX1,VMPZ1,EPOUTB,EPINB)
C
      ELSE IF(IBCDB.EQ.4) THEN
C
C          ABSORB PARTICLE
C
            QLOSTB=QLOSTB+QMULT
            X(L)=-1.D0
            EPOUT=VX(L)**2+VY(L)**2+VZ(L)**2
            IF (KBR.EQ.3) EPOUT=2.D0*(DSQRT(EPOUT+1.D0)-1.D0)
            EPOUT=EPOUT*WMULT
            ELOST=ELOST+EPOUT
            IEPO=IBIN(EPOUT)
            EPOUTB(IEPO)=EPOUTB(IEPO)+EPOUT
      ELSE IF(IBCDB.EQ.5) THEN
C
C         RECREATE AFRACR OF ELECTRONS
C
           CALL RECRE(AFRACR,FEREM,L,Y,VY,VX,VZ,YH,VYH,YBOT,
     1        VMPY1,VMPX1,VMPZ1,EPOUTB,EPINB)
C
      ENDIF
      ENDIF
      RETURN
      END

      FUNCTION IBIN(Z)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      PARAMETER (N1D=5000)
      PARAMETER (NYY=514)
      PARAMETER(NNS=25)
      PARAMETER (NDIM=503)
      PARAMETER(NNS1=NNS+1,NNS2=NNS*2)
C
      PARAMETER(NCL=3*NYY)
C
      COMMON/FKICK/XKICK,DXKICK, YK1,YK2,FNKICK,VMPXH,VMPYH,EHEAT
     1 ,VOSC,DELE,DLASER,TWIDTH,TPEAK,XLASER
      COMMON/PARAM/IT,NC,NB,NP,IMPSW,NRAND,KJSMTH,KQSMTH,
     *    KEI,KEE,KSP,NPTIME,
     *    NSP,NPX(NNS),NPY(NNS),NSPEC(NNS),IDNX(NNS1),IDNY(NNS1),
     *    IBCNDL(NNS),IBCNDR(NNS),IBCNDT(NNS),IBCNDB(NNS),
     *    LOADED(NNS),LOSTL(NNS),LOSTR(NNS),INJL(NNS),INJR(NNS)
      COMMON/PARAMR/ PI,T,AA,SINA,SINP,TDLAZ,AMPH,PHAS,VEA,FNK,
     *    TAU,TAU1,TAU2,EXC,EYC,EZC,BXC,BYC,BZC,WSPEC(NNS),QSPEC(NNS),
     *    AYL(NCL),AYR(NCL),AYLD(NCL),AYRD(NCL),
     *    AZL(NCL),AZR(NCL),AZLD(NCL),AZRD(NCL),
     *    VMPX(NNS),VMPY(NNS),VMPZ(NNS),
     *    XDRIFT(NNS),YDRIFT(NNS),ZDRIFT(NNS),
     *    XN(NNS2),DENX(NNS2),YN(NNS2),DENY(NNS2),
     *    XLJ(NNS),XRJ(NNS),XTJ(NNS),XBJ(NNS),FEREM,AFRACR,
     *    DINJR(NNS),DINJL(NNS),VINJR(NNS),VINJL(NNS),
     *    TINJR(NNS),TINJL(NNS),IBATCH(NNS)
      COMMON /PARAM1/ EKX(NNS),EKY(NNS),EKZ(NNS),EKJ(NNS),
     *    VLIMA,VLIMB,VXAVGA,VXAVGB,VYAVGA,
     *    VYAVGB,VZAVGA,VZAVGB,TFIN,EFIN,
     *    TDEC(NDIM),EDEC(NDIM,6),ELOSTB,AVPOYN,APOYNT(N1D),
     *    EPOUTR(50),EPOUTL(50),EPOUTB(50),EPOUTT(50),
     *    EPINR(50),EPINL(50),EPINB(50),EPINT(50),
     *    DEP,TEP,EPMAX,KSPLIT,NPTSA,NPTSB,NPLOT,NENRG,NHIST,NFT1,NFT2,
     *    NENRG2,KDIAG,LDEC,NEP
C
      IBIN=MIN0(NEP,1+INT(Z/DEP))
      RETURN
      END

      SUBROUTINE RECRE(AFRAC,FEREM,L,X,VX,VY,VZ,XH,VXH,XBND,
     1  VMPX,VMPY,VMPZ,EPOUTB,EPINB)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION X(*),VX(*),VY(*),VZ(*),XH(*),VXH(*),EPOUTB(*),EPINB(*)
      COMMON/PARCM/NX,NY,L3,L4,KBND,NX2,NX1,NY1,NY2,IBCDL,IBCDR,
     *   IBCDT,IBCDB,KBR,LSTL,LSTR,NINJL,NINJR,KBNDY,INOP,
     *   XMAX,YMAX,DT,QMULT,WMULT,XLEFT,XRIGHT,
     *   HX,HY,HXI,HYI,VMPX1,VMPY1,
     *   VMPZ1,ELOST,QLOSTL,QLOSTR,QLOSTT,QLOSTB,
     *   YTOP,YBOT,DRINJ,DLINJ,VRINJ,VLINJ,
     *   TRPAR,TLPAR,DTLPAR,DTRPAR,QINJL,QINJR,EINJ
C
      EXTERNAL RANF
      DATA TWOPI /6.283185307D0/
C
C      ROUTINE TO RESET PARTICLE ENERGY AT BOUNDARY AND REPLACE PARTICLE
C        BACK ONTO GRID
C
C      SIGN OF VMPX DETERMINES DIRECTION PARTICLE IS DISPLACED
C        WHEN REINSERTED INTO GRID
C         E.G. AT RIGHT BOUNDARY, VMPX SHOULD BE NEGATIVE
C
      VYS=VY(L)
      VXS=VX(L)
      VZS=VZ(L)
      EPOUT=VXS**2+VYS**2+VZS**2
      A=RANF(0.0D0)
      IF (A.LT.AFRAC) THEN
C
C      RECREATE AFRAC  WITH SPECIFIED  TEMPERATURE
C
              VX(L)=VMPX*DSQRT(-DLOG(1.D0-.999999D0*RANF(0.0D0)))
              VMAG=DSQRT(-DLOG(1.D0-.999999D0*RANF(0.0D0)))
              TH=TWOPI*RANF(0.0D0)
              VY(L)=VMPY*VMAG*DSIN(TH)
              VZ(L)=VMPZ*VMAG*DCOS(TH)
       ELSE
C
C          REDUCE ENERGY BY FEREM AND RANDOMIZE
C
             EPO=EPOUT
             IF (KBR.EQ.3) EPO=2.D0*(DSQRT(EPO+1.D0)-1.D0)
             EPO=FEREM*EPO
             IF (KBR.EQ.3) VMAG=DSQRT((.5D0*EPO+1.D0)**2-1.D0)
             IF (KBR.NE.3) VMAG=DSQRT(EPO)
             TH=.25D0*TWOPI*(2.D0*RANF(0.0D0)-1.D0)
             TH1=TWOPI*RANF(0.0D0)
             VZ(L)=VMAG*DSIN(TH)*DSIN(TH1)
             VY(L)=VMAG*DSIN(TH)*DCOS(TH1)
             VX(L)=SIGN(VMAG*DCOS(TH),VMPX)
       ENDIF
       EPIN=VX(L)**2+VY(L)**2+VZ(L)**2
       IF (KBR.EQ.3) EPOUT=2.D0*(DSQRT(EPOUT+1.D0)-1.D0)
       IF (KBR.EQ.3) EPIN=2.D0*(DSQRT(EPIN+1.D0)-1.D0)
       EPOUT=EPOUT*WMULT
       EPIN=EPIN*WMULT
       VXH(L)=VX(L)
       DX=VX(L)*DT*RANF(0.0D0)
       XH(L)=XBND+DX*.5D0
       X(L)=XBND+DX
       ELOST=ELOST+EPOUT-EPIN
C
C   ADD ENERGY TO DIAGNOSTIC BINS
C
       IEPO=IBIN(EPOUT)
       IEPI=IBIN(EPIN)
       EPOUTB(IEPO)=EPOUTB(IEPO)+EPOUT
       EPINB(IEPI)=EPINB(IEPI)+EPIN
       RETURN
       END

      SUBROUTINE SETINJ
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      PARAMETER (N1D=5000)
      PARAMETER (NYY=514)
      PARAMETER(NNS=25)
      PARAMETER (NDIM=503)
      PARAMETER(NNS1=NNS+1,NNS2=NNS*2)
C
      PARAMETER(NCL=3*NYY)
C
      COMMON/FKICK/XKICK,DXKICK, YK1,YK2,FNKICK,VMPXH,VMPYH,EHEAT
     1 ,VOSC,DELE,DLASER,TWIDTH,TPEAK,XLASER
      COMMON/PARAM/IT,NC,NB,NP,IMPSW,NRAND,KJSMTH,KQSMTH,
     *    KEI,KEE,KSP,NPTIME,
     *    NSP,NPX(NNS),NPY(NNS),NSPEC(NNS),IDNX(NNS1),IDNY(NNS1),
     *    IBCNDL(NNS),IBCNDR(NNS),IBCNDT(NNS),IBCNDB(NNS),
     *    LOADED(NNS),LOSTL(NNS),LOSTR(NNS),INJL(NNS),INJR(NNS)
      COMMON/PARAMR/ PI,T,AA,SINA,SINP,TDLAZ,AMPH,PHAS,VEA,FNK,
     *    TAU,TAU1,TAU2,EXC,EYC,EZC,BXC,BYC,BZC,WSPEC(NNS),QSPEC(NNS),
     *    AYL(NCL),AYR(NCL),AYLD(NCL),AYRD(NCL),
     *    AZL(NCL),AZR(NCL),AZLD(NCL),AZRD(NCL),
     *    VMPX(NNS),VMPY(NNS),VMPZ(NNS),
     *    XDRIFT(NNS),YDRIFT(NNS),ZDRIFT(NNS),
     *    XN(NNS2),DENX(NNS2),YN(NNS2),DENY(NNS2),
     *    XLJ(NNS),XRJ(NNS),XTJ(NNS),XBJ(NNS),FEREM,AFRACR,
     *    DINJR(NNS),DINJL(NNS),VINJR(NNS),VINJL(NNS),
     *    TINJR(NNS),TINJL(NNS),IBATCH(NNS)
      COMMON /PARAM1/ EKX(NNS),EKY(NNS),EKZ(NNS),EKJ(NNS),
     *    VLIMA,VLIMB,VXAVGA,VXAVGB,VYAVGA,
     *    VYAVGB,VZAVGA,VZAVGB,TFIN,EFIN,
     *    TDEC(NDIM),EDEC(NDIM,6),ELOSTB,AVPOYN,APOYNT(N1D),
     *    EPOUTR(50),EPOUTL(50),EPOUTB(50),EPOUTT(50),
     *    EPINR(50),EPINL(50),EPINB(50),EPINT(50),
     *    DEP,TEP,EPMAX,KSPLIT,NPTSA,NPTSB,NPLOT,NENRG,NHIST,NFT1,NFT2,
     *    NENRG2,KDIAG,LDEC,NEP
C
      COMMON/PARCM/NX,NY,L3,L4,KBND,NX2,NX1,NY1,NY2,IBCDL,IBCDR,
     *   IBCDT,IBCDB,KBR,LSTL,LSTR,NINJL,NINJR,KBNDY,INOP,
     *   XMAX,YMAX,DT,QMULT,WMULT,XLEFT,XRIGHT,
     *   HX,HY,HXI,HYI,VMPX1,VMPY1,
     *   VMPZ1,ELOST,QLOSTL,QLOSTR,QLOSTT,QLOSTB,
     *   YTOP,YBOT,DRINJ,DLINJ,VRINJ,VLINJ,
     *   TRPAR,TLPAR,DTLPAR,DTRPAR,QINJL,QINJR,EINJ
C
      VRINJ = XDRIFT(KSP)
      VLINJ = XDRIFT(KSP)
c specmod
c      DRINJ = DINJR(KSP)
c      DLINJ = DINJL(KSP)
      DRINJ = 0.0D0
      DLINJ = 0.0D0
      TRPAR = TINJR(KSP)
      TLPAR = TINJL(KSP)
      NINJL = INJL(KSP)
      NINJR = INJR(KSP)
      LSTR = LOSTR(KSP)
      LSTL = LOSTL(KSP)
      IF(IBCDL .EQ. 6) THEN
           VAVGL = VAVG(VMPX1,VLINJ)
           IF(KBR .EQ. 3) VAVGL = VAVGL/DSQRT(1.D0+VAVGL**2)
           DTLPAR = DABS(HX*HY*DABS(QMULT)/(DENITL(YMAX)*VAVGL))
      ENDIF
      IF(IBCDR .EQ. 6) THEN
           VAVGR= VAVG(VMPX1,-VRINJ)
           IF(KBR.EQ.3) VAVGR=VAVGR/DSQRT(1.D0+VAVGR**2)
		   DTRPAR=DABS(HX*HY*DABS(QMULT)/(DENITR(YMAX)*VAVGR))
	      ENDIF
	      IF(T .NE. 0.0D0)RETURN
C      TINJL(1) = 0.0
C      TINJL(2) = 0.0
C      TINJR(1) = 0.0
C      TINJR(2) = 0.0
      RETURN
      END
C
      FUNCTION VAVG (VTH,VD)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DATA WING /7.0D0/, SQRPI/1.772453851D0/
      X=VD/VTH
      VAVG = VD
      IF (X.LT.WING) VAVG = .5D0*(VTH*DEXP(-X*X)/SQRPI +
     1   VD*(1+ERF(X)))
      RETURN
      END
C
      FUNCTION TPART(TIN)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      PARAMETER (NBB=512)
      PARAMETER(NC1 = 78885)
      PARAMETER (N1D=5000)
      COMMON  PBUF(NBB,5),Q(NC1),TEMP(2*N1D),TBUF(5,NBB)
      COMMON/POTEN1/ SS(NC1),W(NC1),AX(NC1)
      COMMON/POTEN2/ AX1(NC1),AY(NC1),AY1(NC1)
      COMMON/POTEN3/ AZ(NC1),AZ1(NC1)
      COMMON/CURR/ CX(NC1),CY(NC1),CZ(NC1)
      COMMON/EFIELD/EX(NC1),EY(NC1),EZ(NC1),BX(NC1),BY(NC1),BZ(NC1)
      COMMON/QBK/ QBK(NC1)
      DIMENSION X(NBB),Y(NBB),VX(NBB),VY(NBB),VZ(NBB)
      EQUIVALENCE (X(1),PBUF(1,1)),(Y(1),PBUF(1,2)),(VX(1),PBUF(1,3)),
     *  (VY(1),PBUF(1,4)),(VZ(1),PBUF(1,5))

      PARAMETER (NYY=514)
      PARAMETER(NNS=25)
      PARAMETER (NDIM=503)
      PARAMETER(NNS1=NNS+1,NNS2=NNS*2)
C
	      PARAMETER(NCL=3*NYY)
C
      COMMON/FKICK/XKICK,DXKICK, YK1,YK2,FNKICK,VMPXH,VMPYH,EHEAT
     1 ,VOSC,DELE,DLASER,TWIDTH,TPEAK,XLASER
      COMMON/PARAM/IT,NC,NB,NP,IMPSW,NRAND,KJSMTH,KQSMTH,
     *    KEI,KEE,KSP,NPTIME,
     *    NSP,NPX(NNS),NPY(NNS),NSPEC(NNS),IDNX(NNS1),IDNY(NNS1),
     *    IBCNDL(NNS),IBCNDR(NNS),IBCNDT(NNS),IBCNDB(NNS),
     *    LOADED(NNS),LOSTL(NNS),LOSTR(NNS),INJL(NNS),INJR(NNS)
      COMMON/PARAMR/ PI,T,AA,SINA,SINP,TDLAZ,AMPH,PHAS,VEA,FNK,
     *    TAU,TAU1,TAU2,EXC,EYC,EZC,BXC,BYC,BZC,WSPEC(NNS),QSPEC(NNS),
     *    AYL(NCL),AYR(NCL),AYLD(NCL),AYRD(NCL),
     *    AZL(NCL),AZR(NCL),AZLD(NCL),AZRD(NCL),
     *    VMPX(NNS),VMPY(NNS),VMPZ(NNS),
     *    XDRIFT(NNS),YDRIFT(NNS),ZDRIFT(NNS),
     *    XN(NNS2),DENX(NNS2),YN(NNS2),DENY(NNS2),
     *    XLJ(NNS),XRJ(NNS),XTJ(NNS),XBJ(NNS),FEREM,AFRACR,
     *    DINJR(NNS),DINJL(NNS),VINJR(NNS),VINJL(NNS),
     *    TINJR(NNS),TINJL(NNS),IBATCH(NNS)
      COMMON /PARAM1/ EKX(NNS),EKY(NNS),EKZ(NNS),EKJ(NNS),
     *    VLIMA,VLIMB,VXAVGA,VXAVGB,VYAVGA,
     *    VYAVGB,VZAVGA,VZAVGB,TFIN,EFIN,
     *    TDEC(NDIM),EDEC(NDIM,6),ELOSTB,AVPOYN,APOYNT(N1D),
     *    EPOUTR(50),EPOUTL(50),EPOUTB(50),EPOUTT(50),
     *    EPINR(50),EPINL(50),EPINB(50),EPINT(50),
     *    DEP,TEP,EPMAX,KSPLIT,NPTSA,NPTSB,NPLOT,NENRG,NHIST,NFT1,NFT2,
     *    NENRG2,KDIAG,LDEC,NEP
C
C
C    COMPUTE NORMALIZED TIME TO INJECT PARTICLE
C
C      THIS FUNCTION PROVIDES THE INTEGRAL OF N DT / N MAX
C
C          AT THE PEAK OF PULSE (N MAX) TPART VS TIN HAS A SLOPE
C           OF 1
C
      PI = 3.1415926D0
      IF(TAU1 .EQ. 0.0D0) THEN
	   IF(TIN .LE. 2.0D0 * TAU2) THEN
C
C          N = DSIN (T*PI/2*TAU2) **2
C
		ANSWER = TIN - TAU2 * DSIN(TIN * PI / TAU2) / PI
	   ELSE
		ANSWER=0.0D0
	   ENDIF
      ELSE IF(TAU2 .EQ. 0.0) THEN
C
C          N = CONSTANT IN TIME
C
	   ANSWER = TIN
      ELSE
C     CODED HERE IS THE CO2 PULSE SHAPE WHERE TAU1 < TAU2
C
C            TAU1 IS THE RISE TIME
C            TAU2 IS THE FALL TIME
C
	   A0 = 3.0D0 / TAU2
	   A1 = 2.0D0 / TAU2 + 1.0D0 / TAU1
	   A2 = 1.0D0 / TAU2 + 2.0D0 / TAU1
	   A3 =              3.0D0 / TAU1
C          A4 = 1. / (1.0/A0 - 3.0/A1 + 3.0/A2 - 1.0/A3)
	   TAUX=DLOG(TAU2/TAU1)/(1/TAU1-1/TAU2)
C
C   TAUX IS THE PEAK OF THE PULSE
C
	   A4=  1/(DEXP(-TAUX/TAU2)-DEXP(-TAUX/TAU1))**3
	   T0 = (1.0D0 - DEXP(-A0 * TIN))
	   T1 = (1.0D0 - DEXP(-A1 * TIN))
	   T2 = (1.0D0 - DEXP(-A2 * TIN))
	   T3 = (1.0D0 - DEXP(-A3 * TIN))
	   ANSWER = (T0/A0 - 3.0D0*T1/A1 + 3.0D0*T2/A2 - T3/A3)*A4
      ENDIF
C
      TPART = ANSWER
      RETURN
      END
C
      FUNCTION TCOMP(TPAR)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      PARAMETER (NBB=512)
      PARAMETER(NC1 = 78885)
      PARAMETER (N1D=5000)
      COMMON  PBUF(NBB,5),Q(NC1),TEMP(2*N1D),TBUF(5,NBB)
      COMMON/POTEN1/ SS(NC1),W(NC1),AX(NC1)
      COMMON/POTEN2/ AX1(NC1),AY(NC1),AY1(NC1)
      COMMON/POTEN3/ AZ(NC1),AZ1(NC1)
      COMMON/CURR/ CX(NC1),CY(NC1),CZ(NC1)
      COMMON/EFIELD/EX(NC1),EY(NC1),EZ(NC1),BX(NC1),BY(NC1),BZ(NC1)
      COMMON/QBK/ QBK(NC1)
      DIMENSION X(NBB),Y(NBB),VX(NBB),VY(NBB),VZ(NBB)
      EQUIVALENCE (X(1),PBUF(1,1)),(Y(1),PBUF(1,2)),(VX(1),PBUF(1,3)),
     *  (VY(1),PBUF(1,4)),(VZ(1),PBUF(1,5))

      PARAMETER (NYY=514)
      PARAMETER(NNS=25)
      PARAMETER (NDIM=503)
      PARAMETER(NNS1=NNS+1,NNS2=NNS*2)
C
      PARAMETER(NCL=3*NYY)
C
      COMMON/FKICK/XKICK,DXKICK, YK1,YK2,FNKICK,VMPXH,VMPYH,EHEAT
     1 ,VOSC,DELE,DLASER,TWIDTH,TPEAK,XLASER
      COMMON/PARAM/IT,NC,NB,NP,IMPSW,NRAND,KJSMTH,KQSMTH,
     *    KEI,KEE,KSP,NPTIME,
     *    NSP,NPX(NNS),NPY(NNS),NSPEC(NNS),IDNX(NNS1),IDNY(NNS1),
     *    IBCNDL(NNS),IBCNDR(NNS),IBCNDT(NNS),IBCNDB(NNS),
     *    LOADED(NNS),LOSTL(NNS),LOSTR(NNS),INJL(NNS),INJR(NNS)
      COMMON/PARAMR/ PI,T,AA,SINA,SINP,TDLAZ,AMPH,PHAS,VEA,FNK,
     *    TAU,TAU1,TAU2,EXC,EYC,EZC,BXC,BYC,BZC,WSPEC(NNS),QSPEC(NNS),
     *    AYL(NCL),AYR(NCL),AYLD(NCL),AYRD(NCL),
     *    AZL(NCL),AZR(NCL),AZLD(NCL),AZRD(NCL),
     *    VMPX(NNS),VMPY(NNS),VMPZ(NNS),
     *    XDRIFT(NNS),YDRIFT(NNS),ZDRIFT(NNS),
     *    XN(NNS2),DENX(NNS2),YN(NNS2),DENY(NNS2),
     *    XLJ(NNS),XRJ(NNS),XTJ(NNS),XBJ(NNS),FEREM,AFRACR,
     *    DINJR(NNS),DINJL(NNS),VINJR(NNS),VINJL(NNS),
     *    TINJR(NNS),TINJL(NNS),IBATCH(NNS)
      COMMON /PARAM1/ EKX(NNS),EKY(NNS),EKZ(NNS),EKJ(NNS),
     *    VLIMA,VLIMB,VXAVGA,VXAVGB,VYAVGA,
     *    VYAVGB,VZAVGA,VZAVGB,TFIN,EFIN,
     *    TDEC(NDIM),EDEC(NDIM,6),ELOSTB,AVPOYN,APOYNT(N1D),
     *    EPOUTR(50),EPOUTL(50),EPOUTB(50),EPOUTT(50),
     *    EPINR(50),EPINL(50),EPINB(50),EPINT(50),
     *    DEP,TEP,EPMAX,KSPLIT,NPTSA,NPTSB,NPLOT,NENRG,NHIST,NFT1,NFT2,
     *    NENRG2,KDIAG,LDEC,NEP
C
C
C     BINARY SEARCH TO CONVERT PROBLEM TIME TO INJECT TIME
C
      DATA BIG /1.D25/
      TMIN = 0.0D0
      IF(TAU2 .EQ. 0.0D0) THEN
	   ANSWER = TPAR
      ELSE IF(TAU1 .EQ. 0.0D0) THEN
	   TMAX = 2.0D0 * TAU2
	   ANSWER = BIG
	   IF(TPAR .LE. TMAX) THEN
		DO 444 I = 1,25
		TMID = (TMIN + TMAX) / 2.0D0
		XMID = TPART(TMID)
		IF(XMID . GT. TPAR)TMAX = TMID
		IF(XMID . LT. TPAR)TMIN = TMID
  444           CONTINUE
		ANSWER = TMID
	   ENDIF
      ELSE
	   TMAX = TMIN + 0.1D0 * TAU
	   TMIN=0.0D0
	   DO 445 I = 1,25
	   TMID = (TMIN + TMAX) / 2.0D0
	   XMID = TPART(TMID)
	   IF(XMID . GT. TPAR)TMAX = TMID
	   IF(XMID . LT. TPAR)TMIN = TMID
  445      CONTINUE
	   ANSWER = TMID
      ENDIF
      TCOMP = ANSWER
      RETURN
      END
C
      FUNCTION DENITL(Y)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      PARAMETER (N1D=5000)
      COMMON/PARCM/NX,NY,L3,L4,KBND,NX2,NX1,NY1,NY2,IBCDL,IBCDR,
     *   IBCDT,IBCDB,KBR,LSTL,LSTR,NINJL,NINJR,KBNDY,INOP,
     *   XMAX,YMAX,DT,QMULT,WMULT,XLEFT,XRIGHT,
     *   HX,HY,HXI,HYI,VMPX1,VMPY1,
     *   VMPZ1,ELOST,QLOSTL,QLOSTR,QLOSTT,QLOSTB,
     *   YTOP,YBOT,DRINJ,DLINJ,VRINJ,VLINJ,
     *   TRPAR,TLPAR,DTLPAR,DTRPAR,QINJL,QINJR,EINJ
C
      PARAMETER (NYY=514)
      PARAMETER(NNS=25)
      PARAMETER (NDIM=503)
      PARAMETER(NNS1=NNS+1,NNS2=NNS*2)
C
      PARAMETER(NCL=3*NYY)
C
      COMMON/FKICK/XKICK,DXKICK, YK1,YK2,FNKICK,VMPXH,VMPYH,EHEAT
     1 ,VOSC,DELE,DLASER,TWIDTH,TPEAK,XLASER
      COMMON/PARAM/IT,NC,NB,NP,IMPSW,NRAND,KJSMTH,KQSMTH,
     *    KEI,KEE,KSP,NPTIME,
     *    NSP,NPX(NNS),NPY(NNS),NSPEC(NNS),IDNX(NNS1),IDNY(NNS1),
     *    IBCNDL(NNS),IBCNDR(NNS),IBCNDT(NNS),IBCNDB(NNS),
     *    LOADED(NNS),LOSTL(NNS),LOSTR(NNS),INJL(NNS),INJR(NNS)
      COMMON/PARAMR/ PI,T,AA,SINA,SINP,TDLAZ,AMPH,PHAS,VEA,FNK,
     *    TAU,TAU1,TAU2,EXC,EYC,EZC,BXC,BYC,BZC,WSPEC(NNS),QSPEC(NNS),
     *    AYL(NCL),AYR(NCL),AYLD(NCL),AYRD(NCL),
     *    AZL(NCL),AZR(NCL),AZLD(NCL),AZRD(NCL),
     *    VMPX(NNS),VMPY(NNS),VMPZ(NNS),
     *    XDRIFT(NNS),YDRIFT(NNS),ZDRIFT(NNS),
     *    XN(NNS2),DENX(NNS2),YN(NNS2),DENY(NNS2),
     *    XLJ(NNS),XRJ(NNS),XTJ(NNS),XBJ(NNS),FEREM,AFRACR,
     *    DINJR(NNS),DINJL(NNS),VINJR(NNS),VINJL(NNS),
     *    TINJR(NNS),TINJL(NNS),IBATCH(NNS)
      COMMON /PARAM1/ EKX(NNS),EKY(NNS),EKZ(NNS),EKJ(NNS),
     *    VLIMA,VLIMB,VXAVGA,VXAVGB,VYAVGA,
     *    VYAVGB,VZAVGA,VZAVGB,TFIN,EFIN,
     *    TDEC(NDIM),EDEC(NDIM,6),ELOSTB,AVPOYN,APOYNT(N1D),
     *    EPOUTR(50),EPOUTL(50),EPOUTB(50),EPOUTT(50),
     *    EPINR(50),EPINL(50),EPINB(50),EPINT(50),
     *    DEP,TEP,EPMAX,KSPLIT,NPTSA,NPTSB,NPLOT,NENRG,NHIST,NFT1,NFT2,
     *    NENRG2,KDIAG,LDEC,NEP
C
      DIMENSION SUM(NYY)
      SAVE SUM
C
C     NORMALIZED INTEGRAL OF DENSITY AT LEFT BOUNDARY
C
      DATA ISET/0/,KSPP/-1/
      IF (ISET.EQ.0.OR.KSP.NE.KSPP) THEN
	   SUM(1)=0.D0
	   DO 10 J=1,NY
   10      SUM(J+1)=SUM(J)+DENS(0.0D0,HY*(J-.5D0))*HY
	   ISET=1
	   KSPP=KSP
      ENDIF
      J = Y/HY+1
      FY = Y/HY +1 -J
      FYC = 1.D0 - FY
      DENITL = SUM(J)*FYC + SUM(J+1)*FY
      RETURN
      END
C
      FUNCTION DENITR(Y)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      PARAMETER (N1D=5000)
      COMMON/PARCM/NX,NY,L3,L4,KBND,NX2,NX1,NY1,NY2,IBCDL,IBCDR,
     *   IBCDT,IBCDB,KBR,LSTL,LSTR,NINJL,NINJR,KBNDY,INOP,
     *   XMAX,YMAX,DT,QMULT,WMULT,XLEFT,XRIGHT,
     *   HX,HY,HXI,HYI,VMPX1,VMPY1,
     *   VMPZ1,ELOST,QLOSTL,QLOSTR,QLOSTT,QLOSTB,
     *   YTOP,YBOT,DRINJ,DLINJ,VRINJ,VLINJ,
     *   TRPAR,TLPAR,DTLPAR,DTRPAR,QINJL,QINJR,EINJ
C
      PARAMETER (NYY=514)
      PARAMETER(NNS=25)
      PARAMETER (NDIM=503)
      PARAMETER(NNS1=NNS+1,NNS2=NNS*2)
C
      PARAMETER(NCL=3*NYY)
C
      COMMON/FKICK/XKICK,DXKICK, YK1,YK2,FNKICK,VMPXH,VMPYH,EHEAT
     1 ,VOSC,DELE,DLASER,TWIDTH,TPEAK,XLASER
      COMMON/PARAM/IT,NC,NB,NP,IMPSW,NRAND,KJSMTH,KQSMTH,
     *    KEI,KEE,KSP,NPTIME,
     *    NSP,NPX(NNS),NPY(NNS),NSPEC(NNS),IDNX(NNS1),IDNY(NNS1),
     *    IBCNDL(NNS),IBCNDR(NNS),IBCNDT(NNS),IBCNDB(NNS),
     *    LOADED(NNS),LOSTL(NNS),LOSTR(NNS),INJL(NNS),INJR(NNS)
      COMMON/PARAMR/ PI,T,AA,SINA,SINP,TDLAZ,AMPH,PHAS,VEA,FNK,
     *    TAU,TAU1,TAU2,EXC,EYC,EZC,BXC,BYC,BZC,WSPEC(NNS),QSPEC(NNS),
     *    AYL(NCL),AYR(NCL),AYLD(NCL),AYRD(NCL),
     *    AZL(NCL),AZR(NCL),AZLD(NCL),AZRD(NCL),
     *    VMPX(NNS),VMPY(NNS),VMPZ(NNS),
     *    XDRIFT(NNS),YDRIFT(NNS),ZDRIFT(NNS),
     *    XN(NNS2),DENX(NNS2),YN(NNS2),DENY(NNS2),
     *    XLJ(NNS),XRJ(NNS),XTJ(NNS),XBJ(NNS),FEREM,AFRACR,
     *    DINJR(NNS),DINJL(NNS),VINJR(NNS),VINJL(NNS),
     *    TINJR(NNS),TINJL(NNS),IBATCH(NNS)
      COMMON /PARAM1/ EKX(NNS),EKY(NNS),EKZ(NNS),EKJ(NNS),
     *    VLIMA,VLIMB,VXAVGA,VXAVGB,VYAVGA,
     *    VYAVGB,VZAVGA,VZAVGB,TFIN,EFIN,
     *    TDEC(NDIM),EDEC(NDIM,6),ELOSTB,AVPOYN,APOYNT(N1D),
     *    EPOUTR(50),EPOUTL(50),EPOUTB(50),EPOUTT(50),
     *    EPINR(50),EPINL(50),EPINB(50),EPINT(50),
     *    DEP,TEP,EPMAX,KSPLIT,NPTSA,NPTSB,NPLOT,NENRG,NHIST,NFT1,NFT2,
     *    NENRG2,KDIAG,LDEC,NEP
C
      DIMENSION SUM(NYY)
      SAVE SUM
C
C     NORMALIZED INTEGRAL OF DENSITY AT RIGHT BOUNDARY
C
      DATA ISET/0/,KSPP/-1/
      IF (ISET.EQ.0.OR.KSP.NE.KSPP) THEN
	   SUM(1)=0.D0
	   DO 10 J=1,NY
   10      SUM(J+1)=SUM(J)+DENS(XMAX,HY*(J-.5D0))*HY
	   ISET=1
	   KSPP=KSP
      ENDIF
      J = Y/HY+1
      FY = Y/HY +1 -J
      FYC = 1.D0 - FY
      DENITR = SUM(J)*FYC + SUM(J+1)*FY
      RETURN
      END
C
      SUBROUTINE LINJ
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C     INJECT - LEFT - ELECTROMAGNETIC
C
      PARAMETER (NBB=512)
      PARAMETER(NC1 = 78885)
      PARAMETER (N1D=5000)
      COMMON  PBUF(NBB,5),Q(NC1),TEMP(2*N1D),TBUF(5,NBB)
      COMMON/POTEN1/ SS(NC1),W(NC1),AX(NC1)
      COMMON/POTEN2/ AX1(NC1),AY(NC1),AY1(NC1)
      COMMON/POTEN3/ AZ(NC1),AZ1(NC1)
      COMMON/CURR/ CX(NC1),CY(NC1),CZ(NC1)
      COMMON/EFIELD/EX(NC1),EY(NC1),EZ(NC1),BX(NC1),BY(NC1),BZ(NC1)
      COMMON/QBK/ QBK(NC1)
      DIMENSION X(NBB),Y(NBB),VX(NBB),VY(NBB),VZ(NBB)
      EQUIVALENCE (X(1),PBUF(1,1)),(Y(1),PBUF(1,2)),(VX(1),PBUF(1,3)),
     *  (VY(1),PBUF(1,4)),(VZ(1),PBUF(1,5))

      PARAMETER (NYY=514)
      PARAMETER(NNS=25)
      PARAMETER (NDIM=503)
      PARAMETER(NNS1=NNS+1,NNS2=NNS*2)
C
      PARAMETER(NCL=3*NYY)
C
      COMMON/FKICK/XKICK,DXKICK, YK1,YK2,FNKICK,VMPXH,VMPYH,EHEAT
     1 ,VOSC,DELE,DLASER,TWIDTH,TPEAK,XLASER
      COMMON/PARAM/IT,NC,NB,NP,IMPSW,NRAND,KJSMTH,KQSMTH,
     *    KEI,KEE,KSP,NPTIME,
     *    NSP,NPX(NNS),NPY(NNS),NSPEC(NNS),IDNX(NNS1),IDNY(NNS1),
     *    IBCNDL(NNS),IBCNDR(NNS),IBCNDT(NNS),IBCNDB(NNS),
     *    LOADED(NNS),LOSTL(NNS),LOSTR(NNS),INJL(NNS),INJR(NNS)
      COMMON/PARAMR/ PI,T,AA,SINA,SINP,TDLAZ,AMPH,PHAS,VEA,FNK,
     *    TAU,TAU1,TAU2,EXC,EYC,EZC,BXC,BYC,BZC,WSPEC(NNS),QSPEC(NNS),
     *    AYL(NCL),AYR(NCL),AYLD(NCL),AYRD(NCL),
     *    AZL(NCL),AZR(NCL),AZLD(NCL),AZRD(NCL),
     *    VMPX(NNS),VMPY(NNS),VMPZ(NNS),
     *    XDRIFT(NNS),YDRIFT(NNS),ZDRIFT(NNS),
     *    XN(NNS2),DENX(NNS2),YN(NNS2),DENY(NNS2),
     *    XLJ(NNS),XRJ(NNS),XTJ(NNS),XBJ(NNS),FEREM,AFRACR,
     *    DINJR(NNS),DINJL(NNS),VINJR(NNS),VINJL(NNS),
     *    TINJR(NNS),TINJL(NNS),IBATCH(NNS)
      COMMON /PARAM1/ EKX(NNS),EKY(NNS),EKZ(NNS),EKJ(NNS),
     *    VLIMA,VLIMB,VXAVGA,VXAVGB,VYAVGA,
     *    VYAVGB,VZAVGA,VZAVGB,TFIN,EFIN,
     *    TDEC(NDIM),EDEC(NDIM,6),ELOSTB,AVPOYN,APOYNT(N1D),
     *    EPOUTR(50),EPOUTL(50),EPOUTB(50),EPOUTT(50),
     *    EPINR(50),EPINL(50),EPINB(50),EPINT(50),
     *    DEP,TEP,EPMAX,KSPLIT,NPTSA,NPTSB,NPLOT,NENRG,NHIST,NFT1,NFT2,
     *    NENRG2,KDIAG,LDEC,NEP
C
      COMMON/PARCM/NX,NY,L3,L4,KBND,NX2,NX1,NY1,NY2,IBCDL,IBCDR,
     *   IBCDT,IBCDB,KBR,LSTL,LSTR,NINJL,NINJR,KBNDY,INOP,
     *   XMAX,YMAX,DT,QMULT,WMULT,XLEFT,XRIGHT,
     *   HX,HY,HXI,HYI,VMPX1,VMPY1,
     *   VMPZ1,ELOST,QLOSTL,QLOSTR,QLOSTT,QLOSTB,
     *   YTOP,YBOT,DRINJ,DLINJ,VRINJ,VLINJ,
     *   TRPAR,TLPAR,DTLPAR,DTRPAR,QINJL,QINJR,EINJ
C
      COMMON /PARBD1/ JB,LB,IB(NBB),IBEG,IEND
      DATA TWOPI/6.283185307D0/
      NINJL=NINJL+1
      QINJL=QINJL+QMULT
      VX(LB)=VNEWL(VMPX1,VLINJ)
      VMAG = DSQRT(-DLOG(1.D0-.999999D0*RANF(0.0D0)))
      TH = TWOPI * RANF(0.0D0)
      VY(LB) = VMPY1 * VMAG * DSIN(TH)
      VZ(LB) = VMPZ1 * VMAG * DCOS(TH)
      VPART=VX(LB)
      IF(KBR.EQ.3) VPART=VPART/DSQRT(1.D0+VPART**2)
      IF(IBCDL .EQ. 6)X(LB) = XLEFT + VPART * (T - TCOMP(TLPAR))
      IF(IBCDL .NE. 6)X(LB) = XLEFT + VPART * DT * RANF(0.0D0)
C      CONST = 2* YMAX / TWOPI
C
C  LOAD Y POSITION WITH SIN(PI*Y/YMAX) DISTRIBUTION
C
C      ARG = -.999999 + 1.999998 * RANF(0.0D0)
C      Y(LB) =  CONST * ACOS(ARG)
      YMN = 0.0D0
      YMX = YMAX
      RN = RANF(0.0D0)
      RDNL = 1.D0/DENITL(YMAX)
      DO 20 I=1,25
      YMID = (YMN + YMX) / 2.D0
      XX = DENITL(YMID)*RDNL
      IF (XX.GT.RN) YMX = YMID
  20  IF (XX.LT.RN) YMN = YMID
      Y(LB)=YMID
      TLPAR=TLPAR+DTLPAR
      RETURN
      END
C
      SUBROUTINE RINJ
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C     INJECT - RIGHT - ELECTROMAGNETIC
C
      PARAMETER (NBB=512)
      PARAMETER(NC1 = 78885)
      PARAMETER (N1D=5000)
      COMMON  PBUF(NBB,5),Q(NC1),TEMP(2*N1D),TBUF(5,NBB)
      COMMON/POTEN1/ SS(NC1),W(NC1),AX(NC1)
      COMMON/POTEN2/ AX1(NC1),AY(NC1),AY1(NC1)
      COMMON/POTEN3/ AZ(NC1),AZ1(NC1)
      COMMON/CURR/ CX(NC1),CY(NC1),CZ(NC1)
      COMMON/EFIELD/EX(NC1),EY(NC1),EZ(NC1),BX(NC1),BY(NC1),BZ(NC1)
      COMMON/QBK/ QBK(NC1)
      DIMENSION X(NBB),Y(NBB),VX(NBB),VY(NBB),VZ(NBB)
      EQUIVALENCE (X(1),PBUF(1,1)),(Y(1),PBUF(1,2)),(VX(1),PBUF(1,3)),
     *  (VY(1),PBUF(1,4)),(VZ(1),PBUF(1,5))

      PARAMETER (NYY=514)
      PARAMETER(NNS=25)
      PARAMETER (NDIM=503)
      PARAMETER(NNS1=NNS+1,NNS2=NNS*2)
C
      PARAMETER(NCL=3*NYY)
C
      COMMON/FKICK/XKICK,DXKICK, YK1,YK2,FNKICK,VMPXH,VMPYH,EHEAT
     1 ,VOSC,DELE,DLASER,TWIDTH,TPEAK,XLASER
      COMMON/PARAM/IT,NC,NB,NP,IMPSW,NRAND,KJSMTH,KQSMTH,
     *    KEI,KEE,KSP,NPTIME,
     *    NSP,NPX(NNS),NPY(NNS),NSPEC(NNS),IDNX(NNS1),IDNY(NNS1),
     *    IBCNDL(NNS),IBCNDR(NNS),IBCNDT(NNS),IBCNDB(NNS),
     *    LOADED(NNS),LOSTL(NNS),LOSTR(NNS),INJL(NNS),INJR(NNS)
      COMMON/PARAMR/ PI,T,AA,SINA,SINP,TDLAZ,AMPH,PHAS,VEA,FNK,
     *    TAU,TAU1,TAU2,EXC,EYC,EZC,BXC,BYC,BZC,WSPEC(NNS),QSPEC(NNS),
     *    AYL(NCL),AYR(NCL),AYLD(NCL),AYRD(NCL),
     *    AZL(NCL),AZR(NCL),AZLD(NCL),AZRD(NCL),
     *    VMPX(NNS),VMPY(NNS),VMPZ(NNS),
     *    XDRIFT(NNS),YDRIFT(NNS),ZDRIFT(NNS),
     *    XN(NNS2),DENX(NNS2),YN(NNS2),DENY(NNS2),
     *    XLJ(NNS),XRJ(NNS),XTJ(NNS),XBJ(NNS),FEREM,AFRACR,
     *    DINJR(NNS),DINJL(NNS),VINJR(NNS),VINJL(NNS),
     *    TINJR(NNS),TINJL(NNS),IBATCH(NNS)
      COMMON /PARAM1/ EKX(NNS),EKY(NNS),EKZ(NNS),EKJ(NNS),
     *    VLIMA,VLIMB,VXAVGA,VXAVGB,VYAVGA,
     *    VYAVGB,VZAVGA,VZAVGB,TFIN,EFIN,
     *    TDEC(NDIM),EDEC(NDIM,6),ELOSTB,AVPOYN,APOYNT(N1D),
     *    EPOUTR(50),EPOUTL(50),EPOUTB(50),EPOUTT(50),
     *    EPINR(50),EPINL(50),EPINB(50),EPINT(50),
     *    DEP,TEP,EPMAX,KSPLIT,NPTSA,NPTSB,NPLOT,NENRG,NHIST,NFT1,NFT2,
     *    NENRG2,KDIAG,LDEC,NEP
C
      COMMON/PARCM/NX,NY,L3,L4,KBND,NX2,NX1,NY1,NY2,IBCDL,IBCDR,
     *   IBCDT,IBCDB,KBR,LSTL,LSTR,NINJL,NINJR,KBNDY,INOP,
     *   XMAX,YMAX,DT,QMULT,WMULT,XLEFT,XRIGHT,
     *   HX,HY,HXI,HYI,VMPX1,VMPY1,
     *   VMPZ1,ELOST,QLOSTL,QLOSTR,QLOSTT,QLOSTB,
     *   YTOP,YBOT,DRINJ,DLINJ,VRINJ,VLINJ,
     *   TRPAR,TLPAR,DTLPAR,DTRPAR,QINJL,QINJR,EINJ
C
      COMMON /PARBD1/ JB,LB,IB(NBB),IBEG,IEND
      DATA TWOPI/6.283185307D0/
      NINJR=NINJR+1
      QINJR=QINJR+QMULT
      VX(LB)=-VNEWL(VMPX1,-VRINJ)
      VMAG = DSQRT(-DLOG(1.D0-.999999D0*RANF(0.0D0)))
      TH = TWOPI * RANF(0.0D0)
      VY(LB) = VMPY1 * VMAG * DSIN(TH)
      VZ(LB) = VMPZ1 * VMAG * DCOS(TH)
      VPART=VX(LB)
      IF(KBR.EQ.3) VPART=VPART/DSQRT(1.D0+VPART**2)
      IF(IBCDR. EQ. 6)X(LB) = XRIGHT + VPART * (T - TCOMP(TRPAR))
      IF(IBCDR .NE. 6)X(LB) = XRIGHT + VPART * DT * RANF(0.0D0)
C      CONST = 2* YMAX / TWOPI
C
C  LOAD Y POSITION WITH SIN(PI*Y/YMAX) DISTRIBUTION
C
C      ARG = -.999999D0 + 1.999998D0 * RANF(0.0D0)
C      Y(LB) = CONST * ACOS(ARG)
      YMN = 0.0D0
      YMX = YMAX
      RN = RANF(0.0D0)
      RDNR = 1.D0/DENITR(YMAX)
      DO 20 I=1,25
      YMID = (YMN + YMX) / 2.D0
      XX = DENITR(YMID)/RDNR
      IF (XX.GT.RN) YMX = YMID
  20  IF (XX.LT.RN) YMN = YMID
      Y(LB)=YMID
      TRPAR=TRPAR+DTRPAR
      RETURN
      END
C
      FUNCTION VNEWL(VTHX,VDRIFT)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      DATA WING/7.0D0/
      X0=VDRIFT/VTHX
      XMAX=.5D0*(X0+DSQRT(2.0D0+X0*X0))
      ZMAX=XMAX*DEXP(-(XMAX-X0)**2)
      XMIN=X0-WING
      IF(XMIN.LT.0.0D0)XMIN=0.0D0
      XDIF=X0+WING-XMIN
  100 X=XDIF*RANF(0.0D0)+XMIN
      EX=DEXP(-(X-X0)**2)
      TAU=X*EX
      Z=ZMAX*RANF(0.0D0)
      IF(Z.GT.TAU)GO TO 100
      VNEWL=VTHX*X
      RETURN
      END
C
      SUBROUTINE INJBAT(KSP0,NTHOLE)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C     INJECT PARTICLES IN NEW BATCH
C
      PARAMETER (NBB=512)
      PARAMETER(NC1 = 78885)
      PARAMETER (N1D=5000)
      COMMON  PBUF(NBB,5),Q(NC1),TEMP(2*N1D),TBUF(5,NBB)
      COMMON/POTEN1/ SS(NC1),W(NC1),AX(NC1)
      COMMON/POTEN2/ AX1(NC1),AY(NC1),AY1(NC1)
      COMMON/POTEN3/ AZ(NC1),AZ1(NC1)
      COMMON/CURR/ CX(NC1),CY(NC1),CZ(NC1)
      COMMON/EFIELD/EX(NC1),EY(NC1),EZ(NC1),BX(NC1),BY(NC1),BZ(NC1)
      COMMON/QBK/ QBK(NC1)
      DIMENSION X(NBB),Y(NBB),VX(NBB),VY(NBB),VZ(NBB)
      EQUIVALENCE (X(1),PBUF(1,1)),(Y(1),PBUF(1,2)),(VX(1),PBUF(1,3)),
     *  (VY(1),PBUF(1,4)),(VZ(1),PBUF(1,5))

      PARAMETER (NYY=514)
      PARAMETER(NNS=25)
      PARAMETER (NDIM=503)
      PARAMETER(NNS1=NNS+1,NNS2=NNS*2)
C
      PARAMETER(NCL=3*NYY)
C
      COMMON/FKICK/XKICK,DXKICK, YK1,YK2,FNKICK,VMPXH,VMPYH,EHEAT
     1 ,VOSC,DELE,DLASER,TWIDTH,TPEAK,XLASER
      COMMON/PARAM/IT,NC,NB,NP,IMPSW,NRAND,KJSMTH,KQSMTH,
     *    KEI,KEE,KSP,NPTIME,
     *    NSP,NPX(NNS),NPY(NNS),NSPEC(NNS),IDNX(NNS1),IDNY(NNS1),
     *    IBCNDL(NNS),IBCNDR(NNS),IBCNDT(NNS),IBCNDB(NNS),
     *    LOADED(NNS),LOSTL(NNS),LOSTR(NNS),INJL(NNS),INJR(NNS)
      COMMON/PARAMR/ PI,T,AA,SINA,SINP,TDLAZ,AMPH,PHAS,VEA,FNK,
     *    TAU,TAU1,TAU2,EXC,EYC,EZC,BXC,BYC,BZC,WSPEC(NNS),QSPEC(NNS),
     *    AYL(NCL),AYR(NCL),AYLD(NCL),AYRD(NCL),
     *    AZL(NCL),AZR(NCL),AZLD(NCL),AZRD(NCL),
     *    VMPX(NNS),VMPY(NNS),VMPZ(NNS),
     *    XDRIFT(NNS),YDRIFT(NNS),ZDRIFT(NNS),
     *    XN(NNS2),DENX(NNS2),YN(NNS2),DENY(NNS2),
     *    XLJ(NNS),XRJ(NNS),XTJ(NNS),XBJ(NNS),FEREM,AFRACR,
     *    DINJR(NNS),DINJL(NNS),VINJR(NNS),VINJL(NNS),
     *    TINJR(NNS),TINJL(NNS),IBATCH(NNS)
      COMMON /PARAM1/ EKX(NNS),EKY(NNS),EKZ(NNS),EKJ(NNS),
     *    VLIMA,VLIMB,VXAVGA,VXAVGB,VYAVGA,
     *    VYAVGB,VZAVGA,VZAVGB,TFIN,EFIN,
     *    TDEC(NDIM),EDEC(NDIM,6),ELOSTB,AVPOYN,APOYNT(N1D),
     *    EPOUTR(50),EPOUTL(50),EPOUTB(50),EPOUTT(50),
     *    EPINR(50),EPINL(50),EPINB(50),EPINT(50),
     *    DEP,TEP,EPMAX,KSPLIT,NPTSA,NPTSB,NPLOT,NENRG,NHIST,NFT1,NFT2,
     *    NENRG2,KDIAG,LDEC,NEP
C
      COMMON/PARCM/NX,NY,L3,L4,KBND,NX2,NX1,NY1,NY2,IBCDL,IBCDR,
     *   IBCDT,IBCDB,KBR,LSTL,LSTR,NINJL,NINJR,KBNDY,INOP,
     *   XMAX,YMAX,DT,QMULT,WMULT,XLEFT,XRIGHT,
     *   HX,HY,HXI,HYI,VMPX1,VMPY1,
     *   VMPZ1,ELOST,QLOSTL,QLOSTR,QLOSTT,QLOSTB,
     *   YTOP,YBOT,DRINJ,DLINJ,VRINJ,VLINJ,
     *   TRPAR,TLPAR,DTLPAR,DTRPAR,QINJL,QINJR,EINJ
C
      COMMON /PARBD1/ JB,LB,IB(NBB),IBEG,IEND
C
C     CHECK IF ANY PARTICLES TO INJECT
C
      IF(((TLPAR .LT. TPART(T)) .AND. (IBCDL .EQ. 6)) .OR.
     1((TRPAR .LT. TPART(T)) .AND. (IBCDR .EQ. 6)).OR.
     1((QLOSTL/QMULT.GT.0.75D0).AND. (IBCDL.EQ.7) ) .OR.
     1((QLOSTR/QMULT.GT.0.75D0).AND. (IBCDR.EQ.7) )) THEN
      LB = 0
C
C     INJECT - LEFT - ELECTROMAGNETIC
C
C
C     WRITE OUT OLD BATCH
C
      KSP0 = KSP
      CALL PUTB(PBUF,L4,KSP0,TBUF)
  100 IF(((QLOSTL/QMULT .GT.0.75D0) .AND.(IBCDL.EQ.7))  .OR.
     1  ((TLPAR .LT. TPART(T)) .AND.  (IBCDL .EQ. 6))) THEN
	   LB = LB + 1
	   CALL LINJ
	   EPIN = VX(LB)**2 + VY(LB)**2 + VZ(LB)**2
	   IF (KBR.EQ.3) EPIN = 2.D0*(DSQRT(EPIN+1.D0)-1.D0)
	   EPIN  = WMULT * EPIN
	   ELOST = ELOST - EPIN
	   EINJ = EINJ + EPIN
	   IEPI=MIN0(NEP,1+INT(EPIN/DEP))
	   EPINL(IEPI)=EPINL(IEPI)+EPIN
	   QLOSTL = QLOSTL - QMULT
	   IF(LB .LT. NB)GO TO 100
C
C     WRITE OUT NEW FULL BATCH
C
	   KSP0 = KSP
	   DTSAV=DT
	   DT=0.0D0
	   L4=NB
	   IF (KBR.EQ.1) THEN
		CALL PARMVE
	   ELSE IF (KBR.EQ.2) THEN
		CALL PARMOV
	   ELSE
		CALL PARMVR
	   ENDIF
	   DT=DTSAV
	   CALL PUTB(PBUF,NB,KSP0,TBUF)
	   LB = 0
	   GO TO 100
      ENDIF
C
C     INJECT - RIGHT - ELECTROMAGNETIC
C
  300 IF(((QLOSTR/QMULT .GT.0.75D0) .AND.(IBCDR.EQ.7))  .OR.
     1((TRPAR .LT. TPART(T)) .AND.  (IBCDR .EQ. 6))) THEN
	   LB = LB + 1
	   CALL RINJ
	   EPIN = VX(LB)**2 + VY(LB)**2 + VZ(LB)**2
	   IF (KBR.EQ.3) EPIN = 2.D0*(DSQRT(EPIN+1.D0)-1.D0)
	   EPIN  = WMULT * EPIN
	   ELOST = ELOST - EPIN
	   EINJ = EINJ + EPIN
	   IEPI=MIN0(NEP,1+INT(EPIN/DEP))
	   EPINR(IEPI)=EPINR(IEPI)+EPIN
	   QLOSTR = QLOSTR - QMULT
	   IF(LB .LT. NB)GO TO 300
C
C     WRITE OUT NEW FULL BATCH
C
	   KSP0 = KSP
	   DTSAV=DT
	   DT=0.0D0
	   L4=NB
	   IF (KBR.EQ.1) THEN
		CALL PARMVE
	   ELSE IF (KBR.EQ.2) THEN
		CALL PARMOV
	   ELSE
		CALL PARMVR
	   ENDIF
	   DT=DTSAV
	   CALL PUTB(PBUF,NB,KSP0,TBUF)
	   LB = 0
	   GO TO 300
      ENDIF
C
C     WRITE OUT NEW PARTIAL BATCH
C
       IF(TRPAR .GT. TINJR(KSP)) TINJR(KSP) = TRPAR
       IF(TLPAR .GT. TINJL(KSP))TINJL(KSP) = TLPAR
       INJR (KSP) = NINJR
       INJL (KSP) = NINJL
       IF(LB .EQ. 0)RETURN
       IF((LB/2)*2 .NE. LB) THEN
C
C      NUMBER OF PARTICLES IS ODD, MAKE EVEN
C
	   NTHOLE = NTHOLE + 1
	   LB = LB + 1
	   X(LB) = -1.D0
	   Y(LB) = 0.0D0
	   VX(LB) = 0.0D0
	   VY(LB) = 0.0D0
	   VZ(LB) = 0.0D0
      ENDIF
      KSP0=KSP
      DTSAV=DT
      DT=0.0D0
      L4=LB
      IF (KBR.EQ.1) THEN
	   CALL PARMVE
      ELSE IF (KBR.EQ.2) THEN
	   CALL PARMOV
      ELSE
	   CALL PARMVR
      ENDIF
      DT=DTSAV
      CALL PUTB(PBUF,LB,KSP0,TBUF)
      ENDIF
      RETURN
      END
C
      SUBROUTINE INJALL
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C     INJECT PARTICLES IN HOLES
C
      PARAMETER (NBB=512)
      PARAMETER(NC1 = 78885)
      PARAMETER (N1D=5000)
      COMMON  PBUF(NBB,5),Q(NC1),TEMP(2*N1D),TBUF(5,NBB)
      COMMON/POTEN1/ SS(NC1),W(NC1),AX(NC1)
      COMMON/POTEN2/ AX1(NC1),AY(NC1),AY1(NC1)
      COMMON/POTEN3/ AZ(NC1),AZ1(NC1)
      COMMON/CURR/ CX(NC1),CY(NC1),CZ(NC1)
      COMMON/EFIELD/EX(NC1),EY(NC1),EZ(NC1),BX(NC1),BY(NC1),BZ(NC1)
      COMMON/QBK/ QBK(NC1)
      DIMENSION X(NBB),Y(NBB),VX(NBB),VY(NBB),VZ(NBB)
      EQUIVALENCE (X(1),PBUF(1,1)),(Y(1),PBUF(1,2)),(VX(1),PBUF(1,3)),
     *  (VY(1),PBUF(1,4)),(VZ(1),PBUF(1,5))

      PARAMETER (NYY=514)
      PARAMETER(NNS=25)
      PARAMETER (NDIM=503)
      PARAMETER(NNS1=NNS+1,NNS2=NNS*2)
C
      PARAMETER(NCL=3*NYY)
C
      COMMON/FKICK/XKICK,DXKICK, YK1,YK2,FNKICK,VMPXH,VMPYH,EHEAT
     1 ,VOSC,DELE,DLASER,TWIDTH,TPEAK,XLASER
      COMMON/PARAM/IT,NC,NB,NP,IMPSW,NRAND,KJSMTH,KQSMTH,
     *    KEI,KEE,KSP,NPTIME,
     *    NSP,NPX(NNS),NPY(NNS),NSPEC(NNS),IDNX(NNS1),IDNY(NNS1),
     *    IBCNDL(NNS),IBCNDR(NNS),IBCNDT(NNS),IBCNDB(NNS),
     *    LOADED(NNS),LOSTL(NNS),LOSTR(NNS),INJL(NNS),INJR(NNS)
      COMMON/PARAMR/ PI,T,AA,SINA,SINP,TDLAZ,AMPH,PHAS,VEA,FNK,
     *    TAU,TAU1,TAU2,EXC,EYC,EZC,BXC,BYC,BZC,WSPEC(NNS),QSPEC(NNS),
     *    AYL(NCL),AYR(NCL),AYLD(NCL),AYRD(NCL),
     *    AZL(NCL),AZR(NCL),AZLD(NCL),AZRD(NCL),
     *    VMPX(NNS),VMPY(NNS),VMPZ(NNS),
     *    XDRIFT(NNS),YDRIFT(NNS),ZDRIFT(NNS),
     *    XN(NNS2),DENX(NNS2),YN(NNS2),DENY(NNS2),
     *    XLJ(NNS),XRJ(NNS),XTJ(NNS),XBJ(NNS),FEREM,AFRACR,
     *    DINJR(NNS),DINJL(NNS),VINJR(NNS),VINJL(NNS),
     *    TINJR(NNS),TINJL(NNS),IBATCH(NNS)
      COMMON /PARAM1/ EKX(NNS),EKY(NNS),EKZ(NNS),EKJ(NNS),
     *    VLIMA,VLIMB,VXAVGA,VXAVGB,VYAVGA,
     *    VYAVGB,VZAVGA,VZAVGB,TFIN,EFIN,
     *    TDEC(NDIM),EDEC(NDIM,6),ELOSTB,AVPOYN,APOYNT(N1D),
     *    EPOUTR(50),EPOUTL(50),EPOUTB(50),EPOUTT(50),
     *    EPINR(50),EPINL(50),EPINB(50),EPINT(50),
     *    DEP,TEP,EPMAX,KSPLIT,NPTSA,NPTSB,NPLOT,NENRG,NHIST,NFT1,NFT2,
     *    NENRG2,KDIAG,LDEC,NEP
C
      COMMON/PARCM/NX,NY,L3,L4,KBND,NX2,NX1,NY1,NY2,IBCDL,IBCDR,
     *   IBCDT,IBCDB,KBR,LSTL,LSTR,NINJL,NINJR,KBNDY,INOP,
     *   XMAX,YMAX,DT,QMULT,WMULT,XLEFT,XRIGHT,
     *   HX,HY,HXI,HYI,VMPX1,VMPY1,
     *   VMPZ1,ELOST,QLOSTL,QLOSTR,QLOSTT,QLOSTB,
     *   YTOP,YBOT,DRINJ,DLINJ,VRINJ,VLINJ,
     *   TRPAR,TLPAR,DTLPAR,DTRPAR,QINJL,QINJR,EINJ
C
      COMMON /PARBD1/ JB,LB,IB(NBB),IBEG,IEND
      IF(DT .EQ. 0.0D0)RETURN
      LL = L3
C
C     INJECT - LEFT - ELECTROMAGNETIC
C
  100 IF((TLPAR .LT. TPART(T)) .AND. (IBCDL .EQ. 6).OR.
     1   (QLOSTL/QMULT.GT.-.75D0) .AND. (IBCDL .EQ. 7)) THEN
      DO 10 J=LL,L4
      LB=J
   10 IF(X(LB).LT.0) GO TO 110
C     NUMBER = L4 + 1 - LL
C
C     LOOK AT MAXIMUM GROUP OF 64
C
C     IF(NUMBER .GT. 64)NUMBER = 64
C     NMASK = MASKVM(X(LL),NUMBER,1)
C     LB = LEADZ(NMASK)
C     IF(LB .LT. 64)GO TO 110
C
C     NONE IN THIS GROUP, TRY NEXT 64
C
C     LL = LL + 64
C
C     IF NONE, THEN BATCH IS FULL
C
C     IF(LL .GT. L4)GO TO 400
      RETURN
  110  CONTINUE
C 110 LB = LB + LL
  999 IF(.FALSE.)GO TO 999
C     IF(LB .GT. L4)GO TO 400
      CALL LINJ
      EPIN = VX(LB)**2 + VY(LB)**2 + VZ(LB)**2
      IF (KBR.EQ.3) EPIN = 2.D0*(DSQRT(EPIN+1.D0)-1.D0)
      EPIN  = WMULT * EPIN
      ELOST = ELOST - EPIN
      EINJ = EINJ + EPIN
      IEPI=MIN0(NEP,1+INT(EPIN/DEP))
      EPINL(IEPI)=EPINL(IEPI)+EPIN
      QLOSTL = QLOSTL - QMULT
      LL = LB + 1
      IF(LL .LE. L4)GO TO 100
      RETURN
C
C     INJECT - RIGHT - ELECTROMAGNETIC
C
      ELSE
  300 IF((TRPAR .LT. TPART(T)) .AND. (IBCDR .EQ. 6) .OR.
     1  (QLOSTR/QMULT.GT.-.75D0) .AND. (IBCDR .EQ. 7)) THEN
C     NUMBER = L4 + 1 - LL
C
C     LOOK AT MAXIMUM GROUP OF 64
C
      DO 20 J=LL,L4
      LB=J
   20 IF (X(LB).LT.0) GO TO 310
      RETURN
C     IF(NUMBER .GT. 64)NUMBER = 64
C     NMASK = MASKVM(X(LL),NUMBER,1)
C     LB = LEADZ(NMASK)
C     IF(LB .LT. 64)GO TO 310
C
C     NONE IN THIS GROUP, TRY NEXT 64
C
C     LL = LL + 64
C
C     IF NONE, THEN BATCH IS FULL
C
C     IF(LL .GT. L4)GO TO 400
C     GO TO 300
C 310 LB = LB + LL
  310 CONTINUE
C     IF(LB .GT. L4)GO TO 400
      CALL RINJ
      EPIN = VX(LB)**2 + VY(LB)**2 + VZ(LB)**2
      IF (KBR.EQ.3) EPIN = 2.D0*(DSQRT(EPIN+1.D0)-1.D0)
      EPIN  = WMULT * EPIN
      ELOST = ELOST - EPIN
      EINJ = EINJ + EPIN
      IEPI=MIN0(NEP,1+INT(EPIN/DEP))
      EPINR(IEPI)=EPINR(IEPI)+EPIN
      QLOSTR = QLOSTR - QMULT
      LL = LB + 1
      IF(LL .LE. L4)GO TO 300
      RETURN
      ENDIF
      ENDIF
      RETURN
      END
C
      SUBROUTINE INJCON(NTHOLE)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C      CONSOLIDATE BATCH
C
      PARAMETER (NBB=512)
      PARAMETER(NC1 = 78885)
      PARAMETER (N1D=5000)
      COMMON  PBUF(NBB,5),Q(NC1),TEMP(2*N1D),TBUF(5,NBB)
      COMMON/POTEN1/ SS(NC1),W(NC1),AX(NC1)
      COMMON/POTEN2/ AX1(NC1),AY(NC1),AY1(NC1)
      COMMON/POTEN3/ AZ(NC1),AZ1(NC1)
      COMMON/CURR/ CX(NC1),CY(NC1),CZ(NC1)
      COMMON/EFIELD/EX(NC1),EY(NC1),EZ(NC1),BX(NC1),BY(NC1),BZ(NC1)
      COMMON/QBK/ QBK(NC1)
      DIMENSION X(NBB),Y(NBB),VX(NBB),VY(NBB),VZ(NBB)
      EQUIVALENCE (X(1),PBUF(1,1)),(Y(1),PBUF(1,2)),(VX(1),PBUF(1,3)),
     *  (VY(1),PBUF(1,4)),(VZ(1),PBUF(1,5))

      COMMON/PARCM/NX,NY,L3,L4,KBND,NX2,NX1,NY1,NY2,IBCDL,IBCDR,
     *   IBCDT,IBCDB,KBR,LSTL,LSTR,NINJL,NINJR,KBNDY,INOP,
     *   XMAX,YMAX,DT,QMULT,WMULT,XLEFT,XRIGHT,
     *   HX,HY,HXI,HYI,VMPX1,VMPY1,
     *   VMPZ1,ELOST,QLOSTL,QLOSTR,QLOSTT,QLOSTB,
     *   YTOP,YBOT,DRINJ,DLINJ,VRINJ,VLINJ,
     *   TRPAR,TLPAR,DTLPAR,DTRPAR,QINJL,QINJR,EINJ
C
      PARAMETER (NYY=514)
      PARAMETER(NNS=25)
      PARAMETER (NDIM=503)
      PARAMETER(NNS1=NNS+1,NNS2=NNS*2)
C
      PARAMETER(NCL=3*NYY)
C
      COMMON/FKICK/XKICK,DXKICK, YK1,YK2,FNKICK,VMPXH,VMPYH,EHEAT
     1 ,VOSC,DELE,DLASER,TWIDTH,TPEAK,XLASER
      COMMON/PARAM/IT,NC,NB,NP,IMPSW,NRAND,KJSMTH,KQSMTH,
     *    KEI,KEE,KSP,NPTIME,
     *    NSP,NPX(NNS),NPY(NNS),NSPEC(NNS),IDNX(NNS1),IDNY(NNS1),
     *    IBCNDL(NNS),IBCNDR(NNS),IBCNDT(NNS),IBCNDB(NNS),
     *    LOADED(NNS),LOSTL(NNS),LOSTR(NNS),INJL(NNS),INJR(NNS)
      COMMON/PARAMR/ PI,T,AA,SINA,SINP,TDLAZ,AMPH,PHAS,VEA,FNK,
     *    TAU,TAU1,TAU2,EXC,EYC,EZC,BXC,BYC,BZC,WSPEC(NNS),QSPEC(NNS),
     *    AYL(NCL),AYR(NCL),AYLD(NCL),AYRD(NCL),
     *    AZL(NCL),AZR(NCL),AZLD(NCL),AZRD(NCL),
     *    VMPX(NNS),VMPY(NNS),VMPZ(NNS),
     *    XDRIFT(NNS),YDRIFT(NNS),ZDRIFT(NNS),
     *    XN(NNS2),DENX(NNS2),YN(NNS2),DENY(NNS2),
     *    XLJ(NNS),XRJ(NNS),XTJ(NNS),XBJ(NNS),FEREM,AFRACR,
     *    DINJR(NNS),DINJL(NNS),VINJR(NNS),VINJL(NNS),
     *    TINJR(NNS),TINJL(NNS),IBATCH(NNS)
      COMMON /PARAM1/ EKX(NNS),EKY(NNS),EKZ(NNS),EKJ(NNS),
     *    VLIMA,VLIMB,VXAVGA,VXAVGB,VYAVGA,
     *    VYAVGB,VZAVGA,VZAVGB,TFIN,EFIN,
     *    TDEC(NDIM),EDEC(NDIM,6),ELOSTB,AVPOYN,APOYNT(N1D),
     *    EPOUTR(50),EPOUTL(50),EPOUTB(50),EPOUTT(50),
     *    EPINR(50),EPINL(50),EPINB(50),EPINT(50),
     *    DEP,TEP,EPMAX,KSPLIT,NPTSA,NPTSB,NPLOT,NENRG,NHIST,NFT1,NFT2,
     *    NENRG2,KDIAG,LDEC,NEP
C
      NHOLES = 0
      LOOK = 1
      LB = 0
C
C     COUNT NUMBER OF HOLES IN BATCH
C
      DO 200 L=L3,L4
C
C     LB IS ADDRESS OF FIRST HOLE
C
      IF(LB.EQ.0.AND.X(L).LT.0) LB=L
  200 IF(X(L).LT.0) NHOLES = NHOLES + 1
C 100 NUMBER = L4 + 1 - LOOK
C     IF(NUMBER .GT. 64)NUMBER = 64
C     NMASK =  MASKVM(X(LOOK),NUMBER,1)
C     MHOLES = POPCNT(NMASK)
C     IF(MHOLES .EQ. 0)GO TO 200
C     NHOLES = NHOLES + MHOLES
C     IF(LB .EQ. 0)LB = LOOK + LEADZ(NMASK)
C 200 LOOK = LOOK + NUMBER
C     IF(LOOK .LE. L4)GO TO 100
C
C     NOW HAVE NUMBER OF HOLES, RETURN IF < NB / 4
C
      NTHOLE = NTHOLE + NHOLES
      IF(NHOLES .LT. NB / 4)RETURN
C
C     WRING HOLES OUT OF BATCH, RESET L4
C
      LOUT = LB - 1
      LIN = LB + 1
  250 IF(X(LIN) .GE. 0.0D0) THEN
	   LOUT = LOUT + 1
	   X(LOUT) = X(LIN)
	   Y(LOUT) = Y(LIN)
	   VX(LOUT) = VX(LIN)
	   VY(LOUT) = VY(LIN)
	   VZ(LOUT) = VZ(LIN)
      ENDIF
      LIN = LIN + 1
      IF(LIN .LE. L4)GO TO 250
      L4 = LOUT
      NTHOLE=NTHOLE-NHOLES
      IF((L4/2)*2 .EQ. L4)RETURN
C
C      NUMBER OF PARTICLES IS ODD, MAKE EVEN
C
      L4 = L4 + 1
      X(L4) = -1.D0
      Y(L4) = 0.0D0
      VX(L4) = 0.0D0
      VY(L4) = 0.0D0
      VZ(L4) = 0.0D0
      NTHOLE = NTHOLE + 1
      RETURN
      END
C
      SUBROUTINE INJCHK(NTHOLE)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      PARAMETER (N1D=5000)
      COMMON/PARCM/NX,NY,L3,L4,KBND,NX2,NX1,NY1,NY2,IBCDL,IBCDR,
     *   IBCDT,IBCDB,KBR,LSTL,LSTR,NINJL,NINJR,KBNDY,INOP,
     *   XMAX,YMAX,DT,QMULT,WMULT,XLEFT,XRIGHT,
     *   HX,HY,HXI,HYI,VMPX1,VMPY1,
     *   VMPZ1,ELOST,QLOSTL,QLOSTR,QLOSTT,QLOSTB,
     *   YTOP,YBOT,DRINJ,DLINJ,VRINJ,VLINJ,
     *   TRPAR,TLPAR,DTLPAR,DTRPAR,QINJL,QINJR,EINJ
C
      PARAMETER (NYY=514)
      PARAMETER(NNS=25)
      PARAMETER (NDIM=503)
      PARAMETER(NNS1=NNS+1,NNS2=NNS*2)
C
      PARAMETER(NCL=3*NYY)
C
      COMMON/FKICK/XKICK,DXKICK, YK1,YK2,FNKICK,VMPXH,VMPYH,EHEAT
     1 ,VOSC,DELE,DLASER,TWIDTH,TPEAK,XLASER
      COMMON/PARAM/IT,NC,NB,NP,IMPSW,NRAND,KJSMTH,KQSMTH,
     *    KEI,KEE,KSP,NPTIME,
     *    NSP,NPX(NNS),NPY(NNS),NSPEC(NNS),IDNX(NNS1),IDNY(NNS1),
     *    IBCNDL(NNS),IBCNDR(NNS),IBCNDT(NNS),IBCNDB(NNS),
     *    LOADED(NNS),LOSTL(NNS),LOSTR(NNS),INJL(NNS),INJR(NNS)
      COMMON/PARAMR/ PI,T,AA,SINA,SINP,TDLAZ,AMPH,PHAS,VEA,FNK,
     *    TAU,TAU1,TAU2,EXC,EYC,EZC,BXC,BYC,BZC,WSPEC(NNS),QSPEC(NNS),
     *    AYL(NCL),AYR(NCL),AYLD(NCL),AYRD(NCL),
     *    AZL(NCL),AZR(NCL),AZLD(NCL),AZRD(NCL),
     *    VMPX(NNS),VMPY(NNS),VMPZ(NNS),
     *    XDRIFT(NNS),YDRIFT(NNS),ZDRIFT(NNS),
     *    XN(NNS2),DENX(NNS2),YN(NNS2),DENY(NNS2),
     *    XLJ(NNS),XRJ(NNS),XTJ(NNS),XBJ(NNS),FEREM,AFRACR,
     *    DINJR(NNS),DINJL(NNS),VINJR(NNS),VINJL(NNS),
     *    TINJR(NNS),TINJL(NNS),IBATCH(NNS)
      COMMON /PARAM1/ EKX(NNS),EKY(NNS),EKZ(NNS),EKJ(NNS),
     *    VLIMA,VLIMB,VXAVGA,VXAVGB,VYAVGA,
     *    VYAVGB,VZAVGA,VZAVGB,TFIN,EFIN,
     *    TDEC(NDIM),EDEC(NDIM,6),ELOSTB,AVPOYN,APOYNT(N1D),
     *    EPOUTR(50),EPOUTL(50),EPOUTB(50),EPOUTT(50),
     *    EPINR(50),EPINL(50),EPINB(50),EPINT(50),
     *    DEP,TEP,EPMAX,KSPLIT,NPTSA,NPTSB,NPLOT,NENRG,NHIST,NFT1,NFT2,
     *    NENRG2,KDIAG,LDEC,NEP
C
      CALL NUMB(IBATCH,NUMSP)
      INJ=0
      LTOT=0
      LDSK=0
      DO 10 KSP = 1, NSP
      IF(IBCNDR(KSP).GE.6.OR.IBCNDL(KSP).GE.6) THEN
	   IF(TINJR(KSP).LT.TPART(T) .AND. (IBCNDR(KSP).EQ.6))
     +        CALL ENDRUN('INJECTR' )
	   IF(TINJL(KSP).LT.TPART(T) .AND. (IBCNDL(KSP).EQ.6))
     +        CALL ENDRUN('INJECTL')
	   INJ=INJ+1
	   NINJL = INJL(KSP)
	   NINJR = INJR(KSP)
	   LSTR = LOSTR(KSP)
	   LSTL = LOSTL(KSP)
	   INJT = INJR(KSP) + INJL(KSP)
	   LOSTT = LOSTR(KSP) + LOSTL(KSP)
	   ITOT = INJT - LOSTT
	   LTOT=LTOT+ITOT+NPX(KSP)*NPY(KSP)
	   LDSK=LDSK+IBATCH(KSP)
	   IF(MOD(IT,50).EQ.0)
     +         WRITE(9,1000) T,KSP,ITOT,INJL(KSP),INJR(KSP)
     +         ,INJT,LOSTL(KSP),LOSTR(KSP),LOSTT,IBATCH(KSP)
      ENDIF
 10   CONTINUE
      IF(INJ.EQ.0) RETURN
      IST=LDSK-LTOT-NTHOLE
      IF(IABS(IST).NE.0) THEN
          WRITE(9,1300) T,IST,LDSK,LTOT,NTHOLE
          IF (IABS(IST).GT.5) CALL ENDRUN('NUMBER')
      ENDIF
      QDIV = DABS(QMULT)
      IF(MOD(IT,5).EQ.0) THEN
           WRITE(9,1100) QLOSTL/QDIV,QLOSTR/QDIV,NTHOLE
           WRITE(9,1200) QLOSTL,QLOSTR
      ENDIF
      RETURN
 1000 FORMAT(3X,'TIME= ',F10.5,' SPECIES = ',I7,' NET INJECTED= ',I7/,
     +'  INJECTED: (LEFT)= ',I7,' (RIGHT)= ',I7,' TOTAL= ',I7/,
     +'  LOST: (LEFT)    = ',I7,' (RIGHT)= ',I7,' TOTAL= ',I7,
     +' TOTAL ON DISK= ',I7)
 1100 FORMAT(3X,' NO. LOST LEFT= ',F15.5,' NO LOST RIGHT= ',F15.5,
     +   '  HOLES= ',I7)
 1200 FORMAT(3X,'CHARGE LOST LEFT= ',E15.5,' CHARGE LOST RIGHT= ',E15.5)
 1300 FORMAT('T= ',F12.5,' IST= ',I5,' DISK= ',I10,
     1 ' TOTAL= ',I10,' NTHOLES= ',I10)
      END

      FUNCTION ERF(X)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DATA A1/.0705230784D0/,
     C     A2/.0422820123D0/,
     C     A3/.0092705272D0/,
     C     A4/.0001520143D0/,
     C     A5/.0002765672D0/,
     C     A6/.0000430638D0/
      A=A1+X*(A2+X*(A3+X*(A4+X*(A5+X*A6))))
      ERF=1.D0-1.D0/(1.D0+A*X)**16
      RETURN
      END

      SUBROUTINE FIELD
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      PARAMETER (NBB=512)
      PARAMETER(NC1 = 78885)
      PARAMETER (N1D=5000)
      COMMON  PBUF(NBB,5),Q(NC1),TEMP(2*N1D),TBUF(5,NBB)
      COMMON/POTEN1/ SS(NC1),W(NC1),AX(NC1)
      COMMON/POTEN2/ AX1(NC1),AY(NC1),AY1(NC1)
      COMMON/POTEN3/ AZ(NC1),AZ1(NC1)
      COMMON/CURR/ CX(NC1),CY(NC1),CZ(NC1)
      COMMON/EFIELD/EX(NC1),EY(NC1),EZ(NC1),BX(NC1),BY(NC1),BZ(NC1)
      COMMON/QBK/ QBK(NC1)
      DIMENSION X(NBB),Y(NBB),VX(NBB),VY(NBB),VZ(NBB)
      EQUIVALENCE (X(1),PBUF(1,1)),(Y(1),PBUF(1,2)),(VX(1),PBUF(1,3)),
     *  (VY(1),PBUF(1,4)),(VZ(1),PBUF(1,5))

      COMMON/PARCM/NX,NY,L3,L4,KBND,NX2,NX1,NY1,NY2,IBCDL,IBCDR,
     *   IBCDT,IBCDB,KBR,LSTL,LSTR,NINJL,NINJR,KBNDY,INOP,
     *   XMAX,YMAX,DT,QMULT,WMULT,XLEFT,XRIGHT,
     *   HX,HY,HXI,HYI,VMPX1,VMPY1,
     *   VMPZ1,ELOST,QLOSTL,QLOSTR,QLOSTT,QLOSTB,
     *   YTOP,YBOT,DRINJ,DLINJ,VRINJ,VLINJ,
     *   TRPAR,TLPAR,DTLPAR,DTRPAR,QINJL,QINJR,EINJ
C
      PARAMETER (NYY=514)
      PARAMETER(NNS=25)
      PARAMETER (NDIM=503)
      PARAMETER(NNS1=NNS+1,NNS2=NNS*2)
C
      PARAMETER(NCL=3*NYY)
C
      COMMON/FKICK/XKICK,DXKICK, YK1,YK2,FNKICK,VMPXH,VMPYH,EHEAT
     1 ,VOSC,DELE,DLASER,TWIDTH,TPEAK,XLASER
      COMMON/PARAM/IT,NC,NB,NP,IMPSW,NRAND,KJSMTH,KQSMTH,
     *    KEI,KEE,KSP,NPTIME,
     *    NSP,NPX(NNS),NPY(NNS),NSPEC(NNS),IDNX(NNS1),IDNY(NNS1),
     *    IBCNDL(NNS),IBCNDR(NNS),IBCNDT(NNS),IBCNDB(NNS),
     *    LOADED(NNS),LOSTL(NNS),LOSTR(NNS),INJL(NNS),INJR(NNS)
      COMMON/PARAMR/ PI,T,AA,SINA,SINP,TDLAZ,AMPH,PHAS,VEA,FNK,
     *    TAU,TAU1,TAU2,EXC,EYC,EZC,BXC,BYC,BZC,WSPEC(NNS),QSPEC(NNS),
     *    AYL(NCL),AYR(NCL),AYLD(NCL),AYRD(NCL),
     *    AZL(NCL),AZR(NCL),AZLD(NCL),AZRD(NCL),
     *    VMPX(NNS),VMPY(NNS),VMPZ(NNS),
     *    XDRIFT(NNS),YDRIFT(NNS),ZDRIFT(NNS),
     *    XN(NNS2),DENX(NNS2),YN(NNS2),DENY(NNS2),
     *    XLJ(NNS),XRJ(NNS),XTJ(NNS),XBJ(NNS),FEREM,AFRACR,
     *    DINJR(NNS),DINJL(NNS),VINJR(NNS),VINJL(NNS),
     *    TINJR(NNS),TINJL(NNS),IBATCH(NNS)
      COMMON /PARAM1/ EKX(NNS),EKY(NNS),EKZ(NNS),EKJ(NNS),
     *    VLIMA,VLIMB,VXAVGA,VXAVGB,VYAVGA,
     *    VYAVGB,VZAVGA,VZAVGB,TFIN,EFIN,
     *    TDEC(NDIM),EDEC(NDIM,6),ELOSTB,AVPOYN,APOYNT(N1D),
     *    EPOUTR(50),EPOUTL(50),EPOUTB(50),EPOUTT(50),
     *    EPINR(50),EPINL(50),EPINB(50),EPINT(50),
     *    DEP,TEP,EPMAX,KSPLIT,NPTSA,NPTSB,NPLOT,NENRG,NHIST,NFT1,NFT2,
     *    NENRG2,KDIAG,LDEC,NEP
C
C     DIMENSION IB(2)
      EQUIVALENCE (BZ0,BZC), (EY0,EYC), (EX0,EXC)
      EXTERNAL RANF
      DIMENSION VDOT(NC1), V(NC1)
      DIMENSION BC(4)
      DIMENSION BD(4)
      EQUIVALENCE (VDOT,SS), (V,W)
      DIMENSION BDY1(4),BDY2(4)
       DATA BC /1.D0,0.D0,1.D0,0.D0/,BDY1/0.D0,0.D0,0.D0,0.D0/,
     * BDY2/0.D0,0.D0,0.D0,0.D0/
C     DATA IB /2,2/
      NX1=NX+1
      NY1=NY+1
      NX2=NX+2
      NY2=NY+2
      NX2NY=NX2*NY
      NX2NY1=NX2*NY1
      NX2NY2=NX2*NY2
      NXD=NX2
      NXD1=NXD+1
      NXD2=NXD+2
      NXDNY=NXD*NY
      NXDNY1=NXD*NY1
      NXDNY2=NXD*NY2
      NXD1NY=NXD*NY+1
      NXD2NY=NXD*NY+2
      HX=XMAX/NX
      HY=YMAX/NY
      HXI=1.D0/HX
      HYI=1.D0/HY
      DTI=1.D0/DT
      HXI2=.5D0*HXI
      HXI4=.5D0*HXI2
      HYI2=.5D0*HYI
      HYI4=.5D0*HYI2
      HXSQI=HXI**2
      HYSQI=HYI**2
      DTSQ=DT**2
      HXY=HX*HYI
      BC(3)=1.D0
      IF(KBND.EQ.0) BC(1)=0.D0
      IF(KBNDY.EQ.1) THEN
C
C       BDY1 IS USED TO SET  F = 0 AT Y BOUNDARIES
C
            BDY1(1)=1.D0
            BDY1(3)=1.D0
C
C       BDY2 IS USED TO SET DF/DY = 0 AT Y BOUNDARIES
C
            BDY2(2)=1.D0
            BDY2(4)=1.D0
      ENDIF
      PHAS=PHAS+2.D0*AMPH*(.5D0-RANF(0.0D0))*DT
      TA=T/TDLAZ
      AMP=AA
      IF (TA.LT.1) AMP=AA*(10.D0*TA**3-15.D0*TA**4+6.D0*TA**5)
      COSA=DSQRT(1.D0-SINA**2)
      CPI=1.D0/(1.D0+DT*HXI)
      CMP=(1.D0-DT*HXI)*CPI
      DCI=4.D0*DT*CPI
      CPI=CPI*DT*HXI
      QFAC=0.D0
      IF (NP.GT.0) QFAC=1.D0
      QFX=QFAC*HXI
      QFX2=QFX/2.D0
      QFY=QFAC*HYI
      QFY2=QFY/2.D0
      COSP=DSQRT(1.D0-SINP**2)
      DTSQI=1.D0/DTSQ
      CFT=-4.D0*DTSQI
      CL=1.D0
      BF12=.5D0*DT*CL*HXI
      BF34=.5D0*DT*HXI
      BF1=.5D0-BF12
      BF2=.5D0+BF12
      BF3=.5D0-BF34
      BF4=.5D0+BF34
      KBSW=KBND+1
      IF (KBND.EQ.0) THEN
           BD(1)=0.D0
           BD(2)=0.D0
           BD(3)=0.D0
           BD(4)=0.D0
      ELSE IF (KBND.EQ.1) THEN
           BD(1)=1.0D0
           BD(2)=.5D0*DT*CL
           BD(3)=1.0D0
           BD(4)=.5D0*DT
      ELSE
 40        BD(1)=1.D0
           BD(2)=0.D0
           BD(3)=1.D0
           BD(4)=0.D0
           IF (T.LE.TDLAZ) AMP=.5D0*AA*T**2/TDLAZ
           IF (T.GT.TDLAZ) AMP=AA*(T-.5D0*TDLAZ)
      ENDIF
      AXC=-AMP*SINP*SINA
      AYC=AMP*SINP*COSA
      AZC=AMP*COSP
      CAYIN=DCI*AYC
      CAZIN=DCI*AZC
      AXDT2=AXC*2.D0*DT
      AYDT2=AYC*2.D0*DT
      AZDT2=AZC*2.D0*DT
C
      DKX=COSA*HX
      DKY=SINA*HY
C
      QAV=0.D0
      DO 70 IJ1=NXD2,NXD2NY,NXD
      V(IJ1-1)=0.D0
      Q1=0.D0
      IJ2=IJ1+NX-1
           DO 60 IJ=IJ1,IJ2
           V(IJ)=-QFAC*Q(IJ)
           Q1=Q1+Q(IJ)
   60      CONTINUE
      V(IJ2+1)=0.D0
      QAV=QAV+Q1
   70 CONTINUE
C
C     SET  PHI = 0 AT Y BOUNDARIES
C
      DO 75 IJ=1,NX2
      V(IJ)=0
      V(IJ+NXDNY1)=0.D0
 75   CONTINUE
      IF (DABS(QAV).GT.1.D-13*NP) WRITE (9,530) QAV
      IF (KBND.EQ.2) THEN
C
C          PHI= 0 AT X = 0,XMAX
C
           BC(1) = 0.0D0
           BC(2) = 1.0D0
           BC(3) = 1.0D0
           BC(4) = 0.0D0
      ENDIF
      CALL SOLV2Y(NX2,NY2,HX,HY,0.0D0,V,BC,BDY1,BX)
      IF (IMPSW.GE.0) THEN
C
C       ELECTROMAGNETIC FIELD SOLVE
C
      DO 90 IJ1=NXD2,NXD2NY,NXD
      VDOT(IJ1-1)=0.D0
      IJ2=IJ1+NX-1
           DO 80 IJ=IJ1,IJ2
           VDOT(IJ)=QFX2*(CX(IJ+1)-CX(IJ-1))
     1              +QFY2*(CY(IJ+NXD)-CY(IJ-NXD))
   80      CONTINUE
      VDOT(IJ2+1)=0.D0
   90 CONTINUE
C
C     SET D VDOT/DY  = 0 AT Y BOUNDARIES
C
      DO 95 IJ=1,NX2
      VDOT(IJ)=0.D0
      VDOT(IJ+NXDNY1)=0.D0
 95   CONTINUE
      IF(KBND.EQ.2) THEN
C
C          SET D VDOT /DX = 0 AT X = 0,XMAX
C
           BC(1) = 0.0D0
           BC(2) = 1.0D0
           BC(3) = 0.0D0
           BC(4) = 1.0D0
      ENDIF
      CALL SOLV2Y(NX2,NY2,HX,HY,0.0D0,VDOT,BC,BDY1,BX)
      ENDIF
      IF (IMPSW.EQ.0) THEN
C
C     EXPLICIT VECTOR POTENTIAL
C
      IF(KBND.EQ.1) CALL ADVBND
C
C     CALCULATE AY
C
      TK=T-.5D0*DKY
      TK=TK+PHAS
      DO 220 IJ1=NXD2,NXD2NY,NXD
      TK=TK-DKY
      FIN=DSIN(TK)
      IJ2=IJ1+NX-1
      DO 200 IJ=IJ1,IJ2
      Q(IJ)=2.D0*AY(IJ)-AY1(IJ)
     1 +DTSQ*( HXSQI*(AY(IJ+1)+AY(IJ-1)-2*AY(IJ))
     1        +HYSQI*(AY(IJ+NXD)+AY(IJ-NXD)-2.D0*AY(IJ))
     1 +QFAC*(.25D0*CY(IJ-NXD)+.5D0*CY(IJ)+.25D0*CY(IJ+NXD))
     1        -HYI2*(VDOT(IJ+NXD)-VDOT(IJ-NXD)))
  200 CONTINUE
      IJ=IJ2+1
      IF(KBND.GE.2) THEN
C
C     SET AY=0 AT X = 0,XMAX
C
           Q(IJ)=-Q(IJ-1)
           Q(IJ-NX-1)=-Q(IJ-NX)
      ELSE IF (KBND.EQ.0) THEN
C
C          PERIODIC IN X BOUNDARY CONDITIONS
C
           Q(IJ)=Q(IJ-NX)
           Q(IJ-NX-1)=Q(IJ-1)
      ELSE IF(KBND.EQ.1) THEN
C
C          OUTGOING LIGHT WAVE BOUNDARY CONDITIONS
C
           Q(IJ-NX1)=CMP*(AY(IJ-NX1)-Q(IJ-NX))+AY(IJ-NX)
     1               +CPI*AY1(IJ-NX1)-CAYIN*FIN
           Q(IJ)=CMP*(AY(IJ)-Q(IJ-1))+AY(IJ-1)+CPI*AY1(IJ)
      ENDIF
 220  CONTINUE
      IF(KBND.EQ.1) THEN
           ASL=0.D0
           ASR=0.D0
           DO 230 IJ=NXD1,NXD1NY,NXD
           ASL=Q(IJ)-ASL
           ASR=Q(IJ+NX1)-ASR
  230      CONTINUE
           ASL=ASL/NY
           ASR=ASR/NY
           DO 240 IJ=NXD1,NXD1NY,NXD
           Q(IJ)=Q(IJ)+ASL
           ASL=-ASL
           Q(IJ+NX1)=Q(IJ+NX1)+ASR
           ASR=-ASR
  240      CONTINUE
  250      CONTINUE
      ENDIF
      IF(KBNDY.EQ.0) THEN
           NB1=NXDNY
           NB2=NXD
           FAC=1.D0
      ELSE
C
C          SET D AY/DY = 0 AT Y BOUNDARIES
C
           NB1=NXD
           NB2=NXDNY
           FAC=1.D0
      ENDIF
      DO 260 IJ=1,NX2
      Q(IJ)=FAC*Q(IJ+NB1)
      Q(IJ+NXDNY1)=FAC*Q(IJ+NB2)
  260 CONTINUE
C
C     REPLACE AY WITH NEW VALUES
C
      DO 270 IJ=1,NXDNY2
      AY1(IJ)=AY(IJ)
  270 AY(IJ)=Q(IJ)
C
C     CALCULATE AX
C
      TK=T-.5D0*DKY
      TK=TK+PHAS
      DO 130 IJ1=NXD2,NXD2NY,NXD
      TK=TK-DKY
      FIN=DSIN(TK)
      IJ2=IJ1+NX-1
      DO 110 IJ=IJ1,IJ2
      Q(IJ)=2.D0*AX(IJ)-AX1(IJ)
     1+DTSQ*(HXSQI*(AX(IJ+1)+AX(IJ-1)-2.D0*AX(IJ))
     1       +HYSQI*(AX(IJ+NXD)+AX(IJ-NXD)-2.D0*AX(IJ))
     1+QFAC*(.25D0*CX(IJ-1)+.5D0*CX(IJ)+.25D0*CX(IJ+1))
     1       -HXI2*(VDOT(IJ+1)-VDOT(IJ-1)))
  110 CONTINUE
      IJ=IJ2+1
      IF(KBND.GE.2) THEN
C
C        SET D AX/DX = 0. AT X = 0,XMAX
C
           Q(IJ)=Q(IJ-1)
           Q(IJ-NX-1)=Q(IJ-NX)
      ELSE IF(KBND.EQ.0) THEN
           Q(IJ)=Q(IJ-NX)
           Q(IJ-NX-1)=Q(IJ-1)
      ELSE IF(KBND.EQ.1) THEN
           IJ=IJ-NX1
           Q(IJ)=Q(IJ+1)+Q(IJ+1-NXD)
     1           +HXY*(AY(IJ)+AY(IJ+1)-AY(IJ-NXD)-AY(IJ+1-NXD))
           IJ=IJ+NX1
           Q(IJ)=Q(IJ-1)+Q(IJ-1-NXD)
     1           -HXY*(AY(IJ)+AY(IJ-1)-AY(IJ-NXD)-AY(IJ-1-NXD))
      ENDIF
 130  CONTINUE
      IF(KBND.EQ.1) THEN
           Q(1)=0.D0
           Q(NX2)=0.D0
           ASL=0.D0
           ASR=0.D0
           DO 140 IJ=NXD1,NXD1NY,NXD
           Q(IJ)=Q(IJ)-Q(IJ-NXD)
           ASL=Q(IJ)-ASL
           Q(IJ+NX1)=Q(IJ+NX1)-Q(IJ-1)
           ASR=Q(IJ+NX1)-ASR
  140      CONTINUE
           ASL=ASL/NY
           ASR=ASR/NY
           DO 150 IJ=NXD1,NXD1NY,NXD
           Q(IJ)=Q(IJ)+ASL
           ASL=-ASL
           Q(IJ+NX1)=Q(IJ+NX1)+ASR
           ASR=-ASR
  150      CONTINUE
  160      CONTINUE
      ENDIF
      IF(KBNDY.EQ.0) THEN
C
C          PERIODIC IN Y
C
           NB1=NXDNY
           NB2=NXD
           FAC=1.D0
      ELSE
C
C          SET AX = 0 AT Y BOUNDARIES
C
           NB1=NXD
           NB2=NXDNY
           FAC=-1
      ENDIF
      DO 170 IJ=1,NX2
      Q(IJ)=FAC*Q(IJ+NB1)
      Q(IJ+NXDNY1)=FAC*Q(IJ+NB2)
  170 CONTINUE
C
C     REPLACE AY WITH NEW AY
C
      DO 180 IJ=1,NXDNY2
      AX1(IJ)=AX(IJ)
  180 AX(IJ)=Q(IJ)
C
C     CALCULATE AZ
C
      TK=T-.5D0*DKY
      TK=TK+PHAS
      DO 310 IJ1=NXD2,NXD2NY,NXD
      TK=TK-DKY
      FIN=DSIN(TK)
      IJ2=IJ1+NX-1
      DO 290 IJ=IJ1,IJ2
      Q(IJ)=2.D0*AZ(IJ)-AZ1(IJ)
     1 +DTSQ*(HXSQI*(AZ(IJ+1)+AZ(IJ-1)-2.D0*AZ(IJ))
     1       +HYSQI*(AZ(IJ+NXD)+AZ(IJ-NXD)-2.D0*AZ(IJ))
     2 +QFAC*CZ(IJ))
  290 CONTINUE
      IJ=IJ2+1
      IF(KBND.GE.2) THEN
C
C     SET AZ=0 AT BOTH X BOUNDARIES
C
           Q(IJ)=-Q(IJ-1)
           Q(IJ-NX-1)=-Q(IJ-NX)
      ELSE IF (KBND.EQ.0) THEN
C
C     PERIODIC IN X
C
           Q(IJ)=Q(IJ-NX)
           Q(IJ-NX-1)=Q(IJ-1)
      ELSE IF(KBND.EQ.1) THEN
C
C     OUTGOING WAVES IN X
C
           Q(IJ-NX1)=CMP*(AZ(IJ-NX1)-Q(IJ-NX))+AZ(IJ-NX)
     1               +CPI*AZ1(IJ-NX1)-CAZIN*FIN
           Q(IJ)=CMP*(AZ(IJ)-Q(IJ-1))+AZ(IJ-1)+CPI*AZ1(IJ)
      ENDIF
 310  CONTINUE
      IF(KBNDY.EQ.0) THEN
C
C     PERIODIC IN Y
C
           NB1=NXDNY
           NB2=NXD
           FAC=1.D0
      ELSE
C
C          SET  AZ = 0 AT Y BOUNDARIES
C
           NB1=NXD
           NB2=NXDNY
           FAC=-1.D0
      ENDIF
      DO 320 IJ=1,NX2
      Q(IJ)=FAC*Q(IJ+NB1)
      Q(IJ+NXDNY1)=FAC*Q(IJ+NB2)
  320 CONTINUE
C
C     SET AZ TO NEW AZ
C
      DO 330 IJ=1,NXDNY2
      AZ1(IJ)=AZ(IJ)
  330 AZ(IJ)=Q(IJ)
C
      ELSE IF (IMPSW.EQ.1) THEN
C
C    IMPLICIT FIELD SOLVER
C
C
C     CALCULATE AX
C
      TK=T-.5D0*DKY
      DO 370 IJ1=NXD2,NXD2NY,NXD
      TK=TK-DKY
      IJ2=IJ1+NX-1
      DO 350 IJ=IJ1,IJ2
      Q(IJ)=-4.D0*QFAC*(.25D0*CX(IJ-1)+.5D0*CX(IJ)+.25D0*CX(IJ+1))
     1 +4.D0*HXI2*(VDOT(IJ+1)-VDOT(IJ-1))
     1 -DTSQI*(8.D0*AX(IJ)-4.D0*AX1(IJ))
     1 -2.D0*HXSQI*(AX(IJ+1)+AX(IJ-1)-2.D0*AX(IJ))
     1 -2.D0*HYSQI*(AX(IJ+NXD)+AX(IJ-NXD)-2.D0*AX(IJ))
     1    -HXSQI*(AX1(IJ+1)+AX1(IJ-1)-2.D0*AX1(IJ))
     1    -HYSQI*(AX1(IJ+NXD)+AX1(IJ-NXD)-2.D0*AX1(IJ))
  350 CONTINUE
      IJ=IJ2+1
      IF(KBND.EQ.1) THEN
C
C     OUTGOING WAVE BOUNDARY CONDITIONS
C
           Q(IJ-NX-1)=BF1*AX(IJ-NX-1)+BF2*AX(IJ-NX)+2.*AXDT2*DCOS(TK)
           Q(IJ)=BF3*AX(IJ)+BF4*AX(IJ-1)
      ELSE IF (KBND.EQ.2) THEN
C
C
           Q(IJ-NX-1)=0.D0
           Q(IJ)=0.D0
      ENDIF
 370  CONTINUE
C
C     SET  AX = 0 AT Y = 0,YMAX FOR KBNDY=1
C
      DO 375 IJ=1,NX2
      Q(IJ)=0
      Q(IJ+NXDNY1)=0.D0
 375  CONTINUE
      IF(KBND.EQ.2) THEN
C
C     SET D AX /DX = 0 AT X = 0,XMAX
C
           BC(1) = 0.0D0
           BC(2) = 1.0D0
           BC(3) = 0.0D0
           BC(4) = 1.0D0
      ENDIF
      CALL SOLV2Y(NX2,NY2,HX,HY,CFT,Q,BC,BDY1,BX)
C
C     SET AX TO NEW AX
C
      DO 380 IJ=1,NXDNY2
      AX1(IJ)=AX(IJ)
  380 AX(IJ)=Q(IJ)
C
C     CALCULATE AY
C
      TK=T-.5D0*DKY
      DO 410 IJ1=NXD2,NXD2NY,NXD
      TK=TK-DKY
      IJ2=IJ1+NX-1
      DO 390 IJ=IJ1,IJ2
      Q(IJ)=-4.D0*QFAC*(.25D0*CY(IJ-NXD)+.5D0*CY(IJ)+.25D0*CY(IJ+NXD))
     1 +4.D0*HYI2*(VDOT(IJ+NXD)-VDOT(IJ-NXD))
     1 -DTSQI*(8.D0*AY(IJ)-4.D0*AY1(IJ))
     1 -2.D0*HXSQI*(AY(IJ+1)+AY(IJ-1)-2.D0*AY(IJ))
     1 -2.D0*HYSQI*(AY(IJ+NXD)+AY(IJ-NXD)-2.D0*AY(IJ))
     1    -HXSQI*(AY1(IJ+1)+AY1(IJ-1)-2.D0*AY1(IJ))
     1    -HYSQI*(AY1(IJ+NXD)+AY1(IJ-NXD)-2.D0*AY1(IJ))
  390 CONTINUE
      IJ=IJ2+1
      IF(KBND.EQ.1) THEN
C
C     OUTGOING WAVE BOUNDARY CONDITIONS
C
           Q(IJ-NX-1)=BF1*AY(IJ-NX-1)+BF2*AY(IJ-NX)+2.D0*AYDT2*DCOS(TK)
           Q(IJ)=BF3*AY(IJ)+BF4*AY(IJ-1)
      ELSE IF (KBND.EQ.2) THEN
C
C     SET AY = 0 AT X=0 AND AY=AYC AT X=XMAX
C
           Q(IJ-NX-1)=0.D0
           Q(IJ)=AYC
      ENDIF
  410 CONTINUE
C
C     SET  D AY/DY = 0 AT Y BOUNDARIES  IF KBNDY=1
C
      DO 415 IJ=1,NX2
      Q(IJ)=0.D0
      Q(IJ+NXDNY1)=0.D0
 415  CONTINUE
      CALL SOLV2Y(NX2,NY2,HX,HY,CFT,Q,BD,BDY2,BX)
C
C     SET AY TO NEW AY
C
      DO 420 IJ=1,NXDNY2
      AY1(IJ)=AY(IJ)
  420 AY(IJ)=Q(IJ)
C
C     CALCULATE AZ
C
      TK=T-.5D0*DKY
      DO 450 IJ1=NXD2,NXD2NY,NXD
      TK=TK-DKY
      IJ2=IJ1+NX-1
      DO 430 IJ=IJ1,IJ2
      Q(IJ)=-4.D0*QFAC*CZ(IJ)
     1 -DTSQI*(8.D0*AZ(IJ)-4.D0*AZ1(IJ))
     1 -2.D0*HXSQI*(AZ(IJ+1)+AZ(IJ-1)-2.D0*AZ(IJ))
     1 -2.D0*HYSQI*(AZ(IJ+NXD)+AZ(IJ-NXD)-2.D0*AZ(IJ))
     1    -HXSQI*(AZ1(IJ+1)+AZ1(IJ-1)-2.*AZ1(IJ))
     1    -HYSQI*(AZ1(IJ+NXD)+AZ1(IJ-NXD)-2.*AZ1(IJ))
  430 CONTINUE
      IJ=IJ2+1
      IF (KBND.EQ.1) THEN
C
C     OUTGOING WAVES IN X
C
           Q(IJ-NX-1)=BF1*AZ(IJ-NX-1)+BF2*AZ(IJ-NX)+2.D0*AZDT2*DCOS(TK)
           Q(IJ)=BF3*AZ(IJ)+BF4*AZ(IJ-1)
      ELSE IF(KBND.EQ.2) THEN
C
C     AZ = 0 AT X = 0 AND AZ = AZC AT Y=YMAX
           Q(IJ-NX-1)=0.D0
           Q(IJ)=AZC
      ENDIF
  450 CONTINUE
C
C     SET  AZ = 0 AT Y BOUNDARIES, IF KBNDY = 1
C
      DO 455 IJ=1,NX2
      Q(IJ)=0.D0
      Q(IJ+NXDNY1)=0.D0
 455  CONTINUE
      CALL SOLV2Y(NX2,NY2,HX,HY,CFT,Q,BD,BDY1,BX)
C
C     SET AZ TO NEW AZ
C
      DO 460 IJ=1,NXDNY2
      AZ1(IJ)=AZ(IJ)
  460 AZ(IJ)=Q(IJ)
C
      ENDIF
      IF (IMPSW.GE.0) THEN
C
C     CALCULATE NEW EX,EY,EZ,BX,BY,BZ
C
      DO 490 IJ1=NXD2,NXD2NY,NXD
      IJ2=IJ1+NX-1
      DO 480 IJ=IJ1,IJ2
      EX(IJ)=EXC-HXI2*(V(IJ+1)-V(IJ-1))
     1 -DTI*(.5D0*(AX(IJ)-AX1(IJ))
     1      +.25D0*(AX(IJ+NXD)-AX1(IJ+NXD)+AX(IJ-NXD)-AX1(IJ-NXD)))
      EY(IJ)=EYC-HYI2*(V(IJ+NXD)-V(IJ-NXD))
     1 -DTI*(.5D0*(AY(IJ)-AY1(IJ))
     1       +.25D0*(AY(IJ+1)-AY1(IJ+1)+AY(IJ-1)-AY1(IJ-1)))
      EZ(IJ)=EZC-DTI*(.25D0*(AZ(IJ)-AZ1(IJ))
     1 +.125D0*(AZ(IJ+NXD)-AZ1(IJ+NXD)+AZ(IJ-NXD)-AZ1(IJ-NXD)
     1       +AZ(IJ+1)-AZ1(IJ+1)+AZ(IJ-1)-AZ1(IJ-1))
     1 +.0625D0*(AZ(IJ+1+NXD)-AZ1(IJ+1+NXD)+AZ(IJ-1-NXD)-AZ1(IJ-1-NXD)
     1        +AZ(IJ-1+NXD)-AZ1(IJ-1+NXD)+AZ(IJ+1-NXD)-AZ1(IJ+1-NXD)))
      BX(IJ)=HYI4*(AZ(IJ+NXD)-AZ(IJ-NXD)+AZ1(IJ+NXD)-AZ1(IJ-NXD)) + BXC
      BY(IJ)=-HXI4*(AZ(IJ+1)-AZ(IJ-1)+AZ1(IJ+1)-AZ1(IJ-1)) + BYC
      BZ(IJ)=HXI4*(AY(IJ+1)-AY(IJ-1)+AY1(IJ+1)-AY1(IJ-1))
     1      -HYI4*(AX(IJ+NXD)-AX(IJ-NXD)+AX1(IJ+NXD)-AX1(IJ-NXD))
     1 +BZ0
  480 CONTINUE
  490 CONTINUE
C
C     SET BOUNDARY CONDITIONS AT X=0,XMAX
C
      IF(KBND.NE.0) THEN
           NB1=1
           NB2=NX
           FAC=-1.D0
      ELSE
           NB1=NX
           NB2=1
           FAC=1.D0
      ENDIF
      DO 510 IJ=NXD1,NXD1NY,NXD
      EX(IJ)=FAC*EX(IJ+NB1)
      EY(IJ)=EY(IJ+NB1)
      EZ(IJ)=EZ(IJ+NB1)
      BX(IJ)=BX(IJ+NB1)
      BY(IJ)=BY(IJ+NB1)
      BZ(IJ)=BZ(IJ+NB1)
      EX(IJ+NX1)=FAC*EX(IJ+NB2)
      EY(IJ+NX1)=EY(IJ+NB2)
      EZ(IJ+NX1)=EZ(IJ+NB2)
      BX(IJ+NX1)=BX(IJ+NB2)
      BY(IJ+NX1)=BY(IJ+NB2)
      BZ(IJ+NX1)=BZ(IJ+NB2)
  510 CONTINUE
      IF(KBNDY.EQ.0) THEN
           NB1=NXDNY
           NB2=NXD
      ELSE
           NB1=NXD
           NB2=NXDNY
      ENDIF
      DO 520 IJ=1,NX2
      EX(IJ)=EX(IJ+NB1)
      EY(IJ)=EY(IJ+NB1)
      EZ(IJ)=EZ(IJ+NB1)
      BX(IJ)=BX(IJ+NB1)
      BY(IJ)=BY(IJ+NB1)
      BZ(IJ)=BZ(IJ+NB1)
      EX(IJ+NXDNY1)=EX(IJ+NB2)
      EY(IJ+NXDNY1)=EY(IJ+NB2)
      EZ(IJ+NXDNY1)=EZ(IJ+NB2)
      BX(IJ+NXDNY1)=BX(IJ+NB2)
      BY(IJ+NXDNY1)=BY(IJ+NB2)
      BZ(IJ+NXDNY1)=BZ(IJ+NB2)
  520 CONTINUE
C
      ELSE
C
C     CALCULATE NEW EX,EY : PURE ELECTROSTATIC
C
      DO 540 IJ1=NXD2,NXD2NY,NXD
      IJ2=IJ1+NX-1
      DO 535 IJ=IJ1,IJ2
      EX(IJ)=EXC-HXI2*(V(IJ+1)-V(IJ-1))
      EY(IJ)=EYC-HYI2*(V(IJ+NXD)-V(IJ-NXD))
  535 CONTINUE
  540 CONTINUE
C
C     SET BOUNDARY CONDITIONS AT X=0,XMAX
C
      IF(KBND.NE.0) THEN
           NB1=1
           NB2=NX
           FAC=-1.D0
      ELSE
           NB1=NX
           NB2=1
           FAC=1.D0
      ENDIF
      DO 550 IJ=NXD1,NXD1NY,NXD
      EX(IJ)=FAC*EX(IJ+NB1)
      EY(IJ)=EY(IJ+NB1)
      EX(IJ+NX1)=FAC*EX(IJ+NB2)
      EY(IJ+NX1)=EY(IJ+NB2)
  550 CONTINUE
      IF(KBNDY.EQ.0) THEN
           NB1=NXDNY
           NB2=NXD
      ELSE
           NB1=NXD
           NB2=NXDNY
      ENDIF
      DO 560 IJ=1,NX2
      EX(IJ)=EX(IJ+NB1)
      EY(IJ)=EY(IJ+NB1)
      EX(IJ+NXDNY1)=EX(IJ+NB2)
      EY(IJ+NXDNY1)=EY(IJ+NB2)
  560 CONTINUE
C
      DO 570 IJ=1,NX2NY2
      EZ(IJ)=EZC
      BX(IJ)=BXC
      BY(IJ)=BYC
      BZ(IJ)=BZC
 570  CONTINUE
      ENDIF
      RETURN
  530 FORMAT (' CHARGE IMBALANCE = ',E15.5)
      END

      SUBROUTINE ADVBND
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      COMMON/PARCM/NX,NY,L3,L4,KBND,NX2,NX1,NY1,NY2,IBCDL,IBCDR,
     *   IBCDT,IBCDB,KBR,LSTL,LSTR,NINJL,NINJR,KBNDY,INOP,
     *   XMAX,YMAX,DT,QMULT,WMULT,XLEFT,XRIGHT,
     *   HX,HY,HXI,HYI,VMPX1,VMPY1,
     *   VMPZ1,ELOST,QLOSTL,QLOSTR,QLOSTT,QLOSTB,
     *   YTOP,YBOT,DRINJ,DLINJ,VRINJ,VLINJ,
     *   TRPAR,TLPAR,DTLPAR,DTRPAR,QINJL,QINJR,EINJ
C
      PARAMETER (NBB=512)
      PARAMETER(NC1 = 78885)
      PARAMETER (N1D=5000)
      COMMON  PBUF(NBB,5),Q(NC1),TEMP(2*N1D),TBUF(5,NBB)
      COMMON/POTEN1/ SS(NC1),W(NC1),AX(NC1)
      COMMON/POTEN2/ AX1(NC1),AY(NC1),AY1(NC1)
      COMMON/POTEN3/ AZ(NC1),AZ1(NC1)
      COMMON/CURR/ CX(NC1),CY(NC1),CZ(NC1)
      COMMON/EFIELD/EX(NC1),EY(NC1),EZ(NC1),BX(NC1),BY(NC1),BZ(NC1)
      COMMON/QBK/ QBK(NC1)
      DIMENSION X(NBB),Y(NBB),VX(NBB),VY(NBB),VZ(NBB)
      EQUIVALENCE (X(1),PBUF(1,1)),(Y(1),PBUF(1,2)),(VX(1),PBUF(1,3)),
     *  (VY(1),PBUF(1,4)),(VZ(1),PBUF(1,5))

      PARAMETER (NYY=514)
      PARAMETER(NNS=25)
      PARAMETER (NDIM=503)
      PARAMETER(NNS1=NNS+1,NNS2=NNS*2)
C
      PARAMETER(NCL=3*NYY)
C
      COMMON/FKICK/XKICK,DXKICK, YK1,YK2,FNKICK,VMPXH,VMPYH,EHEAT
     1 ,VOSC,DELE,DLASER,TWIDTH,TPEAK,XLASER
      COMMON/PARAM/IT,NC,NB,NP,IMPSW,NRAND,KJSMTH,KQSMTH,
     *    KEI,KEE,KSP,NPTIME,
     *    NSP,NPX(NNS),NPY(NNS),NSPEC(NNS),IDNX(NNS1),IDNY(NNS1),
     *    IBCNDL(NNS),IBCNDR(NNS),IBCNDT(NNS),IBCNDB(NNS),
     *    LOADED(NNS),LOSTL(NNS),LOSTR(NNS),INJL(NNS),INJR(NNS)
      COMMON/PARAMR/ PI,T,AA,SINA,SINP,TDLAZ,AMPH,PHAS,VEA,FNK,
     *    TAU,TAU1,TAU2,EXC,EYC,EZC,BXC,BYC,BZC,WSPEC(NNS),QSPEC(NNS),
     *    AYL(NCL),AYR(NCL),AYLD(NCL),AYRD(NCL),
     *    AZL(NCL),AZR(NCL),AZLD(NCL),AZRD(NCL),
     *    VMPX(NNS),VMPY(NNS),VMPZ(NNS),
     *    XDRIFT(NNS),YDRIFT(NNS),ZDRIFT(NNS),
     *    XN(NNS2),DENX(NNS2),YN(NNS2),DENY(NNS2),
     *    XLJ(NNS),XRJ(NNS),XTJ(NNS),XBJ(NNS),FEREM,AFRACR,
     *    DINJR(NNS),DINJL(NNS),VINJR(NNS),VINJL(NNS),
     *    TINJR(NNS),TINJL(NNS),IBATCH(NNS)
      COMMON /PARAM1/ EKX(NNS),EKY(NNS),EKZ(NNS),EKJ(NNS),
     *    VLIMA,VLIMB,VXAVGA,VXAVGB,VYAVGA,
     *    VYAVGB,VZAVGA,VZAVGB,TFIN,EFIN,
     *    TDEC(NDIM),EDEC(NDIM,6),ELOSTB,AVPOYN,APOYNT(N1D),
     *    EPOUTR(50),EPOUTL(50),EPOUTB(50),EPOUTT(50),
     *    EPINR(50),EPINL(50),EPINB(50),EPINT(50),
     *    DEP,TEP,EPMAX,KSPLIT,NPTSA,NPTSB,NPLOT,NENRG,NHIST,NFT1,NFT2,
     *    NENRG2,KDIAG,LDEC,NEP
C
      DIMENSION EYOUTL(NC1), EZOUTL(NC1-NYY), EYINL(NC1-2*NYY),
     1 EZINL(NC1-3*NYY)
      DIMENSION EYOUTR(NC1-4*NYY), EZOUTR(NC1-5*NYY), EYINR(NC1-6*NYY),
     1 EZINR(NC1-7*NYY)
      EQUIVALENCE (EYOUTL,Q), (EZOUTL,Q(NYY+1)), (EYINL,Q(2*NYY+1)),
     1 (EZINL,Q(3*NYY+1)), (EYOUTR,Q(4*NYY+1)), (EZOUTR,Q(5*NYY+1)),
     2 (EYINR,Q(6*NYY+1)), (EZINR,Q(7*NYY+1))
      DIMENSION ALPHA(3),BETA(3)
      SAVE ALPHA, BETA,ISET,INISW,TYS,DTIH,HXIQ,IDIAGR,NAB,NJMAX
      DATA ISET /1/
      DATA INISW /0/
C
      IF (ISET.EQ.1) GO TO 130
   10 CONTINUE
C
C-----DIAGNOSTICS
C
      IJ=2
      DO 30 J=1,NY2
      RYL=0.D0
      RZL=0.D0
      RYR=0.D0
      RZR=0.D0
      NJ=J
      DO 20 N=1,NAB
      AL=ALPHA(N)
      RYL=RYL+AL*AYL(NJ)
      RZL=RZL+AL*AZL(NJ)
      IF (IDIAGR.NE.0) THEN
         RYR=RYR+AL*AYR(NJ)
         RZR=RZR+AL*AZR(NJ)
      ENDIF
   20 NJ=NJ+NY2
      EYL=-DTIH*(AY(IJ)+AY(IJ-1)-AY1(IJ)-AY1(IJ-1))
      EYOUTL(J)=.5D0*EYL-HXIQ*(AY(IJ)+AY1(IJ)-AY(IJ-1)-AY1(IJ-1)-RYL)
      EYINL(J)=EYL-EYOUTL(J)
      EZL=-DTIH*(AZ(IJ)+AZ(IJ-1)-AZ1(IJ)-AZ1(IJ-1))
      EZOUTL(J)=.5D0*EZL-HXIQ*(AZ(IJ)+AZ1(IJ)-AZ(IJ-1)-AZ1(IJ-1)-RZL)
      EZINL(J)=EZL-EZOUTL(J)
      IJ=IJ+NX
      IF (IDIAGR.NE.0) THEN
         EYR=-DTIH*(AY(IJ)+AY(IJ-1)-AY1(IJ)-AY1(IJ-1))
         EYOUTR(J)=.5D0*EYR+HXIQ*(AY(IJ)+AY1(IJ)-AY(IJ-1)-AY1(IJ-1)+RYR)
         EYINR(J)=EYR-EYOUTR(J)
         EZR=-DTIH*(AZ(IJ)+AZ(IJ-1)-AZ1(IJ)-AZ1(IJ-1))
         EZOUTR(J)=.5D0*EZR+HXIQ*(AZ(IJ)+AZ1(IJ)-AZ(IJ-1)-AZ1(IJ-1)+RZR)
         EZINR(J)=EZR-EZOUTR(J)
      ENDIF
   30 IJ=IJ+2
C
C----BOUNDARY CONDITION
C
      IJ=NX2+1
      DO 60 J=2,NY1
      IJP=IJ+NX2
      IJM=IJ-NX2
      RYL=2.D0*(AY(IJ+1)+AY1(IJ+1)-AY(IJ)-AY1(IJ))+AY(IJP)+AY1(IJP)
     1 +AY(IJM)+AY1(IJM)-AY(IJP+1)-AY1(IJP+1)-AY(IJM+1)-AY1(IJM+1)
      RZL=2.D0*(AZ(IJ+1)+AZ1(IJ+1)-AZ(IJ)-AZ1(IJ))+AZ(IJP)+AZ1(IJP)
     1 +AZ(IJM)+AZ1(IJM)-AZ(IJP+1)-AZ1(IJP+1)-AZ(IJM+1)-AZ1(IJM+1)
      IJ=IJ+NX1
      IJP=IJ+NX2
      IJM=IJ-NX2
      RYR=2.D0*(AY(IJ-1)+AY1(IJ-1)-AY(IJ)-AY1(IJ))+AY(IJP)+AY1(IJP)
     1 +AY(IJM)+AY1(IJM)-AY(IJP-1)-AY1(IJP-1)-AY(IJM-1)-AY1(IJM-1)
      RZR=2.D0*(AZ(IJ-1)+AZ1(IJ-1)-AZ(IJ)-AZ1(IJ))+AZ(IJP)+AZ1(IJP)
     1 +AZ(IJM)+AZ1(IJM)-AZ(IJP-1)-AZ1(IJP-1)-AZ(IJM-1)-AZ1(IJM-1)
      NJ=J
      DO 50 N=1,NAB
      BT=BETA(N)
      AYLD(NJ)=AYLD(NJ)+RYL+BT*(AYL(NJ+1)-2.D0*AYL(NJ)+AYL(NJ-1))
      AZLD(NJ)=AZLD(NJ)+RZL+BT*(AZL(NJ+1)-2.D0*AZL(NJ)+AZL(NJ-1))
      AYRD(NJ)=AYRD(NJ)+RYR+BT*(AYR(NJ+1)-2.D0*AYR(NJ)+AYR(NJ-1))
      AZRD(NJ)=AZRD(NJ)+RZR+BT*(AZR(NJ+1)-2.D0*AZR(NJ)+AZR(NJ-1))
   50 NJ=NJ+NY2
   60 IJ=IJ+1
C
      DO 80 J=2,NY1
      NJ=J
      DO 70 N=1,NAB
      AYL(NJ)=AYL(NJ)+AYLD(NJ)
      AZL(NJ)=AZL(NJ)+AZLD(NJ)
      AYR(NJ)=AYR(NJ)+AYRD(NJ)
      AZR(NJ)=AZR(NJ)+AZRD(NJ)
   70 NJ=NJ+NY2
   80 CONTINUE
C
      NJ=1
      DO 90 N=1,NAB
      AYL(NJ)=AYL(NJ+NY)
      AZL(NJ)=AZL(NJ+NY)
      AYR(NJ)=AYR(NJ+NY)
      AZR(NJ)=AZR(NJ+NY)
      NJ=NJ+1
      AYL(NJ+NY)=AYL(NJ)
      AZL(NJ+NY)=AZL(NJ)
      AYR(NJ+NY)=AYR(NJ)
      AZR(NJ+NY)=AZR(NJ)
   90 NJ=NJ+NY1
C
      IJ=1
      DO 120 J=1,NY2
      RYL=0.D0
      RZL=0.D0
      RYR=0.D0
      RZR=0.D0
      IF (NAB.EQ.0) GO TO 110
      NJ=J
      DO 100 N=1,NAB
      AL=ALPHA(N)
      RYL=RYL+AL*AYL(NJ)
      RZL=RZL+AL*AZL(NJ)
      RYR=RYR+AL*AYR(NJ)
      RZR=RZR+AL*AZR(NJ)
  100 NJ=NJ+NY2
  110 CONTINUE
      AY1(IJ)=-RYL
      AZ1(IJ)=-RZL
      IJ=IJ+NX1
      AY1(IJ)=-RYR
      AZ1(IJ)=-RZR
  120 IJ=IJ+1
      RETURN
C
      ENTRY INIBND
      INISW=1
  130 NX1=NX+1
      NX2=NX+2
      NY1=NY+1
      NY2=NY+2
      HY=YMAX/NY
      TYS=(DT/HY)**2
      DTIH=.5D0/DT
      HXIQ=.25D0/HX
      IDIAGR=1
      NAB=3
      ALPHA(1)=.32645D0
      ALPHA(2)=.12716D0
      ALPHA(3)=.030905D0
      BETA(1)=.73754D0
      BETA(2)=.983846D0
      BETA(3)=.99964720D0
      DO 140 N=1,NAB
      ALPHA(N)=ALPHA(N)*TYS
  140 BETA(N)=BETA(N)*TYS
      ISET=0
      IF (INISW.EQ.0) GO TO 10
      NJMAX=NAB*NY2
      DO 150 NJ=1,NJMAX
      AYL(NJ)=0.D0
      AYLD(NJ)=0.D0
      AYR(NJ)=0.D0
      AYRD(NJ)=0.D0
      AZL(NJ)=0.D0
      AZLD(NJ)=0.D0
      AZR(NJ)=0.D0
      AZRD(NJ)=0.D0
  150 CONTINUE
      INISW=0
      RETURN
      END

      SUBROUTINE LASER
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C THIS ROUTINE HEATS A FRACTIONAL NO. OF ELECTRONS IN A VOL (YKI-YK1)*DX
C
      PARAMETER (NBB=512)
      PARAMETER(NC1 = 78885)
      PARAMETER (N1D=5000)
      COMMON  PBUF(NBB,5),Q(NC1),TEMP(2*N1D),TBUF(5,NBB)
      COMMON/POTEN1/ SS(NC1),W(NC1),AX(NC1)
      COMMON/POTEN2/ AX1(NC1),AY(NC1),AY1(NC1)
      COMMON/POTEN3/ AZ(NC1),AZ1(NC1)
      COMMON/CURR/ CX(NC1),CY(NC1),CZ(NC1)
      COMMON/EFIELD/EX(NC1),EY(NC1),EZ(NC1),BX(NC1),BY(NC1),BZ(NC1)
      COMMON/QBK/ QBK(NC1)
      DIMENSION X(NBB),Y(NBB),VX(NBB),VY(NBB),VZ(NBB)
      EQUIVALENCE (X(1),PBUF(1,1)),(Y(1),PBUF(1,2)),(VX(1),PBUF(1,3)),
     *  (VY(1),PBUF(1,4)),(VZ(1),PBUF(1,5))

      COMMON/PARCM/NX,NY,L3,L4,KBND,NX2,NX1,NY1,NY2,IBCDL,IBCDR,
     *   IBCDT,IBCDB,KBR,LSTL,LSTR,NINJL,NINJR,KBNDY,INOP,
     *   XMAX,YMAX,DT,QMULT,WMULT,XLEFT,XRIGHT,
     *   HX,HY,HXI,HYI,VMPX1,VMPY1,
     *   VMPZ1,ELOST,QLOSTL,QLOSTR,QLOSTT,QLOSTB,
     *   YTOP,YBOT,DRINJ,DLINJ,VRINJ,VLINJ,
     *   TRPAR,TLPAR,DTLPAR,DTRPAR,QINJL,QINJR,EINJ
C
      PARAMETER (NYY=514)
      PARAMETER(NNS=25)
      PARAMETER (NDIM=503)
      PARAMETER(NNS1=NNS+1,NNS2=NNS*2)
C
      PARAMETER(NCL=3*NYY)
C
      COMMON/FKICK/XKICK,DXKICK, YK1,YK2,FNKICK,VMPXH,VMPYH,EHEAT
     1 ,VOSC,DELE,DLASER,TWIDTH,TPEAK,XLASER
      COMMON/PARAM/IT,NC,NB,NP,IMPSW,NRAND,KJSMTH,KQSMTH,
     *    KEI,KEE,KSP,NPTIME,
     *    NSP,NPX(NNS),NPY(NNS),NSPEC(NNS),IDNX(NNS1),IDNY(NNS1),
     *    IBCNDL(NNS),IBCNDR(NNS),IBCNDT(NNS),IBCNDB(NNS),
     *    LOADED(NNS),LOSTL(NNS),LOSTR(NNS),INJL(NNS),INJR(NNS)
      COMMON/PARAMR/ PI,T,AA,SINA,SINP,TDLAZ,AMPH,PHAS,VEA,FNK,
     *    TAU,TAU1,TAU2,EXC,EYC,EZC,BXC,BYC,BZC,WSPEC(NNS),QSPEC(NNS),
     *    AYL(NCL),AYR(NCL),AYLD(NCL),AYRD(NCL),
     *    AZL(NCL),AZR(NCL),AZLD(NCL),AZRD(NCL),
     *    VMPX(NNS),VMPY(NNS),VMPZ(NNS),
     *    XDRIFT(NNS),YDRIFT(NNS),ZDRIFT(NNS),
     *    XN(NNS2),DENX(NNS2),YN(NNS2),DENY(NNS2),
     *    XLJ(NNS),XRJ(NNS),XTJ(NNS),XBJ(NNS),FEREM,AFRACR,
     *    DINJR(NNS),DINJL(NNS),VINJR(NNS),VINJL(NNS),
     *    TINJR(NNS),TINJL(NNS),IBATCH(NNS)
      COMMON /PARAM1/ EKX(NNS),EKY(NNS),EKZ(NNS),EKJ(NNS),
     *    VLIMA,VLIMB,VXAVGA,VXAVGB,VYAVGA,
     *    VYAVGB,VZAVGA,VZAVGB,TFIN,EFIN,
     *    TDEC(NDIM),EDEC(NDIM,6),ELOSTB,AVPOYN,APOYNT(N1D),
     *    EPOUTR(50),EPOUTL(50),EPOUTB(50),EPOUTT(50),
     *    EPINR(50),EPINL(50),EPINB(50),EPINT(50),
     *    DEP,TEP,EPMAX,KSPLIT,NPTSA,NPTSB,NPLOT,NENRG,NHIST,NFT1,NFT2,
     *    NENRG2,KDIAG,LDEC,NEP
C
      EXTERNAL RANF
C
C     ASSUMING CONSTANT ACCELERATION, VMPXH IS THE FINAL VELOCITY
C       TO BE REACHED OVER THE ACCELERATION DISTANCE DXKICK
C
      DVX=DT*VMPXH**2/(DXKICK)
      XK1=XKICK-.5D0*DXKICK
      XK2=XKICK+.5D0*DXKICK
      IF(DELE.GT.DLASER) RETURN
      DO 100 L=L3,L4
      VXS=VX(L)
      VYS=VY(L)
      IF(VXS*VMPXH.GT.0.AND.DELE.LT.DLASER) THEN
C
C        PARTICLE VELOCITY HAS CORRECT SIGN AND MORE DEPOSITION IS NEEDE
C
         IF  (X(L).GE.XK1.AND.X(L).LE.XK2
     1   .AND.Y(L).GE.YK1.AND.Y(L).LE.YK2) THEN
C
C           PARTICLE IS INSIDE ACCELERATING REGION
C
            FYY=((2.D0*Y(L)-YK2-YK1)/(YK2-YK1))**2
            FYY=1.D0-FYY
            VX(L)=VX(L)+DVX*RANF(0.0D0)*FYY
            VY(L)=VY(L)+DVX*VMPYH*2*(.5D0-RANF(0.0D0))*FYY
            DE=WMULT*(VX(L)**2+VY(L)**2-VXS**2-VYS**2)
            DELE=DELE+DE
            EHEAT=EHEAT+DE
         ENDIF
      ENDIF
  100 CONTINUE
      RETURN
      ENTRY LASDEN
      XLASER=DXKICK+YK1+YK2
      IF(FNKICK.EQ.0.OR.XLASER.LE.0) RETURN
      IF(QMULT.GT.0) RETURN
C
C SEARCH FOR X POSITION OF FNKICK DENSITY
C
C     XKICK IS SET TO FIRST PLACE FROM THE LEFT WHERE DENSITY
C        DROPS BELOW FNKICK (AVERAGED OVER YK1 TO YK2)
C
      IY1=YK1/HY+1
      IY2=YK2/HY+1
      DO 300 I=2,NX1
         II=IY1*NX2+I
         SUM=0.D0
         DO 350 J=IY1,IY2
            SUM=SUM+Q(II)
  350       II=II+NX2
  300    TEMP(I)=-SUM/(IY2-IY1+1)
      DO 400 IS=2,NX1
  400 IF(TEMP(IS).LT.FNKICK) GO TO 410
  410  XKICK=(IS-1.5D0)*HX
       RETURN
      ENTRY LASPOW
      DELE=0.D0
      ARG=((T-TPEAK)/TWIDTH)**2
      IF(ARG.GE.36.D0 ) DLASER=0.D0
      IF(ARG.LT.36.D0 ) DLASER=.5D0*VOSC**2*(YK2-YK1)*DT*DEXP(-ARG)
      RETURN
       END

      SUBROUTINE PDIAG
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      PARAMETER (NBB=512)
      PARAMETER(NC1 = 78885)
      PARAMETER (N1D=5000)
      COMMON  PBUF(NBB,5),Q(NC1),TEMP(2*N1D),TBUF(5,NBB)
      COMMON/POTEN1/ SS(NC1),W(NC1),AX(NC1)
      COMMON/POTEN2/ AX1(NC1),AY(NC1),AY1(NC1)
      COMMON/POTEN3/ AZ(NC1),AZ1(NC1)
      COMMON/CURR/ CX(NC1),CY(NC1),CZ(NC1)
      COMMON/EFIELD/EX(NC1),EY(NC1),EZ(NC1),BX(NC1),BY(NC1),BZ(NC1)
      COMMON/QBK/ QBK(NC1)
      DIMENSION X(NBB),Y(NBB),VX(NBB),VY(NBB),VZ(NBB)
      EQUIVALENCE (X(1),PBUF(1,1)),(Y(1),PBUF(1,2)),(VX(1),PBUF(1,3)),
     *  (VY(1),PBUF(1,4)),(VZ(1),PBUF(1,5))

      COMMON/PARCM/NX,NY,L3,L4,KBND,NX2,NX1,NY1,NY2,IBCDL,IBCDR,
     *   IBCDT,IBCDB,KBR,LSTL,LSTR,NINJL,NINJR,KBNDY,INOP,
     *   XMAX,YMAX,DT,QMULT,WMULT,XLEFT,XRIGHT,
     *   HX,HY,HXI,HYI,VMPX1,VMPY1,
     *   VMPZ1,ELOST,QLOSTL,QLOSTR,QLOSTT,QLOSTB,
     *   YTOP,YBOT,DRINJ,DLINJ,VRINJ,VLINJ,
     *   TRPAR,TLPAR,DTLPAR,DTRPAR,QINJL,QINJR,EINJ
C
      PARAMETER (NYY=514)
      PARAMETER(NNS=25)
      PARAMETER (NDIM=503)
      PARAMETER(NNS1=NNS+1,NNS2=NNS*2)
C
      PARAMETER(NCL=3*NYY)
C
      COMMON/FKICK/XKICK,DXKICK, YK1,YK2,FNKICK,VMPXH,VMPYH,EHEAT
     1 ,VOSC,DELE,DLASER,TWIDTH,TPEAK,XLASER
      COMMON/PARAM/IT,NC,NB,NP,IMPSW,NRAND,KJSMTH,KQSMTH,
     *    KEI,KEE,KSP,NPTIME,
     *    NSP,NPX(NNS),NPY(NNS),NSPEC(NNS),IDNX(NNS1),IDNY(NNS1),
     *    IBCNDL(NNS),IBCNDR(NNS),IBCNDT(NNS),IBCNDB(NNS),
     *    LOADED(NNS),LOSTL(NNS),LOSTR(NNS),INJL(NNS),INJR(NNS)
      COMMON/PARAMR/ PI,T,AA,SINA,SINP,TDLAZ,AMPH,PHAS,VEA,FNK,
     *    TAU,TAU1,TAU2,EXC,EYC,EZC,BXC,BYC,BZC,WSPEC(NNS),QSPEC(NNS),
     *    AYL(NCL),AYR(NCL),AYLD(NCL),AYRD(NCL),
     *    AZL(NCL),AZR(NCL),AZLD(NCL),AZRD(NCL),
     *    VMPX(NNS),VMPY(NNS),VMPZ(NNS),
     *    XDRIFT(NNS),YDRIFT(NNS),ZDRIFT(NNS),
     *    XN(NNS2),DENX(NNS2),YN(NNS2),DENY(NNS2),
     *    XLJ(NNS),XRJ(NNS),XTJ(NNS),XBJ(NNS),FEREM,AFRACR,
     *    DINJR(NNS),DINJL(NNS),VINJR(NNS),VINJL(NNS),
     *    TINJR(NNS),TINJL(NNS),IBATCH(NNS)
      COMMON /PARAM1/ EKX(NNS),EKY(NNS),EKZ(NNS),EKJ(NNS),
     *    VLIMA,VLIMB,VXAVGA,VXAVGB,VYAVGA,
     *    VYAVGB,VZAVGA,VZAVGB,TFIN,EFIN,
     *    TDEC(NDIM),EDEC(NDIM,6),ELOSTB,AVPOYN,APOYNT(N1D),
     *    EPOUTR(50),EPOUTL(50),EPOUTB(50),EPOUTT(50),
     *    EPINR(50),EPINL(50),EPINB(50),EPINT(50),
     *    DEP,TEP,EPMAX,KSPLIT,NPTSA,NPTSB,NPLOT,NENRG,NHIST,NFT1,NFT2,
     *    NENRG2,KDIAG,LDEC,NEP
C
      DIMENSION XSC(2), YSC(2), VSC(2), VSC1(2)
      COMMON /DIST/FVX1(101,2), FVX2(101,2), FVY1(101,2), FVY2(101,2),
     1             FVZ1(101,2), FVZ2(101,2), NFX(2), NFY(2), DV(2), NFV
      COMMON /PART/ FIRST, KNEW, KTEST
      COMMON/ENERMO/ VXAV(NNS),VYAV(NNS),VXRMSD(NNS),VYRMSD(NNS),
     1                VZAV(NNS),VZRMSD(NNS)
c specmod
	REAL XD1,XD2,YD1,YD2
      SAVE IS
C	Definition of LSKIP as SAVE, JWR/SPEC 4/5/94
      SAVE LSKIP
	DATA XD1,XD2,YD1,YD2/ 0.D0, 0.D0, 0.D0, 0.D0 /
	NFV = 0
C
C    PARTICLE DIAGNOSTICS
C
      IF (KDIAG.LT.0) GO TO 40
C
C    PHASE SPACE AND DISTRIBUTION FUNCTION CALCULATION
C
   40 IF (NPLOT.LE.0) GO TO 140
      IF (MOD(IT,NPLOT).NE.0) GO TO 140
      IF (KSP.EQ.KNEW.OR.KTEST.NE.KDIAG) THEN
C
C           START A NEW SPECIES PLOT AT SPECIES NUMBER KSPLIT
C
         IF (KNEW.LE.1.OR.KTEST.NE.KDIAG) THEN
            VLIM=VLIMA
c specmod
c            VXAVG=VXAVGA
c            VYAVG=VYAVGA
c            VZAVG=VZAVGA
            VXAVG=0.D0
            VYAVG=0.D0
            VZAVG=0.D0
            LSKIP=NPTSA
            KNEW=KSPLIT
            KTEST=KDIAG
            XSC(1)=0.D0
            XSC(2)=XMAX
            YSC(1)=0.D0
            YSC(2)=YMAX
            XSC(1)=XLJ(KSP)
            XSC(2)=XRJ(KSP)
            IS=1
        ELSE
            VLIM=VLIMB
c specmod
c            VXAVG=VXAVGB
c            VYAVG=VYAVGB
c            VZAVG=VZAVGB
            VXAVG=0.D0
            VYAVG=0.D0
            VZAVG=0.D0
            LSKIP=NPTSB
            KNEW=1
            IS=2
         ENDIF
         IF (KDIAG.GE.0) THEN
C
C             FIRST FRAME FOR SPECIES
C
              VSC(1)=VXAVG-VLIM
              VSC(2)=VXAVG+VLIM
              VSC(1)=VYAVG-VLIM
              VSC(2)=VYAVG+VLIM
              VSC(1)=VZAVG-VLIM
              VSC(2)=VZAVG+VLIM
              NFX(IS)=0
              NFY(IS)=0
              DO 95 I=1,NFV
              FVX1(I,IS)=0.D0
              FVX2(I,IS)=0.D0
              FVY1(I,IS)=0.D0
              FVY2(I,IS)=0.D0
              FVZ1(I,IS)=0.D0
              FVZ2(I,IS)=0.D0
   95         CONTINUE
         ELSE
C
C             SECOND FRAME FOR SPECIES
C
              LSKIPM=2*LSKIP
              VSC(1)=VXAVG-VLIM
              VSC(2)=VXAVG+VLIM
              VSC1(1)=VYAVG-VLIM
              VSC1(2)=VYAVG+VLIM
              VSC1(1)=VZAVG-VLIM
              VSC1(2)=VZAVG+VLIM
              VSC(1)=VYAVG-VLIM
              VSC(2)=VYAVG+VLIM
         ENDIF
      ENDIF
      NPTS=1+(L4-L3)/LSKIP
      IF (KDIAG.GE.0) THEN
C
C        FIRST SET OF PHASE SPACE PLOTS
C
C        ADD PARTICLES TO DISTRIBUTION FUNCTIONS
C
         DV(IS)=2.D0*VLIM/(NFV-1)
         DO 120 L=L3,L4
         J=0
         IF (X(L).GE.XD1.AND.X(L).LE.XD2) J=J+1
         IF (Y(L).GE.YD1.AND.Y(L).LE.YD2) J=J+2
         IF (J.NE.0) THEN
C
C           PARTICLE IS WITHIN BOUNDARY OF DISTRIBUTION PLOTS
C
            JX=MIN0(NFV,MAX0(1,INT((NFV-1)
     1         *(VX(L)+VLIM-VXAVG)/(2*VLIM)+1)))
            JY=MIN0(NFV,MAX0(1,INT((NFV-1)
     1         *(VY(L)+VLIM-VYAVG)/(2*VLIM)+1)))
            JZ=MIN0(NFV,MAX0(1,INT((NFV-1)
     1         *(VZ(L)+VLIM-VZAVG)/(2*VLIM)+1)))
            IF (J.NE.2) THEN
C
C              ADD PARTICLE TO LEFT DISTRIBUTION FUNCTION
C
               NFX(IS)=NFX(IS)+1
               FVX1(JX,IS)=FVX1(JX,IS)+1.D0
               FVY1(JY,IS)=FVY1(JY,IS)+1.D0
               FVZ1(JZ,IS)=FVZ1(JZ,IS)+1.D0
            ENDIF
            IF (J.NE.1) THEN
C
C              ADD PARTICLE TO RIGHT DISTRIBUTION FUNCTION
C
               NFY(IS)=NFY(IS)+1
               FVX2(JX,IS)=FVX2(JX,IS)+1.D0
               FVY2(JY,IS)=FVY2(JY,IS)+1.D0
               FVZ2(JZ,IS)=FVZ2(JZ,IS)+1.D0
            ENDIF
         ENDIF
  120    CONTINUE
      ELSE
C
C        PLOT SECOND SET OF DISTRIBUTION PLOTS
C
         NPTS=1+(L4-L3)/LSKIPM
         NPTS=1+(L4-L3)/LSKIP
         RETURN
      ENDIF
C
C    PARTICLE ENERGY CALCULATION
C
 140  IF(NENRG2.LE.0) GO TO 180
      IF(MOD(IT,NENRG2).NE.0) GO TO 180
      IF (FIRST.EQ.0.) THEN
C
C        INITIALIZE ARRAYS
C
         VSQ=0.D0
         DO 150 KS=1,NSP
         VXAV(KS)=0.D0
         VYAV(KS)=0.D0
         VXRMSD(KS)=0.D0
         VYRMSD(KS)=0.D0
         VZAV(KS)=0.D0
         VZRMSD(KS)=0.D0
  150    CONTINUE
      ENDIF
      VX1=0.D0
      VY1=0.D0
      VXS1=0.D0
      VYS1=0.D0
      VZ1=0.D0
      VZS1=0.D0
      DO 170 L=L3,L4
      IF(X(L).LT.0) GO TO 170
      VX1=VX1+VX(L)
      VXS1=VXS1+VX(L)**2
      VY1=VY1+VY(L)
      VYS1=VYS1+VY(L)**2
      VZ1=VZ1+VZ(L)
      VZS1=VZS1+VZ(L)**2
  170 CONTINUE
      VXAV(KSP)=VXAV(KSP)+VX1
      VXRMSD(KSP)=VXRMSD(KSP)+VXS1
      VYAV(KSP)=VYAV(KSP)+VY1
      VYRMSD(KSP)=VYRMSD(KSP)+VYS1
      VZAV(KSP)=VZAV(KSP)+VZ1
      VZRMSD(KSP)=VZRMSD(KSP)+VZS1
      VSQ=VSQ+WMULT*(VXS1+VYS1+VZS1)
  180 CONTINUE
      FIRST=1.
      RETURN
      END
C
      SUBROUTINE DIAGNS
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      PARAMETER (NBB=512)
      PARAMETER(NC1 = 78885)
      PARAMETER (N1D=5000)
      COMMON  PBUF(NBB,5),Q(NC1),TEMP(2*N1D),TBUF(5,NBB)
      COMMON/POTEN1/ SS(NC1),W(NC1),AX(NC1)
      COMMON/POTEN2/ AX1(NC1),AY(NC1),AY1(NC1)
      COMMON/POTEN3/ AZ(NC1),AZ1(NC1)
      COMMON/CURR/ CX(NC1),CY(NC1),CZ(NC1)
      COMMON/EFIELD/EX(NC1),EY(NC1),EZ(NC1),BX(NC1),BY(NC1),BZ(NC1)
      COMMON/QBK/ QBK(NC1)
      DIMENSION X(NBB),Y(NBB),VX(NBB),VY(NBB),VZ(NBB)
      EQUIVALENCE (X(1),PBUF(1,1)),(Y(1),PBUF(1,2)),(VX(1),PBUF(1,3)),
     *  (VY(1),PBUF(1,4)),(VZ(1),PBUF(1,5))

      COMMON/PARCM/NX,NY,L3,L4,KBND,NX2,NX1,NY1,NY2,IBCDL,IBCDR,
     *   IBCDT,IBCDB,KBR,LSTL,LSTR,NINJL,NINJR,KBNDY,INOP,
     *   XMAX,YMAX,DT,QMULT,WMULT,XLEFT,XRIGHT,
     *   HX,HY,HXI,HYI,VMPX1,VMPY1,
     *   VMPZ1,ELOST,QLOSTL,QLOSTR,QLOSTT,QLOSTB,
     *   YTOP,YBOT,DRINJ,DLINJ,VRINJ,VLINJ,
     *   TRPAR,TLPAR,DTLPAR,DTRPAR,QINJL,QINJR,EINJ
C
      PARAMETER (NYY=514)
      PARAMETER(NNS=25)
      PARAMETER (NDIM=503)
      PARAMETER(NNS1=NNS+1,NNS2=NNS*2)
C
      PARAMETER(NCL=3*NYY)
C
      COMMON/FKICK/XKICK,DXKICK, YK1,YK2,FNKICK,VMPXH,VMPYH,EHEAT
     1 ,VOSC,DELE,DLASER,TWIDTH,TPEAK,XLASER
      COMMON/PARAM/IT,NC,NB,NP,IMPSW,NRAND,KJSMTH,KQSMTH,
     *    KEI,KEE,KSP,NPTIME,
     *    NSP,NPX(NNS),NPY(NNS),NSPEC(NNS),IDNX(NNS1),IDNY(NNS1),
     *    IBCNDL(NNS),IBCNDR(NNS),IBCNDT(NNS),IBCNDB(NNS),
     *    LOADED(NNS),LOSTL(NNS),LOSTR(NNS),INJL(NNS),INJR(NNS)
      COMMON/PARAMR/ PI,T,AA,SINA,SINP,TDLAZ,AMPH,PHAS,VEA,FNK,
     *    TAU,TAU1,TAU2,EXC,EYC,EZC,BXC,BYC,BZC,WSPEC(NNS),QSPEC(NNS),
     *    AYL(NCL),AYR(NCL),AYLD(NCL),AYRD(NCL),
     *    AZL(NCL),AZR(NCL),AZLD(NCL),AZRD(NCL),
     *    VMPX(NNS),VMPY(NNS),VMPZ(NNS),
     *    XDRIFT(NNS),YDRIFT(NNS),ZDRIFT(NNS),
     *    XN(NNS2),DENX(NNS2),YN(NNS2),DENY(NNS2),
     *    XLJ(NNS),XRJ(NNS),XTJ(NNS),XBJ(NNS),FEREM,AFRACR,
     *    DINJR(NNS),DINJL(NNS),VINJR(NNS),VINJL(NNS),
     *    TINJR(NNS),TINJL(NNS),IBATCH(NNS)
      COMMON /PARAM1/ EKX(NNS),EKY(NNS),EKZ(NNS),EKJ(NNS),
     *    VLIMA,VLIMB,VXAVGA,VXAVGB,VYAVGA,
     *    VYAVGB,VZAVGA,VZAVGB,TFIN,EFIN,
     *    TDEC(NDIM),EDEC(NDIM,6),ELOSTB,AVPOYN,APOYNT(N1D),
     *    EPOUTR(50),EPOUTL(50),EPOUTB(50),EPOUTT(50),
     *    EPINR(50),EPINL(50),EPINB(50),EPINT(50),
     *    DEP,TEP,EPMAX,KSPLIT,NPTSA,NPTSB,NPLOT,NENRG,NHIST,NFT1,NFT2,
     *    NENRG2,KDIAG,LDEC,NEP
C
      COMMON /PART/ FIRST, KNEW, KTEST
C
C      CELL DIAGNOSTICS
C
      LE1=0
      IF (NENRG.GT.0) THEN
         IF (MOD(IT,NENRG).EQ.0) LE1=1
      ENDIF
      LE2=0
      IF (NENRG2.GT.0) THEN
         IF (MOD(IT,NENRG2).EQ.0) LE2=1
      ENDIF
C
C       CALCULATE FIELD ENERGY
C
      IF (LE1+LE2.GT.0) CALL ENERGY(LE1,LE2)

      IF (NHIST.GT.0.AND.IT.GT.0) THEN
C
C       ACCUMULATE POYNTING VECTOR AVERAGED OVER Y
C
         I1=2
         I2=NX1
         I3=I2-I1+1
         DO 100 I=I1,I2
            POYN=0.
            DO 200 J=2,NY1
              K=(J-1)*NX2+I
  200         POYN=POYN+EY(K)*BZ(K)-EZ(K)*BY(K)
  100       APOYNT(I)=APOYNT(I)+POYN/NY
C
      ENDIF
C
      FIRST=0.
      KNEW=1
      KTEST=0
      RETURN
      END

      SUBROUTINE ENERGY(LE1,LE2)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      PARAMETER (NBB=512)
      PARAMETER(NC1 = 78885)
      PARAMETER (N1D=5000)
      COMMON  PBUF(NBB,5),Q(NC1),TEMP(2*N1D),TBUF(5,NBB)
      COMMON/POTEN1/ SS(NC1),W(NC1),AX(NC1)
      COMMON/POTEN2/ AX1(NC1),AY(NC1),AY1(NC1)
      COMMON/POTEN3/ AZ(NC1),AZ1(NC1)
      COMMON/CURR/ CX(NC1),CY(NC1),CZ(NC1)
      COMMON/EFIELD/EX(NC1),EY(NC1),EZ(NC1),BX(NC1),BY(NC1),BZ(NC1)
      COMMON/QBK/ QBK(NC1)
      DIMENSION X(NBB),Y(NBB),VX(NBB),VY(NBB),VZ(NBB)
      EQUIVALENCE (X(1),PBUF(1,1)),(Y(1),PBUF(1,2)),(VX(1),PBUF(1,3)),
     *  (VY(1),PBUF(1,4)),(VZ(1),PBUF(1,5))

      COMMON/PARCM/NX,NY,L3,L4,KBND,NX2,NX1,NY1,NY2,IBCDL,IBCDR,
     *   IBCDT,IBCDB,KBR,LSTL,LSTR,NINJL,NINJR,KBNDY,INOP,
     *   XMAX,YMAX,DT,QMULT,WMULT,XLEFT,XRIGHT,
     *   HX,HY,HXI,HYI,VMPX1,VMPY1,
     *   VMPZ1,ELOST,QLOSTL,QLOSTR,QLOSTT,QLOSTB,
     *   YTOP,YBOT,DRINJ,DLINJ,VRINJ,VLINJ,
     *   TRPAR,TLPAR,DTLPAR,DTRPAR,QINJL,QINJR,EINJ
C
      PARAMETER (NYY=514)
      PARAMETER(NNS=25)
      PARAMETER (NDIM=503)
      PARAMETER(NNS1=NNS+1,NNS2=NNS*2)
C
      PARAMETER(NCL=3*NYY)
C
      COMMON/FKICK/XKICK,DXKICK, YK1,YK2,FNKICK,VMPXH,VMPYH,EHEAT
     1 ,VOSC,DELE,DLASER,TWIDTH,TPEAK,XLASER
      COMMON/PARAM/IT,NC,NB,NP,IMPSW,NRAND,KJSMTH,KQSMTH,
     *    KEI,KEE,KSP,NPTIME,
     *    NSP,NPX(NNS),NPY(NNS),NSPEC(NNS),IDNX(NNS1),IDNY(NNS1),
     *    IBCNDL(NNS),IBCNDR(NNS),IBCNDT(NNS),IBCNDB(NNS),
     *    LOADED(NNS),LOSTL(NNS),LOSTR(NNS),INJL(NNS),INJR(NNS)
      COMMON/PARAMR/ PI,T,AA,SINA,SINP,TDLAZ,AMPH,PHAS,VEA,FNK,
     *    TAU,TAU1,TAU2,EXC,EYC,EZC,BXC,BYC,BZC,WSPEC(NNS),QSPEC(NNS),
     *    AYL(NCL),AYR(NCL),AYLD(NCL),AYRD(NCL),
     *    AZL(NCL),AZR(NCL),AZLD(NCL),AZRD(NCL),
     *    VMPX(NNS),VMPY(NNS),VMPZ(NNS),
     *    XDRIFT(NNS),YDRIFT(NNS),ZDRIFT(NNS),
     *    XN(NNS2),DENX(NNS2),YN(NNS2),DENY(NNS2),
     *    XLJ(NNS),XRJ(NNS),XTJ(NNS),XBJ(NNS),FEREM,AFRACR,
     *    DINJR(NNS),DINJL(NNS),VINJR(NNS),VINJL(NNS),
     *    TINJR(NNS),TINJL(NNS),IBATCH(NNS)
      COMMON /PARAM1/ EKX(NNS),EKY(NNS),EKZ(NNS),EKJ(NNS),
     *    VLIMA,VLIMB,VXAVGA,VXAVGB,VYAVGA,
     *    VYAVGB,VZAVGA,VZAVGB,TFIN,EFIN,
     *    TDEC(NDIM),EDEC(NDIM,6),ELOSTB,AVPOYN,APOYNT(N1D),
     *    EPOUTR(50),EPOUTL(50),EPOUTB(50),EPOUTT(50),
     *    EPINR(50),EPINL(50),EPINB(50),EPINT(50),
     *    DEP,TEP,EPMAX,KSPLIT,NPTSA,NPTSB,NPLOT,NENRG,NHIST,NFT1,NFT2,
     *    NENRG2,KDIAG,LDEC,NEP
C
      COMMON /ENERMO/VXAV(NNS),VYAV(NNS),VXRMSD(NNS),VYRMSD(NNS),
     1                VZAV(NNS),VZRMSD(NNS)
      CHARACTER*16 LABELP
      DIMENSION NSPC(NNS)
      ESQ=0.D0
      ESQE=0.D0
      ESQB=0.D0
      IJ=NX+4
      DO 100 J=2,NY1
         DO 200 I=2,NX1
            ESQE=ESQE+EX(IJ)**2+EY(IJ)**2+EZ(IJ)**2
            ESQB=ESQB+BX(IJ)**2+BY(IJ)**2+BZ(IJ)**2
  200       IJ=IJ+1
  100    IJ=IJ+2
      CF=.5D0*HX*HY
      EFE=CF*ESQE
      EFB=CF*ESQB
      EF=EFE+EFB
      EK=0.D0
      DO 300 KS=1,NSP
         EKX(KS)=VXRMSD(KS)*CF*WSPEC(KS)*DABS(QSPEC(KS))
         EKY(KS)=VYRMSD(KS)*CF*WSPEC(KS)*DABS(QSPEC(KS))
         EKZ(KS)=VZRMSD(KS)*CF*WSPEC(KS)*DABS(QSPEC(KS))
         EKJ(KS)=EKX(KS)+EKY(KS)+EKZ(KS)
         EK=EK+EKJ(KS)
 300  CONTINUE
      IF (LE1.NE.0) THEN
         ETOT=EK+EF
         EB=CF*ELOSTB
         LABELP='ENERGY CHECK'
         WRITE (9,500) LABELP, IT, T
         WRITE (9,600) EFE,EFB,EF,EK,ETOT,EB
C        WRITE (9,700)
         EH=EHEAT*CF
c         WRITE(9,900) EH
         CALL NUMB(NSPC,NSP)
         DO 400 KS=1,NSP
            FN=1.D0/NSPC(KS)
            VXAV(KS)=VXAV(KS)*FN
            VYAV(KS)=VYAV(KS)*FN
            VXRMSD(KS)=DSQRT(VXRMSD(KS)*FN-VXAV(KS)**2)
            VYRMSD(KS)=DSQRT(VYRMSD(KS)*FN-VYAV(KS)**2)
            VZAV(KS)=VZAV(KS)*FN
            VZRMSD(KS)=DSQRT(VZRMSD(KS)*FN-VZAV(KS)**2)
c            WRITE (9,800) VXAV(KS),VYAV(KS),VZAV(KS),
c     1        VXRMSD(KS),VYRMSD(KS),VZRMSD(KS),
c     1        EKX(KS),EKY(KS),EKZ(KS),EKJ(KS)
  400    CONTINUE
      ENDIF
      IF (LE2.NE.0.AND.LDEC.GE.0) THEN
         IF (LDEC.GT.NDIM) THEN
C
C          REINITIALIZE HISTORY ARRAYS
C
            TDEC(1)=TDEC(NDIM)
            TDEC(3)=TDEC(NDIM)
            LDEC=4
            EDEC(3,1)=EDEC(NDIM,1)
            EDEC(3,2)=EDEC(NDIM,2)
            EDEC(3,3)=EDEC(NDIM,3)
            EDEC(3,4)=EDEC(NDIM,4)
            EDEC(3,5)=EDEC(NDIM,5)
            EDEC(3,6)=EDEC(NDIM,6)
         ENDIF
         TDEC(LDEC)=T
         EDEC(LDEC,1)=EFE
         EDEC(LDEC,2)=EFB
         EDEC(LDEC,3)=EKJ(1)
         EDEC(LDEC,4)=EKJ(2)
         EDEC(LDEC,5)=(EHEAT+EINJ)*CF
         EDEC(LDEC,6)=ELOSTB*CF
         LDEC=LDEC+1
C
      ENDIF
      RETURN
  500 FORMAT (/' ',A16,' IT=',I6,'  T=',F9.3)
  600 FORMAT (/' ',5X,'EFE=',E11.4,' EFB=',E11.4,' EF=',E11.4,
     1   ' KINETIC=',E11.4,'  TOTAL=',E11.4,' ELOSTB=',E11.4)
  700 FORMAT (/'    VXAV       VYAV       VZAV        VXRMSD       VYRMS
     1D      VZRMSD     EKX          EKY         EKZ         EKT')
  800 FORMAT(1X,10E12.4)
  900 FORMAT(' EHEAT = ',E11.4)
      END

      SUBROUTINE SOLV2P(NX2,NY2,HX,HY,DD,Q,BC,TMP)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      CALL SLV2XP(NX2-2,NY2-2,NX2,HX,HY,DUMMY,DD,Q,BC,TMP,0)
      RETURN
      END

      SUBROUTINE SLV2PD(NX2,NY2,HX,HY,GX,DD,Q,BC,TMP)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION Q(NX2,*),TMP(NX2,*),BC(4),GX(NX2)
      NX=NX2-2
      NX1=NX+1
      NY=NY2-2
      IGXSW=0
      DO 20 IX=2,NX1
      IF(GX(IX).NE.0.D0)IGXSW=1
 20   CONTINUE
      CALL SLV2XP(NX,NY,NX2,HX,HY,GX,DD,Q,BC,TMP,IGXSW)
      RETURN
      END

      SUBROUTINE SLV2XP(NX,NY,NXD,HX,HY,GX,DD,Q,BC,TMP,IGXSW)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
C  SOLVES(V(I+1,J)+V(I-1,J)-2.*V(I,J))/HX**2
C     +(V(I,J+1)+V(I,J-1)-2.*V(I,J))/HY**2+GX(I)*V(I,J)=Q(I,J)
C     V(I,J) AND Q(I,J) ARE SPECIFIED AT X=(I-1.5)*HX FOR I=2,NX+1,
C     AND AT Y=(J-1.5)*HY FOR J=2,NY+1
C     IF(IGXSW.EQ.0)GX(I) IS IGNORED (TREATED AS ZERO)
C     ZEROS IN ALL OF GX WITH IGXSW NOT ZERO WILL NOT WORK
C     IN SINGULAR CASES (DOUBLY-PERIODIC OR DOUBLY-NEUMANN)
C
C  BOUNDARY CONDITIONS
C     PERIODIC IN Y
C     BC(1)*V(X=0,J)+BC(2)*DV/DX(X=0,J)=Q(1,J)  J=2,NY+1
C     BC(3)*V(X=NX*HX,J)+BC(4)*DV/DX(X=NX*HX,J)=Q(NX+2,J)  J=2,NY+1
C     (BC(1)=.5*HX*BC(1) AND BC(4)=-.5*HX*BC(3) ARE FORBIDDEN)
C     PERIODIC IN X IF BOTH BC(1)AND BC(2) ARE 0.
C
C  RETURNS V(I,J) IN Q(I,J) INCLUDING GHOST CELL VALUES
C     TO GIVE PROPER INTERPOLATED BOUNDARY CONDITIONS
C
C  CONSISTENCY FOR DOUBLY-PERIODIC IS
C     SUM(I=2,NX+1;J=2,NY+1)Q(I,J)=0.
C     CONSISTENCY FOR DOUBLY-NEUMANN IS
C     SUM(I=2,NX+1;J=2,NY+1)Q(I,J)=SUM(J=2,NY+1)(Q(NX+2,J)-Q(1,J))/HX
C
C  Q IS DIMENSIONED AT LEAST (NXD,NY+2)
C     NY MUST BE A POWER OF 2 BETWEEN 8 AND 512
C     NX IS ARBITRARY .GE. 3
C     TMP IS DIMENSIONED AT LEAST (NXD,NY) FOR APERIODIC,
C     TMP IS DIMENSIONED AT LEAST (NXD,NY,2) FOR PERIODIC
C     MAX NY IS 512
C
      COMMON/FFT00/C(65),S(65),EIG(512)
      DIMENSION Q(NXD,*),TMP(NXD,NY,2),BC(4),GX(NXD)
      DATA NA/0/,HYA/0.D0/,DDA/0.D0/
C
      ISING=1
      IF(BC(1).NE.0.D0.OR.IGXSW.NE.0.OR.DD.NE.0.D0)ISING=0
      IF(BC(2).NE.0D0.AND.BC(3).NE.0.D0)ISING=0
      NX2=NX+2
      NY2=NY+2
      NY1=NY+1
      IF(NY.NE.NA.OR.HY.NE.HYA.OR.DD.NE.DDA) THEN
C
           CALL GEN(NY)
           N4=NY/4
           HYSQI=1.D0/HY**2
           IE=1
           DO 45 K=1,N4
           COSS=C(K)
           DO 40 IS=1,2
           DO 35 IR=1,2
           EIG(IE)=HYSQI*(2.D0*COSS-2.D0)+DD
           IE=IE+1
           IF(IE.EQ.2)COSS=-COSS
 35        CONTINUE
           COSS=-COSS
           IF(IE.EQ.3)COSS=0
 40        CONTINUE
 45        CONTINUE
           NA=NY
           HYA=HY
           DDA=DD
C
      ENDIF
      CALL VFFA(Q(1,2),NX2,NY,NXD)
C
      IF(BC(1).EQ.0..AND.BC(2).EQ.0.) THEN
           CALL VSLV1P(NX,NY,NXD,HX,GX,EIG,Q(1,2),TMP,TMP(1,1,2),
     .       IGXSW,ISING)
      ELSE
           CALL VSLV1X(NX,NY,NXD,HX,GX,EIG,Q(1,2),BC,TMP,IGXSW,ISING)
      ENDIF
C
      CALL VFFS(Q(1,2),NX2,NY,NXD)
C
      DO 80 I=1,NX2
      Q(I,1)=Q(I,NY1)
 80   Q(I,NY2)=Q(I,2)
      RETURN
      END

      SUBROUTINE VSLV1P(NX,NY,NXD,HX,GX,GY,Q,TMP1,TMP2,IGXSW,ISING)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
C  SOLVES(V(I+1,J)+V(I-1,J)-2.*V(I,J))/HX**2+(GX(I)+GY(J))*V(I,J)=Q(I,J)
C     V(I,J) AND Q(I,J) SPECIFIED AT (I-1.5)*HX FOR I=2,NX+1, J=1,NY
C     IF (IGXSW.EQ.0) GX(I) IS IGNORED AND TREATED AS ZERO
C     IF(ISING.NE.0) THE J=1 EQUATION IS TREATED AS SINGULAR
C     RETURNS V(I,J) IN Q(I,J), GX(I) AND GY(J) ARE NOT CHANGED
C
C  PERIODIC BOUNDARY CONDITIONS
C     RETURNS PERIODIC VALUES IN Q(1,J) AND Q(NX+2,J) J=1,NY
C
C  TMP1(I,J) AND TMP2(I,J) ARE SCRATCH ARRAYS WITH AT LEAST NXD*NY EACH
C     Q IS DIMENSIONED (NXD,NY+2)
C
      DIMENSION GX(NXD),GY(NY),Q(NXD,*),TMP1(NXD,NY),TMP2(NXD,NY)
      NX1=NX+1
      NX2=NX+2
      NXM1=NX-1
C
      FAC=HX**2
      IF(IGXSW.NE.0) THEN
           DO 10 I=2,NX1
           DO 10 IV=1,NY
           Q(I,IV)=FAC*Q(I,IV)
           TMP1(I,IV)=FAC*(GX(I)+GY(IV))-2.D0
 10        CONTINUE
      ELSE
           DO 12 I=2,NX1
           DO 12 IV=1,NY
           Q(I,IV)=FAC*Q(I,IV)
           TMP1(I,IV)=FAC*GY(IV)-2.D0
 12        CONTINUE
      ENDIF
      DO 20 IV=1,NY
      TMP2(1,IV)=1.D0
 20   TMP2(2,IV)=1.D0
      DO 30 I=3,NX
      DO 30 IV=1,NY
      TMP1(1,IV)=1.D0/TMP1(I-1,IV)
      TMP1(I-1,IV)=TMP1(1,IV)
      Q(I-1,IV)=TMP1(1,IV)*Q(I-1,IV)
c
c *** spec
c *** for spec portability reasons, we check for possible underflow
c     (not an exhaustive check) and set the result to zero, rather
c     than depending upon different system approaches for handling exceptions
c
c      TMP2(I-1,IV)=TMP1(1,IV)*TMP2(I-1,IV)
c
        IF (TMP1(1,IV)  .LT. 1.0D-15 ) TMP1(1,IV)   = 0.0D0
        IF (TMP2(I-1,IV).LT. 1.0D-15 ) TMP2(I-1,IV) = 0.0D0
c
      TMP2(I-1,IV)=TMP1(1,IV)*TMP2(I-1,IV)
      TMP1(I,IV)=TMP1(I,IV)-TMP1(1,IV)
      TMP2(I,IV)=-TMP2(I-1,IV)
      Q(I,IV)=Q(I,IV)-Q(I-1,IV)
      Q(NX1,IV)=Q(NX1,IV)-TMP2(1,IV)*Q(I-1,IV)
c
c *** spec
c *** for spec portability reasons, we check for possible underflow
c     (not an exhaustive check) and set the result to zero, rather
c     than depending upon different system approaches for handling exceptions
c
c      TMP1(NX1,IV)=TMP1(NX1,IV)-TMP2(1,IV)*TMP2(I-1,IV)
c
        IF (TMP2(1,IV)  .LT. 1.0D-15 ) TMP2(1,IV) = 0.0D0
        IF (TMP2(I-1,IV).LT. 1.0D-15 ) TMP2(I-1,IV) = 0.0D0
C
      TMP1(NX1,IV)=TMP1(NX1,IV)-TMP2(1,IV)*TMP2(I-1,IV)
      TMP2(1,IV)=-TMP2(1,IV)*TMP1(1,IV)
 30   CONTINUE
      DO 40 IV=1,NY
      TMP2(NX,IV)=TMP2(NX,IV)+1.D0
      TMP2(1,IV)=TMP2(1,IV)+1.D0
      TMP1(1,IV)=1.D0/TMP1(NX,IV)
      TMP1(NX,IV)=TMP1(1,IV)
      Q(NX,IV)=TMP1(1,IV)*Q(NX,IV)
      TMP2(NX,IV)=TMP1(1,IV)*TMP2(NX,IV)
      Q(NX1,IV)=Q(NX1,IV)-TMP2(1,IV)*Q(NX,IV)
 40   TMP1(NX1,IV)=TMP1(NX1,IV)-TMP2(1,IV)*TMP2(NX,IV)
      IF(ISING.NE.0)TMP1(NX1,1)=1.D15
      DO 50 IV=1,NY
      Q(NX1,IV)=Q(NX1,IV)/TMP1(NX1,IV)
 50   Q(NX,IV)=Q(NX,IV)-TMP2(NX,IV)*Q(NX1,IV)
      DO 60 J=2,NXM1
      I=NX1-J
      DO 60 IV=1,NY
      Q(I,IV)=Q(I,IV)-TMP2(I,IV)*Q(NX1,IV)-TMP1(I,IV)*Q(I+1,IV)
 60   CONTINUE
      DO 70 IV=1,NY
      Q(1,IV)=Q(NX1,IV)
      Q(NX2,IV)=Q(2,IV)
 70   CONTINUE
      RETURN
      END

      SUBROUTINE VSLV1X(NX,NY,NXD,HX,GX,GY,Q,BC,TMP,IGXSW,ISING)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
C  SOLVES (V(I+1,J)+V(I-1,J)-2.*V(I,J))/HX**2+(GX(I)+GY(J))*V(I,J)=Q(I,J
C     V(I,J) AND Q(I,J) SPECIFIED AT(I-1.5)*HX FOR I=2,NX+1, J=1,NY
C     EXCEPT IF IGXSW.EQ.0, GX(I)IGNORED
C     IF(ISING.NE.0),ASSUMED SINGULAR FOR J=1 ONLY
C
C  BOUNDARY CONDITIONS
C     BC(1)*V(X=0,J)+BC(2)*DV/DX(X=0,J)=Q(1,J)
C     BC(3)*V(X=NX*HX,J)+BC(4)*DV/DX(X=NX*HX,J)=Q(NX+2,J)
C     (BC(2)=.5*HX*BC(1) AND BC(4)=-.5*HX*BC(3) ARE FORBIDDEN)
C
C  RETURNS V(I,J) IN Q(I,J) INCLUDING Q(1,J) AND Q(NX+2,J) VALUES WHICH
C     RESULT IN ABOVE BOUNDARY CONDITIONS BY INTERPOLATION
C
C  Q IS DIMENSION (NXD,NY+2)
C     TMP IS DIMENSIONED AT LEAST (NXD,NY)
C
      DIMENSION Q(NXD,*),TMP(NXD,NY),BC(4),GX(NXD),GY(NY)
      HXI=1.D0/HX
      HXSQ=HX**2
      NX1=NX+1
      NX2=NX+2
      R1=.5D0*BC(1)
      R2=HXI*BC(2)
      F1=R1+R2
      F2I=1.D0/(R1-R2)
      R3=.5D0*BC(3)
      R4=HXI*BC(4)
      F3=R3-R4
      F4I=1.D0/(R3+R4)
      IF(IGXSW.NE.0) THEN
           DO 10 I=2,NX1
           DO 10 IV=1,NY
           TMP(I,IV)=(GX(I)+GY(IV))*HXSQ-2.D0
 10        Q(I,IV)=HXSQ*Q(I,IV)
      ELSE
           DO 12 I=2,NX1
           DO 12 IV=1,NY
           TMP(I,IV)=GY(IV)*HXSQ-2.D0
 12        Q(I,IV)=HXSQ*Q(I,IV)
      ENDIF
      DO 20 IV=1,NY
      TMP(2,IV)=TMP(2,IV)-F1*F2I
      TMP(NX1,IV)=TMP(NX1,IV)-F3*F4I
 20   CONTINUE
      DO 30 IV=1,NY
      Q(2,IV)=Q(2,IV)-F2I*Q(1,IV)
      Q(NX1,IV)=Q(NX1,IV)-F4I*Q(NX1+1,IV)
 30   CONTINUE
 40   DO 50 I=3,NX1
      DO 50 IV=1,NY
      TMP(I-1,IV)=1.D0/TMP(I-1,IV)
      Q(I,IV)=Q(I,IV)-TMP(I-1,IV)*Q(I-1,IV)
 50   TMP(I,IV)=TMP(I,IV)-TMP(I-1,IV)
      IF(ISING.EQ.0)Q(NX1,1)=Q(NX1,1)/TMP(NX1,1)
      IF(ISING.NE.0)Q(NX1,1)=0.D0
      DO 60 IV=2,NY
      Q(NX1,IV)=Q(NX1,IV)/TMP(NX1,IV)
 60   CONTINUE
      NX3=NX1+2
      DO 70 II=3,NX1
      I=NX3-II
      DO 70 IV=1,NY
 70   Q(I,IV)=(Q(I,IV)-Q(I+1,IV))*TMP(I,IV)
      DO 80 IV=1,NY
      Q(1,IV)=F2I*Q(1,IV)-F1*F2I*Q(2,IV)
      Q(NX1+1,IV)=F4I*Q(NX1+1,IV)-F3*F4I*Q(NX1,IV)
 80   CONTINUE
      RETURN
      END

      SUBROUTINE GEN(N)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C  GENERATES COS, SIN(I*2*PI/N), I=0,1,...,N/4 IN BERGLAND ORDER
C
      COMMON/FFT00/C(65),S(65),EIG(512)
      DATA NA/0/
      IF(N.EQ.NA)RETURN
      NA=N
      IF (N.EQ.4) THEN
 40        C(1)=1.D0
           S(1)=0.D0
           RETURN
      ENDIF
      IF(N.GT.512.OR.N.LT.8)CALL ABRT('GEN--N OUT OF RANGE',19)
      M=N/4
      K=1
      C(1)=0.D0
      S(1)=1.D0
      KH=0
 10   C(K+1)=DSQRT(.5D0+.5D0*C(KH+1))
      S(K+1)=DSQRT(.5D0-.5D0*C(KH+1))
      KH=K
      K=K+K
      IF(K.LT.M)GO TO 10
      IF(N.NE.4*K)CALL ABRT('GEN--N NOT POWER OF 2',21)
      K=M/4
 20   KH=K/2
      CC=C(KH+1)
      SS=S(KH+1)
      K2=K+K
      K3=K2+K
      IF(K3.EQ.0) THEN
        C(1) = 1.D0
        S(1) = 0.D0
        RETURN
      ENDIF
      DO 30 J=K3,M,K2
      C(J+1)=CC*C(J-K+1)+SS*S(J-K+1)
      S(J+1)=SS*C(J-K+1)-CC*S(J-K+1)
 30   CONTINUE
      K=K/2
      IF(K.GT.0)GO TO 20
      RETURN
      END

      SUBROUTINE VFFA(DATA,M,N,MD)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      COMMON/FFT00/C(65),S(65),EIG(512)
      DIMENSION DATA(MD,*)
      NG=1
      K=N/4
 10   K2=K+K
      K3=K+K2
      J1=1
      K4=K3+K
      J2=K
      KA=K
      KB=K2
      DO 40 IG=1,NG
      CC=C(IG)
      SS=S(IG)
      DO 30 J=J1,J2
      DO 20 IV=1,M
      R1=DATA(IV,J)
      F1=DATA(IV,J+KA)
      T1=CC*DATA(IV,J+KB)+SS*DATA(IV,J+K3)
      T2=CC*DATA(IV,J+K3)-SS*DATA(IV,J+KB)
      DATA(IV,J)=R1+T1
      DATA(IV,J+K)=F1+T2
      DATA(IV,J+K2)=R1-T1
      DATA(IV,J+K3)=T2-F1
 20   CONTINUE
 30   CONTINUE
      KA=K2
      KB=K
      J1=J1+K4
      J2=J2+K4
 40   CONTINUE
      K=K/2
      NG=NG+NG
      IF(K.GE.1)GO TO 10
      DO 50 IV=1,M
      T1=DATA(IV,1)-DATA(IV,2)
      DATA(IV,1)=DATA(IV,1)+DATA(IV,2)
      DATA(IV,2)=T1
 50   CONTINUE
      RETURN
      END

      SUBROUTINE VFFS(DATA,M,N,MD)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      COMMON/FFT00/C(65),S(65),EIG(512)
      DIMENSION DATA(MD,*)
      K=1
      NG=N/4
      DO 10 IV=1,M
      T1=.5D0*(DATA(IV,1)-DATA(IV,2))
      DATA(IV,1)=.5D0*(DATA(IV,1)+DATA(IV,2))
 10   DATA(IV,2)=T1
 20   K2=K+K
      K3=K+K2
      J1=1
      K4=K3+K
      J2=K
      KA=K
      KB=K2
      DO 50 IG=1,NG
      CC=C(IG)
      SS=S(IG)
      DO 40 J=J1,J2
      DO 30 IV=1,M
      R1=.5D0*DATA(IV,J)
      F1=.5D0*DATA(IV,J+K)
      R2=.5D0*DATA(IV,J+K2)
      F2=.5D0*DATA(IV,J+K3)
      T1=R1-R2
      T2=F1+F2
      DATA(IV,J)=R1+R2
      DATA(IV,J+KA)=F1-F2
      DATA(IV,J+KB)=CC*T1-SS*T2
      DATA(IV,J+K3)=CC*T2+SS*T1
 30   CONTINUE
 40   CONTINUE
      KA=K2
      KB=K
      J1=J1+K4
      J2=J2+K4
 50   CONTINUE
      K=K+K
      NG=NG/2
      IF(NG.GE.1)GO TO 20
      RETURN
      END

      SUBROUTINE ABRT(MESS,NC)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      CHARACTER MESS(1)
      NW=(NC+9)/10
      PRINT 99, (MESS(I),I=1,NW)
 99   FORMAT(1X,8A10)
      STOP 'SOLVE'
      END

      SUBROUTINE SOLV2Y(NX2,NY2,HX,HY,DD,Q,BX,BY,TMP)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION BX(4),Q(NX2,*),TMP(NX2,*),BY(4)
      CALL SLV2XY(NX2-2,NY2-2,NX2,HX,HY,DUMMY,DD,Q,BX,BY,TMP,0)
      RETURN
      END

      SUBROUTINE SLV2XD(NX2,NY2,HX,HY,GX,DD,Q,BX,BY,TMP)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION Q(NX2,*),TMP(NX2,*),BX(4),GX(NX2),BY(4)
      NX=NX2-2
      NX1=NX+1
      NY=NY2-2
      IGXSW=0
      DO 20 IX=2,NX1
      IF(GX(IX).NE.0.D0)IGXSW=1
 20   CONTINUE
      CALL SLV2XY(NX,NY,NX2,HX,HY,GX,DD,Q,BX,BY,TMP,IGXSW)
      RETURN
      END

      SUBROUTINE SLV2XY(NX,NY,NXD,HX,HY,GX,DD,Q,BX,BY,TMP,IGXSW)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
C  SOLVES(V(I+1,J)+V(I-1,J)-2.*V(I,J))/HX**2
C     +(V(I,J+1)+V(I,J-1)-2.*V(I,J))/HY**2+GX(I)*V(I,J)=Q(I,J)
C     V(I,J) AND Q(I,J) ARE SPECIFIED AT X=(I-1.5)*HX FOR I=2,NX+1,
C     AND AT Y=(J-1.5)*HY FOR J=2,NY+1
C     IF(IGXSW.EQ.0)GX(I) IS IGNORED (TREATED AS ZERO)
C     ZEROS IN ALL OF GX WITH IGXSW NOT ZERO WILL NOT WORK
C     IN SINGULAR CASES (DOUBLY-PERIODIC OR DOUBLY-NEUMANN)
C
C  BOUNDARY CONDITIONS
C
C     BX(1)*V(X=0,J)+BX(2)*DV/DX(X=0,J)=Q(1,J)  J=2,NY+1
C     BX(3)*V(X=NX*HX,J)+BX(4)*DV/DX(X=NX*HX,J)=Q(NX+2,J)  J=2,NY+1
C     (BX(1)=.5*HX*BX(1) AND BX(4)=-.5*HX*BX(3) ARE FORBIDDEN)
C     PERIODIC IN X IF BOTH BX(1)AND BX(2) ARE 0.
C
C     BOUNDARY CONDITIONS IN Y
C
C     IF BY(1)=1 V(I,Y=0)=Q(I,1)
C     IF BY(2)=1 DV(I,Y=0)/DX=Q(1,I) I=2,NX+1
C     IF(BY(1)=0 AND BY(2) = 0 PERIODIC
C     BY(1) AND BY(2) CAN'T BE BOTH BE 1 AT PRESENT
C     SAME FOR RIGHT BOUNDARY FOR BY(3) AND BY(4)
C  RETURNS V(I,J) IN Q(I,J) INCLUDING GHOST CELL VALUES
C     TO GIVE PROPER INTERPOLATED BOUNDARY CONDITIONS
C
C  CONSISTENCY FOR DOUBLY-PERIODIC IS
C     SUM(I=2,NX+1;J=2,NY+1)Q(I,J)=0.
C     CONSISTENCY FOR DOUBLY-NEUMANN IS
C     SUM(I=2,NX+1;J=2,NY+1)Q(I,J)=SUM(J=2,NY+1)(Q(NX+2,J)-Q(1,J))/HX
C
C  Q IS DIMENSIONED AT LEAST (NXD,NY+2)
C     NY CAN BE ANY INTEGER GREATER THAN 2 AND LESS THAN NDY
C     NX IS ARBITRARY .GE. 3
C     TMP IS DIMENSIONED AT LEAST (NXD,NY) FOR APERIODIC,
C     TMP IS DIMENSIONED AT LEAST (NXD,NY,2) FOR PERIODIC
C
      PARAMETER (NDY=512,NCOEF=3*NDY+15)
      COMMON/FFT01/TEMP(NDY),COEF(NCOEF),DIAG(NDY),IB
      DIMENSION Q(NXD,*),TMP(NXD,NY,2),BX(4),GX(NXD),BY(4)
      DATA NA/0/,HYA/0.D0/,DDA/0.D0/,IBA/-1/
C
      ISING=1
      IF(BX(1).NE.0.D0.OR.BY(1).NE.0.OR.IGXSW.NE.0.OR.DD.NE.0.D0)ISING=0
      IF(BX(2).NE.0.AND.BX(3).NE.0.D0)ISING=0
      IF(BY(2).NE.0.AND.BY(3).NE.0.D0) ISING=0
      NX1=NX+1
      NX2=NX+2
      NY2=NY+2
      NY1=NY+1
      IF(NY.NE.NA.OR.HY.NE.HYA.OR.DD.NE.DDA.OR.IB.NE.IBA) THEN
C
 30         CALL GENB(NY,BY)
            PI=2*DCOS(0.D0)
            HYSQI=1.D0/(HY**2)
            IF(IB.NE.0) THEN
C
C                APERIODIC BOUNDARY CONDITIONS IN Y
C
                  DO 45 I=1,NY
                  DIAG(I)=HYSQI*(2*DCOS((I-IB+1)*PI/NY)-2)+DD
 45               CONTINUE
            ELSE
C
C                PERIODIC BOUNDARY CONDITIONS IN Y
C
                  DIAG(1)=DD
                  DIAG(NY)=-4*HYSQI+DD
                  DO 47 I=3,NY,2
                  DIAG(I-1)=HYSQI*(2*DCOS((I-1)*PI/NY)-2)+DD
 47               DIAG(I)=DIAG(I-1)
            ENDIF
            NA=NY
            HYA=HY
            DDA=DD
            IBA=IB
      ENDIF
      IF(IB.NE.0) THEN
C
C     PUT  Y BOUNDARY CONDITIONS INTO ADJOINING CELLS
C
            DO 35 I=2,NX1
            Q(I,2)=Q(I,2)+(-2*BY(1)/HY+BY(2))*Q(I,1)/HY
            Q(I,NY1)=Q(I,NY1)+(-2*BY(3)/HY-BY(4))*Q(I,NY2)/HY
 35         CONTINUE
      ENDIF
      CALL  FFTF(Q(1,2),NX2,NY,NXD)
C
      IF(BX(1).EQ.0.D0.AND.BX(2).EQ.0.D0) THEN
C
C         PERIODIC BOUNDARY CONDITIONS IN X
C
            CALL VSLV1P(NX,NY,NXD,HX,GX,DIAG,Q(1,2),TMP,TMP(1,1,2),
     .          IGXSW,ISING)
      ELSE
C
C         APERIODIC BOUNDARY CONDITIONS IN X
C
            CALL VSLV1X(NX,NY,NXD,HX,GX,DIAG,Q(1,2),BX,TMP,IGXSW,ISING)
      ENDIF
C
      CALL FFTB(Q(1,2),NX2,NY,NXD)
C
      IF(IB.NE.0) THEN
C
C         APERIODIC BOUNDARY CONDITIONS IN Y
C
            DO 80 I=1,NX2
            Q(I,1)=(2*BY(1)-BY(2)*HY)*Q(I,1)+(BY(2)-BY(1))*Q(I,2)
 80         Q(I,NY2)=(2*BY(3)+BY(4)*HY)*Q(I,NY2)+(BY(2)-BY(1))*Q(I,NY1)
      ELSE
C
C          PERIODIC BOUNDARY CONDITIONS IN Y
C
            DO 87 I=1,NX2
            Q(I,1)=Q(I,NY1)
 87         Q(I,NY2)=Q(I,2)
      ENDIF
      RETURN
C
      END

      SUBROUTINE GENB(N,BY)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C INITIALIZES FFT ROUTINES
C
      DIMENSION BY(4)
      PARAMETER (NDY=512,NCOEF=3*NDY+15)
      COMMON/FFT01/TEMP(NDY),COEF(NCOEF),DIAG(NDY),IB
      DATA NA/0/
      IF(N.EQ.NA)RETURN
      NA=N
      IF(BY(1).EQ.0.D0) THEN
           IF(BY(2).EQ.0) THEN
C
C                PERIODIC FFT
C
                 CALL RFFTI(N,COEF)
                 IB=0
           ELSE IF(BY(3).EQ.0) THEN
C
C               SET DERIVATIVES TO ZERO AT BOUNDARIES
C
                CALL COSQI(N,COEF)
                IB=2
           ELSE
                CALL ABRT('BAD BY',6)
           ENDIF
      ELSE IF(BY(2).EQ.0) THEN
C
C          SET FUNCTION TO ZERO AT BOUNDARIES
C
           IB=1
           CALL SINQI(N,COEF)
      ELSE
           CALL ABRT('BAD BY',6)
      ENDIF
      RETURN
      END

      SUBROUTINE FFTF(DATA,M,N,MD)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION DATA(MD,*)
      PARAMETER (NDY=512,NCOEF=3*NDY+15)
      COMMON/FFT01/TEMP(NDY),COEF(NCOEF),DIAG(NDY),IB
      DO 10 I=1,M
      DO 20 J=1,N
   20 TEMP(J)=DATA(I,J)
      IF (IB.EQ.0) CALL RFFTF(N,TEMP,COEF)
      IF (IB.EQ.1) CALL SINQB(N,TEMP,COEF)
      IF (IB.EQ.2) CALL COSQB(N,TEMP,COEF)
      DO 15 J=1,N
      DATA(I,J)=TEMP(J)
 15   CONTINUE
 10   CONTINUE
      RETURN
      END
C
      SUBROUTINE FFTB(DATA,M,N,MD)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION DATA(MD,*)
      PARAMETER (NDY=512,NCOEF=3*NDY+15)
      COMMON/FFT01/TEMP(NDY),COEF(NCOEF),DIAG(NDY),IB
      DO 10 I=1,M
      DO 20 J=1,N
   20 TEMP(J)=DATA(I,J)
      IF (IB.EQ.0) CALL RFFTB(N,TEMP,COEF)
      IF (IB.EQ.1) CALL SINQF(N,TEMP,COEF)
      IF (IB.EQ.2) CALL COSQF(N,TEMP,COEF)
      K=4
      IF(IB.EQ.0) K=1
      DO 15 J=1,N
      DATA(I,J)=TEMP(J)/(K*N)
 15   CONTINUE
 10   CONTINUE
      RETURN
      END

      SUBROUTINE SMOOTH (NX2,NY2,HX,HY,Q,BC,BD,TEMP)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION BD(4)
      DIMENSION Q(NX2,NY2), BC(4), TEMP(*)
      DIMENSION CS(5), DS(5)
      DATA CS /4*.25D0,-1.25D0/, DS /4*.5D0,3.5D0/, NS /5/
C
C      SMOOTH IN X AND Y WITH BOUNDARY CONDITIONS
C
C     BC(1)*Q(X=0,J)+BC(2)*DQ/DX(X=0,J)= 0 (J=2,NY+1)
C     BC(3)*Q(X=NX*HX,J)+BC(4)*DQ(DX(X=NX*HX,J) = 0 (J=2,NY+1)
C     BD(1)*Q(I,Y=0)+BD(2)*DQ/DY(I,Y=0) = 0 (I=2,NX+1)
C     BD(3)*Q(I,Y=NY*HY)+BD(4)*DQ/DY(I,Y=NY*HY) = 0 (I=2,NX+1)
C
      NX1=NX2-1
      NX=NX1-1
      NY1=NY2-1
      NY=NY1-1
      NX2NY=NX2*NY
      NX2NY1=NX2*NY1
      I1=0
      I2=NX2
      J1=0
      J2=NY2
      KSX=1
      IF (BC(1).EQ.0.D0.AND.BC(2).EQ.0.D0) KSX=0
      IF (KSX.NE.0) THEN
            BC1=.5D0*BC(1)-BC(2)/HX
            BC2=.5D0*BC(1)+BC(2)/HX
            BC3=.5D0*BC(3)-BC(4)/HX
            BC4=.5D0*BC(3)+BC(4)/HX
      ENDIF
      KSY=1
      IF (BD(1).EQ.0.D0.AND.BD(2).EQ.0.D0) KSY=0
      IF(KSY.NE.0) THEN
            BD1=.5D0*BD(1)-BD(2)/HY
            BD2=.5D0*BD(1)+BD(2)/HY
            BD3=.5D0*BD(3)-BD(4)/HY
            BD4=.5D0*BD(3)+BD(4)/HY
      ENDIF
      NTEMP=2*MAX0(NX2,NY2)
      DO 20 I=1,NTEMP
   20 TEMP(I)=0.D0
C
C     X-SMOOTHING
C
      DO 110 IS=1,NS
      C=CS(IS)
      DC=DS(IS)/C
      IF (KSX.NE.0) THEN
            B1=BC1/C
            B2=BC2/C
            B3=BC3/C
            B4=BC4/C
            IJ=1
            DO 30 J=1,NY2
            TEMP(J+J2)=B1*Q(1,J)+B2*Q(2,J)
   30       CONTINUE
      ENDIF
      DO 70 I=2,NX1
      DO 50 J=1,NY2
      TEMP(J+J1)=Q(I-1,J)+DC*Q(I,J)+Q(I+1,J)
   50 CONTINUE
      DO 60 J=1,NY2
      Q(I-1,J)=C*TEMP(J+J2)
   60 CONTINUE
      JH=J1
      J1=J2
   70 J2=JH
      IF (KSX.NE.0) THEN
C
C         APERIODIC IN X
C
            B1I=1.D0/BC1
            B21=BC2*B1I
            B4I=1.D0/BC4
            B34=BC3*B4I
            I=1
            DO 80 J=1,NY2
            Q(1,J)=-B21*Q(2,J)+B1I*Q(1,J)
            Q(NX2,J)=BC3*Q(NX1,J)+BC4*Q(NX2,J)
            Q(NX1,J)=C*TEMP(J+J2)
            Q(NX2,J)=-B34*Q(NX1,J)+B4I*Q(NX2,J)
   80       CONTINUE
      ELSE
C
C         PERIODIC IN X
C
            DO 100 J=1,NY2
            Q(NX1,J)=C*TEMP(J+J2)
            Q(1,J)=Q(NX1,J)
            Q(NX2,J)=Q(2,J)
  100       CONTINUE
      ENDIF
  110 CONTINUE
C
C     Y-SMOOTHING
C
      DO 105 I=1,NTEMP
  105 TEMP(I)=0.D0
      DO 160 IS=1,NS
      C=CS(IS)
      DC=DS(IS)/C
      IJ=NX2+1
      IF (KSY.NE.0) THEN
            B1=BD1/C
            B2=BD2/C
            B3=BD3/C
            B4=BD4/C
            DO 115 I=1,NX2
            TEMP(I+I2)=B1*Q(I,1)+B2*Q(I,2)
 115        CONTINUE
      ENDIF
      DO 140 J=2,NY1
      DO 120 I=1,NX2
      TEMP(I+I1)=Q(I,J-1)+DC*Q(I,J)+Q(I,J+1)
  120 CONTINUE
      DO 130 I=1,NX2
      Q(I,J-1)=C*TEMP(I+I2)
  130 CONTINUE
      IH=I1
      I1=I2
  140 I2=IH
      IF (KSY.NE.0) THEN
C
C       APERIODIC IN Y
C
            B1I=1.D0/BD1
            B21=BD2*B1I
            B4I=1.D0/BD4
            B34=BD3*B4I
            DO 147 J=1,NX2
            Q(J,1)=-B21*Q(J,2)+B1I*Q(J,1)
            Q(J,NY2)=BD3*Q(J,NY1)+BD4*Q(J,NY2)
            Q(J,NY1)=C*TEMP(J+I2)
            Q(J,NY2)=-B34*Q(J,NY1)+B4I*Q(J,NY2)
 147        CONTINUE
      ELSE
C
C         PERIODIC IN Y
C
            DO 150 I=1,NX2
            Q(I,NY1)=C*TEMP(I+I2)
            Q(I,1)=Q(I,NY1)
  150       Q(I,NY2)=Q(I,2)
      ENDIF
  160 CONTINUE
      RETURN
      END

      SUBROUTINE ECRD (X,Y,N)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION X(N), Y(N)
      DO 10 I=1,N
      X(I)=Y(I)
   10 CONTINUE
      RETURN
      ENTRY ECWR(X,Y,N)
      DO 20 I=1,N
      Y(I)=X(I)
   20 CONTINUE
      RETURN
      END

       FUNCTION RANF(R)
       DOUBLE PRECISION RANF

C             random number,special functions,uniform
C***author  fullerton, w., (lanl)
C***purpose  generates a uniformly distributed random number.
C***description
C
C      this pseudo-random number generator is portable among a wide
C variety of computers.  rand(r) undoubtedly is not as good as many
C readily available installation dependent versions, and so this
C routine is not recommended for widespread usage.  its redeeming
C feature is that the exact same random numbers (to within final round-
C off error) can be generated from machine to machine.  thus, programs
C that make use of random numbers can be easily transported to and
C checked in a new environment.
C      the random numbers are generated by the linear congruential
C method described, e.g., by knuth in seminumerical methods (p.9),
C addison-wesley, 1969.  given the i-th number of a pseudo-random
C sequence, the i+1 -st number is generated from
C             x(i+1) = (a*x(i) + c) mod m,
C where here m = 2**22 = 4194304, c = 1731 and several suitable values
C of the multiplier a are discussed below.  both the multiplier a and
C random number x are represented in double precision as two 11-bit
C words.  the constants are chosen so that the period is the maximum
C possible, 4194304.
C      in order that the same numbers be generated from machine to
C machine, it is necessary that 23-bit integers be reducible modulo
C 2**11 exactly, that 23-bit integers be added exactly, and that 11-bit
C integers be multiplied exactly.  furthermore, if the restart option
C is used (where r is between 0 and 1), then the product r*2**22 =
C r*4194304 must be correct to the nearest integer.
C      the first four random numbers should be .0004127026,
C .6750836372, .1614754200, and .9086198807.  the tenth random number
C is .5527787209, and the hundredth is .3600893021 .  the thousandth
C number should be .2176990509 .
C      in order to generate several effectively independent sequences
C with the same generator, it is necessary to know the random number
C for several widely spaced calls.  the i-th random number times 2**22,
C where i=k*p/8 and p is the period of the sequence (p = 2**22), is
C still of the form l*p/8.  in particular we find the i-th random
C number multiplied by 2**22 is given by
C i   =  0  1*p/8  2*p/8  3*p/8  4*p/8  5*p/8  6*p/8  7*p/8  8*p/8
C rand=  0  5*p/8  2*p/8  7*p/8  4*p/8  1*p/8  6*p/8  3*p/8  0
C thus the 4*p/8 = 2097152 random number is 2097152/2**22.
C      several multipliers have been subjected to the spectral test
C (see knuth, p. 82).  four suitable multipliers roughly in order of
C goodness according to the spectral test are
C    3146757 = 1536*2048 + 1029 = 2**21 + 2**20 + 2**10 + 5
C    2098181 = 1024*2048 + 1029 = 2**21 + 2**10 + 5
C    3146245 = 1536*2048 +  517 = 2**21 + 2**20 + 2**9 + 5
C    2776669 = 1355*2048 + 1629 = 5**9 + 7**7 + 1
C
C      in the table below log10(nu(i)) gives roughly the number of
C random decimal digits in the random numbers considered i at a time.
C c is the primary measure of goodness.  in both cases bigger is better.
C
C                   log10 nu(i)              c(i)
C       a       i=2  i=3  i=4  i=5    i=2  i=3  i=4  i=5
C
C    3146757    3.3  2.0  1.6  1.3    3.1  1.3  4.6  2.6
C    2098181    3.3  2.0  1.6  1.2    3.2  1.3  4.6  1.7
C    3146245    3.3  2.2  1.5  1.1    3.2  4.2  1.1  0.4
C    2776669    3.3  2.1  1.6  1.3    2.5  2.0  1.9  2.6
C   best
C    possible   3.3  2.3  1.7  1.4    3.6  5.9  9.7  14.9
C
C             input argument --
C r      if r=0., the next random number of the sequence is generated.
C        if r .lt. 0., the last generated number will be returned for
C          possible use in a restart procedure.
C        if r .gt. 0., the sequence of random numbers will start with
C          the seed r mod 1.  this seed is also returned as the value of
C          rand provided the arithmetic is done exactly.
C
C             output value --
C rand   a pseudo-random number between 0. and 1.
      SAVE IX1, IX0
      PARAMETER (IA1=1536, IA0=1029, IA1MA0=507, IC=1731)
      DATA IX1, IX0 /0, 0/
C***first executable statement  rand
C
C           a*x = 2**22*ia1*ix1 + 2**11*(ia1*ix1 + (ia1-ia0)*(ix0-ix1)
C                   + ia0*ix0) + ia0*ix0
C
      IY0 = IA0*IX0
      IY1 = IA1*IX1 + IA1MA0*(IX0-IX1) + IY0
      IY0 = IY0 + IC
      IX0 = MOD (IY0, 2048)
      IY1 = IY1 + (IY0-IX0)/2048
      IX1 = MOD (IY1, 2048)
C
 10   RANF = IX1*2048 + IX0
      RANF = RANF * 2.38418579D-07
      RETURN
      END

      SUBROUTINE PARMVR
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C       RELATIVISTIC PARTICLE MOVER
      PARAMETER (NBB=512)
      PARAMETER (NC1 = 78885)
      PARAMETER (N1D=5000)
c specmod
      COMMON  PBUF(NBB,5),Q(NC1),TEMP(2*N1D),TBUF(5,NBB)
      COMMON/POTEN1/ SS(NC1),W(NC1),AX(NC1)
      COMMON/POTEN2/ AX1(NC1),AY(NC1),AY1(NC1)
      COMMON/POTEN3/ AZ(NC1),AZ1(NC1)
      COMMON/CURR/ CX(NC1),CY(NC1),CZ(NC1)
      COMMON/EFILD/EX(NC1),EY(NC1),EZ(NC1),BX(NC1),BY(NC1),BZ(NC1)
      COMMON/QBK/ QBK(NC1)
      DIMENSION X(NBB),Y(NBB),VX(NBB),VY(NBB),VZ(NBB)
      EQUIVALENCE (X(1),PBUF(1,1)),(Y(1),PBUF(1,2)),(VX(1),PBUF(1,3)),
     *  (VY(1),PBUF(1,4)),(VZ(1),PBUF(1,5))

      COMMON/PARCM/NX,NY,L3,L4,KBND,NX2,NX1,NY1,NY2,IBCDL,IBCDR,
     *   IBCDT,IBCDB,KBR,LSTL,LSTR,NINJL,NINJR,KBNDY,INOP,
     *   XMAX,YMAX,DT,QMULT,WMULT,XLEFT,XRIGHT,
     *   HX,HY,HXI,HYI,VMPX1,VMPY1,
     *   VMPZ1,ELOST,QLOSTL,QLOSTR,QLOSTT,QLOSTB,
     *   YTOP,YBOT,DRINJ,DLINJ,VRINJ,VLINJ,
     *   TRPAR,TLPAR,DTLPAR,DTRPAR,QINJL,QINJR,EINJ
      DIMENSION HHA(NBB),HHASQ(NBB),C(NBB),F(NBB),G(NBB),XMULT(NBB),
     1 YMULT(NBB),ZMULT(NBB),GA(NBB),XH(NBB),YH(NBB),VXH(NBB),DX(NBB)
     2 ,DY(NBB),W1(NBB),W2(NBB),W3(NBB),W4(NBB),IJ(NBB),EXA(NBB),
     3 EYA(NBB),EZA(NBB),BXA(NBB),BYA(NBB),BZA(NBB),H(NBB),QMLT(NBB)
      COMMON /SCR/ SCR(NBB,18)
      COMMON /PARBD1/ JB, LB,IB(NBB),IBEG,IEND
      DIMENSION I(NBB),FX(NBB),FY(NBB),VXA(NBB),VYA(NBB),VZA(NBB)
      EQUIVALENCE (EXA,SCR(1,1)), (EYA,SCR(1,2))
      EQUIVALENCE (EZA,SCR(1,3)), (BXA,SCR(1,4))
      EQUIVALENCE (BYA,SCR(1,5)), (BZA,SCR(1,6))
      EQUIVALENCE (W1,SCR(1,7)), (W2,SCR(1,8))
      EQUIVALENCE (W3,SCR(1,9)), (W4,SCR(1,10))
      EQUIVALENCE (IJ,SCR(1,11)), (GA,SCR(1,12))
      EQUIVALENCE (VXA,SCR(1,13)), (VYA,SCR(1,14))
      EQUIVALENCE (VZA,SCR(1,15)), (XMULT,SCR(1,16))
      EQUIVALENCE (YMULT,SCR(1,17)), (ZMULT,SCR(1,18))
      EQUIVALENCE (EXA,VXH), (W1,HHA), (W2,HHASQ), (W3,C)
      EQUIVALENCE (EYA,XH), (EZA,YH),(BYA,DX), (BZA,DY)
      EQUIVALENCE (W4,F), (IJ,G), (XMULT,H), (BYA,QMLT)
      EQUIVALENCE (VZA,FY)
      EQUIVALENCE (VYA,FX)
      EQUIVALENCE (VXA,I)
C
      H1 = DT*QMULT/WMULT
      HH = .5D0*H1
      DO 10 L = L3,L4
         H(L) = H1
   10 IF (X(L).LT.0.) H(L) = 0.D0
C
C    CALCULATE OLD GAMMAS.
      DO 20 L = L3,L4
         GA(L) = VX(L)**2+VY(L)**2+VZ(L)**2+1.D0
         GA(L) = DSQRT(GA(L))
         GA(L) = 1.D0/GA(L)
   20 CONTINUE
C    CALCULATE AREA WEIGHT VECTORS
      DO 30 L = L3,L4
         RX = HXI*X(L)+1.5D0
         RY = HYI*Y(L)+1.5D0
         I(L) = RX
         IF (I(L).LT.1) I(L) = 1
         FX(L) = RX-I(L)
         FXC = 1.D0-FX(L)
         J = RY
         FY(L) = RY-J
         FYC = 1.D0-FY(L)
         IJ(L) = I(L)+NX2*(J-1)
         W1(L) = FXC*FYC
         W2(L) = FX(L)*FYC
         W3(L) = FXC*FY(L)
         W4(L) = FX(L)*FY(L)
   30 CONTINUE
C  FETCH EX FIELD VECTOR
C    CALCULATE AVERAGE FIELD ON PARTICLE
C     1EF4,NX2,324)
      DO 40 L = L3,L4
         EXA(L) = W1(L)*EX(IJ(L))+W2(L)*EX(IJ(L)+1)
     1           +W3(L)*EX(IJ(L)+NX2)+W4(L)*EX(IJ(L)+NX2+1)
         EYA(L) = W1(L)*EY(IJ(L))+W2(L)*EY(IJ(L)+1)
     1           +W3(L)*EY(IJ(L)+NX2)+W4(L)*EY(IJ(L)+NX2+1)
         EZA(L) = W1(L)*EZ(IJ(L))+W2(L)*EZ(IJ(L)+1)
     1           +W3(L)*EZ(IJ(L)+NX2)+W4(L)*EZ(IJ(L)+NX2+1)
         BXA(L) = W1(L)*BX(IJ(L))+W2(L)*BX(IJ(L)+1)
     1           +W3(L)*BX(IJ(L)+NX2)+W4(L)*BX(IJ(L)+NX2+1)
         BYA(L) = W1(L)*BY(IJ(L))+W2(L)*BY(IJ(L)+1)
     1           +W3(L)*BY(IJ(L)+NX2)+W4(L)*BY(IJ(L)+NX2+1)
         BZA(L) = W1(L)*BZ(IJ(L))+W2(L)*BZ(IJ(L)+1)
     1           +W3(L)*BZ(IJ(L)+NX2)+W4(L)*BZ(IJ(L)+NX2+1)
   40 CONTINUE
C  ADVANCE THREE COMPONENTS OF MOMENTUM
      DO 50 L = L3,L4
         HHA(L) = HH*GA(L)
         HHASQ(L) = HHA(L)*GA(L)
         C(L) = GA(L)*(1.-HHASQ(L)*(VX(L)*EXA(L)+VY(L)*EYA(L)
     1          +VZ(L)*EZA(L)))
         F(L) = 1.D0-H(L)*HHASQ(L)*(BXA(L)**2+BYA(L)**2+BZA(L)**2)
         G(L) = HHASQ(L)*(VX(L)*BXA(L)+VY(L)*BYA(L)+VZ(L)*BZA(L))
         VXA(L) = C(L)*VX(L)+HHA(L)*EXA(L)
         VYA(L) = C(L)*VY(L)+HHA(L)*EYA(L)
         VZA(L) = C(L)*VZ(L)+HHA(L)*EZA(L)
         VX(L) = F(L)*VX(L)+H(L)*(EXA(L)+G(L)*BXA(L)
     1           +VYA(L)*BZA(L)-VZA(L)*BYA(L))
         VY(L) = F(L)*VY(L)+H(L)*(EYA(L)+G(L)*BYA(L)
     1          +VZA(L)*BXA(L)-VXA(L)*BZA(L))
         VZ(L) = F(L)*VZ(L)+H(L)*(EZA(L)+G(L)*BZA(L)
     1          +VXA(L)*BYA(L)-VYA(L)*BXA(L))
   50 CONTINUE
C   COMPUTE NEW GAMMAS
      DO 60 L = L3,L4
         GA(L) = VX(L)**2+VY(L)**2+VZ(L)**2+1.D0
         GA(L) = DSQRT(GA(L))
         GA(L) = 1.D0/GA(L)
   60 CONTINUE
C   ADVANCE WHOLE AND HALF-TIME POSITIONS.
      DO 70 L = L3,L4
         VXH(L) = VX(L)
         DX(L) = GA(L)*DT*VX(L)
         DY(L) = GA(L)*DT*VY(L)
         IF (X(L).LT.0.) DX(L) = 0.D0
         IF (X(L).LT.0.) DY(L) = 0.D0
         XH(L) = X(L)+.5D0*DX(L)
         X(L) = X(L)+DX(L)
         YH(L) = Y(L)+.5D0*DY(L)
         Y(L) = Y(L)+DY(L)
   70 CONTINUE

C   CHECK FOR PARTICLE BOUNDARY CROSSINGS

      JB = 0
      DO 80 L = L3,L4
         IB(L) = 0
         IF (X(L).GE.XRIGHT) IB(L) = 1
         IF (X(L).LT.XLEFT) IB(L) = 1
         IF (Y(L).LT.0.) IB(L) = 1
         IF (Y(L).GE.YMAX) IB(L) = 1
   80 CONTINUE
      DO 81 L = L3,L4
         JB = JB+IB(L)
         IF(IB(L).NE.0) IB(JB) = L
 81   CONTINUE
      IF (JB.GT.0) CALL BCND

C   CALCULATE AREA WEIGHT VECTORS AT HALF-TIME STEP.

      DO 90 L = L3,L4
         RX = HXI*XH(L)+1.5D0
         RY = HYI*YH(L)+1.5D0
         I(L) = RX
         IF (I(L).LT.1) I(L) = 1
         FX(L) = RX-I(L)
         FXC = 1.D0-FX(L)
         J = RY
         FY(L) = RY-J
         FYC = 1.D0-FY(L)
         IJ(L) = I(L)+NX2*(J-1)
         W1(L) = FXC*FYC
         W2(L) = FX(L)*FYC
         W3(L) = FXC*FY(L)
         W4(L) = FX(L)*FY(L)
   90 CONTINUE
C   AREA WEIGHT PARTICLES ONTO CURRENT GRIDS
      DO 100 L = L3,L4
         QMLT(L) = QMULT
  100 IF (X(L).LT.0.) QMLT(L) = 0.D0
      DO 110 L = L3,L4
         QMA = QMLT(L)*GA(L)
         XMULT(L) = QMA*VXH(L)
         YMULT(L) = QMA*VY(L)
  110 ZMULT(L) = QMA*VZ(L)
      DO 120 L = L3,L4
         CX(IJ(L)) = CX(IJ(L))+XMULT(L)*W1(L)
         CX(IJ(L)+1) = CX(IJ(L)+1)+XMULT(L)*W2(L)
         CX(IJ(L)+NX2) = CX(IJ(L)+NX2)+XMULT(L)*W3(L)
         CX(IJ(L)+NX2+1) = CX(IJ(L)+NX2+1)+XMULT(L)*W4(L)
         CY(IJ(L)) = CY(IJ(L))+YMULT(L)*W1(L)
         CY(IJ(L)+1) = CY(IJ(L)+1)+YMULT(L)*W2(L)
         CY(IJ(L)+NX2) = CY(IJ(L)+NX2)+YMULT(L)*W3(L)
         CY(IJ(L)+NX2+1) = CY(IJ(L)+NX2+1)+YMULT(L)*W4(L)
         CZ(IJ(L)) = CZ(IJ(L))+ZMULT(L)*W1(L)
         CZ(IJ(L)+1) = CZ(IJ(L)+1)+ZMULT(L)*W2(L)
         CZ(IJ(L)+NX2) = CZ(IJ(L)+NX2)+ZMULT(L)*W3(L)
         CZ(IJ(L)+NX2+1) = CZ(IJ(L)+NX2+1)+ZMULT(L)*W4(L)
  120 CONTINUE
C    CALCULATE AREA WEIGHT VECTORS AT WHOLE TIME
      DO 130 L = L3,L4
         RX = HXI*X(L)+1.5D0
         RY = HYI*Y(L)+1.5D0
         I(L) = RX
         IF (I(L).LT.1) I(L) = 1
         FX(L) = RX-I(L)
         FXC = 1.D0-FX(L)
         J = RY
         FY(L) = RY-J
         FYC = 1.D0-FY(L)
         IJ(L) = I(L)+NX2*(J-1)
         W1(L) = FXC*FYC
         W2(L) = FX(L)*FYC
         W3(L) = FXC*FY(L)
         W4(L) = FX(L)*FY(L)
  130 CONTINUE
C  AREA WEIGHT PARTICLES ONTO CHARGE GRID
      DO 140 L = L3,L4
         Q(IJ(L)) = Q(IJ(L))+W1(L)*QMLT(L)
         Q(IJ(L)+1) = Q(IJ(L)+1)+W2(L)*QMLT(L)
         Q(IJ(L)+NX2) = Q(IJ(L)+NX2)+W3(L)*QMLT(L)
         Q(IJ(L)+NX2+1) = Q(IJ(L)+NX2+1)+W4(L)*QMLT(L)
C
  140 CONTINUE
      RETURN
      END

      SUBROUTINE PARMOV
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C       NONRELATIVISTIC ELECTROMAGNETIC PARTICLE MOVER
C REVISION 2.3  86/01/13  22:22:06  DWF
      PARAMETER (NBB=512)
      PARAMETER (NC1 = 78885)
      PARAMETER (N1D=5000)
c specmod
      COMMON  PBUF(NBB,5),Q(NC1),TEMP(2*N1D),TBUF(5,NBB)
      COMMON/POTEN1/ SS(NC1),W(NC1),AX(NC1)
      COMMON/POTEN2/ AX1(NC1),AY(NC1),AY1(NC1)
      COMMON/POTEN3/ AZ(NC1),AZ1(NC1)
      COMMON/CURR/ CX(NC1),CY(NC1),CZ(NC1)
      COMMON/EFIELD/EX(NC1),EY(NC1),EZ(NC1),BX(NC1),BY(NC1),BZ(NC1)
      COMMON/QBK/ QBK(NC1)
      DIMENSION X(NBB),Y(NBB),VX(NBB),VY(NBB),VZ(NBB)
      EQUIVALENCE (X(1),PBUF(1,1)),(Y(1),PBUF(1,2)),(VX(1),PBUF(1,3)),
     *  (VY(1),PBUF(1,4)),(VZ(1),PBUF(1,5))

      COMMON/PARCM/NX,NY,L3,L4,KBND,NX2,NX1,NY1,NY2,IBCDL,IBCDR,
     *   IBCDT,IBCDB,KBR,LSTL,LSTR,NINJL,NINJR,KBNDY,INOP,
     *   XMAX,YMAX,DT,QMULT,WMULT,XLEFT,XRIGHT,
     *   HX,HY,HXI,HYI,VMPX1,VMPY1,
     *   VMPZ1,ELOST,QLOSTL,QLOSTR,QLOSTT,QLOSTB,
     *   YTOP,YBOT,DRINJ,DLINJ,VRINJ,VLINJ,
     *   TRPAR,TLPAR,DTLPAR,DTRPAR,QINJL,QINJR,EINJ

      DIMENSION HHA(NBB),HHASQ(NBB),C(NBB),F(NBB),G(NBB),XMULT(NBB),
     1 YMULT(NBB),ZMULT(NBB),GA(NBB),XH(NBB),YH(NBB),VXH(NBB),DX(NBB)
     2 ,DY(NBB),W1(NBB),W2(NBB),W3(NBB),W4(NBB),IJ(NBB),EXA(NBB),
     3 EYA(NBB),EZA(NBB),BXA(NBB),BYA(NBB),BZA(NBB),H(NBB),QMLT(NBB)
      COMMON /SCR/ SCR(NBB,18)
      COMMON /PARBD1/ JB, LB,IB(NBB),IBEG,IEND
      DIMENSION I(NBB),FX(NBB),FY(NBB),VXA(NBB),VYA(NBB),VZA(NBB)
      EQUIVALENCE (EXA,SCR(1,1)), (EYA,SCR(1,2))
      EQUIVALENCE (EZA,SCR(1,3)), (BXA,SCR(1,4))
      EQUIVALENCE (BYA,SCR(1,5)), (BZA,SCR(1,6))
      EQUIVALENCE (W1,SCR(1,7)), (W2,SCR(1,8))
      EQUIVALENCE (W3,SCR(1,9)), (W4,SCR(1,10))
      EQUIVALENCE (IJ,SCR(1,11)), (GA,SCR(1,12))
      EQUIVALENCE (VXA,SCR(1,13)), (VYA,SCR(1,14))
      EQUIVALENCE (VZA,SCR(1,15)), (XMULT,SCR(1,16))
      EQUIVALENCE (YMULT,SCR(1,17)), (ZMULT,SCR(1,18))
      EQUIVALENCE (EXA,VXH), (W1,HHA), (W2,HHASQ), (W3,C)
      EQUIVALENCE (EYA,XH), (EZA,YH),(BYA,DX), (BZA,DY)
      EQUIVALENCE (W4,F), (IJ,G), (XMULT,H), (BYA,QMLT)
      EQUIVALENCE (VZA,FY)
      EQUIVALENCE (VYA,FX)
      EQUIVALENCE (VXA,I)
C
      H1 = DT*QMULT/WMULT
      HH = .5D0*H1
      DO 10 L = L3,L4
         H(L) = H1
   10 IF (X(L).LT.0.D0) H(L) = 0.D0
C
C    CALCULATE AREA WEIGHT VECTORS

      DO 20 L = L3,L4
         RX = HXI*X(L)+1.5D0
         RY = HYI*Y(L)+1.5D0
         I(L) = RX
         IF (I(L).LT.1) I(L) = 1
         FX(L) = RX-I(L)
         FXC = 1.D0-FX(L)
         J = RY
         FY(L) = RY-J
         FYC = 1.D0-FY(L)
         IJ(L) = I(L)+NX2*(J-1)
         W1(L) = FXC*FYC
         W2(L) = FX(L)*FYC
         W3(L) = FXC*FY(L)
         W4(L) = FX(L)*FY(L)
   20 CONTINUE

C    FETCH EX FIELD VECTOR
C    CALCULATE AVERAGE FIELD ON PARTICLE

      DO 30 L = L3,L4
         EXA(L) = W1(L)*EX(IJ(L))+W2(L)*EX(IJ(L)+1)
     1           +W3(L)*EX(IJ(L)+NX2)+W4(L)*EX(IJ(L)+NX2+1)
         EYA(L) = W1(L)*EY(IJ(L))+W2(L)*EY(IJ(L)+1)
     1           +W3(L)*EY(IJ(L)+NX2)+W4(L)*EY(IJ(L)+NX2+1)
         EZA(L) = W1(L)*EZ(IJ(L))+W2(L)*EZ(IJ(L)+1)
     1           +W3(L)*EZ(IJ(L)+NX2)+W4(L)*EZ(IJ(L)+NX2+1)
         BXA(L) = W1(L)*BX(IJ(L))+W2(L)*BX(IJ(L)+1)
     1           +W3(L)*BX(IJ(L)+NX2)+W4(L)*BX(IJ(L)+NX2+1)
         BYA(L) = W1(L)*BY(IJ(L))+W2(L)*BY(IJ(L)+1)
     1           +W3(L)*BY(IJ(L)+NX2)+W4(L)*BY(IJ(L)+NX2+1)
         BZA(L) = W1(L)*BZ(IJ(L))+W2(L)*BZ(IJ(L)+1)
     1           +W3(L)*BZ(IJ(L)+NX2)+W4(L)*BZ(IJ(L)+NX2+1)
   30 CONTINUE
C  ADVANCE THREE COMPONENTS OF VELOCITY
      DO 40 L = L3,L4
         HHA(L) = HH
         F(L) = 1.D0-H(L)*HHA(L)*(BXA(L)**2+BYA(L)**2+BZA(L)**2)
         G(L) = HHA(L)*(VX(L)*BXA(L)+VY(L)*BYA(L)+VZ(L)*BZA(L))
         VXA(L) = VX(L)+HHA(L)*EXA(L)
         VYA(L) = VY(L)+HHA(L)*EYA(L)
         VZA(L) = VZ(L)+HHA(L)*EZA(L)
         VX(L) = F(L)*VX(L)+H(L)*(EXA(L)+G(L)*BXA(L)
     1              +VYA(L)*BZA(L)-VZA(L)*BYA(L))
         VY(L) = F(L)*VY(L)+H(L)*(EYA(L)+G(L)*BYA(L)
     1              +VZA(L)*BXA(L)-VXA(L)*BZA(L))
         VZ(L) = F(L)*VZ(L)+H(L)*(EZA(L)+G(L)*BZA(L)
     1              +VXA(L)*BYA(L)-VYA(L)*BXA(L))
   40 CONTINUE
C   ADVANCE WHOLE AND HALF-TIME POSITIONS.
      DO 50 L = L3,L4
         VXH(L) = VX(L)
         DX(L) = DT*VX(L)
         DY(L) = DT*VY(L)
         IF (X(L).LT.0.) DX(L) = 0.D0
         IF (X(L).LT.0.) DY(L) = 0.D0
         XH(L) = X(L)+.5D0*DX(L)
         X(L) = X(L)+DX(L)
         YH(L) = Y(L)+.5D0*DY(L)
         Y(L) = Y(L)+DY(L)
   50 CONTINUE
C   CHECK FOR PARTICLE BOUNDARY CROSSINGS
      JB = 0
      DO 60 L = L3,L4
          IB(L) = 0
          IF (X(L).GE.XRIGHT) IB(L) = 1
      IF (X(L).LT.XLEFT) IB(L) = 1
      IF (Y(L).LT.0.) IB(L) = 1
      IF (Y(L).GE.YMAX) IB(L) = 1
   60 CONTINUE
      DO 61 L = L3,L4
          JB = JB+IB(L)
          IF(IB(L).NE.0) IB(JB) = L
   61 CONTINUE
      IF (JB.GT.0) CALL BCND

C   CALCULATE AREA WEIGHT VECTORS A HALF-TIME STEP.

      DO 70 L = L3,L4
          RX = HXI*XH(L)+1.5D0
          RY = HYI*YH(L)+1.5D0
          I(L) = RX
          IF (I(L).LT.1) I(L) = 1
          FX(L) = RX-I(L)
          FXC = 1.D0-FX(L)
          J = RY
          FY(L) = RY-J
          FYC = 1.D0-FY(L)
          IJ(L) = I(L)+NX2*(J-1)
          W1(L) = FXC*FYC
          W2(L) = FX(L)*FYC
          W3(L) = FXC*FY(L)
          W4(L) = FX(L)*FY(L)
   70 CONTINUE

C   AREA WEIGHT PARTICLES ONTO CURRENT GRIDS

      DO 80 L = L3,L4
          QMLT(L) = QMULT
   80 IF (X(L).LT.0.) QMLT(L) = 0.D0
      DO 90 L = L3,L4
          XMULT(L) = QMLT(L)*VXH(L)
          YMULT(L) = QMLT(L)*VY(L)
   90 ZMULT(L) = QMLT(L)*VZ(L)
      DO 100 L = L3,L4
          CX(IJ(L)) = CX(IJ(L))+XMULT(L)*W1(L)
          CX(IJ(L)+1) = CX(IJ(L)+1)+XMULT(L)*W2(L)
          CX(IJ(L)+NX2) = CX(IJ(L)+NX2)+XMULT(L)*W3(L)
          CX(IJ(L)+NX2+1) = CX(IJ(L)+NX2+1)+XMULT(L)*W4(L)
          CY(IJ(L)) = CY(IJ(L))+YMULT(L)*W1(L)
          CY(IJ(L)+1) = CY(IJ(L)+1)+YMULT(L)*W2(L)
          CY(IJ(L)+NX2) = CY(IJ(L)+NX2)+YMULT(L)*W3(L)
          CY(IJ(L)+NX2+1) = CY(IJ(L)+NX2+1)+YMULT(L)*W4(L)
          CZ(IJ(L)) = CZ(IJ(L))+ZMULT(L)*W1(L)
          CZ(IJ(L)+1) = CZ(IJ(L)+1)+ZMULT(L)*W2(L)
          CZ(IJ(L)+NX2) = CZ(IJ(L)+NX2)+ZMULT(L)*W3(L)
          CZ(IJ(L)+NX2+1) = CZ(IJ(L)+NX2+1)+ZMULT(L)*W4(L)
  100 CONTINUE
C    CALCULATE AREA WEIGHT VECTORS AT WHOLE TIME
      DO 110 L = L3,L4
          RX = HXI*X(L)+1.5D0
          RY = HYI*Y(L)+1.5D0
          I(L) = RX
          IF (I(L).LT.1) I(L) = 1
          FX(L) = RX-I(L)
          FXC = 1.D0-FX(L)
          J = RY
          FY(L) = RY-J
          FYC = 1.D0-FY(L)
          IJ(L) = I(L)+NX2*(J-1)
          W1(L) = FXC*FYC
          W2(L) = FX(L)*FYC
          W3(L) = FXC*FY(L)
          W4(L) = FX(L)*FY(L)
  110 CONTINUE
C  AREA WEIGHT PARTICLES ONTO CHARGE GRID
      DO 120 L = L3,L4
          Q(IJ(L)) = Q(IJ(L))+W1(L)*QMLT(L)
          Q(IJ(L)+1) = Q(IJ(L)+1)+W2(L)*QMLT(L)
          Q(IJ(L)+NX2) = Q(IJ(L)+NX2)+W3(L)*QMLT(L)
          Q(IJ(L)+NX2+1) = Q(IJ(L)+NX2+1)+W4(L)*QMLT(L)
C
  120 CONTINUE
      RETURN
      END

      SUBROUTINE PARMVE
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C       ELECTROSTATIC PARTICLE MOVER
C REVISION 2.3  86/01/13  22:22:06  DWF

      PARAMETER (NBB=512)
      PARAMETER (NC1 = 78885)
      PARAMETER (N1D=5000)

c specmod
      COMMON  PBUF(NBB,5),Q(NC1),TEMP(2*N1D),TBUF(5,NBB)
      COMMON/POTEN1/ SS(NC1),W(NC1),AX(NC1)
      COMMON/POTEN2/ AX1(NC1),AY(NC1),AY1(NC1)
      COMMON/POTEN3/ AZ(NC1),AZ1(NC1)
      COMMON/CURR/ CX(NC1),CY(NC1),CZ(NC1)
      COMMON/EFIELD/EX(NC1),EY(NC1),EZ(NC1),BX(NC1),BY(NC1),BZ(NC1)
      COMMON/QBK/ QBK(NC1)
      DIMENSION X(NBB),Y(NBB),VX(NBB),VY(NBB),VZ(NBB)
      EQUIVALENCE (X(1),PBUF(1,1)),(Y(1),PBUF(1,2)),(VX(1),PBUF(1,3)),
     *  (VY(1),PBUF(1,4)),(VZ(1),PBUF(1,5))

      COMMON/PARCM/NX,NY,L3,L4,KBND,NX2,NX1,NY1,NY2,IBCDL,IBCDR,
     *   IBCDT,IBCDB,KBR,LSTL,LSTR,NINJL,NINJR,KBNDY,INOP,
     *   XMAX,YMAX,DT,QMULT,WMULT,XLEFT,XRIGHT,
     *   HX,HY,HXI,HYI,VMPX1,VMPY1,
     *   VMPZ1,ELOST,QLOSTL,QLOSTR,QLOSTT,QLOSTB,
     *   YTOP,YBOT,DRINJ,DLINJ,VRINJ,VLINJ,
     *   TRPAR,TLPAR,DTLPAR,DTRPAR,QINJL,QINJR,EINJ

      DIMENSION HHA(NBB),HHASQ(NBB),C(NBB),F(NBB),G(NBB),XMULT(NBB),
     1 YMULT(NBB),ZMULT(NBB),GA(NBB),XH(NBB),YH(NBB),VXH(NBB),DX(NBB)
     2 ,DY(NBB),W1(NBB),W2(NBB),W3(NBB),W4(NBB),IJ(NBB),EXA(NBB),
     3 EYA(NBB),EZA(NBB),BXA(NBB),BYA(NBB),BZA(NBB),H(NBB),QMLT(NBB)
      COMMON /SCR/ SCR(NBB,18)
      COMMON /PARBD1/ JB,LB,IB(NBB),IBEG,IEND
      DIMENSION I(NBB),FX(NBB),FY(NBB),VXA(NBB),VYA(NBB),VZA(NBB)
      EQUIVALENCE (EXA,SCR(1,1)), (EYA,SCR(1,2))
      EQUIVALENCE (EZA,SCR(1,3)), (BXA,SCR(1,4))
      EQUIVALENCE (BYA,SCR(1,5)), (BZA,SCR(1,6))
      EQUIVALENCE (W1,SCR(1,7)), (W2,SCR(1,8))
      EQUIVALENCE (W3,SCR(1,9)), (W4,SCR(1,10))
      EQUIVALENCE (IJ,SCR(1,11)), (GA,SCR(1,12))
      EQUIVALENCE (VXA,SCR(1,13)), (VYA,SCR(1,14))
      EQUIVALENCE (VZA,SCR(1,15)), (XMULT,SCR(1,16))
      EQUIVALENCE (YMULT,SCR(1,17)), (ZMULT,SCR(1,18))
      EQUIVALENCE (EXA,VXH), (W1,HHA), (W2,HHASQ), (W3,C)
      EQUIVALENCE (EYA,XH), (EZA,YH), (BYA,DX), (BZA,DY)
      EQUIVALENCE (W4,F), (IJ,G), (XMULT,H), (BYA,QMLT)
      EQUIVALENCE (VZA,FY)
      EQUIVALENCE (VYA,FX)
      EQUIVALENCE (VXA,I)
C
      H1 = DT*QMULT/WMULT
      HH = .5D0*H1
      DO 10 L = L3,L4
          H(L) = H1
   10 IF (X(L).LT.0.) H(L) = 0.D0
C
C    CALCULATE AREA WEIGHT VECTORS
      DO 20 L = L3,L4
          RX = HXI*X(L)+1.5D0
          RY = HYI*Y(L)+1.5D0
          I(L) = RX
          IF (I(L).LT.1) I(L) = 1
          FX(L) = RX-I(L)
          FXC = 1.D0-FX(L)
          J = RY
          FY(L) = RY-J
          FYC = 1.D0-FY(L)
          IJ(L) = I(L)+NX2*(J-1)
          W1(L) = FXC*FYC
          W2(L) = FX(L)*FYC
          W3(L) = FXC*FY(L)
          W4(L) = FX(L)*FY(L)
   20 CONTINUE

C    FETCH EX FIELD VECTOR
C    CALCULATE AVERAGE FIELD ON PARTICLE

      DO 30 L = L3,L4
      EXA(L) = W1(L)*EX(IJ(L)) + W2(L)*EX(IJ(L)+1)
     1        +W3(L)*EX(IJ(L)+NX2) + W4(L)*EX(IJ(L)+NX2+1)
      EYA(L) = W1(L)*EY(IJ(L)) + W2(L)*EY(IJ(L)+1)
     1        +W3(L)*EY(IJ(L)+NX2) + W4(L)*EY(IJ(L)+NX2+1)
   30 CONTINUE

C  ADVANCE TWO COMPONENTS OF VELOCITY

      DO 40 L = L3,L4
          VX(L) = VX(L)+H(L)*EXA(L)
          VY(L) = VY(L)+H(L)*EYA(L)
   40 CONTINUE

C   ADVANCE WHOLE POSITIONS.

      DO 50 L = L3,L4
         H(L) = 1.D0
         IF (X(L).LT.0.D0) H(L) = 0.D0
         X(L) = X(L)+DT*VX(L)*H(L)
         Y(L) = Y(L)+DT*VY(L)*H(L)
   50 CONTINUE

C   CHECK FOR PARTICLE BOUNDARY CROSSINGS

      JB = 0
      DO 60 L = L3,L4
         IB(L) = 0
         IF (X(L).GE.XRIGHT) IB(L) = 1
         IF (X(L).LT.XLEFT) IB(L) = 1
         IF (Y(L).LT.0.) IB(L) = 1
         IF (Y(L).GE.YMAX) IB(L) = 1
   60 CONTINUE
       DO 61 L = L3,L4
         JB = JB+IB(L)
         IF(IB(L).NE.0) IB(JB) = L
   61 CONTINUE
      IF (JB.GT.0) CALL BCND

C    CALCULATE AREA WEIGHT VECTORS AT WHOLE TIME

      DO 70 L = L3,L4
         QMLT(L) = QMULT
   70 IF (X(L).LT.0) QMLT(L) = 0.D0
      DO 80 L = L3,L4
         RX = HXI*X(L)+1.5D0
         RY = HYI*Y(L)+1.5D0
         I(L) = RX
         IF (I(L).LT.1) I(L) = 1
         FX(L) = RX-I(L)
         FXC = 1.D0-FX(L)
         J = RY
         FY(L) = RY-J
         FYC = 1.D0-FY(L)
         IJ(L) = I(L)+NX2*(J-1)
         W1(L) = FXC*FYC
         W2(L) = FX(L)*FYC
         W3(L) = FXC*FY(L)
         W4(L) = FX(L)*FY(L)
   80 CONTINUE
C  AREA WEIGHT PARTICLES ONTO CHARGE GRID
      DO 90 L = L3,L4
         Q(IJ(L)) = Q(IJ(L))+W1(L)*QMLT(L)
         Q(IJ(L)+1) = Q(IJ(L)+1)+W2(L)*QMLT(L)
         Q(IJ(L)+NX2) = Q(IJ(L)+NX2)+W3(L)*QMLT(L)
         Q(IJ(L)+NX2+1) = Q(IJ(L)+NX2+1)+W4(L)*QMLT(L)
C
   90 CONTINUE
      RETURN
      END

c** for spec benchmark portability, a timer routine is NOT used.
c
	SUBROUTINE JOBTIM(T)
	IMPLICIT DOUBLE PRECISION (A-H, O-Z)
	T = 0.0
	RETURN
	END
C
c      SUBROUTINE JOBTIM(T)
C MUST SUPPLY A ROUTINE TO RETURN CPU TIME IN SECONDS
c      CALL CPUTIME(T)
c      RETURN
c      END

      SUBROUTINE PARTBL(NSPEC,PBUF,SHIFT)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C  PARTICLE I/O ROUTINE
C
C  NTOT IS THE MAXIMUM NUMBER OF PARTICLES OF ALL SPECIES
C  NSP IS THE NUMBER OF SPECIES
C  NDIM IS THE MAXIMUM NUMBER OF PARTCLES ALLOWED IN PBUF
C  KGROUP  IS THE NUMBER OF PARTICLE QUANTITIES
C
C     RESERVE BUFFER AND DISK SPACE
C   SHIFT IS A SCRATCH ARRAY AT LEAST NDIM*KGROUP IN SIZE
C  NPTS IS THE NUMBER OF PARTICLES IN PBUF
C     NPTS IS INPUT ON PUTB/GETB CALLS AND OUTPUT ON GETB CALLS
C  ISP IS THE SPECIES NUMBER
C    ISP IS INPUT ON PUTB/GETB CALLS AND OUTPUT ON GETB CALLS
C     NPACK DOES NOT PACK IF = 1 AND PACKS 2 PER WORD IF IT IS 2
C    GETB CALL AFTER PUTB CALL DOES NOT DO A PUT
C
C
C   THE NEXT STATEMENT DEFINES WHERE THE JOB WILL BE RUN:
C  NLCM = 5 * # OF PARTICLES FOR IN MEMORY ON CRAY-2
C  NLCM = LESS THAN (5 * # OF PARTICLES) FOR DISK/SSD ON XMP
C  NLCM = T * # PARTICLES FOR IN MEM ON XMP; COMMENT BUFFER DIMENSION
C  STATEMENT BELOW; UNCOMMENT POINTER STATEMENT AND MEMADJUST STATEMENTS
      PARAMETER ( NLCM = 3750010 )
c*** spec mod
c prev version had buffer as a local array.
c modified version has it bound to common
c this eliminates the need for static variable allocation on some platforms
c -MRG/Digital
c
c old code
cc      DIMENSION NSPEC(*),PBUF(*),SHIFT(*)
ccCHW   COMMON /BUFDSK/ BUFFER(NLCM)
cc      DIMENSION BUFFER (NLCM)
ccCHW   POINTER (IBP, BUFFER)
c *** new code
      DIMENSION NSPEC(*),PBUF(*),SHIFT(*)
      COMMON /BUFDSK/ BUFFER(NLCM)
ccc      DIMENSION BUFFER (NLCM)
CHW   POINTER (IBP, BUFFER)
      LOGICAL DSKPRT
      DIMENSION NPSR(10),NPSW(10)
      SAVE NWDSW,NWDSR,NWS,NBUF,NDM,NV,NSP0,ISP0,NPSR,NPSW
      SAVE IWSAVE,IRSAVE,WSAVE,DSKPRT,LCMW,LCMR,IFL,NPACK
C     SAVE RSAVE,LCMMAX,ISW,ITIN,ITOUT,IBP,ISAVE
      SAVE RSAVE,LCMMAX,ISW,ITIN,ITOUT,ISAVE
      DATA NPACK/1/
C 8-Aug-91 Intergraph; stop warnings for SETB's formals; PARTBL is never called.
      RETURN
      ENTRY SETB(NTOT,NSP,NDIM,KGROUP)
CHW   CALL GETFL(KFL)
CHW   WRITE(9,*) ' KFL IS ',KFL
CHW   CALL MEMADJ(2510000 ,IERR)
CHW   IBP = KFL + 100
CHW   WRITE(9,*) ' IBP IS ',IBP
CHW   CALL GETFL(KFL)
CHW   WRITE(9,*) ' NEW KFL IS ',KFL
      NWDSW = 0
      NWDSR = 0
      NWS = 0
      NBUF = KGROUP * NDIM
      NDM = NDIM
      NV = KGROUP
      NSP0 = NSP
      IF (NSP.GT.10) CALL ENDRUN('NSP')
      ISP0 = 0
      NWS = NTOT * NV
      DO 10 I = 1, NSP0
      NPSR(I) = 0
      NPSW(I) = 0
 10   CONTINUE
      IWSAVE = 0
      IRSAVE = 0
      RSAVE = 0.D0
      WSAVE = 0.D0
C
C  NWS IS THE MAXIMUM NUMBER OF WORDS REQUIRED TO STORE PARTICLES
C
      DSKPRT = NWS / NPACK .GT. NLCM
      IF (.NOT.DSKPRT) THEN
             LCMW=1
      ELSE
CHW          IF(NPACK.EQ.2) CALL PAKDTBL(0)
CHW          CALL SETDTBL(BUFFER,-NLCM/2,54,'DAT',1000000,1)
             CALL SUDTBL (ITIN,ITOUT,NWS)
CHW          CALL SUDTBL (ITOUT,NWS)
      ENDIF
      RETURN
      ENTRY GETB (PBUF,NPTS,ISP,SHIFT)
      IF (NWDSR.LT.0) GO TO 70
      IF (IFL.EQ.0) GO TO 80
      IFL=1
      GO TO 30
      ENTRY PUTB (PBUF,NPTS,ISP,SHIFT)
      IF (NPTS.GT.NDM) CALL ENDRUN('NPTS')
      IFL=0
 30   CONTINUE
C
C  WRITE DATA TO DISK
C
      NWDS=NV*NPTS
      IF (IABS(ISP).NE.ISP0) THEN
         ISP0=ISP0+1
         IF (ISP0.GT.NSP0) CALL ENDRUN('BAD ISP')
         IF (ISP0.NE.IABS(ISP).AND.IFL.EQ.0) CALL ENDRUN('ORDER')
      ENDIF
      NPSW(ISP0)=NPSW(ISP0)+NWDS
      IF (NPTS.GT.0) THEN
      SHIFT(1)=WSAVE
      DO 35 J=1,NV
      K1=J+IWSAVE
      K2=(J-1)*NDM+1
      DO 35 I=1,NPTS
      SHIFT(K1)=PBUF(K2)
      K1=K1+NV
 35   K2=K2+1
      NWDS=NWDS+IWSAVE
      IWSAVE=0
      WSAVE=0.
      IF(MOD(NWDS,NPACK).NE.0) THEN
           WSAVE=PBUF(NDM*(NV-1)+NPTS)
           NWDS=NWDS-1
           IWSAVE=1
      ENDIF
      NWDSW=NWDSW+NWDS
      IF (NWDSW.GT.NWS) CALL ENDRUN ('NOSPACE')
      IF (DSKPRT) THEN
             CALL PUTDT (ITOUT,SHIFT,NWDS)
      ELSE
             NWDS2=(NWDS)/NPACK
             K=LCMW+NWDS2-LCMR
             IF (K.GT.0.AND.LCMMAX.GT.LCMR) THEN
C
C       SHIFT BUFFER TO ALLOW FOR THE NEW DATA
C
                 DO 52 L=LCMMAX,LCMR,-1
                 BUFFER(L+K)=BUFFER(L)
52               CONTINUE
                 LCMR=LCMR+K
                 LCMMAX = LCMMAX + NWDS2
             ENDIF
CHW          IF(NPACK.EQ.2)  CALL PACK(SHIFT,BUFFER(LCMW),NWDS)
             IF(NPACK.EQ.1) CALL ECWR(SHIFT,BUFFER(LCMW),NWDS)
             LCMW=LCMW+NWDS2
      ENDIF
      ENDIF
      IF (IFL.EQ.0.AND.NWDSR.GT.0) RETURN
      IF (NWDSR.GT.0) GO TO 80
      ISP=0
      NWDSR=-1
      RETURN
 70   CONTINUE
C
C   REWIND FILES TO BEGIN CYCLE
C
      IF(IWSAVE.NE.0) THEN
             SHIFT(1)=WSAVE
             NWDSW=NWDSW+2
             IF(DSKPRT) THEN
                 CALL PUTDT(ITOUT,SHIFT,2)
             ELSE
CHW              CALL PACK(SHIFT,BUFFER(LCMW),2)
                 LCMW=LCMW+1
             ENDIF
      ENDIF
      IWSAVE=0
      IRSAVE=0
      ISAVE=0
      ISW=-1
      DO 75 I=1,NSP0
      NPSR(I)=NPSW(I)
 75   NPSW(I)=0
      NWDSR=NWDSW
      NWDSW=0
      LCMR=1
      LCMMAX=MAX0(LCMW,LCMMAX)
      LCMW=1
      ISP0=1
      IF (DSKPRT) THEN
             CALL CLRDT (ITIN)
             CALL REWDT (ITOUT)
             ITMP=ITIN
             ITIN=ITOUT
             ITOUT=ITMP
      ENDIF
      IF (NWDSR.EQ.0) THEN
             ISP=-ISP0
             NWDSR=0
             NPTS=0
             IFL=1
             RETURN
      ENDIF
80    CONTINUE
C
C  READ DATA FROM DISK
C
      IFL=1
      IF (NPSR(ISP0).EQ.0) ISP0=ISP0+1
      IF (ISP0.GT.NSP0) CALL ENDRUN('ERR READ')
      ISP=ISP0
      NWDS=MIN0(NBUF,NPSR(ISP0))
      NPSR(ISP0)=MAX0(0,NPSR(ISP0)-NWDS)
      IF (NPSR(ISP0).EQ.0) ISP=-ISP
      IF(MOD(NWDS,NPACK).NE.0) THEN
             ISW=-ISW
             NWDS=NWDS+ISW
             ISAVE=(ISW+1)/2
      ENDIF
      NWDSR=NWDSR-NWDS
      IF(NWDSR.LT.0) CALL ENDRUN('READERR')
      IF (DSKPRT) THEN
             CALL GETDT(ITIN,SHIFT,NWDS)
      ELSE
             NWDS2=(NWDS)/NPACK
CHW          IF(NPACK.EQ.2) CALL UNPACK(BUFFER(LCMR),SHIFT,NWDS2)
             IF(NPACK.EQ.1) CALL ECRD (SHIFT,BUFFER(LCMR),NWDS)
             LCMR=LCMR+NWDS2
      ENDIF
      NPTS=NWDS/NV
      NMAX=NPTS
      DO 110 J=1,NV
      K1=J-IRSAVE
      K2=1+(J-1)*NDM
      DO 110 I=1,NMAX
      PBUF(K2)=SHIFT(K1)
      K1=K1+NV
 110  K2=K2+1
      IF(IRSAVE.EQ.1) PBUF(1)=RSAVE
      RSAVE=SHIFT(NWDS)
      IRSAVE=ISAVE
      RETURN
      ENTRY NUMB(NSPEC,NSP)
      DO 120 I=1,NSP0
 120  NSPEC(I)=NPSW(I)/NV
      NSP=NSP0
      RETURN
      END

      SUBROUTINE SUDTBL(IU1,IU2,NWS)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      PARAMETER ( N = 20 )
      PARAMETER (IT1 = 1)
      PARAMETER(IT2 = IT1 + 1)
c specmod
	DATA LOC/1/
      IU1 = IT1
      IU2 = IT2
C      OPEN(IU1,STATUS='NEW')
C      OPEN(IU2,STATUS='NEW')
C     CALL ASSIGN(IU1,'HAT101',0)
C     CALL ASSIGN(IU2,'HAT102',0)
C     CALL FAMSIZ(IU1,77777000B)
C     CALL FAMSIZ(IU2,77777000B)
C     CALL SETSSD(IU1)
CHW   CALL SETDISK(IU1,1)
CHW   CALL SETDISK(IU2,7)
C     CALL SETSSD(IU2)
C     CALL SSDINQ(IU1,LOC)
      IF (LOC .EQ. 1) WRITE(9,101) IU1
C     CALL SSDINQ(IU2,LOC)
      IF (LOC .EQ. 1) WRITE(9,101) IU2
      WRITE(9,100) IU1
      WRITE(9,100) IU2
      WRITE(9,102) N
      RETURN
100   FORMAT(' DISK UNIT ', I5,' CREATED')
101   FORMAT(' UNIT ', I5, '  IS ON THE SSD')
102   FORMAT(' BUFFER CAPACITY OF ',I4,' TIMES BATCH SIZE')
       END

      SUBROUTINE PUTDT(ITOUT,LC,NWDS)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C    PUT NWDS OF DATA FROM ARRAY LC INTO I/O BUFFER;
C    WRITE BUFFER TO DISK WHEN FULL.
C  N:  SIZE OF BUFFER IN RELATION TO SIZE OF LC.
      PARAMETER (N = 20)
      COMMON /H/ NWR(500)
      DOUBLE PRECISION LC(1280)
      DIMENSION TBUF1(N * 1280), TBUF2(N * 1280)
C NPUTS:  NUMBER OF CALLS TO THIS ROUTINE SINCE LAST PHYSICAL DISK WRITE.
C NWTW1:  NUMBER OF WORDS TO WRITE FROM BUFFER 1.
C NWTW2:  NUMBER OF WORDS TO WRITE FROM BUFFER 2.
C NDUMPS:  NUMBER OF PHYSICAL DISK WRITES CARRIED OUT.
      SAVE NPUTS, NWTW1, NWTW2, NDUMPS, TBUF1, TBUF2
      DATA NPUTS /0/, NDUMPS /0/, NWTW1 /0/, NWTW2 /0/
      NPUTS = NPUTS + 1
      IF (NPUTS .GT. N) GO TO 25
      DO 10 I = 1, NWDS
       J = I + ((NPUTS - 1) * 1280)
       TBUF1(J) = LC(I)
10    CONTINUE
      NWTW1 = NWTW1 + NWDS
      IF (NPUTS .NE. N .AND. NWDS .EQ. 1280) RETURN
      NDUMPS = NDUMPS + 1
      NWR(NDUMPS) = NWTW1
C      IF (UNIT(ITOUT)) 20,99,99
20    CONTINUE
C     WRITE(9,*) 'PUT1: ',NWTW1,' WORDS LOC: ',(NDUMPS-1)*(1280*N),
C    5  ' NDUMPS: ',NDUMPS,' NWDS: ',NWDS
C     CALL WDISK(ITOUT,TBUF1,NWTW1,(NDUMPS-1)*(1280 * N))
C       WRITE(ITOUT,(TBUF1(I),I=1,NWTW1))
      NWTW1 = 0
      IF (NWDS.NE.1280) NDUMPS = 0
      RETURN
25    CONTINUE
      DO 30 I = 1, NWDS
       J = I + ((NPUTS - N - 1) * 1280)
       TBUF2(J) = LC(I)
30    CONTINUE
      NWTW2 = NWTW2 + NWDS
      IF (NPUTS .NE. 2*N .AND. NWDS .EQ. 1280) RETURN
      NDUMPS = NDUMPS + 1
      NWR(NDUMPS) = NWTW2
C      IF (UNIT(ITOUT)) 40,99,99
40    CONTINUE
C     WRITE(9,*) 'PUT1: ',NWTW2,' WORDS LOC: ',(NDUMPS-1)*(1280*N),
C    5  ' NDUMPS: ',NDUMPS,' NWDS: ',NWDS
C     CALL WDISK(ITOUT,TBUF2,NWTW2,(NDUMPS-1)*(1280 * N))
C     WRITE(ITOUT,(TBUF1(I),I=1,NWTW1))
      NWTW2 = 0
      NPUTS = 0
      IF (NWDS.NE.1280) NDUMPS = 0
      RETURN
C99    CALL ENDRUN(' WDISK ')
      END

      SUBROUTINE GETDT(ITIN,LC,NWDS)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C   READ DATA INTO BUFFERS FROM DISK UNIT ITIN;
C   TRANSFER NWDS FROM BUFFERS TO ARRAY LC.
C N:  SIZE OF BUFFERS IN RELATION TO SIZE OF LC.
C     (Funtionality removed for SPEC95)
      WRITE(6,555)
 555  FORMAT(1X, 'SPEC_ERROR: CALL TO GETDT!' )
      STOP
      END

      SUBROUTINE ENDRUN(H)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      CHARACTER*80 H
      WRITE(9,10)H
      STOP
10    FORMAT(///,'RUN TERMINATED --',A10)
      END

      SUBROUTINE CLRDT(IT)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
c      IF (UNIT(IT)) 10,99,99
CHW   REWIND(IT)
10    RETURN
C99    CALL ENDRUN( 'CLRDTBL')
      END

      SUBROUTINE REWDT(IT)
c      IF (UNIT(IT)) 10,99,99
CHW   REWIND(IT)
10    RETURN
C99    CALL ENDRUN( 'CLRDTBL')
      END

      SUBROUTINE RFFTB(N,R,WSAVE)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION       R(*)       ,WSAVE(*)
      IF (N .EQ. 1) RETURN
      CALL RFFTB1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1))
      RETURN
      END

      SUBROUTINE RFFTB1(N,C,CH,WA,FAC)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION       CH(*)      ,C(*)       ,WA(*)      ,FAC(*)
      NF = FAC(2)
      NA = 0
      L1 = 1
      IW = 1
      DO 116 K1=1,NF
         IP = FAC(K1+2)
         L2 = IP*L1
         IDO = N/L2
         IDL1 = IDO*L1
         IF (IP .EQ. 4) THEN
            IX2 = IW+IDO
            IX3 = IX2+IDO
            IF (NA .EQ. 0) THEN
               CALL RADB4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3))
            ELSE
               CALL RADB4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3))
            ENDIF
            NA = 1-NA
         ELSE IF (IP .EQ. 2) THEN
            IF (NA .EQ. 0) THEN
               CALL RADB2 (IDO,L1,C,CH,WA(IW))
            ELSE
               CALL RADB2 (IDO,L1,CH,C,WA(IW))
            ENDIF
            NA = 1-NA
         ELSE IF (IP .EQ. 3) THEN
            IX2 = IW+IDO
            IF (NA .EQ. 0) THEN
               CALL RADB3 (IDO,L1,C,CH,WA(IW),WA(IX2))
            ELSE
               CALL RADB3 (IDO,L1,CH,C,WA(IW),WA(IX2))
            ENDIF
            NA = 1-NA
         ELSE IF (IP .EQ. 5) THEN
            IX2 = IW+IDO
            IX3 = IX2+IDO
            IX4 = IX3+IDO
            IF (NA .EQ. 0) THEN
               CALL RADB5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4))
            ELSE
               CALL RADB5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))
            ENDIF
            NA = 1-NA
         ELSE
            IF (NA .EQ. 0) THEN
               CALL RADBG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))
            ELSE
               CALL RADBG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))
            ENDIF
            IF (IDO .EQ. 1) NA = 1-NA
         ENDIF
         L1 = L2
         IW = IW+(IP-1)*IDO
  116 CONTINUE
      IF (NA .EQ. 0) RETURN
      DO 117 I=1,N
         C(I) = CH(I)
  117 CONTINUE
      RETURN
      END

      SUBROUTINE RFFTF(N,R,WSAVE)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION       R(*)       ,WSAVE(*)
      IF (N .EQ. 1) RETURN
      CALL RFFTF1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1))
      RETURN
      END

      SUBROUTINE RFFTF1(N,C,CH,WA,FAC)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION       CH(*)      ,C(*)       ,WA(*)      ,FAC(*)
      NF = FAC(2)
      NA = 1
      L2 = N
      IW = N
      DO 111 K1=1,NF
         KH = NF-K1
         IP = FAC(KH+3)
         L1 = L2/IP
         IDO = N/L2
         IDL1 = IDO*L1
         IW = IW-(IP-1)*IDO
         NA = 1-NA
         IF (IP .EQ. 4) THEN
            IX2 = IW+IDO
            IX3 = IX2+IDO
            IF (NA .EQ. 0) THEN
               CALL RADF4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3))
            ELSE
               CALL RADF4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3))
            ENDIF
         ELSE IF (IP .EQ. 2) THEN
            IF (NA .EQ. 0) THEN
               CALL RADF2 (IDO,L1,C,CH,WA(IW))
            ELSE
               CALL RADF2 (IDO,L1,CH,C,WA(IW))
            ENDIF
         ELSE IF (IP .EQ. 3) THEN
            IX2 = IW+IDO
            IF (NA .EQ. 0) THEN
               CALL RADF3 (IDO,L1,C,CH,WA(IW),WA(IX2))
            ELSE
               CALL RADF3 (IDO,L1,CH,C,WA(IW),WA(IX2))
            ENDIF
         ELSE IF (IP .EQ. 5) THEN
            IX2 = IW+IDO
            IX3 = IX2+IDO
            IX4 = IX3+IDO
            IF (NA .EQ. 0) THEN
               CALL RADF5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4))
            ELSE
               CALL RADF5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))
            ENDIF
         ELSE
           IF (IDO .EQ. 1) NA = 1-NA
           IF (NA .EQ. 0) THEN
               CALL RADFG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))
               NA = 1
           ELSE
               CALL RADFG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))
               NA = 0
           ENDIF
         ENDIF
         L2 = L1
  111 CONTINUE
      IF (NA .EQ. 1) RETURN
      DO 112 I=1,N
         C(I) = CH(I)
  112 CONTINUE
      RETURN
      END

      SUBROUTINE RFFTI(N,WSAVE)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION       WSAVE(*)
      IF (N .EQ. 1) RETURN
      CALL RFFTI1 (N,WSAVE(N+1),WSAVE(2*N+1))
      RETURN
      END

      SUBROUTINE RFFTI1(N,WA,FAC)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION       WA(*)      ,FAC(*)    ,NTRYH(4)
      DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/
      NL = N
      NF = 0
      J = 0
  101 J = J+1
      IF (J.LE.4) THEN
         NTRY = NTRYH(J)
      ELSE
         NTRY = NTRY+2
      ENDIF
  104 NQ = NL/NTRY
      NR = NL-NTRY*NQ
      IF (NR.NE.0) GO TO 101
      NF = NF+1
      FAC(NF+2) = NTRY
      NL = NQ
      IF (NTRY .EQ. 2 .AND. NF .NE. 1) THEN
         DO 106 I=2,NF
            IB = NF-I+2
            FAC(IB+2) = FAC(IB+1)
  106    CONTINUE
         FAC(3) = 2
      ENDIF
      IF (NL .NE. 1) GO TO 104
      FAC(1) = N
      FAC(2) = NF
      TPI = 6.28318530717959
      ARGH = TPI/DBLE(N)
      IS = 0
      NFM1 = NF-1
      L1 = 1
      IF (NFM1 .EQ. 0) RETURN
      DO 110 K1=1,NFM1
         IP = FAC(K1+2)
         LD = 0
         L2 = L1*IP
         IDO = N/L2
         IPM = IP-1
         DO 109 J=1,IPM
            LD = LD+L1
            I = IS
            ARGLD = DBLE(LD)*ARGH
            FI = 0.D0
            DO 108 II=3,IDO,2
               I = I+2
               FI = FI+1.D0
               ARG = FI*ARGLD
               WA(I-1) = DCOS(ARG)
               WA(I) = DSIN(ARG)
  108       CONTINUE
            IS = IS+IDO
  109    CONTINUE
         L1 = L2
  110 CONTINUE
      RETURN
      END

      SUBROUTINE COSQB(N,X,WSAVE)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION       X(*)       ,WSAVE(*)
      DATA TSQRT2 /2.82842712474619D0/
      IF (N .LT. 2) THEN
         X(1) = 4.*X(1)
         RETURN
      ELSE IF (N .EQ. 2) THEN
         X1 = 4.*(X(1)+X(2))
         X(2) = TSQRT2*(X(1)-X(2))
         X(1) = X1
         RETURN
      ELSE
         CALL COSQB1 (N,X,WSAVE,WSAVE(N+1))
         RETURN
      ENDIF
      END

      SUBROUTINE COSQB1(N,X,W,XH)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION       X(*)       ,W(*)       ,XH(*)
      NS2 = (N+1)/2
      NP2 = N+2
      DO 101 I=3,N,2
         XIM1 = X(I-1)+X(I)
         X(I) = X(I)-X(I-1)
         X(I-1) = XIM1
  101 CONTINUE
      X(1) = X(1)+X(1)
      MODN = MOD(N,2)
      IF (MODN .EQ. 0) X(N) = X(N)+X(N)
      CALL RFFTB (N,X,XH)
      DO 102 K=2,NS2
         KC = NP2-K
         XH(K) = W(K-1)*X(KC)+W(KC-1)*X(K)
         XH(KC) = W(K-1)*X(K)-W(KC-1)*X(KC)
  102 CONTINUE
      IF (MODN .EQ. 0) X(NS2+1) = W(NS2)*(X(NS2+1)+X(NS2+1))
      DO 103 K=2,NS2
         KC = NP2-K
         X(K) = XH(K)+XH(KC)
         X(KC) = XH(K)-XH(KC)
  103 CONTINUE
      X(1) = X(1)+X(1)
      RETURN
      END

      SUBROUTINE COSQF(N,X,WSAVE)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION       X(*)       ,WSAVE(*)
      DATA SQRT2 /1.4142135623731D0/
      IF (N .EQ. 2) THEN
         TSQX = SQRT2*X(2)
         X(2) = X(1)-TSQX
         X(1) = X(1)+TSQX
      ELSE IF (N .GT. 2) THEN
         CALL COSQF1 (N,X,WSAVE,WSAVE(N+1))
      ENDIF
      RETURN
      END

      SUBROUTINE COSQF1(N,X,W,XH)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION       X(*)       ,W(*)       ,XH(*)
      NS2 = (N+1)/2
      NP2 = N+2
      DO 101 K=2,NS2
         KC = NP2-K
         XH(K) = X(K)+X(KC)
         XH(KC) = X(K)-X(KC)
  101 CONTINUE
      MODN = MOD(N,2)
      IF (MODN .EQ. 0) XH(NS2+1) = X(NS2+1)+X(NS2+1)
      DO 102 K=2,NS2
         KC = NP2-K
         X(K) = W(K-1)*XH(KC)+W(KC-1)*XH(K)
         X(KC) = W(K-1)*XH(K)-W(KC-1)*XH(KC)
  102 CONTINUE
      IF (MODN .EQ. 0) X(NS2+1) = W(NS2)*XH(NS2+1)
      CALL RFFTF (N,X,XH)
      DO 103 I=3,N,2
         XIM1 = X(I-1)-X(I)
         X(I) = X(I-1)+X(I)
         X(I-1) = XIM1
  103 CONTINUE
      RETURN
      END

      SUBROUTINE COSQI(N,WSAVE)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION       WSAVE(*)
      DATA PIH /1.57079632679491D0/
      DT = PIH/DBLE(N)
      FK = 0.D0
      DO 101 K=1,N
         FK = FK+1.D0
         WSAVE(K) = DCOS(FK*DT)
  101 CONTINUE
      CALL RFFTI (N,WSAVE(N+1))
      RETURN
      END

      SUBROUTINE COST(N,X,WSAVE)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION       X(*)       ,WSAVE(*)
      NM1 = N-1
      NP1 = N+1
      NS2 = N/2
      IF (N .EQ. 2) THEN
         X1H = X(1)+X(2)
         X(2) = X(1)-X(2)
         X(1) = X1H
         RETURN
      ELSE IF (N .EQ. 3) THEN
         X1P3 = X(1)+X(3)
         TX2 = X(2)+X(2)
         X(2) = X(1)-X(3)
         X(1) = X1P3+TX2
         X(3) = X1P3-TX2
         RETURN
      ELSE IF (N .GT. 3) THEN
         C1 = X(1)-X(N)
         X(1) = X(1)+X(N)
         DO 104 K=2,NS2
            KC = NP1-K
            T1 = X(K)+X(KC)
            T2 = X(K)-X(KC)
            C1 = C1+WSAVE(KC)*T2
            T2 = WSAVE(K)*T2
            X(K) = T1-T2
            X(KC) = T1+T2
  104    CONTINUE
         MODN = MOD(N,2)
         IF (MODN .NE. 0) X(NS2+1) = X(NS2+1)+X(NS2+1)
         CALL RFFTF (NM1,X,WSAVE(N+1))
         XIM2 = X(2)
         X(2) = C1
         DO 105 I=4,N,2
            XI = X(I)
            X(I) = X(I-2)-X(I-1)
            X(I-1) = XIM2
            XIM2 = XI
  105    CONTINUE
         IF (MODN .NE. 0) X(N) = XIM2
      ENDIF
      RETURN
      END

      SUBROUTINE COSTI(N,WSAVE)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION       WSAVE(*)
      DATA PI /3.14159265358979D0/
      IF (N .LE. 3) RETURN
      NM1 = N-1
      NP1 = N+1
      NS2 = N/2
      DT = PI/DBLE(NM1)
      FK = 0.D0
      DO 101 K=2,NS2
         KC = NP1-K
         FK = FK+1.D0
         WSAVE(K) = 2.D0*DSIN(FK*DT)
         WSAVE(KC) = 2.D0*DCOS(FK*DT)
  101 CONTINUE
      CALL RFFTI (NM1,WSAVE(N+1))
      RETURN
      END

      SUBROUTINE SINQB(N,X,WSAVE)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION       X(*)       ,WSAVE(*)
      IF (N .EQ. 1) THEN
         X(1) = 4.D0*X(1)
      ELSE
         NS2 = N/2
         DO 102 K=2,N,2
            X(K) = -X(K)
  102    CONTINUE
         CALL COSQB (N,X,WSAVE)
         DO 103 K=1,NS2
            KC = N-K
            XHOLD = X(K)
            X(K) = X(KC+1)
            X(KC+1) = XHOLD
  103    CONTINUE
      ENDIF
      RETURN
      END

      SUBROUTINE SINQF(N,X,WSAVE)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION       X(*)       ,WSAVE(*)
      IF (N .EQ. 1) RETURN
      NS2 = N/2
      DO 101 K=1,NS2
         KC = N-K
         XHOLD = X(K)
         X(K) = X(KC+1)
         X(KC+1) = XHOLD
  101 CONTINUE
      CALL COSQF (N,X,WSAVE)
      DO 102 K=2,N,2
         X(K) = -X(K)
  102 CONTINUE
      RETURN
      END

      SUBROUTINE SINQI(N,WSAVE)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION       WSAVE(*)
      CALL COSQI (N,WSAVE)
      RETURN
      END

      SUBROUTINE SINT(N,X,WSAVE)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION       X(*)       ,WSAVE(*)
      DATA SQRT3 /1.73205080756888D0/
      IF (N .LT. 2) THEN
         X(1) = X(1)+X(1)
      ELSE IF (N .EQ. 2) THEN
         XH = SQRT3*(X(1)+X(2))
         X(2) = SQRT3*(X(1)-X(2))
         X(1) = XH
      ELSE
         NP1 = N+1
         NS2 = N/2
         WSAVE(1) = 0.D0
         KW = NP1
         DO 104 K=1,NS2
1           KW = KW+1
            KC = NP1-K
            T1 = X(K)-X(KC)
            T2 = WSAVE(KW)*(X(K)+X(KC))
            WSAVE(K+1) = T1+T2
            WSAVE(KC+1) = T2-T1
  104    CONTINUE
         MODN = MOD(N,2)
         IF (MODN .NE. 0) WSAVE(NS2+2) = 4.*X(NS2+1)
         NF = NP1+NS2+1
         CALL RFFTF (NP1,WSAVE,WSAVE(NF))
         X(1) = .5D0*WSAVE(1)
         DO 105 I=3,N,2
            X(I-1) = -WSAVE(I)
            X(I) = X(I-2)+WSAVE(I-1)
  105    CONTINUE
         IF (MODN .NE. 0) RETURN
         X(N) = -WSAVE(N+1)
      ENDIF
      RETURN
      END

      SUBROUTINE SINTI(N,WSAVE)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION       WSAVE(*)
      DATA PI /3.14159265358979D0/
      IF (N .LE. 1) RETURN
      NP1 = N+1
      NS2 = N/2
      DT = PI/DBLE(NP1)
      KS = N+2
      KF = KS+NS2-1
      FK = 0.D0
      DO 101 K=KS,KF
         FK = FK+1.D0
         WSAVE(K) = 2.D0*DSIN(FK*DT)
  101 CONTINUE
      CALL RFFTI (NP1,WSAVE(KF+1))
      RETURN
      END

      SUBROUTINE RADB2(IDO,L1,CC,CH,WA1)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION       CC(IDO,2,L1)           ,CH(IDO,L1,2)           ,
     1                WA1(*)
      DO 101 K=1,L1
         CH(1,K,1) = CC(1,1,K)+CC(IDO,2,K)
         CH(1,K,2) = CC(1,1,K)-CC(IDO,2,K)
  101 CONTINUE
      IF (IDO . GT. 2) THEN
         IDP2 = IDO+2
         IF((IDO-1)/2.GE.L1) THEN
            DO 104 K=1,L1
               DO 103 I=3,IDO,2
                  IC = IDP2-I
                  CH(I-1,K,1) = CC(I-1,1,K)+CC(IC-1,2,K)
                  TR2 =         CC(I-1,1,K)-CC(IC-1,2,K)
                  CH(I,K,1) =   CC(I,1,K)  -CC(IC,2,K)
                  TI2 =         CC(I,1,K)  +CC(IC,2,K)
                  CH(I-1,K,2) = WA1(I-2)*TR2-WA1(I-1)*TI2
                  CH(I,K,2) =   WA1(I-2)*TI2+WA1(I-1)*TR2
  103          CONTINUE
  104       CONTINUE
         ELSE
  108       DO 110 I=3,IDO,2
               IC = IDP2-I
               DO 109 K=1,L1
                  CH(I-1,K,1) = CC(I-1,1,K)+CC(IC-1,2,K)
                  TR2 =         CC(I-1,1,K)-CC(IC-1,2,K)
                  CH(I,K,1) =   CC(I,1,K)  -CC(IC,2,K)
                  TI2 =         CC(I,1,K)  +CC(IC,2,K)
                  CH(I-1,K,2) = WA1(I-2)*TR2-WA1(I-1)*TI2
                  CH(I,K,2) =   WA1(I-2)*TI2+WA1(I-1)*TR2
  109          CONTINUE
  110       CONTINUE
         ENDIF
         IF (MOD(IDO,2) .EQ. 1) RETURN
      ELSE IF (IDO .LT. 2) THEN
         RETURN
      ENDIF
      DO 106 K=1,L1
         CH(IDO,K,1) = CC(IDO,1,K)+CC(IDO,1,K)
         CH(IDO,K,2) = -(CC(1,2,K)+CC(1,2,K))
  106 CONTINUE
      RETURN
      END

      SUBROUTINE RADB3(IDO,L1,CC,CH,WA1,WA2)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION       CC(IDO,3,L1)           ,CH(IDO,L1,3)           ,
     1                WA1(*)     ,WA2(*)
      DATA TAUR,TAUI /-.5D0,.866025403784439D0/
      DO 101 K=1,L1
         TR2 = CC(IDO,2,K)+CC(IDO,2,K)
         CR2 = CC(1,1,K)+TAUR*TR2
         CH(1,K,1) = CC(1,1,K)+TR2
         CI3 = TAUI*(CC(1,3,K)+CC(1,3,K))
         CH(1,K,2) = CR2-CI3
         CH(1,K,3) = CR2+CI3
  101 CONTINUE
      IF (IDO .EQ. 1) RETURN
      IDP2 = IDO+2
      IF((IDO-1)/2.GE.L1) THEN
         DO 103 K=1,L1
            DO 102 I=3,IDO,2
               IC = IDP2-I
               TR2 = CC(I-1,3,K)+CC(IC-1,2,K)
               CR2 = CC(I-1,1,K)+TAUR*TR2
               CH(I-1,K,1) = CC(I-1,1,K)+TR2
               TI2 = CC(I,3,K)-CC(IC,2,K)
               CI2 = CC(I,1,K)+TAUR*TI2
               CH(I,K,1) = CC(I,1,K)+TI2
               CR3 = TAUI*(CC(I-1,3,K)-CC(IC-1,2,K))
               CI3 = TAUI*(CC(I,3,K)+CC(IC,2,K))
               DR2 = CR2-CI3
               DR3 = CR2+CI3
               DI2 = CI2+CR3
               DI3 = CI2-CR3
               CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2
               CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2
               CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3
               CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3
  102       CONTINUE
  103    CONTINUE
         RETURN
      ELSE
         DO 106 I=3,IDO,2
            IC = IDP2-I
            DO 105 K=1,L1
               TR2 = CC(I-1,3,K)+CC(IC-1,2,K)
               CR2 = CC(I-1,1,K)+TAUR*TR2
               CH(I-1,K,1) = CC(I-1,1,K)+TR2
               TI2 = CC(I,3,K)-CC(IC,2,K)
               CI2 = CC(I,1,K)+TAUR*TI2
               CH(I,K,1) = CC(I,1,K)+TI2
               CR3 = TAUI*(CC(I-1,3,K)-CC(IC-1,2,K))
               CI3 = TAUI*(CC(I,3,K)+CC(IC,2,K))
               DR2 = CR2-CI3
               DR3 = CR2+CI3
               DI2 = CI2+CR3
               DI3 = CI2-CR3
               CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2
               CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2
               CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3
               CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3
  105       CONTINUE
  106    CONTINUE
         RETURN
      ENDIF
      END

      SUBROUTINE RADB4(IDO,L1,CC,CH,WA1,WA2,WA3)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION       CC(IDO,4,L1)           ,CH(IDO,L1,4)           ,
     1                WA1(*)     ,WA2(*)     ,WA3(*)
      DATA SQRT2 /1.414213562373095D0/
      DO 101 K=1,L1
         TR1 = CC(1,1,K)-CC(IDO,4,K)
         TR2 = CC(1,1,K)+CC(IDO,4,K)
         TR3 = CC(IDO,2,K)+CC(IDO,2,K)
         TR4 = CC(1,3,K)+CC(1,3,K)
         CH(1,K,1) = TR2+TR3
         CH(1,K,2) = TR1-TR4
         CH(1,K,3) = TR2-TR3
         CH(1,K,4) = TR1+TR4
  101 CONTINUE
C      IF (IDO-2) 107,105,102
      IF (IDO .GT. 2) THEN
         IDP2 = IDO+2
         IF((IDO-1)/2.GE.L1) THEN
            DO 104 K=1,L1
               DO 103 I=3,IDO,2
                  IC = IDP2-I
                  TI1 = CC(I,1,K)+CC(IC,4,K)
                  TI2 = CC(I,1,K)-CC(IC,4,K)
                  TI3 = CC(I,3,K)-CC(IC,2,K)
                  TR4 = CC(I,3,K)+CC(IC,2,K)
                  TR1 = CC(I-1,1,K)-CC(IC-1,4,K)
                  TR2 = CC(I-1,1,K)+CC(IC-1,4,K)
                  TI4 = CC(I-1,3,K)-CC(IC-1,2,K)
                  TR3 = CC(I-1,3,K)+CC(IC-1,2,K)
                  CH(I-1,K,1) = TR2+TR3
                  CR3 = TR2-TR3
                  CH(I,K,1) = TI2+TI3
                  CI3 = TI2-TI3
                  CR2 = TR1-TR4
                  CR4 = TR1+TR4
                  CI2 = TI1+TI4
                  CI4 = TI1-TI4
                  CH(I-1,K,2) = WA1(I-2)*CR2-WA1(I-1)*CI2
                  CH(I,K,2) = WA1(I-2)*CI2+WA1(I-1)*CR2
                  CH(I-1,K,3) = WA2(I-2)*CR3-WA2(I-1)*CI3
                  CH(I,K,3) = WA2(I-2)*CI3+WA2(I-1)*CR3
                  CH(I-1,K,4) = WA3(I-2)*CR4-WA3(I-1)*CI4
                  CH(I,K,4) = WA3(I-2)*CI4+WA3(I-1)*CR4
  103          CONTINUE
  104       CONTINUE
         ELSE
            DO 110 I=3,IDO,2
               IC = IDP2-I
               DO 109 K=1,L1
                  TI1 = CC(I,1,K)+CC(IC,4,K)
                  TI2 = CC(I,1,K)-CC(IC,4,K)
                  TI3 = CC(I,3,K)-CC(IC,2,K)
                  TR4 = CC(I,3,K)+CC(IC,2,K)
                  TR1 = CC(I-1,1,K)-CC(IC-1,4,K)
                  TR2 = CC(I-1,1,K)+CC(IC-1,4,K)
                  TI4 = CC(I-1,3,K)-CC(IC-1,2,K)
                  TR3 = CC(I-1,3,K)+CC(IC-1,2,K)
                  CH(I-1,K,1) = TR2+TR3
                  CR3 = TR2-TR3
                  CH(I,K,1) = TI2+TI3
                  CI3 = TI2-TI3
                  CR2 = TR1-TR4
                  CR4 = TR1+TR4
                  CI2 = TI1+TI4
                  CI4 = TI1-TI4
                  CH(I-1,K,2) = WA1(I-2)*CR2-WA1(I-1)*CI2
                  CH(I,K,2) = WA1(I-2)*CI2+WA1(I-1)*CR2
                  CH(I-1,K,3) = WA2(I-2)*CR3-WA2(I-1)*CI3
                  CH(I,K,3) = WA2(I-2)*CI3+WA2(I-1)*CR3
                  CH(I-1,K,4) = WA3(I-2)*CR4-WA3(I-1)*CI4
                  CH(I,K,4) = WA3(I-2)*CI4+WA3(I-1)*CR4
  109          CONTINUE
  110       CONTINUE
         ENDIF
         IF (MOD(IDO,2) .EQ. 1) RETURN
      ELSE IF (IDO .LT. 2) THEN
         RETURN
      ENDIF
      DO 106 K=1,L1
         TI1 = CC(1,2,K)+CC(1,4,K)
         TI2 = CC(1,4,K)-CC(1,2,K)
         TR1 = CC(IDO,1,K)-CC(IDO,3,K)
         TR2 = CC(IDO,1,K)+CC(IDO,3,K)
         CH(IDO,K,1) = TR2+TR2
         CH(IDO,K,2) = SQRT2*(TR1-TI1)
         CH(IDO,K,3) = TI2+TI2
         CH(IDO,K,4) = -SQRT2*(TR1+TI1)
  106 CONTINUE
      RETURN
      END

      SUBROUTINE RADB5(IDO,L1,CC,CH,WA1,WA2,WA3,WA4)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION       CC(IDO,5,L1)           ,CH(IDO,L1,5)           ,
     1                WA1(*)     ,WA2(*)     ,WA3(*)     ,WA4(*)
      DATA TR11,TI11,TR12,TI12 /.309016994374947D0,.951056516295154D0,
     1-.809016994374947D0,.587785252292473D0/
      DO 101 K=1,L1
         TI5 = CC(1,3,K)+CC(1,3,K)
         TI4 = CC(1,5,K)+CC(1,5,K)
         TR2 = CC(IDO,2,K)+CC(IDO,2,K)
         TR3 = CC(IDO,4,K)+CC(IDO,4,K)
         CH(1,K,1) = CC(1,1,K)+TR2+TR3
         CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3
         CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3
         CI5 = TI11*TI5+TI12*TI4
         CI4 = TI12*TI5-TI11*TI4
         CH(1,K,2) = CR2-CI5
         CH(1,K,3) = CR3-CI4
         CH(1,K,4) = CR3+CI4
         CH(1,K,5) = CR2+CI5
  101 CONTINUE
      IF (IDO .EQ. 1) RETURN
      IDP2 = IDO+2
      IF((IDO-1)/2.GE.L1) THEN
         DO 103 K=1,L1
            DO 102 I=3,IDO,2
               IC = IDP2-I
               TI5 = CC(I,3,K)+CC(IC,2,K)
               TI2 = CC(I,3,K)-CC(IC,2,K)
               TI4 = CC(I,5,K)+CC(IC,4,K)
               TI3 = CC(I,5,K)-CC(IC,4,K)
               TR5 = CC(I-1,3,K)-CC(IC-1,2,K)
               TR2 = CC(I-1,3,K)+CC(IC-1,2,K)
               TR4 = CC(I-1,5,K)-CC(IC-1,4,K)
               TR3 = CC(I-1,5,K)+CC(IC-1,4,K)
               CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3
               CH(I,K,1) = CC(I,1,K)+TI2+TI3
               CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3
               CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3
               CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3
               CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3
               CR5 = TI11*TR5+TI12*TR4
               CI5 = TI11*TI5+TI12*TI4
               CR4 = TI12*TR5-TI11*TR4
               CI4 = TI12*TI5-TI11*TI4
               DR3 = CR3-CI4
               DR4 = CR3+CI4
               DI3 = CI3+CR4
               DI4 = CI3-CR4
               DR5 = CR2+CI5
               DR2 = CR2-CI5
               DI5 = CI2-CR5
               DI2 = CI2+CR5
               CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2
               CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2
               CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3
               CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3
               CH(I-1,K,4) = WA3(I-2)*DR4-WA3(I-1)*DI4
               CH(I,K,4) = WA3(I-2)*DI4+WA3(I-1)*DR4
               CH(I-1,K,5) = WA4(I-2)*DR5-WA4(I-1)*DI5
               CH(I,K,5) = WA4(I-2)*DI5+WA4(I-1)*DR5
  102       CONTINUE
  103    CONTINUE
         RETURN
      ELSE
         DO 106 I=3,IDO,2
            IC = IDP2-I
            DO 105 K=1,L1
               TI5 = CC(I,3,K)+CC(IC,2,K)
               TI2 = CC(I,3,K)-CC(IC,2,K)
               TI4 = CC(I,5,K)+CC(IC,4,K)
               TI3 = CC(I,5,K)-CC(IC,4,K)
               TR5 = CC(I-1,3,K)-CC(IC-1,2,K)
               TR2 = CC(I-1,3,K)+CC(IC-1,2,K)
               TR4 = CC(I-1,5,K)-CC(IC-1,4,K)
               TR3 = CC(I-1,5,K)+CC(IC-1,4,K)
               CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3
               CH(I,K,1) = CC(I,1,K)+TI2+TI3
               CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3
               CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3
               CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3
               CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3
               CR5 = TI11*TR5+TI12*TR4
               CI5 = TI11*TI5+TI12*TI4
               CR4 = TI12*TR5-TI11*TR4
               CI4 = TI12*TI5-TI11*TI4
               DR3 = CR3-CI4
               DR4 = CR3+CI4
               DI3 = CI3+CR4
               DI4 = CI3-CR4
               DR5 = CR2+CI5
               DR2 = CR2-CI5
               DI5 = CI2-CR5
               DI2 = CI2+CR5
               CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2
               CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2
               CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3
               CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3
               CH(I-1,K,4) = WA3(I-2)*DR4-WA3(I-1)*DI4
               CH(I,K,4) = WA3(I-2)*DI4+WA3(I-1)*DR4
               CH(I-1,K,5) = WA4(I-2)*DR5-WA4(I-1)*DI5
               CH(I,K,5) = WA4(I-2)*DI5+WA4(I-1)*DR5
  105       CONTINUE
  106    CONTINUE
         RETURN
      ENDIF
      END

      SUBROUTINE RADBG(IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION       CH(IDO,L1,IP)          ,CC(IDO,IP,L1)          ,
     1                C1(IDO,L1,IP)          ,C2(IDL1,IP),
     2                CH2(IDL1,IP)           ,WA(*)
      DATA TPI/6.28318530717959D0/
      ARG = TPI/DBLE(IP)
      DCP = DCOS(ARG)
      DSP = DSIN(ARG)
      IDP2 = IDO+2
      NBD = (IDO-1)/2
      IPP2 = IP+2
      IPPH = (IP+1)/2
      IF (IDO .GE. L1) THEN
         DO 102 K=1,L1
            DO 101 I=1,IDO
               CH(I,K,1) = CC(I,1,K)
  101       CONTINUE
  102    CONTINUE
      ELSE
         DO 105 I=1,IDO
            DO 104 K=1,L1
               CH(I,K,1) = CC(I,1,K)
  104       CONTINUE
  105    CONTINUE
      ENDIF
      DO 108 J=2,IPPH
         JC = IPP2-J
         J2 = J+J
         DO 107 K=1,L1
            CH(1,K,J) = CC(IDO,J2-2,K)+CC(IDO,J2-2,K)
            CH(1,K,JC) = CC(1,J2-1,K)+CC(1,J2-1,K)
  107    CONTINUE
  108 CONTINUE
      IF (IDO .GT. 1) THEN
         IF (NBD .GE. L1) THEN
            DO 111 J=2,IPPH
               JC = IPP2-J
               DO 110 K=1,L1
                  DO 109 I=3,IDO,2
                     IC = IDP2-I
                     CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K)
                     CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K)
                     CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K)
                     CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K)
  109             CONTINUE
  110          CONTINUE
  111       CONTINUE
         ELSE
            DO 115 J=2,IPPH
               JC = IPP2-J
               DO 114 I=3,IDO,2
                  IC = IDP2-I
                  DO 113 K=1,L1
                     CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K)
                     CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K)
                     CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K)
                     CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K)
  113             CONTINUE
  114          CONTINUE
  115       CONTINUE
         ENDIF
      ENDIF
      AR1 = 1.
      AI1 = 0.
      DO 120 L=2,IPPH
         LC = IPP2-L
         AR1H = DCP*AR1-DSP*AI1
         AI1 = DCP*AI1+DSP*AR1
         AR1 = AR1H
         DO 117 IK=1,IDL1
            C2(IK,L) = CH2(IK,1)+AR1*CH2(IK,2)
            C2(IK,LC) = AI1*CH2(IK,IP)
  117    CONTINUE
         DC2 = AR1
         DS2 = AI1
         AR2 = AR1
         AI2 = AI1
         DO 119 J=3,IPPH
            JC = IPP2-J
            AR2H = DC2*AR2-DS2*AI2
            AI2 = DC2*AI2+DS2*AR2
            AR2 = AR2H
            DO 118 IK=1,IDL1
               C2(IK,L) = C2(IK,L)+AR2*CH2(IK,J)
               C2(IK,LC) = C2(IK,LC)+AI2*CH2(IK,JC)
  118       CONTINUE
  119    CONTINUE
  120 CONTINUE
      DO 122 J=2,IPPH
         DO 121 IK=1,IDL1
            CH2(IK,1) = CH2(IK,1)+CH2(IK,J)
  121    CONTINUE
  122 CONTINUE
      DO 124 J=2,IPPH
         JC = IPP2-J
         DO 123 K=1,L1
            CH(1,K,J) = C1(1,K,J)-C1(1,K,JC)
            CH(1,K,JC) = C1(1,K,J)+C1(1,K,JC)
  123    CONTINUE
  124 CONTINUE
      IF (IDO .NE. 1) THEN
         IF (NBD .GE. L1) THEN
            DO 127 J=2,IPPH
               JC = IPP2-J
               DO 126 K=1,L1
                  DO 125 I=3,IDO,2
                     CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC)
                     CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC)
                     CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC)
                     CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC)
  125             CONTINUE
  126          CONTINUE
  127       CONTINUE
         ELSE
            DO 131 J=2,IPPH
               JC = IPP2-J
               DO 130 I=3,IDO,2
                  DO 129 K=1,L1
                     CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC)
                     CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC)
                     CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC)
                     CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC)
  129             CONTINUE
  130          CONTINUE
  131       CONTINUE
         ENDIF
      ELSE
         RETURN
      ENDIF
      DO 133 IK=1,IDL1
         C2(IK,1) = CH2(IK,1)
  133 CONTINUE
      DO 135 J=2,IP
         DO 134 K=1,L1
            C1(1,K,J) = CH(1,K,J)
  134    CONTINUE
  135 CONTINUE
      IF (NBD .LE. L1) THEN
         IS = -IDO
         DO 138 J=2,IP
           IS = IS+IDO
           IDIJ = IS
           DO 137 I=3,IDO,2
             IDIJ = IDIJ+2
             DO 136 K=1,L1
               C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J)
               C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J)
  136        CONTINUE
  137      CONTINUE
  138    CONTINUE
      ELSE
         IS = -IDO
         DO 142 J=2,IP
           IS = IS+IDO
           DO 141 K=1,L1
             IDIJ = IS
             DO 140 I=3,IDO,2
               IDIJ = IDIJ+2
               C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J)
               C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J)
  140        CONTINUE
  141      CONTINUE
  142    CONTINUE
      ENDIF
      RETURN
      END

      SUBROUTINE RADF2(IDO,L1,CC,CH,WA1)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION       CH(IDO,2,L1)           ,CC(IDO,L1,2)           ,
     1                WA1(*)
      DO 101 K=1,L1
         CH(1,1,K) = CC(1,K,1)+CC(1,K,2)
         CH(IDO,2,K) = CC(1,K,1)-CC(1,K,2)
  101 CONTINUE
      IF (IDO .GT. 2) THEN
         IDP2 = IDO+2
         IF((IDO-1)/2.GE.L1) THEN
            DO 104 K=1,L1
               DO 103 I=3,IDO,2
                  IC = IDP2-I
                  TR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
                  TI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
                  CH(I,1,K) = CC(I,K,1)+TI2
                  CH(IC,2,K) = TI2-CC(I,K,1)
                  CH(I-1,1,K) = CC(I-1,K,1)+TR2
                  CH(IC-1,2,K) = CC(I-1,K,1)-TR2
  103          CONTINUE
  104       CONTINUE
         ELSE
            DO 110 I=3,IDO,2
               IC = IDP2-I
               DO 109 K=1,L1
                  TR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
                  TI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
                  CH(I,1,K) = CC(I,K,1)+TI2
                  CH(IC,2,K) = TI2-CC(I,K,1)
                  CH(I-1,1,K) = CC(I-1,K,1)+TR2
                  CH(IC-1,2,K) = CC(I-1,K,1)-TR2
  109          CONTINUE
  110       CONTINUE
         ENDIF
         IF (MOD(IDO,2) .EQ. 1) RETURN
      ELSE IF (IDO .LT. 2) THEN
         RETURN
      ENDIF
      DO 106 K=1,L1
         CH(1,2,K) = -CC(IDO,K,2)
         CH(IDO,1,K) = CC(IDO,K,1)
  106 CONTINUE
      RETURN
      END

      SUBROUTINE RADF3(IDO,L1,CC,CH,WA1,WA2)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION       CH(IDO,3,L1)           ,CC(IDO,L1,3)           ,
     1                WA1(*)     ,WA2(*)
      DATA TAUR,TAUI /-.5D0,.866025403784439D0/
      DO 101 K=1,L1
         CR2 = CC(1,K,2)+CC(1,K,3)
         CH(1,1,K) = CC(1,K,1)+CR2
         CH(1,3,K) = TAUI*(CC(1,K,3)-CC(1,K,2))
         CH(IDO,2,K) = CC(1,K,1)+TAUR*CR2
  101 CONTINUE
      IF (IDO .EQ. 1) RETURN
      IDP2 = IDO+2
      IF((IDO-1)/2.GE.L1) THEN
         DO 103 K=1,L1
            DO 102 I=3,IDO,2
               IC = IDP2-I
               DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
               DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
               DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
               DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
               CR2 = DR2+DR3
               CI2 = DI2+DI3
               CH(I-1,1,K) = CC(I-1,K,1)+CR2
               CH(I,1,K) = CC(I,K,1)+CI2
               TR2 = CC(I-1,K,1)+TAUR*CR2
               TI2 = CC(I,K,1)+TAUR*CI2
               TR3 = TAUI*(DI2-DI3)
               TI3 = TAUI*(DR3-DR2)
               CH(I-1,3,K) = TR2+TR3
               CH(IC-1,2,K) = TR2-TR3
               CH(I,3,K) = TI2+TI3
               CH(IC,2,K) = TI3-TI2
  102       CONTINUE
  103    CONTINUE
         RETURN
      ENDIF
      DO 106 I=3,IDO,2
         IC = IDP2-I
         DO 105 K=1,L1
            DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
            DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
            DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
            DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
            CR2 = DR2+DR3
            CI2 = DI2+DI3
            CH(I-1,1,K) = CC(I-1,K,1)+CR2
            CH(I,1,K) = CC(I,K,1)+CI2
            TR2 = CC(I-1,K,1)+TAUR*CR2
            TI2 = CC(I,K,1)+TAUR*CI2
            TR3 = TAUI*(DI2-DI3)
            TI3 = TAUI*(DR3-DR2)
            CH(I-1,3,K) = TR2+TR3
            CH(IC-1,2,K) = TR2-TR3
            CH(I,3,K) = TI2+TI3
            CH(IC,2,K) = TI3-TI2
  105    CONTINUE
  106 CONTINUE
      RETURN
      END

      SUBROUTINE RADF4(IDO,L1,CC,CH,WA1,WA2,WA3)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION       CC(IDO,L1,4)           ,CH(IDO,4,L1)           ,
     1                WA1(*)     ,WA2(*)     ,WA3(*)
      DATA HSQT2 /.7071067811865475D0/
      DO 101 K=1,L1
         TR1 = CC(1,K,2)+CC(1,K,4)
         TR2 = CC(1,K,1)+CC(1,K,3)
         CH(1,1,K) = TR1+TR2
         CH(IDO,4,K) = TR2-TR1
         CH(IDO,2,K) = CC(1,K,1)-CC(1,K,3)
         CH(1,3,K) = CC(1,K,4)-CC(1,K,2)
  101 CONTINUE
      IF (IDO .GT. 2) THEN
         IDP2 = IDO+2
         IF((IDO-1)/2.GE.L1) THEN
            DO 104 K=1,L1
               DO 103 I=3,IDO,2
                  IC = IDP2-I
                  CR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
                  CI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
                  CR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
                  CI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
                  CR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4)
                  CI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4)
                  TR1 = CR2+CR4
                  TR4 = CR4-CR2
                  TI1 = CI2+CI4
                  TI4 = CI2-CI4
                  TI2 = CC(I,K,1)+CI3
                  TI3 = CC(I,K,1)-CI3
                  TR2 = CC(I-1,K,1)+CR3
                  TR3 = CC(I-1,K,1)-CR3
                  CH(I-1,1,K) = TR1+TR2
                  CH(IC-1,4,K) = TR2-TR1
                  CH(I,1,K) = TI1+TI2
                  CH(IC,4,K) = TI1-TI2
                  CH(I-1,3,K) = TI4+TR3
                  CH(IC-1,2,K) = TR3-TI4
                  CH(I,3,K) = TR4+TI3
                  CH(IC,2,K) = TR4-TI3
  103          CONTINUE
  104       CONTINUE
         ELSE
            DO 109 I=3,IDO,2
               IC = IDP2-I
               DO 108 K=1,L1
                  CR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
                  CI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
                  CR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
                  CI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
                  CR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4)
                  CI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4)
                  TR1 = CR2+CR4
                  TR4 = CR4-CR2
                  TI1 = CI2+CI4
                  TI4 = CI2-CI4
                  TI2 = CC(I,K,1)+CI3
                  TI3 = CC(I,K,1)-CI3
                  TR2 = CC(I-1,K,1)+CR3
                  TR3 = CC(I-1,K,1)-CR3
                  CH(I-1,1,K) = TR1+TR2
                  CH(IC-1,4,K) = TR2-TR1
                  CH(I,1,K) = TI1+TI2
                  CH(IC,4,K) = TI1-TI2
                  CH(I-1,3,K) = TI4+TR3
                  CH(IC-1,2,K) = TR3-TI4
                  CH(I,3,K) = TR4+TI3
                  CH(IC,2,K) = TR4-TI3
  108          CONTINUE
  109       CONTINUE
         ENDIF
         IF (MOD(IDO,2) .EQ. 1) RETURN
      ELSE IF (IDO .LT. 2) THEN
         RETURN
      ENDIF
      DO 106 K=1,L1
         TI1 = -HSQT2*(CC(IDO,K,2)+CC(IDO,K,4))
         TR1 = HSQT2*(CC(IDO,K,2)-CC(IDO,K,4))
         CH(IDO,1,K) = TR1+CC(IDO,K,1)
         CH(IDO,3,K) = CC(IDO,K,1)-TR1
         CH(1,2,K) = TI1-CC(IDO,K,3)
         CH(1,4,K) = TI1+CC(IDO,K,3)
  106 CONTINUE
      RETURN
      END

      SUBROUTINE RADF5(IDO,L1,CC,CH,WA1,WA2,WA3,WA4)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION       CC(IDO,L1,5)           ,CH(IDO,5,L1)           ,
     1                WA1(*)     ,WA2(*)     ,WA3(*)     ,WA4(*)
      DATA TR11,TI11,TR12,TI12 /.309016994374947D0,.951056516295154D0,
     1-.809016994374947D0,.587785252292473D0/
      DO 101 K=1,L1
         CR2 = CC(1,K,5)+CC(1,K,2)
         CI5 = CC(1,K,5)-CC(1,K,2)
         CR3 = CC(1,K,4)+CC(1,K,3)
         CI4 = CC(1,K,4)-CC(1,K,3)
         CH(1,1,K) = CC(1,K,1)+CR2+CR3
         CH(IDO,2,K) = CC(1,K,1)+TR11*CR2+TR12*CR3
         CH(1,3,K) = TI11*CI5+TI12*CI4
         CH(IDO,4,K) = CC(1,K,1)+TR12*CR2+TR11*CR3
         CH(1,5,K) = TI12*CI5-TI11*CI4
  101 CONTINUE
      IF (IDO .EQ. 1) RETURN
      IDP2 = IDO+2
      IF((IDO-1)/2.GE.L1) THEN
         DO 103 K=1,L1
            DO 102 I=3,IDO,2
               IC = IDP2-I
               DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
               DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
               DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
               DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
               DR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4)
               DI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4)
               DR5 = WA4(I-2)*CC(I-1,K,5)+WA4(I-1)*CC(I,K,5)
               DI5 = WA4(I-2)*CC(I,K,5)-WA4(I-1)*CC(I-1,K,5)
               CR2 = DR2+DR5
               CI5 = DR5-DR2
               CR5 = DI2-DI5
               CI2 = DI2+DI5
               CR3 = DR3+DR4
               CI4 = DR4-DR3
               CR4 = DI3-DI4
               CI3 = DI3+DI4
               CH(I-1,1,K) = CC(I-1,K,1)+CR2+CR3
               CH(I,1,K) = CC(I,K,1)+CI2+CI3
               TR2 = CC(I-1,K,1)+TR11*CR2+TR12*CR3
               TI2 = CC(I,K,1)+TR11*CI2+TR12*CI3
               TR3 = CC(I-1,K,1)+TR12*CR2+TR11*CR3
               TI3 = CC(I,K,1)+TR12*CI2+TR11*CI3
               TR5 = TI11*CR5+TI12*CR4
               TI5 = TI11*CI5+TI12*CI4
               TR4 = TI12*CR5-TI11*CR4
               TI4 = TI12*CI5-TI11*CI4
               CH(I-1,3,K) = TR2+TR5
               CH(IC-1,2,K) = TR2-TR5
               CH(I,3,K) = TI2+TI5
               CH(IC,2,K) = TI5-TI2
               CH(I-1,5,K) = TR3+TR4
               CH(IC-1,4,K) = TR3-TR4
               CH(I,5,K) = TI3+TI4
               CH(IC,4,K) = TI4-TI3
  102       CONTINUE
  103    CONTINUE
         RETURN
      ELSE
         DO 106 I=3,IDO,2
            IC = IDP2-I
            DO 105 K=1,L1
               DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
               DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
               DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
               DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
               DR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4)
               DI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4)
               DR5 = WA4(I-2)*CC(I-1,K,5)+WA4(I-1)*CC(I,K,5)
               DI5 = WA4(I-2)*CC(I,K,5)-WA4(I-1)*CC(I-1,K,5)
               CR2 = DR2+DR5
               CI5 = DR5-DR2
               CR5 = DI2-DI5
               CI2 = DI2+DI5
               CR3 = DR3+DR4
               CI4 = DR4-DR3
               CR4 = DI3-DI4
               CI3 = DI3+DI4
               CH(I-1,1,K) = CC(I-1,K,1)+CR2+CR3
               CH(I,1,K) = CC(I,K,1)+CI2+CI3
               TR2 = CC(I-1,K,1)+TR11*CR2+TR12*CR3
               TI2 = CC(I,K,1)+TR11*CI2+TR12*CI3
               TR3 = CC(I-1,K,1)+TR12*CR2+TR11*CR3
               TI3 = CC(I,K,1)+TR12*CI2+TR11*CI3
               TR5 = TI11*CR5+TI12*CR4
               TI5 = TI11*CI5+TI12*CI4
               TR4 = TI12*CR5-TI11*CR4
               TI4 = TI12*CI5-TI11*CI4
               CH(I-1,3,K) = TR2+TR5
               CH(IC-1,2,K) = TR2-TR5
               CH(I,3,K) = TI2+TI5
               CH(IC,2,K) = TI5-TI2
               CH(I-1,5,K) = TR3+TR4
               CH(IC-1,4,K) = TR3-TR4
               CH(I,5,K) = TI3+TI4
               CH(IC,4,K) = TI4-TI3
  105       CONTINUE
  106    CONTINUE
         RETURN
      ENDIF
      END

      SUBROUTINE RADFG(IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION       CH(IDO,L1,IP)          ,CC(IDO,IP,L1)          ,
     1                C1(IDO,L1,IP)          ,C2(IDL1,IP),
     2                CH2(IDL1,IP)           ,WA(*)
      DATA TPI/6.28318530717959D0/
      ARG = TPI/DBLE(IP)
      DCP = DCOS(ARG)
      DSP = DSIN(ARG)
      IPPH = (IP+1)/2
      IPP2 = IP+2
      IDP2 = IDO+2
      NBD = (IDO-1)/2
      IF (IDO .NE. 1) THEN
         DO 101 IK=1,IDL1
            CH2(IK,1) = C2(IK,1)
  101    CONTINUE
         DO 103 J=2,IP
            DO 102 K=1,L1
               CH(1,K,J) = C1(1,K,J)
  102       CONTINUE
  103    CONTINUE
         IF (NBD .LE. L1) THEN
           IS = -IDO
           DO 106 J=2,IP
             IS = IS+IDO
             IDIJ = IS
             DO 105 I=3,IDO,2
               IDIJ = IDIJ+2
               DO 104 K=1,L1
                 CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J)
                 CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J)
  104          CONTINUE
  105        CONTINUE
  106      CONTINUE
         ELSE
           IS = -IDO
           DO 110 J=2,IP
             IS = IS+IDO
             DO 109 K=1,L1
               IDIJ = IS
               DO 108 I=3,IDO,2
                 IDIJ = IDIJ+2
                 CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J)
                 CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J)
  108          CONTINUE
  109        CONTINUE
  110      CONTINUE
         ENDIF
         IF (NBD .GE. L1) THEN
            DO 114 J=2,IPPH
               JC = IPP2-J
               DO 113 K=1,L1
                  DO 112 I=3,IDO,2
                     C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC)
                     C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC)
                     C1(I,K,J) = CH(I,K,J)+CH(I,K,JC)
                     C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J)
  112             CONTINUE
  113          CONTINUE
  114       CONTINUE
         ELSE
            DO 118 J=2,IPPH
               JC = IPP2-J
               DO 117 I=3,IDO,2
                  DO 116 K=1,L1
                     C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC)
                     C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC)
                     C1(I,K,J) = CH(I,K,J)+CH(I,K,JC)
                     C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J)
  116             CONTINUE
  117          CONTINUE
  118       CONTINUE
         ENDIF
      ELSE
         DO 120 IK=1,IDL1
            C2(IK,1) = CH2(IK,1)
  120    CONTINUE
      ENDIF
      DO 123 J=2,IPPH
         JC = IPP2-J
         DO 122 K=1,L1
            C1(1,K,J) = CH(1,K,J)+CH(1,K,JC)
            C1(1,K,JC) = CH(1,K,JC)-CH(1,K,J)
  122    CONTINUE
  123 CONTINUE
C
      AR1 = 1.
      AI1 = 0.
      DO 127 L=2,IPPH
         LC = IPP2-L
         AR1H = DCP*AR1-DSP*AI1
         AI1 = DCP*AI1+DSP*AR1
         AR1 = AR1H
         DO 124 IK=1,IDL1
            CH2(IK,L) = C2(IK,1)+AR1*C2(IK,2)
            CH2(IK,LC) = AI1*C2(IK,IP)
  124    CONTINUE
         DC2 = AR1
         DS2 = AI1
         AR2 = AR1
         AI2 = AI1
         DO 126 J=3,IPPH
            JC = IPP2-J
            AR2H = DC2*AR2-DS2*AI2
            AI2 = DC2*AI2+DS2*AR2
            AR2 = AR2H
            DO 125 IK=1,IDL1
               CH2(IK,L) = CH2(IK,L)+AR2*C2(IK,J)
               CH2(IK,LC) = CH2(IK,LC)+AI2*C2(IK,JC)
  125       CONTINUE
  126    CONTINUE
  127 CONTINUE
      DO 129 J=2,IPPH
         DO 128 IK=1,IDL1
            CH2(IK,1) = CH2(IK,1)+C2(IK,J)
  128    CONTINUE
  129 CONTINUE
C
      IF (IDO .GE. L1) THEN
         DO 131 K=1,L1
            DO 130 I=1,IDO
               CC(I,1,K) = CH(I,K,1)
  130       CONTINUE
  131    CONTINUE
      ELSE
         DO 134 I=1,IDO
            DO 133 K=1,L1
               CC(I,1,K) = CH(I,K,1)
  133       CONTINUE
  134    CONTINUE
      ENDIF
      DO 137 J=2,IPPH
         JC = IPP2-J
         J2 = J+J
         DO 136 K=1,L1
            CC(IDO,J2-2,K) = CH(1,K,J)
            CC(1,J2-1,K) = CH(1,K,JC)
  136    CONTINUE
  137 CONTINUE
      IF (IDO .EQ. 1) RETURN
      IF (NBD .GE. L1) THEN
         DO 140 J=2,IPPH
            JC = IPP2-J
            J2 = J+J
            DO 139 K=1,L1
               DO 138 I=3,IDO,2
                  IC = IDP2-I
                  CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC)
                  CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC)
                  CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC)
                  CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J)
  138          CONTINUE
  139       CONTINUE
  140    CONTINUE
         RETURN
      ENDIF
      DO 144 J=2,IPPH
         JC = IPP2-J
         J2 = J+J
         DO 143 I=3,IDO,2
            IC = IDP2-I
            DO 142 K=1,L1
               CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC)
               CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC)
               CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC)
               CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J)
  142       CONTINUE
  143    CONTINUE
  144 CONTINUE
      RETURN
      END

      FUNCTION RAND(R)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      SAVE IY0, IY1, IX0, IX1
      DATA IA1, IA0, IA1MA0 /1536, 1029, 507/
      DATA IC /1731/
      DATA IX1, IX0 /0, 0/
      IF (R.EQ.0.) THEN
         IY0 = IA0*IX0
         IY1 = IA1*IX1 + IA1MA0*(IX0-IX1) + IY0
         IY0 = IY0 + IC
         IX0 = MOD (IY0, 2048)
         IY1 = IY1 + (IY0-IX0)/2048
         IX1 = MOD (IY1, 2048)
      ELSE IF (R.GT.0.) THEN
         IX1 = DMOD(R,1.0D0)*4194304.D0 + 0.5D0
         IX0 = MOD (IX1, 2048)
         IX1 = (IX1-IX0)/2048
      ENDIF
      RAND = IX1*2048 + IX0
      RAND = RAND / 4194304.D0
      RETURN
      END