C
C                  lpm1bk.f  -  body of DM benchmark code
C                               used by slave and master
C ----------------------------------------------------------------
C
         SUBROUTINE LPM1MA
C
C     VERSION OF 'LPM1' FOR RUNNING ON MASTER PROCESSOR
C
C-----------------------------------------------------------------------
C   Make sure that these commons are truely global
C       INCLUDE 'C:\TINYV2R0\INCLUDE\TINY.INC'
C       INCLUDE 'CHAN.INC'
C
C     COMMON /GRAFIX/ MASKSZ,MSPORT,SSPORT,GPORT,GBOOT,G_TASKID,
C    1       IBLK,IWHT,IRED,IGRN,IBLU,IYEL,IMAG,ICYA,SRPORT
C     INTEGER MASKSZ,MSPORT,SSPORT,GPORT,GBOOT,G_TASKID,SRPORT
C     COMMON /MTINY/ MYNUM,NSLAV,NTASK,ISLMIN(128),ISLMAX(128)
C-----------------------------------------------------------------------
C
C  Initialise express profiler
C        INTEGER LOGBUF(2048)LABBUF(256)
C        CALL KEPINI(LABBUF,1024,LOGBUF,8192)
C        CALL KEPLAB(1,'Inner Loop','Loop= %d')
C        CALL KXPOFF
C        CALL KEPOFF
C        CALL KCPOFF
C     Name changed from MASTER to avoid possible clash with Tiny Harness
         CALL MISTER
C
         END
C/ MODULE c1s2
C
         SUBROUTINE CLEAR
C
C 1.2  CLEAR VARIABLES AND ARRAYS
C
       IMPLICIT COMPLEX(C),  DOUBLE PRECISION(D), LOGICAL(L)
C
       COMMON/COMCON/ R21(8)
       COMMON/COMSTT/ R22(178306)
       COMMON/COMDEV/ R23(823),I23(113)
       COMMON/COMDIA/ R24(327),I24(202)
       COMMON/COMKLY/ R25(4)
       COMMON/COMNUM/ R31(14),I31(8)
       COMMON/COMSCA/ R32(16)
       COMMON/COMHOK/ R41(36),I41(10)
       COMMON/COMGEO/ R42(13312),I42(21506)
       COMMON/COMOUT/ R51(17),I51(9)
C---------------------------------------------------------------------
C
C
         ZEROS=0.0
C
C     BLOCK COMCON
         CALL RESETR(R21,8,ZEROS)
C     BLOCK COMSTT
         CALL RESETR(R22,178306,ZEROS)
C     BLOCK COMDEV
         CALL RESETR(R23,823,ZEROS)
         CALL RESETI(I23,113,0)
C     BLOCK COMDIA
         CALL RESETR(R24,327,ZEROS)
         CALL RESETI(I24,202,0)
C     BLOCK COMKLY
         CALL RESETR(R25,4,ZEROS)
C     BLOCK COMNUM
         CALL RESETR(R31,14,ZEROS)
         CALL RESETI(I31,8,0)
C     BLOCK COMSCA
         CALL RESETR(R32,16,ZEROS)
C     BLOCK COMHOK
         CALL RESETR(R41,36,ZEROS)
         CALL RESETI(I41,10,0)
C     BLOCK COMGEO
         CALL RESETR(R42,13312,ZEROS)
         CALL RESETI(I42,21506,0)
C     BLOCK COMOUT
         CALL RESETR(R51,17,ZEROS)
         CALL RESETI(I51,9,0)
C
         END
C/ MODULE C1S3
C
         SUBROUTINE PRESET
C
C 1.3  Set default values
C
C-----------------------------------------------------------------------
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C       INCLUDE 'COMDDP.inc'
C--------------------------------------------------------------------
CL                  C1.9.    DEVELOPMENT AND DIAGNOSTIC PARAMETERS
       COMMON/COMDDP/
     I   MAXDUM,   MXDUMP,   NADUMP,   NCLASS,   NPDUMP,   NPOINT,
     I   NSUB,     NVDUMP,
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       LOGICAL
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       DIMENSION
     I   NADUMP(20),         NPDUMP(20),         NVDUMP(20),
     L   NLHEAD(9),          NLOMT1(50),         NLOMT2(50),
     L   NLOMT3(50)
C       INCLUDE 'COMCON.inc'
C---------------------------------------------------------------------
CL                  C2.1     Physical Constants
       COMMON/COMCON/
     R   API   ,   BOLTZK,   CLIGHT,   ELCHAG,   ELMASS,   EMU0  ,
     R   EOVERM,   EPS0
C       INCLUDE 'COMSTT.inc'
C---------------------------------------------------------------------
CL                  C2.2     Physical State
       COMMON/COMSTT/
     R   B3    ,   BAV   ,   CD1   ,   CD2   ,   E1    ,   E2    ,
     R   P1    ,   P2    ,   Q1    ,   Q2    ,   REALTN,   TIMRUN
       DIMENSION
     R   B3(605,40),        BAV(605,40),       CD1(605,40),
     R   CD2(605,40),       E1(605,40),        E2(605,40),
     R   P1(20000),          P2(20000),          Q1(20000),
     R   Q2(20000)
C       INCLUDE 'COMDEV.inc'
C---------------------------------------------------------------------
CL                  C2.3     Device description
       COMMON/COMDEV/
     R   B3RHS ,   B3RHSD,   BAPLY ,   BAPLYD,   CAVEAM,   CAVEFR,
     R   CAVIC ,   CAVRES,   CAVTC ,   DEPTH ,   DEVHYT,   DEVLEN,
     R   DEVRAD,   EAPLYD,   EEMIT ,   EEMITD,   ENIT  ,   ENITD ,
     R   GAP   ,   RESAX ,   RESE  ,   RESN  ,   RESS  ,   RESW  ,
     R   RINNER,   SPACE ,   VOLTAG,   WIDTH ,
     I   LCATH ,   LCAV  ,   LLEFT ,   LWVANE,   MDEPTH,   MGAP  ,
     I   NBCAX ,   NBCCAV,   NBCE  ,   NBCN  ,   NBCS  ,   NBCW  ,
     I   NCAV  ,   NDEV
       DIMENSION
     R   CAVEAM(100),        CAVEFR(100),        CAVIC(4,100),
     R   CAVRES(100),        CAVTC(100),
     I   NBCCAV(100)
C       INCLUDE 'COMDIA.inc'
C---------------------------------------------------------------------
CL                  C2.4     Physical Diagnostics
       COMMON/COMDIA/
     R   B3POW ,   BOUT  ,   CAVPOY,   E1POW ,   E2POW ,   EJ1POW,
     R   EJ2POW,   EJENP ,   EJPOWM,   EJPOWP,   EJPWPN,   EKFLXI,
     R   EKFLXO,   ENEJ1 ,   ENEJ2 ,   ENEL1 ,   ENEL1O,   ENEL2 ,
     R   ENEL2O,   ENKIN ,   ENKINO,   ENMAG ,   ENMAGO,   ENPOYT,
     R   ENTOT ,   ENTOTO,   EOUT  ,   TOTM1 ,   TOTM2 ,   TPOYP ,
     I   LCAVEN,   LCAVST,   NPNEW ,   NPOLD
       DIMENSION
     R   BOUT(100),          CAVPOY(100),        EOUT(100),
     I   LCAVEN(100),        LCAVST(100)
C       INCLUDE 'COMNUM.inc'
C---------------------------------------------------------------------
CL                  C3.1     Numerical Parameters
       COMMON/COMNUM/
     R   C1    ,   C2    ,   CD0   ,   CURANT,   DT    ,   DX1   ,
     R   DX1DX2,   DX1OX2,   DX2   ,   DX2OX1,   ELPERP,   HLFDX1,
     R   HLFDX2,   TCACO ,
     I   LMAX  ,   LMAXP ,   LMAXP2,   MMAX  ,   MMAXP ,   MMAXP2,
     I   NEMIT ,   NP
C       INCLUDE 'COMSCA.inc'
C---------------------------------------------------------------------
CL                  C3.2     Scaling Factors
       COMMON/COMSCA/
     R   SCB3  ,   SCE1  ,   SCE2  ,   SCEMEN,   SCEPOW,   SCI1  ,
     R   SCI2  ,   SCIP  ,   SCKE  ,   SCKPOW,   SCP1  ,   SCP2  ,
     R   SCV1  ,   SCV2  ,   SCX1  ,   SCX2
C       INCLUDE 'COMHOK.inc'
C---------------------------------------------------------------------
CL                  C4.1     Housekeeping
       COMMON/COMHOK/
     R   TIMECP,   XPSMAX,   XPSMIN,   YPSMAX,   YPSMIN,
     I   N1MAX ,   N2MAX ,   NCASE ,   NGMAX ,   NOSEP ,   NPDUM ,
     I   NPMAX ,   NSRC  ,   NXDUM ,   NYDUM
       DIMENSION
     R   TIMECP(32)
C       INCLUDE 'COMGEO.inc'
C---------------------------------------------------------------------
CL                  C4.2     Device boundary data
       COMMON/COMGEO/
     R   ASCUR ,   CCTSRC,   EBEXT ,   ELSCUR,   ENSUR ,   EPOYNT,
     R   RHOC  ,   SURCHG,   SURIC ,
     I   LINDEX,   MINDEX,   NBCTYP,   NBDIM ,   NBSEG2,   NCOLOR,
     I   NDIRN ,   NG
       DIMENSION
     R   ASCUR(1500),        CCTSRC(1500),       EBEXT(2,1500),
     R   ELSCUR(1500),       ENSUR(1500),        EPOYNT(1500),
     R   RHOC(1500),         SURCHG(1500),       SURIC(4,1500),
     I   LINDEX(1500),       MINDEX(1500),       NBCTYP(1500),
     I   NCOLOR(1500),       NDIRN(1500),        NG(605,40)
C       INCLUDE 'COMOUT.inc'
C---------------------------------------------------------------------
CL                  C5.1     Output Variables
       COMMON/COMOUT/
     R   BCNMAX,   BCNMIN,   BCVMAX,   BCVMIN,   CUAMAX,   CUAMIN,
     R   CUEMAX,   CUEMIN,   ECVMAX,   ECVMIN,   TONS1 ,   TONS2 ,
     R   TONS3 ,   TONS4 ,   TONS5 ,   TONS6 ,   TONS7 ,
     I   NBCHT ,   NOPSEL,   NS1   ,   NS2   ,   NS3   ,   NS4   ,
     I   NS5   ,   NS6   ,   NS7
C-----------------------------------------------------------------------
         DATA        ICLASS,   ISUB/1,   3/
                                       CALL EXPERT(ICLASS,ISUB,1)
         IF(NLOMT1(ISUB))RETURN
C
C-----------------------------------------------------------------------
CL              1.         Olympus data
C
C     NDIARY channel default number
         NDIARY=9
         NREC  =10
C
C
C-----------------------------------------------------------------------
CL              2.         physical
C
C
CL                  2.1      constants
         API    = 3.141593
         BOLTZK = 1.380E-23
         CLIGHT = 3.000E+8
         ELCHAG = -1.602E-19
         ELMASS = 9.108E-31
         EMU0   = 4.0*API*1.E-7
         EPS0   = 1.0/(EMU0*CLIGHT**2)
C
CL                  2.2      device description
         TIMRUN = 0.0
         VOLTAG = -0.5E+6
         BAPLY  =  0.0
         B3RHS  = 0.0
         EEMIT  = -1.0E+6
         ENIT   = 0.0
C     set to default values
         DEVHYT = 0.15
         DEVLEN = 0.37
         DEVRAD = 0.0
         LLEFT  = 16
         LCAV   = 8
         LWVANE = 2
         LCATH  = 66
         MGAP   =  8
         MDEPTH = 16
         NCAV   = 6
         CALL RESETR(CAVTC ,100,1.0)
         CALL RESETR(CAVRES,100,1.0)
C
C     boundary conditions
         RESN=0.
         RESS=0.
         RESE=0.0
         RESW=0.
         NBCN=0
         NBCS=0
         NBCE=0
         NBCW=-3
C
         RESAX=0.
         NBCAX=3
C
C-----------------------------------------------------------------------
CL              3.         numerical
C
         TCACO  = 0.01
         CURANT = 0.8385256
         ELPERP = 1.0E11
         NEMIT  = 5
         NP     = 0
C
         LMAX   = 75
         MMAX   = 33
C
C-----------------------------------------------------------------------
CL              4.         housekeeping
C
         NCASE  = 2
         NPDUM  = 100
         NXDUM  = 16
         NYDUM  = 16
         NPMAX  = 20000
         N1MAX  = 605
         N2MAX  = 40
         NBDIM  = 1024
         NOSEP  = 10
         NGMAX  = 1000
C
C     PSPACE arguments
         XPSMIN=0.12
         XPSMAX=0.85
         YPSMIN=0.12
         YPSMAX=0.85
C
C-----------------------------------------------------------------------
CL              5.         output
C
         NOPSEL = 3
         NS1    = 25
         NS2    = 100
         NS3    = 1
         NS4    = 1
         NS5    = 1
C
         TONS1  = 0.10
         TONS2  = 5.00
         TONS3  = 2.00
         TONS4  = 0.05
         TONS5  = 0.1
C
         NBCHT=11
         BCNMIN=-0.15
         BCNMAX= 0.05
         BCVMIN= -0.15
         BCVMAX= 0.05
         ECVMIN=-4.0E7
         ECVMAX= 4.0E7
         CUEMIN=-5
         CUEMAX= 5
         CUAMIN=-5
         CUAMAX= 5
C-----------------------------------------------------------------------
         END
C/ MODULE C1S6
C
         SUBROUTINE INITAL
C
C 1.6  DEFINE PHYSICAL INITIAL CONDITIONS
C
C-----------------------------------------------------------------------
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C       INCLUDE 'COMDDP.inc'
C--------------------------------------------------------------------
CL                  C1.9.    DEVELOPMENT AND DIAGNOSTIC PARAMETERS
       COMMON/COMDDP/
     I   MAXDUM,   MXDUMP,   NADUMP,   NCLASS,   NPDUMP,   NPOINT,
     I   NSUB,     NVDUMP,
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       LOGICAL
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       DIMENSION
     I   NADUMP(20),         NPDUMP(20),         NVDUMP(20),
     L   NLHEAD(9),          NLOMT1(50),         NLOMT2(50),
     L   NLOMT3(50)
C       INCLUDE 'COMCON.inc'
C---------------------------------------------------------------------
CL                  C2.1     Physical Constants
       COMMON/COMCON/
     R   API   ,   BOLTZK,   CLIGHT,   ELCHAG,   ELMASS,   EMU0  ,
     R   EOVERM,   EPS0
C       INCLUDE 'COMSTT.inc'
C---------------------------------------------------------------------
CL                  C2.2     Physical State
       COMMON/COMSTT/
     R   B3    ,   BAV   ,   CD1   ,   CD2   ,   E1    ,   E2    ,
     R   P1    ,   P2    ,   Q1    ,   Q2    ,   REALTN,   TIMRUN
       DIMENSION
     R   B3(605,40),        BAV(605,40),       CD1(605,40),
     R   CD2(605,40),       E1(605,40),        E2(605,40),
     R   P1(20000),          P2(20000),          Q1(20000),
     R   Q2(20000)
C       INCLUDE 'COMDEV.inc'
C---------------------------------------------------------------------
CL                  C2.3     Device description
       COMMON/COMDEV/
     R   B3RHS ,   B3RHSD,   BAPLY ,   BAPLYD,   CAVEAM,   CAVEFR,
     R   CAVIC ,   CAVRES,   CAVTC ,   DEPTH ,   DEVHYT,   DEVLEN,
     R   DEVRAD,   EAPLYD,   EEMIT ,   EEMITD,   ENIT  ,   ENITD ,
     R   GAP   ,   RESAX ,   RESE  ,   RESN  ,   RESS  ,   RESW  ,
     R   RINNER,   SPACE ,   VOLTAG,   WIDTH ,
     I   LCATH ,   LCAV  ,   LLEFT ,   LWVANE,   MDEPTH,   MGAP  ,
     I   NBCAX ,   NBCCAV,   NBCE  ,   NBCN  ,   NBCS  ,   NBCW  ,
     I   NCAV  ,   NDEV
       DIMENSION
     R   CAVEAM(100),        CAVEFR(100),        CAVIC(4,100),
     R   CAVRES(100),        CAVTC(100),
     I   NBCCAV(100)
C       INCLUDE 'COMDIA.inc'
C---------------------------------------------------------------------
CL                  C2.4     Physical Diagnostics
       COMMON/COMDIA/
     R   B3POW ,   BOUT  ,   CAVPOY,   E1POW ,   E2POW ,   EJ1POW,
     R   EJ2POW,   EJENP ,   EJPOWM,   EJPOWP,   EJPWPN,   EKFLXI,
     R   EKFLXO,   ENEJ1 ,   ENEJ2 ,   ENEL1 ,   ENEL1O,   ENEL2 ,
     R   ENEL2O,   ENKIN ,   ENKINO,   ENMAG ,   ENMAGO,   ENPOYT,
     R   ENTOT ,   ENTOTO,   EOUT  ,   TOTM1 ,   TOTM2 ,   TPOYP ,
     I   LCAVEN,   LCAVST,   NPNEW ,   NPOLD
       DIMENSION
     R   BOUT(100),          CAVPOY(100),        EOUT(100),
     I   LCAVEN(100),        LCAVST(100)
C       INCLUDE 'COMNUM.inc'
C---------------------------------------------------------------------
CL                  C3.1     Numerical Parameters
       COMMON/COMNUM/
     R   C1    ,   C2    ,   CD0   ,   CURANT,   DT    ,   DX1   ,
     R   DX1DX2,   DX1OX2,   DX2   ,   DX2OX1,   ELPERP,   HLFDX1,
     R   HLFDX2,   TCACO ,
     I   LMAX  ,   LMAXP ,   LMAXP2,   MMAX  ,   MMAXP ,   MMAXP2,
     I   NEMIT ,   NP
C       INCLUDE 'COMSCA.inc'
C---------------------------------------------------------------------
CL                  C3.2     Scaling Factors
       COMMON/COMSCA/
     R   SCB3  ,   SCE1  ,   SCE2  ,   SCEMEN,   SCEPOW,   SCI1  ,
     R   SCI2  ,   SCIP  ,   SCKE  ,   SCKPOW,   SCP1  ,   SCP2  ,
     R   SCV1  ,   SCV2  ,   SCX1  ,   SCX2
C       INCLUDE 'COMHOK.inc'
C---------------------------------------------------------------------
CL                  C4.1     Housekeeping
       COMMON/COMHOK/
     R   TIMECP,   XPSMAX,   XPSMIN,   YPSMAX,   YPSMIN,
     I   N1MAX ,   N2MAX ,   NCASE ,   NGMAX ,   NOSEP ,   NPDUM ,
     I   NPMAX ,   NSRC  ,   NXDUM ,   NYDUM
       DIMENSION
     R   TIMECP(32)
C       INCLUDE 'COMGEO.inc'
C---------------------------------------------------------------------
CL                  C4.2     Device boundary data
       COMMON/COMGEO/
     R   ASCUR ,   CCTSRC,   EBEXT ,   ELSCUR,   ENSUR ,   EPOYNT,
     R   RHOC  ,   SURCHG,   SURIC ,
     I   LINDEX,   MINDEX,   NBCTYP,   NBDIM ,   NBSEG2,   NCOLOR,
     I   NDIRN ,   NG
       DIMENSION
     R   ASCUR(1500),        CCTSRC(1500),       EBEXT(2,1500),
     R   ELSCUR(1500),       ENSUR(1500),        EPOYNT(1500),
     R   RHOC(1500),         SURCHG(1500),       SURIC(4,1500),
     I   LINDEX(1500),       MINDEX(1500),       NBCTYP(1500),
     I   NCOLOR(1500),       NDIRN(1500),        NG(605,40)
C       INCLUDE 'COMOUT.inc'
C---------------------------------------------------------------------
CL                  C5.1     Output Variables
       COMMON/COMOUT/
     R   BCNMAX,   BCNMIN,   BCVMAX,   BCVMIN,   CUAMAX,   CUAMIN,
     R   CUEMAX,   CUEMIN,   ECVMAX,   ECVMIN,   TONS1 ,   TONS2 ,
     R   TONS3 ,   TONS4 ,   TONS5 ,   TONS6 ,   TONS7 ,
     I   NBCHT ,   NOPSEL,   NS1   ,   NS2   ,   NS3   ,   NS4   ,
     I   NS5   ,   NS6   ,   NS7
C-----------------------------------------------------------------------
         DATA        ICLASS,   ISUB/1,   6/
                                       CALL EXPERT(ICLASS,ISUB,1)
         IF(NLOMT1(ISUB))RETURN
C
C-----------------------------------------------------------------------
CL              1.         transmission line
C
C
CL                  1.1      transmission line
         NBSEG=NBSEG2-2
C
         IF(NCASE.EQ.1) THEN
         CALL SETBOX(LMAXP2,MMAXP2,N1MAX,NG,
     +               NBSEG2,LINDEX,MINDEX,NDIRN,NBDIM)
         DO 110 JS=1,NBSEG2
C     west
         IF(NDIRN(JS).EQ.1) THEN
         SURIC(1,JS)=RESW
         EBEXT(1,JS)=0.0
         EBEXT(2,JS)=0.0
         NBCTYP(JS)=NBCW
         NCOLOR(JS)=1
C     north
         ELSE IF(NDIRN(JS).EQ.2) THEN
         SURIC(1,JS)=RESN
         EBEXT(1,JS)=0.0
         EBEXT(2,JS)=0.0
         NBCTYP(JS)=NBCN
         NCOLOR(JS)=2
C     east
         ELSE IF(NDIRN(JS).EQ.3) THEN
         SURIC(1,JS)=RESE
         EBEXT(1,JS)=0.0
         EBEXT(2,JS)=0.0
         NBCTYP(JS)=NBCE
         NCOLOR(JS)=1
C     south
         ELSE
         SURIC(1,JS)=RESN
         EBEXT(1,JS)=0.0
         EBEXT(2,JS)=0.0
         NBCTYP(JS)=NBCN
         NCOLOR(JS)=-4
         IF(LINDEX(JS).LT.10
     +      .AND.NBCE.NE.1)NCOLOR(JS)=4
         END IF
  110    CONTINUE
C
C-----------------------------------------------------------------------
CL              2.         case 2 linear oscillator
C
C     This version allows power injection into and extraction from
C     the tops of the resonant cavities
C
         ELSE IF(NCASE.EQ.2..OR.NCASE.EQ.3) THEN
C
CL                  2.1      dimensionless coeffs for cavity impedance
C  RESN is used to include dc resistance for test cases
         DO 210 JCAV=1,NCAV
         ZRES=CAVRES(JCAV)
         ZTAU=CAVTC(JCAV)*(1.0E9/DT)
         CAVIC(1,JCAV)=(ZRES+RESN)*ZTAU+RESN*0.5
         CAVIC(2,JCAV)=ZTAU+0.5
         CAVIC(3,JCAV)=(ZRES+RESN)*ZTAU-RESN*0.5
         CAVIC(4,JCAV)=ZTAU-0.5
  210    CONTINUE
C
CL                  2.2      set up device
         CALL SETLO(LMAXP2,MMAXP2,N1MAX,NG,NBSEG2,
     +              LINDEX,MINDEX,NDIRN,NBDIM,
     +              LLEFT,LCAV,LWVANE,LCATH,MGAP,MDEPTH,NCAV,
     +              NBCTYP,NCOLOR,SURIC,
     +              NBCW,NBCE,NBCAX,NBCCAV,
     +              RESW,RESE,RESAX,CAVIC,LCAVST,LCAVEN)
C     applying an electric at the source end can be done as follows,
C     but the initial step in E causes a large Gibbs Phenomena on
C     the electric and magnetic fields which propogate down the
C     device. A cleaner result obtains if we ramp up. So...
C.****this has been replaced by ERAMP in c2s1
C     apply electric field at lhs
C     DO 200 JS = 4,NBSEG2
C     IF(NDIRN(JS).EQ.1.AND.LINDEX(JS).EQ.2.AND.NCOLOR(JS).EQ.1)
C     +   EBEXT(JS)=EAPLYD
C     200     CONTINUE
C.*****
C     case 3 is same as 2 except emission is suppressed on
C     part of the cathode
C
         IF(NCASE.EQ.3) THEN
         DO 220 JS=1,NBSEG2
         IF(NDIRN(JS).EQ.4.AND.NCOLOR(JS).EQ.-4)
     +    NCOLOR(JS)=-NCOLOR(JS)
         JLAST=2*(LMAX+MMAX)-LCATH-MGAP-8
         IF(JS.GT.JLAST)NCOLOR(JS)=IEBS(NCOLOR(JS))
  220    CONTINUE
         END IF
         END IF
C
C-----------------------------------------------------------------------
CL              3.         Initial E and B at t=0
C
         DO 300 JM=1,MMAXP2
         ZRAD=JM+RINNER-1.5
         DO 300 JL=1,LMAXP2
C     uniform applied E*r over whole domain
C     this is silly except for ncase=1
         E2(JL,JM)=ENITD/ZRAD
C     uniform B over whole domain
  300    B3(JL,JM)=BAPLYD
C
         CALL EBJCLR(E1,E2,B3,CD1,CD2,NG,N1MAX,LMAXP2,MMAXP2)
         CALL ESRCIN(E1,E2,B3,N1MAX,NBSEG2,
     +               LINDEX,MINDEX,NDIRN,NBCTYP,EBEXT)
C
C-----------------------------------------------------------------------
         END
C/ MODULE C1S8
C
         SUBROUTINE START
C
C 1.8  START THE CALCULATION
C
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C       INCLUDE 'COMDDP.inc'
C--------------------------------------------------------------------
CL                  C1.9.    DEVELOPMENT AND DIAGNOSTIC PARAMETERS
       COMMON/COMDDP/
     I   MAXDUM,   MXDUMP,   NADUMP,   NCLASS,   NPDUMP,   NPOINT,
     I   NSUB,     NVDUMP,
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       LOGICAL
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       DIMENSION
     I   NADUMP(20),         NPDUMP(20),         NVDUMP(20),
     L   NLHEAD(9),          NLOMT1(50),         NLOMT2(50),
     L   NLOMT3(50)
C       INCLUDE 'COMCON.inc'
C---------------------------------------------------------------------
CL                  C2.1     Physical Constants
       COMMON/COMCON/
     R   API   ,   BOLTZK,   CLIGHT,   ELCHAG,   ELMASS,   EMU0  ,
     R   EOVERM,   EPS0
C       INCLUDE 'COMSTT.inc'
C---------------------------------------------------------------------
CL                  C2.2     Physical State
       COMMON/COMSTT/
     R   B3    ,   BAV   ,   CD1   ,   CD2   ,   E1    ,   E2    ,
     R   P1    ,   P2    ,   Q1    ,   Q2    ,   REALTN,   TIMRUN
       DIMENSION
     R   B3(605,40),        BAV(605,40),       CD1(605,40),
     R   CD2(605,40),       E1(605,40),        E2(605,40),
     R   P1(20000),          P2(20000),          Q1(20000),
     R   Q2(20000)
C       INCLUDE 'COMDEV.inc'
C---------------------------------------------------------------------
CL                  C2.3     Device description
       COMMON/COMDEV/
     R   B3RHS ,   B3RHSD,   BAPLY ,   BAPLYD,   CAVEAM,   CAVEFR,
     R   CAVIC ,   CAVRES,   CAVTC ,   DEPTH ,   DEVHYT,   DEVLEN,
     R   DEVRAD,   EAPLYD,   EEMIT ,   EEMITD,   ENIT  ,   ENITD ,
     R   GAP   ,   RESAX ,   RESE  ,   RESN  ,   RESS  ,   RESW  ,
     R   RINNER,   SPACE ,   VOLTAG,   WIDTH ,
     I   LCATH ,   LCAV  ,   LLEFT ,   LWVANE,   MDEPTH,   MGAP  ,
     I   NBCAX ,   NBCCAV,   NBCE  ,   NBCN  ,   NBCS  ,   NBCW  ,
     I   NCAV  ,   NDEV
       DIMENSION
     R   CAVEAM(100),        CAVEFR(100),        CAVIC(4,100),
     R   CAVRES(100),        CAVTC(100),
     I   NBCCAV(100)
C       INCLUDE 'COMDIA.inc'
C---------------------------------------------------------------------
CL                  C2.4     Physical Diagnostics
       COMMON/COMDIA/
     R   B3POW ,   BOUT  ,   CAVPOY,   E1POW ,   E2POW ,   EJ1POW,
     R   EJ2POW,   EJENP ,   EJPOWM,   EJPOWP,   EJPWPN,   EKFLXI,
     R   EKFLXO,   ENEJ1 ,   ENEJ2 ,   ENEL1 ,   ENEL1O,   ENEL2 ,
     R   ENEL2O,   ENKIN ,   ENKINO,   ENMAG ,   ENMAGO,   ENPOYT,
     R   ENTOT ,   ENTOTO,   EOUT  ,   TOTM1 ,   TOTM2 ,   TPOYP ,
     I   LCAVEN,   LCAVST,   NPNEW ,   NPOLD
       DIMENSION
     R   BOUT(100),          CAVPOY(100),        EOUT(100),
     I   LCAVEN(100),        LCAVST(100)
C       INCLUDE 'COMNUM.inc'
C---------------------------------------------------------------------
CL                  C3.1     Numerical Parameters
       COMMON/COMNUM/
     R   C1    ,   C2    ,   CD0   ,   CURANT,   DT    ,   DX1   ,
     R   DX1DX2,   DX1OX2,   DX2   ,   DX2OX1,   ELPERP,   HLFDX1,
     R   HLFDX2,   TCACO ,
     I   LMAX  ,   LMAXP ,   LMAXP2,   MMAX  ,   MMAXP ,   MMAXP2,
     I   NEMIT ,   NP
C       INCLUDE 'COMSCA.inc'
C---------------------------------------------------------------------
CL                  C3.2     Scaling Factors
       COMMON/COMSCA/
     R   SCB3  ,   SCE1  ,   SCE2  ,   SCEMEN,   SCEPOW,   SCI1  ,
     R   SCI2  ,   SCIP  ,   SCKE  ,   SCKPOW,   SCP1  ,   SCP2  ,
     R   SCV1  ,   SCV2  ,   SCX1  ,   SCX2
C       INCLUDE 'COMHOK.inc'
C---------------------------------------------------------------------
CL                  C4.1     Housekeeping
       COMMON/COMHOK/
     R   TIMECP,   XPSMAX,   XPSMIN,   YPSMAX,   YPSMIN,
     I   N1MAX ,   N2MAX ,   NCASE ,   NGMAX ,   NOSEP ,   NPDUM ,
     I   NPMAX ,   NSRC  ,   NXDUM ,   NYDUM
       DIMENSION
     R   TIMECP(32)
C       INCLUDE 'COMOUT.inc'
C---------------------------------------------------------------------
CL                  C5.1     Output Variables
       COMMON/COMOUT/
     R   BCNMAX,   BCNMIN,   BCVMAX,   BCVMIN,   CUAMAX,   CUAMIN,
     R   CUEMAX,   CUEMIN,   ECVMAX,   ECVMIN,   TONS1 ,   TONS2 ,
     R   TONS3 ,   TONS4 ,   TONS5 ,   TONS6 ,   TONS7 ,
     I   NBCHT ,   NOPSEL,   NS1   ,   NS2   ,   NS3   ,   NS4   ,
     I   NS5   ,   NS6   ,   NS7
C-----------------------------------------------------------------------
         DATA        ICLASS,   ISUB/1,   8/
                                       CALL EXPERT(ICLASS,ISUB,1)
         IF(NLOMT1(ISUB))RETURN
C
C-----------------------------------------------------------------------
CL              1.         make tca zero at first step
C
         DO 100 JM=1,MMAXP2
         DO 100 JL=1,LMAXP2
         BAV(JL,JM)=B3(JL,JM)
  100    CONTINUE
C-----------------------------------------------------------------------
         END
C/ MODULE C1S9
C
         FUNCTION RANDS(KFLAG)
C
C 1.9  return random no in [0,1]
C
C        KFLAG=1   initialise
C             =0   next random number
C
C-----------------------------------------------------------------------
         RANDS=REND(KFLAG)
         END
C/ MODULE C1S14
C
         SUBROUTINE SETLO(KLMAX2,KMMAX2,KXDIM,KNG,KNBSP2,
     +   KL,KM,KDIR,KNBDIM,
     +   KLLEFT,KLCAV,KLVANE,KLCATH,KMGAP,KMDPTH,KNCAV,
     +   KBCTYP,KCOLOR,PSURIC,
     +   KBCIN,KBCOUT,KBCAX,KBCCAV,
     +   PRIN,PROUT,PRAX,PCAVIC,KCAVST,KCAVEN)
C
C 1.14 define geometry and boundary arrays for Linear oscillator
C
C-----------------------------------------------------------------------
       DIMENSION
     +   KNG(KXDIM,*),       KL(KNBDIM),         KM(KNBDIM),
     +   KDIR(KNBDIM),       KBCTYP(KNBDIM),     KCOLOR(KNBDIM),
     +   KBCCAV(*),          KCAVST(*),          KCAVEN(*),
     +   PCAVIC(4,*),        PSURIC(4,KNBDIM)
C
C-----------------------------------------------------------------------
CL              1.         initialise geometry array
C
         ILMAXP=KLMAX2-1
         ILMAX =ILMAXP-1
         IMMAXP=KMMAX2-1
         IMMAX =IMMAXP-1
C
CL                  1.1      interior
         DO 110 JM=2,IMMAX
         DO 110 JL=2,ILMAX
         KNG(JL,JM)=0
  110    CONTINUE
C
CL                  1.2      guard cells
C     left and right ends
         DO 120 JM=1,IMMAXP
         KNG(1,JM)=1
         KNG(ILMAXP,JM)=1
  120    CONTINUE
C     top and bottom
         DO 121 JL=1,ILMAXP
         KNG(JL,IMMAXP)=1
         KNG(JL,1)=1
  121    CONTINUE
C
CL                  1.3      dummy first element of surface table
         INBSEG=1
         KL(1)=1
         KM(1)=1
         KDIR(1)=0
C
CL                  1.4      clear impedance arrays
         DO 140 J2=1,KNBDIM
         DO 140 J1=1,4
         PSURIC(J1,J2)=0.0
  140    CONTINUE
C
C-----------------------------------------------------------------------
CL              2.         Anode
C
         IRED=2
         IBCA=0
C
         IL=2
         IMCATH=IMMAX-KMGAP-KMDPTH-1
         IM=KMGAP+IMCATH+2
         IRIGHT=ILMAX-KLLEFT-KNCAV*(KLCAV+KLVANE)-1+KLVANE
C
CL                  2.1      entrance line
         IF(KLLEFT.GT.0) THEN
         DO 211 JS=1,KLLEFT
         INBSEG=INBSEG+1
         KL(INBSEG)=IL
         KM(INBSEG)=IM
         KDIR(INBSEG) =2
C
         KBCTYP(INBSEG) =IBCA
         KCOLOR(INBSEG) =IRED
C
         KNG(IL,IM)   = INBSEG
         KNG(IL,IM-1) =-INBSEG
C     set grid array in anode
         IMP1=IM+1
         DO 210 JMG=IMP1,KMMAX2
         KNG(IL,JMG)=1
  210    CONTINUE
         IL = IL + 1
  211    CONTINUE
         END IF
C
CL                  2.2      cavities and vanes
         IF(KNCAV.GT.0) THEN
         DO 226 JCAV=1,KNCAV
C
C     mark the corner cell
         KNG(IL,IM-1)=-1
C
C     up cavity
         DO 220 JS=1,KMDPTH
         INBSEG=INBSEG+1
         KL(INBSEG)=IL
         KM(INBSEG)=IM
         KDIR(INBSEG) = 1
C
         KBCTYP(INBSEG) =IBCA
         KCOLOR(INBSEG) =IRED
C
         KNG(IL-1,IM) = INBSEG
         KNG(IL,IM) =-INBSEG
         IM=IM+1
  220    CONTINUE
C     along top of cavity
         KCAVST(JCAV)=INBSEG+1
         DO 222 JS=1,KLCAV
         INBSEG=INBSEG+1
         KL(INBSEG)=IL
         KM(INBSEG)=IM
         KDIR(INBSEG) =2
C
         KBCTYP(INBSEG) =KBCCAV(JCAV)
         KCOLOR(INBSEG) =IRED
         DO 221 J=1,4
         PSURIC(J,INBSEG) = PCAVIC(J,JCAV)
  221    CONTINUE
C
         KNG(IL,IM) = INBSEG
         KNG(IL,IM-1) =-INBSEG
         IL=IL+1
  222    CONTINUE
         KCAVEN(JCAV)=INBSEG
C     along rh side of cavity
         DO 223 JS=1,KMDPTH
         INBSEG=INBSEG+1
         KL(INBSEG)=IL
         KM(INBSEG)=IM
         KDIR(INBSEG) =3
C
         KBCTYP(INBSEG) =IBCA
         KCOLOR(INBSEG) =IRED
C
         KNG(IL,IM-1) = INBSEG
         KNG(IL-1,IM-1) =-INBSEG
         IM=IM-1
  223    CONTINUE
C     mark the corner cell
         KNG(IL-1,IM-1)=-1
C     along the vane bottom
         IF(JCAV.LT.KNCAV) THEN
         DO 225 JS=1,KLVANE
         INBSEG=INBSEG+1
         KL(INBSEG)=IL
         KM(INBSEG)=IM
         KDIR(INBSEG) =2
C
         KBCTYP(INBSEG) =IBCA
         KCOLOR(INBSEG) =IRED
C
         KNG(IL,IM) = INBSEG
         KNG(IL,IM-1)=-INBSEG
         IL=IL+1
C     set grid array in anode
         IMP1=IM+1
         DO 224 JMG=IMP1,KMMAX2
         KNG(IL,JMG)=1
  224    CONTINUE
  225    CONTINUE
         END IF
  226    CONTINUE
         END IF
C
CL                  2.3      exit line
         IF(IRIGHT.GT.0) THEN
         DO 231 JS=1,IRIGHT
         INBSEG=INBSEG+1
         KL(INBSEG)=IL
         KM(INBSEG)=IM
         KDIR(INBSEG) =2
C
         KBCTYP(INBSEG) =IBCA
         KCOLOR(INBSEG) =IRED
C
         KNG(IL,IM)   = INBSEG
         KNG(IL,IM-1) =-INBSEG
         IL=IL+1
C     set grid array in anode
         IMP1=IM+1
         DO 230 JMG=IMP1,KMMAX2
         KNG(IL,JMG)=1
  230    CONTINUE
  231    CONTINUE
         END IF
C
C-----------------------------------------------------------------------
CL              3.         right hand end
C
         IBLACK = 1
         IBCR   = KBCOUT
         ZRESR  = PROUT
         ICOLRH = IBLACK
         IF(IBCR.EQ.IBCA) ICOLRH=IRED
C
         IJSMAX=KMGAP+IMCATH
         DO 300 JS=1,IJSMAX
         INBSEG=INBSEG+1
         KL(INBSEG)=IL
         KM(INBSEG)=IM
         KDIR(INBSEG) =3
C
         KBCTYP(INBSEG) =IBCR
         KCOLOR(INBSEG) =ICOLRH
         PSURIC(1,INBSEG)=ZRESR
C
         KNG(IL,IM-1)   = INBSEG
         KNG(IL-1,IM-1) =-INBSEG
         IM=IM-1
  300    CONTINUE
C
C-----------------------------------------------------------------------
CL              4.         bottom
C
         INEND=ILMAX-KLCATH-1
C
CL                  4.1      end section
         IBLUE = -4
         IBCC  = 0
         ILEMIT=4
C
         IF(INEND.GT.0) THEN
         DO 410 JS=1,INEND
         INBSEG=INBSEG+1
         KL(INBSEG)=IL
         KM(INBSEG)=IM
         KDIR(INBSEG) =4
         KBCTYP(INBSEG) =KBCAX
         KCOLOR(INBSEG) =IBLACK
         PSURIC(1,INBSEG) =PRAX
C
         KNG(IL-1,IM-1) = INBSEG
         KNG(IL-1,IM)   =-INBSEG
         IL=IL-1
  410    CONTINUE
         END IF
C
CL                  4.2      rh end of cathode
         IF(IMCATH.GT.0) THEN
         DO 421 JS=1,IMCATH
         INBSEG=INBSEG+1
         KL(INBSEG)=IL
         KM(INBSEG)=IM
         KDIR(INBSEG) =1
C
         KBCTYP(INBSEG) =IBCC
         KCOLOR(INBSEG) =IBLUE
C
         KNG(IL-1,IM) = INBSEG
         KNG(IL,IM)   =-INBSEG
C     set grid array in cathode
         ILM2=IL-2
         DO 420 JLG=2,ILM2
         KNG(JLG,IM)=1
  420    CONTINUE
         IM=IM+1
  421    CONTINUE
         END IF
C
CL                  4.3      cathode top
         KNG(IL,IM)=-1
         DO 430 JS=1,KLCATH
         INBSEG=INBSEG+1
         KL(INBSEG)=IL
         KM(INBSEG)=IM
         KDIR(INBSEG) =4
C
         KBCTYP(INBSEG) =IBCC
         KCOLOR(INBSEG) =IBLUE
         IF(IL.LE.ILEMIT)KCOLOR(INBSEG)=IEBS(IBLUE)
C
         KNG(IL-1,IM-1) = INBSEG
         KNG(IL-1,IM)   =-INBSEG
         IL=IL-1
  430    CONTINUE
C
C-----------------------------------------------------------------------
CL              5.         left hand end
C
         ZRESL=PRIN
         IBCL=KBCIN
         DO 500 JS=1,KMGAP
         INBSEG=INBSEG+1
         KL(INBSEG)=IL
         KM(INBSEG)=IM
         KDIR(INBSEG) =1
C
         KBCTYP(INBSEG) =IBCL
         KCOLOR(INBSEG) =IBLACK
         PSURIC(1,INBSEG) =ZRESL
C
         KNG(IL-1,IM) = INBSEG
         KNG(IL,IM)   =-INBSEG
         IM=IM+1
  500    CONTINUE
C
C-----------------------------------------------------------------------
CL              6.         wrap around
C
         DO 601 J=2,3
         INBSEG=INBSEG+1
         KL(INBSEG)=KL(J)
         KM(INBSEG)=KM(J)
         KDIR(INBSEG)=KDIR(J)
C
         KBCTYP(INBSEG) =KBCTYP(J)
         KCOLOR(INBSEG) =KCOLOR(J)
         DO 600 J1=1,4
         PSURIC(J1,INBSEG) =PSURIC(J1,J)
  600    CONTINUE
  601    CONTINUE
         KNBSP2=INBSEG
C-----------------------------------------------------------------------
         END
C/ MODULE C3S6
C
         SUBROUTINE QSHARE(PRHO,KXDIM,KLMAX2,KMMAX2,
     +                     PX,PY,KNP,PC1,PC2,PCD0,PRZERO)
C
C 2.3  assign charge to mesh using CIC
C
C     .     Result is in units of superparticle charge
C-----------------------------------------------------------------------
       DIMENSION
     +   PRHO(KXDIM,*),
     +   PX(KNP),  PY(KNP)
C
C-----------------------------------------------------------------------
CL              1.         Initialise
C
         DO 100 JM=1,KMMAX2
         DO 100 JL=1,KLMAX2
  100    PRHO(JL,JM)=0.0
C
C-----------------------------------------------------------------------
CL              2.         Assign Charge
C
         IF(KNP.GE.1) THEN
         DO 200 JP=1,KNP
C     indices
         ILM=PX(JP)
         ILP=ILM+1
         IMM=PY(JP)
         IMP=IMM+1
C     offsets
         ZX=PX(JP)-ILM
         ZY=PY(JP)-IMM
         ZXM=1.0-ZX
         ZYM=1.0-ZY
C     assign
         PRHO(ILM,IMM)=PRHO(ILM,IMM)+ZXM*ZYM
         PRHO(ILP,IMM)=PRHO(ILP,IMM)+ZX *ZYM
         PRHO(ILM,IMP)=PRHO(ILM,IMP)+ZXM*ZY
         PRHO(ILP,IMP)=PRHO(ILP,IMP)+ZX *ZY
  200    CONTINUE
         END IF
C-----------------------------------------------------------------------
         END
C/ MODULE C2S4
C
         SUBROUTINE BEXTRP
C
C 2.4  extrapolate E and B for particle mover step
C
C---------------------------------------------------------------------
C       INCLUDE 'COMCON.inc'
C---------------------------------------------------------------------
CL                  C2.1     Physical Constants
       COMMON/COMCON/
     R   API   ,   BOLTZK,   CLIGHT,   ELCHAG,   ELMASS,   EMU0  ,
     R   EOVERM,   EPS0
C       INCLUDE 'COMSTT.inc'
C---------------------------------------------------------------------
CL                  C2.2     Physical State
       COMMON/COMSTT/
     R   B3    ,   BAV   ,   CD1   ,   CD2   ,   E1    ,   E2    ,
     R   P1    ,   P2    ,   Q1    ,   Q2    ,   REALTN,   TIMRUN
       DIMENSION
     R   B3(605,40),        BAV(605,40),       CD1(605,40),
     R   CD2(605,40),       E1(605,40),        E2(605,40),
     R   P1(20000),          P2(20000),          Q1(20000),
     R   Q2(20000)
C       INCLUDE 'COMDEV.inc'
C---------------------------------------------------------------------
CL                  C2.3     Device description
       COMMON/COMDEV/
     R   B3RHS ,   B3RHSD,   BAPLY ,   BAPLYD,   CAVEAM,   CAVEFR,
     R   CAVIC ,   CAVRES,   CAVTC ,   DEPTH ,   DEVHYT,   DEVLEN,
     R   DEVRAD,   EAPLYD,   EEMIT ,   EEMITD,   ENIT  ,   ENITD ,
     R   GAP   ,   RESAX ,   RESE  ,   RESN  ,   RESS  ,   RESW  ,
     R   RINNER,   SPACE ,   VOLTAG,   WIDTH ,
     I   LCATH ,   LCAV  ,   LLEFT ,   LWVANE,   MDEPTH,   MGAP  ,
     I   NBCAX ,   NBCCAV,   NBCE  ,   NBCN  ,   NBCS  ,   NBCW  ,
     I   NCAV  ,   NDEV
       DIMENSION
     R   CAVEAM(100),        CAVEFR(100),        CAVIC(4,100),
     R   CAVRES(100),        CAVTC(100),
     I   NBCCAV(100)
C       INCLUDE 'COMDIA.inc'
C---------------------------------------------------------------------
CL                  C2.4     Physical Diagnostics
       COMMON/COMDIA/
     R   B3POW ,   BOUT  ,   CAVPOY,   E1POW ,   E2POW ,   EJ1POW,
     R   EJ2POW,   EJENP ,   EJPOWM,   EJPOWP,   EJPWPN,   EKFLXI,
     R   EKFLXO,   ENEJ1 ,   ENEJ2 ,   ENEL1 ,   ENEL1O,   ENEL2 ,
     R   ENEL2O,   ENKIN ,   ENKINO,   ENMAG ,   ENMAGO,   ENPOYT,
     R   ENTOT ,   ENTOTO,   EOUT  ,   TOTM1 ,   TOTM2 ,   TPOYP ,
     I   LCAVEN,   LCAVST,   NPNEW ,   NPOLD
       DIMENSION
     R   BOUT(100),          CAVPOY(100),        EOUT(100),
     I   LCAVEN(100),        LCAVST(100)
C       INCLUDE 'COMNUM.inc'
C---------------------------------------------------------------------
CL                  C3.1     Numerical Parameters
       COMMON/COMNUM/
     R   C1    ,   C2    ,   CD0   ,   CURANT,   DT    ,   DX1   ,
     R   DX1DX2,   DX1OX2,   DX2   ,   DX2OX1,   ELPERP,   HLFDX1,
     R   HLFDX2,   TCACO ,
     I   LMAX  ,   LMAXP ,   LMAXP2,   MMAX  ,   MMAXP ,   MMAXP2,
     I   NEMIT ,   NP
C       INCLUDE 'COMSCA.inc'
C---------------------------------------------------------------------
CL                  C3.2     Scaling Factors
       COMMON/COMSCA/
     R   SCB3  ,   SCE1  ,   SCE2  ,   SCEMEN,   SCEPOW,   SCI1  ,
     R   SCI2  ,   SCIP  ,   SCKE  ,   SCKPOW,   SCP1  ,   SCP2  ,
     R   SCV1  ,   SCV2  ,   SCX1  ,   SCX2
C       INCLUDE 'COMHOK.inc'
C---------------------------------------------------------------------
CL                  C4.1     Housekeeping
       COMMON/COMHOK/
     R   TIMECP,   XPSMAX,   XPSMIN,   YPSMAX,   YPSMIN,
     I   N1MAX ,   N2MAX ,   NCASE ,   NGMAX ,   NOSEP ,   NPDUM ,
     I   NPMAX ,   NSRC  ,   NXDUM ,   NYDUM
       DIMENSION
     R   TIMECP(32)
C       INCLUDE 'COMGEO.inc'
C---------------------------------------------------------------------
CL                  C4.2     Device boundary data
       COMMON/COMGEO/
     R   ASCUR ,   CCTSRC,   EBEXT ,   ELSCUR,   ENSUR ,   EPOYNT,
     R   RHOC  ,   SURCHG,   SURIC ,
     I   LINDEX,   MINDEX,   NBCTYP,   NBDIM ,   NBSEG2,   NCOLOR,
     I   NDIRN ,   NG
       DIMENSION
     R   ASCUR(1500),        CCTSRC(1500),       EBEXT(2,1500),
     R   ELSCUR(1500),       ENSUR(1500),        EPOYNT(1500),
     R   RHOC(1500),         SURCHG(1500),       SURIC(4,1500),
     I   LINDEX(1500),       MINDEX(1500),       NBCTYP(1500),
     I   NCOLOR(1500),       NDIRN(1500),        NG(605,40)
C       INCLUDE 'COMOUT.inc'
C---------------------------------------------------------------------
CL                  C5.1     Output Variables
       COMMON/COMOUT/
     R   BCNMAX,   BCNMIN,   BCVMAX,   BCVMIN,   CUAMAX,   CUAMIN,
     R   CUEMAX,   CUEMIN,   ECVMAX,   ECVMIN,   TONS1 ,   TONS2 ,
     R   TONS3 ,   TONS4 ,   TONS5 ,   TONS6 ,   TONS7 ,
     I   NBCHT ,   NOPSEL,   NS1   ,   NS2   ,   NS3   ,   NS4   ,
     I   NS5   ,   NS6   ,   NS7
C
C---------------------------------------------------------------------
CL              1.         extrapolation using boundary tables
C
         ID=NDIRN(3)
         DO 140 JSEG=4,NBSEG2
         IL=LINDEX(JSEG)
         IM=MINDEX(JSEG)
         IDO=ID
         ID=NDIRN(JSEG)
         IF(NCOLOR(JSEG).LT.0)ZS=-1
C
CL                  1.1      west
         IF(ID.EQ.1) THEN
           BAV(IL-1,IM)=BAV(IL,IM)
           IF(IDO.NE.2)E1(IL-1,IM)=ZS*E1(IL,IM)
C
CL                  1.2      north
           ELSE IF(ID.EQ.2) THEN
           BAV(IL,IM)=BAV(IL,IM-1)
           IF(IDO.NE.3)E2(IL,IM)=ZS*E2(IL,IM-1)
C
CL                  1.3      east
           ELSE IF(ID.EQ.3) THEN
           BAV(IL,IM-1)=BAV(IL-1,IM-1)
           IF(IDO.NE.4)E1(IL,IM)  =ZS*E1(IL-1,IM)
C
CL                  1.4      south
           ELSE
           BAV(IL-1,IM-1)=BAV(IL-1,IM)
C          IF(IDO.NE.1)E2(IL,IM-1)  =ZS*E2(IL,IM)
         END IF
  140    CONTINUE
C---------------------------------------------------------------------
         END
C/ MODULE C2S7
C
         SUBROUTINE CURASS(PX1,PY1,PX2,PY2,PJX,PJY,KXDIM)
C
C 2.7  assign current from trajectory segment
C
C-----------------------------------------------------------------------
C. Input:  Trajectory start (PX1,PY1) and end (PX2,PY2)
C.
C. Output: X current contribution at N & S mesh points
C.         Y current contribution at E & W mesh points
C.
C. Note:   It is assumed that PX- and PY- are in units
C.         of cell widths, and that the cell addresses
C.         are given integer truncation of coordinates.
C.         In addition, it is assumed that points
C.         (PX1,PY1) and (PX2,PY2) lie in the same cell.
C.
C-----------------------------------------------------------------------
       DIMENSION   PJX(KXDIM,*),       PJY(KXDIM,*)
C
C-----------------------------------------------------------------------
CL              1.         location
C
C     midpoint
         ZX = (PX1+PX2)*0.5
         ZY = (PY1+PY2)*0.5
C     length
         ZVX = PX2-PX1
         ZVY = PY2-PY1
C     cell
         IL = ZX
         IM = ZY
C
C-----------------------------------------------------------------------
CL              2.         current assignment
C
         ZCN = (ZY-IM)*ZVX
         ZCS = ZVX-ZCN
         ZCE = (ZX-IL)*ZVY
         ZCW = ZVY-ZCE
C
         PJX(IL,IM+1) = PJX(IL,IM+1) + ZCN
         PJX(IL  ,IM) = PJX(IL,  IM) + ZCS
         PJY(IL+1,IM) = PJY(IL+1,IM) + ZCE
         PJY(IL  ,IM) = PJY(IL  ,IM) + ZCW
C-----------------------------------------------------------------------
         END
C/ MODULE C2S12
C
         SUBROUTINE BEAMIN(PX,PY,PPX,PPY,KNP,KNPMAX,PKEFLX,
     +   PJX,PJY,KXDIM,KLMAX2,KMMAX2,PC1,PDXODY,
     +   PMOMAV,PBCUR,PRIN,PROUT)
C
C 2.12 inject electron beam in [PRIN,PROUT] at z=0 plane
C
C-----------------------------------------------------------------------
C.  input:
C.                      KNP    number of particles
C.                      KNPMAX dimension of particle tables
C.                      KXDIM  x dimension of current arrays
C.                      KLMAX2 max x index of current arrays used
C.                      KMMAX2 max y index of current arrays used
C.                      PC1    c / (DX/DT)
C.                      PDXODY DX/DY
C.                      PMOMAV momentum per electron in beam (in mc's)
C.                      PBCUR  beam current (particle displacement units
C.                      PRIN   beam inner radius (cell index units)
C.                      PROUTR beam outer radius (cell index units)
C. output:
C.                      positions PX,PY and momenta PPx,PPY of newly inj
C.                      particles and their contributions to the total p
C.                      ke, PKEFLX, and to the mesh current PJX,PJY.
C.
C---------------------------------------------------------------------
       DIMENSION
     +   PX(KNP),  PY(KNP),  PPX(KNP), PPY(KNP), PJX(KXDIM,KMMAX2),
     +   PJY(KXDIM,KMMAX2)
C
C-----------------------------------------------------------------------
CL              1.         initialise beam details
C
         ZPSQ=PMOMAV**2
         ZGAM=SQRT(1.0+ZPSQ)
         ZVX=PC1/ZGAM*PMOMAV
         ZVY=0.0
         ZKE=ZPSQ/(ZGAM+1.0)
         ZBIN=2.0
         ZTOTCR=ZVX/2
         INP=KNP
C
C-----------------------------------------------------------------------
CL              2.         inject particles
C
  200    IF(ZTOTCR.LT.PBCUR) THEN
         INP=INP+1
         IF(INP.LT.KNPMAX) THEN
         ZVEL=ZVX*RANDS(0)
         PX(INP)=ZBIN+ZVEL
         PY(INP)=PRIN+(PROUT-PRIN)*RANDS(0)
         PPX(INP)=PMOMAV
         PPY(INP)=0.0
C
CL                  2.1      currents
         CALL CURASS(ZBIN,PY(INP),PX(INP),PY(INP),PJX,PJY,KXDIM)
         ZTOTCUR=ZTOTCUR+ZVEL
         ELSE
         CALLMESAGE('  ===PARTICLE TABLE OVERFLOW - RUN ABANDONED====')
         STOP
         END IF
         GO TO 200
         END IF
C
C-----------------------------------------------------------------------
CL              3.         energy diagnostics
C
         PKEFLX=(KNP-INP)*ZKE
         KNP=INP
C-----------------------------------------------------------------------
         END
C/ MODULE C3S4
C
         SUBROUTINE FRAMEL(PTIME,ISTEP,CHAR8)
C
C 3.4  Advance frame and label new frame
C
       DIMENSION   IDATA(11)
       CHARACTER   CHAR8*8
C
C-----------------------------------------------------------------------
CL              1.         new page
C
         CALL FRAME
         CALL CTRMAG(10)
C        CALL BACCOL(60)
C
C-----------------------------------------------------------------------
CL              2.         add descriptive footer to page
C
                 CALL LINCOL(4)
         CALL ITALIC(1)
         CALL PLACE(16,68)
         CALL TYPECS('Time = ')
         CALL TYPENF(PTIME,3)
         CALL TYPECS('  ns')
         CALL SPACE(6)
         CALL TYPECS('Step = ')
         CALL TYPENI(ISTEP)
         CALL SPACE(6)
         CALL TYPECS(CHAR8)
         CALL SPACE(6)
         CALL TYPECS('            ')
         CALL SPACE(6)
         CALL TYPECS('Frame ')
         CALL ENQCON(IDATA)
         IFN = IDATA(1)
         CALL TYPENI(IFN)
         CALL ITALIC(0)
         IFN = IFN + 1
C-----------------------------------------------------------------------
         END
C/ MODULE C3S9
C
         SUBROUTINE B3CON(K)
C
C 3.9  contour plot of b3
C
C-----------------------------------------------------------------------
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C       INCLUDE 'COMDDP.inc'
C--------------------------------------------------------------------
CL                  C1.9.    DEVELOPMENT AND DIAGNOSTIC PARAMETERS
       COMMON/COMDDP/
     I   MAXDUM,   MXDUMP,   NADUMP,   NCLASS,   NPDUMP,   NPOINT,
     I   NSUB,     NVDUMP,
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       LOGICAL
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       DIMENSION
     I   NADUMP(20),         NPDUMP(20),         NVDUMP(20),
     L   NLHEAD(9),          NLOMT1(50),         NLOMT2(50),
     L   NLOMT3(50)
C       INCLUDE 'COMCON.inc'
C---------------------------------------------------------------------
CL                  C2.1     Physical Constants
       COMMON/COMCON/
     R   API   ,   BOLTZK,   CLIGHT,   ELCHAG,   ELMASS,   EMU0  ,
     R   EOVERM,   EPS0
C       INCLUDE 'COMSTT.inc'
C---------------------------------------------------------------------
CL                  C2.2     Physical State
       COMMON/COMSTT/
     R   B3    ,   BAV   ,   CD1   ,   CD2   ,   E1    ,   E2    ,
     R   P1    ,   P2    ,   Q1    ,   Q2    ,   REALTN,   TIMRUN
       DIMENSION
     R   B3(605,40),        BAV(605,40),       CD1(605,40),
     R   CD2(605,40),       E1(605,40),        E2(605,40),
     R   P1(20000),          P2(20000),          Q1(20000),
     R   Q2(20000)
C       INCLUDE 'COMDEV.inc'
C---------------------------------------------------------------------
CL                  C2.3     Device description
       COMMON/COMDEV/
     R   B3RHS ,   B3RHSD,   BAPLY ,   BAPLYD,   CAVEAM,   CAVEFR,
     R   CAVIC ,   CAVRES,   CAVTC ,   DEPTH ,   DEVHYT,   DEVLEN,
     R   DEVRAD,   EAPLYD,   EEMIT ,   EEMITD,   ENIT  ,   ENITD ,
     R   GAP   ,   RESAX ,   RESE  ,   RESN  ,   RESS  ,   RESW  ,
     R   RINNER,   SPACE ,   VOLTAG,   WIDTH ,
     I   LCATH ,   LCAV  ,   LLEFT ,   LWVANE,   MDEPTH,   MGAP  ,
     I   NBCAX ,   NBCCAV,   NBCE  ,   NBCN  ,   NBCS  ,   NBCW  ,
     I   NCAV  ,   NDEV
       DIMENSION
     R   CAVEAM(100),        CAVEFR(100),        CAVIC(4,100),
     R   CAVRES(100),        CAVTC(100),
     I   NBCCAV(100)
C       INCLUDE 'COMDIA.inc'
C---------------------------------------------------------------------
CL                  C2.4     Physical Diagnostics
       COMMON/COMDIA/
     R   B3POW ,   BOUT  ,   CAVPOY,   E1POW ,   E2POW ,   EJ1POW,
     R   EJ2POW,   EJENP ,   EJPOWM,   EJPOWP,   EJPWPN,   EKFLXI,
     R   EKFLXO,   ENEJ1 ,   ENEJ2 ,   ENEL1 ,   ENEL1O,   ENEL2 ,
     R   ENEL2O,   ENKIN ,   ENKINO,   ENMAG ,   ENMAGO,   ENPOYT,
     R   ENTOT ,   ENTOTO,   EOUT  ,   TOTM1 ,   TOTM2 ,   TPOYP ,
     I   LCAVEN,   LCAVST,   NPNEW ,   NPOLD
       DIMENSION
     R   BOUT(100),          CAVPOY(100),        EOUT(100),
     I   LCAVEN(100),        LCAVST(100)
C       INCLUDE 'COMNUM.inc'
C---------------------------------------------------------------------
CL                  C3.1     Numerical Parameters
       COMMON/COMNUM/
     R   C1    ,   C2    ,   CD0   ,   CURANT,   DT    ,   DX1   ,
     R   DX1DX2,   DX1OX2,   DX2   ,   DX2OX1,   ELPERP,   HLFDX1,
     R   HLFDX2,   TCACO ,
     I   LMAX  ,   LMAXP ,   LMAXP2,   MMAX  ,   MMAXP ,   MMAXP2,
     I   NEMIT ,   NP
C       INCLUDE 'COMSCA.inc'
C---------------------------------------------------------------------
CL                  C3.2     Scaling Factors
       COMMON/COMSCA/
     R   SCB3  ,   SCE1  ,   SCE2  ,   SCEMEN,   SCEPOW,   SCI1  ,
     R   SCI2  ,   SCIP  ,   SCKE  ,   SCKPOW,   SCP1  ,   SCP2  ,
     R   SCV1  ,   SCV2  ,   SCX1  ,   SCX2
C       INCLUDE 'COMHOK.inc'
C---------------------------------------------------------------------
CL                  C4.1     Housekeeping
       COMMON/COMHOK/
     R   TIMECP,   XPSMAX,   XPSMIN,   YPSMAX,   YPSMIN,
     I   N1MAX ,   N2MAX ,   NCASE ,   NGMAX ,   NOSEP ,   NPDUM ,
     I   NPMAX ,   NSRC  ,   NXDUM ,   NYDUM
       DIMENSION
     R   TIMECP(32)
C       INCLUDE 'COMGEO.inc'
C---------------------------------------------------------------------
CL                  C4.2     Device boundary data
       COMMON/COMGEO/
     R   ASCUR ,   CCTSRC,   EBEXT ,   ELSCUR,   ENSUR ,   EPOYNT,
     R   RHOC  ,   SURCHG,   SURIC ,
     I   LINDEX,   MINDEX,   NBCTYP,   NBDIM ,   NBSEG2,   NCOLOR,
     I   NDIRN ,   NG
       DIMENSION
     R   ASCUR(1500),        CCTSRC(1500),       EBEXT(2,1500),
     R   ELSCUR(1500),       ENSUR(1500),        EPOYNT(1500),
     R   RHOC(1500),         SURCHG(1500),       SURIC(4,1500),
     I   LINDEX(1500),       MINDEX(1500),       NBCTYP(1500),
     I   NCOLOR(1500),       NDIRN(1500),        NG(605,40)
C       INCLUDE 'COMOUT.inc'
C---------------------------------------------------------------------
CL                  C5.1     Output Variables
       COMMON/COMOUT/
     R   BCNMAX,   BCNMIN,   BCVMAX,   BCVMIN,   CUAMAX,   CUAMIN,
     R   CUEMAX,   CUEMIN,   ECVMAX,   ECVMIN,   TONS1 ,   TONS2 ,
     R   TONS3 ,   TONS4 ,   TONS5 ,   TONS6 ,   TONS7 ,
     I   NBCHT ,   NOPSEL,   NS1   ,   NS2   ,   NS3   ,   NS4   ,
     I   NS5   ,   NS6   ,   NS7
C
         DIMENSION PCONHT(12),ZBX(1024) ,ZBY(1024)
C
C-----------------------------------------------------------------------
         DATA        ICLASS,   ISUB/3,   9/
                                       CALL EXPERT(ICLASS,ISUB,1)
C  Statement added to use array and avoid compile warning
         PCONHT(1)=0.0
C
         IF(NLOMT3(ISUB)) RETURN
C
C-----------------------------------------------------------------------
CL              1.         set plot mappings
C
C
CL                  1.1      set pspace
C     adjust plot size to overlap line graphs in x
C     and have right size after collaging
C     it is assumed collaging reduces vertical by 2
C     unless the y pspace max exceeds 1,in which
C     case the vertical scaling is set to unity
         ZDX=(XPSMAX-XPSMIN)/(LMAX-1)
         ZXP1=XPSMIN-ZDX
         ZXP2=XPSMAX+ZDX
C
         ZDY=(YPSMAX-YPSMIN)/(MMAX-1)
         ZYSC=2*DEVHYT/DEVLEN
         ZYP1=(YPSMIN-ZDY)*ZYSC
         ZYP2=(YPSMAX+ZDY)*ZYSC
  10     IF(ZYP2.LT.1) GOTO 11
         ZYSC=ZYSC/2
         ZYP1=(YPSMIN-ZDY)*ZYSC
         ZYP2=(YPSMAX+ZDY)*ZYSC
         GOTO 10
  11     CONTINUE
         ZYSH=(YPSMAX+YPSMIN-ZYP1-ZYP2)*0.5
         ZYP1=ZYP1+ZYSH
         ZYP2=ZYP2+ZYSH
         CALL PSPACE(ZXP1,ZXP2,ZYP1,ZYP2)
C
CL                  1.2      set mapping
         ZXL=1.
         ZXU=LMAXP2
         ZYL=1.
         ZYU=MMAXP2
         CALL MAP(ZXL,ZXU,ZYL,ZYU)
         CALL LINCOL(4)
         CALL FULL
C
C-----------------------------------------------------------------------
CL              2.         label the plot
C
         IF(K.EQ.1) THEN
         CALL CTRFNT(14)
C        CALL BACCOL(60)
         CALL LINCOL(4)
         CALL CTRMAG(20)
         CALL PLACE(7,1)
         CALL TYPECS('B3 contours')
         CALL CTRMAG(10)
         CALL PLACE(14,5)
         CALL TYPECS(CHLAB1)
         CALL PLACE(14,7)
         CALL TYPECS('time:')
         CALL TYPECS(CHRTIM)
         CALL TYPECS('     date:')
         CALL TYPECS(CHRDAT)
         CALL CTRMAG(10)
         CALL PLACE(89,3)
         CALL TYPECS('            ')
         CALL PLACE(89,5)
         CALL TYPECS('            ')
         CALL PLACE(89,7)
         CALL TYPECS('            ')
         CALL ITALIC(0)
         CALL FRAME
C
C-----------------------------------------------------------------------
CL              3.         draw colour scale
C  for 50 element colour scale
C
         CALL PSPACE(ZXP2,0.98,YPSMIN,YPSMAX)
         CALL MAP(0.0,2.5,-3.0,54.0)
C
         CALL CTRMAG(14)
         DO 300 J=0,50
         CALL LINCOL(J+9)
         CALL FILCOL(J+9)
  300    CALL BOX(0.3,1.,FLOAT(J),FLOAT(J+1))
         CALL PLOTNF(0.75,-2.5,BCNMIN,3)
         CALL PLOTNF(0.75,53.5,BCNMAX,3)
C
         CALL FRAME
C  for 8 element colour scale
C
         CALL COULST(1)
         CALL PSPACE(ZXP2,0.98,YPSMIN,YPSMAX)
         CALL MAP(0.0,2.5,-2.0,13.0)
C
         CALL CTRMAG(14)
         DO 350 J=1,8
         CALL LINCOL(J+7)
         CALL FILCOL(J+7)
  350    CALL BOX(0.3,1.,FLOAT(J),FLOAT(J+1))
         CALL PLOTNF(0.75,-1.5,BCNMIN,3)
         CALL PLOTNF(0.75,12.0,BCNMAX,3)
C
         CALL FRAME
         CALL COULST(0)
         CALL PSPACE(ZXP1,ZXP2,ZYP1,ZYP2)
         CALL MAP(ZXL,ZXU,ZYL,ZYU)
         CALL FILCOL(0)
         CALL CTRFNT(1)
         CALL CTRMAG(10)
C
C-----------------------------------------------------------------------
CL              4.         draw electrodes
C
         CALL BORDER
         CALL BOX(ZXL+1,ZXU-1,ZYL+1,ZYU-1)
C
CL                  4.1      Shade the anode
         ZANG = 90.0
         ISEP = NOSEP
         ZTOR = 1.7453292E-2
         CALL THICK(1)
C
C     load shading arrays
         ZBX(1) = ZXU
         ZBY(1) = ZYU
         ZBX(2) = ZXL
         ZBY(2) = ZYU
         ZBX(3) = ZXL
         ZBY(3) = MINDEX(2)
         IDIRO  = NDIRN(2)
C
         ISIDES=3
         ICOLOR=IEBS(NCOLOR(2))
         CALL LINCOL(ICOLOR)
         IS=1
C
  410    IS=IS+1
         IF(NDIRN(IS).NE.IDIRO) THEN
           IDIRO=NDIRN(IS)
           ISIDES=ISIDES+1
           ZBX(ISIDES) = LINDEX(IS)
           ZBY(ISIDES) = MINDEX(IS)
         END IF
         IF(IEBS(NCOLOR(IS)).EQ.ICOLOR) GO TO 410
C
         ISIDES=ISIDES+1
         ZBX(ISIDES) = ZXU
         ZBY(ISIDES) = ZBY(ISIDES-1)
         ISIDES=ISIDES+1
         ZBX(ISIDES) = ZXU
         ZBY(ISIDES) = ZYU
C
C     FLOOD FILL
         CALL FILCOL(ICOLOR)
         CALL PTJOIN(ZBX,ZBY,1,ISIDES,-1)
C
C
CL                  4.2      Shade the cathode
         ZANG = 0.0
         ISEP = NOSEP/2
         ZTOR = 1.7453292E-2
         ICOLOR=4
         IFLCOL=6
  420    IS=IS+1
         IF(IEBS(NCOLOR(IS)).NE.ICOLOR) GO TO 420
C
C     load shading arrays
         ZBX(1) = ZXL
         ZBY(1) = ZYL
         ZBX(2) = LINDEX(IS)
         ZBY(2) = ZYL
         ZBX(3) = LINDEX(IS)
         ZBY(3) = MINDEX(IS)
         IDIRO  = NDIRN(IS)
C
         ISIDES=3
         CALL LINCOL(ICOLOR)
C
  421    IS=IS+1
         IF(NDIRN(IS).NE.IDIRO) THEN
           IDIRO=NDIRN(IS)
           ISIDES=ISIDES+1
           ZBX(ISIDES) = LINDEX(IS)
           ZBY(ISIDES) = MINDEX(IS)
         END IF
         IF(IEBS(NCOLOR(IS)).EQ.ICOLOR) GO TO 421
C
         ISIDES=ISIDES+1
         ZBX(ISIDES) = ZXL
         ZBY(ISIDES) = ZBY(ISIDES-1)
         ISIDES=ISIDES+1
         ZBX(ISIDES) = ZXL
         ZBY(ISIDES) = ZYL
C
C     FLOOD FILL
         CALL FILCOL(IFLCOL)
         CALL PTJOIN(ZBX,ZBY,1,ISIDES,-1)
C
CL                  4.3      add tick marks every cm
         CALL LINCOL(5)
C
C     Along x direction
         ZXDIV=(LMAX-1)/100.0/DEVLEN
         IT=0
         ZX=2
  430    ZYTOP=ZYL+0.35
         ZYBOT=ZYU-0.35
         IF((IT/5)*5.EQ.IT)THEN
         ZYTOP=ZYL+0.75
         ZYBOT=ZYU-0.75
         END IF
         CALL POSITN(ZX,ZYL)
         CALL JOIN(ZX,ZYTOP)
         CALL POSITN(ZX,ZYU)
         CALL JOIN(ZX,ZYBOT)
         ZX=ZX+ZXDIV
         IT=IT+1
         IF(ZX.LT.LMAXP2) GO TO 430
C     Along y direction
         ZYDIV=(MMAX-1)/100.0/DEVHYT
         IT=0
         ZY=2
  431    ZXTOP=ZXL+0.35
         ZXBOT=ZXU-0.35
         IF((IT/5)*5.EQ.IT)THEN
         ZXTOP=ZXL+0.75
         ZXBOT=ZXU-0.75
         END IF
         CALL POSITN(ZXL,ZY)
         CALL JOIN(ZXTOP,ZY)
         CALL POSITN(ZXU,ZY)
         CALL JOIN(ZXBOT,ZY)
         ZY=ZY+ZYDIV
         IT=IT+1
         IF(ZY.LT.MMAXP2) GO TO 431
C
         CALL PSPACE(XPSMIN,XPSMAX,YPSMIN,YPSMAX)
         CALL FRAME
C
C-----------------------------------------------------------------------
C     4.         PLOT THE COLOUR CONTOURS FOR PAINT JET
C
         ELSE IF(K.EQ.2) THEN
         DO 401 M=1,MMAXP
         ZBYL=M
         ZBYU=M+1
         ZBXL=1
         DO 401 L=1,LMAXP
         IF(NG(L,M).GT.0) THEN
         ZBXL=L+1
         GOTO 401
         ENDIF
         LCOLOR=(B3(L,M)*SCB3-BCNMIN)/(BCNMAX-BCNMIN)*8+8
         LCOLOR=MIN(MAX(LCOLOR,8),15)
         IF(L+1.GT.LMAXP.OR.NG(L+1,M).GT.0) GOTO 400
         LCOLPL=(B3(L+1,M)*SCB3-BCNMIN)/(BCNMAX-BCNMIN)*8+8
         LCOLPL=MIN(MAX(LCOLPL,8),15)
         IF(LCOLPL.EQ.LCOLOR) GOTO 401
  400    ZBXU=L+1
C
         CALL LINCOL(LCOLOR)
         CALL FILCOL(LCOLOR)
         CALL BOX(ZBXL,ZBXU,ZBYL,ZBYU)
         ZBXL=ZBXU
C
  401    CONTINUE
C
C-----------------------------------------------------------------------
CL              5.         PLOT COLOURS FOR HTS
C
         ELSE IF(K.EQ.3) THEN
         DO 501 M=1,MMAXP
         ZBYL=M
         ZBYU=M+1
         ZBXL=1
         DO 501 L=1,LMAXP
         IF(NG(L,M).GT.0) THEN
         ZBXL=L+1
         GOTO 501
         ENDIF
         LCOLOR=(B3(L,M)*SCB3-BCNMIN)/(BCNMAX-BCNMIN)*50+9
         LCOLOR=MIN(MAX(LCOLOR,9),59)
         IF(L+1.GT.LMAXP.OR.NG(L+1,M).GT.0) GOTO 500
         LCOLPL=(B3(L+1,M)*SCB3-BCNMIN)/(BCNMAX-BCNMIN)*50+9
         LCOLPL=MIN(MAX(LCOLPL,9),59)
         IF(LCOLPL.EQ.LCOLOR) GOTO 501
  500    ZBXU=L+1
C
         CALL LINCOL(LCOLOR)
         CALL FILCOL(LCOLOR)
         CALL BOX(ZBXL,ZBXU,ZBYL,ZBYU)
         ZBXL=ZBXU
C
  501    CONTINUE
         END IF
C-----------------------------------------------------------------------
         CALL FILCOL(0)
         CALL PICNOW
         CALL PSPACE(XPSMIN,XPSMAX,YPSMIN,YPSMAX)
C
         END
C/ MODULE C3S11
C
         SUBROUTINE GHINIT
C
C 3.3  Initialise graphical output
C
C-----------------------------------------------------------------------
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C       INCLUDE 'COMDDP.inc'
C--------------------------------------------------------------------
CL                  C1.9.    DEVELOPMENT AND DIAGNOSTIC PARAMETERS
       COMMON/COMDDP/
     I   MAXDUM,   MXDUMP,   NADUMP,   NCLASS,   NPDUMP,   NPOINT,
     I   NSUB,     NVDUMP,
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       LOGICAL
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       DIMENSION
     I   NADUMP(20),         NPDUMP(20),         NVDUMP(20),
     L   NLHEAD(9),          NLOMT1(50),         NLOMT2(50),
     L   NLOMT3(50)
C       INCLUDE 'COMCON.inc'
C---------------------------------------------------------------------
CL                  C2.1     Physical Constants
       COMMON/COMCON/
     R   API   ,   BOLTZK,   CLIGHT,   ELCHAG,   ELMASS,   EMU0  ,
     R   EOVERM,   EPS0
C       INCLUDE 'COMSTT.inc'
C---------------------------------------------------------------------
CL                  C2.2     Physical State
       COMMON/COMSTT/
     R   B3    ,   BAV   ,   CD1   ,   CD2   ,   E1    ,   E2    ,
     R   P1    ,   P2    ,   Q1    ,   Q2    ,   REALTN,   TIMRUN
       DIMENSION
     R   B3(605,40),        BAV(605,40),       CD1(605,40),
     R   CD2(605,40),       E1(605,40),        E2(605,40),
     R   P1(20000),          P2(20000),          Q1(20000),
     R   Q2(20000)
C       INCLUDE 'COMDEV.inc'
C---------------------------------------------------------------------
CL                  C2.3     Device description
       COMMON/COMDEV/
     R   B3RHS ,   B3RHSD,   BAPLY ,   BAPLYD,   CAVEAM,   CAVEFR,
     R   CAVIC ,   CAVRES,   CAVTC ,   DEPTH ,   DEVHYT,   DEVLEN,
     R   DEVRAD,   EAPLYD,   EEMIT ,   EEMITD,   ENIT  ,   ENITD ,
     R   GAP   ,   RESAX ,   RESE  ,   RESN  ,   RESS  ,   RESW  ,
     R   RINNER,   SPACE ,   VOLTAG,   WIDTH ,
     I   LCATH ,   LCAV  ,   LLEFT ,   LWVANE,   MDEPTH,   MGAP  ,
     I   NBCAX ,   NBCCAV,   NBCE  ,   NBCN  ,   NBCS  ,   NBCW  ,
     I   NCAV  ,   NDEV
       DIMENSION
     R   CAVEAM(100),        CAVEFR(100),        CAVIC(4,100),
     R   CAVRES(100),        CAVTC(100),
     I   NBCCAV(100)
C       INCLUDE 'COMDIA.inc'
C---------------------------------------------------------------------
CL                  C2.4     Physical Diagnostics
       COMMON/COMDIA/
     R   B3POW ,   BOUT  ,   CAVPOY,   E1POW ,   E2POW ,   EJ1POW,
     R   EJ2POW,   EJENP ,   EJPOWM,   EJPOWP,   EJPWPN,   EKFLXI,
     R   EKFLXO,   ENEJ1 ,   ENEJ2 ,   ENEL1 ,   ENEL1O,   ENEL2 ,
     R   ENEL2O,   ENKIN ,   ENKINO,   ENMAG ,   ENMAGO,   ENPOYT,
     R   ENTOT ,   ENTOTO,   EOUT  ,   TOTM1 ,   TOTM2 ,   TPOYP ,
     I   LCAVEN,   LCAVST,   NPNEW ,   NPOLD
       DIMENSION
     R   BOUT(100),          CAVPOY(100),        EOUT(100),
     I   LCAVEN(100),        LCAVST(100)
C       INCLUDE 'COMNUM.inc'
C---------------------------------------------------------------------
CL                  C3.1     Numerical Parameters
       COMMON/COMNUM/
     R   C1    ,   C2    ,   CD0   ,   CURANT,   DT    ,   DX1   ,
     R   DX1DX2,   DX1OX2,   DX2   ,   DX2OX1,   ELPERP,   HLFDX1,
     R   HLFDX2,   TCACO ,
     I   LMAX  ,   LMAXP ,   LMAXP2,   MMAX  ,   MMAXP ,   MMAXP2,
     I   NEMIT ,   NP
C       INCLUDE 'COMSCA.inc'
C---------------------------------------------------------------------
CL                  C3.2     Scaling Factors
       COMMON/COMSCA/
     R   SCB3  ,   SCE1  ,   SCE2  ,   SCEMEN,   SCEPOW,   SCI1  ,
     R   SCI2  ,   SCIP  ,   SCKE  ,   SCKPOW,   SCP1  ,   SCP2  ,
     R   SCV1  ,   SCV2  ,   SCX1  ,   SCX2
C       INCLUDE 'COMHOK.inc'
C---------------------------------------------------------------------
CL                  C4.1     Housekeeping
       COMMON/COMHOK/
     R   TIMECP,   XPSMAX,   XPSMIN,   YPSMAX,   YPSMIN,
     I   N1MAX ,   N2MAX ,   NCASE ,   NGMAX ,   NOSEP ,   NPDUM ,
     I   NPMAX ,   NSRC  ,   NXDUM ,   NYDUM
       DIMENSION
     R   TIMECP(32)
C       INCLUDE 'COMGEO.inc'
C---------------------------------------------------------------------
CL                  C4.2     Device boundary data
       COMMON/COMGEO/
     R   ASCUR ,   CCTSRC,   EBEXT ,   ELSCUR,   ENSUR ,   EPOYNT,
     R   RHOC  ,   SURCHG,   SURIC ,
     I   LINDEX,   MINDEX,   NBCTYP,   NBDIM ,   NBSEG2,   NCOLOR,
     I   NDIRN ,   NG
       DIMENSION
     R   ASCUR(1500),        CCTSRC(1500),       EBEXT(2,1500),
     R   ELSCUR(1500),       ENSUR(1500),        EPOYNT(1500),
     R   RHOC(1500),         SURCHG(1500),       SURIC(4,1500),
     I   LINDEX(1500),       MINDEX(1500),       NBCTYP(1500),
     I   NCOLOR(1500),       NDIRN(1500),        NG(605,40)
C       INCLUDE 'COMOUT.inc'
C---------------------------------------------------------------------
CL                  C5.1     Output Variables
       COMMON/COMOUT/
     R   BCNMAX,   BCNMIN,   BCVMAX,   BCVMIN,   CUAMAX,   CUAMIN,
     R   CUEMAX,   CUEMIN,   ECVMAX,   ECVMIN,   TONS1 ,   TONS2 ,
     R   TONS3 ,   TONS4 ,   TONS5 ,   TONS6 ,   TONS7 ,
     I   NBCHT ,   NOPSEL,   NS1   ,   NS2   ,   NS3   ,   NS4   ,
     I   NS5   ,   NS6   ,   NS7
C
      DIMENSION  HUE(9),SAT(9),VALUE(9)
      DATA HUE/0.0,0.9,0.8,0.6,0.5,0.4,0.4,0.33,0.2/
      DATA SAT/0.93,0.86,0.79,1.0,1.0,0.71,0.79,1.0,0.64/
      DATA VALUE/0.86,0.79,0.64,1.0,1.0,1.0,0.93,1.0,1.0/
C-----------------------------------------------------------------------
         DATA        ICLASS,   ISUB/3,  11/
                                       CALL EXPERT(ICLASS,ISUB,1)
         IF(NLOMT3(ISUB)) RETURN
C
C-----------------------------------------------------------------------
CL              1.         filename and plot spaces
C
C     file name
         CALL FILNAM(CHLAB6)
C     frame limit
         CALL GPSTOP(NGMAX)
C     default colours
         CALL LINCOL(4)
         CALL COULST(0)
C
C     plot spaces
         CALL CSPACE(0.0,1.0,0.0,1.0)
         CALL PSPACE(XPSMIN,XPSMAX,YPSMIN,YPSMAX)
         CALL PAPER(1)
C
C-----------------------------------------------------------------------
CL              2.         header page
C
C
CL                  2.1      new run labelling
         CALL CTRMAG(20)
         CALL PLACE(1,3)
         CALL TYPECS(CHLAB6)
         CALL CRLNFD
         CALL CRLNFD
         CALL TYPECS(CHLAB1)
         CALL CRLNFD
         CALL CRLNFD
         CALL TYPECS(CHLAB2)
         CALL CRLNFD
         CALL CRLNFD
         CALL TYPECS(CHLAB3)
         CALL CRLNFD
         CALL CRLNFD
         CALL TYPECS(CHLAB4)
         CALL CRLNFD
         CALL CRLNFD
         CALL TYPECS('Date:  ')
         CALL TYPECS(CHRDAT)
         CALL CRLNFD
         CALL CRLNFD
         CALL TYPECS('Time:  ')
         CALL TYPECS(CHRTIM)
         CALL CRLNFD
         CALL CRLNFD
         CALL TYPECS('Ref:   ')
         CALL TYPECS(CHREFN)
         CALL CRLNFD
C
CL                  2.2      continuation run labelling
         IF(NLRES) THEN
         CALL CRLNFD
         CALL TYPECS('CONTINUATION RUN FROM:')
         CALL CRLNFD
         CALL CRLNFD
         CALL TYPECS(' old run date: ')
         CALL TYPECS(CHDATO)
         CALL CRLNFD
         CALL CRLNFD
         CALL TYPECS(' old run time: ')
         CALL TYPECS(CHTIMO)
         END IF
         CALL FRAME
C
C-----------------------------------------------------------------------
         END
C/ MODULE C3S14
C
         SUBROUTINE B3CAVP(K)
C
C 3.14 plot magnetic field along cavity tops
C
C-----------------------------------------------------------------------
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C       INCLUDE 'COMDDP.inc'
C--------------------------------------------------------------------
CL                  C1.9.    DEVELOPMENT AND DIAGNOSTIC PARAMETERS
       COMMON/COMDDP/
     I   MAXDUM,   MXDUMP,   NADUMP,   NCLASS,   NPDUMP,   NPOINT,
     I   NSUB,     NVDUMP,
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       LOGICAL
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       DIMENSION
     I   NADUMP(20),         NPDUMP(20),         NVDUMP(20),
     L   NLHEAD(9),          NLOMT1(50),         NLOMT2(50),
     L   NLOMT3(50)
C       INCLUDE 'COMCON.inc'
C---------------------------------------------------------------------
CL                  C2.1     Physical Constants
       COMMON/COMCON/
     R   API   ,   BOLTZK,   CLIGHT,   ELCHAG,   ELMASS,   EMU0  ,
     R   EOVERM,   EPS0
C       INCLUDE 'COMSTT.inc'
C---------------------------------------------------------------------
CL                  C2.2     Physical State
       COMMON/COMSTT/
     R   B3    ,   BAV   ,   CD1   ,   CD2   ,   E1    ,   E2    ,
     R   P1    ,   P2    ,   Q1    ,   Q2    ,   REALTN,   TIMRUN
       DIMENSION
     R   B3(605,40),        BAV(605,40),       CD1(605,40),
     R   CD2(605,40),       E1(605,40),        E2(605,40),
     R   P1(20000),          P2(20000),          Q1(20000),
     R   Q2(20000)
C       INCLUDE 'COMDEV.inc'
C---------------------------------------------------------------------
CL                  C2.3     Device description
       COMMON/COMDEV/
     R   B3RHS ,   B3RHSD,   BAPLY ,   BAPLYD,   CAVEAM,   CAVEFR,
     R   CAVIC ,   CAVRES,   CAVTC ,   DEPTH ,   DEVHYT,   DEVLEN,
     R   DEVRAD,   EAPLYD,   EEMIT ,   EEMITD,   ENIT  ,   ENITD ,
     R   GAP   ,   RESAX ,   RESE  ,   RESN  ,   RESS  ,   RESW  ,
     R   RINNER,   SPACE ,   VOLTAG,   WIDTH ,
     I   LCATH ,   LCAV  ,   LLEFT ,   LWVANE,   MDEPTH,   MGAP  ,
     I   NBCAX ,   NBCCAV,   NBCE  ,   NBCN  ,   NBCS  ,   NBCW  ,
     I   NCAV  ,   NDEV
       DIMENSION
     R   CAVEAM(100),        CAVEFR(100),        CAVIC(4,100),
     R   CAVRES(100),        CAVTC(100),
     I   NBCCAV(100)
C       INCLUDE 'COMDIA.inc'
C---------------------------------------------------------------------
CL                  C2.4     Physical Diagnostics
       COMMON/COMDIA/
     R   B3POW ,   BOUT  ,   CAVPOY,   E1POW ,   E2POW ,   EJ1POW,
     R   EJ2POW,   EJENP ,   EJPOWM,   EJPOWP,   EJPWPN,   EKFLXI,
     R   EKFLXO,   ENEJ1 ,   ENEJ2 ,   ENEL1 ,   ENEL1O,   ENEL2 ,
     R   ENEL2O,   ENKIN ,   ENKINO,   ENMAG ,   ENMAGO,   ENPOYT,
     R   ENTOT ,   ENTOTO,   EOUT  ,   TOTM1 ,   TOTM2 ,   TPOYP ,
     I   LCAVEN,   LCAVST,   NPNEW ,   NPOLD
       DIMENSION
     R   BOUT(100),          CAVPOY(100),        EOUT(100),
     I   LCAVEN(100),        LCAVST(100)
C       INCLUDE 'COMNUM.inc'
C---------------------------------------------------------------------
CL                  C3.1     Numerical Parameters
       COMMON/COMNUM/
     R   C1    ,   C2    ,   CD0   ,   CURANT,   DT    ,   DX1   ,
     R   DX1DX2,   DX1OX2,   DX2   ,   DX2OX1,   ELPERP,   HLFDX1,
     R   HLFDX2,   TCACO ,
     I   LMAX  ,   LMAXP ,   LMAXP2,   MMAX  ,   MMAXP ,   MMAXP2,
     I   NEMIT ,   NP
C       INCLUDE 'COMSCA.inc'
C---------------------------------------------------------------------
CL                  C3.2     Scaling Factors
       COMMON/COMSCA/
     R   SCB3  ,   SCE1  ,   SCE2  ,   SCEMEN,   SCEPOW,   SCI1  ,
     R   SCI2  ,   SCIP  ,   SCKE  ,   SCKPOW,   SCP1  ,   SCP2  ,
     R   SCV1  ,   SCV2  ,   SCX1  ,   SCX2
C       INCLUDE 'COMHOK.inc'
C---------------------------------------------------------------------
CL                  C4.1     Housekeeping
       COMMON/COMHOK/
     R   TIMECP,   XPSMAX,   XPSMIN,   YPSMAX,   YPSMIN,
     I   N1MAX ,   N2MAX ,   NCASE ,   NGMAX ,   NOSEP ,   NPDUM ,
     I   NPMAX ,   NSRC  ,   NXDUM ,   NYDUM
       DIMENSION
     R   TIMECP(32)
C       INCLUDE 'COMGEO.inc'
C---------------------------------------------------------------------
CL                  C4.2     Device boundary data
       COMMON/COMGEO/
     R   ASCUR ,   CCTSRC,   EBEXT ,   ELSCUR,   ENSUR ,   EPOYNT,
     R   RHOC  ,   SURCHG,   SURIC ,
     I   LINDEX,   MINDEX,   NBCTYP,   NBDIM ,   NBSEG2,   NCOLOR,
     I   NDIRN ,   NG
       DIMENSION
     R   ASCUR(1500),        CCTSRC(1500),       EBEXT(2,1500),
     R   ELSCUR(1500),       ENSUR(1500),        EPOYNT(1500),
     R   RHOC(1500),         SURCHG(1500),       SURIC(4,1500),
     I   LINDEX(1500),       MINDEX(1500),       NBCTYP(1500),
     I   NCOLOR(1500),       NDIRN(1500),        NG(605,40)
C       INCLUDE 'COMOUT.inc'
C---------------------------------------------------------------------
CL                  C5.1     Output Variables
       COMMON/COMOUT/
     R   BCNMAX,   BCNMIN,   BCVMAX,   BCVMIN,   CUAMAX,   CUAMIN,
     R   CUEMAX,   CUEMIN,   ECVMAX,   ECVMIN,   TONS1 ,   TONS2 ,
     R   TONS3 ,   TONS4 ,   TONS5 ,   TONS6 ,   TONS7 ,
     I   NBCHT ,   NOPSEL,   NS1   ,   NS2   ,   NS3   ,   NS4   ,
     I   NS5   ,   NS6   ,   NS7
C-----------------------------------------------------------------------
         DIMENSION
     +   ZX(512),ZY(512)
C
C-----------------------------------------------------------------------
CL              1.         initialise
C
C
CL                  1.1      set mapping
         ZXMIN=0
         ZXMAX=(LMAX-1)*DX1*100
         CALL MAP(ZXMIN,ZXMAX,BCVMIN,BCVMAX)
C
CL                  1.2      Plot labelling
         IF(K.EQ.1) THEN
C        CALL BACCOL(60)
         CALL LINCOL(4)
         CALL CTRMAG(20)
         CALL PLACE(7,1)
         CALL TYPECS('B3 along Cavity Tops')
         CALL CTRMAG(10)
         CALL PLACE(14,5)
         CALL TYPECS(CHLAB1)
         CALL PLACE(14,7)
         CALL TYPECS('time:')
         CALL TYPECS(CHRTIM)
         CALL TYPECS('     date:')
         CALL TYPECS(CHRDAT)
         CALL CTRFNT(1)
         CALL CTRMAG(10)
         CALL PLACE(89,3)
         CALL TYPECS('     ')
         CALL PLACE(89,5)
         CALL TYPECS('     ')
         CALL PLACE(89,7)
         CALL TYPECS('      ')
         CALL ITALIC(0)
         CALL FRAME
C
CL                  1.3      plot axes
         CALL LINCOL(4)
         CALL OKAXES(0,5)
         CALL BORDER
         CALL FRAME
C
C-----------------------------------------------------------------------
CL              2.         plot curve
C
C
         ELSE IF(K.EQ.2) THEN
         DO 200 JL=2,LMAX
         ZX(2*JL-3)=(JL-2)*DX1*100
         ZX(2*JL-2)=(JL-1)*DX1*100
         ZY(2*JL-3)=B3(JL,MMAX)*SCB3
         ZY(2*JL-2)=ZY(2*JL-3)
  200    CONTINUE
C       close ends for shading
         ZX(2*LMAX-1)=(LMAX-1)*DX1*100
         ZY(2*LMAX-1)=0.0
         ZX(2*LMAX)=0.0
         ZY(2*LMAX)=0.0
         CALL LINCOL(3)
         CALL FILCOL(3)
         CALL PTJOIN(ZX,ZY,1,LMAX*2,-1)
         END IF
C-----------------------------------------------------------------------
         CALL PICNOW
         CALL FILCOL(0)
C-----------------------------------------------------------------------
         END
C/ MODULE C3S15
C
         SUBROUTINE E1CAVP(K)
C
C 3.15 plot electric field along cavity bottoms
C
C-----------------------------------------------------------------------
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C       INCLUDE 'COMDDP.inc'
C--------------------------------------------------------------------
CL                  C1.9.    DEVELOPMENT AND DIAGNOSTIC PARAMETERS
       COMMON/COMDDP/
     I   MAXDUM,   MXDUMP,   NADUMP,   NCLASS,   NPDUMP,   NPOINT,
     I   NSUB,     NVDUMP,
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       LOGICAL
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       DIMENSION
     I   NADUMP(20),         NPDUMP(20),         NVDUMP(20),
     L   NLHEAD(9),          NLOMT1(50),         NLOMT2(50),
     L   NLOMT3(50)
C       INCLUDE 'COMCON.inc'
C---------------------------------------------------------------------
CL                  C2.1     Physical Constants
       COMMON/COMCON/
     R   API   ,   BOLTZK,   CLIGHT,   ELCHAG,   ELMASS,   EMU0  ,
     R   EOVERM,   EPS0
C       INCLUDE 'COMSTT.inc'
C---------------------------------------------------------------------
CL                  C2.2     Physical State
       COMMON/COMSTT/
     R   B3    ,   BAV   ,   CD1   ,   CD2   ,   E1    ,   E2    ,
     R   P1    ,   P2    ,   Q1    ,   Q2    ,   REALTN,   TIMRUN
       DIMENSION
     R   B3(605,40),        BAV(605,40),       CD1(605,40),
     R   CD2(605,40),       E1(605,40),        E2(605,40),
     R   P1(20000),          P2(20000),          Q1(20000),
     R   Q2(20000)
C       INCLUDE 'COMDEV.inc'
C---------------------------------------------------------------------
CL                  C2.3     Device description
       COMMON/COMDEV/
     R   B3RHS ,   B3RHSD,   BAPLY ,   BAPLYD,   CAVEAM,   CAVEFR,
     R   CAVIC ,   CAVRES,   CAVTC ,   DEPTH ,   DEVHYT,   DEVLEN,
     R   DEVRAD,   EAPLYD,   EEMIT ,   EEMITD,   ENIT  ,   ENITD ,
     R   GAP   ,   RESAX ,   RESE  ,   RESN  ,   RESS  ,   RESW  ,
     R   RINNER,   SPACE ,   VOLTAG,   WIDTH ,
     I   LCATH ,   LCAV  ,   LLEFT ,   LWVANE,   MDEPTH,   MGAP  ,
     I   NBCAX ,   NBCCAV,   NBCE  ,   NBCN  ,   NBCS  ,   NBCW  ,
     I   NCAV  ,   NDEV
       DIMENSION
     R   CAVEAM(100),        CAVEFR(100),        CAVIC(4,100),
     R   CAVRES(100),        CAVTC(100),
     I   NBCCAV(100)
C       INCLUDE 'COMDIA.inc'
C---------------------------------------------------------------------
CL                  C2.4     Physical Diagnostics
       COMMON/COMDIA/
     R   B3POW ,   BOUT  ,   CAVPOY,   E1POW ,   E2POW ,   EJ1POW,
     R   EJ2POW,   EJENP ,   EJPOWM,   EJPOWP,   EJPWPN,   EKFLXI,
     R   EKFLXO,   ENEJ1 ,   ENEJ2 ,   ENEL1 ,   ENEL1O,   ENEL2 ,
     R   ENEL2O,   ENKIN ,   ENKINO,   ENMAG ,   ENMAGO,   ENPOYT,
     R   ENTOT ,   ENTOTO,   EOUT  ,   TOTM1 ,   TOTM2 ,   TPOYP ,
     I   LCAVEN,   LCAVST,   NPNEW ,   NPOLD
       DIMENSION
     R   BOUT(100),          CAVPOY(100),        EOUT(100),
     I   LCAVEN(100),        LCAVST(100)
C       INCLUDE 'COMNUM.inc'
C---------------------------------------------------------------------
CL                  C3.1     Numerical Parameters
       COMMON/COMNUM/
     R   C1    ,   C2    ,   CD0   ,   CURANT,   DT    ,   DX1   ,
     R   DX1DX2,   DX1OX2,   DX2   ,   DX2OX1,   ELPERP,   HLFDX1,
     R   HLFDX2,   TCACO ,
     I   LMAX  ,   LMAXP ,   LMAXP2,   MMAX  ,   MMAXP ,   MMAXP2,
     I   NEMIT ,   NP
C       INCLUDE 'COMSCA.inc'
C---------------------------------------------------------------------
CL                  C3.2     Scaling Factors
       COMMON/COMSCA/
     R   SCB3  ,   SCE1  ,   SCE2  ,   SCEMEN,   SCEPOW,   SCI1  ,
     R   SCI2  ,   SCIP  ,   SCKE  ,   SCKPOW,   SCP1  ,   SCP2  ,
     R   SCV1  ,   SCV2  ,   SCX1  ,   SCX2
C       INCLUDE 'COMHOK.inc'
C---------------------------------------------------------------------
CL                  C4.1     Housekeeping
       COMMON/COMHOK/
     R   TIMECP,   XPSMAX,   XPSMIN,   YPSMAX,   YPSMIN,
     I   N1MAX ,   N2MAX ,   NCASE ,   NGMAX ,   NOSEP ,   NPDUM ,
     I   NPMAX ,   NSRC  ,   NXDUM ,   NYDUM
       DIMENSION
     R   TIMECP(32)
C       INCLUDE 'COMGEO.inc'
C---------------------------------------------------------------------
CL                  C4.2     Device boundary data
       COMMON/COMGEO/
     R   ASCUR ,   CCTSRC,   EBEXT ,   ELSCUR,   ENSUR ,   EPOYNT,
     R   RHOC  ,   SURCHG,   SURIC ,
     I   LINDEX,   MINDEX,   NBCTYP,   NBDIM ,   NBSEG2,   NCOLOR,
     I   NDIRN ,   NG
       DIMENSION
     R   ASCUR(1500),        CCTSRC(1500),       EBEXT(2,1500),
     R   ELSCUR(1500),       ENSUR(1500),        EPOYNT(1500),
     R   RHOC(1500),         SURCHG(1500),       SURIC(4,1500),
     I   LINDEX(1500),       MINDEX(1500),       NBCTYP(1500),
     I   NCOLOR(1500),       NDIRN(1500),        NG(605,40)
C       INCLUDE 'COMOUT.inc'
C---------------------------------------------------------------------
CL                  C5.1     Output Variables
       COMMON/COMOUT/
     R   BCNMAX,   BCNMIN,   BCVMAX,   BCVMIN,   CUAMAX,   CUAMIN,
     R   CUEMAX,   CUEMIN,   ECVMAX,   ECVMIN,   TONS1 ,   TONS2 ,
     R   TONS3 ,   TONS4 ,   TONS5 ,   TONS6 ,   TONS7 ,
     I   NBCHT ,   NOPSEL,   NS1   ,   NS2   ,   NS3   ,   NS4   ,
     I   NS5   ,   NS6   ,   NS7
C-----------------------------------------------------------------------
         DIMENSION
     +   ZX(512),ZY(512)
C
C-----------------------------------------------------------------------
CL              1.         initialise
C
C
CL                  1.1      Set mapping
         ZXMIN=0
         ZXMAX=(LMAX-1)*DX1*100
         CALL MAP(ZXMIN,ZXMAX,ECVMIN,ECVMAX)
C
CL                  1.2      Plot labelling
         IF(K.EQ.1)THEN
C        CALL BACCOL(60)
         CALL LINCOL(4)
         CALL CTRMAG(20)
         CALL PLACE(7,1)
         CALL TYPECS('E1 along Cavity Bottoms')
         CALL CTRMAG(10)
         CALL PLACE(14,5)
         CALL TYPECS(CHLAB1)
         CALL PLACE(14,7)
         CALL TYPECS('time:')
         CALL TYPECS(CHRTIM)
         CALL TYPECS('     date:')
         CALL TYPECS(CHRDAT)
         CALL CTRFNT(1)
         CALL CTRMAG(10)
         CALL PLACE(89,3)
         CALL TYPECS('            ')
         CALL PLACE(89,5)
         CALL TYPECS('     ')
         CALL PLACE(89,7)
         CALL TYPECS('      ')
         CALL ITALIC(0)
         CALL FRAME
C
CL                  1.3      label the plot
         CALL LINCOL(4)
         CALL OKAXES(0,5)
         CALL BORDER
         CALL FRAME
C
C
C-----------------------------------------------------------------------
CL              2.         plot curve
C
C
         ELSE IF(K.EQ.2) THEN
         DO 200 JL=2,LMAX
         ZX(2*JL-3)=(JL-2)*DX1*100
         ZX(2*JL-2)=(JL-1)*DX1*100
         ZY(2*JL-3)=E1(JL,MMAX-MDEPTH+1)*SCE1
         ZY(2*JL-2)=ZY(2*JL-3)
  200    CONTINUE
C       close curve for shading
         ZX(2*LMAX-1)=(LMAX-1)*DX1*100
         ZY(2*LMAX-1)=0.0
         ZX(2*LMAX)=0.0
         ZY(2*LMAX)=0.0
         CALL LINCOL(2)
         CALL FILCOL(2)
         CALL PTJOIN(ZX,ZY,1,LMAX*2,-1)
         END IF
C-----------------------------------------------------------------------
         CALL FILCOL(0)
         CALL PICNOW
C-----------------------------------------------------------------------
         END
C/ MODULE C3S16
C
         SUBROUTINE IPENDP(K)
C
C 3.16 plot electron current into diode end of anode
C
C-----------------------------------------------------------------------
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C       INCLUDE 'COMDDP.inc'
C--------------------------------------------------------------------
CL                  C1.9.    DEVELOPMENT AND DIAGNOSTIC PARAMETERS
       COMMON/COMDDP/
     I   MAXDUM,   MXDUMP,   NADUMP,   NCLASS,   NPDUMP,   NPOINT,
     I   NSUB,     NVDUMP,
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       LOGICAL
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       DIMENSION
     I   NADUMP(20),         NPDUMP(20),         NVDUMP(20),
     L   NLHEAD(9),          NLOMT1(50),         NLOMT2(50),
     L   NLOMT3(50)
C       INCLUDE 'COMCON.inc'
C---------------------------------------------------------------------
CL                  C2.1     Physical Constants
       COMMON/COMCON/
     R   API   ,   BOLTZK,   CLIGHT,   ELCHAG,   ELMASS,   EMU0  ,
     R   EOVERM,   EPS0
C       INCLUDE 'COMSTT.inc'
C---------------------------------------------------------------------
CL                  C2.2     Physical State
       COMMON/COMSTT/
     R   B3    ,   BAV   ,   CD1   ,   CD2   ,   E1    ,   E2    ,
     R   P1    ,   P2    ,   Q1    ,   Q2    ,   REALTN,   TIMRUN
       DIMENSION
     R   B3(605,40),        BAV(605,40),       CD1(605,40),
     R   CD2(605,40),       E1(605,40),        E2(605,40),
     R   P1(20000),          P2(20000),          Q1(20000),
     R   Q2(20000)
C       INCLUDE 'COMDEV.inc'
C---------------------------------------------------------------------
CL                  C2.3     Device description
       COMMON/COMDEV/
     R   B3RHS ,   B3RHSD,   BAPLY ,   BAPLYD,   CAVEAM,   CAVEFR,
     R   CAVIC ,   CAVRES,   CAVTC ,   DEPTH ,   DEVHYT,   DEVLEN,
     R   DEVRAD,   EAPLYD,   EEMIT ,   EEMITD,   ENIT  ,   ENITD ,
     R   GAP   ,   RESAX ,   RESE  ,   RESN  ,   RESS  ,   RESW  ,
     R   RINNER,   SPACE ,   VOLTAG,   WIDTH ,
     I   LCATH ,   LCAV  ,   LLEFT ,   LWVANE,   MDEPTH,   MGAP  ,
     I   NBCAX ,   NBCCAV,   NBCE  ,   NBCN  ,   NBCS  ,   NBCW  ,
     I   NCAV  ,   NDEV
       DIMENSION
     R   CAVEAM(100),        CAVEFR(100),        CAVIC(4,100),
     R   CAVRES(100),        CAVTC(100),
     I   NBCCAV(100)
C       INCLUDE 'COMDIA.inc'
C---------------------------------------------------------------------
CL                  C2.4     Physical Diagnostics
       COMMON/COMDIA/
     R   B3POW ,   BOUT  ,   CAVPOY,   E1POW ,   E2POW ,   EJ1POW,
     R   EJ2POW,   EJENP ,   EJPOWM,   EJPOWP,   EJPWPN,   EKFLXI,
     R   EKFLXO,   ENEJ1 ,   ENEJ2 ,   ENEL1 ,   ENEL1O,   ENEL2 ,
     R   ENEL2O,   ENKIN ,   ENKINO,   ENMAG ,   ENMAGO,   ENPOYT,
     R   ENTOT ,   ENTOTO,   EOUT  ,   TOTM1 ,   TOTM2 ,   TPOYP ,
     I   LCAVEN,   LCAVST,   NPNEW ,   NPOLD
       DIMENSION
     R   BOUT(100),          CAVPOY(100),        EOUT(100),
     I   LCAVEN(100),        LCAVST(100)
C       INCLUDE 'COMNUM.inc'
C---------------------------------------------------------------------
CL                  C3.1     Numerical Parameters
       COMMON/COMNUM/
     R   C1    ,   C2    ,   CD0   ,   CURANT,   DT    ,   DX1   ,
     R   DX1DX2,   DX1OX2,   DX2   ,   DX2OX1,   ELPERP,   HLFDX1,
     R   HLFDX2,   TCACO ,
     I   LMAX  ,   LMAXP ,   LMAXP2,   MMAX  ,   MMAXP ,   MMAXP2,
     I   NEMIT ,   NP
C       INCLUDE 'COMSCA.inc'
C---------------------------------------------------------------------
CL                  C3.2     Scaling Factors
       COMMON/COMSCA/
     R   SCB3  ,   SCE1  ,   SCE2  ,   SCEMEN,   SCEPOW,   SCI1  ,
     R   SCI2  ,   SCIP  ,   SCKE  ,   SCKPOW,   SCP1  ,   SCP2  ,
     R   SCV1  ,   SCV2  ,   SCX1  ,   SCX2
C       INCLUDE 'COMHOK.inc'
C---------------------------------------------------------------------
CL                  C4.1     Housekeeping
       COMMON/COMHOK/
     R   TIMECP,   XPSMAX,   XPSMIN,   YPSMAX,   YPSMIN,
     I   N1MAX ,   N2MAX ,   NCASE ,   NGMAX ,   NOSEP ,   NPDUM ,
     I   NPMAX ,   NSRC  ,   NXDUM ,   NYDUM
       DIMENSION
     R   TIMECP(32)
C       INCLUDE 'COMGEO.inc'
C---------------------------------------------------------------------
CL                  C4.2     Device boundary data
       COMMON/COMGEO/
     R   ASCUR ,   CCTSRC,   EBEXT ,   ELSCUR,   ENSUR ,   EPOYNT,
     R   RHOC  ,   SURCHG,   SURIC ,
     I   LINDEX,   MINDEX,   NBCTYP,   NBDIM ,   NBSEG2,   NCOLOR,
     I   NDIRN ,   NG
       DIMENSION
     R   ASCUR(1500),        CCTSRC(1500),       EBEXT(2,1500),
     R   ELSCUR(1500),       ENSUR(1500),        EPOYNT(1500),
     R   RHOC(1500),         SURCHG(1500),       SURIC(4,1500),
     I   LINDEX(1500),       MINDEX(1500),       NBCTYP(1500),
     I   NCOLOR(1500),       NDIRN(1500),        NG(605,40)
C       INCLUDE 'COMOUT.inc'
C---------------------------------------------------------------------
CL                  C5.1     Output Variables
       COMMON/COMOUT/
     R   BCNMAX,   BCNMIN,   BCVMAX,   BCVMIN,   CUAMAX,   CUAMIN,
     R   CUEMAX,   CUEMIN,   ECVMAX,   ECVMIN,   TONS1 ,   TONS2 ,
     R   TONS3 ,   TONS4 ,   TONS5 ,   TONS6 ,   TONS7 ,
     I   NBCHT ,   NOPSEL,   NS1   ,   NS2   ,   NS3   ,   NS4   ,
     I   NS5   ,   NS6   ,   NS7
C-----------------------------------------------------------------------
         DIMENSION
     +   ZX(512),ZY(512),CSAVE(512)
C
C-----------------------------------------------------------------------
CL              1.         initialise
C
C
CL                  1.1      set mapping
         ZXMIN=0
         ZXMAX=(MMAX-1)*DX2*100
         CALL MAP(ZXMIN,ZXMAX,CUEMIN,CUEMAX)
C
CL                  1.2      Plot labelling
         IF(K.EQ.1) THEN
C        CALL BACCOL(60)
         CALL LINCOL(4)
         CALL CTRMAG(20)
         CALL PLACE(7,1)
         CALL TYPECS('I1 into right hand end')
         CALL CTRMAG(10)
         CALL PLACE(14,5)
         CALL TYPECS(CHLAB1)
         CALL PLACE(14,7)
         CALL TYPECS('time:')
         CALL TYPECS(CHRTIM)
         CALL TYPECS('     date:')
         CALL TYPECS(CHRDAT)
         CALL CTRFNT(1)
         CALL CTRMAG(10)
         CALL PLACE(89,3)
         CALL TYPECS('            ')
         CALL PLACE(89,5)
         CALL TYPECS('     ')
         CALL PLACE(89,7)
         CALL TYPECS('      ')
         CALL ITALIC(0)
         CALL FRAME
C
CL                  1.3      plot axes
         CALL LINCOL(4)
         CALL OKAXES(0,5)
         CALL BORDER
         CALL FRAME
C
C-----------------------------------------------------------------------
CL              2.         plot curve
C
         ELSE IF(K.EQ.2) THEN
         DO 200 JM=2,MMAXP2
         ZX(JM-1)=(JM-2)*DX2*100
         ZY(JM-1)=(CD1(LMAX,JM)+CSAVE(JM-1))*SCI1/5000.
         ZX(MMAXP2)=0.0
         ZY(MMAXP2)=0.0
  200    CONTINUE
C
         CALL LINCOL(4)
         CALL FILCOL(4)
         CALL PTJOIN(ZX,ZY,1,MMAXP2,-1)
C-----------------------------------------------------------------------
         CALL FILCOL(0)
         CALL PICNOW
         ELSE IF(K.EQ.3) THEN
C-----------------------------------------------------------------------
C
C     3. SAVE FIRST CURRENT
C
         DO 300 JM=2,MMAXP2
  300    CSAVE(JM-1)=CD1(LMAX,JM)
C
         ELSE IF(K.EQ.4) THEN
C----------------------------------------------------------------------
C    4. SAVE SUBSEQUENT CURRENTS
C
         DO 400 JM=2,MMAXP2
 400     CSAVE(JM-1)=CSAVE(JM-1)+CD1(LMAX,JM)
         ENDIF
C-----------------------------------------------------------------------
         END
C/ MODULE C3S17
C
         SUBROUTINE IPTOPP(K)
C
C 3.17 plot currents along cavity bottoms
C
C-----------------------------------------------------------------------
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C       INCLUDE 'COMDDP.inc'
C--------------------------------------------------------------------
CL                  C1.9.    DEVELOPMENT AND DIAGNOSTIC PARAMETERS
       COMMON/COMDDP/
     I   MAXDUM,   MXDUMP,   NADUMP,   NCLASS,   NPDUMP,   NPOINT,
     I   NSUB,     NVDUMP,
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       LOGICAL
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       DIMENSION
     I   NADUMP(20),         NPDUMP(20),         NVDUMP(20),
     L   NLHEAD(9),          NLOMT1(50),         NLOMT2(50),
     L   NLOMT3(50)
C       INCLUDE 'COMCON.inc'
C---------------------------------------------------------------------
CL                  C2.1     Physical Constants
       COMMON/COMCON/
     R   API   ,   BOLTZK,   CLIGHT,   ELCHAG,   ELMASS,   EMU0  ,
     R   EOVERM,   EPS0
C       INCLUDE 'COMSTT.inc'
C---------------------------------------------------------------------
CL                  C2.2     Physical State
       COMMON/COMSTT/
     R   B3    ,   BAV   ,   CD1   ,   CD2   ,   E1    ,   E2    ,
     R   P1    ,   P2    ,   Q1    ,   Q2    ,   REALTN,   TIMRUN
       DIMENSION
     R   B3(605,40),        BAV(605,40),       CD1(605,40),
     R   CD2(605,40),       E1(605,40),        E2(605,40),
     R   P1(20000),          P2(20000),          Q1(20000),
     R   Q2(20000)
C       INCLUDE 'COMDEV.inc'
C---------------------------------------------------------------------
CL                  C2.3     Device description
       COMMON/COMDEV/
     R   B3RHS ,   B3RHSD,   BAPLY ,   BAPLYD,   CAVEAM,   CAVEFR,
     R   CAVIC ,   CAVRES,   CAVTC ,   DEPTH ,   DEVHYT,   DEVLEN,
     R   DEVRAD,   EAPLYD,   EEMIT ,   EEMITD,   ENIT  ,   ENITD ,
     R   GAP   ,   RESAX ,   RESE  ,   RESN  ,   RESS  ,   RESW  ,
     R   RINNER,   SPACE ,   VOLTAG,   WIDTH ,
     I   LCATH ,   LCAV  ,   LLEFT ,   LWVANE,   MDEPTH,   MGAP  ,
     I   NBCAX ,   NBCCAV,   NBCE  ,   NBCN  ,   NBCS  ,   NBCW  ,
     I   NCAV  ,   NDEV
       DIMENSION
     R   CAVEAM(100),        CAVEFR(100),        CAVIC(4,100),
     R   CAVRES(100),        CAVTC(100),
     I   NBCCAV(100)
C       INCLUDE 'COMDIA.inc'
C---------------------------------------------------------------------
CL                  C2.4     Physical Diagnostics
       COMMON/COMDIA/
     R   B3POW ,   BOUT  ,   CAVPOY,   E1POW ,   E2POW ,   EJ1POW,
     R   EJ2POW,   EJENP ,   EJPOWM,   EJPOWP,   EJPWPN,   EKFLXI,
     R   EKFLXO,   ENEJ1 ,   ENEJ2 ,   ENEL1 ,   ENEL1O,   ENEL2 ,
     R   ENEL2O,   ENKIN ,   ENKINO,   ENMAG ,   ENMAGO,   ENPOYT,
     R   ENTOT ,   ENTOTO,   EOUT  ,   TOTM1 ,   TOTM2 ,   TPOYP ,
     I   LCAVEN,   LCAVST,   NPNEW ,   NPOLD
       DIMENSION
     R   BOUT(100),          CAVPOY(100),        EOUT(100),
     I   LCAVEN(100),        LCAVST(100)
C       INCLUDE 'COMNUM.inc'
C---------------------------------------------------------------------
CL                  C3.1     Numerical Parameters
       COMMON/COMNUM/
     R   C1    ,   C2    ,   CD0   ,   CURANT,   DT    ,   DX1   ,
     R   DX1DX2,   DX1OX2,   DX2   ,   DX2OX1,   ELPERP,   HLFDX1,
     R   HLFDX2,   TCACO ,
     I   LMAX  ,   LMAXP ,   LMAXP2,   MMAX  ,   MMAXP ,   MMAXP2,
     I   NEMIT ,   NP
C       INCLUDE 'COMSCA.inc'
C---------------------------------------------------------------------
CL                  C3.2     Scaling Factors
       COMMON/COMSCA/
     R   SCB3  ,   SCE1  ,   SCE2  ,   SCEMEN,   SCEPOW,   SCI1  ,
     R   SCI2  ,   SCIP  ,   SCKE  ,   SCKPOW,   SCP1  ,   SCP2  ,
     R   SCV1  ,   SCV2  ,   SCX1  ,   SCX2
C       INCLUDE 'COMHOK.inc'
C---------------------------------------------------------------------
CL                  C4.1     Housekeeping
       COMMON/COMHOK/
     R   TIMECP,   XPSMAX,   XPSMIN,   YPSMAX,   YPSMIN,
     I   N1MAX ,   N2MAX ,   NCASE ,   NGMAX ,   NOSEP ,   NPDUM ,
     I   NPMAX ,   NSRC  ,   NXDUM ,   NYDUM
       DIMENSION
     R   TIMECP(32)
C       INCLUDE 'COMGEO.inc'
C---------------------------------------------------------------------
CL                  C4.2     Device boundary data
       COMMON/COMGEO/
     R   ASCUR ,   CCTSRC,   EBEXT ,   ELSCUR,   ENSUR ,   EPOYNT,
     R   RHOC  ,   SURCHG,   SURIC ,
     I   LINDEX,   MINDEX,   NBCTYP,   NBDIM ,   NBSEG2,   NCOLOR,
     I   NDIRN ,   NG
       DIMENSION
     R   ASCUR(1500),        CCTSRC(1500),       EBEXT(2,1500),
     R   ELSCUR(1500),       ENSUR(1500),        EPOYNT(1500),
     R   RHOC(1500),         SURCHG(1500),       SURIC(4,1500),
     I   LINDEX(1500),       MINDEX(1500),       NBCTYP(1500),
     I   NCOLOR(1500),       NDIRN(1500),        NG(605,40)
C       INCLUDE 'COMOUT.inc'
C---------------------------------------------------------------------
CL                  C5.1     Output Variables
       COMMON/COMOUT/
     R   BCNMAX,   BCNMIN,   BCVMAX,   BCVMIN,   CUAMAX,   CUAMIN,
     R   CUEMAX,   CUEMIN,   ECVMAX,   ECVMIN,   TONS1 ,   TONS2 ,
     R   TONS3 ,   TONS4 ,   TONS5 ,   TONS6 ,   TONS7 ,
     I   NBCHT ,   NOPSEL,   NS1   ,   NS2   ,   NS3   ,   NS4   ,
     I   NS5   ,   NS6   ,   NS7
C-----------------------------------------------------------------------
         DIMENSION
     +   ZX(512),ZY(512)
C
C-----------------------------------------------------------------------
CL              1.         initialise
C
C
CL                  1.1      set mapping
         ZXMIN=0
         ZXMAX=(LMAX-1)*DX1*100
         CALL MAP(ZXMIN,ZXMAX,CUAMIN,CUAMAX)
C
CL                  1.2      Plot labelling
         IF(K.EQ.1) THEN
C        CALL BACCOL(60)
         CALL LINCOL(4)
         CALL CTRMAG(20)
         CALL PLACE(7,1)
         CALL TYPECS('I2 along Cavity Bottoms')
         CALL CTRMAG(10)
         CALL PLACE(14,5)
         CALL TYPECS(CHLAB1)
         CALL PLACE(14,7)
         CALL TYPECS('time:')
         CALL TYPECS(CHRTIM)
         CALL TYPECS('     date:')
         CALL TYPECS(CHRDAT)
         CALL CTRFNT(1)
         CALL CTRMAG(10)
         CALL PLACE(89,3)
         CALL TYPECS('            ')
         CALL PLACE(89,5)
         CALL TYPECS('     ')
         CALL PLACE(89,7)
         CALL TYPECS('      ')
         CALL ITALIC(0)
         CALL FRAME
C
CL                  1.3      plot axes
         CALL LINCOL(4)
         CALL OKAXES(0,5)
         CALL BORDER
         CALL FRAME
C
C-----------------------------------------------------------------------
CL              2.         plot curve
C
C
         ELSE IF(K.EQ.2) THEN
         DO 200 JL=2,LMAXP2
         ZX(JL-1)=(JL-2)*DX1*100
         ZY(JL-1)=CD2(JL,MMAX-MDEPTH)*SCI2/1000.0
  200    CONTINUE
         CALL LINCOL(4)
         CALL FILCOL(4)
         ZY(1)=0.0
         CALL PTJOIN(ZX,ZY,1,LMAXP,-1)
         END IF
C-----------------------------------------------------------------------
         CALL FILCOL(0)
         CALL PICNOW
C-----------------------------------------------------------------------
         END
C/ MODULE C3S20
C
         SUBROUTINE FRAML1(PTIME,ISTEP,CHAR8)
C
C 3.4  Advance frame and label new frame
C
       DIMENSION   IDATA(11)
       CHARACTER   CHAR8*8
C
C  Statement added to use IDATA and avoid compile warning
         IDATA(1)=1
C
C-----------------------------------------------------------------------
CL              1.         new page
C
         CALL FRAME
         CALL CTRMAG(40)
         CALL CTROBL(0.5)
C        CALL BACCOL(60)
         CALL CTRFNT(16)
C
C-----------------------------------------------------------------------
CL              2.         add descriptive footer to page
C
                 CALL LINCOL(4)
         CALL MAP(0.0,1.0,0.0,1.0)
         CALL PCSEND(0.5,0.0,'Time = ')
         CALL TYPENF(PTIME,2)
         CALL PLOTCS(0.65,0.0,'ns')
         CALL CTRMAG(10)
         CALL CTROBL(1.0)
         CALL CTRFNT(1)
         IFN = IFN + 1
C-----------------------------------------------------------------------
         END
C/ MODULE C3S22
C
         SUBROUTINE E1FFT
C
C 3.22 plot FFT of E1 along cavity bottom
C
C-----------------------------------------------------------------------
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C       INCLUDE 'COMDDP.inc'
C--------------------------------------------------------------------
CL                  C1.9.    DEVELOPMENT AND DIAGNOSTIC PARAMETERS
       COMMON/COMDDP/
     I   MAXDUM,   MXDUMP,   NADUMP,   NCLASS,   NPDUMP,   NPOINT,
     I   NSUB,     NVDUMP,
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       LOGICAL
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       DIMENSION
     I   NADUMP(20),         NPDUMP(20),         NVDUMP(20),
     L   NLHEAD(9),          NLOMT1(50),         NLOMT2(50),
     L   NLOMT3(50)
C       INCLUDE 'COMCON.inc'
C---------------------------------------------------------------------
CL                  C2.1     Physical Constants
       COMMON/COMCON/
     R   API   ,   BOLTZK,   CLIGHT,   ELCHAG,   ELMASS,   EMU0  ,
     R   EOVERM,   EPS0
C       INCLUDE 'COMSTT.inc'
C---------------------------------------------------------------------
CL                  C2.2     Physical State
       COMMON/COMSTT/
     R   B3    ,   BAV   ,   CD1   ,   CD2   ,   E1    ,   E2    ,
     R   P1    ,   P2    ,   Q1    ,   Q2    ,   REALTN,   TIMRUN
       DIMENSION
     R   B3(605,40),        BAV(605,40),       CD1(605,40),
     R   CD2(605,40),       E1(605,40),        E2(605,40),
     R   P1(20000),          P2(20000),          Q1(20000),
     R   Q2(20000)
C       INCLUDE 'COMDEV.inc'
C---------------------------------------------------------------------
CL                  C2.3     Device description
       COMMON/COMDEV/
     R   B3RHS ,   B3RHSD,   BAPLY ,   BAPLYD,   CAVEAM,   CAVEFR,
     R   CAVIC ,   CAVRES,   CAVTC ,   DEPTH ,   DEVHYT,   DEVLEN,
     R   DEVRAD,   EAPLYD,   EEMIT ,   EEMITD,   ENIT  ,   ENITD ,
     R   GAP   ,   RESAX ,   RESE  ,   RESN  ,   RESS  ,   RESW  ,
     R   RINNER,   SPACE ,   VOLTAG,   WIDTH ,
     I   LCATH ,   LCAV  ,   LLEFT ,   LWVANE,   MDEPTH,   MGAP  ,
     I   NBCAX ,   NBCCAV,   NBCE  ,   NBCN  ,   NBCS  ,   NBCW  ,
     I   NCAV  ,   NDEV
       DIMENSION
     R   CAVEAM(100),        CAVEFR(100),        CAVIC(4,100),
     R   CAVRES(100),        CAVTC(100),
     I   NBCCAV(100)
C       INCLUDE 'COMDIA.inc'
C---------------------------------------------------------------------
CL                  C2.4     Physical Diagnostics
       COMMON/COMDIA/
     R   B3POW ,   BOUT  ,   CAVPOY,   E1POW ,   E2POW ,   EJ1POW,
     R   EJ2POW,   EJENP ,   EJPOWM,   EJPOWP,   EJPWPN,   EKFLXI,
     R   EKFLXO,   ENEJ1 ,   ENEJ2 ,   ENEL1 ,   ENEL1O,   ENEL2 ,
     R   ENEL2O,   ENKIN ,   ENKINO,   ENMAG ,   ENMAGO,   ENPOYT,
     R   ENTOT ,   ENTOTO,   EOUT  ,   TOTM1 ,   TOTM2 ,   TPOYP ,
     I   LCAVEN,   LCAVST,   NPNEW ,   NPOLD
       DIMENSION
     R   BOUT(100),          CAVPOY(100),        EOUT(100),
     I   LCAVEN(100),        LCAVST(100)
C       INCLUDE 'COMNUM.inc'
C---------------------------------------------------------------------
CL                  C3.1     Numerical Parameters
       COMMON/COMNUM/
     R   C1    ,   C2    ,   CD0   ,   CURANT,   DT    ,   DX1   ,
     R   DX1DX2,   DX1OX2,   DX2   ,   DX2OX1,   ELPERP,   HLFDX1,
     R   HLFDX2,   TCACO ,
     I   LMAX  ,   LMAXP ,   LMAXP2,   MMAX  ,   MMAXP ,   MMAXP2,
     I   NEMIT ,   NP
C       INCLUDE 'COMSCA.inc'
C---------------------------------------------------------------------
CL                  C3.2     Scaling Factors
       COMMON/COMSCA/
     R   SCB3  ,   SCE1  ,   SCE2  ,   SCEMEN,   SCEPOW,   SCI1  ,
     R   SCI2  ,   SCIP  ,   SCKE  ,   SCKPOW,   SCP1  ,   SCP2  ,
     R   SCV1  ,   SCV2  ,   SCX1  ,   SCX2
C       INCLUDE 'COMHOK.inc'
C---------------------------------------------------------------------
CL                  C4.1     Housekeeping
       COMMON/COMHOK/
     R   TIMECP,   XPSMAX,   XPSMIN,   YPSMAX,   YPSMIN,
     I   N1MAX ,   N2MAX ,   NCASE ,   NGMAX ,   NOSEP ,   NPDUM ,
     I   NPMAX ,   NSRC  ,   NXDUM ,   NYDUM
       DIMENSION
     R   TIMECP(32)
C       INCLUDE 'COMGEO.inc'
C---------------------------------------------------------------------
CL                  C4.2     Device boundary data
       COMMON/COMGEO/
     R   ASCUR ,   CCTSRC,   EBEXT ,   ELSCUR,   ENSUR ,   EPOYNT,
     R   RHOC  ,   SURCHG,   SURIC ,
     I   LINDEX,   MINDEX,   NBCTYP,   NBDIM ,   NBSEG2,   NCOLOR,
     I   NDIRN ,   NG
       DIMENSION
     R   ASCUR(1500),        CCTSRC(1500),       EBEXT(2,1500),
     R   ELSCUR(1500),       ENSUR(1500),        EPOYNT(1500),
     R   RHOC(1500),         SURCHG(1500),       SURIC(4,1500),
     I   LINDEX(1500),       MINDEX(1500),       NBCTYP(1500),
     I   NCOLOR(1500),       NDIRN(1500),        NG(605,40)
C       INCLUDE 'COMOUT.inc'
C---------------------------------------------------------------------
CL                  C5.1     Output Variables
       COMMON/COMOUT/
     R   BCNMAX,   BCNMIN,   BCVMAX,   BCVMIN,   CUAMAX,   CUAMIN,
     R   CUEMAX,   CUEMIN,   ECVMAX,   ECVMIN,   TONS1 ,   TONS2 ,
     R   TONS3 ,   TONS4 ,   TONS5 ,   TONS6 ,   TONS7 ,
     I   NBCHT ,   NOPSEL,   NS1   ,   NS2   ,   NS3   ,   NS4   ,
     I   NS5   ,   NS6   ,   NS7
C-----------------------------------------------------------------------
         DIMENSION
     +   ZX(512),ZY(512)
C
C-----------------------------------------------------------------------
CL              1.        FFT
C
C
CL                  1.1     Deternine number of zero to pack with
         JREQ=2*LMAX
         DO 10 J=1,9
 10      IF(JREQ.LT.2**J) GOTO 11
         STOP 'STOP IN E1FFT'
 11      JN=2**J
C----------------------------------------------------------------------
CL  CENTER UP AND PACK ARRAY
C
         JSTART=(JN-LMAX)/2
C
         ZYDC=0.
         DO 100 J=2,LMAX
         ZYDC=ZYDC+E2(J,MMAX-MDEPTH)
 100     CONTINUE
C
         ZYDC=ZYDC/(LMAX-1.)
         DO 12 J=2,LMAX
         ZX(J)=0.
  12     ZY(J+JSTART+1)=E2(J,MMAX-MDEPTH)-ZYDC
C
C SINE BELL
C
         ZY(3+JSTART)=0.5*ZY(3+JSTART)
         ZY(4+JSTART)=0.866*ZY(4+JSTART)
         ZY(LMAX+JSTART)=0.866*ZY(LMAX+JSTART)
         ZY(LMAX+JSTART+1)=0.5*ZY(LMAX+JSTART+1)
C
         DO 13 J=1,JSTART+2
         ZX(J)=0.
  13     ZY(J)=0.
C
         DO 14 J=JSTART+LMAX+2,JN
         ZX(J)=0.
  14     ZY(J)=0.
C-----------------------------------------------------------------------
CL 1.3  FFT
C
         JINV=2
         CALL FT01A(JN,JINV,ZY,ZX)
C
C-----------------------------------------------------------------------
C PLOT CURVE
C
C 1.4 CONVER TO REAL WAVELENGTH
C
        ZYMAX=0.
         DO 15 J=2,LMAX
         ZY(J)=SQRT(ZY(J)**2+ZX(J)**2)
          IF(ZY(J).GT.ZYMAX) ZYMAX=ZY(J)
  15     ZX(J)=FLOAT(J)/DEVLEN*LMAX/FLOAT(JN)
C
             ZEPS=1.E-30
             IF(ZYMAX.LT.ZEPS)RETURN
C
C-----------------------------------------------------------------------
        ZYMAX=10.0**(1.+INT(ALOG10(ZYMAX)))
C 2.1 PLOT THE RESULT
C
         CALL MAPYL(0.,45.,ZYMAX/1000.,ZYMAX)
         CALL PTJOIN(ZX,ZY,2,LMAX,0)
         CALL CTRMAG(12)
         CALL SCAYLI(10.0)
         CALL BORDER
         CALL PLACE(20,4)
         CALL CTRMAG(20)
         CALL TYPECS('Freq(GHz)  v  1/(Wavelength) m')
         CALL SUPFIX
         CALL TYPECS('-1')
         CALL NORMAL
         CALL CTRMAG(10)
         CALL PICNOW
C
C-----------------------------------------------------------------------
C
         END

C/ MODULE C3S23
      SUBROUTINE FT01A (IT,INV,TR,TI)
C###### 15/05/70 LAST LIBRARY UPDATE
C         THIS ROUTINE CALCULATES THE FOURIER TRANSFORM OF EQUALLY SPACE
C         F(N)  N=0,1,...,IT-1
C         THE DATA IS TAKEN TO BE PERIODIC IE.   F(N+IT) = F(N)
C         ++++++ ARGUMENTS SET BY THE CALLING PROGRAM ++++++
C         IT IS THE PROBLEM SIZE AND MUST BE A POWER OF 2
C         INV = 2 FOR DIRECT TRANSFORM IE.
C         G(M) = SUM OVER N=0,1,..,IT-1 OF F(N)*EXP(2PI*SQRT(-1)*N*M/IT)
C         FOR M=0,1,...,IT-1
C         INV = 1 FOR INVERSE TRANSFORM IE.
C      F(N) = (1./IT)*(SUM OVER M=0,1,..,IT-1 OF G(M)*EXP(-2PI*SQRT(-1)*
C         FOR N =0,1,...,IT-1
C         TR(I)    I=1,2,..,IT MUST CONTAIN REAL PART OF DATA
C         TI(I)    I=1,2,..,IT MUST CONTAIN THE IMAGINARY PART OF DATA
C         ++++++ ARGUMENTS SET BY ROUTINE ++++++
C         IF IT IS NOT A POWER OF 2 INV IS SET TO -1 FOR ERROR RETURN
C        TR(I)    I=1,2,..,IT IS SET TO REAL PART OF TRANSFORM
C         TI(I)    I=1,2,..,IT IS SET TO THE IMAGINARY PART OF TRANSFORM
C         THE METHOD USED IN THIS ROUTINE IS DISCRIBED IN
C         (GENTLEMAN AND SANDE, PROC. FALL JOINT COMPUTER CONFER. 1966)
      DIMENSION TR(4),TI(4),UR(15),UI(15)
      DATA KJUMP/1/
      GO TO(100,200),KJUMP
  100 UM=.5
      DO 50 I=1,15
      UM=.5*UM
      TH=6.283185*UM
      UR(I)=COS(TH)
   50 UI(I)=SIN(TH)
  200 UM=1.
      GO TO(1,2),INV
    1 UM=-1.
    2 I0=2
      DO 3 I=2,16
      I0=I0+I0
      IF(I0-IT)3,4,5
    3 CONTINUE
C     ERROR IN IT - SET INV=-1 AND RETURN
    5 INV=-1
      RETURN
C     IT= 2**I - INITIALISE OUTER LOOP
    4 I0=I
      II=I0
      I1=IT/2
      I3=1
C     START MIDDLE LOOP
   10 K=0
      I2=I1+I1
C     CALCULATE TWIDDLE FACTOR E(K/I2)
   11 WR=1.
      WI=0.
      KK=K
      J0=I0
   24 IF(KK)21,22,21
   21 J0=J0-1
      KK1=KK
      KK=KK/2
      IF(KK1-2*KK)23,21,23
   23 WS=WR*UR(J0)-WI*UI(J0)
      WI=WR*UI(J0)+WI*UR(J0)
      WR=WS
      GO TO 24
   22 WI=WI*UM
C     START INNER LOOP
      J=0
C     DO 2*2 TRANSFORM
   31 L=J*I2+K
      L1=L+I1
      ZR=TR(L+1)+TR(L1+1)
      ZI=TI(L+1)+TI(L1+1)
      Z=WR*(TR(L+1)-TR(L1+1))-WI*(TI(L+1)-TI(L1+1))
      TI(L1+1)=WR*(TI(L+1)-TI(L1+1))+WI*(TR(L+1)-TR(L1+1))
      TR(L+1)=ZR
      TR(L1+1)=Z
      TI(L+1)=ZI
C     INDEX J LOOP
      J=J+1
      IF(J-I3)31,12,12
C     INDEX K LOOP
   12 K=K+1
      IF(K-I1)11,6,6
C     INDEX OUTER LOOP
    6 I3=I3+I3
      I0=I0-1
      I1=I1/2
      IF(I1)51,51,10
C     UNSCRAMBLE
   51 J=1
      UM=1.
      GO TO(61,52),INV
   61 UM=1./FLOAT(IT)
   52 K=0
      J1=J
      DO 53 I=1,II
      J2=J1/2
      K=2*(K-J2)+J1
   53 J1=J2
   54 IF(K-J)66,56,55
   56 TR(J+1)=TR(J+1)*UM
      TI(J+1)=TI(J+1)*UM
      GO TO 66
   55 ZR=TR(J+1)
      ZI=TI(J+1)
      TR(J+1)=TR(K+1)*UM
      TI(J+1)=TI(K+1)*UM
      TR(K+1)=ZR*UM
      TI(K+1)=ZI*UM
   66 J=J+1
      IF(J-IT+1)52,57,57
   57 TR(1)=TR(1)*UM
      TI(1)=TI(1)*UM
      TR(IT)=TR(IT)*UM
      TI(IT)=TI(IT)*UM
      END
C/ MODULE C3S24
C
         SUBROUTINE COULST(K)
C
C 3.24  set def colour tables
C
C-----------------------------------------------------------------------
      DIMENSION  HUE(9),SAT(9),VALUE(9)
      DATA HUE/0.0,0.9,0.8,0.6,0.5,0.4,0.4,0.33,0.2/
      DATA SAT/0.93,0.86,0.79,1.0,1.0,0.71,0.79,1.0,0.64/
      DATA VALUE/0.86,0.79,0.64,1.0,1.0,1.0,0.93,1.0,1.0/
C-----------------------------------------------------------------------
         DATA        ICLASS,   ISUB/3,  24/
                                       CALL EXPERT(ICLASS,ISUB,1)
C
C-----------------------------------------------------------------------
CL              1.         filename and plot spaces
C
         IF(K.EQ.0) THEN
         ZSAT=0.7
         ZLIT=0.6
                 CALL HLS
                 CALL COLSET((9./14.),0.85,1.0,60)
         CALL BACCOL(60)
         DO 100 L=9,59
         ZINTEN=(L-3.)/56.
C        CALL COLSET(ZINTEN,0.7,1.0,L)
         CALL COLSET(ZINTEN,ZLIT,ZSAT,L)
  100    CONTINUE
C      set standard colours
         CALL COLSET(1.0    ,0.0, 0.0,1)
         CALL COLSET(1.0/3.0,ZLIT,ZSAT,2)
         CALL COLSET(2.0/3.0,ZLIT,ZSAT,3)
         CALL COLSET(1.0    ,ZLIT,ZSAT,4)
         CALL COLSET(1.0    ,1.0 , 0.0,5)
         CALL COLSET(5.0/6.0,ZLIT,ZSAT,6)
         CALL COLSET(1.0/6.0,ZLIT,ZSAT,7)
         CALL COLSET(1.0/2.0,ZLIT,ZSAT,8)
C
        ELSE
        CALL HSV
        DO 1 J1=8,15
 1      CALL COLSET(HUE(J1-7),SAT(J1-7),VALUE(J1-7),J1)
         ENDIF
C-----------------------------------------------------------------------
         END
C/ MODULE c5s3
C
         SUBROUTINE ARRAYS(KGROUP,KBLOCK)
C
C 5.3  PRINT COMMON ARRAYS
C
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C       INCLUDE 'COMDDP.inc'
C--------------------------------------------------------------------
CL                  C1.9.    DEVELOPMENT AND DIAGNOSTIC PARAMETERS
       COMMON/COMDDP/
     I   MAXDUM,   MXDUMP,   NADUMP,   NCLASS,   NPDUMP,   NPOINT,
     I   NSUB,     NVDUMP,
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       LOGICAL
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       DIMENSION
     I   NADUMP(20),         NPDUMP(20),         NVDUMP(20),
     L   NLHEAD(9),          NLOMT1(50),         NLOMT2(50),
     L   NLOMT3(50)
C       INCLUDE 'COMCON.inc'
C---------------------------------------------------------------------
CL                  C2.1     Physical Constants
       COMMON/COMCON/
     R   API   ,   BOLTZK,   CLIGHT,   ELCHAG,   ELMASS,   EMU0  ,
     R   EOVERM,   EPS0
C       INCLUDE 'COMSTT.inc'
C---------------------------------------------------------------------
CL                  C2.2     Physical State
       COMMON/COMSTT/
     R   B3    ,   BAV   ,   CD1   ,   CD2   ,   E1    ,   E2    ,
     R   P1    ,   P2    ,   Q1    ,   Q2    ,   REALTN,   TIMRUN
       DIMENSION
     R   B3(605,40),        BAV(605,40),       CD1(605,40),
     R   CD2(605,40),       E1(605,40),        E2(605,40),
     R   P1(20000),          P2(20000),          Q1(20000),
     R   Q2(20000)
C       INCLUDE 'COMDEV.inc'
C---------------------------------------------------------------------
CL                  C2.3     Device description
       COMMON/COMDEV/
     R   B3RHS ,   B3RHSD,   BAPLY ,   BAPLYD,   CAVEAM,   CAVEFR,
     R   CAVIC ,   CAVRES,   CAVTC ,   DEPTH ,   DEVHYT,   DEVLEN,
     R   DEVRAD,   EAPLYD,   EEMIT ,   EEMITD,   ENIT  ,   ENITD ,
     R   GAP   ,   RESAX ,   RESE  ,   RESN  ,   RESS  ,   RESW  ,
     R   RINNER,   SPACE ,   VOLTAG,   WIDTH ,
     I   LCATH ,   LCAV  ,   LLEFT ,   LWVANE,   MDEPTH,   MGAP  ,
     I   NBCAX ,   NBCCAV,   NBCE  ,   NBCN  ,   NBCS  ,   NBCW  ,
     I   NCAV  ,   NDEV
       DIMENSION
     R   CAVEAM(100),        CAVEFR(100),        CAVIC(4,100),
     R   CAVRES(100),        CAVTC(100),
     I   NBCCAV(100)
C       INCLUDE 'COMDIA.inc'
C---------------------------------------------------------------------
CL                  C2.4     Physical Diagnostics
       COMMON/COMDIA/
     R   B3POW ,   BOUT  ,   CAVPOY,   E1POW ,   E2POW ,   EJ1POW,
     R   EJ2POW,   EJENP ,   EJPOWM,   EJPOWP,   EJPWPN,   EKFLXI,
     R   EKFLXO,   ENEJ1 ,   ENEJ2 ,   ENEL1 ,   ENEL1O,   ENEL2 ,
     R   ENEL2O,   ENKIN ,   ENKINO,   ENMAG ,   ENMAGO,   ENPOYT,
     R   ENTOT ,   ENTOTO,   EOUT  ,   TOTM1 ,   TOTM2 ,   TPOYP ,
     I   LCAVEN,   LCAVST,   NPNEW ,   NPOLD
       DIMENSION
     R   BOUT(100),          CAVPOY(100),        EOUT(100),
     I   LCAVEN(100),        LCAVST(100)
C       INCLUDE 'COMKLY.inc'
C---------------------------------------------------------------------
CL                  C2.5     Klystron device details
       COMMON/COMKLY/
     R   BMCUR ,   BMMOM ,   BMRIN ,   BMROUT
C       INCLUDE 'COMNUM.inc'
C---------------------------------------------------------------------
CL                  C3.1     Numerical Parameters
       COMMON/COMNUM/
     R   C1    ,   C2    ,   CD0   ,   CURANT,   DT    ,   DX1   ,
     R   DX1DX2,   DX1OX2,   DX2   ,   DX2OX1,   ELPERP,   HLFDX1,
     R   HLFDX2,   TCACO ,
     I   LMAX  ,   LMAXP ,   LMAXP2,   MMAX  ,   MMAXP ,   MMAXP2,
     I   NEMIT ,   NP
C       INCLUDE 'COMSCA.inc'
C---------------------------------------------------------------------
CL                  C3.2     Scaling Factors
       COMMON/COMSCA/
     R   SCB3  ,   SCE1  ,   SCE2  ,   SCEMEN,   SCEPOW,   SCI1  ,
     R   SCI2  ,   SCIP  ,   SCKE  ,   SCKPOW,   SCP1  ,   SCP2  ,
     R   SCV1  ,   SCV2  ,   SCX1  ,   SCX2
C       INCLUDE 'COMHOK.inc'
C---------------------------------------------------------------------
CL                  C4.1     Housekeeping
       COMMON/COMHOK/
     R   TIMECP,   XPSMAX,   XPSMIN,   YPSMAX,   YPSMIN,
     I   N1MAX ,   N2MAX ,   NCASE ,   NGMAX ,   NOSEP ,   NPDUM ,
     I   NPMAX ,   NSRC  ,   NXDUM ,   NYDUM
       DIMENSION
     R   TIMECP(32)
C       INCLUDE 'COMGEO.inc'
C---------------------------------------------------------------------
CL                  C4.2     Device boundary data
       COMMON/COMGEO/
     R   ASCUR ,   CCTSRC,   EBEXT ,   ELSCUR,   ENSUR ,   EPOYNT,
     R   RHOC  ,   SURCHG,   SURIC ,
     I   LINDEX,   MINDEX,   NBCTYP,   NBDIM ,   NBSEG2,   NCOLOR,
     I   NDIRN ,   NG
       DIMENSION
     R   ASCUR(1500),        CCTSRC(1500),       EBEXT(2,1500),
     R   ELSCUR(1500),       ENSUR(1500),        EPOYNT(1500),
     R   RHOC(1500),         SURCHG(1500),       SURIC(4,1500),
     I   LINDEX(1500),       MINDEX(1500),       NBCTYP(1500),
     I   NCOLOR(1500),       NDIRN(1500),        NG(605,40)
C       INCLUDE 'COMOUT.inc'
C---------------------------------------------------------------------
CL                  C5.1     Output Variables
       COMMON/COMOUT/
     R   BCNMAX,   BCNMIN,   BCVMAX,   BCVMIN,   CUAMAX,   CUAMIN,
     R   CUEMAX,   CUEMIN,   ECVMAX,   ECVMIN,   TONS1 ,   TONS2 ,
     R   TONS3 ,   TONS4 ,   TONS5 ,   TONS6 ,   TONS7 ,
     I   NBCHT ,   NOPSEL,   NS1   ,   NS2   ,   NS3   ,   NS4   ,
     I   NS5   ,   NS6   ,   NS7
C---------------------------------------------------------------------
C
         IF(KGROUP.EQ.0)GO TO 100
         IF((KGROUP.LT.0).OR.(KGROUP.GT.9))RETURN
         GO TO(100,200,300,400,500,999,999,999,999),KGROUP
C
C---------------------------------------------------------------------
CL              1.         GENERAL OLYMPUS DATA
C
  100    CONTINUE
         IF(KBLOCK.EQ.0)GO TO 101
         GO TO(110,999,999,999,999,999,999,999,190),KBLOCK
  101    CONTINUE
C
CL                  1.1      BLOCK COMBAS
  110    CONTINUE
         CALL PAGE
         CALL BLINES(1)
         CALL  MESAGE(' BLOCK COMBAS                                  ')
         CALL BLINES(1)
         CALL IARRAY('LABEL1  ',LABEL1,12)
         CALL IARRAY('LABEL2  ',LABEL2,12)
         CALL IARRAY('LABEL3  ',LABEL3,12)
         CALL IARRAY('LABEL4  ',LABEL4,12)
         CALL IARRAY('LABEL5  ',LABEL5,12)
         CALL IARRAY('LABEL6  ',LABEL6,12)
         CALL IARRAY('LABEL7  ',LABEL7,12)
         CALL IARRAY('LABEL8  ',LABEL8,12)
         IF(KBLOCK.NE.0)RETURN
C
CL                  1.9      BLOCK COMDDP
  190    CONTINUE
         CALL PAGE
         CALL BLINES(1)
         CALL  MESAGE(' BLOCK COMDDP                                  ')
         CALL BLINES(1)
         CALL IARRAY('NADUMP  ',NADUMP,20)
         CALL IARRAY('NPDUMP  ',NPDUMP,20)
         CALL IARRAY('NVDUMP  ',NVDUMP,20)
         CALL LARRAY('NLHEAD  ',NLHEAD,9)
         CALL LARRAY('NLOMT1  ',NLOMT1,50)
         CALL LARRAY('NLOMT2  ',NLOMT2,50)
         CALL LARRAY('NLOMT3  ',NLOMT3,50)
         IF((KGROUP.NE.0).OR.(KBLOCK.NE.0))RETURN
C
C---------------------------------------------------------------------
CL              2.         PHYSICAL PROBLEM
C
  200    CONTINUE
         IF(KBLOCK.EQ.0)GO TO 201
         GO TO(999,220,230,240,999,999,999,999,999),KBLOCK
  201    CONTINUE
C
CL                  2.2      BLOCK COMSTT
  220    CONTINUE
         CALL PAGE
         CALL BLINES(1)
         CALL  MESAGE(' BLOCK COMSTT                                  ')
         CALL BLINES(1)
         CALL RARRAY('B3      ',B3    ,NXDUM*NYDUM)
         CALL RARRAY('BAV     ',BAV   ,NXDUM*NYDUM)
         CALL RARRAY('CD1     ',CD1   ,NXDUM*NYDUM)
         CALL RARRAY('CD2     ',CD2   ,NXDUM*NYDUM)
         CALL RARRAY('E1      ',E1    ,NXDUM*NYDUM)
         CALL RARRAY('E2      ',E2    ,NXDUM*NYDUM)
         CALL RARRAY('P1      ',P1    ,NPDUM)
         CALL RARRAY('P2      ',P2    ,NPDUM)
         CALL RARRAY('Q1      ',Q1    ,NPDUM)
         CALL RARRAY('Q2      ',Q2    ,NPDUM)
         IF(KBLOCK.NE.0)RETURN
C
CL                  2.3      BLOCK COMDEV
  230    CONTINUE
         CALL PAGE
         CALL BLINES(1)
         CALL  MESAGE(' BLOCK COMDEV                                  ')
         CALL BLINES(1)
         CALL RARRAY('CAVEAM  ',CAVEAM,100)
         CALL RARRAY('CAVEFR  ',CAVEFR,100)
         CALL RARRAY('CAVIC   ',CAVIC ,4*100)
         CALL RARRAY('CAVRES  ',CAVRES,100)
         CALL RARRAY('CAVTC   ',CAVTC ,100)
         CALL IARRAY('NBCCAV  ',NBCCAV,100)
         IF(KBLOCK.NE.0)RETURN
C
CL                  2.4      BLOCK COMDIA
  240    CONTINUE
         CALL PAGE
         CALL BLINES(1)
         CALL  MESAGE(' BLOCK COMDIA                                  ')
         CALL BLINES(1)
         CALL RARRAY('BOUT    ',BOUT  ,NCAV)
         CALL RARRAY('CAVPOY  ',CAVPOY,NCAV)
         CALL RARRAY('EOUT    ',EOUT  ,NCAV)
         CALL IARRAY('LCAVEN  ',LCAVEN,NCAV)
         CALL IARRAY('LCAVST  ',LCAVST,NCAV)
         IF(KBLOCK.NE.0)RETURN
C
C---------------------------------------------------------------------
CL              3.         NUMERICAL SCHEME
C
  300    CONTINUE
         IF(KBLOCK.EQ.0)GO TO 301
         GO TO(999,999,999,999,999,999,999,999,999),KBLOCK
  301    CONTINUE
C
C---------------------------------------------------------------------
CL              4.         HOUSEKEEPING
C
  400    CONTINUE
         IF(KBLOCK.EQ.0)GO TO 401
         GO TO(410,420,999,999,999,999,999,999,999),KBLOCK
  401    CONTINUE
C
CL                  4.1      BLOCK COMHOK
  410    CONTINUE
         CALL PAGE
         CALL BLINES(1)
         CALL  MESAGE(' BLOCK COMHOK                                  ')
         CALL BLINES(1)
         CALL RARRAY('TIMECP  ',TIMECP,32)
         IF(KBLOCK.NE.0)RETURN
C
CL                  4.2      BLOCK COMGEO
  420    CONTINUE
         CALL PAGE
         CALL BLINES(1)
         CALL  MESAGE(' BLOCK COMGEO                                  ')
         CALL BLINES(1)
         CALL RARRAY('ASCUR   ',ASCUR ,NBSEG2)
         CALL RARRAY('CCTSRC  ',CCTSRC,NBSEG2)
         CALL RARRAY('EBEXT   ',EBEXT ,2*NBSEG2)
         CALL RARRAY('ELSCUR  ',ELSCUR,NBSEG2)
         CALL RARRAY('ENSUR   ',ENSUR ,NBSEG2)
         CALL RARRAY('EPOYNT  ',EPOYNT,NBSEG2)
         CALL RARRAY('RHOC    ',RHOC  ,NBSEG2)
         CALL RARRAY('SURCHG  ',SURCHG,NBSEG2)
         CALL RARRAY('SURIC   ',SURIC ,4*NBSEG2)
         CALL IARRAY('LINDEX  ',LINDEX,NBSEG2)
         CALL IARRAY('MINDEX  ',MINDEX,NBSEG2)
         CALL IARRAY('NBCTYP  ',NBCTYP,NBSEG2)
         CALL IARRAY('NCOLOR  ',NCOLOR,NBSEG2)
         CALL IARRAY('NDIRN   ',NDIRN ,NBSEG2)
         CALL IARRAY('NG      ',NG    ,NXDUM*NYDUM)
         IF((KGROUP.NE.0).OR.(KBLOCK.NE.0))RETURN
C
C---------------------------------------------------------------------
CL              5.         I/O AND DIAGNOSTICS
C
  500    CONTINUE
         IF(KBLOCK.EQ.0)GO TO 501
         GO TO(999,999,999,999,999,999,999,999,999),KBLOCK
  501    CONTINUE
C
C---------------------------------------------------------------------
C
  999    CONTINUE
         END
C/ MODULE CGS1
      SUBROUTINE SHADE(BOUNDX,BOUNDY,WORK,NSIDES,ANGLE,ISEP)
C
C          THIS DOES PARALLEL-LINE SHADING WITHIN A POLYGONAL BOUNDARY
C          SPECIFIED BY A SET OF VERTEX CO-ORDINATES. (THE CLOSURE
C          BOUNDARY LINE IS DEFINED BY THE FIRST AND LAST VERTICES).
C
C
C          THE ARGUMENTS ARE AS FOLLOWS:
C
C          [BOUNDX] ARE THE SUCCESSIVE BOUNDARY X-VERTICES.
C          [BOUNDY] ARE THE SUCCESSIVE BOUNDARY Y-VERTICES.
C                   (BOTH ARE OF SIZE <NSIDES>).
C          [WORK]   IS A WORK ARRAY OF SIZE <NSIDES> X 3.
C          <NSIDES> IS THE NO. OF BOUNDARY SIDES.
C          <ANGLE>  IS THE ANGLE OF THE SHADING FROM THE
C                   HORIZONTAL (IN THE CURRENT ANGLE UNITS).
C          <ISEP>   IS THE PERP. DISTANCE BETWEEN SHADING LINES,
C                   AS A NUMBER OF BASIC RESOLUTION UNITS.
C
C
      REAL    BOUNDX(NSIDES),BOUNDY(NSIDES),WORK(NSIDES,3)
      LOGICAL VISIBL
C
      COMMON /T0ACON/ ANGCON
      COMMON /T0MAPA/ X1MAPV,X2MAPV,Y1MAPV,Y2MAPV
      COMMON /T0MAPP/ X1MAP0,X2MAP0,Y1MAP0,Y2MAP0
C
C          THE FOLLOWING IS THE INTERPOLATION FUNCTION:
C
      CROSSY(XR1,YR1,XR2,YR2)= (XR1*(YR2-YR1)/(XR1-XR2))+YR1
C
C          THE FOLLOWING ARE THE FORWARD AND BACKWARD ROTATIONS:
C
      ROTX(X,Y)= (XO-X)*SINA-(YO-Y)*COSA
      ROTY(X,Y)= (XO-X)*COSA+(YO-Y)*SINA
      REROTX(X,Y)= XO-X*SINA-Y*COSA
      REROTY(X,Y)= YO-Y*SINA+X*COSA
C
C
C          IF WINDOWING OR MAPPING ARE WRONG, THE SUBROUTINE ENDS.
C          THE ANGLE IS NORMALISED TO THE RANGE -90.0 TO +90.0 DEGREES,
C          THE TRANSFORMATION CONSTANTS ARE CALCULATED, AND THE
C          START AND END POINTS ARE SET ACCORDING TO THE QUADRANT.
C
      IF (X1MAP0.EQ.X2MAP0.OR.Y1MAP0.EQ.Y2MAP0) RETURN
      IF (X1MAPV.EQ.X2MAPV.OR.Y1MAPV.EQ.Y2MAPV) RETURN
C
      ANGL= ANGLE*ANGCON
      COSA= COS(ANGL)
      SINA= SIN(ANGL)
      IF (COSA.GT.0.0) GO TO 1
      COSA= -COSA
      SINA= -SINA
C
    1 XOFF= AMIN1(X1MAPV,X2MAPV)
      XEND= AMAX1(X1MAPV,X2MAPV)
      IF (SINA.LE.0.0) GO TO 2
      XOFF= AMAX1(X1MAPV,X2MAPV)
      XEND= AMIN1(X1MAPV,X2MAPV)
C
    2 YOFF= AMIN1(Y1MAPV,Y2MAPV)
      YEND= AMAX1(Y1MAPV,Y2MAPV)
      XO= XOFF
      YO= YOFF
C
C          ALL THE VERTEX CO-ORDINATES ARE ROTATIONALLY TRANSFORMED.
C
      DO 10 IROT= 1,NSIDES
        WORK(IROT,1)= ROTX(BOUNDX(IROT),BOUNDY(IROT))
        WORK(IROT,2)= ROTY(BOUNDX(IROT),BOUNDY(IROT))
   10 CONTINUE
C
C          LOOP-20 DOES EACH SHADE LINE IN TURN.
C          LOOP-30 SEARCHES EVERY BOUNDARY SIDE FOR
C          A CROSSOVER POINT, AND WHERE ONE EXISTS,
C          LOOP-40 SORTS IT DOWN THE ORDERED LIST OF
C          CROSSOVER-POINT YR-VALUES BY REPEATED SWAPS.
C
C          IF REL. X-POSITIONS HAVE THE SAME SIGN, THEN NO
C          CROSSOVER POINT EXISTS ON THIS BOUNDARY LINE.
C          IF THE SHADE LINE INTERSECTS A VERTEX, THE LINE
C          IS SIDESTEPPED SLIGHTLY TO GIVE CORRECT TESTING.
C
      XREND= ROTX(XEND,YEND)
      RESOLU= 0.001*ABS(XREND)
      DXR= ISEP*RESOLU
      NLINES= ABS((XREND-0.000001)/DXR)
      DO 20 LINE= 1,NLINES
        XR= DXR*LINE
        NCROSS= 0
        DO 30 ISIDE= 1,NSIDES
          IEND1= ISIDE
          IEND2= ISIDE+1
          IF (IEND2.GT.NSIDES) IEND2= 1
          XR1= WORK(IEND1,1)-XR
          XR2= WORK(IEND2,1)-XR
          IF (XR1.EQ.0.0.AND.XR2.EQ.0.0) GO TO 30
          IF (XR1*XR2.GT.0.0)            GO TO 30
          IF (XR1*XR2.LT.0.0)            GO TO 3
          SIDSTP= XR1
          IF (SIDSTP.EQ.0.0) SIDSTP= XR2
          IF (SIDSTP.GT.0.0)             GO TO 30
          SIDSTP= 1.0E-06*SIDSTP
          XR1= XR1+SIDSTP
          XR2= XR2+SIDSTP
    3     YR1= WORK(IEND1,2)
          YR2= WORK(IEND2,2)
          YR= CROSSY(XR1,YR1,XR2,YR2)
          LIMIT= NCROSS
          NCROSS= NCROSS+1
          WORK(NCROSS,3)= YR
          IF (NCROSS.EQ.1)               GO TO 30
          DO 40 ISORT= 1,LIMIT
            LEVEL= NCROSS-(ISORT-1)
            VALUHI= WORK(LEVEL  ,3)
            VALULO= WORK(LEVEL-1,3)
            IF (VALUHI.GE.VALULO)        GO TO 30
            WORK(LEVEL  ,3)= VALULO
            WORK(LEVEL-1,3)= VALUHI
   40     CONTINUE
   30   CONTINUE
C
C          IF THERE ARE NO CROSSOVER POINTS, THE NEXT SHADE LINE
C          IS BEGUN; OTHERWISE, THE PRESENT LINE RUNS THROUGH ALL
C          THE CROSSOVER POINTS (IN ORDER), ALTERNATING IN VISIBILITY.
C          IF THE DISTANCE BETWEEN TWO CONSECUTIVE CROSSOVER POINTS
C          IS LESS THAN THE SET RESOLUTION, BOTH ARE IGNORED.
C
        IF (NCROSS.LE.0)                 GO TO 20
        VISIBL= .FALSE.
        IDRAW= 0
    4     IDRAW= IDRAW+1
          IF (IDRAW.GT.NCROSS)           GO TO 20
          YR= WORK(IDRAW,3)
          IF (IDRAW.EQ.NCROSS)           GO TO 5
          YRNEXT= WORK(IDRAW+1,3)
          DIFRAC= (YRNEXT-YR)/RESOLU
          IF (DIFRAC.GT.1.0)             GO TO 5
          IDRAW= IDRAW+1
          GO TO 4
C
    5     X= REROTX(XR,YR)
          Y= REROTY(XR,YR)
          IF (.NOT.VISIBL) CALL POSITN(X,Y)
          IF (VISIBL)      CALL JOIN(X,Y)
          VISIBL= .NOT.VISIBL
          GO TO 4
   20 CONTINUE
C
      END
C
C/ MODULE CGS3
C
         SUBROUTINE SEGPLT(POS,PVAL,PHTS,K1,K2)
C
C     G.3 Plot contours on triangular segment
C     used by Ghost emulator of tv80 routine <q7plot>
C-----------------------------------------------------------------------
       DIMENSION
     +   POS(2,3), PVAL(3),  ZX1(2,256),         ZX2(2,256),
     +   IBAND(3), IHITE(256),         PHTS(2)
C
C-----------------------------------------------------------------------
CL              1.         Locate bands of nodes
C
         ILWB = 1
         IUPB = MIN0(128,K1)
C
         DO 101 JN = 1,3
         DO 100 JHT = ILWB,IUPB
         IF(PVAL(JN).GT.PHTS(JHT)) GO TO 100
         IBAND(JN) = JHT
         GO TO 101
  100    CONTINUE
         IBAND(JN) = IUPB + 1
  101    CONTINUE
C
C-----------------------------------------------------------------------
CL              2.         Find contour-element intersections
C
         INTS = 0
         DO 223 J1 = 1,2
         I1 = J1 + 1
         DO 223 J2 = I1,3
C
CL                  2.1      No intersection
         IF(IBAND(J1).EQ.IBAND(J2)) GO TO 223
C
CL                  2.2      Add intersection to table
         ILOW = J1
         IHIG = J2
         IF(IBAND(J1).LT.IBAND(J2) ) GO TO 220
         ILOW = J2
         IHIG = J1
  220    CONTINUE
C
         IBL = IBAND(ILOW)
         IBU = IBAND(IHIG) - 1
         ZDHT = PVAL(IHIG) - PVAL(ILOW)
C
         DO 222 JINTS = IBL,IBU
         INTS = INTS + 1
         IHITE(INTS) = JINTS
         ZFRAC=AMIN1(AMAX1((PHTS(JINTS)-PVAL(ILOW))/ZDHT,0.0),1.0)
C
         DO 221 JC = 1,2
         ZX1(JC,INTS) = POS(JC,ILOW) +
     +   (POS(JC,IHIG)-POS(JC,ILOW)) * ZFRAC
  221    CONTINUE
  222    CONTINUE
  223    CONTINUE
C
C-----------------------------------------------------------------------
CL              3.         Pair up intersections
C
         I = 1
  300    J = I
C
         IF(I.GE.INTS) GO TO 311
  301    J = J + 1
         IF(IHITE(I).NE.IHITE(J)) GO TO 301
C
CL                  3.1      Pair found
         DO 310 JC = 1,2
         ZX2(JC,I) = ZX1(JC,J)
  310    ZX1(JC,J) = ZX1(JC,INTS)
         IHITE(J) = IHITE(INTS)
         INTS = INTS - 1
         I = I + 1
         GO TO 300
  311    CONTINUE
C
C-----------------------------------------------------------------------
CL              4.         Plot contour segments
C
         IF(INTS.EQ.0) GO TO 401
C
         DO 400 JSEG = 1,INTS
         ZXL = ZX1(1,JSEG)
         ZYL = ZX1(2,JSEG)
         ZXR = ZX2(1,JSEG)
         ZYR = ZX2(2,JSEG)
         IF(IHITE(JSEG).LT.K2)CALL BROKEN(4,4,4,4)
         CALL POSITN(ZXL,ZYL)
         CALL JOIN(ZXR,ZYR)
         CALL FULL
  400    CONTINUE
C
  401    CONTINUE
C
C-----------------------------------------------------------------------
         END
C/ MODULE CGS4
C
         SUBROUTINE OKAXES(KAXNO,KMARK)
C
C     AXES WITH SENSIBLE ORIGIN
C     KAXNO = 0 DRAW BOTH AXES
C     KAXNO = 1, 2 DRAW X, Y AXIS ONLY
C     KMARK  MAX NO OF MARKINGS ON AXIS
C-----------------------------------------------------------------------
       DIMENSION
     +   IDATA(3), ZDATA(12),          IDAT2(10),          ZDAT2(9)
         ZEPS=1.E-6
C
C-----------------------------------------------------------------------
CL              1.         set map and origin
C
C     GET MAP AND USE ITS LIMITS
C     TO DETERMINE WHETHER ORIGIN APPEARS
         CALL ENQMAP(IDATA,ZDATA)
         IMAPON=IDATA(2)
         ZTMIN=ZDATA(1)
         ZTMAX=ZDATA(2)
         ZFMIN=ZDATA(3)
         ZFMAX=ZDATA(4)
C     FIX UP IF MIN AND MAX EQUAL
         ZTINCR=0.
         ZFINCR=0.
         IF (ABS(ZTMAX-ZTMIN).LT.ZEPS) ZTINCR=ZEPS
         IF (ABS(ZFMAX-ZFMIN).LT.ZEPS) ZFINCR=ZEPS
         ZT1=ZTMIN-ZTINCR
         ZT2=ZTMAX+ZTINCR
         ZF1=ZFMIN-ZFINCR
         ZF2=ZFMAX+ZFINCR
         ZTAX=ZTMIN
         IF (ZT1*ZT2.LT.ZEPS*(ZT2-ZT1)) ZTAX=0.
         ZFAX=ZFMIN
         IF (ZF1*ZF2.LT.ZEPS*(ZF2-ZF1)) ZFAX=0.
         CALL AXORIG(ZTAX,ZFAX)
C
C-----------------------------------------------------------------------
CL              2.         draw axes
C
C
CL                  2.1      set character size
         CALL ENQCHR(IZAT2,ZDAT2)
         IMAG=IDAT2(2)
         IMAGG=130/KMARK
         CALL CTRMAG(IMAGG)
C
CL                  2.2      plot axes
         CALL OKXXES(KAXNO,KMARK)
C
CL                  2.3      reset magnification
         CALL CTRMAG(IMAG)
C-----------------------------------------------------------------------
         END
C/ MODULE CGS5
C
         SUBROUTINE OKXXES(KAXNO,KMARK)
C
C     ------------------------------------------------
C ROUTINO. ( 192)   VERSION (A6.5)    25:MAR:83
C
C     ------------------------------------------------
C     THIS DRAWS AXES WITH (OPTIONAL) ANNOTATION,
C     SETTING THE AXES INTERVALS AUTOMATICALLY.
C     [X-LINEAR, Y-LINEAR MARKING].
C**
C     KAXNO=0 DRAW BOTH AXES
C     KAXNO=1, 2 DRAW X, Y AXIS ONLY (WA 31/7/85)
C**
       REAL        RDATA(1)
       INTEGER     IDATA(1)
C
       COMMON /T0APOS/       AXPOSX,   AXPOSY
       COMMON /T0CDIM/       MAGN0,    OBLAT0
       COMMON /T0CSPA/       X1CHR0,   X2CHR0,   Y1CHR0,   Y2CHR0
       COMMON /T0MAPP/       X1MAP0,   X2MAP0,   Y1MAP0,   Y2MAP0
       COMMON /T0MAPT/       MAPNO0
       COMMON /T0PPOS/       XPLOT0,   YPLOT0
       COMMON /T0TRAC/       IPRINT
       COMMON /T0WNDO/       X1WND0,   X2WND0,   Y1WND0,   Y2WND0
C
       DATA        RDATA /0.0/
C
C
         IF (IPRINT.EQ.1) CALL G0MESG(70,0)
C
C     IF THE WINDOW AREA OR THE X-MAPPING IS WRONG,
C     NOTHING MORE IS DONE. OTHERWISE, THE CURRENT
C     CHAR. MAGNIFICATION IS SAVED AND A SUITABLE
C     NEW ONE CALCULATED, THE CURRENT CHAR.-SPACE
C     ARGUMENTS ARE KEPT AND C-SPACE IS SWITCHED OFF,
C     THEN THE CURRENT PLOTTING POSITION IS STORED.
C
         IF (X1WND0.EQ.X2WND0.OR.Y1WND0.EQ.Y2WND0)     RETURN
         IF (X1MAP0.EQ.X2MAP0)                         RETURN
C
         FRACWD= (X2WND0-X1WND0)/(X2MAP0-X1MAP0)
         IF (MAPNO0.LE.2) GO TO 1
         IF (SIGN(1.0,X1WND0)*SIGN(1.0,X2WND0).LE.0.0) RETURN
         IF (SIGN(1.0,X1MAP0)*SIGN(1.0,X2MAP0).LE.0.0) RETURN
         FRACWD= ALOG10(X2WND0/X1WND0)/ALOG10(X2MAP0/X1MAP0)
C
    1    IPRSAV= IPRINT
         IPRINT= 0
         MAGSAV= MAGN0
         MAG= MAGN0*ABS(FRACWD)+0.00001
         IF (MAG.LE.10)   MAG=10
         IF (MAG.GT.100) MAG= 100
         CALL CTRMAG(MAG)
C
         XCSAV1= X1CHR0
         XCSAV2= X2CHR0
         YCSAV1= Y1CHR0
         YCSAV2= Y2CHR0
         CALL CSPACE(0.0,0.0,0.0,0.0)
C
         XHERE= XPLOT0
         YHERE= YPLOT0
C
C     FOR EACH AXIS IN TURN, THE POSITION IS SET APPROPRIATELY
C     WITHIN THE CURRENT WINDOW, THE TICK MARK POSITIONS
C     AND END POINTS ARE CALCULATED, THEN THE AXIS IS DRAWN.
C
         IDATA(1)= 1
         CALL G3LINK(0,14,-1,IDATA,RDATA)
         IF (KAXNO.EQ.2) GO TO 2
C
         AXPOSX= 0.0
         IF (SIGN(1.0,Y1WND0)*SIGN(1.0,Y2WND0).GT.0.0) AXPOSX= Y1WND0
         CALL GMDIVS(-1,0.0,KMARK)
         CALL G0TICK
         CALL G0PLAX(1)
         IF (KAXNO.EQ.1) GO TO 3
C
    2    AXPOSY= 0.0
         IF (SIGN(1.0,X1WND0)*SIGN(1.0,X2WND0).GT.0.0) AXPOSY= X1WND0
         CALL GMDIVS(-2,0.0,KMARK)
         CALL G0TICK
         CALL G0PLAY(1)
C
    3    IDATA(1)= 0
         CALL G3LINK(0,14,-1,IDATA,RDATA)
C
C     FINALLY, THE PREVIOUS CHARACTER MAGNIFICATION,
C     CHAR.-SPACE AND PLOTTING POSITION ARE RESTORED.
C
         CALL CTRMAG(MAGSAV)
         CALL CSPACE(XCSAV1,XCSAV2,YCSAV1,YCSAV2)
         CALL POSITN(XHERE,YHERE)
         IPRINT= IPRSAV
C
         END
C
C/ MODULE CGS6
C
         SUBROUTINE GMDIVS(IAXIS,DIVLEN,KMARK)
C
C     ------------------------------------------------
C ROUTINO. ( 231)   VERSION (A6.7)    25:MAR:83
C
C     ------------------------------------------------
C     THIS FINDS THE POSITIONS OF THE INTERVALS ON THE GIVEN AXIS
C     (FOR LIN. SCALING) WHICH LIE WITHIN THE CURRENT WINDOW AREA,
C     AND ALSO SETS THE MOST SUITABLE AXIS ANNOTATION FORMAT.
C     <IAXIS> GIVES THE REQUIRED AXIS BY ITS MODULUS:
C     = 1, THE X-AXIS IS TAKEN, OR
C     = 2, THE Y-AXIS IS TAKEN.
C     <DIVLEN> GIVES THE REQUIRED INTERVAL LENGTH.
C     THE FOLLOWING ARGUMENTS ARE SUPPLIED THROUGH COMMON:
C     <X1WND0>    THE COORDINATES
C     <X2WND0>    OF
C     <Y1WND0>    THE
C     <Y2WND0>    WINDOW RECTANGLE.
C     <AXPOSX> THE POSITION OF THE X-AXIS ALONG Y.
C     <AXPOSY> THE POSITION OF THE Y-AXIS ALONG X.
C     <NOTATA> IF ZERO, NO ANNOTATION IS REQUIRED,
C     IF NON-ZERO, ANNOT. FORMAT MUST BE CALCULATED.
C     THE FOLLOWING ARGUMENTS ARE RETURNED THROUGH COMMON:
C     (ONLY THE ARGS. RELEVANT TO THE GIVEN AXIS ARE CHANGED):
C     <KTYPEX> IS THE X-AXIS TYPE (= 1 FOR LIN. AXIS).
C     <KTYPEY> IS THE Y-AXIS TYPE (= 1 FOR LIN. AXIS).
C     <DIVLX>  IS THE X-AXIS SUB-INTERVAL LENGTH.
C     <DIVLY>  IS THE Y-AXIS SUB-INTERVAL LENGTH.
C     <NSKIPX> IS THE NO. OF SUB-INTERVALS PER MAJOR INTERVAL IN X.
C     <NSKIPY> IS THE NO. OF SUB-INTERVALS PER MAJOR INTERVAL IN Y.
C     <NTIKLX> IS THE MARKING START-POINT FOR THE X-AXIS.
C     <NTIKLY> IS THE MARKING START-POINT FOR THE Y-AXIS.
C     <NTIKHX> IS THE MARKING END-  POINT FOR THE X-AXIS.
C     <NTIKHY> IS THE MARKING END-  POINT FOR THE Y-AXIS.
C     <NDECSX> IS THE X-AXIS ANNOTATION BASIS-EXPONENT.
C     <NDECSY> IS THE Y-AXIS ANNOTATION BASIS-EXPONENT.
C     <NCHRSX> IS THE NO. OF CHARS. IN X-AXIS ANNOTATION.
C     <NCHRSY> IS THE NO. OF CHARS. IN Y-AXIS ANNOTATION.
C     <NAFTPX> IS THE NO. OF CHARS. AFTER THE DEC. PT. IN X.
C     <NAFTPY> IS THE NO. OF CHARS. AFTER THE DEC. PT. IN Y.
C     <KANNX>  GIVES THE X-AXIS ANNOTATION TYPE, AND
C     <KANNY>  GIVES THE Y-AXIS ANNOTATION TYPE, AS FOLLOWS:
C     = 1, IT IS INTEGER
C     = 2, IT IS REAL,
C     = 3, IT IS INTEGER WITH MULT. FACTOR.
C     = 4, IT IS REAL    WITH MULT. FACTOR.
C     <KAXIS>  IS SET BY <IAXIS> FOR SUBSEQUENT USE.
       LOGICAL     DONE
C
       COMMON /T0AARG/       KAXIS
       COMMON /T0ADIX/       DIVLX,    NTIKLX,   NTIKHX
       COMMON /T0ADIY/       DIVLY,    NTIKLY,   NTIKHY
       COMMON /T0ANOX/       KANNX,    NCHRSX,   NAFTPX
       COMMON /T0ANOY/       KANNY,    NCHRSY,   NAFTPY
       COMMON /T0ASKX/       NSKIPX,   NDECSX
       COMMON /T0ASKY/       NSKIPY,   NDECSY
       COMMON /T0ATYP/       KTYPEX,   KTYPEY
       COMMON /T0NOTA/       NOTATA
       COMMON /T0WNDO/       X1WND0,   X2WND0,   Y1WND0,   Y2WND0
C
       DATA        LIMSIG /5/
C
C
C     THE AXIS TYPE IS SET AND THE END POINTS ARE FOUND.
C
         KAXIS= IAXIS
C
         ENDMIN= AMIN1(X1WND0,X2WND0)
         ENDMAX= AMAX1(X1WND0,X2WND0)
         IF (IEBS(KAXIS).EQ.1) GO TO 1
         ENDMIN= AMIN1(Y1WND0,Y2WND0)
         ENDMAX= AMAX1(Y1WND0,Y2WND0)
C
C     THE NO. OF STEPS IN THE WINDOW AT THE GIVEN INTERVAL SIZE
C     IS FOUND, AND IF THIS IS > 1000, THE INTERVAL LENGTH IS
C     INCREASED BY A SUITABLE FACTOR OF 10 TO GIVE < 999 STEPS.
C     A LIMIT OF 100 SUB-INTERVALS IS THEN SET, AND THE ACTUAL
C     SUB-INTERVAL LENGTH TO BE USED IS HENCE CALCULATED. IF
C     THE GIVEN STEP SIZE IS ZERO, A START INTERVAL-LENGTH OF
C     A SUITABLE POWER OF 10 IS CHOSEN TO GIVE APPROX. 13 SUB-
C     DIVISIONS, AND THE SUB-INTERVAL LIMIT IS SET ALSO AT KMARK.
C**
C      LIMIT ALTERED TO CHANGE NUMBER OF ANNOTATIONS TO KMARK (WA 31/7/8
C     ALSO FIXED SO THAT LIMIT ANNOTATIONS PRODUCED (FORMERLY LIMIT+1)
C**
C
    1    DIVSIZ= ABS(DIVLEN)
         IF (DIVSIZ.LE.0.0) GO TO 3
C
         STEPS= (ENDMAX-ENDMIN)/DIVSIZ
         IF (STEPS.LT.1.0E3) GO TO 2
         EXP= ALOG10(STEPS)
         IF (EXP.LT.0.0) EXP= EXP-1.0
         DIVSIZ= DIVSIZ*(10.0**(INT(EXP)-2))
    2    LIMIT= 100
         GO TO 4
C
    3    DIVSIZ= (ENDMAX-ENDMIN)/13.0
         EXP= ALOG10(DIVSIZ)
         IF (EXP.LT.0.0) EXP= EXP-1.0
         DIVSIZ= 10.0**INT(EXP)
         LIMIT= KMARK
C
C     THIS SECTION CALCULATES THE INITIAL EDGE POINTS,
C     ROUNDING-OFF ALWAYS IN THE CORRECT DIRECTION.
C     (UNCHANGED - ROUND BOTTOM UP, TOP DOWN, WA)
C
    4    ROUND= 0.999
         IF (ENDMIN.LT.0.0) ROUND= -0.001
         NLO= (ENDMIN/DIVSIZ)+ROUND
         ROUND= -0.999
         IF (ENDMAX.GT.0.0) ROUND= 0.001
         NHI= (ENDMAX/DIVSIZ)+ROUND
         IDIV= 1
         IDEC= 1
         DONE= .FALSE.
C
C     THIS PART INCREASES THE INTERVAL SIZE BY FACTORS OF
C     2, 5, 10, ETC. UNTIL THE GIVEN LIMIT IS SATISFIED.
C
    5    IFACT= IDIV*IDEC
         NLONOW= NLO
         IF (NLO.GT.0) NLONOW= NLONOW+IFACT-1
         NLONOW= NLONOW/IFACT
         NHINOW= NHI
         IF (NHI.LT.0) NHINOW= NHINOW-IFACT+1
         NHINOW= NHINOW/IFACT
C
         IF ((NHINOW-NLONOW+1).LE.LIMIT) GO TO 8
C
         IF (IDIV.NE.1) GO TO 6
         IDIV= 2
         GO TO 5
    6    IF (IDIV.NE.2) GO TO 7
         IDIV= 5
         GO TO 5
    7    IDIV= 1
         IDEC= IDEC*10
         GO TO 5
C
C     WHEN THE SUB-INTERVAL LIMIT HAS BEEN SATISFIED, THE
C     NEW VALUES ARE STORED, AND THE PROCESS IS REPEATED
C     WITH A LIMIT VALUE OF KMARK TO FIND THE MAJOR INTERVALS.
C
    8    IF (DONE) GO TO 9
         DONE= .TRUE.
         NLO= NLONOW
         NHI= NHINOW
         DIVSIZ= DIVSIZ*IFACT
         IDIV= 1
         IDEC= 1
         LIMIT= KMARK
         GO TO 5
C
C     ONCE THE VALUES HAVE BEEN FOUND, THEY ARE PLACED
C     INTO THE APPROPRIATE VARIABLES IN THE COMMON BLOCK.
C
    9    IF (IEBS(KAXIS).EQ.2) GO TO 10
         KTYPEX= 1
         DIVLX= DIVSIZ
         NTIKLX= NLO
         NTIKHX= NHI
         NSKIPX= IFACT
         GO TO 11
C
   10    KTYPEY= 1
         DIVLY= DIVSIZ
         NTIKLY= NLO
         NTIKHY= NHI
         NSKIPY= IFACT
C
C     IF <NOTATA> IS NON-ZERO AND THERE ARE TICK MARKS
C     TO ANNOTATE, THE NUMBER FORMAT IS CALCULATED BELOW:
C
   11    IF (NOTATA.EQ.0)  RETURN
         NCHARS= 1
         KANNOT= 1
         IF (NHI-NLO.LT.0) GO TO 16
C
C     FIRST THE MAJOR INTERVAL SIZE IS CALCULATED, THEN
C     THE MAXIMUM AND MINIMUM POSITION VALUES ARE FOUND.
C
         STPSIZ= DIVSIZ*IFACT
         TIKMAX= ABS((NHI/IFACT)*STPSIZ)
         TIKMIN= ABS((NLO/IFACT)*STPSIZ)
         IF (TIKMAX.GE.TIKMIN) GO TO 12
         TIKMAX= TIKMIN
         TIKMIN= ABS((NHI/IFACT)*STPSIZ)
   12    IF (TIKMIN.LT.STPSIZ)      TIKMIN= STPSIZ
         IF (NLO.GT.0.AND.NHI.LT.0) TIKMIN= STPSIZ
         IF (NLO.LT.0.AND.NHI.GT.0) TIKMIN= STPSIZ
C
C     THE EXPONENT AND NO. OF SIG. DIGITS ARE FOUND FOR
C     BOTH THE LARGEST VALUE AND THE INTERVAL, AND
C     THESE ARE COMBINED TO GIVE THE NUMBER CONSTANTS.
C     IF NUMSIG > LIMSIG, THE NUMBER IS TRUNCATED;
C     IF NUMEXP >= LIMSIG, OVERFLOW HAS OCCURRED;
C     IF NAFTDP > LIMSIG, UNDERFLOW HAS OCCURRED;
C     IF NAFTDP <= 0, THE FORMAT IS INTEGER.
C
         CALL G0SIZS(TIKMAX,LIMSIG,MAXEXP,MAXSIG)
         INTEXP= MAXEXP
         INTSIG= 0
         IF (STPSIZ.LE.TIKMAX) CALL G0SIZS(STPSIZ,LIMSIG,INTEXP,INTSIG)
         NAFTDP= INTSIG-INTEXP
         NUMEXP= MAXEXP
         NUMSIG= MAXSIG
         IF (NAFTDP.GT.MAXSIG-MAXEXP) NUMSIG= NUMEXP+NAFTDP
         IF (NUMSIG.GT.LIMSIG)        NUMSIG= LIMSIG
         NAFTDP= NUMSIG-NUMEXP-1
         IF (NAFTDP.LT.0) NAFTDP= 0
         NCHARS= NUMSIG+2
         IF (NUMEXP.GE.LIMSIG) GO TO 14
         IF (NAFTDP.GT.LIMSIG) GO TO 14
         NDECS= 0
         IF (NAFTDP.GT.0)      GO TO 13
C
C     THE FOLLOWING SECTIONS SET ANNOTATION TYPES
C     INTEGER AND REAL RESP., WITHOUT SCALING FACTOR.
C
         NCHARS= MAXEXP+2
         NAFTDP= 0
         KANNOT= 1
         GO TO 16
C
   13    IF (NUMEXP.LT.0) NCHARS= NAFTDP+3
         KANNOT= 2
         GO TO 16
C
C     THE FOLLOWING SECTIONS SET ANNOTATION TYPES
C     INTEGER AND REAL RESP., WITH A SCALING FACTOR.
C     THIS FACTOR IS GIVEN BY THE EXPONENT OF THE
C     MINIMUM (NON-ZERO) ABSOLUTE POSITION VALUE.
C
   14    CALL G0SIZS(TIKMIN,LIMSIG,MINEXP,MINSIG)
         NDECS= MINEXP
         NAFTDP= MINEXP-NUMEXP+NUMSIG-1
         IF (NAFTDP.GT.0) GO TO 15
C
         NCHARS= MAXEXP-MINEXP+2
         NAFTDP= 0
         KANNOT= 3
         GO TO 16
C
   15    KANNOT= 4
C
C     THE APPROPRIATE VALUES IN THE COMMON BLOCK
C     ARE THEN UPDATED, AND THE SUBROUTINE ENDS.
C
   16    IF (IEBS(KAXIS).EQ.2) GO TO 17
         NCHRSX= NCHARS
         NAFTPX= NAFTDP
         KANNX= KANNOT
         NDECSX= NDECS
         RETURN
C
   17    NCHRSY= NCHARS
         NAFTPY= NAFTDP
         KANNY= KANNOT
         NDECSY= NDECS
C
         END
C/ MODULE c5s1
C
         SUBROUTINE REPORT(KCLASS,KSUB,KPOINT)
C
C 5.1  CONTROL THE DIAGNOSTICS
C
C-----------------------------------------------------------------------
C
         CALL DUMCOM(KCLASS,KSUB,KPOINT)
C
         END
C/ MODULE cus15
C
         SUBROUTINE RESETI(KA,KDIM,KVALUE)
C
C U.15 RESET INTEGER ARRAY TO SPECIFIED VALUE
C
C-----------------------------------------------------------------------
       DIMENSION   KA(KDIM)
C-----------------------------------------------------------------------
C
         DO 1 J=1,KDIM
         KA(J) = KVALUE
    1    CONTINUE
C
         END
C/ MODULE cus14
C
         SUBROUTINE RESETR(PA,KDIM,PVALUE)
C
C U.14 RESET REAL ARRAY TO SPECIFIED VALUE
C
C-----------------------------------------------------------------------
       DIMENSION   PA(KDIM)
C-----------------------------------------------------------------------
C
         DO 1 J=1,KDIM
         PA(J) = PVALUE
    1    CONTINUE
C
         END
C/ MODULE c0s4
C
         SUBROUTINE EXPERT(KCLASS,KSUB,KPOINT)
C
C 0.4  MODIFY STANDARD OPERATION OF PROGRAM
C
C       INCLUDE 'COMDDP.inc'
C--------------------------------------------------------------------
CL                  C1.9.    DEVELOPMENT AND DIAGNOSTIC PARAMETERS
       COMMON/COMDDP/
     I   MAXDUM,   MXDUMP,   NADUMP,   NCLASS,   NPDUMP,   NPOINT,
     I   NSUB,     NVDUMP,
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       LOGICAL
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       DIMENSION
     I   NADUMP(20),         NPDUMP(20),         NVDUMP(20),
     L   NLHEAD(9),          NLOMT1(50),         NLOMT2(50),
     L   NLOMT3(50)
C-----------------------------------------------------------------------
C
C     SET TRACER VARIABLES
         NCLASS = KCLASS
         NSUB = KSUB
         NPOINT = KPOINT
C
C     ARE DIAGNOSTICS REQUIRED ?
         IF(NLREPT) CALL REPORT(KCLASS,KSUB,KPOINT)
C
         END
C/ MODULE C1S10
C
         SUBROUTINE SETBOX(KLMAX2,KMMAX2,KXDIM,KNG,KNBSP2,
     +   KL,KM,KDIR,KNBDIM)
C
C 1.10 define geometry and boundary arrays for rectangular comp. box
C
C---------------------------------------------------------------------
C. Input KLMAX2 lmax+2
C.       KMMAX2 mmax+2
C.       KXDIM x dimension of geometry array
C.       KNBDIM  dimension of bounday table array
C.
C.Output KNG geometry array
C.       on a mesh KLMAX2 * KMMAX2
C.       KL x index of surface element
C.       KM y index of surface element
C.       KDIR diection index of surface element
C.       KNBSP2 no of surface elements + 2
C.
C---------------------------------------------------------------------
       DIMENSION
     +   KNG(KXDIM,*),       KL(KNBDIM),         KM(KNBDIM),
     +   KDIR(KNBDIM)
C
C---------------------------------------------------------------------
CL              1.         initialise geometry array
C
         ILMAXP=KLMAX2-1
         ILMAX =ILMAXP-1
         IMMAXP=KMMAX2-1
         IMMAX =IMMAXP-1
C
CL                  1.1      interior
         DO 110 JM=2,IMMAX
         DO 110 JL=2,ILMAX
         KNG(JL,JM)=0
  110    CONTINUE
C
CL                  1.2      guard cells
C     left and right ends
         DO 120 JM=1,IMMAXP
         KNG(1,JM)=1
         KNG(ILMAXP,JM)=1
  120    CONTINUE
C     top and bottom
         DO 121 JL=1,ILMAXP
         KNG(JL,IMMAXP)=1
         KNG(JL,1)=1
  121    CONTINUE
C
CL                  1.3      dummy first element of surface table
         INBSEG=1
         KL(1)=1
         KM(1)=1
         KDIR(1)=0
C
C---------------------------------------------------------------------
CL              2.         rectangular box surface
C
C     along the top
         DO 200 JL=2,ILMAX
         INBSEG=INBSEG+1
         KL(INBSEG)=JL
         KM(INBSEG)=IMMAXP
         KDIR(INBSEG) =2
C
         KNG(JL,IMMAXP) = INBSEG
         KNG(JL,IMMAX ) =-INBSEG
  200    CONTINUE
C     along rh end
         DO 201 JM=IMMAXP,3,-1
         INBSEG=INBSEG+1
         KL(INBSEG)=ILMAXP
         KM(INBSEG)=JM
         KDIR(INBSEG) =3
C
         KNG(ILMAXP,JM-1) = INBSEG
         KNG(ILMAX ,JM-1) =-INBSEG
  201    CONTINUE
C     along the bottom
         DO 202 JL=ILMAXP,3,-1
         INBSEG=INBSEG+1
         KL(INBSEG)=JL
         KM(INBSEG)=2
         KDIR(INBSEG) =4
C
         KNG(JL-1,1) = INBSEG
         KNG(JL-1,2) =-INBSEG
  202    CONTINUE
C     along lh end
         DO 203 JM=2,IMMAX
         INBSEG=INBSEG+1
         KL(INBSEG)=2
         KM(INBSEG)=JM
         KDIR(INBSEG) =1
C
         KNG(1,JM) = INBSEG
         KNG(2,JM) =-INBSEG
  203    CONTINUE
C
C---------------------------------------------------------------------
CL              3.         wrap around
C
         DO 300 J=2,3
         INBSEG=INBSEG+1
         KL(INBSEG)=KL(J)
         KM(INBSEG)=KM(J)
         KDIR(INBSEG)=KDIR(J)
  300    CONTINUE
         KNBSP2=INBSEG
C---------------------------------------------------------------------
         END
C/ MODULE C1S13
C
         SUBROUTINE ESRCIN(PEX,PEY,PBZ,KXDIM,
     +                     KNBSP2,KL,KM,KDIR,KBCTYP,PEBEXT)
C
C 1.13 Initialise surface B to be consistent with surface E
C
C---------------------------------------------------------------------
C. Input PEX at timelevel n
C.       PEY at timelevel n
C.       PBZ at timelevel n-1/2
C.       on a mesh KLMAX2 * KMMAX2
C.       KXDIM is dimension of first arg.
C.       KL x index of surface element
C.       KM y index of surface element
C.       KDIR diection index of surface element
C.       KBCTYP surface element bc selector (0,1, etc)
C.       PEBEXT applied E (KBCTYP=0) and E-new
C.              or B (KBCTYP=1)
C.       KNBSP2 no of surface elements + 2
C.
C.Output PBZ modified at surface elements
C.
C. Note  PEX and PEY are in units of q*dt/(2*me*c)
C.       PBZ is in units of q*dt/(2*me)
C.       PJX and PJY are in units of mu*(dy,dx)*dt*q/(2*me)
C.
C.       The modifications to PBZ are consistent with the assumption
C.       that the applied E corresponds to an incoming em wave (E=H)
C.       which is steady in time, and that the B (or H) at the surface
C.       is a space average of the neighbouring points B values.
C.       In effect, this routine maps the Cauchy bc on the t=0 surface
C.       onto the active computational domain boundary domain in a
C.       timecentred fashion
C.
C. NOTE: It is assumed the first two boundary segments are repeated at
C.       the end of the table. This allows look ahead (or behind) to
C.       deal with corners. Look ahead is not needed by this
C.       routine.
C.
C---------------------------------------------------------------------
       DIMENSION
     +   PEX(KXDIM,*),       PEY(KXDIM,*),       PBZ(KXDIM,*),
     +   PEBEXT(2,*),     KL(*),         KM(*),
     +   KDIR(*),       KBCTYP(*)
C
C---------------------------------------------------------------------
CL              1.         boundary sweep
C
C
         DO 240 JSEG=4,KNBSP2
         IL = KL(JSEG)
         IM = KM(JSEG)
         IDN= KDIR(JSEG)
         IBC= KBCTYP(JSEG)
C
C---------------------------------------------------------------------
CL              2.         Radiating resistive wall bc
C
         IF (IBC.EQ.4.OR.IBC.EQ.5) THEN
         ZE = PEBEXT(1,JSEG)
C
CL                  2.1      lhs boundary(W)
         IF(IDN.EQ.1) THEN
         PBZ(IL,IM)=ZE + PBZ(IL,IM)
         PEY(IL,IM)=ZE + PEY(IL,IM)
C
CL                  2.2      top boundary(N)
         ELSE IF(IDN.EQ.2) THEN
         PBZ(IL,IM-1)=ZE + PBZ(IL,IM-1)
         PEX(IL,IM)=ZE + PEX(IL,IM)
C
CL                  2.3      rhs boundary(E)
         ELSE IF(IDN.EQ.3) THEN
         PBZ(IL-1,IM-1)=-ZE + PBZ(IL-1,IM-1)
         PEY(IL,IM-1)=ZE + PEY(IL,IM-1)
C
CL                  2.4      bottom boundary(S)
         ELSE
         PBZ(IL-1,IM)=-ZE + PBZ(IL-1,IM)
         PEX(IL-1,IM)=ZE + PEX(IL-1,IM)
         END IF
         ELSE
C     error traps or additional cases can be added here
         END IF
  240    CONTINUE
C---------------------------------------------------------------------
         END
C/ MODULE C1S12
C
         SUBROUTINE EBJCLR(PEX,PEY,PBZ,PJX,PJY,KNG,KXDIM,
     +                     KLMAX2,KMMAX2)
C
C 2.11 clear E, B and J on boundary surface using geometry array
C
C---------------------------------------------------------------------
C. Input PEX at timelevel n
C.       PEY at timelevel n
C.       PJX at timelevel n-1/2
C.       PJY at timelevel n-1/2
C.       PBZ at timelevel n-1/2
C.       KNG grid masking array
C.       on a mesh KLMAX2 * KMMAX2
C.       KXDIM is dimension of first arg.
C.
C. Note  PEX and PEY are in units of q*dt/(2*me*c)
C.       PBZ is in units of q*dt/(2*me)
C.       PJX and PJY are in units of mu*(dy,dx)*dt*q/(2*me)
C.
C. Output: PEX,PJX,PEY,PJY,PBZ zeroed in boundary region
C.
C. NOTE: It is assumed that KNG <=0 in the active region and that
C.       KNG > 0 in the boundary region. In addition, it is assumed
C.       that a guard cell layer at least one cell deep surrounds the
C.       active computational region.
C.
C---------------------------------------------------------------------
       DIMENSION
     +   PEX(KXDIM,*),       PEY(KXDIM,*),       PBZ(KXDIM,*),
     +   PJX(KXDIM,*),       PJY(KXDIM,*),       KNG(KXDIM,*)
C
C---------------------------------------------------------------------
CL              1.         initialise
C
         ILMAXP=KLMAX2-1
         IMMAXP=KMMAX2-1
C
         ILMAX=ILMAXP-1
         IMMAX=IMMAXP-1
C
C---------------------------------------------------------------------
CL              2.         guard cell layer
C
         DO 200 JL=1,KLMAX2
C     bottom
         PEX(JL,1) = 0.
         PJX(JL,1) = 0.
         PEY(JL,1) = 0.
         PJY(JL,1) = 0.
         PBZ(JL,1) = 0.
C     top
         PEX(JL,KMMAX2) = 0.
         PJX(JL,KMMAX2) = 0.
         PEY(JL,IMMAXP) = 0.
         PJY(JL,IMMAXP) = 0.
         PBZ(JL,IMMAXP) = 0.
         PBZ(JL,KMMAX2) = 0.
  200    CONTINUE
C
         DO 201 JM=1,KMMAX2
C     left
         PEX(1,JM) = 0.
         PJX(1,JM) = 0.
         PEY(1,JM) = 0.
         PJY(1,JM) = 0.
         PBZ(1,JM) = 0.
C     right
         PEX(ILMAXP,JM) = 0.
         PJX(ILMAXP,JM) = 0.
         PEY(KLMAX2,JM) = 0.
         PJY(KLMAX2,JM) = 0.
         PBZ(ILMAXP,JM) = 0.
         PBZ(KLMAX2,JM) = 0.
  201    CONTINUE
C
C---------------------------------------------------------------------
CL              3.         active region
C
         DO 301 JM=2,IMMAX
         DO 300 JL=2,ILMAX
C
         IF(KNG(JL,JM).LE.0) GO TO 300
C
C     BZ clear
         PBZ(JL,JM) = 0.
C
C     EY and JY clear
         IF(KNG(JL-1,JM).GT.0) THEN
         PEY(JL,JM) = 0.
         PJY(JL,JM) = 0.
         END IF
C
         IF(KNG(JL+1,JM).GT.0) THEN
         PEY(JL+1,JM) = 0.
         PJY(JL+1,JM) = 0.
         END IF
C
C     EX and JX clear
         IF(KNG(JL,JM-1).GT.0) THEN
         PEX(JL,JM) = 0.
         PJX(JL,JM) = 0.
         END IF
C
         IF(KNG(JL,JM+1).GT.0) THEN
         PEY(JL,JM+1) = 0.
         PJY(JL,JM+1) = 0.
         END IF
C
  300    CONTINUE
  301    CONTINUE
C---------------------------------------------------------------------
         END
C/ MODULE C2S15
C
         SUBROUTINE ERAMP(PEAP,PRZERO,KSTEP,KRAMP,KNBSP2,
     +   KL,KM,KDIR,KBCTYP,PEXT)
C
C 2.15 Ramp up applied E over KRAMP steps use cosine bell
C
C---------------------------------------------------------------------
C. Input PEAP applied E field
C.       PRZERO radius of inner comp. box boundary
C.       KSTEP current step number
C.       KRAMP no of steps of ramp up
C.       KNBDIM  dimension of bounday table array
C.       KL x index of surface element
C.       KM y index of surface element
C.       KDIR diection index of surface element
C.       KKBCTYP bc on surface element
C.       KNBSP2 no of surface elements + 2
C.
C.Output PEXT surface applied electric field
C.       element 1 = old, 2 = new timelevel E field
C.
C---------------------------------------------------------------------
       DIMENSION
     +   KL(KNBSP2),         KM(KNBSP2),         KBCTYP(KNBSP2),
     +   KDIR(KNBSP2),       PEXT(2,KNBSP2)
C
C---------------------------------------------------------------------
CL              1.         compute current r * E field
C
         ZPI2=3.141593/2.0
         ZE=PEAP
         IF(KSTEP.LT.KRAMP)ZE=PEAP*SIN(ZPI2*FLOAT(KSTEP)/FLOAT(KRAMP))*
     +   *2
C
C---------------------------------------------------------------------
CL              2.         update surface arrays
C
         DO 200 JS=1,KNBSP2
C west boundary
         IF(KDIR(JS).EQ.1.AND.KL(JS).EQ.2) THEN
         PEXT(1,JS)=PEXT(2,JS)
         PEXT(2,JS)=ZE/(KM(JS)+PRZERO-1.5)
         END IF
C north boundary
C        IF(KDIR(JS).EQ.2)  PEXT(1,JS)=PEXT(2,JS)
C        IF(KDIR(JS).EQ.2)  PEXT(2,JS)=ZE
  200    CONTINUE
C---------------------------------------------------------------------
         END
C/ MODULE cus17
C
         SUBROUTINE JOBTIM(PTIME)
C
C U.17 FETCH ALLOCATED JOBTIME (SECS)
C
C-----------------------------------------------------------------------
C
C     CALL MESAGE('JOBTIM is not implemented:100,000 returned')
         PTIME = 100000.
C
         END
C/ MODULE cus27
C
         SUBROUTINE DUMCOM(KCLASS,KSUB,KPOINT)
C
C U.27 DUMP SELECTED COMMON BLOCKS
C
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C       INCLUDE 'COMDDP.inc'
C--------------------------------------------------------------------
CL                  C1.9.    DEVELOPMENT AND DIAGNOSTIC PARAMETERS
       COMMON/COMDDP/
     I   MAXDUM,   MXDUMP,   NADUMP,   NCLASS,   NPDUMP,   NPOINT,
     I   NSUB,     NVDUMP,
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       LOGICAL
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       DIMENSION
     I   NADUMP(20),         NPDUMP(20),         NVDUMP(20),
     L   NLHEAD(9),          NLOMT1(50),         NLOMT2(50),
     L   NLOMT3(50)
C-----------------------------------------------------------------------
       LOGICAL     ILREPT
       DIMENSION   IDIGIT(8)
       DATA        IDMAX/8/, ILREPT/.TRUE./
C
C-----------------------------------------------------------------------
CL              1.         INITIALIZE AND PRINT STEP NUMBER
C
         ICODE = 10000 * KCLASS + 100 * KSUB + KPOINT
         IF(ICODE.NE.20101) GO TO 100
         CALL BLINES(1)
         CALL IVAR('STEP    ',NSTEP)
         CALLMESAGE('********************                         '  )
  100    CONTINUE
         IF(KCLASS.NE.0) GO TO 101
         IF(NLCHED) GO TO 102
         GO TO 200
C
  101    IF(.NOT.NLHEAD(KCLASS))GO TO 200
  102    CALL REPTHD(KCLASS,KSUB,KPOINT)
         ILREPT=.FALSE.
C
C-----------------------------------------------------------------------
CL              2.         SCAN OVER LIST
C
  200    CONTINUE
         DO 800 J=1,MXDUMP
         IF(NPDUMP(J).NE.ICODE) GO TO 800
C
C-----------------------------------------------------------------------
CL              3.         DUMPING POINT FOUND
C
C     PRINT HEADING ONLY ONCE
         IF(ILREPT)CALL REPTHD(KCLASS,KSUB,KPOINT)
         ILREPT=.FALSE.
C
C-----------------------------------------------------------------------
CL              4.         ARE VARIABLES TO BE DUMPED
C
         I=1
         ID=NVDUMP(J)
         IF(ID.EQ.0)GO TO 500
         IF(ID.NE.100)GO TO 600
         CALL CLIST(0,0)
C
C-----------------------------------------------------------------------
CL              5.         ARE ARRAYS TO BE DUMPED
C
  500    CONTINUE
         I=2
         ID=NADUMP(J)
         IF(ID.EQ.0)GO TO 800
         IF(ID.NE.100)GO TO 600
         CALL ARRAYS(0,0)
         GO TO 800
C
C-----------------------------------------------------------------------
CL              6.         DISENTANGLE CODE
C
  600    CONTINUE
         CALL RESETI(IDIGIT,IDMAX,0)
         DO 601 JD=1,IDMAX
         IDIV=ID/10
         IDIGIT(JD)=ID-IDIV*10
         IN=JD
         IF(IDIV.EQ.0)GO TO 700
         ID=IDIV
  601    CONTINUE
C
C-----------------------------------------------------------------------
CL              7.         ISSUE CALLS
C
  700    CONTINUE
C
C     MAKE *IN* EVEN
         IN=2*(IN/2)
         IF(IN.EQ.0)GO TO 800
C
         DO 701 JD=1,IN,2
         IJ=IN-JD+1
         IG=IDIGIT(IJ)
         IB=IDIGIT(IJ-1)
         IF(IG.EQ.0)GO TO 701
         IF(I.EQ.1)CALL CLIST(IG,IB)
         IF(I.EQ.2)CALL ARRAYS(IG,IB)
  701    CONTINUE
         IF(I.EQ.1)GO TO 500
C
C-----------------------------------------------------------------------
CL              8.         NEXT ENTRY IN LIST
C
  800    CONTINUE
         END
C/ MODULE c0s2
C
         SUBROUTINE MODIFY
C
C 0.2  MODIFY BASIC DATA IF REQUIRED
C
C-----------------------------------------------------------------------
C
         CALLMESAGE('                                               ')
         END
C/ MODULE cus19
C
         SUBROUTINE RESETL(KLA,KDIM,KLVAL)
C
C U.19 RESET LOGICAL ARRAY TO SPECIFIED VALUE
C
C
C-----------------------------------------------------------------------
       LOGICAL     KLA,      KLVAL
       DIMENSION   KLA(KDIM)
C-----------------------------------------------------------------------
C
         DO 1 J=1,KDIM
         KLA(J) = KLVAL
    1    CONTINUE
C
         END
C/ MODULE C2S12
C
         SUBROUTINE SURCUR(PEX,PEY,PBZ,PJX,PJY,KXDIM,KLMAX2,KMMAX2,
     +                     KNBSP2,KL,KM,KDIR,KBCTYP,
     +                     PEBEXT,PICEXT,POYNT,PCCTS,PASCUR,
     +                     PC1,PC2,PRB0,PRZERO)
C
C 2.12 Compute surface currents and Poynting fluxes
C
C     R-Z geometry version
C-----------------------------------------------------------------------
C. Input PEX at timelevel n
C.       PEY at timelevel n
C.       PJX at timelevel n-1/2
C.       PJY at timelevel n-1/2
C.       PBZ at timelevel n-1/2
C.       on a mesh KLMAX2 * KMMAX2
C.       KXDIM is dimension of first arg.
C.       PRB0 uniform externally applied R * B-THETA
C.       PRZERO radius of inner edge of comp. box
C.       KL x index of surface element
C.       KM y index of surface element
C.       KDIR diection index of surface element
C.       KBCTYP surface element bc selector (0,1, etc)
C.       PEBEXT applied E at time n (KBCTYP=0)
C.              and applied E at time n+1 (KBCTYP=0)
C.              or B (KBCTYP=1)
C.       PICEXT surface impedance coeffs (KBCTYP=0) or
C.              external surface current (KBCTYP=1)
C.       PCCTS external circuit source term at old timelevel
C.       KNBSP2 no of surface elements + 2
C.       PC1 c * dt / dx
C.       PC2 c * dt / dy
C.
C.Output PCCTS external circuit source term at new timelevel
C.       PASCUR actual current through electrode surface element
C.       POYNT  surface poynting flux into active region
C.       PJX modified at timelevel n-1/2
C.       PJY modified at timelevel n-1/2
C.       on a mesh KLMAX2 * KMMAX2
C.
C. Note  PEX and PEY are in units of q*dt/(2*me*c)
C.       PBZ is in units of q*dt/(2*me)
C.       PJX and PJY are in units of mu*(dy,dx)*dt*q/(2*me)
C.
C.       The modifications to PJX and PJY are to bring the
C.       boundary equations into the same form as interior node eqs.
C.
C. NOTE: It is assumed the first two boundary segments are repeated at
C.       the end of the table. This allows look ahead (or behind) to
C.       deal with corners. Look ahead is not needed by this
C.       routine.
C.
C.
C. NOTE: The x component corresponds to z and the y component to r
C.       The main difference between this routine and the corresponding
C.       Cartesian one in MAXSOL is the inclusion of the scale factors
C.       ZRAD, which when set to unity recover the cartesian case.
C-----------------------------------------------------------------------
       DIMENSION
     +   PEX(KXDIM,*),       PEY(KXDIM,*),       PBZ(KXDIM,*),
     +   PJX(KXDIM,*),       PJY(KXDIM,*),       PEBEXT(2,*),
     +   PICEXT(4,*),        POYNT(*),           PCCTS(*),
     +   PASCUR(*),          KL(*),              KM(*),
     +   KDIR(*),            KBCTYP(*)
C
      COMMON /MTINY/ MYNUM,NSLAV,NTASK,ISLMIN(128),ISLMAX(128)
C-----------------------------------------------------------------------
CL              1.         perfect conductor
C
C
CL                  1.1      preliminaries
C     indexing
         ILMAXP=KLMAX2-1
         IMMAXP=KMMAX2-1
         ILMAX =ILMAXP-1
         IMMAX =IMMAXP-1
C
         DO 810 JSEG=4,KNBSP2
         IL = KL(JSEG)
         IM = KM(JSEG)
Cskip
         IF(IL .LT. ISLMIN(MYNUM+1) .OR. IL .GE. ISLMAX(MYNUM+1)+1)
     1     GOTO 810
         IDN= KDIR(JSEG)
         IBC= KBCTYP(JSEG)
C
C     initialise
         ZRB0=PRB0
         ZRAD=PRZERO+IM-2
         ZRADW=ZRAD+0.5
         ZRADE=ZRADW-1
C
C  ----------------------------------------------------------------
C     perfect conductor, IBC=0
C
         IF (IBC.EQ.0) THEN
         POYNT(JSEG)=0.0
C
CL                  1.2      lhs boundary(W)
         IF(IDN.EQ.1) THEN
         ZRBT = ZRADW * PBZ(IL,IM)
         PASCUR(JSEG)=-PJY(IL,IM) + ZRB0 - ZRBT
         PJY(IL,IM)=-ZRBT
C
CL                  1.3      top boundary(N)
         ELSE IF(IDN.EQ.2) THEN
         ZRBT = ZRADE * PBZ(IL,IM-1)
         PASCUR(JSEG)=-PJX(IL,IM) + ZRB0 - ZRBT
         PJX(IL,IM)=-ZRBT
C
CL                  1.4      rhs boundary(E)
         ELSE IF(IDN.EQ.3) THEN
         ZRBT = ZRADE * PBZ(IL-1,IM-1)
         PASCUR(JSEG)=-PJY(IL,IM-1) - ZRB0 + ZRBT
         PJY(IL,IM-1)=ZRBT
C
CL                  1.5      bottom boundary(S)
         ELSE
         ZRBT = ZRADW * PBZ(IL-1,IM)
         PASCUR(JSEG)=-PJX(IL-1,IM) + ZRB0 - ZRBT
         PJX(IL-1,IM)=ZRBT
         END IF
C
C-----------------------------------------------------------------------
CL              2.         periodic boundary conditions
C
C     It is assumed that periodic conditions can only be applied to
C     lines l=2,ilmaxp, the E boundary is processed before the W,
C     and that the boundary indexing
C     arrays comply with these assumptions.
C
         ELSE IF(IBC.EQ.1) THEN
C
CL                  2.1      lhs boundary(W)
         IF(IDN.EQ.1) THEN
         ZBA=(PBZ(ILMAX,IM)+PBZ(2,IM))/2.
         ZEA=PEY(2,IM)-PC1/2*(PJY(2,IM)/ZRADW-PBZ(2,IM))
         POYNT(JSEG)= PC1*ZBA*ZEA*ZRADW
C
CL                  2.2      rhs boundary(E)
         ELSE IF(IDN.EQ.3) THEN
         IMM=IM-1
         ZPJTOT=PJY(2,IMM)+PJY(ILMAXP,IMM)
         ZRBW=ZRADE*PBZ(ILMAX,IMM)
         ZRBE=ZRADE*PBZ(2,IMM)
         ZDTE=-PC1*(ZRBE-ZRBW+ZPJTOT)/ZRADE
         PJY(2,IMM)=ZPJTOT-ZRBW
         PJY(ILMAXP,IMM)=ZPJTOT+ZRBE
         POYNT(JSEG)=-PC1*(ZRBE+ZRBW)*(PEY(2,IMM)*2+ZDTE)*0.25
C
CL                  2.3      bottom(S) and top(N) boundaries
         ELSE
         CALLMESAGE(48H===ERROR IN PERIODIC BC====='                   )
         CALLIVAR('IL      ',IL)
         CALLIVAR('IM      ',IM)
         CALLIVAR('IDN     ',IDN)
         END IF
C
C-----------------------------------------------------------------------
CL              3.         domain decomposition bc
C
         ELSE IF(IBC.EQ.2) THEN
         PASCUR(JSEG)=0.0
C
CL                  3.1      lhs boundary(W)
         IF(IDN.EQ.1) THEN
         ZRBEXT=ZRADW*PEBEXT(1,JSEG)
         PJY(IL,IM)=PJY(IL,IM)+PICEXT(1,JSEG)-ZRBEXT
         POYNT(JSEG)= PC1*(PBZ(IL,IM)+PEBEXT(1,JSEG))*
     +   (PEY(IL,IM)*ZRADW+PC1*(-PBZ(IL,IM)*ZRADW-PJY(IL,IM))/2.)/2.
C
CL                  3.2      top boundary(N)
         ELSE IF(IDN.EQ.2) THEN
         ZRBEXT=ZRADW*PEBEXT(1,JSEG)
         PJX(IL,IM)=PJX(IL,IM)+PICEXT(1,JSEG)-ZRBEXT
         POYNT(JSEG)= PC2*(ZRADE*PBZ(IL,IM-1)+ZRBEXT)*
     +   (PEX(IL,IM)-PC2*(PBZ(IL,IM-1)*ZRADE+PJX(IL,IM)
     +   )/2./ZRAD)/2.
C
CL                  3.3      rhs boundary(E)
         ELSE IF(IDN.EQ.3) THEN
         ZRBEXT=ZRADE*PEBEXT(1,JSEG)
         PJY(IL,IM-1)=PJY(IL,IM-1)+PICEXT(1,JSEG)+ZRBEXT
         POYNT(JSEG)=-PC1*(PBZ(IL-1,IM-1)+PEBEXT(1,JSEG))*
     +   (PEY(IL-1,IM)*ZRADE+PC1*(PBZ(IL-1,IM-1)*ZRADE-PJY(IL-1,IM)
     +   )/2.)/2.
C
CL                  3.4      bottom boundary(S)
         ELSE
         ZRBEXT=ZRADE*PEBEXT(1,JSEG)
         PJX(IL-1,IM)=PJX(IL-1,IM)+PICEXT(1,JSEG)+ZRBEXT
         POYNT(JSEG)=-PC2*(ZRADW*PBZ(IL-1,IM)+ZRBEXT)*
     +   (PEX(IL-1,IM)+PC2*(PBZ(IL-1,IM)*ZRADW-PJX(IL-1,IM)
     +   )/2./ZRAD)/2.
         END IF
C
C-----------------------------------------------------------------------
CL              4.         symmetry bc
C
         ELSE IF(IBC.EQ.3) THEN
C     B=0 and particles are reflected
         POYNT(JSEG)=0.0
         PASCUR(JSEG)=0.0
C
CL                  4.1      lhs boundary(W)
         IF(IDN.EQ.1) THEN
         PJY(IL,IM)=2*PJY(IL,IM)+PBZ(IL,IM)*ZRADW
C
CL                  4.2      top boundary(N)
         ELSE IF(IDN.EQ.2) THEN
         CALLMESAGE(48H=== N boundary symmetry bc illegal====='        )
C
CL                  4.3      rhs boundary(E)
         ELSE IF(IDN.EQ.3) THEN
         PJY(IL,IM-1)=2*PJY(IL,IM-1)-PBZ(IL-1,IM-1)*ZRADE
C
CL                  4.4      bottom boundary(S)
         ELSE
C     axis of symmetry at r=0
         IF(PRZERO.GT.0.0)
     +   CALLMESAGE('=====Inconsistent bc on S boundary=====')
         END IF
C
C-----------------------------------------------------------------------
CL              5.         specified electric field
C
         ELSE IF (IBC.EQ.-3) THEN
C
CL                  5.1      lhs boundary(W)
         IF(IDN.EQ.1) THEN
         ZDTRE=(PEBEXT(2,JSEG)-PEBEXT(1,JSEG))*ZRADW/PC1
         ZEAV=(PEBEXT(2,JSEG)+PEBEXT(1,JSEG))*0.5
         ZRBT = ZRADW * PBZ(IL,IM)
         PASCUR(JSEG)=-PJY(IL,IM) + ZRB0 - ZRBT - ZDTRE*0.5
         PJY(IL,IM)=-ZRBT -ZDTRE
         POYNT(JSEG)=PC1*PASCUR(JSEG)*ZEAV
C
CL                  5.2      top boundary(N)
         ELSE IF(IDN.EQ.2) THEN
         ZDTRE=(PEBEXT(2,JSEG)-PEBEXT(1,JSEG))*ZRAD/PC2
         ZEAV=(PEBEXT(2,JSEG)+PEBEXT(1,JSEG))*0.5
         ZRBT = ZRADE * PBZ(IL,IM-1)
         PASCUR(JSEG)=-PJX(IL,IM) + ZRB0 - ZRBT - ZDTRE*0.5
         PJX(IL,IM)=-ZRBT -ZDTRE
         POYNT(JSEG)=PC2*PASCUR(JSEG)*ZEAV
C
CL                  5.3      rhs boundary(E)
         ELSE IF(IDN.EQ.3) THEN
         ZDTRE=(PEBEXT(2,JSEG)-PEBEXT(1,JSEG))*ZRADE/PC1
         ZEAV=(PEBEXT(2,JSEG)+PEBEXT(1,JSEG))*0.5
         ZRBT = ZRADE * PBZ(IL-1,IM-1)
         PASCUR(JSEG)=-PJY(IL,IM-1) - ZRB0 + ZRBT - ZDTRE*0.5
         PJY(IL,IM-1)=ZRBT -ZDTRE
         POYNT(JSEG)=PC1*PASCUR(JSEG)*ZEAV
C
CL                  5.4      bottom boundary(S)
         ELSE
         ZDTRE=(PEBEXT(2,JSEG)-PEBEXT(1,JSEG))*ZRAD/PC2
         ZEAV=(PEBEXT(2,JSEG)+PEBEXT(1,JSEG))*0.5
         ZRBT = ZRADW * PBZ(IL-1,IM)
         PASCUR(JSEG)=-PJX(IL-1,IM) + ZRB0 - ZRBT - ZDTRE*0.5
         PJX(IL-1,IM)=ZRBT -ZDTRE
         POYNT(JSEG)=PC2*PASCUR(JSEG)*ZEAV
         END IF
C
C-----------------------------------------------------------------------
CL              6.         lossy inductive wall and source field bc
C
         ELSE IF (IBC.EQ.-2) THEN
         ZTOLD  = PCCTS(JSEG)
         ZDTEE2 = (PEBEXT(2,JSEG)-PEBEXT(1,JSEG))*0.5
         ZA11 = PICEXT(2,JSEG)
         ZA12 = PICEXT(1,JSEG)
         ZB11 = PICEXT(4,JSEG)
         ZB12 = PICEXT(3,JSEG)
         ZDELTA = ZB11-ZA11
C
CL                  6.1      lhs boundary(W)
         IF(IDN.EQ.1) THEN
         ZRBT = ZRADW * PBZ(IL,IM)
         ZDTREA=ZDTEE2*ZRADW
         ZB1=ZRADW*ZDELTA*(PEY(IL,IM)-PEBEXT(1,JSEG))+ZA11*ZDTREA-ZTOLD
         ZB2=-PC1*(ZRBT-ZRB0+PJY(IL,IM))
         ZDET=ZA11*PC1+ZA12
         ZDTRE2=(PC1*ZB1+ZA12*ZB2)/ZDET
         PASCUR(JSEG)=(ZB2*ZA11-ZB1)/ZDET
         PJY(IL,IM)=PJY(IL,IM)+PASCUR(JSEG)-ZDTRE2/PC1-ZRB0
         POYNT(JSEG)=PC1*PASCUR(JSEG)*(PEY(IL,IM)+ZDTRE2/ZRADW)
C
CL                  6.2      top boundary(N)
         ELSE IF(IDN.EQ.2) THEN
         ZRBT = ZRADE * PBZ(IL,IM-1)
         ZDTREA=ZDTEE2*ZRAD
         ZB1=ZRAD*ZDELTA*(PEX(IL,IM)-PEBEXT(1,JSEG))+ZA11*ZDTREA-ZTOLD
         ZB2=-PC2*(ZRBT-ZRB0+PJX(IL,IM))
         ZDET=ZA11*PC2+ZA12
         ZDTRE2=(PC2*ZB1+ZA12*ZB2)/ZDET
         PASCUR(JSEG)=(ZB2*ZA11-ZB1)/ZDET
         PJX(IL,IM)=PJX(IL,IM)+PASCUR(JSEG)-ZDTRE2/PC2-ZRB0
         POYNT(JSEG)=PC2*PASCUR(JSEG)*(PEX(IL,IM)+ZDTRE2/ZRAD)
C=====
C        write(2,9999)jseg,il,im,zdtre2,pascur(jseg),pex(il,im),
C    +   ztold,poynt(jseg),pex(il,im)+zdtre2/zrad
C9999    format(3I4,6(1x,e10.4))
         CALLMESAGE(48H===I/O COMMENTED OUT   ====='                   )
C=====
C
CL                  6.3      rhs boundary(E)
         ELSE IF(IDN.EQ.3) THEN
         ZRBT = ZRADE * PBZ(IL-1,IM-1)
         ZDTREA=ZDTEE2*ZRADE
         ZB1=ZRADE*ZDELTA*(PEY(IL,IM-1)-PEBEXT(1,JSEG))+ZA11*ZDTREA
     $   -ZTOLD
         ZB2=-PC1*(-ZRBT+ZRB0+PJY(IL,IM-1))
         ZDET=ZA11*PC1+ZA12
         ZDTRE2=(PC1*ZB1+ZA12*ZB2)/ZDET
         PASCUR(JSEG)=(ZB2*ZA11-ZB1)/ZDET
         PJY(IL,IM-1)=PJY(IL,IM-1)+PASCUR(JSEG)-ZDTRE2/PC1+ZRB0
         POYNT(JSEG)=PC1*PASCUR(JSEG)*(PEY(IL,IM-1)+ZDTRE2/ZRADE)
C
CL                  6.4      bottom boundary(S)
         ELSE
         ZRBT = ZRADW * PBZ(IL-1,IM)
         ZDTREA=ZDTEE2*ZRAD
         ZB1=ZRAD*ZDELTA*(PEX(IL-1,IM)-PEBEXT(1,JSEG))+ZA11*ZDTREA-ZTOLD
         ZB2=-PC2*(-ZRBT+ZRB0+PJX(IL-1,IM))
         ZDET=ZA11*PC2+ZA12
         ZDTRE2=(PC2*ZB1+ZA12*ZB2)/ZDET
         PASCUR(JSEG)=(ZB2*ZA11-ZB1)/ZDET
         PJX(IL-1,IM)=PJX(IL-1,IM)+PASCUR(JSEG)-ZDTRE2/PC2+ZRB0
         POYNT(JSEG)=PC2*PASCUR(JSEG)*(PEX(IL-1,IM)+ZDTRE2/ZRAD)
         END IF
C
CL                  6.5      External circuit term
         PCCTS(JSEG)=ZB11*(ZDTRE2-ZDTREA)+ZB12*PASCUR(JSEG)
C
C
C-----------------------------------------------------------------------
CL              7.         Resistive wall and source field bc
C
         ELSE IF (IBC.EQ.-1) THEN
         ZR = PICEXT(1,JSEG)
         ZE = (PEBEXT(1,JSEG)+PEBEXT(2,JSEG))*0.5
         ZER=(1.0+ZR)*ZE
C
CL                  7.1      lhs boundary(W)
         IF(IDN.EQ.1) THEN
         ZRBT = ZRADW * PBZ(IL,IM)
         ZB1=ZRADW*(ZE-PEY(IL,IM))
         ZB2=-PC1*(ZRBT-ZRB0+PJY(IL,IM))
         ZDET=PC1+ZR
         ZDTRE2=(ZR*ZB2+PC1*ZB1)/ZDET
         PASCUR(JSEG)=(ZB2-ZB1)/ZDET
         PJY(IL,IM)=PJY(IL,IM)+PASCUR(JSEG)-ZDTRE2/PC1-ZRB0
         POYNT(JSEG)=PC1*PASCUR(JSEG)*(PEY(IL,IM)+ZDTRE2/ZRADW)
C
CL                  7.2      top boundary(N)
         ELSE IF(IDN.EQ.2) THEN
         ZRBT = ZRADE * PBZ(IL,IM-1)
         ZB1=ZRAD*(ZE-PEX(IL,IM))
         ZB2=-PC2*(ZRBT-ZRB0+PJX(IL,IM))
         ZDET=PC2+ZR
         ZDTRE2=(ZR*ZB2+PC2*ZB1)/ZDET
         PASCUR(JSEG)=(ZB2-ZB1)/ZDET
         PJX(IL,IM)=PJX(IL,IM)+PASCUR(JSEG)-ZDTRE2/PC2-ZRB0
         POYNT(JSEG)=PC2*PASCUR(JSEG)*(PEX(IL,IM)+ZDTRE2/ZRAD)
C
CL                  7.3      rhs boundary(E)
         ELSE IF(IDN.EQ.3) THEN
         ZRBT = ZRADE * PBZ(IL-1,IM-1)
         ZB1=ZRADE*(ZE-PEY(IL,IM-1))
         ZB2=-PC1*(-ZRBT+ZRB0+PJY(IL,IM-1))
         ZDET=PC1+ZR
         ZDTRE2=(ZR*ZB2+PC1*ZB1)/ZDET
         PASCUR(JSEG)=(ZB2-ZB1)/ZDET
         PJY(IL,IM-1)=PJY(IL,IM-1)+PASCUR(JSEG)-ZDTRE2/PC1+ZRB0
         POYNT(JSEG)=PC1*PASCUR(JSEG)*(PEY(IL,IM-1)+ZDTRE2/ZRADE)
C
CL                  7.4      bottom boundary(S)
         ELSE
         ZRBT = ZRADW * PBZ(IL-1,IM)
         ZB1=ZRAD*(ZE-PEX(IL-1,IM))
         ZB2=-PC2*(-ZRBT+ZRB0+PJX(IL-1,IM))
         ZDET=PC2+ZR
         ZDTRE2=(ZR*ZB2+PC2*ZB1)/ZDET
         PASCUR(JSEG)=(ZB2-ZB1)/ZDET
         PJX(IL-1,IM)=PJX(IL-1,IM)+PASCUR(JSEG)-ZDTRE2/PC2+ZRB0
         POYNT(JSEG)=PC2*PASCUR(JSEG)*(PEX(IL-1,IM)+ZDTRE2/ZRAD)
         END IF
C
C-----------------------------------------------------------------------
CL              8.         epilogue
C
C
CL                  8.1      unspecified bc cases
         ELSE
C     error traps or additional cases can be added here
         END IF
  810    CONTINUE
C
CL                  8.2      Wrap around boundary tables
         DO 820 JS = 2,3
         POYNT(JS)=POYNT(JS+KNBSP2-3)
         PASCUR(JS)=PASCUR(JS+KNBSP2-3)
  820    CONTINUE
C-----------------------------------------------------------------------
         END
C/ MODULE C2S11
C
         SUBROUTINE EBJCLS(PEX,PEY,PBZ,PJX,PJY,KXDIM,KLMAX2,
     +                     KMMAX2,KNBSP2,KL,KM,KDIR)
C
C 2.11 clear E, B and J on boundary surface using boundary tables
C
C---------------------------------------------------------------------
C. Input PEX at timelevel n
C.       PEY at timelevel n
C.       PJX at timelevel n-1/2
C.       PJY at timelevel n-1/2
C.       PBZ at timelevel n-1/2
C.       on a mesh KLMAX2 * KMMAX2
C.       KXDIM is dimension of first arg.
C.       KL x index of surface element
C.       KM y index of surface element
C.       KDIR diection index of surface element
C.       KNBSP2 no of surface elements + 2
C.
C. Note  PEX and PEY are in units of q*dt/(2*me*c)
C.       PBZ is in units of q*dt/(2*me)
C.       PJX and PJY are in units of mu*(dy,dx)*dt*q/(2*me)
C.
C. Output: PEX,PJX,PEY,PJY,PBZ zeroed in boundary region
C.
C. NOTE: It is assumed the first two boundary segments are repeated at t
C.       end of the table. This allows look ahead (or behind) to deal wi
C.       corners. Look ahead (behind) by one element is needed by this
C.       routine.
C.
C---------------------------------------------------------------------
       DIMENSION
     +   PEX(KXDIM,*),       PEY(KXDIM,*),       PBZ(KXDIM,*),
     +   PJX(KXDIM,*),       PJY(KXDIM,*),
     +   KL(KNBSP2),         KM(KNBSP2),         KDIR(KNBSP2)
C
      COMMON /MTINY/ MYNUM,NSLAV,NTASK,ISLMIN(128),ISLMAX(128)
C-----------------------------------------------------------------------
CL              1.         boundary sweep
C
         IDN=KDIR(3)
C
         DO 100 JSEG=4,KNBSP2
         IDO=IDN
         IDN=KDIR(JSEG)
         IL = KL(JSEG)
         IM = KM(JSEG)
Cskip
         if(il .lt. islmin(mynum+1) .or. il .ge. islmax(mynum+1)+1)
     1     GOTO 100

C
C     lhs boundary
         IF(IDN.EQ.1) THEN
         PBZ(IL-1,IM) = 0.
         IF(IDO.EQ.4) PBZ(IL-1,IM-1) = 0.
         IF(IDO.NE.2) PEX(IL-1,IM  ) = 0.
C
C     top boundary
         ELSE IF(IDN.EQ.2) THEN
         PBZ(IL  ,IM) = 0.
         IF(IDO.EQ.1) PBZ(IL-1,IM  ) = 0.
         IF(IDO.NE.3) PEY(IL  ,IM  ) = 0.
C
C     rhs boundary
         ELSE IF(IDN.EQ.3) THEN
         PBZ(IL,IM-1) = 0.
         IF(IDO.EQ.2) PBZ(IL  ,IM  ) = 0.
         IF(IDO.NE.4) PEX(IL  ,IM  ) = 0.
C
C     bottom boundary
         ELSE
         PBZ(IL-1,IM-1) = 0.
         IF(IDO.EQ.3) PBZ(IL  ,IM-1) = 0.
         IF(IDO.NE.1) PEY(IL  ,IM-1) = 0.
         END IF
  100    CONTINUE
C---------------------------------------------------------------------
         END
C/ MODULE c0s3
C
         SUBROUTINE COTROL
C
C 0.3  CONTROL THE RUN
C
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C       INCLUDE 'COMDDP.inc'
C--------------------------------------------------------------------
CL                  C1.9.    DEVELOPMENT AND DIAGNOSTIC PARAMETERS
       COMMON/COMDDP/
     I   MAXDUM,   MXDUMP,   NADUMP,   NCLASS,   NPDUMP,   NPOINT,
     I   NSUB,     NVDUMP,
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       LOGICAL
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       DIMENSION
     I   NADUMP(20),         NPDUMP(20),         NVDUMP(20),
     L   NLHEAD(9),          NLOMT1(50),         NLOMT2(50),
     L   NLOMT3(50)
C-----------------------------------------------------------------------
C
       DATA        ICLASS,   ISUB/0,   3/
C        CALLMESAGE('    0.3 ENTER RUN CONTROL                      ')
C
C-----------------------------------------------------------------------
CL              1.         PROLOGUE
C
         IF(NLRES) GO TO 170
C
C     A.         NEW RUN
C
CL                  1.1      LABEL THE RUN
  110    CALL LABRUN
                                       CALL EXPERT(ICLASS,ISUB,1)
C
CL                  1.2      CLEAR VARIABLES AND ARRAYS
  120    CALL CLEAR
                                       CALL EXPERT(ICLASS,ISUB,2)
C
CL                  1.3      SET DEFAULT VALUES
  130    CALL PRESET
                                       CALL EXPERT(ICLASS,ISUB,3)
C
CL                  1.4      DEFINE DATA SPECIFIC TO RUN
  140    CALL DATA
                                       CALL EXPERT(ICLASS,ISUB,4)
C
CL                  1.5      SET AUXILIARY VALUES
  150    CALL AUXVAL
                                       CALL EXPERT(ICLASS,ISUB,5)
C
CL                  1.6      DEFINE PHYSICAL INITIAL CONDITIONS
  160    CALL INITAL
                                       CALL EXPERT(ICLASS,ISUB,6)
         GO TO 180
C
C     B.         RESUME A PREVIOUS RUN
C
CL                  1.7      PICK UP RECORD, MODIFY REQUIRED PARAMETERS
  170    CONTINUE
                                       CALL EXPERT(ICLASS,ISUB,7)
C     LABEL THE CONTINUATION RUN
         CALL LABRUN
                                       CALL EXPERT(ICLASS,ISUB,8)
C     CLEAR VARIABLES AND ARRAYS
         CALL CLEAR
                                       CALL EXPERT(ICLASS,ISUB,9)
C     PICK UP RECORD AND PRINT DETAILS
         CALL RESUME
                                       CALL EXPERT(ICLASS,ISUB,10)
C     READ ANY NEW DATA NEEDED
         CALL DATA
                                       CALL EXPERT(ICLASS,ISUB,11)
C     MODIFY AUXILIARY VARIABLES AS REQUIRED
         CALL AUXVAL
                                       CALL EXPERT(ICLASS,ISUB,12)
C
C     C.         PRELIMINARY OPERATIONS
C
CL                  1.8      START OR RESTART THE RUN
  180    CALL START
                                       CALL EXPERT(ICLASS,ISUB,13)
C     INITIAL OUTPUT
         CALL OUTPUT(1)
                                       CALL EXPERT(ICLASS,ISUB,14)
C
C
C-----------------------------------------------------------------------
CL              2.         CALCULATION
C
C
CL                  2.1      STEP ON THE CALCULATION
  210    CALL STEPON
                                       CALL EXPERT(ICLASS,ISUB,15)
C
C-----------------------------------------------------------------------
CL              3.         OUTPUT
C
C
CL                  3.1      PERIODIC PRODUCTION OF OUTPUT
  310    CALL OUTPUT(2)
                                       CALL EXPERT(ICLASS,ISUB,16)
C
C-----------------------------------------------------------------------
CL              4.         EPILOGUE
C
C
CL                  4.1      TEST FOR COMPLETION OF RUN
  410    CALL TESEND
                                       CALL EXPERT(ICLASS,ISUB,17)
         IF(.NOT.NLEND) GO TO 210
C
C     FINAL OUTPUT
         CALL OUTPUT(3)
                                       CALL EXPERT(ICLASS,ISUB,18)
C
CL                  4.2      TERMINATE THE RUN
  420    CALL ENDRUN
C
         END
C/ MODULE C2S10
C
         SUBROUTINE STEPEB(PEX,PEY,PBZ,PJX,PJY,KNG,KXDIM,KLMAX2,KMMAX2,
     +   PC1,PC2,PBZERO,
     +   KL,KM,KDIR,KBCTYP,PEBEXT,PICEXT,POYNT,PCCTS,PASCUR,KNBSP2,
     +   PEXEN,PEYEN,PBZEN,POWEJX,POWEJY,PRZERO)
C
C 2.10 advance electric and magnetic fields by one timestep
C.     and compute energies,powers and electrode currents
C.     r-z geomatry(z=x direction,r=y direction)
C---------------------------------------------------------------------
C. Input PEX at timelevel n-1
C.       PEY at timelevel n-1
C.       PBZ at timelevel n-1/2
C.       PJX at timelevel n-1/2
C.       PJY at timelevel n-1/2
C.       on a mesh KLMAX2 * KMMAX2
C.       KXDIM is dimension of first arg.
C.       PC1 c * dt / dx
C.       PC2 c * dt / dy
C.       PBZERO uniform externally applied Bz
C.       PRZERO radius of inner edge of computational box
C.       KL x index of surface element
C.       KM y index of surface element
C.       KDIR diection index of surface element
C.       KBCTYP surface element bc selector (0,1, etc)
C.       PEBEXT applied E (KBCTYP=0) and E-new
C.              or B (KBCTYP=1)
C.       PICEXT surface impedance (KBCTYP=0) coeffs or
C.              external surface current (KBCTYP=1)
C.       PCCTS Source term for ext. cct equations for this timelevel
C.       KNBSP2 no of surface elements + 2
C.
C.Output PCCTS Source term for ext. cct equations for next timelevel
C.       PASCUR actual surface current in electrode surface element
C.       POYNT  surface poynting flux (in positive x&y directions)
C.       PEX at timelevel n
C.       PEY at timelevel n
C.       PBZ at timelevel n+1/2
C.       PJX at timelevel n-1/2
C.       PJX modified at timelevel n-1/2
C.       PJY modified at timelevel n-1/2
C.       on a mesh KLMAX2 * KMMAX2
C.       PEXEN energy in Ex field component at time n
C.       PEYEN energy in Ey field component at time n
C.       PBZEN energy in Bz field component at time n
C.       POWEJX (E.J)x power at time n-1/2
C.       POWEJY (E.J)y power at time n-1/2
C.
C. Note  PEX and PEY are in units of q*dt/(2*me*c)
C.       PBZ is in units of q*dt/(2*me)
C.       PJX and PJY are in units of mu*(dy,dx)*dt*q/(2*me)
C---------------------------------------------------------------------
       DIMENSION
     +   PEX(KXDIM,*),       PEY(KXDIM,*),       PBZ(KXDIM,*),
     +   PJX(KXDIM,*),       PJY(KXDIM,*),       PEBEXT(2,*),
     +   PICEXT(4,*),     POYNT(KNBSP2),      PCCTS(KNBSP2),
     +   PASCUR(KNBSP2),     KL(KNBSP2),         KM(KNBSP2),
     +   KDIR(KNBSP2),       KBCTYP(KNBSP2)
C
      COMMON /MTINY/ MYNUM,NSLAV,NTASK,ISLMIN(128),ISLMAX(128)
C
         COMMON/COMTIM/ SNTIME(20,20),SNTDIF(20,20)
         DIMENSION ZTARR(2)
C
C  SNTIME(TIMPNT,MYNUM+1) time point TIMPNT, processor number MYNUM
C  1-proc calc is in MYNUM=NSLAV, times in position 20
C
         IF(MYNUM .EQ. NSLAV) THEN
           INUM1=20
         ELSE
           INUM1=MYNUM+1
           IF(INUM1 .GT. 19) INUM1=19
         ENDIF
C
C---------------------------------------------------------------------
CL              1.         clear E, B and J on boundary surface
C
C.NOTE:  This routine uses boundary tables
C.       It is assumed the first two boundary segments are repeated at
C.       the end of the table. This allows look ahead (or behind) to
C.       deal with corners. Look ahead (behind) by one element
C.       is needed by this routine.
C.
         CALL EBJCLS(PEX,PEY,PBZ,PJX,PJY,KXDIM,KLMAX2,KMMAX2,
     +                    KNBSP2,KL,KM,KDIR)
C.
C. Output: PEX,PJX,PEY,PJY,PBZ zeroed in boundary region
C
C---------------------------------------------------------------------
CL              2.         Compute surface currents
C
         CALL SURCUR(PEX,PEY,PBZ,PJX,PJY,KXDIM,KLMAX2,KMMAX2,
     +                     KNBSP2,KL,KM,KDIR,KBCTYP,
     +                     PEBEXT,PICEXT,POYNT,PCCTS,PASCUR,
     +                     PC1,PC2,PBZERO,PRZERO)
C
C-----------------------------------------------------------------------
C  Time point 18
         CALL SECOWA(SNTIME(18,INUM1),ZTARR)
C
C  Exchange current densities with neighbouring processors
C        CALL SNXCD0   Replaced by next 2 lines
         CALL SNXFLD(PJY,KXDIM,0,0)
         CALL SNXFLD(PJY,KXDIM,0,1)
C
C-----------------------------------------------------------------------
C  Time point 19
         CALL SECOWA(SNTIME(19,INUM1),ZTARR)
C
C
C.Output PCCTS external cct source term for next timelevel
C.       PASCUR actual surface current on electrode surface element
C.       POYNT Poynting flux in at timelevel n-1/2
C.       PJX modified on surface nodes
C.       PJY modified on surface nodes
C.
C.       The modifications to PJX and PJY are to bring the
C.       boundary equations into the same form as interior node eqs.
C.
C. NOTE: It is assumed the first two boundary segments are repeated at
C.       the end of the table. This allows look ahead (or behind) to
C.       deal with corners. Look ahead is not needed by this
C.       routine.
C
C---------------------------------------------------------------------
CL              3.         advance E and B by one timestep
C
         CALL ADVEB(PEX,PEY,PBZ,PJX,PJY,PC1,PC2,
     +                    KXDIM,KLMAX2,KMMAX2,
     +                    PEXEN,PEYEN,PBZEN,POWEJX,POWEJY,PRZERO)
C
C.
C. Output: PEX at timelevel n
C.         PEY at timelevel n
C.         PBZ at timelevel n+1/2
C.         PEXEN energy in Ex field component at time n
C.         PEYEN energy in Ey field component at time n
C.         PBZEN energy in Bz field component at time n
C.         POWEJX (E.J)x power at time n-1/2
C.         POWEJY (E.J)y power at time n-1/2
C.
C---------------------------------------------------------------------
         END
C/ MODULE C2S6
C
         SUBROUTINE ACCEL(PX,PY,PPX,PPY,KNP,PEX,PEY,PBZ,PEJPOW,KXDIM)
C
C 2.6  update particle momenta
C
C-----------------------------------------------------------------------
C. Input:  momenta (PPX(JP),PPY(JP),J=1,NP) at timelevel n-1/2
C.         positions (PX(JP),PY(JP),JP=1,NP) at timelevel n
C.         electric field (PEX,PEY) at timelevel n
C.         magnetic field PBZ     at timelevel n
C.         where PEX,PEY and PBZ are defined on an interlaced
C.         TM mesh of size LMAXP2*MMAXP2
C.
C. Output: momenta (PPX(JP),PPY(JP),J=1,NP) at timelevel n+1/2
C.         PEJPOW j.E energy into particles
C.
C. Note:   PX and PY are in units of cellwidths
C.         PPX and PPY are in units of me*c
C.         PEX and PEY are in units of q*dt/(2*me*c)
C.         PBZ is in units of q*dt/(2*me)
C.
C.         so EoM reduces to
C.
C.          n+1/2   n-1/2    n   n+1/2  n-1/2     n
C.         P     = P   +  2*E +(P   +  P     ) x B / GAMMA
C.
C.         where
C.                         n-1/2  n
C.         GAMMA**2 =  1+(P     +E )**2
C-----------------------------------------------------------------------
      COMMON /MTINY/ MYNUM,NSLAV,NTASK,ISLMIN(128),ISLMAX(128)
       DIMENSION
     +   PX(KNP),  PY(KNP),  PPX(KNP), PPY(KNP), PEX(KXDIM,*),
     +   PEY(KXDIM,*),       PBZ(KXDIM,*)
C
C-----------------------------------------------------------------------
CL              1.         interpolate fields
C
         PEJPOW=0.0
         IF(KNP.LT.1) RETURN
C
         DO 300 JP = 1,KNP
C
CL                  1.1      positions relative to charge mesh
         ZXC = PX(JP)
         ZYC = PY(JP)
C
C  Skip particles not in region for this processor
Cskip
         if(zxc .lt. islmin(mynum+1) .or.
     1      zxc .ge. islmax(mynum+1)+1.0) GOTO 300
         ILC = ZXC
         IMC = ZYC
C
         ILCP = ILC + 1
         IMCP = IMC + 1
C
         ZDXC = ZXC - ILC
         ZDYC = ZYC - IMC
C
CL                  1.2      positions relative to B3 mesh
         ZXB = ZXC - 0.5
         ZYB = ZYC - 0.5
C
         ILB = ZXB
         IMB = ZYB
C
         ILBP = ILB + 1
         IMBP = IMB + 1
C
         ZDXB = ZXB - ILB
         ZDYB = ZYB - IMB
C
CL                  1.3      B3 at particle
         ZBW = PBZ(ILB ,IMB)+ZDYB*(PBZ(ILB ,IMBP)-PBZ(ILB ,IMB))
         ZBE = PBZ(ILBP,IMB)+ZDYB*(PBZ(ILBP,IMBP)-PBZ(ILBP,IMB))
         ZB  = ZBW+ZDXB*(ZBE-ZBW)
C
CL                  1.4      E1 at particle
         ZE1W = PEX(ILB ,IMC)+ZDYC*(PEX(ILB ,IMCP)-PEX(ILB ,IMC))
         ZE1E = PEX(ILBP,IMC)+ZDYC*(PEX(ILBP,IMCP)-PEX(ILBP,IMC))
         ZE1  = ZE1W+ZDXB*(ZE1E-ZE1W)
C
CL                  1.5      E2 at particle
         ZE2W = PEY(ILC ,IMB)+ZDYB*(PEY(ILC ,IMBP)-PEY(ILC ,IMB))
         ZE2E = PEY(ILCP,IMB)+ZDYB*(PEY(ILCP,IMBP)-PEY(ILCP,IMB))
         ZE2  = ZE2W+ZDXC*(ZE2E-ZE2W)
C
C-----------------------------------------------------------------------
CL              2.         update momenta
C.****
C.       ZGAMO=SQRT(1.0+PPX(JP)**2+PPY(JP)**2)
C.***
C
C     half E
         ZPXM = PPX(JP)+ZE1
         ZPYM = PPY(JP)+ZE2
C     relativistic factor
         ZGAMMA = SQRT(1.0+ZPXM**2+ZPYM**2)
         ZOMEGA = ZB/ZGAMMA
         ZFAC   = 1.0/(1.0+ZOMEGA**2)
C     half rotate
         ZPX = ZPXM + ZOMEGA*ZPYM
         ZPY = ZPYM - ZOMEGA*ZPXM
C     half rotate and scale
         ZPXP = (ZPX + ZOMEGA*ZPY) * ZFAC
         ZPYP = (ZPY - ZOMEGA*ZPX) * ZFAC
C     half E
         PPX(JP) = ZPXP + ZE1
         PPY(JP) = ZPYP + ZE2
C.***
C.      ZGAMN=SQRT(1.0+PPX(JP)**2+PPY(JP)**2)
C.      ZGAMA=(ZGAMO+ZGAMN)/2
C.***
C
C-----------------------------------------------------------------------
CL              3.         Exchange energy
C
C.       PEJPOW=PEJPOW+((ZPXM+ZPXP)*ZE1+(ZPYM+ZPYP)*ZE2)/ZGAMA
         PEJPOW=PEJPOW+((ZPXM+ZPXP)*ZE1+(ZPYM+ZPYP)*ZE2)/ZGAMMA
  300    CONTINUE
C
C-----------------------------------------------------------------------
         END
C/ MODULE C2S13
C
         SUBROUTINE ADVEB(PEX,PEY,PBZ,PJX,PJY,PC1,PC2,
     +                    KXDIM,KLMAX2,KMMAX2,
     +                    PEXEN,PEYEN,PBZEN,POWEJX,POWEJY,PRZERO)
C
C 2.13 advance E and B by one timestep
C
C     r-z geometry case
C---------------------------------------------------------------------
C. Input PEX at timelevel n-1
C.       PEY at timelevel n-1
C.       PJX at timelevel n-1/2
C.       PJY at timelevel n-1/2
C.       PBZ at timelevel n-1/2
C.       on a mesh KLMAX2 * KMMAX2
C.       PC1 = c*DT/DX
C.       PC2 = c*DT/DY
C.
C. Note  PEX and PEY are in units of q*dt/(2*me*c)
C.       PBZ is in units of q*dt/(2*me)
C.       PJX and PJY are in units of mu*(dy,dx)*dt*q/(2*me)
C.
C. Output: PEX at timelevel n
C.         PEY at timelevel n
C.         PBZ at timelevel n+1/2
C.         PEXEN energy in Ex field component at time n
C.         PEYEN energy in Ey field component at time n
C.         PBZEN energy in Bz field component at time n
C.         POWEJX (E.J)x power at time n-1/2
C.         POWEJY (E.J)y power at time n-1/2
C.
C.
C. NOTE: Boundary conditions are not dealt with by this routine
C.       This routine assumes effective surface currents are in
C.       place and that E,B and J have been cleared in the passive
C.       embedded domain. Fixed E bc are assumed on the surface
C.       of the guard element layer
C.
C. NOTE: The X components correspond to the z direction and
C.       the Y components correspond to the r direction and
C.       the Z components correspond to the theta direction.
C---------------------------------------------------------------------
       DIMENSION
     +   PEX(KXDIM,*),       PEY(KXDIM,*),       PBZ(KXDIM,*),
     +   PJX(KXDIM,*),       PJY(KXDIM,*)
C
      COMMON /MTINY/ MYNUM,NSLAV,NTASK,ISLMIN(128),ISLMAX(128)
C
         COMMON/COMTIM/ SNTIME(20,20),SNTDIF(20,20)
C  SNTIME(TIMPNT,MYNUM+1) time point TIMPNT, processor number MYNUM
         DIMENSION ZTARR(2)
C
C  SNTIME(TIMPNT,MYNUM+1) time point TIMPNT, processor number MYNUM
C  1-proc calc is in MYNUM=NSLAV, times in position 20
C
         IF(MYNUM .EQ. NSLAV) THEN
           INUM1=20
         ELSE
           INUM1=MYNUM+1
           IF(INUM1 .GT. 19) INUM1=19
         ENDIF
C
C---------------------------------------------------------------------
CL              1.         initialise
C
         ILMAXP=KLMAX2-1
         ILMAX=ILMAXP-1
C
         IMMAXP=KMMAX2-1
         IMMAX=IMMAXP-1
         IMMIN=2
C
         PEXEN=0.0
         PEYEN=0.0
         PBZEN=0.0
         POWEJX=0.0
         POWEJY=0.0
C
CL                  1.1      Axis treatment
         IF(PRZERO.LE.0.0) THEN
         PRZERO=0.0
         IMMIN=3
         DO 110 JL=2,ILMAX
         ZEXOLD=PEX(JL,2)
         ZEXNEW=ZEXOLD+PC2*(4*PBZ(JL,2)-8*PJX(JL,2))
         PEXEN=PEXEN+ZEXNEW**2/16.0
         POWEJX=POWEJX+(PBZ(JL,2)+2*PJX(JL,2))*(ZEXOLD+ZEXNEW)/4.0
         PEX(JL,2)=ZEXNEW
  110    CONTINUE
         END IF
C
         ZR15=PRZERO-1.5
C
C---------------------------------------------------------------------
CL              2.         update EX
C
C  skip: Limit indices to the processors region
         JL1=ISLMIN(MYNUM+1)
         IF(JL1 .LT. 2) JL1=2
         JL2=ISLMAX(MYNUM+1)
         IF(JL2 .GT. ILMAX) JL2=ILMAX
C
         DO 200 JM=IMMIN,IMMAXP
C        DO 200 JL=2,ILMAX
         DO 200 JL=JL1,JL2

         ZRP =JM+ZR15
         ZRAD=ZRP-0.5
         ZRM =ZRP-1
         ZEXOLD=PEX(JL,JM)
         ZEXNEW=ZEXOLD+PC2*(ZRP*PBZ(JL,JM)-ZRM*PBZ(JL,JM-1)
     +   -PJX(JL,JM))/ZRAD
         PEXEN=PEXEN+ZEXNEW**2*ZRAD
         POWEJX=POWEJX+PJX(JL,JM)*(ZEXOLD+ZEXNEW)
         PEX(JL,JM)=ZEXNEW
  201    CONTINUE
  200    CONTINUE
C
C---------------------------------------------------------------------
CL              3.         update EY
C
C  skip: Limit indices to the processors region
         JL2=ISLMAX(MYNUM+1)
         IF(JL2 .GT. ILMAX) JL2=ILMAXP
C
         DO 300 JM=2,IMMAX
C        DO 300 JL=2,ILMAXP
         DO 300 JL=JL1,JL2
C
         ZRAD=JM+ZR15
         ZEYOLD=PEY(JL,JM)
         ZEYNEW=ZEYOLD-PC1*(PBZ(JL,JM)-PBZ(JL-1,JM)+PJY(JL,JM)/ZRAD)
         PEYEN=PEYEN+ZEYNEW**2*ZRAD
         POWEJY=POWEJY+PJY(JL,JM)*(ZEYOLD+ZEYNEW)
         PEY(JL,JM)=ZEYNEW
  301    CONTINUE
  300    CONTINUE
C
C-----------------------------------------------------------------------
C  Time point 11
         CALL SECOWA(SNTIME(11,INUM1),ZTARR)
C
C---------------------------------------------------------------------
C  Exchange E1 and E2
C        CALL SNXE12    Replaced by next line, only E2 necessary
         CALL SNXFLD(PEY,KXDIM,0,0)
C
C-----------------------------------------------------------------------
C  Time point 15
         CALL SECOWA(SNTIME(15,INUM1),ZTARR)
C
C  Zero normal E-fields on electrodes
         CALL SNXE0
C
C---------------------------------------------------------------------
CL              4.         update BZ
C
C  skip: Limit indices to the processors region
         JL2=ISLMAX(MYNUM+1)
         IF(JL2 .GT. ILMAX) JL2=ILMAX
C
         DO 400 JM=2,IMMAX
C        DO 400 JL=2,ILMAX
         DO 400 JL=JL1,JL2
C
                 ZRAD = JM + ZR15
         ZBZOLD=PBZ(JL,JM)
         PBZ(JL,JM)=PBZ(JL,JM) + PC2*(PEX(JL,JM+1)-PEX(JL,JM))
     +                         - PC1*(PEY(JL+1,JM)-PEY(JL,JM))
         PBZEN=PBZEN+ZBZOLD*PBZ(JL,JM)*ZRAD
  401    CONTINUE
  400    CONTINUE
C---------------------------------------------------------------------
         POWEJX=POWEJX*PC2/2.0
         POWEJY=POWEJY*PC1/2.0
         PEXEN=PEXEN/2.0
         PEYEN=PEYEN/2.0
         PBZEN=PBZEN/2.0
C
C-----------------------------------------------------------------------
C  Time point 16
         CALL SECOWA(SNTIME(16,INUM1),ZTARR)
C
C---------------------------------------------------------------------
C  Exchange B3
C        CALL SNXB3   Replaced by next line
         CALL SNXFLD(PBZ,KXDIM,0,0)
C
         END
C/ MODULE C2S2
C
         SUBROUTINE MOVCUR(PX,PY,PPX,PPY,KNP,PKE,PKEFLX,
     +                     PJX,PJY,KNG,KXDIM,KLMAX2,KMMAX2,
     +                     PC1,PDXODY,KBCTYP,KBSEG2)
C
C .2.2 Update particle positions
C
C.     apply particle boundary conditions
C.     and accumulate current densities
C---------------------------------------------------------------------
C.    Input:  positions (PX(J),PY(J),J=1,KNP) at timelevel n
C.            momenta   (PPX(J),PPY(J),J=1,KNP) at timelevel n+1/2
C.            KNG grid mask array
C.            KBCTYP bc type array
C.            KBSEG2 no of boundary segments + 2
C.
C.    Output: positions at timelevel n+1
C.            current densities (PJX(L,M),PJY(L,M)) at n+1/2 on
C.            a rectangular mesh with the usual TM interlacing
C.            and of size klmax2 * kmmax2. It is assumed that this
C.            mesh has sufficient guard cells that particles always
C.            lie on the mesh regions, even after timestepping.
C.            However, with the implementation of bc in this routine,
C.            the guard cells are only assigned to for the domain
C.            decomposition case
C.            PKE the total particle K E
C.            PKEFLX particle K E flux to walls
C.
C.
C.    Note:   It is assumed within this routine that positions are
C.            input in units of x and y mesh spacings, velocities
C.            are in units of mesh spacings per timestep (i.e (vx,vy)
C.            in units (DX/DT,DY/DT)) and momenta are in units me*c.
C.            PC1 is c/(DX/DT) and PDXODY is DX/DY.
C.            The current density is that which would result if
C.            DX=DY=DT=Q=1, where Q is the total charge per particle.
C.
C.            This version assumes that PJX and PJY are initialised
C.            elsewhere
C.
C.   NOTE:    The domain decomposition boundary conditions are not
C.            fully implemented in this version.
C.
C---------------------------------------------------------------------
       LOGICAL     ILIVE
       DIMENSION
     +   PX(KNP),  PY(KNP),  PPX(KNP), PPY(KNP), PJX(KXDIM,KMMAX2),
     +   PJY(KXDIM,KMMAX2),  KNG(KXDIM,KMMAX2),  KBCTYP(KBSEG2)
C---------------------------------------------------------------------
C     OLYMPUS interface
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C       INCLUDE 'COMDDP.inc'
C--------------------------------------------------------------------
CL                  C1.9.    DEVELOPMENT AND DIAGNOSTIC PARAMETERS
       COMMON/COMDDP/
     I   MAXDUM,   MXDUMP,   NADUMP,   NCLASS,   NPDUMP,   NPOINT,
     I   NSUB,     NVDUMP,
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       LOGICAL
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       DIMENSION
     I   NADUMP(20),         NPDUMP(20),         NVDUMP(20),
     L   NLHEAD(9),          NLOMT1(50),         NLOMT2(50),
     L   NLOMT3(50)
C
      COMMON /MTINY/ MYNUM,NSLAV,NTASK,ISLMIN(128),ISLMAX(128)
C
         DATA        ICLASS,   ISUB/2,   2/
                                       CALL EXPERT(ICLASS,ISUB,1)
         IF(NLOMT2(ISUB))RETURN
C
C---------------------------------------------------------------------
CL              1.         Move particles
C
         PKE=0.0
         PKEFLX=0.0
         IF(KNP.LE.0) RETURN
C
         IP=KNP+1
         INP=KNP
         ZXPER=KLMAX2-3
         ZYPER=KMMAX2-3
C
         DO 520 JP=1,KNP
         IP=IP-1
C     velocity
         ZPSQ = PPX(IP)**2+PPY(IP)**2
         ZGAM = SQRT(1+ZPSQ)
         ZKE  = ZPSQ/(ZGAM+1)
         ZCOG = PC1 / ZGAM
         ZVX  = ZCOG * PPX(IP)
         ZVY  = ZCOG * PPY(IP) * PDXODY
C     positions
         ZXO = PX(IP)
         ZYO = PY(IP)
C  Skip over particles not in region concerning this processor
Cskip
         if(zxo .lt. islmin(mynum+1) .or.
     1      zxo .ge. islmax(mynum+1)+1.0) goto 520
         ZXN = ZXO + ZVX
         ZYN = ZYO + ZVY
C     cells
         ILO = ZXO
         IMO = ZYO
         ILN = ZXN
         IMN = ZYN
         ILIVE=.TRUE.
C
C---------------------------------------------------------------------
CL              2.         current density assignment-one cell case
C
         IF(IMO.EQ.IMN) THEN
           IF(ILO.EQ.ILN) THEN
             CALL CURASS(ZXO,ZYO,ZXN,ZYN,PJX,PJY,KXDIM)
             ELSE
C
C---------------------------------------------------------------------
CL              3.         assignment and particle bc - two cell case
C
C
CL                  3.1      two cell E-W case
C     old cell
             ZXI = AMAX0(ILO,ILN)
             ZTO = (ZXI-ZXO)/ZVX
             ZYI = ZYO + ZTO * ZVY
             CALL CURASS(ZXO,ZYO,ZXI,ZYI,PJX,PJY,KXDIM)
C     new cell
             ING=KNG(ILN,IMN)
             IF(ING.LE.0) THEN
C     interior cell
               CALL CURASS(ZXI,ZYI,ZXN,ZYN,PJX,PJY,KXDIM)
C     guard cell
               ELSE
               IF(KBCTYP(ING).LE.0) THEN
C     kill particle
                 ILIVE=.FALSE.
                 ELSE IF(KBCTYP(ING).EQ.1) THEN
C     periodic wrap round
                 ZPERX=(ILO-ILN)*ZXPER
                 ZXI=ZXI+ZPERX
                 ZXN=ZXN+ZPERX
                 CALL CURASS(ZXI,ZYI,ZXN,ZYN,PJX,PJY,KXDIM)
                 ELSE IF(KBCTYP(ING).EQ.2) THEN
C     domain decomposition
                 ILIVE=.FALSE.
                 ELSE IF(KBCTYP(ING).EQ.3) THEN
C     symmetry bc (reverse normal particle velocity)
                 ZXN = 2*ZXI - ZXN
                 PPX(IP)=-PPX(IP)
                 CALL CURASS(ZXI,ZYI,ZXN,ZYN,PJX,PJY,KXDIM)
                END IF
              END IF
             END IF
           ELSE IF (ILO.EQ.ILN) THEN
C
CL                  3.2      two cell N-S case
C     old cell
           ZYI = AMAX0(IMO,IMN)
           ZTO = (ZYI-ZYO) / ZVY
           ZXI = ZXO + ZTO * ZVX
           CALL CURASS(ZXO,ZYO,ZXI,ZYI,PJX,PJY,KXDIM)
C     new cell
           ING=KNG(ILN,IMN)
           IF(ING.LE.0) THEN
C     interior cell
             CALL CURASS(ZXI,ZYI,ZXN,ZYN,PJX,PJY,KXDIM)
C     guard cell
             ELSE
             IF(KBCTYP(ING).LE.0) THEN
C     kill particle
               ILIVE=.FALSE.
               ELSE IF(KBCTYP(ING).EQ.1) THEN
C     periodic wrap round
               ZPER=(IMO-IMN)*ZYPER
               ZYI=ZYI+ZPER
               ZYN=ZYN+ZPER
               CALL CURASS(ZXI,ZYI,ZXN,ZYN,PJX,PJY,KXDIM)
               ELSE IF(KBCTYP(ING).EQ.2) THEN
C     domain decomposition
               ILIVE=.FALSE.
               ELSE IF(KBCTYP(ING).EQ.3) THEN
C     symmetry bc (reverse normal particle velocity)
               ZYN = 2*ZYI - ZYN
               PPY(IP)=-PPY(IP)
               CALL CURASS(ZXI,ZYI,ZXN,ZYN,PJX,PJY,KXDIM)
               END IF
             END IF
           ELSE
C
C---------------------------------------------------------------------
CL              4.         three cell case
C
C
CL                  4.1      old cell
           ZTH = (AMAX0(IMO,IMN)-ZYO) / ZVY
           ZTV = (AMAX0(ILO,ILN)-ZXO) / ZVX
C
         IF(ZTV.LT.ZTH) THEN
C     east-west from old cell
           ILI=ILN
           IMI=IMO
           ZTO=ZTV
           ZDT=ZTH-ZTV
           ELSE
C     north-south from old cell
           ILI=ILO
           IMI=IMN
           ZTO=ZTH
           ZDT=ZTV-ZTH
           END IF
C
           ZXI1 = ZXO + ZTO * ZVX
           ZYI1 = ZYO + ZTO * ZVY
           ZXI2 = ZXI1 + ZDT * ZVX
           ZYI2 = ZYI1 + ZDT * ZVY
C
C
           CALL CURASS(ZXO,ZYO,ZXI1,ZYI1,PJX,PJY,KXDIM)
C
CL                  4.2      second cell
           INGI=KNG(ILI,IMI)
           IF(INGI.LE.0) THEN
C     interior cell
             CALL CURASS(ZXI1,ZYI1,ZXI2,ZYI2,PJX,PJY,KXDIM)
C     guard cell
             ELSE
             IF(KBCTYP(INGI).LE.0) THEN
C     kill particle
               ILIVE=.FALSE.
               ELSE IF(KBCTYP(INGI).EQ.1) THEN
C     periodic wrap round
               ZPERX=(ILO-ILI)*ZXPER
               ZPERY=(IMO-IMI)*ZYPER
               ZXI1=ZXI1+ZPERX
               ZXI2=ZXI2+ZPERX
               ZYI1=ZYI1+ZPERY
               ZYI2=ZYI2+ZPERY
               ZXN=ZXN+ZPERX
               ZYN=ZYN+ZPERY
               CALL CURASS(ZXI1,ZYI1,ZXI2,ZYI2,PJX,PJY,KXDIM)
C
               ELSE IF(KBCTYP(INGI).EQ.2) THEN
C     domain decomposition
               ILIVE=.FALSE.
               ELSE IF(KBCTYP(INGI).EQ.3) THEN
C     symmetry bc (reverse normal particle velocity)
               IF(IMI.EQ.IMO) THEN
                 ZXI2= 2*ZXI1- ZXI2
                 ZXN = 2*ZXI1- ZXN
                 PPX(IP)=-PPX(IP)
                 ELSE
                 ZYI2= 2*ZYI1- ZYI2
                 ZYN = 2*ZYI1- ZYN
                 PPY(IP)=-PPY(IP)
                 END IF
               CALL CURASS(ZXI1,ZYI1,ZXI2,ZYI2,PJX,PJY,KXDIM)
C
               END IF
             END IF
C
CL                  4.3      third cell
             IF(ILIVE) THEN
C
               IL3=ZXN
               IM3=ZYN
               ING=KNG(IL3,IM3)
               IF(ING.LE.0) THEN
C     interior cell
                 CALL CURASS(ZXI2,ZYI2,ZXN,ZYN,PJX,PJY,KXDIM)
C     guard cell
                 ELSE
                 IF(KBCTYP(ING).LE.0) THEN
C     kill particle
                   ILIVE=.FALSE.
                   ELSE IF(KBCTYP(ING).EQ.1) THEN
C     periodic wrap round
                   ZPERX=(ILI-ILN)*ZXPER
                   ZPERY=(IMI-IMN)*ZYPER
                   ZXI2=ZXI2+ZPERX
                   ZYI2=ZYI2+ZPERY
                   ZXN=ZXN+ZPERX
                   ZYN=ZYN+ZPERY
                   CALL CURASS(ZXI2,ZYI2,ZXN,ZYN,PJX,PJY,KXDIM)
                   ELSE IF(KBCTYP(ING).EQ.2) THEN
C     domain  decomposition
                   ILIVE=.FALSE.
                   ELSE IF(KBCTYP(ING).EQ.3) THEN
C     symmetry bc
                   IF(ILI.EQ.ILN) THEN
                     ZYN = 2*ZYI2-ZYN
                     PPY(IP)=-PPY(IP)
                     END IF
C
                   IF(IMI.EQ.IMN) THEN
                     ZXN = 2*ZXI2-ZXN
                     PPX(IP)=-PPX(IP)
                     END IF
C
                   CALL CURASS(ZXI2,ZYI2,ZXN,ZYN,PJX,PJY,KXDIM)
C
                 END IF
               END IF
             END IF
           END IF
C
C---------------------------------------------------------------------
CL              5.         update particle position
C
         IF(ILIVE) THEN
C
CL                  5.1      internal cell, periodic and symmetry
                   PKE = PKE + ZKE
           PX(IP)=ZXN
           PY(IP)=ZYN
C  Detect particles leaving region belonging to this processor
           CALL SNXPTC(2,IP,ZXN)
C
C****error trap
         ILMP=KLMAX2-1
         IMMP=KMMAX2-1
           IF(ZXN.LT.2.OR.ZXN.GE.ILMP.OR.ZYN.LT.2.OR.ZYN.GT.IMMP)THEN
           CALL MESAGE(' BC FAILURE DETECTED IN <2.2> MOVCUR')
C          NLEND=.TRUE.
              END IF
C*****
           ELSE
C
CL                  5.2      particle killed
                   PKEFLX=PKEFLX+ZKE
           PX(IP)=PX(INP)
           PY(IP)=PY(INP)
           PPX(IP)=PPX(INP)
           PPY(IP)=PPY(INP)
           INP=INP-1
C
C code needed here to buffer domain decomp bc particles lost
         END IF
C---------------------------------------------------------------------
  520    CONTINUE
         KNP=INP
         END
C/ MODULE C3S2
C
         SUBROUTINE SCAPLT(K)
C
C 3.2  scatter plot of current particle coords
C
C-----------------------------------------------------------------------
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C       INCLUDE 'COMDDP.inc'
C--------------------------------------------------------------------
CL                  C1.9.    DEVELOPMENT AND DIAGNOSTIC PARAMETERS
       COMMON/COMDDP/
     I   MAXDUM,   MXDUMP,   NADUMP,   NCLASS,   NPDUMP,   NPOINT,
     I   NSUB,     NVDUMP,
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       LOGICAL
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       DIMENSION
     I   NADUMP(20),         NPDUMP(20),         NVDUMP(20),
     L   NLHEAD(9),          NLOMT1(50),         NLOMT2(50),
     L   NLOMT3(50)
C       INCLUDE 'COMCON.inc'
C---------------------------------------------------------------------
CL                  C2.1     Physical Constants
       COMMON/COMCON/
     R   API   ,   BOLTZK,   CLIGHT,   ELCHAG,   ELMASS,   EMU0  ,
     R   EOVERM,   EPS0
C       INCLUDE 'COMSTT.inc'
C---------------------------------------------------------------------
CL                  C2.2     Physical State
       COMMON/COMSTT/
     R   B3    ,   BAV   ,   CD1   ,   CD2   ,   E1    ,   E2    ,
     R   P1    ,   P2    ,   Q1    ,   Q2    ,   REALTN,   TIMRUN
       DIMENSION
     R   B3(605,40),        BAV(605,40),       CD1(605,40),
     R   CD2(605,40),       E1(605,40),        E2(605,40),
     R   P1(20000),          P2(20000),          Q1(20000),
     R   Q2(20000)
C       INCLUDE 'COMDEV.inc'
C---------------------------------------------------------------------
CL                  C2.3     Device description
       COMMON/COMDEV/
     R   B3RHS ,   B3RHSD,   BAPLY ,   BAPLYD,   CAVEAM,   CAVEFR,
     R   CAVIC ,   CAVRES,   CAVTC ,   DEPTH ,   DEVHYT,   DEVLEN,
     R   DEVRAD,   EAPLYD,   EEMIT ,   EEMITD,   ENIT  ,   ENITD ,
     R   GAP   ,   RESAX ,   RESE  ,   RESN  ,   RESS  ,   RESW  ,
     R   RINNER,   SPACE ,   VOLTAG,   WIDTH ,
     I   LCATH ,   LCAV  ,   LLEFT ,   LWVANE,   MDEPTH,   MGAP  ,
     I   NBCAX ,   NBCCAV,   NBCE  ,   NBCN  ,   NBCS  ,   NBCW  ,
     I   NCAV  ,   NDEV
       DIMENSION
     R   CAVEAM(100),        CAVEFR(100),        CAVIC(4,100),
     R   CAVRES(100),        CAVTC(100),
     I   NBCCAV(100)
C       INCLUDE 'COMDIA.inc'
C---------------------------------------------------------------------
CL                  C2.4     Physical Diagnostics
       COMMON/COMDIA/
     R   B3POW ,   BOUT  ,   CAVPOY,   E1POW ,   E2POW ,   EJ1POW,
     R   EJ2POW,   EJENP ,   EJPOWM,   EJPOWP,   EJPWPN,   EKFLXI,
     R   EKFLXO,   ENEJ1 ,   ENEJ2 ,   ENEL1 ,   ENEL1O,   ENEL2 ,
     R   ENEL2O,   ENKIN ,   ENKINO,   ENMAG ,   ENMAGO,   ENPOYT,
     R   ENTOT ,   ENTOTO,   EOUT  ,   TOTM1 ,   TOTM2 ,   TPOYP ,
     I   LCAVEN,   LCAVST,   NPNEW ,   NPOLD
       DIMENSION
     R   BOUT(100),          CAVPOY(100),        EOUT(100),
     I   LCAVEN(100),        LCAVST(100)
C       INCLUDE 'COMNUM.inc'
C---------------------------------------------------------------------
CL                  C3.1     Numerical Parameters
       COMMON/COMNUM/
     R   C1    ,   C2    ,   CD0   ,   CURANT,   DT    ,   DX1   ,
     R   DX1DX2,   DX1OX2,   DX2   ,   DX2OX1,   ELPERP,   HLFDX1,
     R   HLFDX2,   TCACO ,
     I   LMAX  ,   LMAXP ,   LMAXP2,   MMAX  ,   MMAXP ,   MMAXP2,
     I   NEMIT ,   NP
C       INCLUDE 'COMSCA.inc'
C---------------------------------------------------------------------
CL                  C3.2     Scaling Factors
       COMMON/COMSCA/
     R   SCB3  ,   SCE1  ,   SCE2  ,   SCEMEN,   SCEPOW,   SCI1  ,
     R   SCI2  ,   SCIP  ,   SCKE  ,   SCKPOW,   SCP1  ,   SCP2  ,
     R   SCV1  ,   SCV2  ,   SCX1  ,   SCX2
C       INCLUDE 'COMHOK.inc'
C---------------------------------------------------------------------
CL                  C4.1     Housekeeping
       COMMON/COMHOK/
     R   TIMECP,   XPSMAX,   XPSMIN,   YPSMAX,   YPSMIN,
     I   N1MAX ,   N2MAX ,   NCASE ,   NGMAX ,   NOSEP ,   NPDUM ,
     I   NPMAX ,   NSRC  ,   NXDUM ,   NYDUM
       DIMENSION
     R   TIMECP(32)
C       INCLUDE 'COMGEO.inc'
C---------------------------------------------------------------------
CL                  C4.2     Device boundary data
       COMMON/COMGEO/
     R   ASCUR ,   CCTSRC,   EBEXT ,   ELSCUR,   ENSUR ,   EPOYNT,
     R   RHOC  ,   SURCHG,   SURIC ,
     I   LINDEX,   MINDEX,   NBCTYP,   NBDIM ,   NBSEG2,   NCOLOR,
     I   NDIRN ,   NG
       DIMENSION
     R   ASCUR(1500),        CCTSRC(1500),       EBEXT(2,1500),
     R   ELSCUR(1500),       ENSUR(1500),        EPOYNT(1500),
     R   RHOC(1500),         SURCHG(1500),       SURIC(4,1500),
     I   LINDEX(1500),       MINDEX(1500),       NBCTYP(1500),
     I   NCOLOR(1500),       NDIRN(1500),        NG(605,40)
C       INCLUDE 'COMOUT.inc'
C---------------------------------------------------------------------
CL                  C5.1     Output Variables
       COMMON/COMOUT/
     R   BCNMAX,   BCNMIN,   BCVMAX,   BCVMIN,   CUAMAX,   CUAMIN,
     R   CUEMAX,   CUEMIN,   ECVMAX,   ECVMIN,   TONS1 ,   TONS2 ,
     R   TONS3 ,   TONS4 ,   TONS5 ,   TONS6 ,   TONS7 ,
     I   NBCHT ,   NOPSEL,   NS1   ,   NS2   ,   NS3   ,   NS4   ,
     I   NS5   ,   NS6   ,   NS7
C
      COMMON /MTINY/ MYNUM,NSLAV,NTASK,ISLMIN(128),ISLMAX(128)
C
         DIMENSION   ZBX(1500),        ZBY(1500),        ZWK(3072)
C
C-----------------------------------------------------------------------
CL              1.         set plot mappings
C
C
CL                  1.1      set pspace
C     adjust plot size to overlap line graphs in x
C     and have right size after collaging
C     it is assumed collaging reduces vertical by 2
C     unless the y pspace max exceeds 1,in which
C     case the vertical scaling is set to unity
         ZDX=(XPSMAX-XPSMIN)/(LMAX-1)
         ZXP1=XPSMIN-ZDX
         ZXP2=XPSMAX+ZDX
C
         ZDY=(YPSMAX-YPSMIN)/(MMAX-1)
         ZYSC=2*DEVHYT/DEVLEN
         ZYP1=(YPSMIN-ZDY)*ZYSC
         ZYP2=(YPSMAX+ZDY)*ZYSC
  10     IF(ZYP2.LT.1) GOTO 11
         ZYSC=ZYSC/2
         ZYP1=(YPSMIN-ZDY)*ZYSC
         ZYP2=(YPSMAX+ZDY)*ZYSC
         GOTO 10
   11    CONTINUE
         ZYSH=(YPSMIN+YPSMAX-ZYP1-ZYP2)*0.5
         ZYP1=ZYP1+ZYSH
         ZYP2=ZYP2+ZYSH
         CALL PSPACE(ZXP1,ZXP2,ZYP1,ZYP2)
C
CL                  1.2      set mapping
         ZXL=1.
         ZXU=LMAXP2
         ZYL=1.
         ZYU=MMAXP2
         CALL MAP(ZXL,ZXU,ZYL,ZYU)
         CALL LINCOL(4)
C        CALL BACCOL(60)
         CALL FULL
C
C-----------------------------------------------------------------------
CL              2.         label the plot
C
         IF(K.EQ.1) THEN
C        CALL BACCOL(60)
         CALL CTRMAG(20)
         CALL PLACE(7,1)
         CALL TYPECS('PARTICLE DISTRIBUTION')
         CALL CTRMAG(10)
         CALL PLACE(14,5)
         CALL TYPECS(CHLAB1)
         CALL PLACE(14,7)
         CALL TYPECS('TIME:')
         CALL TYPECS(CHRTIM)
         CALL TYPECS('     DATE:')
         CALL TYPECS(CHRDAT)
         CALL CTRFNT(1)
         CALL CTRMAG(10)
         CALL PLACE(89,3)
         CALL TYPECS('            ')
         CALL PLACE(89,5)
         CALL TYPECS('     ')
         CALL PLACE(89,7)
         CALL TYPECS('      ')
         CALL ITALIC(0)
         CALL FRAME
C
C-----------------------------------------------------------------------
CL              3.         draw electrodes
C
         CALL BORDER
         CALL BOX(ZXL+1,ZXU-1,ZYL+1,ZYU-1)
C
CL                  3.1      Shade the anode
         ZANG = 90.0
         ISEP = NOSEP
         ZTOR = 1.7453292E-2
         CALL THICK(1)
C
C     load shading arrays
         ZBX(1) = ZXU
         ZBY(1) = ZYU
         ZBX(2) = ZXL
         ZBY(2) = ZYU
         ZBX(3) = ZXL
         ZBY(3) = MINDEX(2)
         IDIRO  = NDIRN(2)
C
         ISIDES=3
         ICOLOR=IEBS(NCOLOR(2))
         CALL LINCOL(ICOLOR)
         IS=1
C
  310    IS=IS+1
         IF(NDIRN(IS).NE.IDIRO) THEN
           IDIRO=NDIRN(IS)
           ISIDES=ISIDES+1
           ZBX(ISIDES) = LINDEX(IS)
           ZBY(ISIDES) = MINDEX(IS)
         END IF
         IF(IEBS(NCOLOR(IS)).EQ.ICOLOR) GO TO 310
C
         ISIDES=ISIDES+1
         ZBX(ISIDES) = ZXU
         ZBY(ISIDES) = ZBY(ISIDES-1)
         ISIDES=ISIDES+1
         ZBX(ISIDES) = ZXU
         ZBY(ISIDES) = ZYU
C
         ZANGS = ATAN2((ZYU-ZYL)*SIN(ZANG*ZTOR),
     +                 (ZXU-ZXL)*COS(ZANG*ZTOR))
         ZANGS = ZANGS / ZTOR
         CALL SHADE(ZBX,ZBY,ZWK,ISIDES,ZANGS,ISEP)
C     FLOOD FILL
         CALL FILCOL(ICOLOR)
         CALL PTJOIN(ZBX,ZBY,1,ISIDES,-1)
C
C
CL                  3.2      Shade the cathode
         ZANG = 0.0
         ISEP = NOSEP*2
         ZTOR = 1.7453292E-2
         ICOLOR=4
         IFCOL =6
  320    IS=IS+1
         IF(IEBS(NCOLOR(IS)).NE.ICOLOR) GO TO 320
C
C     load shading arrays
         ZBX(1) = ZXL
         ZBY(1) = ZYL
         ZBX(2) = LINDEX(IS)
         ZBY(2) = ZYL
         ZBX(3) = LINDEX(IS)
         ZBY(3) = MINDEX(IS)
         IDIRO  = NDIRN(IS)
C
         ISIDES=3
         CALL LINCOL(ICOLOR)
C
  321    IS=IS+1
         IF(NDIRN(IS).NE.IDIRO) THEN
           IDIRO=NDIRN(IS)
           ISIDES=ISIDES+1
           ZBX(ISIDES) = LINDEX(IS)
           ZBY(ISIDES) = MINDEX(IS)
         END IF
         IF(IEBS(NCOLOR(IS)).EQ.ICOLOR) GO TO 321
C
         ISIDES=ISIDES+1
         ZBX(ISIDES) = ZXL
         ZBY(ISIDES) = ZBY(ISIDES-1)
         ISIDES=ISIDES+1
         ZBX(ISIDES) = ZXL
         ZBY(ISIDES) = ZYL
C
         ZANGS = ATAN2((ZYU-ZYL)*SIN(ZANG*ZTOR),
     +                 (ZXU-ZXL)*COS(ZANG*ZTOR))
         ZANGS = ZANGS / ZTOR
         CALL SHADE(ZBX,ZBY,ZWK,ISIDES,ZANGS,ISEP)
C     FLOOD FILL
         CALL FILCOL(IFCOL)
         CALL PTJOIN(ZBX,ZBY,1,ISIDES,-1)
C
CL                  3.3      add tick marks every cm
         CALL LINCOL(5)
C
C     Along x direction
         ZXDIV=(LMAX-1)/100.0/DEVLEN
         IT=0
         ZX=2
  330    ZYTOP=ZYL+0.35
         ZYBOT=ZYU-0.35
         IF((IT/5)*5.EQ.IT)THEN
         ZYTOP=ZYL+0.75
         ZYBOT=ZYU-0.75
         END IF
         CALL POSITN(ZX,ZYL)
         CALL JOIN(ZX,ZYTOP)
         CALL POSITN(ZX,ZYU)
         CALL JOIN(ZX,ZYBOT)
         ZX=ZX+ZXDIV
         IT=IT+1
         IF(ZX.LT.LMAXP2) GO TO 330
C     Along y direction
         ZYDIV=(MMAX-1)/100.0/DEVHYT
         IT=0
         ZY=2
  331    ZXTOP=ZXL+0.35
         ZXBOT=ZXU-0.35
         IF((IT/5)*5.EQ.IT)THEN
         ZXTOP=ZXL+0.75
         ZXBOT=ZXU-0.75
         END IF
         CALL POSITN(ZXL,ZY)
         CALL JOIN(ZXTOP,ZY)
         CALL POSITN(ZXU,ZY)
         CALL JOIN(ZXBOT,ZY)
         ZY=ZY+ZYDIV
         IT=IT+1
         IF(ZY.LT.MMAXP2) GO TO 331
C
         CALL PSPACE(XPSMIN,XPSMAX,YPSMIN,YPSMAX)
         CALL FRAME
C
C
C-----------------------------------------------------------------------
CL              4.         particle coords
C
         ELSE IF(K.EQ.2) THEN
         CALL LINCOL(4)
         DO 400 J = 1,NP
         ZX=Q1(J)
         ZY=Q2(J)
Cskip
C        if(zx .lt. islmin(mynum+1) .or.
C    1      zx .ge. islmax(mynum+1)+1.0) goto 400
         CALL PLOTNC(ZX,ZY,172)
  400    CONTINUE
         END IF
C-----------------------------------------------------------------------
         CALL PICNOW
         CALL FILCOL(0)
         CALL PSPACE(XPSMIN,XPSMAX,YPSMIN,YPSMAX)
C
         END
C/ MODULE C2S11
C
        SUBROUTINE EMITEL(PX,PY,PPX,PPY,KNP,KNPMAX,
     +                     PEX,PEY,KXDIM,PEEMIT,PARCH,PC1,PC2,KL,
     +                     KM,KDIRN,KBCTYP,
     +                     KCOLOR,PCHG,PEN,KBSEG2,PRZERO,PENK)
C
C 2.2  Emit electrons from negative coloured surfaces
C     .     for fields E > PEEMIT
C-----------------------------------------------------------------------
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C       INCLUDE 'COMDDP.inc'
C--------------------------------------------------------------------
CL                  C1.9.    DEVELOPMENT AND DIAGNOSTIC PARAMETERS
       COMMON/COMDDP/
     I   MAXDUM,   MXDUMP,   NADUMP,   NCLASS,   NPDUMP,   NPOINT,
     I   NSUB,     NVDUMP,
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       LOGICAL
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       DIMENSION
     I   NADUMP(20),         NPDUMP(20),         NVDUMP(20),
     L   NLHEAD(9),          NLOMT1(50),         NLOMT2(50),
     L   NLOMT3(50)
C-----------------------------------------------------------------------
         DATA   ICLASS,ISUB/2,11/
C-----------------------------------------------------------------------
C.    Input:  positions (PX(J),PY(J),J=1,KNP) at timelevel n
C.            momenta (PPX(J),PPY(J),J=1,KNP) at timelevel n+1/2
C.            KNPMAX dimension of particle arrays
C.            PEX 1-component of electric fields
C.            PEY 2-component of electric fields
C.            KXDIM 1-dimension of field arrays
C.            PEEMIT emission threshold field
C.            PARCH charge per superparticle electron
C.            PRZERO radius of inner edge of comp. box.
C.            PC1 1-direction courant no (effectively 1/dx)
C.            PC2 2-direction courant no (effectively 1/dy)
C.            KL surface element 1 index table
C.            KM surface element 2 index table
C.            KDIRN surface element direction index table
C.            KCOLOR colour index of surface element
C.            PCHG particle charge on surface element
C.            PEN  E field normal to surface element
C.            PENK K E of emitted electrons
C.            KBSEG2 no of boundary segments + 2
C.
C.    Output: new particle positions and momenta at emitting surfac
C.
C.
C-----------------------------------------------------------------------
       DIMENSION
     +   PX(KNPMAX),         PY(KNPMAX),         PPX(KNPMAX),
     +   PPY(KNPMAX)
       DIMENSION   PEX(KXDIM,*),       PEY(KXDIM,*)
       DIMENSION
     +   KL(KBSEG2),         KM(KBSEG2),         KDIRN(KBSEG2),
     +   KBCTYP(KBSEG2),
     +   KCOLOR(KBSEG2),     PCHG(KBSEG2),       PEN(KBSEG2)
C-----------------------------------------------------------------------
      COMMON /MTINY/ MYNUM,NSLAV,NTASK,ISLMIN(128),ISLMAX(128)
C-----------------------------------------------------------------------
                          CALL EXPERT(ICLASS,ISUB,1)
         IF(NLOMT2(ISUB)) RETURN
C
C-----------------------------------------------------------------------
CL              1.         find charge deficiency
C
         INSEG1=KBSEG2-1
         ZR01=PRZERO-2
         ZR02=PRZERO-1.5
         INP=KNP+1
         ISTART=3
         IEND=ISTART
C
         DO 100 JSEG=1,KBSEG2
         PEN(JSEG)=0.0
C        PCHG(JSEG)=0.0
  100    CONTINUE
C
         DO 130 JSEG=3,INSEG1
         ICC=KCOLOR(JSEG)
         IF(ICC.LT.0) THEN
C     JSEG is an emitter
         IF(ISTART.EQ.3)ISTART=JSEG
         IEND=JSEG
C
CL                  1.1      indexing
          IDC=KDIRN(JSEG)
          IDP=KDIRN(JSEG-1)
          IF(IDP.EQ.1)IDP=5
          IDN=KDIRN(JSEG+1)
          IF(IDN.EQ.4)IDN=0
          IL=KL(JSEG)
          IM=KM(JSEG)
C
CL                  1.2      find fields
          IF(IDC.EQ.4) THEN
C     south
           ZEL = PEY(IL-1,IM)*(IM+ZR02)
           ZER = PEY(IL,IM)*(IM+ZR02)
           ELSE IF(IDC.EQ.1) THEN
C     west
           ZEL = PEX(IL,IM+1)*(IM+1+ZR01)
           ZER = PEX(IL,IM)*(IM+ZR01)
C     axis case
           IF(IM.EQ.2.AND.PRZERO.LE.0.0)ZER=ZER/4.0
C
           ELSE IF(IDC.EQ.2) THEN
C     north
           ZEL =-PEY(IL+1,IM-1)*(IM-1+ZR02)
           ZER =-PEY(IL,IM-1)*(IM-1+ZR02)
           ELSE
C     east
           ZEL =-PEX(IL-1,IM-1)*(IM-1+ZR01)
           ZER =-PEX(IL-1,IM)*(IM+ZR01)
C     axis case
         IF(IM.EQ.3.AND.PRZERO.LE.0.0)ZEL=ZEL/4.0
C
           END IF
C     convex corners case
           IF(IDP.EQ.IDC+1) ZER = 2*ZER
           IF(IDN.EQ.IDC-1) ZEL = 2*ZEL
C
CL                  1.3      store charge deficiencies
            ZPC=PARCH*PC1*2
C next line is emission field fudge
C           ZPC=PARCH*PC1*8
            IF(IDC.EQ.1.OR.IDC.EQ.3) ZPC=PARCH*PC2*2
C
          PCHG(JSEG)  =PCHG(JSEG  ) - ZER/ZPC
          PCHG(JSEG+1)=PCHG(JSEG+1) - ZEL/ZPC
          PEN(JSEG  ) = PEN(JSEG  ) + ZER/2
          PEN(JSEG+1) = PEN(JSEG+1) + ZEL/2
C
          END IF
  130    CONTINUE
C
C-----------------------------------------------------------------------
CL              2.         emit electrons
C
C     limit emission at end of cathode
C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C       cosine bell end disabled by C on next 3 lines
C        PCHG(IEND+1)=0.0
C        PCHG(IEND)=PCHG(IEND)*0.25
C        PCHG(IEND-1)=PCHG(IEND-1)*.75
C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
         ZQOUT=RANDS(0)
C
C       periodic bc fixup
         IDO=KDIRN(1)
         IBCO=KBCTYP(1)
C       locate E corner
        DO 210 JSEG=2,KBSEG2
         IDN=KDIRN(JSEG)
         IBC=KBCTYP(JSEG)
         ISEGE=JSEG
         IF(IBCO.EQ.1.AND.IBC.EQ.0.AND.IDN.EQ.4.AND.IDO.EQ.3)GOTO 211
         IDO=IDN
  210    IBCO=IBC
C       failure,so give up
                 GO TO 214
C       success, so find W corner
  211    DO 212 JSEG=ISEGE,KBSEG2
                 ISEGW=JSEG
                 IF(KL(JSEG).EQ.2) GO TO 213
  212    CONTINUE
C       inconsistency
         CALLMESAGE('PERIODIC WRAP FAILURE IN <2.11>EMITEL')
         STOP
C   apply periodic bc to charge and field
  213    PCHG(ISEGW)=PCHG(ISEGW)+PCHG(ISEGE)
         PEN (ISEGW)=PEN (ISEGW)+PEN (ISEGE)
         PCHG(ISEGE)=PCHG(ISEGW)
         PEN (ISEGE)=PEN (ISEGW)
C-----------------------------------------------------------------------
  214    DO 202 JSEG=ISTART,INSEG1
         ICC=KCOLOR(JSEG)
         IF(ICC.LT.0) THEN
C
C     establish segment orientation
         IL=KL(JSEG)
         IM=KM(JSEG)
         ZXSGN=0
         ZYSGN=0
         ZVXSGN=0
         ZVYSGN=0
         IDC=KDIRN(JSEG)
         IF(IDC.EQ.4) THEN
         ZVYSGN=2
C fudge factor
         zvysgn=0.10
C end fudge
         ZXSGN=-1
         ELSE IF(IDC.EQ.1) THEN
         ZVXSGN=2
         ZYSGN=1
         ELSE IF(IDC.EQ.2) THEN
         ZVYSGN=-2
         ZXSGN=1
         ELSE
         ZVXSGN=-2
         ZYSGN=-1
         END IF
C
C     left half
         ZQIN=ZQOUT
         ZQL=-PCHG(JSEG)
         ZQL2=ZQL/2
         ZQTOT=ZQL2+ZQIN
         INL=ZQTOT
         ZQRES=ZQTOT-INL
C     emit
         IF(INL.GT.0.AND.PEN(JSEG).GT.PEEMIT) THEN
         DO 200 J=1,INL
          ZDX=(J-ZQIN)/ZQL
          ZXC=IL+ZXSGN*ZDX
C  Omit injection if out of region
Cskip
          if(zxc .lt. islmin(mynum+1) .or.
     1       zxc .ge. islmax(mynum+1)+1.0) goto 200
          KNP=KNP+1
          IF(KNP.GT.KNPMAX) GO TO 400
          ZDP=PEN(JSEG)*RANDS(0)
          PX(KNP)=IL+ZXSGN*ZDX
          PY(KNP)=IM+ZYSGN*ZDX
          PPX(KNP)=ZDP*ZVXSGN
          PPY(KNP)=ZDP*ZVYSGN
  200    CONTINUE
         END IF
C
C     right half
         ZQR=-PCHG(JSEG+1)
         ZQR2=ZQR/2
         ZQTOT=ZQR2+ZQRES
         INR=ZQTOT
         ZQOUT=ZQTOT-INR
C     emit
         IF(INR.GT.0.AND.PEN(JSEG+1).GT.PEEMIT) THEN
         DO 201 J=1,INR
          ZDX=(J-ZQRES)/ZQR+0.5
          ZXC=IL+ZXSGN*ZDX
C  Omit injection if out of region
Cskip
         IF(zxc .lt. islmin(mynum+1) .or.
     1      zxc .ge. islmax(mynum+1)+1.0) goto 201
          KNP=KNP+1
          IF(KNP.GT.KNPMAX) GO TO 400
          ZDP=PEN(JSEG+1)*RANDS(0)
          PX(KNP)=IL+ZXSGN*ZDX
          PY(KNP)=IM+ZYSGN*ZDX
          PPX(KNP)=ZDP*ZVXSGN
          PPY(KNP)=ZDP*ZVYSGN
  201    CONTINUE
         END IF
         END IF
  202    CONTINUE
C
C-----------------------------------------------------------------------
CL              3.         KE of emitted electrons
C
         PENK=0.0
         IF(INP.LE.KNP) THEN
         DO 300 JP=INP,KNP
         ZPSQ=PPX(JP)**2+PPY(JP)**2
         ZGAM=SQRT(1.0+ZPSQ)
         PENK=PENK+ZPSQ/(1.0+ZGAM)
  300    CONTINUE
         END IF
         RETURN
C
C-----------------------------------------------------------------------
CL              4.         Table overflow
C
  400    CALLMESAGE('  ==PARTICLE TABLE OVERFLOW - RUN ABANDONED====  ')
C-----------------------------------------------------------------------
         STOP
         END
C
      REAL FUNCTION REND(KFLAG)
C
C  RAONDOM NUMBER [0.0-1.0]
C
C  KFLAG = 1   INITIALISE
C        = 0   REND CONTAINS NEXT RANDOM NUMBER
C
      INTEGER ISW/0/
      SAVE INIT,ISW
C
      IF(ISW .EQ. 0) THEN
        INIT=1325
        ISW=1
      ENDIF
      IF(KFLAG .EQ. 0) THEN
            INIT = MOD(3125*INIT,65536)
            REND = (INIT - 32768.0)/65536.0 +0.5
      ELSEIF (KFLAG .EQ. 1) THEN
            INIT=1325
            INIT = MOD(3125*INIT,65536)
            REND = (INIT - 32768.0)/65536.0 +0.5
      ENDIF
C
      IF (REND .LT. 0.0) REND=0.0
      IF (REND .GT. 1.0) REND=1.0
C
      END
C
C *********************************************************
C
         INTEGER FUNCTION IEBS(N)
         IF(N .LT. 0) THEN
            IEBS=-N
         ELSE
            IEBS=N
         ENDIF
         END
C/ MODULE C2S9
C
         SUBROUTINE SETCUR(PBZ,PBAV,PJX,PJY,KXDIM,KLMAX2,KMMAX2,PRZERO,
     +                     PJCOEF,KL,KM,KDIR,KBCTYP,KBSEG2)
C
C 2.9  Clear current arrays and add transverse current adjustment
C
C-----------------------------------------------------------------------
C.    Input:  PBZ  magnetic field at timelevel n+1/2
C.            PBAV magnetic field at timelevel n
C.            KXDIM dimension of first arg. of mesh arrays
C.            PRZERO radius of inner edge of computational box
C.            PJCOEF transverse current adjustment magnitude
C.            KBCTYP bc type array
C.            KL x index of surface element
C.            KM y index of surface element
C.            KDIR direction index of surface element
C.            KBSEG2 no of boundary segments + 2
C.
C.    Output: current densities (PJX(L,M),PJY(L,M)) at n+1/2 on
C.            a rectangular mesh with the usual TM interlacing
C.            and of size klmax2 * kmmax2. The values loaded by the
C.            transverse current adjustment are given by
C.            PJCOEF*curl(curl(E))
C.            The TCA is set to zero on boundary nodes.
C.
C.    Note:   PBAV values are overwritten by this routine.
C.            Remember current arrays are scaled after particle
C.            current assignment - divide value of PJCOEF by
C.            the multiplier (CD0 in venus-rz) before entering
C.            this routine.
C.
C-----------------------------------------------------------------------
       DIMENSION
     +   PBZ(KXDIM,KMMAX2),  PBAV(KXDIM,KMMAX2), PJX(KXDIM,KMMAX2),
     +   PJY(KXDIM,KMMAX2),  KBCTYP(KBSEG2),     KL(KBSEG2),
     +   KM(KBSEG2),         KDIR(KBSEG2)
C
C-----------------------------------------------------------------------
      COMMON /MTINY/ MYNUM,NSLAV,NTASK,ISLMIN(128),ISLMAX(128)
C-----------------------------------------------------------------------
CL              1.         Find B-dot*radius*pjcoef
C
         ZRIN=PRZERO-1.5
         DO 100 JM=1,KMMAX2
         ZRAD=ZRIN+JM
         ZJCOEF=PJCOEF*ZRAD*2.0
         DO 100 JL=1,KLMAX2
         PBAV(JL,JM)=ZJCOEF*(PBZ(JL,JM)-PBAV(JL,JM))
  100    CONTINUE
C
C-----------------------------------------------------------------------
CL              2.         compute TCA
C
C
CL                  2.1      initialise
         ILMAXP=KLMAX2-1
         ILMAX=ILMAXP-1
Cskip
C  limit current assignment to x-coords belonging to processor
         il1=islmin(mynum+1)
         il2=islmax(mynum+1)
         if(il1 .lt. 2) il1=2
         if(il2 .gt. ilmaxp) il2=ilmaxp
C
         IMMAXP=KMMAX2-1
         IMMAX=IMMAXP-1
C
CL                  2.2      update JX (z direction)
         DO 220 JM=2,IMMAXP
Cskip
C        DO 220 JL=2,ILMAX
           pjx(il1-1,jm)=0.0
           pjx(il2+1,jm)=0.0
         do 220 jl=il1,il2
  220    PJX(JL,JM)=PBAV(JL,JM-1)-PBAV(JL,JM)
C
CL                  2.3      update JY (r direction)
         DO 230 JM=2,IMMAX
Cskip
C        DO 230 JL=2,ILMAXP
           pjy(il1-1,jm)=0.0
           pjy(il2+1,jm)=0.0
         do 230 jl=il1,il2
  230    PJY(JL,JM)=PBAV(JL,JM)-PBAV(JL-1,JM)
C-----------------------------------------------------------------------
         END
C/ MODULE C2S10
C
         SUBROUTINE SURDEN(PX,PY,KNP,KNG,KXDIM,
     +                     KL,KM,KDIRN,KBCTYP,PCHG,KBSEG2)
C
C 2.2  Compute particle surface charge
C
C     .     using area weighting
C-----------------------------------------------------------------------
C.    Input:  positions (PX(J),PY(J),J=1,KNP) at timelevel n
C.            KNG grid mask array
C.            KBCTYP bc type array
C.            KBSEG2 no of boundary segments + 2
C.            KL surface element 1 index table
C.            KM surface element 2 index table
C.            KDIRN surface element direction index table
C.
C.    Output: surface charge PCHG(1...KBSEG2)
C.
C.
C-----------------------------------------------------------------------
       DIMENSION
     +   PX(KNP),  PY(KNP),  KNG(KXDIM,*),       KBCTYP(KBSEG2),
     +   KL(KBSEG2),         KM(KBSEG2),         KDIRN(KBSEG2),
     +   PCHG(KBSEG2),       ZQ(4)
C
      COMMON /MTINY/ MYNUM,NSLAV,NTASK,ISLMIN(128),ISLMAX(128)
C-----------------------------------------------------------------------
CL              1.         clear
C
         DO 100 JSEG=1,KBSEG2
         PCHG(JSEG)=0.0
  100    CONTINUE
C
C-----------------------------------------------------------------------
CL              2.         Assign
C
         IF(KNP.GE.1) THEN
         DO 210 JP=1,KNP
C     locate element
           ILM=PX(JP)
           IMM=PY(JP)
Cskip
         if(ilm .lt. islmin(mynum+1) .or. ilm .ge. islmax(mynum+1)+1)
     1     GOTO 210
           ING=-KNG(ILM,IMM)
           IF(ING.GT.0) THEN
C     offsets
             ZX=PX(JP)-ILM
             ZY=PY(JP)-IMM
             ZXM=1.0-ZX
             ZYM=1.0-ZY
C     weights
             ZQ(1)=ZXM*ZYM
             ZQ(2)=ZXM*ZY
             ZQ(3)=ZX *ZY
             ZQ(4)=ZX *ZYM
C
CL                  2.1      Accumulate charges
C     corner on boundary
         IF(ING.EQ.1) THEN
C     bottom left
         INGW=-KNG(ILM-1,IMM  )
         IF(INGW.GT.0)PCHG(INGW)=PCHG(INGW)+ZQ(1)
C     top left
         INGN=-KNG(ILM  ,IMM+1)
         IF(INGN.GT.0)PCHG(INGN)=PCHG(INGN)+ZQ(2)
C     top right
         INGE=-KNG(ILM+1,IMM  )
         IF(INGE.GT.0)PCHG(INGE)=PCHG(INGE)+ZQ(3)
C     bottom right
         INGS=-KNG(ILM  ,IMM-1)
         IF(INGS.GT.0)PCHG(INGS)=PCHG(INGS)+ZQ(4)
         ELSE
C     first segment
             ID=KDIRN(ING)
             IDP=ID+1
             IF(IDP.EQ.5)IDP=1
             PCHG(ING)=PCHG(ING)+ZQ(ID)
             PCHG(ING+1)=PCHG(ING+1)+ZQ(IDP)
C     previous segment
             IDP=ID-1
             IF(IDP.EQ.0)IDP=4
             IDM=KDIRN(ING-1)
             IF(IDM.EQ.IDP) THEN
               INGM=ING-1
               IF(INGM.EQ.1)INGM=KBSEG2-2
               PCHG(INGM)=PCHG(INGM)+ZQ(IDM)
C     three segment case
               IDP=IDP-1
               IF(IDP.EQ.0)IDP=4
               IDM=KDIRN(ING-2)
               IF(IDM.EQ.IDP) THEN
                 INGM=INGM-1
                 IF(INGM.EQ.1)INGM=KBSEG2-2
                 PCHG(INGM)=PCHG(INGM)+ZQ(IDM)
               END IF
             END IF
           END IF
           END IF
  210    CONTINUE
         END IF
C
C-----------------------------------------------------------------------
CL              3.         End wrap
C
         PCHG(2)=PCHG(2)+PCHG(KBSEG2-1)
         PCHG(3)=PCHG(3)+PCHG(KBSEG2)
         PCHG(KBSEG2)=PCHG(3)
         PCHG(KBSEG2-1)=PCHG(2)
C-----------------------------------------------------------------------
         END
C
C/ MODULE c0s0
C
         SUBROUTINE MISTER
C
C 0.0  FORTRAN MASTER PROGRAM
C
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C-----------------------------------------------------------------------
C
C     date and time stamp for current run
C        CALL TIMDAT(CHRTIM,CHRDAT)
C        CHDATO=CHRDAT
C        CHTIMO=CHRTIM
         CHRTIM='        '
         CHRDAT='        '
         CHDATO='        '
         CHTIMO='        '
C
C     TIME ALLOCATED TO JOB
         CALL JOBTIM(ALTIME)
C
C     SET UP THE BASIC CONTROL DATA
         CALL BASIC
C
C     PRINT DATE AND TIME
C        CALL DAYTIM
C
C     CONTROL THE RUN
         CALL COTROL
C
C
         CLOSE(UNIT=NOUT)
         END
C/ MODULE c5s2
C
         SUBROUTINE CLIST(KGROUP,KBLOCK)
C
C 5.2  PRINT COMMON VARIABLES
C
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C       INCLUDE 'COMDDP.inc'
C--------------------------------------------------------------------
CL                  C1.9.    DEVELOPMENT AND DIAGNOSTIC PARAMETERS
       COMMON/COMDDP/
     I   MAXDUM,   MXDUMP,   NADUMP,   NCLASS,   NPDUMP,   NPOINT,
     I   NSUB,     NVDUMP,
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       LOGICAL
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       DIMENSION
     I   NADUMP(20),         NPDUMP(20),         NVDUMP(20),
     L   NLHEAD(9),          NLOMT1(50),         NLOMT2(50),
     L   NLOMT3(50)
C       INCLUDE 'COMCON.inc'
C---------------------------------------------------------------------
CL                  C2.1     Physical Constants
       COMMON/COMCON/
     R   API   ,   BOLTZK,   CLIGHT,   ELCHAG,   ELMASS,   EMU0  ,
     R   EOVERM,   EPS0
C       INCLUDE 'COMSTT.inc'
C---------------------------------------------------------------------
CL                  C2.2     Physical State
       COMMON/COMSTT/
     R   B3    ,   BAV   ,   CD1   ,   CD2   ,   E1    ,   E2    ,
     R   P1    ,   P2    ,   Q1    ,   Q2    ,   REALTN,   TIMRUN
       DIMENSION
     R   B3(605,40),        BAV(605,40),       CD1(605,40),
     R   CD2(605,40),       E1(605,40),        E2(605,40),
     R   P1(20000),          P2(20000),          Q1(20000),
     R   Q2(20000)
C       INCLUDE 'COMDEV.inc'
C---------------------------------------------------------------------
CL                  C2.3     Device description
       COMMON/COMDEV/
     R   B3RHS ,   B3RHSD,   BAPLY ,   BAPLYD,   CAVEAM,   CAVEFR,
     R   CAVIC ,   CAVRES,   CAVTC ,   DEPTH ,   DEVHYT,   DEVLEN,
     R   DEVRAD,   EAPLYD,   EEMIT ,   EEMITD,   ENIT  ,   ENITD ,
     R   GAP   ,   RESAX ,   RESE  ,   RESN  ,   RESS  ,   RESW  ,
     R   RINNER,   SPACE ,   VOLTAG,   WIDTH ,
     I   LCATH ,   LCAV  ,   LLEFT ,   LWVANE,   MDEPTH,   MGAP  ,
     I   NBCAX ,   NBCCAV,   NBCE  ,   NBCN  ,   NBCS  ,   NBCW  ,
     I   NCAV  ,   NDEV
       DIMENSION
     R   CAVEAM(100),        CAVEFR(100),        CAVIC(4,100),
     R   CAVRES(100),        CAVTC(100),
     I   NBCCAV(100)
C       INCLUDE 'COMDIA.inc'
C---------------------------------------------------------------------
CL                  C2.4     Physical Diagnostics
       COMMON/COMDIA/
     R   B3POW ,   BOUT  ,   CAVPOY,   E1POW ,   E2POW ,   EJ1POW,
     R   EJ2POW,   EJENP ,   EJPOWM,   EJPOWP,   EJPWPN,   EKFLXI,
     R   EKFLXO,   ENEJ1 ,   ENEJ2 ,   ENEL1 ,   ENEL1O,   ENEL2 ,
     R   ENEL2O,   ENKIN ,   ENKINO,   ENMAG ,   ENMAGO,   ENPOYT,
     R   ENTOT ,   ENTOTO,   EOUT  ,   TOTM1 ,   TOTM2 ,   TPOYP ,
     I   LCAVEN,   LCAVST,   NPNEW ,   NPOLD
       DIMENSION
     R   BOUT(100),          CAVPOY(100),        EOUT(100),
     I   LCAVEN(100),        LCAVST(100)
C       INCLUDE 'COMKLY.inc'
C---------------------------------------------------------------------
CL                  C2.5     Klystron device details
       COMMON/COMKLY/
     R   BMCUR ,   BMMOM ,   BMRIN ,   BMROUT
C       INCLUDE 'COMNUM.inc'
C---------------------------------------------------------------------
CL                  C3.1     Numerical Parameters
       COMMON/COMNUM/
     R   C1    ,   C2    ,   CD0   ,   CURANT,   DT    ,   DX1   ,
     R   DX1DX2,   DX1OX2,   DX2   ,   DX2OX1,   ELPERP,   HLFDX1,
     R   HLFDX2,   TCACO ,
     I   LMAX  ,   LMAXP ,   LMAXP2,   MMAX  ,   MMAXP ,   MMAXP2,
     I   NEMIT ,   NP
C       INCLUDE 'COMSCA.inc'
C---------------------------------------------------------------------
CL                  C3.2     Scaling Factors
       COMMON/COMSCA/
     R   SCB3  ,   SCE1  ,   SCE2  ,   SCEMEN,   SCEPOW,   SCI1  ,
     R   SCI2  ,   SCIP  ,   SCKE  ,   SCKPOW,   SCP1  ,   SCP2  ,
     R   SCV1  ,   SCV2  ,   SCX1  ,   SCX2
C       INCLUDE 'COMHOK.inc'
C---------------------------------------------------------------------
CL                  C4.1     Housekeeping
       COMMON/COMHOK/
     R   TIMECP,   XPSMAX,   XPSMIN,   YPSMAX,   YPSMIN,
     I   N1MAX ,   N2MAX ,   NCASE ,   NGMAX ,   NOSEP ,   NPDUM ,
     I   NPMAX ,   NSRC  ,   NXDUM ,   NYDUM
       DIMENSION
     R   TIMECP(32)
C       INCLUDE 'COMGEO.inc'
C---------------------------------------------------------------------
CL                  C4.2     Device boundary data
       COMMON/COMGEO/
     R   ASCUR ,   CCTSRC,   EBEXT ,   ELSCUR,   ENSUR ,   EPOYNT,
     R   RHOC  ,   SURCHG,   SURIC ,
     I   LINDEX,   MINDEX,   NBCTYP,   NBDIM ,   NBSEG2,   NCOLOR,
     I   NDIRN ,   NG
       DIMENSION
     R   ASCUR(1500),        CCTSRC(1500),       EBEXT(2,1500),
     R   ELSCUR(1500),       ENSUR(1500),        EPOYNT(1500),
     R   RHOC(1500),         SURCHG(1500),       SURIC(4,1500),
     I   LINDEX(1500),       MINDEX(1500),       NBCTYP(1500),
     I   NCOLOR(1500),       NDIRN(1500),        NG(605,40)
C       INCLUDE 'COMOUT.inc'
C---------------------------------------------------------------------
CL                  C5.1     Output Variables
       COMMON/COMOUT/
     R   BCNMAX,   BCNMIN,   BCVMAX,   BCVMIN,   CUAMAX,   CUAMIN,
     R   CUEMAX,   CUEMIN,   ECVMAX,   ECVMIN,   TONS1 ,   TONS2 ,
     R   TONS3 ,   TONS4 ,   TONS5 ,   TONS6 ,   TONS7 ,
     I   NBCHT ,   NOPSEL,   NS1   ,   NS2   ,   NS3   ,   NS4   ,
     I   NS5   ,   NS6   ,   NS7
C---------------------------------------------------------------------
C
         IF(KGROUP.EQ.0)GO TO 100
         IF((KGROUP.LT.0).OR.(KGROUP.GT.9))RETURN
         GO TO(100,200,300,400,500,999,999,999,999),KGROUP
C
C---------------------------------------------------------------------
CL              1.         GENERAL OLYMPUS DATA
C
  100    CONTINUE
         IF(KBLOCK.EQ.0)GO TO 101
         GO TO(110,120,999,999,999,999,999,999,190),KBLOCK
  101    CONTINUE
C
CL                  1.1      BLOCK COMBAS
  110    CONTINUE
         CALL PAGE
         CALL  MESAGE(' BLOCK COMBAS                                  ')
         CALL BLINES(1)
         CALL IVAR('NDIARY  ',NDIARY)
         CALL IVAR('NIN     ',NIN   )
         CALL IVAR('NLEDGE  ',NLEDGE)
         CALL IVAR('NONLIN  ',NONLIN)
         CALL IVAR('NOUT    ',NOUT  )
         CALL IVAR('NPRINT  ',NPRINT)
         CALL IVAR('NPUNCH  ',NPUNCH)
         CALL IVAR('NREAD   ',NREAD )
         CALL IVAR('NREC    ',NREC  )
         CALL IVAR('NRESUM  ',NRESUM)
         CALL IVAR('NRUN    ',NRUN  )
         CALL IVAR('NSTEP   ',NSTEP )
         CALL LVAR('NLEND   ',NLEND )
         CALL LVAR('NLRES   ',NLRES )
         IF(KBLOCK.NE.0)RETURN
C
CL                  1.2      BLOCK CHABAS
  120    CONTINUE
         CALL PAGE
         CALL  MESAGE(' BLOCK CHABAS                                  ')
         CALL BLINES(1)
         CALL HVAR('CHLAB1  ',CHLAB1)
         CALL HVAR('CHLAB2  ',CHLAB2)
         CALL HVAR('CHLAB3  ',CHLAB3)
         CALL HVAR('CHLAB4  ',CHLAB4)
         CALL HVAR('CHLAB5  ',CHLAB5)
         CALL HVAR('CHLAB6  ',CHLAB6)
         CALL HVAR('CHLAB7  ',CHLAB7)
         CALL HVAR('CHLAB8  ',CHLAB8)
         CALL HVAR('CHLAB9  ',CHLAB9)
         CALL HVAR('CHLB10  ',CHLB10)
         CALL HVAR('CHLB11  ',CHLB11)
         CALL HVAR('CHLB12  ',CHLB12)
         CALL HVAR('CHLB13  ',CHLB13)
         CALL HVAR('CHLB14  ',CHLB14)
         CALL HVAR('CHLB15  ',CHLB15)
         CALL HVAR('CHRTIM  ',CHRTIM)
         CALL HVAR('CHRDAT  ',CHRDAT)
         CALL HVAR('CHTIMO  ',CHTIMO)
         CALL HVAR('CHDATO  ',CHDATO)
         CALL HVAR('CHREFN  ',CHREFN)
         IF(KBLOCK.NE.0)RETURN
C
CL                  1.9      BLOCK COMDDP
  190    CONTINUE
         CALL PAGE
         CALL  MESAGE(' BLOCK COMDDP                                  ')
         CALL BLINES(1)
         CALL IVAR('MAXDUM  ',MAXDUM)
         CALL IVAR('MXDUMP  ',MXDUMP)
         CALL IVAR('NCLASS  ',NCLASS)
         CALL IVAR('NPOINT  ',NPOINT)
         CALL IVAR('NSUB    ',NSUB  )
         CALL LVAR('NLCHED  ',NLCHED)
         CALL LVAR('NLREPT  ',NLREPT)
         IF((KGROUP.NE.0).OR.(KBLOCK.NE.0))RETURN
C
C---------------------------------------------------------------------
CL              2.         PHYSICAL PROBLEM
C
  200    CONTINUE
         IF(KBLOCK.EQ.0)GO TO 201
         GO TO(210,220,230,240,250,999,999,999,999),KBLOCK
  201    CONTINUE
C
CL                  2.1      BLOCK COMCON
  210    CONTINUE
         CALL PAGE
         CALL  MESAGE(' BLOCK COMCON                                  ')
         CALL BLINES(1)
         CALL RVAR('API     ',API   )
         CALL RVAR('BOLTZK  ',BOLTZK)
         CALL RVAR('CLIGHT  ',CLIGHT)
         CALL RVAR('ELCHAG  ',ELCHAG)
         CALL RVAR('ELMASS  ',ELMASS)
         CALL RVAR('EMU0    ',EMU0  )
         CALL RVAR('EOVERM  ',EOVERM)
         CALL RVAR('EPS0    ',EPS0  )
         IF(KBLOCK.NE.0)RETURN
C
CL                  2.2      BLOCK COMSTT
  220    CONTINUE
         CALL PAGE
         CALL  MESAGE(' BLOCK COMSTT                                  ')
         CALL BLINES(1)
         CALL RVAR('REALTN  ',REALTN)
         CALL RVAR('TIMRUN  ',TIMRUN)
         IF(KBLOCK.NE.0)RETURN
C
CL                  2.3      BLOCK COMDEV
  230    CONTINUE
         CALL PAGE
         CALL  MESAGE(' BLOCK COMDEV                                  ')
         CALL BLINES(1)
         CALL RVAR('B3RHS   ',B3RHS )
         CALL RVAR('B3RHSD  ',B3RHSD)
         CALL RVAR('BAPLY   ',BAPLY )
         CALL RVAR('BAPLYD  ',BAPLYD)
         CALL RVAR('DEPTH   ',DEPTH )
         CALL RVAR('DEVHYT  ',DEVHYT)
         CALL RVAR('DEVLEN  ',DEVLEN)
         CALL RVAR('DEVRAD  ',DEVRAD)
         CALL RVAR('EAPLYD  ',EAPLYD)
         CALL RVAR('EEMIT   ',EEMIT )
         CALL RVAR('EEMITD  ',EEMITD)
         CALL RVAR('ENIT    ',ENIT  )
         CALL RVAR('ENITD   ',ENITD )
         CALL RVAR('GAP     ',GAP   )
         CALL RVAR('RESAX   ',RESAX )
         CALL RVAR('RESE    ',RESE  )
         CALL RVAR('RESN    ',RESN  )
         CALL RVAR('RESS    ',RESS  )
         CALL RVAR('RESW    ',RESW  )
         CALL RVAR('RINNER  ',RINNER)
         CALL RVAR('SPACE   ',SPACE )
         CALL RVAR('VOLTAG  ',VOLTAG)
         CALL RVAR('WIDTH   ',WIDTH )
         CALL IVAR('LCATH   ',LCATH )
         CALL IVAR('LCAV    ',LCAV  )
         CALL IVAR('LLEFT   ',LLEFT )
         CALL IVAR('LWVANE  ',LWVANE)
         CALL IVAR('MDEPTH  ',MDEPTH)
         CALL IVAR('MGAP    ',MGAP  )
         CALL IVAR('NBCAX   ',NBCAX )
         CALL IVAR('NBCE    ',NBCE  )
         CALL IVAR('NBCN    ',NBCN  )
         CALL IVAR('NBCS    ',NBCS  )
         CALL IVAR('NBCW    ',NBCW  )
         CALL IVAR('NCAV    ',NCAV  )
         CALL IVAR('NDEV    ',NDEV  )
         IF(KBLOCK.NE.0)RETURN
C
CL                  2.4      BLOCK COMDIA
  240    CONTINUE
         CALL PAGE
         CALL  MESAGE(' BLOCK COMDIA                                  ')
         CALL BLINES(1)
         CALL RVAR('B3POW   ',B3POW )
         CALL RVAR('E1POW   ',E1POW )
         CALL RVAR('E2POW   ',E2POW )
         CALL RVAR('EJ1POW  ',EJ1POW)
         CALL RVAR('EJ2POW  ',EJ2POW)
         CALL RVAR('EJENP   ',EJENP )
         CALL RVAR('EJPOWM  ',EJPOWM)
         CALL RVAR('EJPOWP  ',EJPOWP)
         CALL RVAR('EJPWPN  ',EJPWPN)
         CALL RVAR('EKFLXI  ',EKFLXI)
         CALL RVAR('EKFLXO  ',EKFLXO)
         CALL RVAR('ENEJ1   ',ENEJ1 )
         CALL RVAR('ENEJ2   ',ENEJ2 )
         CALL RVAR('ENEL1   ',ENEL1 )
         CALL RVAR('ENEL1O  ',ENEL1O)
         CALL RVAR('ENEL2   ',ENEL2 )
         CALL RVAR('ENEL2O  ',ENEL2O)
         CALL RVAR('ENKIN   ',ENKIN )
         CALL RVAR('ENKINO  ',ENKINO)
         CALL RVAR('ENMAG   ',ENMAG )
         CALL RVAR('ENMAGO  ',ENMAGO)
         CALL RVAR('ENPOYT  ',ENPOYT)
         CALL RVAR('ENTOT   ',ENTOT )
         CALL RVAR('ENTOTO  ',ENTOTO)
         CALL RVAR('TOTM1   ',TOTM1 )
         CALL RVAR('TOTM2   ',TOTM2 )
         CALL RVAR('TPOYP   ',TPOYP )
         CALL IVAR('NPNEW   ',NPNEW )
         CALL IVAR('NPOLD   ',NPOLD )
         IF(KBLOCK.NE.0)RETURN
C
CL                  2.5      BLOCK COMKLY
  250    CONTINUE
         CALL PAGE
         CALL  MESAGE(' BLOCK COMKLY                                  ')
         CALL BLINES(1)
         CALL RVAR('BMCUR   ',BMCUR )
         CALL RVAR('BMMOM   ',BMMOM )
         CALL RVAR('BMRIN   ',BMRIN )
         CALL RVAR('BMROUT  ',BMROUT)
         IF((KGROUP.NE.0).OR.(KBLOCK.NE.0))RETURN
C
C---------------------------------------------------------------------
CL              3.         NUMERICAL SCHEME
C
  300    CONTINUE
         IF(KBLOCK.EQ.0)GO TO 301
         GO TO(310,320,999,999,999,999,999,999,999),KBLOCK
  301    CONTINUE
C
CL                  3.1      BLOCK COMNUM
  310    CONTINUE
         CALL PAGE
         CALL  MESAGE(' BLOCK COMNUM                                  ')
         CALL BLINES(1)
         CALL RVAR('C1      ',C1    )
         CALL RVAR('C2      ',C2    )
         CALL RVAR('CD0     ',CD0   )
         CALL RVAR('CURANT  ',CURANT)
         CALL RVAR('DT      ',DT    )
         CALL RVAR('DX1     ',DX1   )
         CALL RVAR('DX1DX2  ',DX1DX2)
         CALL RVAR('DX1OX2  ',DX1OX2)
         CALL RVAR('DX2     ',DX2   )
         CALL RVAR('DX2OX1  ',DX2OX1)
         CALL RVAR('ELPERP  ',ELPERP)
         CALL RVAR('HLFDX1  ',HLFDX1)
         CALL RVAR('HLFDX2  ',HLFDX2)
         CALL RVAR('TCACO   ',TCACO )
         CALL IVAR('LMAX    ',LMAX  )
         CALL IVAR('LMAXP   ',LMAXP )
         CALL IVAR('LMAXP2  ',LMAXP2)
         CALL IVAR('MMAX    ',MMAX  )
         CALL IVAR('MMAXP   ',MMAXP )
         CALL IVAR('MMAXP2  ',MMAXP2)
         CALL IVAR('NEMIT   ',NEMIT )
         CALL IVAR('NP      ',NP    )
         IF(KBLOCK.NE.0)RETURN
C
CL                  3.2      BLOCK COMSCA
  320    CONTINUE
         CALL PAGE
         CALL  MESAGE(' BLOCK COMSCA                                  ')
         CALL BLINES(1)
         CALL RVAR('SCB3    ',SCB3  )
         CALL RVAR('SCE1    ',SCE1  )
         CALL RVAR('SCE2    ',SCE2  )
         CALL RVAR('SCEMEN  ',SCEMEN)
         CALL RVAR('SCEPOW  ',SCEPOW)
         CALL RVAR('SCI1    ',SCI1  )
         CALL RVAR('SCI2    ',SCI2  )
         CALL RVAR('SCIP    ',SCIP  )
         CALL RVAR('SCKE    ',SCKE  )
         CALL RVAR('SCKPOW  ',SCKPOW)
         CALL RVAR('SCP1    ',SCP1  )
         CALL RVAR('SCP2    ',SCP2  )
         CALL RVAR('SCV1    ',SCV1  )
         CALL RVAR('SCV2    ',SCV2  )
         CALL RVAR('SCX1    ',SCX1  )
         CALL RVAR('SCX2    ',SCX2  )
         IF((KGROUP.NE.0).OR.(KBLOCK.NE.0))RETURN
C
C---------------------------------------------------------------------
CL              4.         HOUSEKEEPING
C
  400    CONTINUE
         IF(KBLOCK.EQ.0)GO TO 401
         GO TO(410,420,999,999,999,999,999,999,999),KBLOCK
  401    CONTINUE
C
CL                  4.1      BLOCK COMHOK
  410    CONTINUE
         CALL PAGE
         CALL  MESAGE(' BLOCK COMHOK                                  ')
         CALL BLINES(1)
         CALL RVAR('XPSMAX  ',XPSMAX)
         CALL RVAR('XPSMIN  ',XPSMIN)
         CALL RVAR('YPSMAX  ',YPSMAX)
         CALL RVAR('YPSMIN  ',YPSMIN)
         CALL IVAR('N1MAX   ',N1MAX )
         CALL IVAR('N2MAX   ',N2MAX )
         CALL IVAR('NCASE   ',NCASE )
         CALL IVAR('NGMAX   ',NGMAX )
         CALL IVAR('NOSEP   ',NOSEP )
         CALL IVAR('NPDUM   ',NPDUM )
         CALL IVAR('NPMAX   ',NPMAX )
         CALL IVAR('NSRC    ',NSRC  )
         CALL IVAR('NXDUM   ',NXDUM )
         CALL IVAR('NYDUM   ',NYDUM )
         IF(KBLOCK.NE.0)RETURN
C
CL                  4.2      BLOCK COMGEO
  420    CONTINUE
         CALL PAGE
         CALL  MESAGE(' BLOCK COMGEO                                  ')
         CALL BLINES(1)
         CALL IVAR('NBDIM   ',NBDIM )
         CALL IVAR('NBSEG2  ',NBSEG2)
         IF((KGROUP.NE.0).OR.(KBLOCK.NE.0))RETURN
C
C---------------------------------------------------------------------
CL              5.         I/O AND DIAGNOSTICS
C
  500    CONTINUE
         IF(KBLOCK.EQ.0)GO TO 501
         GO TO(510,999,999,999,999,999,999,999,999),KBLOCK
  501    CONTINUE
C
CL                  5.1      BLOCK COMOUT
  510    CONTINUE
         CALL PAGE
         CALL  MESAGE(' BLOCK COMOUT                                  ')
         CALL BLINES(1)
         CALL RVAR('BCNMAX  ',BCNMAX)
         CALL RVAR('BCNMIN  ',BCNMIN)
         CALL RVAR('BCVMAX  ',BCVMAX)
         CALL RVAR('BCVMIN  ',BCVMIN)
         CALL RVAR('CUAMAX  ',CUAMAX)
         CALL RVAR('CUAMIN  ',CUAMIN)
         CALL RVAR('CUEMAX  ',CUEMAX)
         CALL RVAR('CUEMIN  ',CUEMIN)
         CALL RVAR('ECVMAX  ',ECVMAX)
         CALL RVAR('ECVMIN  ',ECVMIN)
         CALL RVAR('TONS1   ',TONS1 )
         CALL RVAR('TONS2   ',TONS2 )
         CALL RVAR('TONS3   ',TONS3 )
         CALL RVAR('TONS4   ',TONS4 )
         CALL RVAR('TONS5   ',TONS5 )
         CALL RVAR('TONS6   ',TONS6 )
         CALL RVAR('TONS7   ',TONS7 )
         CALL IVAR('NBCHT   ',NBCHT )
         CALL IVAR('NOPSEL  ',NOPSEL)
         CALL IVAR('NS1     ',NS1   )
         CALL IVAR('NS2     ',NS2   )
         CALL IVAR('NS3     ',NS3   )
         CALL IVAR('NS4     ',NS4   )
         CALL IVAR('NS5     ',NS5   )
         CALL IVAR('NS6     ',NS6   )
         CALL IVAR('NS7     ',NS7   )
         IF((KGROUP.NE.0).OR.(KBLOCK.NE.0))RETURN
C
C---------------------------------------------------------------------
C
  999    CONTINUE
         END
C/ MODULE C4S1
C
         SUBROUTINE TESEND
C
C 4.1  TEST FOR COMPLETION OF RUN
C
C-----------------------------------------------------------------------
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C       INCLUDE 'COMDDP.inc'
C--------------------------------------------------------------------
CL                  C1.9.    DEVELOPMENT AND DIAGNOSTIC PARAMETERS
       COMMON/COMDDP/
     I   MAXDUM,   MXDUMP,   NADUMP,   NCLASS,   NPDUMP,   NPOINT,
     I   NSUB,     NVDUMP,
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       LOGICAL
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       DIMENSION
     I   NADUMP(20),         NPDUMP(20),         NVDUMP(20),
     L   NLHEAD(9),          NLOMT1(50),         NLOMT2(50),
     L   NLOMT3(50)
C       INCLUDE 'COMCON.inc'
C---------------------------------------------------------------------
CL                  C2.1     Physical Constants
       COMMON/COMCON/
     R   API   ,   BOLTZK,   CLIGHT,   ELCHAG,   ELMASS,   EMU0  ,
     R   EOVERM,   EPS0
C       INCLUDE 'COMSTT.inc'
C---------------------------------------------------------------------
CL                  C2.2     Physical State
       COMMON/COMSTT/
     R   B3    ,   BAV   ,   CD1   ,   CD2   ,   E1    ,   E2    ,
     R   P1    ,   P2    ,   Q1    ,   Q2    ,   REALTN,   TIMRUN
       DIMENSION
     R   B3(605,40),        BAV(605,40),       CD1(605,40),
     R   CD2(605,40),       E1(605,40),        E2(605,40),
     R   P1(20000),          P2(20000),          Q1(20000),
     R   Q2(20000)
C       INCLUDE 'COMDEV.inc'
C---------------------------------------------------------------------
CL                  C2.3     Device description
       COMMON/COMDEV/
     R   B3RHS ,   B3RHSD,   BAPLY ,   BAPLYD,   CAVEAM,   CAVEFR,
     R   CAVIC ,   CAVRES,   CAVTC ,   DEPTH ,   DEVHYT,   DEVLEN,
     R   DEVRAD,   EAPLYD,   EEMIT ,   EEMITD,   ENIT  ,   ENITD ,
     R   GAP   ,   RESAX ,   RESE  ,   RESN  ,   RESS  ,   RESW  ,
     R   RINNER,   SPACE ,   VOLTAG,   WIDTH ,
     I   LCATH ,   LCAV  ,   LLEFT ,   LWVANE,   MDEPTH,   MGAP  ,
     I   NBCAX ,   NBCCAV,   NBCE  ,   NBCN  ,   NBCS  ,   NBCW  ,
     I   NCAV  ,   NDEV
       DIMENSION
     R   CAVEAM(100),        CAVEFR(100),        CAVIC(4,100),
     R   CAVRES(100),        CAVTC(100),
     I   NBCCAV(100)
C       INCLUDE 'COMDIA.inc'
C---------------------------------------------------------------------
CL                  C2.4     Physical Diagnostics
       COMMON/COMDIA/
     R   B3POW ,   BOUT  ,   CAVPOY,   E1POW ,   E2POW ,   EJ1POW,
     R   EJ2POW,   EJENP ,   EJPOWM,   EJPOWP,   EJPWPN,   EKFLXI,
     R   EKFLXO,   ENEJ1 ,   ENEJ2 ,   ENEL1 ,   ENEL1O,   ENEL2 ,
     R   ENEL2O,   ENKIN ,   ENKINO,   ENMAG ,   ENMAGO,   ENPOYT,
     R   ENTOT ,   ENTOTO,   EOUT  ,   TOTM1 ,   TOTM2 ,   TPOYP ,
     I   LCAVEN,   LCAVST,   NPNEW ,   NPOLD
       DIMENSION
     R   BOUT(100),          CAVPOY(100),        EOUT(100),
     I   LCAVEN(100),        LCAVST(100)
C       INCLUDE 'COMNUM.inc'
C---------------------------------------------------------------------
CL                  C3.1     Numerical Parameters
       COMMON/COMNUM/
     R   C1    ,   C2    ,   CD0   ,   CURANT,   DT    ,   DX1   ,
     R   DX1DX2,   DX1OX2,   DX2   ,   DX2OX1,   ELPERP,   HLFDX1,
     R   HLFDX2,   TCACO ,
     I   LMAX  ,   LMAXP ,   LMAXP2,   MMAX  ,   MMAXP ,   MMAXP2,
     I   NEMIT ,   NP
C       INCLUDE 'COMSCA.inc'
C---------------------------------------------------------------------
CL                  C3.2     Scaling Factors
       COMMON/COMSCA/
     R   SCB3  ,   SCE1  ,   SCE2  ,   SCEMEN,   SCEPOW,   SCI1  ,
     R   SCI2  ,   SCIP  ,   SCKE  ,   SCKPOW,   SCP1  ,   SCP2  ,
     R   SCV1  ,   SCV2  ,   SCX1  ,   SCX2
C       INCLUDE 'COMHOK.inc'
C---------------------------------------------------------------------
CL                  C4.1     Housekeeping
       COMMON/COMHOK/
     R   TIMECP,   XPSMAX,   XPSMIN,   YPSMAX,   YPSMIN,
     I   N1MAX ,   N2MAX ,   NCASE ,   NGMAX ,   NOSEP ,   NPDUM ,
     I   NPMAX ,   NSRC  ,   NXDUM ,   NYDUM
       DIMENSION
     R   TIMECP(32)
C       INCLUDE 'COMGEO.inc'
C---------------------------------------------------------------------
CL                  C4.2     Device boundary data
       COMMON/COMGEO/
     R   ASCUR ,   CCTSRC,   EBEXT ,   ELSCUR,   ENSUR ,   EPOYNT,
     R   RHOC  ,   SURCHG,   SURIC ,
     I   LINDEX,   MINDEX,   NBCTYP,   NBDIM ,   NBSEG2,   NCOLOR,
     I   NDIRN ,   NG
       DIMENSION
     R   ASCUR(1500),        CCTSRC(1500),       EBEXT(2,1500),
     R   ELSCUR(1500),       ENSUR(1500),        EPOYNT(1500),
     R   RHOC(1500),         SURCHG(1500),       SURIC(4,1500),
     I   LINDEX(1500),       MINDEX(1500),       NBCTYP(1500),
     I   NCOLOR(1500),       NDIRN(1500),        NG(605,40)
C       INCLUDE 'COMOUT.inc'
C---------------------------------------------------------------------
CL                  C5.1     Output Variables
       COMMON/COMOUT/
     R   BCNMAX,   BCNMIN,   BCVMAX,   BCVMIN,   CUAMAX,   CUAMIN,
     R   CUEMAX,   CUEMIN,   ECVMAX,   ECVMIN,   TONS1 ,   TONS2 ,
     R   TONS3 ,   TONS4 ,   TONS5 ,   TONS6 ,   TONS7 ,
     I   NBCHT ,   NOPSEL,   NS1   ,   NS2   ,   NS3   ,   NS4   ,
     I   NS5   ,   NS6   ,   NS7
C-----------------------------------------------------------------------
C
C-----------------------------------------------------------------------
CL              1.         voltage check
C
         ICASE=2
         IF(ICASE.EQ.1) THEN
C       this checks voltage at diode end
         ILBOT=LCATH
         IMTOP=20
         IF(NCASE.EQ.3) IMTOP=MMAX-MGAP-9
         ZVSCAL=DX1*SCE1
         ZVOLT=0.0
         DO 100 JM=2,IMTOP
         DO 100 JL=ILBOT,LMAX
         ZVOLT=ZVOLT+E1(JL,JM)*JM
  100    CONTINUE
         ZVOLT=ZVOLT*ZVSCAL*2.0/(IMTOP*IMTOP-4)
         ZCUR=ASCUR(3)*SCI1/1000.
         ELSE
C    this case checks volts over periodic diode(ncase=1)
                 ZVSCAL=DX2*SCE2/(LMAX-1)
         ZVOLT=0.0
         DO 110 JM=2,MMAX
         DO 110 JL=2,LMAX
  110    ZVOLT=ZVOLT+E2(JL,JM)
         ZVOLT=ZVOLT*ZVSCAL
         ZD=(MMAX-1)*DX2
         ZR=RINNER*DX2+ZD/2
         ZL=(LMAX-1)*DX1
         ZCUR=8*API*EPS0*ZR*ZL/ZD**2/9*SQRT(2*EOVERM*ZVOLT**3)
         END IF
C
CL                  1.1      STEP OUTPUT
C        WRITE(NONLIN,9000) NSTEP,REALTN,NP,ZVOLT,ZCUR,NPOLD,NPNEW
C9000    FORMAT(' STEP = ',I5,' TIME = ',E12.5,' NP = ',I5,
C    +   ' VOLTAGE = ',E12.5,
C    +   ' CURRENT = ',E12.5,' NPOLD = ',I5,' NPNEW = ',I5)
         IF(NSTEP.GE.NRUN) NLEND = .TRUE.
C-----------------------------------------------------------------------
         END
C/ MODULE CGS2
         SUBROUTINE CONPLT(PARR,KCHECK,KXDIM,
     +   KXMIN,KXMAX,KYMIN,KYMAX,PCONHT,KNCHTS)
C
C     . DA PARR(KXDIM,KYMAX)  : array of function values
C     . DA PX(KXMAX)          : array of X grid positions
C     . DA PY(KXMAX)          : array of Y grid positions
C     . DA PCONHT(KNCHTS)     : array of contour heights
C     . IA KCHECK(KXDIM,KYMAX): 0 for no plot of element
C     .
C     . I  KXDIM   : x dimension of 2d array
C     . I  KXMIN   : min x index of plot
C     . I  KYMIN   : min y index of plot
C     . I  KXMAX   : max x index of plot
C     . I  KYMAX   : max y index of plot
C     . I  KNCHTS  : no. of contour heights
C-----------------------------------------------------------------------
       DIMENSION
     +   PARR(KXDIM,KYMAX),  PCONHT(KNCHTS),     KCHECK(KXDIM,KYMAX)
       DIMENSION   ZCHTS(128),         ZPOS1(2,3),         ZVAL1(3)
C
C-----------------------------------------------------------------------
CL              1.         INITIALISE
C
         IYMAX=KYMAX-1
         IXMAX=KXMAX-1
C
         IF (KNCHTS.LE.128) THEN
         DO 100 J=1,KNCHTS
  100    ZCHTS(J)=PCONHT(J)
         ELSE
C        PRINT*, 'Too many contour heights, run terminated'
         STOP
         END IF
C
C-----------------------------------------------------------------------
CL              2.         GENERATE CONTOUR PLOT
C
         DO 220 JY= KYMIN,IYMAX
         DO 220 JX= KXMIN,IXMAX
C
         IF(KCHECK(JX,JY).NE.0) GO TO 220
C
CL                  2.1      do bottom left triangle
         ZPOS1(1,1)=(JX)-0.5
         ZPOS1(1,2)=(JX+1)-0.5
         ZPOS1(1,3)=(JX)-0.5
C
         ZPOS1(2,1)=(JY)-0.5
         ZPOS1(2,2)=(JY)-0.5
         ZPOS1(2,3)=(JY+1)-0.5
C
         ZVAL1(1)=PARR(JX,JY)
         ZVAL1(2)=PARR(JX+1,JY)
         ZVAL1(3)=PARR(JX,JY+1)
C
         CALL SEGPLT(ZPOS1,ZVAL1,ZCHTS,KNCHTS,1)
C
CL                  2.2      do top right triangle
         ZPOS1(1,1)=(JX+1)-0.5
         ZPOS1(1,2)=(JX+1)-0.5
         ZPOS1(1,3)=(JX)-0.5
C
         ZPOS1(2,1)=(JY)-0.5
         ZPOS1(2,2)=(JY+1)-0.5
         ZPOS1(2,3)=(JY+1)-0.5
C
         ZVAL1(1)=PARR(JX+1,JY)
         ZVAL1(2)=PARR(JX+1,JY+1)
         ZVAL1(3)=PARR(JX,JY+1)
C
         CALL SEGPLT(ZPOS1,ZVAL1,ZCHTS,KNCHTS,1)
C
  220    CONTINUE
C-----------------------------------------------------------------------
         CALL PICNOW
         RETURN
         END
C/ MODULE cus11
C
         SUBROUTINE REPTHD(KCLASS,KSUB,KPOINT)
C
C U.11 PRINT HEADING FOR DIAGNOSTICS REPORT
C
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C-----------------------------------------------------------------------
C
C        WRITE(NOUT,9000) KCLASS,KSUB,KPOINT
C
         RETURN
C9000    FORMAT(4X,'CLASS =',I6,', ','SUBPROGRAM =',I6,', POINT =',I6)
         END
C
         SUBROUTINE AXORIG
         END
C/ MODULE cus9
C
         SUBROUTINE IARRAY(KNAME,KA,KDIM)
C
C U.9  PRINT NAME AND VALUES OF INTEGER ARRAY
C
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C-----------------------------------------------------------------------
       DIMENSION   KA(KDIM)
       CHARACTER   KNAME*8
C-----------------------------------------------------------------------
C
C        WRITE(NOUT,9000) KNAME
C        WRITE(NOUT,9001) (KA(J),J=1,KDIM)
C
         RETURN
C9000    FORMAT(/4X,A8/)
C9001    FORMAT(10(1X,I11))
         END
C/ MODULE C3S11
C
         SUBROUTINE WINDOI(KNAME,KA,KX,KY,KXDIM,KYDIM)
C
C 3.11  output window of 2-d integer array
C
C---------------------------------------------------------------------
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C---------------------------------------------------------------------
       DIMENSION   KA(KXDIM,KYDIM)
       CHARACTER KNAME*8
C
C---------------------------------------------------------------------
CL              1.         set bounds
C
         IF(KX.GT.KXDIM) THEN
C        WRITE(NOUT,9000)
C9000    FORMAT(' KX TOO LARGE')
         STOP
         END IF
C
         IF(KY.GT.KYDIM) THEN
C        WRITE(NOUT,9001)
C9001    FORMAT(' KY TOO LARGE')
         STOP
         END IF
C
         IXMAX=KX+9
         IF(IXMAX.GT.KXDIM)IXMAX=KXDIM
         IYMAX=KY+9
         IF(IYMAX.GT.KYDIM)IYMAX=KYDIM
C
C---------------------------------------------------------------------
CL              2.         output
C
C        WRITE(NOUT,9002) KNAME
C9002    FORMAT(A)
C        WRITE(NOUT,9003) (I,I=KX,IXMAX)
C9003    FORMAT(6X,10(3X,I7))
         DO 200 J=KY,IYMAX
C        WRITE(NOUT,9004) J,(KA(I,J),I=KX,IXMAX)
  200    CONTINUE
C9004    FORMAT(1X,I6,10I10)
C---------------------------------------------------------------------
         RETURN
         END
C/ MODULE cus2
C
         SUBROUTINE PAGE
C
C U.2  FETCH NEW PAGE ON OUTPUT CHANNEL
C
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C-----------------------------------------------------------------------
C
C        WRITE(NOUT,9000)
C
         RETURN
C9000    FORMAT('1')
         END
C/ MODULE cus6
C
         SUBROUTINE HVAR(KNAME,KVALUE)
C
C U.6  PRINT NAME AND VALUE OF CHARACTER VARIABLE
C
C     (This was a hollerith print routine in FORTRAN IV
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C-----------------------------------------------------------------------
       CHARACTER   KNAME*8,  KVALUE*(*)
C-----------------------------------------------------------------------
C
C        WRITE(NOUT,9000) KNAME , KVALUE
C
         RETURN
C9000    FORMAT(4X,A8,' =',4X,A)
         END
C/ MODULE cus7
C
         SUBROUTINE LVAR(KNAME,KLVAL)
C
C U.7  PRINT NAME AND VALUE OF LOGICAL VARIABLE
C
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C-----------------------------------------------------------------------
       CHARACTER   KNAME*8
       LOGICAL     KLVAL
C-----------------------------------------------------------------------
C
C        IF(KLVAL)      WRITE(NOUT,9000) KNAME
C        IF(.NOT.KLVAL) WRITE(NOUT,9001) KNAME
C
         RETURN
C9000    FORMAT(4X,A8,' =      .TRUE.')
C9001    FORMAT(4X,A8,' =     .FALSE.')
         END
C/ MODULE cus18
C
         SUBROUTINE LARRAY(KNAME,KLA,KDIM)
C
C U.18 PRINT NAME AND VALUES OF LOGICAL ARRAY
C
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C-----------------------------------------------------------------------
       LOGICAL     KLA
       DIMENSION   KLA(KDIM)
       CHARACTER   KNAME*8
C-----------------------------------------------------------------------
C
C        WRITE(NOUT,9000) KNAME
C        WRITE(NOUT,9001) (KLA(J),J=1,KDIM)
C
         RETURN
C9000    FORMAT(/4X,A8/)
C9001    FORMAT(10(1X,L11))
         END
C/ MODULE cus8
C
         SUBROUTINE RARRAY(KNAME,PA,KDIM)
C
C U.8  PRINT NAME AND VALUES OF REAL ARRAY
C
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C-----------------------------------------------------------------------
       DIMENSION   PA(KDIM)
       CHARACTER   KNAME*8
C-----------------------------------------------------------------------
C
C        WRITE(NOUT,9000) KNAME
C        WRITE(NOUT,9001) (PA(J),J=1,KDIM)
C
         RETURN
C9000    FORMAT(/4X,A8/)
C9001    FORMAT(10(1X,1PE11.3))
         END
C/ MODULE C3S10
C
         SUBROUTINE WINDOR(KNAME,PA,KX,KY,KXDIM,KYDIM)
C
C 3.10  output window of 2-d real array
C
C---------------------------------------------------------------------
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C---------------------------------------------------------------------
       DIMENSION   PA(KXDIM,KYDIM)
       CHARACTER KNAME*8
C
C---------------------------------------------------------------------
CL              1.         set bounds
C
         IF(KX.GT.KXDIM) THEN
C        WRITE(NOUT,9000)
C9000    FORMAT(' KX TOO LARGE')
         STOP
         END IF
C
         IF(KY.GT.KYDIM) THEN
C        WRITE(NOUT,9001)
C9001    FORMAT(' KY TOO LARGE')
         STOP
         END IF
C
         IXMAX=KX+9
         IF(IXMAX.GT.KXDIM)IXMAX=KXDIM
         IYMAX=KY+9
         IF(IYMAX.GT.KYDIM)IYMAX=KYDIM
C
C---------------------------------------------------------------------
CL              2.         output
C
C        WRITE(NOUT,9002) KNAME
C9002    FORMAT(A)
C        WRITE(NOUT,9003) (I,I=KX,IXMAX)
C9003    FORMAT(3X,10(3X,I7))
         DO 200 J=KY,IYMAX
C        WRITE(NOUT,9004) J,(PA(I,J),I=KX,IXMAX)
  200    CONTINUE
C9004    FORMAT(1X,I6,10(1X,E9.3))
C---------------------------------------------------------------------
         END
C/ MODULE C3S13
C
         SUBROUTINE SURDMI(KNAME,KA,KL,KM,KDIRN,KBSEG2)
C
C 3.13  output surface table for integer array
C
C---------------------------------------------------------------------
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C---------------------------------------------------------------------
       DIMENSION   KA(KBSEG2),KL(KBSEG2),KM(KBSEG2),KDIRN(KBSEG2)
       CHARACTER KNAME*8
C
C---------------------------------------------------------------------
CL              2.         output
C
C        WRITE(NOUT,9002) KNAME
C9002    FORMAT(A)
C        WRITE(NOUT,9000)
C9000    FORMAT(2(' index  L    M   dir     value    '))
C        WRITE(NOUT,9003) (J,KL(J),KM(J),KDIRN(J),KA(J),J=1,KBSEG2)
C9003    FORMAT(2(1X,4I5,I6,6X))
C---------------------------------------------------------------------
         END
C/ MODULE C3S12
C
         SUBROUTINE SURDMR(KNAME,PA,KL,KM,KDIRN,KBSEG2)
C
C 3.12  output surface table for real array
C
C---------------------------------------------------------------------
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C---------------------------------------------------------------------
       DIMENSION   PA(KBSEG2),KL(KBSEG2),KM(KBSEG2),KDIRN(KBSEG2)
       CHARACTER KNAME*8
C
C---------------------------------------------------------------------
CL              2.         output
C
C        WRITE(NOUT,9002) KNAME
C9002    FORMAT(//,A,/)
C        WRITE(NOUT,9000)
C9000    FORMAT(2(' index  L    M   dir     value    '))
C        WRITE(NOUT,9003) (J,KL(J),KM(J),KDIRN(J),PA(J),J=1,KBSEG2)
C9003    FORMAT(2(1X,4I5,G12.5))
C---------------------------------------------------------------------
         END
C/ MODULE cus4
C
         SUBROUTINE RVAR(KNAME,PVALUE)
C
C U.4  PRINT NAME AND VALUE OF REAL VARIABLE
C
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C-----------------------------------------------------------------------
       CHARACTER   KNAME*8
C-----------------------------------------------------------------------
C
C        WRITE(NOUT,9000) KNAME , PVALUE
C
         RETURN
C9000    FORMAT(4X,A8,' = ',1PE12.5)
         END
C/ MODULE cus1
C
         SUBROUTINE MESAGE(KMESS)
C
C U.1  PRINT CHARACTER MESSAGE ON OUTPUT CHANNEL
C
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C-----------------------------------------------------------------------
       CHARACTER   KMESS*(*)
C-----------------------------------------------------------------------
C
C        WRITE(NOUT,9000) KMESS
C
         RETURN
C9000    FORMAT(4X,A)
         END
C/ MODULE cus5
C
         SUBROUTINE IVAR(KNAME,KVALUE)
C
C U.5  PRINT NAME AND VALUE OF INTEGER VARIABLE
C
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C-----------------------------------------------------------------------
       CHARACTER   KNAME*8
C-----------------------------------------------------------------------
C
C        WRITE(NOUT,9000) KNAME , KVALUE
C
         RETURN
C9000    FORMAT(4X,A8,' =',I12)
         END
C/ MODULE cus53
C
         SUBROUTINE LADATA(KNAME,KARRAY,KDIM)
C
C U.53 input logical array of values from data file on nread
C
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


       CHARACTER   KNAME*8
       DIMENSION   IDEF(1024) ,         KARRAY(KDIM)
       LOGICAL     ILNOCH,   KARRAY,   IDEF
C
C-----------------------------------------------------------------------
CL              1.         input
C
         IMIN=MIN(KDIM,1024)
         DO 100 J=1,IMIN
  100    IDEF(J)=KARRAY(J)
C
C-----------------------------------------------------------------------
CL              2.         output
C
         ILNOCH=.TRUE.
         DO 200 J=1,IMIN
         IF( IDEF(J) .NEQV. KARRAY(J) ) THEN
         ILNOCH=.FALSE.
C        WRITE(NOUT,9001) J,KARRAY(J),IDEF(J)
         END IF
  200    CONTINUE
C9000    FORMAT(' changes to ',A8,' : ',A)
C9001    FORMAT(4(1X,I3,3X,L12,' (',L12,' )    '))
         RETURN
C
C-----------------------------------------------------------------------
CL              3.         errors
C
  300    CONTINUE
C        WRITE(NOUT,9002)
C9002    FORMAT(' =====end of file met by LADATA=====')
         STOP
  301    CONTINUE
C        WRITE(NOUT,9003)
C9003    FORMAT(' =====error in read met by LADATA=====')
         STOP
         END
C/ MODULE cus51
C
         SUBROUTINE RADATA(KNAME,PARRAY,KDIM)
C
C U.51 input real array of values from data file on nread
C
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


       CHARACTER   KNAME*8
       DIMENSION   ZDEF(1024) ,         PARRAY(KDIM)
       LOGICAL     ILNOCH
C
C-----------------------------------------------------------------------
CL              1.         input
C
         IMIN=MIN(KDIM,1024)
         DO 100 J=1,IMIN
  100    ZDEF(J)=PARRAY(J)
C
C-----------------------------------------------------------------------
CL              2.         output
C
         ILNOCH=.TRUE.
         DO 200 J=1,IMIN
         IF(ZDEF(J).NE.PARRAY(J)) THEN
            ILNOCH=.FALSE.
C           WRITE(NOUT,9001) J,PARRAY(J),ZDEF(J)
         END IF
  200    CONTINUE
C9000    FORMAT(' changes to ',A8,' : ',A)
C9001    FORMAT(4(1X,I3,3X,1PE12.5,' (',1PE12.5,' )    '))
         RETURN
C
C-----------------------------------------------------------------------
CL              3.         errors
C
  300    CONTINUE
C        WRITE(NOUT,9002)
C9002    FORMAT(' =====end of file met by RADATA=====')
         STOP
  301    CONTINUE
C        WRITE(NOUT,9003)
C9003    FORMAT(' =====error in read met by RADATA=====')
         STOP
         END
C/ MODULE cus50
C
         SUBROUTINE HDATA(KNAME,KCHARS)
C
C U.50 input character string from data file on nread
C
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
       CHARACTER   KNAME*8,  ICDEF*80
       CHARACTER   KCHARS*(*)
C
C-----------------------------------------------------------------------
CL              1.         input
C
         ICDEF=KCHARS
C
C-----------------------------------------------------------------------
CL              2.         output
C
         RETURN
C
C-----------------------------------------------------------------------
CL              3.         errors
C
  300    CONTINUE
C        WRITE(NOUT,9001)
C9001    FORMAT(' =====end of file met by HDATA=====')
         STOP
  301    CONTINUE
C        WRITE(NOUT,9002)
C9002    FORMAT(' =====error in read met by HDATA=====')
         STOP
         END
C/ MODULE cus46
C
         SUBROUTINE IDATA(KNAME,KVALUE)
C
C U.46 input integer value from data file on nread
C
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


       CHARACTER   KNAME*8
C
C-----------------------------------------------------------------------
CL              1.         input
C
         IDEF=KVALUE
C
C-----------------------------------------------------------------------
CL              2.         output
C
         RETURN
C
C-----------------------------------------------------------------------
CL              3.         errors
C
  300    CONTINUE
C        WRITE(NOUT,9001)
C9001    FORMAT(' =====end of file met by IDATA=====')
         STOP
  301    CONTINUE
C        WRITE(NOUT,9002)
C9002    FORMAT(' =====error in read met by IDATA=====')
         STOP
         END
C/ MODULE cus47
C
         SUBROUTINE LDATA(KNAME,KLVALU)
C
C U.47 input logical value from data file on nread
C
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


       CHARACTER   KNAME*8
       LOGICAL     KLVALU,   ILDEF
C
C-----------------------------------------------------------------------
CL              1.         input
C
         ILDEF=KLVALU
C
C-----------------------------------------------------------------------
CL              2.         output
C
         RETURN
C
C-----------------------------------------------------------------------
CL              3.         errors
C
  300    CONTINUE
C        WRITE(NOUT,9001)
C9001    FORMAT(' =====end of file met by LDATA=====')
         STOP
  301    CONTINUE
C        WRITE(NOUT,9002)
C9002    FORMAT(' =====error in read met by LDATA=====')
         STOP
         END
C/ MODULE cus45
C
         SUBROUTINE RDATA(KNAME,PVALUE)
C
C U.45 input real value from data file on nread
C
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


       CHARACTER   KNAME*8
C
C-----------------------------------------------------------------------
CL              1.         input
C
         ZDEF=PVALUE
C
C-----------------------------------------------------------------------
CL              2.         output
C
         RETURN
C
C-----------------------------------------------------------------------
CL              3.         errors
C
  300    CONTINUE
C        WRITE(NOUT,9001)
C9001    FORMAT(' =====end of file met by RDATA=====')
         STOP
  301    CONTINUE
C        WRITE(NOUT,9002)
C9002    FORMAT(' =====error in read met by RDATA=====')
         STOP
         END
C/ MODULE cus52
C
         SUBROUTINE IADATA(KNAME,KARRAY,KDIM)
C
C U.52 input integer array of values from data file on nread
C
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


       CHARACTER   KNAME*8
       DIMENSION   IDEF(1024) ,         KARRAY(KDIM)
       LOGICAL     ILNOCH
C
C-----------------------------------------------------------------------
CL              1.         input
C
         IMIN=MIN(KDIM,1024)
         DO 100 J=1,IMIN
  100    IDEF(J)=KARRAY(J)
C
C-----------------------------------------------------------------------
CL              2.         output
C
         ILNOCH=.TRUE.
         DO 200 J=1,IMIN
         IF(IDEF(J).NE.KARRAY(J)) THEN
         ILNOCH=.FALSE.
C        WRITE(NOUT,9001) J,KARRAY(J),IDEF(J)
         END IF
  200    CONTINUE
C9000    FORMAT(' changes to ',A8,' : ',A)
C9001    FORMAT(4(1X,I3,3X,I12,' (',I12,' )    '))
         RETURN
C
C-----------------------------------------------------------------------
CL              3.         errors
C
  300    CONTINUE
C        WRITE(NOUT,9002)
C9002    FORMAT(' =====end of file met by IADATA=====')
         STOP
  301    CONTINUE
C        WRITE(NOUT,9003)
C9003    FORMAT(' =====error in read met by IADATA=====')
         STOP
         END
C
         SUBROUTINE BLINES(K)
C
C U.3  INSERT BLANK LINES ON OUTPUT CHANNEL
C
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C-----------------------------------------------------------------------
C
         DO 1 J=1,K
C        WRITE(NOUT,9000)
    1    CONTINUE
C
         RETURN
C9000    FORMAT(' ')
         END
C/ MODULE C1S5
C
         SUBROUTINE AUXVAL
C
C 1.5  SET AUXILIARY VALUES
C
C-----------------------------------------------------------------------
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C       INCLUDE 'COMDDP.inc'
C--------------------------------------------------------------------
CL                  C1.9.    DEVELOPMENT AND DIAGNOSTIC PARAMETERS
       COMMON/COMDDP/
     I   MAXDUM,   MXDUMP,   NADUMP,   NCLASS,   NPDUMP,   NPOINT,
     I   NSUB,     NVDUMP,
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       LOGICAL
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       DIMENSION
     I   NADUMP(20),         NPDUMP(20),         NVDUMP(20),
     L   NLHEAD(9),          NLOMT1(50),         NLOMT2(50),
     L   NLOMT3(50)
C       INCLUDE 'COMCON.inc'
C---------------------------------------------------------------------
CL                  C2.1     Physical Constants
       COMMON/COMCON/
     R   API   ,   BOLTZK,   CLIGHT,   ELCHAG,   ELMASS,   EMU0  ,
     R   EOVERM,   EPS0
C       INCLUDE 'COMSTT.inc'
C---------------------------------------------------------------------
CL                  C2.2     Physical State
       COMMON/COMSTT/
     R   B3    ,   BAV   ,   CD1   ,   CD2   ,   E1    ,   E2    ,
     R   P1    ,   P2    ,   Q1    ,   Q2    ,   REALTN,   TIMRUN
       DIMENSION
     R   B3(605,40),        BAV(605,40),       CD1(605,40),
     R   CD2(605,40),       E1(605,40),        E2(605,40),
     R   P1(20000),          P2(20000),          Q1(20000),
     R   Q2(20000)
C       INCLUDE 'COMDEV.inc'
C---------------------------------------------------------------------
CL                  C2.3     Device description
       COMMON/COMDEV/
     R   B3RHS ,   B3RHSD,   BAPLY ,   BAPLYD,   CAVEAM,   CAVEFR,
     R   CAVIC ,   CAVRES,   CAVTC ,   DEPTH ,   DEVHYT,   DEVLEN,
     R   DEVRAD,   EAPLYD,   EEMIT ,   EEMITD,   ENIT  ,   ENITD ,
     R   GAP   ,   RESAX ,   RESE  ,   RESN  ,   RESS  ,   RESW  ,
     R   RINNER,   SPACE ,   VOLTAG,   WIDTH ,
     I   LCATH ,   LCAV  ,   LLEFT ,   LWVANE,   MDEPTH,   MGAP  ,
     I   NBCAX ,   NBCCAV,   NBCE  ,   NBCN  ,   NBCS  ,   NBCW  ,
     I   NCAV  ,   NDEV
       DIMENSION
     R   CAVEAM(100),        CAVEFR(100),        CAVIC(4,100),
     R   CAVRES(100),        CAVTC(100),
     I   NBCCAV(100)
C       INCLUDE 'COMDIA.inc'
C---------------------------------------------------------------------
CL                  C2.4     Physical Diagnostics
       COMMON/COMDIA/
     R   B3POW ,   BOUT  ,   CAVPOY,   E1POW ,   E2POW ,   EJ1POW,
     R   EJ2POW,   EJENP ,   EJPOWM,   EJPOWP,   EJPWPN,   EKFLXI,
     R   EKFLXO,   ENEJ1 ,   ENEJ2 ,   ENEL1 ,   ENEL1O,   ENEL2 ,
     R   ENEL2O,   ENKIN ,   ENKINO,   ENMAG ,   ENMAGO,   ENPOYT,
     R   ENTOT ,   ENTOTO,   EOUT  ,   TOTM1 ,   TOTM2 ,   TPOYP ,
     I   LCAVEN,   LCAVST,   NPNEW ,   NPOLD
       DIMENSION
     R   BOUT(100),          CAVPOY(100),        EOUT(100),
     I   LCAVEN(100),        LCAVST(100)
C       INCLUDE 'COMNUM.inc'
C---------------------------------------------------------------------
CL                  C3.1     Numerical Parameters
       COMMON/COMNUM/
     R   C1    ,   C2    ,   CD0   ,   CURANT,   DT    ,   DX1   ,
     R   DX1DX2,   DX1OX2,   DX2   ,   DX2OX1,   ELPERP,   HLFDX1,
     R   HLFDX2,   TCACO ,
     I   LMAX  ,   LMAXP ,   LMAXP2,   MMAX  ,   MMAXP ,   MMAXP2,
     I   NEMIT ,   NP
C       INCLUDE 'COMSCA.inc'
C---------------------------------------------------------------------
CL                  C3.2     Scaling Factors
       COMMON/COMSCA/
     R   SCB3  ,   SCE1  ,   SCE2  ,   SCEMEN,   SCEPOW,   SCI1  ,
     R   SCI2  ,   SCIP  ,   SCKE  ,   SCKPOW,   SCP1  ,   SCP2  ,
     R   SCV1  ,   SCV2  ,   SCX1  ,   SCX2
C       INCLUDE 'COMHOK.inc'
C---------------------------------------------------------------------
CL                  C4.1     Housekeeping
       COMMON/COMHOK/
     R   TIMECP,   XPSMAX,   XPSMIN,   YPSMAX,   YPSMIN,
     I   N1MAX ,   N2MAX ,   NCASE ,   NGMAX ,   NOSEP ,   NPDUM ,
     I   NPMAX ,   NSRC  ,   NXDUM ,   NYDUM
       DIMENSION
     R   TIMECP(32)
C       INCLUDE 'COMGEO.inc'
C---------------------------------------------------------------------
CL                  C4.2     Device boundary data
       COMMON/COMGEO/
     R   ASCUR ,   CCTSRC,   EBEXT ,   ELSCUR,   ENSUR ,   EPOYNT,
     R   RHOC  ,   SURCHG,   SURIC ,
     I   LINDEX,   MINDEX,   NBCTYP,   NBDIM ,   NBSEG2,   NCOLOR,
     I   NDIRN ,   NG
       DIMENSION
     R   ASCUR(1500),        CCTSRC(1500),       EBEXT(2,1500),
     R   ELSCUR(1500),       ENSUR(1500),        EPOYNT(1500),
     R   RHOC(1500),         SURCHG(1500),       SURIC(4,1500),
     I   LINDEX(1500),       MINDEX(1500),       NBCTYP(1500),
     I   NCOLOR(1500),       NDIRN(1500),        NG(605,40)
C       INCLUDE 'COMOUT.inc'
C---------------------------------------------------------------------
CL                  C5.1     Output Variables
       COMMON/COMOUT/
     R   BCNMAX,   BCNMIN,   BCVMAX,   BCVMIN,   CUAMAX,   CUAMIN,
     R   CUEMAX,   CUEMIN,   ECVMAX,   ECVMIN,   TONS1 ,   TONS2 ,
     R   TONS3 ,   TONS4 ,   TONS5 ,   TONS6 ,   TONS7 ,
     I   NBCHT ,   NOPSEL,   NS1   ,   NS2   ,   NS3   ,   NS4   ,
     I   NS5   ,   NS6   ,   NS7
C-----------------------------------------------------------------------
         DATA        ICLASS,   ISUB/1,   5/
                                       CALL EXPERT(ICLASS,ISUB,1)
         IF(NLOMT1(ISUB))RETURN
C
C-----------------------------------------------------------------------
CL              1.         Physical
C
         EOVERM = ELCHAG/ELMASS
         DX1    = DEVLEN/(LMAX-1)
         DX2    = DEVHYT/(MMAX-1)
         GAP    = MGAP*DX2
         DEPTH  = MDEPTH*DX2
         SPACE  = (LCAV+LWVANE)*DX1
         WIDTH  = LWVANE*DX1
C
C-----------------------------------------------------------------------
CL              2.         Numerical
C
         HLFDX1 = DX1 / 2.0
         HLFDX2 = DX2 / 2.0
         DX1DX2 = DX1 * DX2
         DX1OX2 = DX1 / DX2
         DX2OX1 = DX2 / DX1
         DT     = CURANT/SQRT(1./DX1**2+1./DX2**2)/CLIGHT
         REALTN = NSTEP*DT*1.0E9
         IF(TIMRUN.GT.0.0) THEN
         NRUN   = TIMRUN/DT/1.0E9
C        WRITE(NOUT,9000) NRUN
C9000    FORMAT(' NRUN reset to ',I10)
         END IF
C
         C1     = CLIGHT * DT / DX1
         C2     = CLIGHT * DT / DX2
         RINNER = DEVRAD/DX2
         ZRCATH = RINNER+MMAX-MGAP-MDEPTH-1
         CD0    = ELPERP*ELCHAG**2*EMU0/(4*API*ELMASS*DX2)
C
         LMAXP  = LMAX + 1
         LMAXP2 = LMAX + 2
C
         MMAXP  = MMAX + 1
         MMAXP2 = MMAX + 2
         ZZZZ = REND(1)
C
C-----------------------------------------------------------------------
CL              3.         Scaling
C
C     DIMENSIONLESS * SC__ = SI VALUE
C     position
         SCX1   = DX1
         SCX2   = DX2
C     velocity
         SCV1   = DX1 / DT
         SCV2   = DX2 / DT
C     momentum
         SCP1   = ELMASS*CLIGHT
         SCP2   = SCP2
C     fields
         SCB3   = 2.0/(EOVERM * DT)
         SCE1   = SCB3 * CLIGHT
         SCE2   = SCE1
C     Currents
         SCI1   = SCB3*DX2*2.0*API/EMU0
         SCI2   = SCB3*DX2*2.0*API/EMU0
         SCIP   = ELPERP*ELCHAG/DT
C     Energies and powers
         SCKE   = ELMASS*ELPERP*CLIGHT**2
         SCKPOW = SCKE/DT
         SCEMEN = SCE1**2*EPS0*DX1DX2*2*API*DX2
         SCEPOW = SCEMEN/DT
C
C     specified fields
         EAPLYD = VOLTAG/LOG(1+MGAP/ZRCATH)/SCE2/DX2
         BAPLYD = BAPLY/SCB3
         EEMITD = EEMIT/SCE2
         B3RHSD = B3RHS/SCB3
         ENITD  = ENIT/SCE2
C the following assumes ENIT is voltage accross coax(NCASE=1)
C        ENITD  = ENIT  /LOG(1+(MMAX-1)/RINNER)/SCE2/DX2
C
C-----------------------------------------------------------------------
CL              4.         Housekeeping
C
C     set default file names
         CHLAB6='G_'//CHREFN
         CHLAB7='F_'//CHREFN
         CHLAB8='R_'//CHREFN
         CHLAB9='E_'//CHREFN
         CHLB10='C_'//CHREFN
C-----------------------------------------------------------------------
         END
C/ MODULE C3S7
C
         SUBROUTINE EAVCAV(K)
C
C 3.7  Output time history of cavity electric fields and
C
C     magnetic fields and some selected currents
C this assumes geometry as set by <1.14> SETLO
C
C     this version outputs B in Tesla and the cavity
C     integrated voltage in Kilovolts
C-----------------------------------------------------------------------
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C       INCLUDE 'COMDDP.inc'
C--------------------------------------------------------------------
CL                  C1.9.    DEVELOPMENT AND DIAGNOSTIC PARAMETERS
       COMMON/COMDDP/
     I   MAXDUM,   MXDUMP,   NADUMP,   NCLASS,   NPDUMP,   NPOINT,
     I   NSUB,     NVDUMP,
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       LOGICAL
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       DIMENSION
     I   NADUMP(20),         NPDUMP(20),         NVDUMP(20),
     L   NLHEAD(9),          NLOMT1(50),         NLOMT2(50),
     L   NLOMT3(50)
C       INCLUDE 'COMCON.inc'
C---------------------------------------------------------------------
CL                  C2.1     Physical Constants
       COMMON/COMCON/
     R   API   ,   BOLTZK,   CLIGHT,   ELCHAG,   ELMASS,   EMU0  ,
     R   EOVERM,   EPS0
C       INCLUDE 'COMSTT.inc'
C---------------------------------------------------------------------
CL                  C2.2     Physical State
       COMMON/COMSTT/
     R   B3    ,   BAV   ,   CD1   ,   CD2   ,   E1    ,   E2    ,
     R   P1    ,   P2    ,   Q1    ,   Q2    ,   REALTN,   TIMRUN
       DIMENSION
     R   B3(605,40),        BAV(605,40),       CD1(605,40),
     R   CD2(605,40),       E1(605,40),        E2(605,40),
     R   P1(20000),          P2(20000),          Q1(20000),
     R   Q2(20000)
C       INCLUDE 'COMDEV.inc'
C---------------------------------------------------------------------
CL                  C2.3     Device description
       COMMON/COMDEV/
     R   B3RHS ,   B3RHSD,   BAPLY ,   BAPLYD,   CAVEAM,   CAVEFR,
     R   CAVIC ,   CAVRES,   CAVTC ,   DEPTH ,   DEVHYT,   DEVLEN,
     R   DEVRAD,   EAPLYD,   EEMIT ,   EEMITD,   ENIT  ,   ENITD ,
     R   GAP   ,   RESAX ,   RESE  ,   RESN  ,   RESS  ,   RESW  ,
     R   RINNER,   SPACE ,   VOLTAG,   WIDTH ,
     I   LCATH ,   LCAV  ,   LLEFT ,   LWVANE,   MDEPTH,   MGAP  ,
     I   NBCAX ,   NBCCAV,   NBCE  ,   NBCN  ,   NBCS  ,   NBCW  ,
     I   NCAV  ,   NDEV
       DIMENSION
     R   CAVEAM(100),        CAVEFR(100),        CAVIC(4,100),
     R   CAVRES(100),        CAVTC(100),
     I   NBCCAV(100)
C       INCLUDE 'COMDIA.inc'
C---------------------------------------------------------------------
CL                  C2.4     Physical Diagnostics
       COMMON/COMDIA/
     R   B3POW ,   BOUT  ,   CAVPOY,   E1POW ,   E2POW ,   EJ1POW,
     R   EJ2POW,   EJENP ,   EJPOWM,   EJPOWP,   EJPWPN,   EKFLXI,
     R   EKFLXO,   ENEJ1 ,   ENEJ2 ,   ENEL1 ,   ENEL1O,   ENEL2 ,
     R   ENEL2O,   ENKIN ,   ENKINO,   ENMAG ,   ENMAGO,   ENPOYT,
     R   ENTOT ,   ENTOTO,   EOUT  ,   TOTM1 ,   TOTM2 ,   TPOYP ,
     I   LCAVEN,   LCAVST,   NPNEW ,   NPOLD
       DIMENSION
     R   BOUT(100),          CAVPOY(100),        EOUT(100),
     I   LCAVEN(100),        LCAVST(100)
C       INCLUDE 'COMNUM.inc'
C---------------------------------------------------------------------
CL                  C3.1     Numerical Parameters
       COMMON/COMNUM/
     R   C1    ,   C2    ,   CD0   ,   CURANT,   DT    ,   DX1   ,
     R   DX1DX2,   DX1OX2,   DX2   ,   DX2OX1,   ELPERP,   HLFDX1,
     R   HLFDX2,   TCACO ,
     I   LMAX  ,   LMAXP ,   LMAXP2,   MMAX  ,   MMAXP ,   MMAXP2,
     I   NEMIT ,   NP
C       INCLUDE 'COMSCA.inc'
C---------------------------------------------------------------------
CL                  C3.2     Scaling Factors
       COMMON/COMSCA/
     R   SCB3  ,   SCE1  ,   SCE2  ,   SCEMEN,   SCEPOW,   SCI1  ,
     R   SCI2  ,   SCIP  ,   SCKE  ,   SCKPOW,   SCP1  ,   SCP2  ,
     R   SCV1  ,   SCV2  ,   SCX1  ,   SCX2
C       INCLUDE 'COMHOK.inc'
C---------------------------------------------------------------------
CL                  C4.1     Housekeeping
       COMMON/COMHOK/
     R   TIMECP,   XPSMAX,   XPSMIN,   YPSMAX,   YPSMIN,
     I   N1MAX ,   N2MAX ,   NCASE ,   NGMAX ,   NOSEP ,   NPDUM ,
     I   NPMAX ,   NSRC  ,   NXDUM ,   NYDUM
       DIMENSION
     R   TIMECP(32)
C       INCLUDE 'COMGEO.inc'
C---------------------------------------------------------------------
CL                  C4.2     Device boundary data
       COMMON/COMGEO/
     R   ASCUR ,   CCTSRC,   EBEXT ,   ELSCUR,   ENSUR ,   EPOYNT,
     R   RHOC  ,   SURCHG,   SURIC ,
     I   LINDEX,   MINDEX,   NBCTYP,   NBDIM ,   NBSEG2,   NCOLOR,
     I   NDIRN ,   NG
       DIMENSION
     R   ASCUR(1500),        CCTSRC(1500),       EBEXT(2,1500),
     R   ELSCUR(1500),       ENSUR(1500),        EPOYNT(1500),
     R   RHOC(1500),         SURCHG(1500),       SURIC(4,1500),
     I   LINDEX(1500),       MINDEX(1500),       NBCTYP(1500),
     I   NCOLOR(1500),       NDIRN(1500),        NG(605,40)
C       INCLUDE 'COMOUT.inc'
C---------------------------------------------------------------------
CL                  C5.1     Output Variables
       COMMON/COMOUT/
     R   BCNMAX,   BCNMIN,   BCVMAX,   BCVMIN,   CUAMAX,   CUAMIN,
     R   CUEMAX,   CUEMIN,   ECVMAX,   ECVMIN,   TONS1 ,   TONS2 ,
     R   TONS3 ,   TONS4 ,   TONS5 ,   TONS6 ,   TONS7 ,
     I   NBCHT ,   NOPSEL,   NS1   ,   NS2   ,   NS3   ,   NS4   ,
     I   NS5   ,   NS6   ,   NS7
C-----------------------------------------------------------------------
         DATA        ICLASS,   ISUB/3,   7/
                                       CALL EXPERT(ICLASS,ISUB,1)
         IF(NLOMT3(ISUB)) RETURN
C-----------------------------------------------------------------------
         GO TO (100,200,300),K
C
C-----------------------------------------------------------------------
CL              1.         Initialisation
C
  100    CONTINUE
C     set up output file on NPUNCH
C        OPEN(UNIT=NPUNCH,FILE=CHLAB7,FORM='UNFORMATTED')
C     write in header information to channel NPUNCH
         KCHAN = NPUNCH
C
C        WRITE(KCHAN) CHLAB1,CHREFN,CHRDAT,CHRDAT
C
C        WRITE(KCHAN)LMAX,MMAX,NCASE,NCAV
C
         DEPCM=DEPTH*100.
         GAPCM=GAP*100.
         RZCM=DEVRAD*100.
         SPACM=SPACE*100.
         WDCM=WIDTH*100.
         VOLTK=VOLTAG/1000.
C
C        WRITE(KCHAN)DEPCM,GAPCM,RZCM,SPACM,WDCM,VOLTK
C
C        WRITE(KCHAN)NCAV
C
         RETURN
C
C-----------------------------------------------------------------------
CL              2.         Periodic Output
C
  200    CONTINUE
C
         IL1=2+LLEFT
         IL2=LCAV+LWVANE
C
CL                  2.1      average E and B across cavities
         DO 211 J=1,NCAV
         ILMIN=IL1+(J-1)*IL2
         ILMAX=ILMIN+LCAV-1
         EOUT(J)=0.0
         BOUT(J)= B3((ILMIN+ILMAX)/2,MMAX)
         DO 210 IL=ILMIN,ILMAX
         EOUT(J)=EOUT(J)+E1(IL,MMAX-MDEPTH+1)
  210    CONTINUE
         EOUT(J)=EOUT(J)*SCE2*DX1/1000
         BOUT(J)=BOUT(J)*SCB3
  211    CONTINUE
C
C  CAVITY POYNTING POWER
C
         DO 213 J=1,NCAV
         CAVPOY(J)=0.0
         DO 214 IL=LCAVST(J),LCAVEN(J)
 214     CAVPOY(J)=CAVPOY(J)+EPOYNT(IL)
         CAVPOY(J)=SCEPOW*CAVPOY(J)
 213     CONTINUE
C
CL                  2.2      output
C        WRITE(NPUNCH) REALTN,(EOUT(N),N=1,NCAV),(BOUT(N),N=1,NCAV)
C    $ ,(CAVPOY(N),N=1,NCAV)
         RETURN
C
C-----------------------------------------------------------------------
CL              3.         Closedown
C
  300    CONTINUE
C        CLOSE(UNIT=NPUNCH)
C-----------------------------------------------------------------------
         END
C/ MODULE C3S3
C
         SUBROUTINE GAUSOP
C
C 3.3  Output charge conservation check
C
C-----------------------------------------------------------------------
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C       INCLUDE 'COMDDP.inc'
C--------------------------------------------------------------------
CL                  C1.9.    DEVELOPMENT AND DIAGNOSTIC PARAMETERS
       COMMON/COMDDP/
     I   MAXDUM,   MXDUMP,   NADUMP,   NCLASS,   NPDUMP,   NPOINT,
     I   NSUB,     NVDUMP,
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       LOGICAL
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       DIMENSION
     I   NADUMP(20),         NPDUMP(20),         NVDUMP(20),
     L   NLHEAD(9),          NLOMT1(50),         NLOMT2(50),
     L   NLOMT3(50)
C       INCLUDE 'COMCON.inc'
C---------------------------------------------------------------------
CL                  C2.1     Physical Constants
       COMMON/COMCON/
     R   API   ,   BOLTZK,   CLIGHT,   ELCHAG,   ELMASS,   EMU0  ,
     R   EOVERM,   EPS0
C       INCLUDE 'COMSTT.inc'
C---------------------------------------------------------------------
CL                  C2.2     Physical State
       COMMON/COMSTT/
     R   B3    ,   BAV   ,   CD1   ,   CD2   ,   E1    ,   E2    ,
     R   P1    ,   P2    ,   Q1    ,   Q2    ,   REALTN,   TIMRUN
       DIMENSION
     R   B3(605,40),        BAV(605,40),       CD1(605,40),
     R   CD2(605,40),       E1(605,40),        E2(605,40),
     R   P1(20000),          P2(20000),          Q1(20000),
     R   Q2(20000)
C       INCLUDE 'COMDEV.inc'
C---------------------------------------------------------------------
CL                  C2.3     Device description
       COMMON/COMDEV/
     R   B3RHS ,   B3RHSD,   BAPLY ,   BAPLYD,   CAVEAM,   CAVEFR,
     R   CAVIC ,   CAVRES,   CAVTC ,   DEPTH ,   DEVHYT,   DEVLEN,
     R   DEVRAD,   EAPLYD,   EEMIT ,   EEMITD,   ENIT  ,   ENITD ,
     R   GAP   ,   RESAX ,   RESE  ,   RESN  ,   RESS  ,   RESW  ,
     R   RINNER,   SPACE ,   VOLTAG,   WIDTH ,
     I   LCATH ,   LCAV  ,   LLEFT ,   LWVANE,   MDEPTH,   MGAP  ,
     I   NBCAX ,   NBCCAV,   NBCE  ,   NBCN  ,   NBCS  ,   NBCW  ,
     I   NCAV  ,   NDEV
       DIMENSION
     R   CAVEAM(100),        CAVEFR(100),        CAVIC(4,100),
     R   CAVRES(100),        CAVTC(100),
     I   NBCCAV(100)
C       INCLUDE 'COMDIA.inc'
C---------------------------------------------------------------------
CL                  C2.4     Physical Diagnostics
       COMMON/COMDIA/
     R   B3POW ,   BOUT  ,   CAVPOY,   E1POW ,   E2POW ,   EJ1POW,
     R   EJ2POW,   EJENP ,   EJPOWM,   EJPOWP,   EJPWPN,   EKFLXI,
     R   EKFLXO,   ENEJ1 ,   ENEJ2 ,   ENEL1 ,   ENEL1O,   ENEL2 ,
     R   ENEL2O,   ENKIN ,   ENKINO,   ENMAG ,   ENMAGO,   ENPOYT,
     R   ENTOT ,   ENTOTO,   EOUT  ,   TOTM1 ,   TOTM2 ,   TPOYP ,
     I   LCAVEN,   LCAVST,   NPNEW ,   NPOLD
       DIMENSION
     R   BOUT(100),          CAVPOY(100),        EOUT(100),
     I   LCAVEN(100),        LCAVST(100)
C       INCLUDE 'COMNUM.inc'
C---------------------------------------------------------------------
CL                  C3.1     Numerical Parameters
       COMMON/COMNUM/
     R   C1    ,   C2    ,   CD0   ,   CURANT,   DT    ,   DX1   ,
     R   DX1DX2,   DX1OX2,   DX2   ,   DX2OX1,   ELPERP,   HLFDX1,
     R   HLFDX2,   TCACO ,
     I   LMAX  ,   LMAXP ,   LMAXP2,   MMAX  ,   MMAXP ,   MMAXP2,
     I   NEMIT ,   NP
C       INCLUDE 'COMSCA.inc'
C---------------------------------------------------------------------
CL                  C3.2     Scaling Factors
       COMMON/COMSCA/
     R   SCB3  ,   SCE1  ,   SCE2  ,   SCEMEN,   SCEPOW,   SCI1  ,
     R   SCI2  ,   SCIP  ,   SCKE  ,   SCKPOW,   SCP1  ,   SCP2  ,
     R   SCV1  ,   SCV2  ,   SCX1  ,   SCX2
C       INCLUDE 'COMHOK.inc'
C---------------------------------------------------------------------
CL                  C4.1     Housekeeping
       COMMON/COMHOK/
     R   TIMECP,   XPSMAX,   XPSMIN,   YPSMAX,   YPSMIN,
     I   N1MAX ,   N2MAX ,   NCASE ,   NGMAX ,   NOSEP ,   NPDUM ,
     I   NPMAX ,   NSRC  ,   NXDUM ,   NYDUM
       DIMENSION
     R   TIMECP(32)
C       INCLUDE 'COMGEO.inc'
C---------------------------------------------------------------------
CL                  C4.2     Device boundary data
       COMMON/COMGEO/
     R   ASCUR ,   CCTSRC,   EBEXT ,   ELSCUR,   ENSUR ,   EPOYNT,
     R   RHOC  ,   SURCHG,   SURIC ,
     I   LINDEX,   MINDEX,   NBCTYP,   NBDIM ,   NBSEG2,   NCOLOR,
     I   NDIRN ,   NG
       DIMENSION
     R   ASCUR(1500),        CCTSRC(1500),       EBEXT(2,1500),
     R   ELSCUR(1500),       ENSUR(1500),        EPOYNT(1500),
     R   RHOC(1500),         SURCHG(1500),       SURIC(4,1500),
     I   LINDEX(1500),       MINDEX(1500),       NBCTYP(1500),
     I   NCOLOR(1500),       NDIRN(1500),        NG(605,40)
C       INCLUDE 'COMOUT.inc'
C---------------------------------------------------------------------
CL                  C5.1     Output Variables
       COMMON/COMOUT/
     R   BCNMAX,   BCNMIN,   BCVMAX,   BCVMIN,   CUAMAX,   CUAMIN,
     R   CUEMAX,   CUEMIN,   ECVMAX,   ECVMIN,   TONS1 ,   TONS2 ,
     R   TONS3 ,   TONS4 ,   TONS5 ,   TONS6 ,   TONS7 ,
     I   NBCHT ,   NOPSEL,   NS1   ,   NS2   ,   NS3   ,   NS4   ,
     I   NS5   ,   NS6   ,   NS7
         DIMENSION ZESUM(100)
C-----------------------------------------------------------------------
         DATA        ICLASS,   ISUB/3,   3/
                                       CALL EXPERT(ICLASS,ISUB,1)
         IF(NLOMT3(ISUB)) RETURN
C
C-----------------------------------------------------------------------
CL              1.         find charge conservation error field
C
C     note contents of array CD1 are overwritten
         CALL EBJCLS(E1,E2,B3,CD1,CD2,N1MAX,LMAXP2,MMAXP2,
     +               NBSEG2,LINDEX,MINDEX,NDIRN)
         CALL GAUSCK(E1,E2,CD1,N1MAX,LMAXP2,MMAXP2,
     +               Q1,Q2,NP,C1,C2,CD0,RINNER)
C
C-----------------------------------------------------------------------
CL              2.         find error norms
C
C
CL                  2.1      initialise
         ZMSE = 0.0
         ZAVE = 0.0
         INEL = O
         ZMXE = 0.0
         ZMNE = 0.0
         ILMX = 0
         ILMN = 0
         IMMX = 0
         IMMX = 0
C
CL                  2.2      accumulate over interior elements
         DO 220 IL = 1,LMAXP
         DO 220 IM = 1,MMAXP
         IF(NG(IL,IM).EQ.0) THEN
         ZQ1=CD1(IL,IM)
         ZQ2=CD1(IL+1,IM)
         ZQ3=CD1(IL+1,IM+1)
         ZQ4=CD1(IL,IM+1)
C
         INEL=INEL+1
         ZAVE=ZAVE+ZQ1+ZQ2+ZQ3+ZQ4
         ZMSE=ZMSE+ZQ1**2+ZQ2**2+ZQ3**2+ZQ4**2
         IF(ZQ1.GT.ZMXE) THEN
         ZMXE=ZQ1
         ILMX=IL
         IMMX=IM
         END IF
C     find value and position of max
         IF(ZQ2.GT.ZMXE) THEN
         ZMXE=ZQ2
         ILMX=IL+1
         IMMX=IM
         END IF
         IF(ZQ3.GT.ZMXE) THEN
         ZMXE=ZQ3
         ILMX=IL+1
         IMMX=IM+1
         END IF
         IF(ZQ4.GT.ZMXE) THEN
         ZMXE=ZQ4
         ILMX=IL
         IMMX=IM+1
         END IF
C     find value and position of min
         IF(ZQ1.LT.ZMNE) THEN
         ZMNE=ZQ1
         ILMN=IL
         IMMN=IM
         END IF
         IF(ZQ2.LT.ZMNE) THEN
         ZMNE=ZQ2
         ILMN=IL+1
         IMMN=IM
         END IF
         IF(ZQ3.LT.ZMNE) THEN
         ZMNE=ZQ3
         ILMN=IL+1
         IMMN=IM+1
         END IF
         IF(ZQ4.LT.ZMNE) THEN
         ZMNE=ZQ4
         ILMN=IL
         IMMN=IM+1
         END IF
C
         END IF
  220    CONTINUE
C
         ZAVE=ZAVE/4/INEL
         ZMSE=ZMSE/4/INEL
         ZRME=SQRT(ZMSE)
C
C-----------------------------------------------------------------------
CL              3.         output summary line
C
C        WRITE(NOUT,9000) NSTEP,REALTN,ZAVE,ZRME,ILMN,IMMN,ZMNE,ILMX,
C    +   IMMX,ZMXE
C9000    FORMAT(' GAUSCK,step ',I5,E10.4,' av=',E10.4,' dev=',E10.4,
C    +   ' min=',2I4,1X,E10.4,' max=',2I4,1X,E10.4)
         DO 300 M=2,3
C        WRITE(NOUT,9006) M
C9006    FORMAT(' GAUSCK, M=',I3)
C        WRITE(NOUT,9007) (L,CD1(L,M),L=1,LMAXP2)
C9007    FORMAT(5(1X,I3,1X,E10.4))
  300    CONTINUE
C
C-----------------------------------------------------------------------
CL              4.         PRINT E-FIELD CHECK
C
         IF(NBCE.EQ.1) THEN
         DO 401 J=1,MMAX
         ZESUM(J)=0.0
         DO 400 I=2,LMAX-1
  400    ZESUM(J)=ZESUM(J)+E2(I,J)
  401    ZESUM(J)=ZESUM(J)/(LMAX-2.0)*SCE2
C        WRITE(NOUT,9001)
C        WRITE(NOUT,9002) (ZESUM(J),J=1,MMAX)
C9001    FORMAT('Averaged E-Field')
C9002    FORMAT(1X,6E14.5)
C
C-----------------------------------------------------------------------
CL              5.         assignment check
C
         CALL SURDEN(Q1,Q2,NP,NG,N1MAX,LINDEX,MINDEX,
     +   NDIRN,NBCTYP,RHOC,NBSEG2)
         CALL SURDMR('RHOC    ',RHOC,LINDEX,MINDEX,NDIRN,NBSEG2)
         CALL QSHARE(CD1,N1MAX,LMAXP2,MMAXP2,
     +               Q1,Q2,NP,C1,C2,CD0,RINNER)
         DO 500 M=1,4
C        WRITE(NOUT,9004) M
C9004    FORMAT(' QSHARE, M=',I3)
C        WRITE(NOUT,9005) (L,CD1(L,M),L=1,LMAXP2)
C9005    FORMAT(5(1X,I3,1X,E10.4))
  500    CONTINUE
C===
         ELSE
         DO 404 J=10,LMAX,10
         DO 403 L=1,MMAX
         ZESUM(L)=0.0
         DO 402 L1=J,J+9
  402    ZESUM(L)=ZESUM(L)+E2(L1,L)
  403    ZESUM(L)=ZESUM(L)*0.1*SCE2
C        WRITE(NOUT,9001)
C        WRITE(NOUT,9003) J
C9003    FORMAT(1X,'J=',I4)
C        WRITE(NOUT,9002) (ZESUM(L),L=1,MMAX)
  404    CONTINUE
         ENDIF
         END
C/ MODULE C3S13
C
         SUBROUTINE ENPWOP
C
C 3.13 Output energy and power values
C
C-----------------------------------------------------------------------
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C       INCLUDE 'COMDDP.inc'
C--------------------------------------------------------------------
CL                  C1.9.    DEVELOPMENT AND DIAGNOSTIC PARAMETERS
       COMMON/COMDDP/
     I   MAXDUM,   MXDUMP,   NADUMP,   NCLASS,   NPDUMP,   NPOINT,
     I   NSUB,     NVDUMP,
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       LOGICAL
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       DIMENSION
     I   NADUMP(20),         NPDUMP(20),         NVDUMP(20),
     L   NLHEAD(9),          NLOMT1(50),         NLOMT2(50),
     L   NLOMT3(50)
C       INCLUDE 'COMCON.inc'
C---------------------------------------------------------------------
CL                  C2.1     Physical Constants
       COMMON/COMCON/
     R   API   ,   BOLTZK,   CLIGHT,   ELCHAG,   ELMASS,   EMU0  ,
     R   EOVERM,   EPS0
C       INCLUDE 'COMSTT.inc'
C---------------------------------------------------------------------
CL                  C2.2     Physical State
       COMMON/COMSTT/
     R   B3    ,   BAV   ,   CD1   ,   CD2   ,   E1    ,   E2    ,
     R   P1    ,   P2    ,   Q1    ,   Q2    ,   REALTN,   TIMRUN
       DIMENSION
     R   B3(605,40),        BAV(605,40),       CD1(605,40),
     R   CD2(605,40),       E1(605,40),        E2(605,40),
     R   P1(20000),          P2(20000),          Q1(20000),
     R   Q2(20000)
C       INCLUDE 'COMDEV.inc'
C---------------------------------------------------------------------
CL                  C2.3     Device description
       COMMON/COMDEV/
     R   B3RHS ,   B3RHSD,   BAPLY ,   BAPLYD,   CAVEAM,   CAVEFR,
     R   CAVIC ,   CAVRES,   CAVTC ,   DEPTH ,   DEVHYT,   DEVLEN,
     R   DEVRAD,   EAPLYD,   EEMIT ,   EEMITD,   ENIT  ,   ENITD ,
     R   GAP   ,   RESAX ,   RESE  ,   RESN  ,   RESS  ,   RESW  ,
     R   RINNER,   SPACE ,   VOLTAG,   WIDTH ,
     I   LCATH ,   LCAV  ,   LLEFT ,   LWVANE,   MDEPTH,   MGAP  ,
     I   NBCAX ,   NBCCAV,   NBCE  ,   NBCN  ,   NBCS  ,   NBCW  ,
     I   NCAV  ,   NDEV
       DIMENSION
     R   CAVEAM(100),        CAVEFR(100),        CAVIC(4,100),
     R   CAVRES(100),        CAVTC(100),
     I   NBCCAV(100)
C       INCLUDE 'COMDIA.inc'
C---------------------------------------------------------------------
CL                  C2.4     Physical Diagnostics
       COMMON/COMDIA/
     R   B3POW ,   BOUT  ,   CAVPOY,   E1POW ,   E2POW ,   EJ1POW,
     R   EJ2POW,   EJENP ,   EJPOWM,   EJPOWP,   EJPWPN,   EKFLXI,
     R   EKFLXO,   ENEJ1 ,   ENEJ2 ,   ENEL1 ,   ENEL1O,   ENEL2 ,
     R   ENEL2O,   ENKIN ,   ENKINO,   ENMAG ,   ENMAGO,   ENPOYT,
     R   ENTOT ,   ENTOTO,   EOUT  ,   TOTM1 ,   TOTM2 ,   TPOYP ,
     I   LCAVEN,   LCAVST,   NPNEW ,   NPOLD
       DIMENSION
     R   BOUT(100),          CAVPOY(100),        EOUT(100),
     I   LCAVEN(100),        LCAVST(100)
C       INCLUDE 'COMNUM.inc'
C---------------------------------------------------------------------
CL                  C3.1     Numerical Parameters
       COMMON/COMNUM/
     R   C1    ,   C2    ,   CD0   ,   CURANT,   DT    ,   DX1   ,
     R   DX1DX2,   DX1OX2,   DX2   ,   DX2OX1,   ELPERP,   HLFDX1,
     R   HLFDX2,   TCACO ,
     I   LMAX  ,   LMAXP ,   LMAXP2,   MMAX  ,   MMAXP ,   MMAXP2,
     I   NEMIT ,   NP
C       INCLUDE 'COMSCA.inc'
C---------------------------------------------------------------------
CL                  C3.2     Scaling Factors
       COMMON/COMSCA/
     R   SCB3  ,   SCE1  ,   SCE2  ,   SCEMEN,   SCEPOW,   SCI1  ,
     R   SCI2  ,   SCIP  ,   SCKE  ,   SCKPOW,   SCP1  ,   SCP2  ,
     R   SCV1  ,   SCV2  ,   SCX1  ,   SCX2
C       INCLUDE 'COMHOK.inc'
C---------------------------------------------------------------------
CL                  C4.1     Housekeeping
       COMMON/COMHOK/
     R   TIMECP,   XPSMAX,   XPSMIN,   YPSMAX,   YPSMIN,
     I   N1MAX ,   N2MAX ,   NCASE ,   NGMAX ,   NOSEP ,   NPDUM ,
     I   NPMAX ,   NSRC  ,   NXDUM ,   NYDUM
       DIMENSION
     R   TIMECP(32)
C       INCLUDE 'COMGEO.inc'
C---------------------------------------------------------------------
CL                  C4.2     Device boundary data
       COMMON/COMGEO/
     R   ASCUR ,   CCTSRC,   EBEXT ,   ELSCUR,   ENSUR ,   EPOYNT,
     R   RHOC  ,   SURCHG,   SURIC ,
     I   LINDEX,   MINDEX,   NBCTYP,   NBDIM ,   NBSEG2,   NCOLOR,
     I   NDIRN ,   NG
       DIMENSION
     R   ASCUR(1500),        CCTSRC(1500),       EBEXT(2,1500),
     R   ELSCUR(1500),       ENSUR(1500),        EPOYNT(1500),
     R   RHOC(1500),         SURCHG(1500),       SURIC(4,1500),
     I   LINDEX(1500),       MINDEX(1500),       NBCTYP(1500),
     I   NCOLOR(1500),       NDIRN(1500),        NG(605,40)
C       INCLUDE 'COMOUT.inc'
C---------------------------------------------------------------------
CL                  C5.1     Output Variables
       COMMON/COMOUT/
     R   BCNMAX,   BCNMIN,   BCVMAX,   BCVMIN,   CUAMAX,   CUAMIN,
     R   CUEMAX,   CUEMIN,   ECVMAX,   ECVMIN,   TONS1 ,   TONS2 ,
     R   TONS3 ,   TONS4 ,   TONS5 ,   TONS6 ,   TONS7 ,
     I   NBCHT ,   NOPSEL,   NS1   ,   NS2   ,   NS3   ,   NS4   ,
     I   NS5   ,   NS6   ,   NS7
C-----------------------------------------------------------------------
         DATA        ICLASS,   ISUB/3,   13/
                                       CALL EXPERT(ICLASS,ISUB,1)
         IF(NLOMT3(ISUB)) RETURN
C
C-----------------------------------------------------------------------
CL              1.         normalise values
C
C
CL                  1.1      energies
         ZEE1=ENEL1*SCEMEN
         ZEE2=ENEL2*SCEMEN
         ZEEN=ZEE1+ZEE2
         ZEB3=ENMAG*SCEMEN
C
         ZENTOT=ENTOT*SCEMEN
         ZENPOY=ENPOYT*SCEMEN
         ZENEJ1=ENEJ1*SCEMEN
         ZENEJ2=ENEJ2*SCEMEN
         ZENEJ =ZENEJ1+ZENEJ2
C
CL                  1.2      powers
         ZE1POW=E1POW*SCEPOW*1.0E-9
         ZE2POW=E2POW*SCEPOW*1.0E-9
         ZEPOW =ZE1POW+ZE2POW
         ZB3POW=B3POW*SCEPOW*1.0E-9
         ZJE1P=EJ1POW*SCEPOW*1.0E-9
         ZJE2P=EJ2POW*SCEPOW*1.0E-9
         ZJEP =ZJE1P+ZJE2P
         ZPOYP=TPOYP*SCEPOW*1.0E-9
         ZPOWT=ZE1POW+ZE2POW+ZB3POW+ZJE1P+ZJE2P
C
C-----------------------------------------------------------------------
CL              2.         output values
C
C        WRITE(NOUT,9000)NSTEP,REALTN,ZPOYP,ZJEP,ZEPOW,ZB3POW,
C    +   ZPOWT,ZEEN,ZEB3,ZENTOT
C9000    FORMAT(' ENPWOP, step=',I5,1X,G10.4,
C    +   ' GW=',5(1X,G10.4),' Joules=',3(1X,G10.4))
C-----------------------------------------------------------------------
         END
C/ MODULE C3S21
C
         SUBROUTINE ENPWPP
C
C 3.21 Output particle energy and power values
C
C-----------------------------------------------------------------------
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C       INCLUDE 'COMDDP.inc'
C--------------------------------------------------------------------
CL                  C1.9.    DEVELOPMENT AND DIAGNOSTIC PARAMETERS
       COMMON/COMDDP/
     I   MAXDUM,   MXDUMP,   NADUMP,   NCLASS,   NPDUMP,   NPOINT,
     I   NSUB,     NVDUMP,
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       LOGICAL
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       DIMENSION
     I   NADUMP(20),         NPDUMP(20),         NVDUMP(20),
     L   NLHEAD(9),          NLOMT1(50),         NLOMT2(50),
     L   NLOMT3(50)
C       INCLUDE 'COMCON.inc'
C---------------------------------------------------------------------
CL                  C2.1     Physical Constants
       COMMON/COMCON/
     R   API   ,   BOLTZK,   CLIGHT,   ELCHAG,   ELMASS,   EMU0  ,
     R   EOVERM,   EPS0
C       INCLUDE 'COMSTT.inc'
C---------------------------------------------------------------------
CL                  C2.2     Physical State
       COMMON/COMSTT/
     R   B3    ,   BAV   ,   CD1   ,   CD2   ,   E1    ,   E2    ,
     R   P1    ,   P2    ,   Q1    ,   Q2    ,   REALTN,   TIMRUN
       DIMENSION
     R   B3(605,40),        BAV(605,40),       CD1(605,40),
     R   CD2(605,40),       E1(605,40),        E2(605,40),
     R   P1(20000),          P2(20000),          Q1(20000),
     R   Q2(20000)
C       INCLUDE 'COMDEV.inc'
C---------------------------------------------------------------------
CL                  C2.3     Device description
       COMMON/COMDEV/
     R   B3RHS ,   B3RHSD,   BAPLY ,   BAPLYD,   CAVEAM,   CAVEFR,
     R   CAVIC ,   CAVRES,   CAVTC ,   DEPTH ,   DEVHYT,   DEVLEN,
     R   DEVRAD,   EAPLYD,   EEMIT ,   EEMITD,   ENIT  ,   ENITD ,
     R   GAP   ,   RESAX ,   RESE  ,   RESN  ,   RESS  ,   RESW  ,
     R   RINNER,   SPACE ,   VOLTAG,   WIDTH ,
     I   LCATH ,   LCAV  ,   LLEFT ,   LWVANE,   MDEPTH,   MGAP  ,
     I   NBCAX ,   NBCCAV,   NBCE  ,   NBCN  ,   NBCS  ,   NBCW  ,
     I   NCAV  ,   NDEV
       DIMENSION
     R   CAVEAM(100),        CAVEFR(100),        CAVIC(4,100),
     R   CAVRES(100),        CAVTC(100),
     I   NBCCAV(100)
C       INCLUDE 'COMDIA.inc'
C---------------------------------------------------------------------
CL                  C2.4     Physical Diagnostics
       COMMON/COMDIA/
     R   B3POW ,   BOUT  ,   CAVPOY,   E1POW ,   E2POW ,   EJ1POW,
     R   EJ2POW,   EJENP ,   EJPOWM,   EJPOWP,   EJPWPN,   EKFLXI,
     R   EKFLXO,   ENEJ1 ,   ENEJ2 ,   ENEL1 ,   ENEL1O,   ENEL2 ,
     R   ENEL2O,   ENKIN ,   ENKINO,   ENMAG ,   ENMAGO,   ENPOYT,
     R   ENTOT ,   ENTOTO,   EOUT  ,   TOTM1 ,   TOTM2 ,   TPOYP ,
     I   LCAVEN,   LCAVST,   NPNEW ,   NPOLD
       DIMENSION
     R   BOUT(100),          CAVPOY(100),        EOUT(100),
     I   LCAVEN(100),        LCAVST(100)
C       INCLUDE 'COMNUM.inc'
C---------------------------------------------------------------------
CL                  C3.1     Numerical Parameters
       COMMON/COMNUM/
     R   C1    ,   C2    ,   CD0   ,   CURANT,   DT    ,   DX1   ,
     R   DX1DX2,   DX1OX2,   DX2   ,   DX2OX1,   ELPERP,   HLFDX1,
     R   HLFDX2,   TCACO ,
     I   LMAX  ,   LMAXP ,   LMAXP2,   MMAX  ,   MMAXP ,   MMAXP2,
     I   NEMIT ,   NP
C       INCLUDE 'COMSCA.inc'
C---------------------------------------------------------------------
CL                  C3.2     Scaling Factors
       COMMON/COMSCA/
     R   SCB3  ,   SCE1  ,   SCE2  ,   SCEMEN,   SCEPOW,   SCI1  ,
     R   SCI2  ,   SCIP  ,   SCKE  ,   SCKPOW,   SCP1  ,   SCP2  ,
     R   SCV1  ,   SCV2  ,   SCX1  ,   SCX2
C       INCLUDE 'COMHOK.inc'
C---------------------------------------------------------------------
CL                  C4.1     Housekeeping
       COMMON/COMHOK/
     R   TIMECP,   XPSMAX,   XPSMIN,   YPSMAX,   YPSMIN,
     I   N1MAX ,   N2MAX ,   NCASE ,   NGMAX ,   NOSEP ,   NPDUM ,
     I   NPMAX ,   NSRC  ,   NXDUM ,   NYDUM
       DIMENSION
     R   TIMECP(32)
C       INCLUDE 'COMGEO.inc'
C---------------------------------------------------------------------
CL                  C4.2     Device boundary data
       COMMON/COMGEO/
     R   ASCUR ,   CCTSRC,   EBEXT ,   ELSCUR,   ENSUR ,   EPOYNT,
     R   RHOC  ,   SURCHG,   SURIC ,
     I   LINDEX,   MINDEX,   NBCTYP,   NBDIM ,   NBSEG2,   NCOLOR,
     I   NDIRN ,   NG
       DIMENSION
     R   ASCUR(1500),        CCTSRC(1500),       EBEXT(2,1500),
     R   ELSCUR(1500),       ENSUR(1500),        EPOYNT(1500),
     R   RHOC(1500),         SURCHG(1500),       SURIC(4,1500),
     I   LINDEX(1500),       MINDEX(1500),       NBCTYP(1500),
     I   NCOLOR(1500),       NDIRN(1500),        NG(605,40)
C       INCLUDE 'COMOUT.inc'
C---------------------------------------------------------------------
CL                  C5.1     Output Variables
       COMMON/COMOUT/
     R   BCNMAX,   BCNMIN,   BCVMAX,   BCVMIN,   CUAMAX,   CUAMIN,
     R   CUEMAX,   CUEMIN,   ECVMAX,   ECVMIN,   TONS1 ,   TONS2 ,
     R   TONS3 ,   TONS4 ,   TONS5 ,   TONS6 ,   TONS7 ,
     I   NBCHT ,   NOPSEL,   NS1   ,   NS2   ,   NS3   ,   NS4   ,
     I   NS5   ,   NS6   ,   NS7
C-----------------------------------------------------------------------
         DATA        ICLASS,   ISUB/3,   21/
                                       CALL EXPERT(ICLASS,ISUB,1)
         IF(NLOMT3(ISUB)) RETURN
C
C-----------------------------------------------------------------------
CL              1.         normalise values
C
C
CL                  1.1      energies
         ZKEOLD=ENKINO*SCKE
         ZKENEW=ENKIN*SCKE
         ZKEOUT=EKFLUX*SCKE
         ZEJEN =EJENP*SCKE
C
CL                  1.2      powers
         ZKEPOW=EKFLUX*SCKPOW*1.0E-9
         ZJEP =EJPOWP*SCKPOW*1.0E-9
         ZPOWT=(ENKIN+EKFLXO-ENKINO-EJPOWP)*SCKPOW*1.0E-9
C
C-----------------------------------------------------------------------
CL              2.         output values
C
C        WRITE(NOUT,9000)NSTEP,REALTN,ZKEPOW,ZJEP,ZPOWT,ZKENEW,
C    +   ZKEOUT,ZEJEN
C9000    FORMAT(' ENPWPP, step=',I5,1X,G10.4,
C    +   ' GW=',3(1X,G10.4),' Joules=',3(1X,G10.4))
C-----------------------------------------------------------------------
         END
C/ MODULE C3S12
C
         SUBROUTINE CURROP
C
C 3.10 Output currents at selected points
C
C .    assumes data is as set by <1.14>SETLO
C
C-----------------------------------------------------------------------
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C       INCLUDE 'COMDDP.inc'
C--------------------------------------------------------------------
CL                  C1.9.    DEVELOPMENT AND DIAGNOSTIC PARAMETERS
       COMMON/COMDDP/
     I   MAXDUM,   MXDUMP,   NADUMP,   NCLASS,   NPDUMP,   NPOINT,
     I   NSUB,     NVDUMP,
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       LOGICAL
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       DIMENSION
     I   NADUMP(20),         NPDUMP(20),         NVDUMP(20),
     L   NLHEAD(9),          NLOMT1(50),         NLOMT2(50),
     L   NLOMT3(50)
C       INCLUDE 'COMCON.inc'
C---------------------------------------------------------------------
CL                  C2.1     Physical Constants
       COMMON/COMCON/
     R   API   ,   BOLTZK,   CLIGHT,   ELCHAG,   ELMASS,   EMU0  ,
     R   EOVERM,   EPS0
C       INCLUDE 'COMSTT.inc'
C---------------------------------------------------------------------
CL                  C2.2     Physical State
       COMMON/COMSTT/
     R   B3    ,   BAV   ,   CD1   ,   CD2   ,   E1    ,   E2    ,
     R   P1    ,   P2    ,   Q1    ,   Q2    ,   REALTN,   TIMRUN
       DIMENSION
     R   B3(605,40),        BAV(605,40),       CD1(605,40),
     R   CD2(605,40),       E1(605,40),        E2(605,40),
     R   P1(20000),          P2(20000),          Q1(20000),
     R   Q2(20000)
C       INCLUDE 'COMDEV.inc'
C---------------------------------------------------------------------
CL                  C2.3     Device description
       COMMON/COMDEV/
     R   B3RHS ,   B3RHSD,   BAPLY ,   BAPLYD,   CAVEAM,   CAVEFR,
     R   CAVIC ,   CAVRES,   CAVTC ,   DEPTH ,   DEVHYT,   DEVLEN,
     R   DEVRAD,   EAPLYD,   EEMIT ,   EEMITD,   ENIT  ,   ENITD ,
     R   GAP   ,   RESAX ,   RESE  ,   RESN  ,   RESS  ,   RESW  ,
     R   RINNER,   SPACE ,   VOLTAG,   WIDTH ,
     I   LCATH ,   LCAV  ,   LLEFT ,   LWVANE,   MDEPTH,   MGAP  ,
     I   NBCAX ,   NBCCAV,   NBCE  ,   NBCN  ,   NBCS  ,   NBCW  ,
     I   NCAV  ,   NDEV
       DIMENSION
     R   CAVEAM(100),        CAVEFR(100),        CAVIC(4,100),
     R   CAVRES(100),        CAVTC(100),
     I   NBCCAV(100)
C       INCLUDE 'COMDIA.inc'
C---------------------------------------------------------------------
CL                  C2.4     Physical Diagnostics
       COMMON/COMDIA/
     R   B3POW ,   BOUT  ,   CAVPOY,   E1POW ,   E2POW ,   EJ1POW,
     R   EJ2POW,   EJENP ,   EJPOWM,   EJPOWP,   EJPWPN,   EKFLXI,
     R   EKFLXO,   ENEJ1 ,   ENEJ2 ,   ENEL1 ,   ENEL1O,   ENEL2 ,
     R   ENEL2O,   ENKIN ,   ENKINO,   ENMAG ,   ENMAGO,   ENPOYT,
     R   ENTOT ,   ENTOTO,   EOUT  ,   TOTM1 ,   TOTM2 ,   TPOYP ,
     I   LCAVEN,   LCAVST,   NPNEW ,   NPOLD
       DIMENSION
     R   BOUT(100),          CAVPOY(100),        EOUT(100),
     I   LCAVEN(100),        LCAVST(100)
C       INCLUDE 'COMNUM.inc'
C---------------------------------------------------------------------
CL                  C3.1     Numerical Parameters
       COMMON/COMNUM/
     R   C1    ,   C2    ,   CD0   ,   CURANT,   DT    ,   DX1   ,
     R   DX1DX2,   DX1OX2,   DX2   ,   DX2OX1,   ELPERP,   HLFDX1,
     R   HLFDX2,   TCACO ,
     I   LMAX  ,   LMAXP ,   LMAXP2,   MMAX  ,   MMAXP ,   MMAXP2,
     I   NEMIT ,   NP
C       INCLUDE 'COMSCA.inc'
C---------------------------------------------------------------------
CL                  C3.2     Scaling Factors
       COMMON/COMSCA/
     R   SCB3  ,   SCE1  ,   SCE2  ,   SCEMEN,   SCEPOW,   SCI1  ,
     R   SCI2  ,   SCIP  ,   SCKE  ,   SCKPOW,   SCP1  ,   SCP2  ,
     R   SCV1  ,   SCV2  ,   SCX1  ,   SCX2
C       INCLUDE 'COMHOK.inc'
C---------------------------------------------------------------------
CL                  C4.1     Housekeeping
       COMMON/COMHOK/
     R   TIMECP,   XPSMAX,   XPSMIN,   YPSMAX,   YPSMIN,
     I   N1MAX ,   N2MAX ,   NCASE ,   NGMAX ,   NOSEP ,   NPDUM ,
     I   NPMAX ,   NSRC  ,   NXDUM ,   NYDUM
       DIMENSION
     R   TIMECP(32)
C       INCLUDE 'COMGEO.inc'
C---------------------------------------------------------------------
CL                  C4.2     Device boundary data
       COMMON/COMGEO/
     R   ASCUR ,   CCTSRC,   EBEXT ,   ELSCUR,   ENSUR ,   EPOYNT,
     R   RHOC  ,   SURCHG,   SURIC ,
     I   LINDEX,   MINDEX,   NBCTYP,   NBDIM ,   NBSEG2,   NCOLOR,
     I   NDIRN ,   NG
       DIMENSION
     R   ASCUR(1500),        CCTSRC(1500),       EBEXT(2,1500),
     R   ELSCUR(1500),       ENSUR(1500),        EPOYNT(1500),
     R   RHOC(1500),         SURCHG(1500),       SURIC(4,1500),
     I   LINDEX(1500),       MINDEX(1500),       NBCTYP(1500),
     I   NCOLOR(1500),       NDIRN(1500),        NG(605,40)
C       INCLUDE 'COMOUT.inc'
C---------------------------------------------------------------------
CL                  C5.1     Output Variables
       COMMON/COMOUT/
     R   BCNMAX,   BCNMIN,   BCVMAX,   BCVMIN,   CUAMAX,   CUAMIN,
     R   CUEMAX,   CUEMIN,   ECVMAX,   ECVMIN,   TONS1 ,   TONS2 ,
     R   TONS3 ,   TONS4 ,   TONS5 ,   TONS6 ,   TONS7 ,
     I   NBCHT ,   NOPSEL,   NS1   ,   NS2   ,   NS3   ,   NS4   ,
     I   NS5   ,   NS6   ,   NS7
         DIMENSION   ZCUR(8),IM(8),IL(8)
C-----------------------------------------------------------------------
         DATA        ICLASS,   ISUB/3,   12/
                                       CALL EXPERT(ICLASS,ISUB,1)
         IF(NLOMT3(ISUB)) RETURN
C
C-----------------------------------------------------------------------
CL              1.         specify spot currents
C
         IRIGHT=LMAX-1-NCAV*(LCAV+LWVANE)-LLEFT
         IMCATH=MMAX-MGAP-MDEPTH-1
C     entrance line anode current
         IL(1)=2
         IM(1)=MMAX-MDEPTH+1
C     end of cavity structure
         IL(2)=LMAX-IRIGHT
         IM(2)=IM(1)
C     rh top corner of anode
         IL(3)=LMAX+1
         IM(3)=IM(2)
C     diode end axis
         IL(4)=IL(3)
         IM(4)=3
C     cathode corner
         IL(5)=LCATH+2
         IM(5)=IMCATH+2
C     cathode entrance line
         IL(6)=3
         IM(6)=IM(5)
C     elements 7 and 8 are for integrate particle currents
         DO 100 I1=1,NBSEG2
         DO 100 I2=1,6
         IF(LINDEX(I1).EQ.IL(I2).AND.
     +   MINDEX(I1).EQ.IM(I2)) ZCUR(I2)=ASCUR(I1)*SCI1/1000.
  100    CONTINUE
C
C-----------------------------------------------------------------------
CL              2.         specify particle currents
C
C     along diode end
         ZCEND = 0.0
         IMST = 2
         IMEN = MMAXP-MDEPTH-1
         DO 200 JM = IMST,IMEN
         ZCEND=ZCEND+CD1(LMAX,JM)
  200    CONTINUE
         ZCUR(7) = ZCEND*SCI1/1000.
C     along exit line
         ZCEXIT = 0.0
         ILST = LLEFT+NCAV*(LCAV+LWVANE)
         ILEN = LMAX
         DO 201 JL = ILST,ILEN
         ZCEXIT=ZCEXIT+CD2(JL,IMEN)
  201    CONTINUE
         ZCUR(8)=ZCEXIT*SCI2/1000.
C
C-----------------------------------------------------------------------
CL              3.         output currents
C
C        WRITE(NOUT,9000)NSTEP,REALTN,(ZCUR(J),J=1,8)
C9000    FORMAT(' CURRENTS, step=',I5,1X,G10.4,
C    +   ' kA=',8(1X,G10.4))
         IF(NCASE.NE.3) RETURN
C-----------------------------------------------------------------------
C          4.       WRITE E-FIELD AT DIODE END
C
         DO 400 L=3,MMAX-MGAP-9,5
C        WRITE(NOUT,9001) L
C9001    FORMAT('L=',I3)
C        WRITE(NOUT,9002) (E1(J,L),J=LCATH,LMAX)
C9002    FORMAT(9E13.7)
 400     CONTINUE
C----------------------------------------------------------------------
         END
C/ MODULE C3S10
C
         SUBROUTINE CURBOD(K)
C
C 3.10 Output time history of boundary current
C
C-----------------------------------------------------------------------
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C       INCLUDE 'COMDDP.inc'
C--------------------------------------------------------------------
CL                  C1.9.    DEVELOPMENT AND DIAGNOSTIC PARAMETERS
       COMMON/COMDDP/
     I   MAXDUM,   MXDUMP,   NADUMP,   NCLASS,   NPDUMP,   NPOINT,
     I   NSUB,     NVDUMP,
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       LOGICAL
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       DIMENSION
     I   NADUMP(20),         NPDUMP(20),         NVDUMP(20),
     L   NLHEAD(9),          NLOMT1(50),         NLOMT2(50),
     L   NLOMT3(50)
C       INCLUDE 'COMCON.inc'
C---------------------------------------------------------------------
CL                  C2.1     Physical Constants
       COMMON/COMCON/
     R   API   ,   BOLTZK,   CLIGHT,   ELCHAG,   ELMASS,   EMU0  ,
     R   EOVERM,   EPS0
C       INCLUDE 'COMSTT.inc'
C---------------------------------------------------------------------
CL                  C2.2     Physical State
       COMMON/COMSTT/
     R   B3    ,   BAV   ,   CD1   ,   CD2   ,   E1    ,   E2    ,
     R   P1    ,   P2    ,   Q1    ,   Q2    ,   REALTN,   TIMRUN
       DIMENSION
     R   B3(605,40),        BAV(605,40),       CD1(605,40),
     R   CD2(605,40),       E1(605,40),        E2(605,40),
     R   P1(20000),          P2(20000),          Q1(20000),
     R   Q2(20000)
C       INCLUDE 'COMDEV.inc'
C---------------------------------------------------------------------
CL                  C2.3     Device description
       COMMON/COMDEV/
     R   B3RHS ,   B3RHSD,   BAPLY ,   BAPLYD,   CAVEAM,   CAVEFR,
     R   CAVIC ,   CAVRES,   CAVTC ,   DEPTH ,   DEVHYT,   DEVLEN,
     R   DEVRAD,   EAPLYD,   EEMIT ,   EEMITD,   ENIT  ,   ENITD ,
     R   GAP   ,   RESAX ,   RESE  ,   RESN  ,   RESS  ,   RESW  ,
     R   RINNER,   SPACE ,   VOLTAG,   WIDTH ,
     I   LCATH ,   LCAV  ,   LLEFT ,   LWVANE,   MDEPTH,   MGAP  ,
     I   NBCAX ,   NBCCAV,   NBCE  ,   NBCN  ,   NBCS  ,   NBCW  ,
     I   NCAV  ,   NDEV
       DIMENSION
     R   CAVEAM(100),        CAVEFR(100),        CAVIC(4,100),
     R   CAVRES(100),        CAVTC(100),
     I   NBCCAV(100)
C       INCLUDE 'COMDIA.inc'
C---------------------------------------------------------------------
CL                  C2.4     Physical Diagnostics
       COMMON/COMDIA/
     R   B3POW ,   BOUT  ,   CAVPOY,   E1POW ,   E2POW ,   EJ1POW,
     R   EJ2POW,   EJENP ,   EJPOWM,   EJPOWP,   EJPWPN,   EKFLXI,
     R   EKFLXO,   ENEJ1 ,   ENEJ2 ,   ENEL1 ,   ENEL1O,   ENEL2 ,
     R   ENEL2O,   ENKIN ,   ENKINO,   ENMAG ,   ENMAGO,   ENPOYT,
     R   ENTOT ,   ENTOTO,   EOUT  ,   TOTM1 ,   TOTM2 ,   TPOYP ,
     I   LCAVEN,   LCAVST,   NPNEW ,   NPOLD
       DIMENSION
     R   BOUT(100),          CAVPOY(100),        EOUT(100),
     I   LCAVEN(100),        LCAVST(100)
C       INCLUDE 'COMNUM.inc'
C---------------------------------------------------------------------
CL                  C3.1     Numerical Parameters
       COMMON/COMNUM/
     R   C1    ,   C2    ,   CD0   ,   CURANT,   DT    ,   DX1   ,
     R   DX1DX2,   DX1OX2,   DX2   ,   DX2OX1,   ELPERP,   HLFDX1,
     R   HLFDX2,   TCACO ,
     I   LMAX  ,   LMAXP ,   LMAXP2,   MMAX  ,   MMAXP ,   MMAXP2,
     I   NEMIT ,   NP
C       INCLUDE 'COMSCA.inc'
C---------------------------------------------------------------------
CL                  C3.2     Scaling Factors
       COMMON/COMSCA/
     R   SCB3  ,   SCE1  ,   SCE2  ,   SCEMEN,   SCEPOW,   SCI1  ,
     R   SCI2  ,   SCIP  ,   SCKE  ,   SCKPOW,   SCP1  ,   SCP2  ,
     R   SCV1  ,   SCV2  ,   SCX1  ,   SCX2
C       INCLUDE 'COMHOK.inc'
C---------------------------------------------------------------------
CL                  C4.1     Housekeeping
       COMMON/COMHOK/
     R   TIMECP,   XPSMAX,   XPSMIN,   YPSMAX,   YPSMIN,
     I   N1MAX ,   N2MAX ,   NCASE ,   NGMAX ,   NOSEP ,   NPDUM ,
     I   NPMAX ,   NSRC  ,   NXDUM ,   NYDUM
       DIMENSION
     R   TIMECP(32)
C       INCLUDE 'COMGEO.inc'
C---------------------------------------------------------------------
CL                  C4.2     Device boundary data
       COMMON/COMGEO/
     R   ASCUR ,   CCTSRC,   EBEXT ,   ELSCUR,   ENSUR ,   EPOYNT,
     R   RHOC  ,   SURCHG,   SURIC ,
     I   LINDEX,   MINDEX,   NBCTYP,   NBDIM ,   NBSEG2,   NCOLOR,
     I   NDIRN ,   NG
       DIMENSION
     R   ASCUR(1500),        CCTSRC(1500),       EBEXT(2,1500),
     R   ELSCUR(1500),       ENSUR(1500),        EPOYNT(1500),
     R   RHOC(1500),         SURCHG(1500),       SURIC(4,1500),
     I   LINDEX(1500),       MINDEX(1500),       NBCTYP(1500),
     I   NCOLOR(1500),       NDIRN(1500),        NG(605,40)
C       INCLUDE 'COMOUT.inc'
C---------------------------------------------------------------------
CL                  C5.1     Output Variables
       COMMON/COMOUT/
     R   BCNMAX,   BCNMIN,   BCVMAX,   BCVMIN,   CUAMAX,   CUAMIN,
     R   CUEMAX,   CUEMIN,   ECVMAX,   ECVMIN,   TONS1 ,   TONS2 ,
     R   TONS3 ,   TONS4 ,   TONS5 ,   TONS6 ,   TONS7 ,
     I   NBCHT ,   NOPSEL,   NS1   ,   NS2   ,   NS3   ,   NS4   ,
     I   NS5   ,   NS6   ,   NS7
         DIMENSION   ZCUR(8),IM(8),IL(8)
C-----------------------------------------------------------------------
         DATA        ICLASS,   ISUB/3,   10/
                                       CALL EXPERT(ICLASS,ISUB,1)
         IF(NLOMT3(ISUB)) RETURN
C-----------------------------------------------------------------------
         GO TO (100,200,300),K
C
C-----------------------------------------------------------------------
CL              1.         Initialisation
C
  100    CONTINUE
C     set up output file on NPUNCH
C        OPEN(UNIT=NREC,FILE=CHLB10,FORM='UNFORMATTED')
C     write in header information to channel NPUNCH
         KCHAN = NREC
C        WRITE(KCHAN) NBSEG2,LMAXP2,MMAXP2
C        WRITE(KCHAN) (LINDEX(J),MINDEX(J),NCOLOR(J),J=1,NBSEG2)
C
         RETURN
C
C-----------------------------------------------------------------------
CL              2.         Periodic Output
C
  200    CONTINUE
C
CL                  2.1      specify spot currents
         IRIGHT=LMAX-1-NCAV*(LCAV+LWVANE)-LLEFT+LWVANE
         IMCATH=MMAX-MGAP-MDEPTH-1
C     entrance line anode current
         IL(1)=2
         IM(1)=MMAX-MDEPTH+1
C     end of cavity structure
         IL(2)=LMAXP-IRIGHT
         IM(2)=IM(1)
C     rh top corner of anode
         IL(3)=LMAX+1
         IM(3)=IM(2)
C     cathode corner
         IL(4)=LCATH+2
         IM(4)=IMCATH+2
C     cathode entrance line
         IL(5)=3
         IM(5)=IM(4)
C     elements 6,7 and 8 are for integrate particle currents
         DO 210 I1=1,NBSEG2
         DO 210 I2=1,5
         IF(LINDEX(I1).EQ.IL(I2).AND.
     +   MINDEX(I1).EQ.IM(I2)) ZCUR(I2)=ASCUR(I1)*SCI1/1000.
  210    CONTINUE
C
CL                  2.2      specify particle currents
C     along diode end
         ZCEND = 0.0
         IMST = 2
         IMEN = MMAXP-MDEPTH-1
         DO 220 JM = IMST,IMEN
         ZCEND=ZCEND+CD1(LMAX,JM)
  220    CONTINUE
         ZCUR(7) = ZCEND*SCI1/1000.
C     along exit line
         ZCEXIT = 0.0
         ILST = LMAX-IRIGHT
         ILEN = LMAX
         IF(IRIGHT.GT.0) THEN
         DO 221 JL = ILST,ILEN
         ZCEXIT=ZCEXIT+CD2(JL,IMEN)
  221    CONTINUE
         ELSE
         ZCEXIT=0.0
         END IF
         ZCUR(8)=ZCEXIT*SCI2/1000.
C     along anode bottom
         ZCTOP  = 0.0
         ILST = 3
         ILEN = LMAX
         DO 222 JL = ILST,ILEN
         ZCTOP =ZCTOP+CD2(JL,IMEN)
  222    CONTINUE
         ZCUR(6)=ZCTOP *SCI2/1000.
C
CL                  2.3      output currents
                 KCHAN=NREC
C        WRITE(KCHAN) REALTN,(ZCUR(L),L=1,8)
         RETURN
C
C-----------------------------------------------------------------------
CL              3.         Closedown
C
  300    CONTINUE
C       CLOSE(UNIT=NREC)
C-----------------------------------------------------------------------
         END
C/ MODULE C3S8
C
         SUBROUTINE ENPOW(K)
C
C 3.8  Output time history of energy and power totals
C
C-----------------------------------------------------------------------
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C       INCLUDE 'COMDDP.inc'
C--------------------------------------------------------------------
CL                  C1.9.    DEVELOPMENT AND DIAGNOSTIC PARAMETERS
       COMMON/COMDDP/
     I   MAXDUM,   MXDUMP,   NADUMP,   NCLASS,   NPDUMP,   NPOINT,
     I   NSUB,     NVDUMP,
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       LOGICAL
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       DIMENSION
     I   NADUMP(20),         NPDUMP(20),         NVDUMP(20),
     L   NLHEAD(9),          NLOMT1(50),         NLOMT2(50),
     L   NLOMT3(50)
C       INCLUDE 'COMCON.inc'
C---------------------------------------------------------------------
CL                  C2.1     Physical Constants
       COMMON/COMCON/
     R   API   ,   BOLTZK,   CLIGHT,   ELCHAG,   ELMASS,   EMU0  ,
     R   EOVERM,   EPS0
C       INCLUDE 'COMSTT.inc'
C---------------------------------------------------------------------
CL                  C2.2     Physical State
       COMMON/COMSTT/
     R   B3    ,   BAV   ,   CD1   ,   CD2   ,   E1    ,   E2    ,
     R   P1    ,   P2    ,   Q1    ,   Q2    ,   REALTN,   TIMRUN
       DIMENSION
     R   B3(605,40),        BAV(605,40),       CD1(605,40),
     R   CD2(605,40),       E1(605,40),        E2(605,40),
     R   P1(20000),          P2(20000),          Q1(20000),
     R   Q2(20000)
C       INCLUDE 'COMDEV.inc'
C---------------------------------------------------------------------
CL                  C2.3     Device description
       COMMON/COMDEV/
     R   B3RHS ,   B3RHSD,   BAPLY ,   BAPLYD,   CAVEAM,   CAVEFR,
     R   CAVIC ,   CAVRES,   CAVTC ,   DEPTH ,   DEVHYT,   DEVLEN,
     R   DEVRAD,   EAPLYD,   EEMIT ,   EEMITD,   ENIT  ,   ENITD ,
     R   GAP   ,   RESAX ,   RESE  ,   RESN  ,   RESS  ,   RESW  ,
     R   RINNER,   SPACE ,   VOLTAG,   WIDTH ,
     I   LCATH ,   LCAV  ,   LLEFT ,   LWVANE,   MDEPTH,   MGAP  ,
     I   NBCAX ,   NBCCAV,   NBCE  ,   NBCN  ,   NBCS  ,   NBCW  ,
     I   NCAV  ,   NDEV
       DIMENSION
     R   CAVEAM(100),        CAVEFR(100),        CAVIC(4,100),
     R   CAVRES(100),        CAVTC(100),
     I   NBCCAV(100)
C       INCLUDE 'COMDIA.inc'
C---------------------------------------------------------------------
CL                  C2.4     Physical Diagnostics
       COMMON/COMDIA/
     R   B3POW ,   BOUT  ,   CAVPOY,   E1POW ,   E2POW ,   EJ1POW,
     R   EJ2POW,   EJENP ,   EJPOWM,   EJPOWP,   EJPWPN,   EKFLXI,
     R   EKFLXO,   ENEJ1 ,   ENEJ2 ,   ENEL1 ,   ENEL1O,   ENEL2 ,
     R   ENEL2O,   ENKIN ,   ENKINO,   ENMAG ,   ENMAGO,   ENPOYT,
     R   ENTOT ,   ENTOTO,   EOUT  ,   TOTM1 ,   TOTM2 ,   TPOYP ,
     I   LCAVEN,   LCAVST,   NPNEW ,   NPOLD
       DIMENSION
     R   BOUT(100),          CAVPOY(100),        EOUT(100),
     I   LCAVEN(100),        LCAVST(100)
C       INCLUDE 'COMNUM.inc'
C---------------------------------------------------------------------
CL                  C3.1     Numerical Parameters
       COMMON/COMNUM/
     R   C1    ,   C2    ,   CD0   ,   CURANT,   DT    ,   DX1   ,
     R   DX1DX2,   DX1OX2,   DX2   ,   DX2OX1,   ELPERP,   HLFDX1,
     R   HLFDX2,   TCACO ,
     I   LMAX  ,   LMAXP ,   LMAXP2,   MMAX  ,   MMAXP ,   MMAXP2,
     I   NEMIT ,   NP
C       INCLUDE 'COMSCA.inc'
C---------------------------------------------------------------------
CL                  C3.2     Scaling Factors
       COMMON/COMSCA/
     R   SCB3  ,   SCE1  ,   SCE2  ,   SCEMEN,   SCEPOW,   SCI1  ,
     R   SCI2  ,   SCIP  ,   SCKE  ,   SCKPOW,   SCP1  ,   SCP2  ,
     R   SCV1  ,   SCV2  ,   SCX1  ,   SCX2
C       INCLUDE 'COMHOK.inc'
C---------------------------------------------------------------------
CL                  C4.1     Housekeeping
       COMMON/COMHOK/
     R   TIMECP,   XPSMAX,   XPSMIN,   YPSMAX,   YPSMIN,
     I   N1MAX ,   N2MAX ,   NCASE ,   NGMAX ,   NOSEP ,   NPDUM ,
     I   NPMAX ,   NSRC  ,   NXDUM ,   NYDUM
       DIMENSION
     R   TIMECP(32)
C       INCLUDE 'COMGEO.inc'
C---------------------------------------------------------------------
CL                  C4.2     Device boundary data
       COMMON/COMGEO/
     R   ASCUR ,   CCTSRC,   EBEXT ,   ELSCUR,   ENSUR ,   EPOYNT,
     R   RHOC  ,   SURCHG,   SURIC ,
     I   LINDEX,   MINDEX,   NBCTYP,   NBDIM ,   NBSEG2,   NCOLOR,
     I   NDIRN ,   NG
       DIMENSION
     R   ASCUR(1500),        CCTSRC(1500),       EBEXT(2,1500),
     R   ELSCUR(1500),       ENSUR(1500),        EPOYNT(1500),
     R   RHOC(1500),         SURCHG(1500),       SURIC(4,1500),
     I   LINDEX(1500),       MINDEX(1500),       NBCTYP(1500),
     I   NCOLOR(1500),       NDIRN(1500),        NG(605,40)
C       INCLUDE 'COMOUT.inc'
C---------------------------------------------------------------------
CL                  C5.1     Output Variables
       COMMON/COMOUT/
     R   BCNMAX,   BCNMIN,   BCVMAX,   BCVMIN,   CUAMAX,   CUAMIN,
     R   CUEMAX,   CUEMIN,   ECVMAX,   ECVMIN,   TONS1 ,   TONS2 ,
     R   TONS3 ,   TONS4 ,   TONS5 ,   TONS6 ,   TONS7 ,
     I   NBCHT ,   NOPSEL,   NS1   ,   NS2   ,   NS3   ,   NS4   ,
     I   NS5   ,   NS6   ,   NS7
C-----------------------------------------------------------------------
         DATA        ICLASS,   ISUB/3,   8/
                                       CALL EXPERT(ICLASS,ISUB,1)
         IF(NLOMT3(ISUB)) RETURN
C-----------------------------------------------------------------------
         GO TO (100,200,300),K
C
C-----------------------------------------------------------------------
CL              1.         Initialisation
C
  100    CONTINUE
C     set up output file on NDIARY
C        OPEN(UNIT=NDIARY,FILE=CHLAB9,FORM='UNFORMATTED')
C     write in header information to channel NDIARY
         KCHAN = NDIARY
C
C        WRITE(KCHAN) CHLAB1,CHREFN,CHRDAT,CHRDAT
C9000    FORMAT(A48/3A8)
C
C        WRITE(KCHAN)LMAX,MMAX,NCASE,NCAV
C
         DEPCM=DEPTH*100.
         GAPCM=GAP*100.
         RZCM=DEVRAD*100.
         SPACM=SPACE*100.
         WDCM=WIDTH*100.
         VOLTK=VOLTAG/1000.
C
C        WRITE(KCHAN)DEPCM,GAPCM,RZCM,SPACM,WDCM,VOLTK
C
C        WRITE(KCHAN)NCAV
C
         RETURN
C
C-----------------------------------------------------------------------
CL              2.         Periodic Output
C
  200    CONTINUE
C
CL                  2.1      energies
         ZEE1=ENEL1*SCEMEN
         ZEE2=ENEL2*SCEMEN
         ZEB3=ENMAG*SCEMEN
C
         ZENTOT=ENTOT*SCEMEN
         ZENPOY=ENPOYT*SCEMEN
         ZENEJ1=ENEJ1*SCEMEN
         ZENEJ2=ENEJ2*SCEMEN
C
CL                  2.2      powers
         ZE1POW=E1POW*SCEPOW
         ZE2POW=E2POW*SCEPOW
         ZB3POW=B3POW*SCEPOW
         ZJE1P=EJ1POW*SCEPOW
         ZJE2P=EJ2POW*SCEPOW
         ZPOYP=TPOYP*SCEPOW
         ZPOWT=ZE1POW+ZE2POW+ZB3POW+ZJE1P+ZJE2P
C
         IF(ENKIN.NE.0) THEN
         ZKETOT=1.0+(EKFLXO-ENKINO)/ENKIN-
     &   EJPOWP/ENKIN
         ENDIF
CL                  2.3      output
C        WRITE(NDIARY) REALTN,ZEE1,ZEE2,ZEB3,ZENTOT,ZENPOY,ZENEJ1,
C    + ZENEJ2,ZE1POW,ZE2POW,ZB3POW,ZPOWT,ZPOYP,ZJE1P,ZJE2P,ZKETOT
         RETURN
C
C-----------------------------------------------------------------------
CL              3.         Closedown
C
  300    CONTINUE
C        CLOSE(UNIT=NDIARY)
C-----------------------------------------------------------------------
         END
C/ MODULE C3S5
C
         SUBROUTINE ORBIT(K)
C
C 3.5  Track orbits of selected particles
C
C-----------------------------------------------------------------------
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C       INCLUDE 'COMDDP.inc'
C--------------------------------------------------------------------
CL                  C1.9.    DEVELOPMENT AND DIAGNOSTIC PARAMETERS
       COMMON/COMDDP/
     I   MAXDUM,   MXDUMP,   NADUMP,   NCLASS,   NPDUMP,   NPOINT,
     I   NSUB,     NVDUMP,
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       LOGICAL
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       DIMENSION
     I   NADUMP(20),         NPDUMP(20),         NVDUMP(20),
     L   NLHEAD(9),          NLOMT1(50),         NLOMT2(50),
     L   NLOMT3(50)
C       INCLUDE 'COMCON.inc'
C---------------------------------------------------------------------
CL                  C2.1     Physical Constants
       COMMON/COMCON/
     R   API   ,   BOLTZK,   CLIGHT,   ELCHAG,   ELMASS,   EMU0  ,
     R   EOVERM,   EPS0
C       INCLUDE 'COMSTT.inc'
C---------------------------------------------------------------------
CL                  C2.2     Physical State
       COMMON/COMSTT/
     R   B3    ,   BAV   ,   CD1   ,   CD2   ,   E1    ,   E2    ,
     R   P1    ,   P2    ,   Q1    ,   Q2    ,   REALTN,   TIMRUN
       DIMENSION
     R   B3(605,40),        BAV(605,40),       CD1(605,40),
     R   CD2(605,40),       E1(605,40),        E2(605,40),
     R   P1(20000),          P2(20000),          Q1(20000),
     R   Q2(20000)
C       INCLUDE 'COMDEV.inc'
C---------------------------------------------------------------------
CL                  C2.3     Device description
       COMMON/COMDEV/
     R   B3RHS ,   B3RHSD,   BAPLY ,   BAPLYD,   CAVEAM,   CAVEFR,
     R   CAVIC ,   CAVRES,   CAVTC ,   DEPTH ,   DEVHYT,   DEVLEN,
     R   DEVRAD,   EAPLYD,   EEMIT ,   EEMITD,   ENIT  ,   ENITD ,
     R   GAP   ,   RESAX ,   RESE  ,   RESN  ,   RESS  ,   RESW  ,
     R   RINNER,   SPACE ,   VOLTAG,   WIDTH ,
     I   LCATH ,   LCAV  ,   LLEFT ,   LWVANE,   MDEPTH,   MGAP  ,
     I   NBCAX ,   NBCCAV,   NBCE  ,   NBCN  ,   NBCS  ,   NBCW  ,
     I   NCAV  ,   NDEV
       DIMENSION
     R   CAVEAM(100),        CAVEFR(100),        CAVIC(4,100),
     R   CAVRES(100),        CAVTC(100),
     I   NBCCAV(100)
C       INCLUDE 'COMDIA.inc'
C---------------------------------------------------------------------
CL                  C2.4     Physical Diagnostics
       COMMON/COMDIA/
     R   B3POW ,   BOUT  ,   CAVPOY,   E1POW ,   E2POW ,   EJ1POW,
     R   EJ2POW,   EJENP ,   EJPOWM,   EJPOWP,   EJPWPN,   EKFLXI,
     R   EKFLXO,   ENEJ1 ,   ENEJ2 ,   ENEL1 ,   ENEL1O,   ENEL2 ,
     R   ENEL2O,   ENKIN ,   ENKINO,   ENMAG ,   ENMAGO,   ENPOYT,
     R   ENTOT ,   ENTOTO,   EOUT  ,   TOTM1 ,   TOTM2 ,   TPOYP ,
     I   LCAVEN,   LCAVST,   NPNEW ,   NPOLD
       DIMENSION
     R   BOUT(100),          CAVPOY(100),        EOUT(100),
     I   LCAVEN(100),        LCAVST(100)
C       INCLUDE 'COMNUM.inc'
C---------------------------------------------------------------------
CL                  C3.1     Numerical Parameters
       COMMON/COMNUM/
     R   C1    ,   C2    ,   CD0   ,   CURANT,   DT    ,   DX1   ,
     R   DX1DX2,   DX1OX2,   DX2   ,   DX2OX1,   ELPERP,   HLFDX1,
     R   HLFDX2,   TCACO ,
     I   LMAX  ,   LMAXP ,   LMAXP2,   MMAX  ,   MMAXP ,   MMAXP2,
     I   NEMIT ,   NP
C       INCLUDE 'COMSCA.inc'
C---------------------------------------------------------------------
CL                  C3.2     Scaling Factors
       COMMON/COMSCA/
     R   SCB3  ,   SCE1  ,   SCE2  ,   SCEMEN,   SCEPOW,   SCI1  ,
     R   SCI2  ,   SCIP  ,   SCKE  ,   SCKPOW,   SCP1  ,   SCP2  ,
     R   SCV1  ,   SCV2  ,   SCX1  ,   SCX2
C       INCLUDE 'COMHOK.inc'
C---------------------------------------------------------------------
CL                  C4.1     Housekeeping
       COMMON/COMHOK/
     R   TIMECP,   XPSMAX,   XPSMIN,   YPSMAX,   YPSMIN,
     I   N1MAX ,   N2MAX ,   NCASE ,   NGMAX ,   NOSEP ,   NPDUM ,
     I   NPMAX ,   NSRC  ,   NXDUM ,   NYDUM
       DIMENSION
     R   TIMECP(32)
C       INCLUDE 'COMOUT.inc'
C---------------------------------------------------------------------
CL                  C5.1     Output Variables
       COMMON/COMOUT/
     R   BCNMAX,   BCNMIN,   BCVMAX,   BCVMIN,   CUAMAX,   CUAMIN,
     R   CUEMAX,   CUEMIN,   ECVMAX,   ECVMIN,   TONS1 ,   TONS2 ,
     R   TONS3 ,   TONS4 ,   TONS5 ,   TONS6 ,   TONS7 ,
     I   NBCHT ,   NOPSEL,   NS1   ,   NS2   ,   NS3   ,   NS4   ,
     I   NS5   ,   NS6   ,   NS7
C
C-----------------------------------------------------------------------
CL              1.         set plot mapping
C
         IF(K.NE.1) GO TO 200
         ZXL=2.
         ZXU=LMAXP
         ZYL=2.
         ZYU=MMAXP
         CALL MAP(ZXL,ZXU,ZYL,ZYU)
         CALL LINCOL(1)
         CALL BORDER
         CALL LINCOL(4)
         RETURN
C
C-----------------------------------------------------------------------
CL              2.         particle coords
C
  200    IF(K.NE.2) GO TO 300
         DO 201 J= 1,NP
         ZX=Q1(J)
         ZY=Q2(J)
         CALL PLOTNC(ZX,ZY,172)
  201    CONTINUE
         RETURN
C
C-----------------------------------------------------------------------
CL              3.         closedown
C
  300    IF(K.NE.3) GO TO 400
         CALL PICNOW
         CALL GREND
         RETURN
C
C-----------------------------------------------------------------------
CL              4.         error
C
  400    CONTINUE
C        WRITE(NOUT,9000) K
C9000    FORMAT(' *****ILLEGAL ARG TO ORBIT, K =',I10)
         STOP
         END
C/ MODULE C3S6
C
         SUBROUTINE GAUSCK(PEX,PEY,PRHO,KXDIM,KLMAX2,KMMAX2,
     +                     PX,PY,KNP,PC1,PC2,PCD0,PRZERO)
C
C 3.5  Compute rho-div(E), lumped zr cylindrical case
C
C     .     Result is in units of superparticle charge
C-----------------------------------------------------------------------
       DIMENSION
     +   PEX(KXDIM,*),       PEY(KXDIM,*),       PRHO(KXDIM,*),
     +   PX(KNP),  PY(KNP)
C
C-----------------------------------------------------------------------
CL              1.         Initialise
C
         DO 100 JM=1,KMMAX2
         DO 100 JL=1,KLMAX2
  100    PRHO(JL,JM)=0.0
C
C-----------------------------------------------------------------------
CL              2.         Assign Charge
C
         IF(KNP.GE.1) THEN
         DO 200 JP=1,KNP
C     indices
         ILM=PX(JP)
         ILP=ILM+1
         IMM=PY(JP)
         IMP=IMM+1
C     offsets
         ZX=PX(JP)-ILM
         ZY=PY(JP)-IMM
         ZXM=1.0-ZX
         ZYM=1.0-ZY
C     assign
         PRHO(ILM,IMM)=PRHO(ILM,IMM)+ZXM*ZYM
         PRHO(ILP,IMM)=PRHO(ILP,IMM)+ZX *ZYM
         PRHO(ILM,IMP)=PRHO(ILM,IMP)+ZXM*ZY
         PRHO(ILP,IMP)=PRHO(ILP,IMP)+ZX *ZY
  200    CONTINUE
         END IF
C
C-----------------------------------------------------------------------
CL              3.         Compute residual
C
         ILMAXP=KLMAX2-1
         IMMAXP=KMMAX2-1
                 ZFAC  =1.0/PC1/PC2/PCD0
C
         DO 300 JM=2,IMMAXP
         ZRAD=PRZERO+JM-2
         ZRP=ZRAD+0.5
         ZRM=ZRAD-0.5
         DO 300 JL=2,ILMAXP
         PRHO(JL,JM)=PRHO(JL,JM) -
     +   (PC2*(ZRP*PEY(JL,JM)-ZRM*PEY(JL,JM-1))
     +   +PC1*ZRAD*(PEX(JL,JM)-PEX(JL-1,JM))) *ZFAC
  300    CONTINUE
C-----------------------------------------------------------------------
         END
C
C/ MODULE c0s1
         SUBROUTINE BASIC
C
C 0.1  INITIALIZE BASIC DATA
C
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C       INCLUDE 'COMDDP.inc'
C--------------------------------------------------------------------
CL                  C1.9.    DEVELOPMENT AND DIAGNOSTIC PARAMETERS
       COMMON/COMDDP/
     I   MAXDUM,   MXDUMP,   NADUMP,   NCLASS,   NPDUMP,   NPOINT,
     I   NSUB,     NVDUMP,
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       LOGICAL
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       DIMENSION
     I   NADUMP(20),         NPDUMP(20),         NVDUMP(20),
     L   NLHEAD(9),          NLOMT1(50),         NLOMT2(50),
     L   NLOMT3(50)
C
                 CHARACTER CANS
                 CHARACTER*70 CNREAD,CNOUT,CNRESM
C
C---------------------------------------------------------------------
CL              1.         GENERAL OLYMPUS DATA
C
CL                  1.1      BASIC SYSTEM PARAMETERS
C     CPU - TIME USED SO FAR
         DIMENSION ZTAR(2)
         CPTIME=0.0
         CALL SECOWA(ZTIME,ZTAR)
         STIME = ZTIME
C
C     CLEAR ALL 16 LABEL ARRAYS
         CHLAB1=' LPM1 BENCHMARK'
         CHLAB2=' '
         CHLAB3=' '
         CHLAB4=' '
         CHLAB5=' '
         CHLAB6=' '
         CHLAB7=' '
         CHLAB8=' '
         CHLAB9=' '
         CHLB10=' '
         CHLB11=' '
         CHLB12=' '
         CHLB13=' '
         CHLB14=' '
         CHLB15=' '
         CHLB16=' '
         CHREFN='LPM1'
C
C     INPUT-OUTPUT CHANNELS
         NLEDGE = 8
         NONLIN = 2
         NPUNCH=7
         NPRINT=2
         NREAD=1
         NDIARY=NPUNCH
         NIN=NREAD
         NOUT=NPRINT
C
C     TIMESTEP CONTROL
         NRUN = 1
         NSTEP=0
C
C     RESTART CONTROL
         NREC = 1
         NRESUM = NLEDGE
C
C     LOGICAL SWITCHES
         NLEND=.FALSE.
         NLRES=.FALSE.
C
C  Get data from Parsys Supernode keyboard
         CALL SNDATA(1)
C
CL                  1.9      DIAGNOSTIC AND DEVELOPMENT PARAMETERS
C     MAXIMUM DIMENSIONS OF DUMP ARRAYS
         MAXDUM = 20
         MXDUMP = 10
C     RESET DUMP ARRAYS
         CALL RESETI(NADUMP,MAXDUM,0)
         CALL RESETI(NPDUMP,MAXDUM,0)
         CALL RESETI(NVDUMP,MAXDUM,0)
C     TRACER VARIABLES
         NCLASS = 0
         NSUB = 1
         NPOINT = 1
C     LOGICAL SWITCHES
         NLCHED = .FALSE.
         NLREPT = .FALSE.
C     REPORT HEADS FOR CLASSES 1-9
         CALL RESETL(NLHEAD,9,.FALSE.)
C     RESET CLASS 1,2,3 SUBPROGRAM SELECTOR ARRAY
         CALL RESETL(NLOMT1,50,.FALSE.)
         CALL RESETL(NLOMT2,50,.FALSE.)
         CALL RESETL(NLOMT3,50,.FALSE.)
C   ======================================
C  .......  READ SEQUENCE COMMENTED OUT FOR BENCHMARK
C       establish NREAD is open
C        INARGS=IARGC()
C        NO ARGS - ASK FOR FILENAME
C        IF(INARGS.EQ.0) THEN
C100     WRITE(*,9000)
C9000    FORMAT('Enter input filename')
C              READ(*,9001) CNREAD
               CNREAD=' '
C9001    FORMAT(A)
C              WRITE(*,9002) CNREAD
C9002    FORMAT('Input file = ',A,/,' OK? y/n')
               CANS=' '
C              READ(*,9001) CANS
C        IF(CANS.NE.'y'.AND.CANS.NE.'Y') GO TO 100
C    FILENAME IS ARG
C        ELSE
C          CALL GETARG(1,CNREAD)
C        END IF
C    the input data is on channel NREAD=1
C    and printer output is on channel NOUT=2
C        OPEN(UNIT=NREAD,FILE=CNREAD)
C        the output filename is first line of data on NREAD
C        READ(NREAD,9001) CNOUT
         CNOUT='O_LPM1'
C
C        OPEN(UNIT=NOUT,FILE=CNOUT)
C
C   ========================================
C=
C
         CALLMESAGE('    LOCAL PARTICLE-MESH BENCHMARK (LPM1)       ')
         CALLMESAGE('    ------------------------------------       ')
         CALLMESAGE('    GENESIS DISTRIBUTED MEMORY BENCHMARKS      ')
         CALLMESAGE('      SOUTHAMPTON UNIVERSITY, MAY 1991         ')
C
C   ========================================
C       NEWRUN or RESET?
C    restart coordinates are on channel 8
C          CALL LDATA('NLRES   ',NLRES)
                 IF(NLRES) THEN
C          READ(NREAD,9001) CNRESM
           CNRESM='R_MILO01'
C          OPEN(UNIT=NRESUM,FILE=CNRESM,FORM='UNFORMATTED')
                 END IF
C   =========================================
C
C     record input filename on output
C                WRITE(NOUT,9003) CNREAD
C9003    FORMAT('Input file = ',A)
C
C    USER INTERFACE
                 CALL MODIFY
C
         END
C
C/ MODULE c1s4r
         SUBROUTINE DATA
C
C 1.4  Define data specific to run
C
C list directed input version
C
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN
C       INCLUDE 'COMDDP.inc'
C--------------------------------------------------------------------
CL                  C1.9.    DEVELOPMENT AND DIAGNOSTIC PARAMETERS
       COMMON/COMDDP/
     I   MAXDUM,   MXDUMP,   NADUMP,   NCLASS,   NPDUMP,   NPOINT,
     I   NSUB,     NVDUMP,
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       LOGICAL
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       DIMENSION
     I   NADUMP(20),         NPDUMP(20),         NVDUMP(20),
     L   NLHEAD(9),          NLOMT1(50),         NLOMT2(50),
     L   NLOMT3(50)
C       INCLUDE 'COMCON.inc'
C---------------------------------------------------------------------
CL                  C2.1     Physical Constants
       COMMON/COMCON/
     R   API   ,   BOLTZK,   CLIGHT,   ELCHAG,   ELMASS,   EMU0  ,
     R   EOVERM,   EPS0
C       INCLUDE 'COMSTT.inc'
C---------------------------------------------------------------------
CL                  C2.2     Physical State
       COMMON/COMSTT/
     R   B3    ,   BAV   ,   CD1   ,   CD2   ,   E1    ,   E2    ,
     R   P1    ,   P2    ,   Q1    ,   Q2    ,   REALTN,   TIMRUN
       DIMENSION
     R   B3(605,40),        BAV(605,40),       CD1(605,40),
     R   CD2(605,40),       E1(605,40),        E2(605,40),
     R   P1(20000),          P2(20000),          Q1(20000),
     R   Q2(20000)
C       INCLUDE 'COMDEV.inc'
C---------------------------------------------------------------------
CL                  C2.3     Device description
       COMMON/COMDEV/
     R   B3RHS ,   B3RHSD,   BAPLY ,   BAPLYD,   CAVEAM,   CAVEFR,
     R   CAVIC ,   CAVRES,   CAVTC ,   DEPTH ,   DEVHYT,   DEVLEN,
     R   DEVRAD,   EAPLYD,   EEMIT ,   EEMITD,   ENIT  ,   ENITD ,
     R   GAP   ,   RESAX ,   RESE  ,   RESN  ,   RESS  ,   RESW  ,
     R   RINNER,   SPACE ,   VOLTAG,   WIDTH ,
     I   LCATH ,   LCAV  ,   LLEFT ,   LWVANE,   MDEPTH,   MGAP  ,
     I   NBCAX ,   NBCCAV,   NBCE  ,   NBCN  ,   NBCS  ,   NBCW  ,
     I   NCAV  ,   NDEV
       DIMENSION
     R   CAVEAM(100),        CAVEFR(100),        CAVIC(4,100),
     R   CAVRES(100),        CAVTC(100),
     I   NBCCAV(100)
C       INCLUDE 'COMDIA.inc'
C---------------------------------------------------------------------
CL                  C2.4     Physical Diagnostics
       COMMON/COMDIA/
     R   B3POW ,   BOUT  ,   CAVPOY,   E1POW ,   E2POW ,   EJ1POW,
     R   EJ2POW,   EJENP ,   EJPOWM,   EJPOWP,   EJPWPN,   EKFLXI,
     R   EKFLXO,   ENEJ1 ,   ENEJ2 ,   ENEL1 ,   ENEL1O,   ENEL2 ,
     R   ENEL2O,   ENKIN ,   ENKINO,   ENMAG ,   ENMAGO,   ENPOYT,
     R   ENTOT ,   ENTOTO,   EOUT  ,   TOTM1 ,   TOTM2 ,   TPOYP ,
     I   LCAVEN,   LCAVST,   NPNEW ,   NPOLD
       DIMENSION
     R   BOUT(100),          CAVPOY(100),        EOUT(100),
     I   LCAVEN(100),        LCAVST(100)
C       INCLUDE 'COMKLY.inc'
C---------------------------------------------------------------------
CL                  C2.5     Klystron device details
       COMMON/COMKLY/
     R   BMCUR ,   BMMOM ,   BMRIN ,   BMROUT
C       INCLUDE 'COMNUM.inc'
C---------------------------------------------------------------------
CL                  C3.1     Numerical Parameters
       COMMON/COMNUM/
     R   C1    ,   C2    ,   CD0   ,   CURANT,   DT    ,   DX1   ,
     R   DX1DX2,   DX1OX2,   DX2   ,   DX2OX1,   ELPERP,   HLFDX1,
     R   HLFDX2,   TCACO ,
     I   LMAX  ,   LMAXP ,   LMAXP2,   MMAX  ,   MMAXP ,   MMAXP2,
     I   NEMIT ,   NP
C       INCLUDE 'COMSCA.inc'
C---------------------------------------------------------------------
CL                  C3.2     Scaling Factors
       COMMON/COMSCA/
     R   SCB3  ,   SCE1  ,   SCE2  ,   SCEMEN,   SCEPOW,   SCI1  ,
     R   SCI2  ,   SCIP  ,   SCKE  ,   SCKPOW,   SCP1  ,   SCP2  ,
     R   SCV1  ,   SCV2  ,   SCX1  ,   SCX2
C       INCLUDE 'COMHOK.inc'
C---------------------------------------------------------------------
CL                  C4.1     Housekeeping
       COMMON/COMHOK/
     R   TIMECP,   XPSMAX,   XPSMIN,   YPSMAX,   YPSMIN,
     I   N1MAX ,   N2MAX ,   NCASE ,   NGMAX ,   NOSEP ,   NPDUM ,
     I   NPMAX ,   NSRC  ,   NXDUM ,   NYDUM
       DIMENSION
     R   TIMECP(32)
C       INCLUDE 'COMGEO.inc'
C---------------------------------------------------------------------
CL                  C4.2     Device boundary data
       COMMON/COMGEO/
     R   ASCUR ,   CCTSRC,   EBEXT ,   ELSCUR,   ENSUR ,   EPOYNT,
     R   RHOC  ,   SURCHG,   SURIC ,
     I   LINDEX,   MINDEX,   NBCTYP,   NBDIM ,   NBSEG2,   NCOLOR,
     I   NDIRN ,   NG
       DIMENSION
     R   ASCUR(1500),        CCTSRC(1500),       EBEXT(2,1500),
     R   ELSCUR(1500),       ENSUR(1500),        EPOYNT(1500),
     R   RHOC(1500),         SURCHG(1500),       SURIC(4,1500),
     I   LINDEX(1500),       MINDEX(1500),       NBCTYP(1500),
     I   NCOLOR(1500),       NDIRN(1500),        NG(605,40)
C       INCLUDE 'COMOUT.inc'
C---------------------------------------------------------------------
CL                  C5.1     Output Variables
       COMMON/COMOUT/
     R   BCNMAX,   BCNMIN,   BCVMAX,   BCVMIN,   CUAMAX,   CUAMIN,
     R   CUEMAX,   CUEMIN,   ECVMAX,   ECVMIN,   TONS1 ,   TONS2 ,
     R   TONS3 ,   TONS4 ,   TONS5 ,   TONS6 ,   TONS7 ,
     I   NBCHT ,   NOPSEL,   NS1   ,   NS2   ,   NS3   ,   NS4   ,
     I   NS5   ,   NS6   ,   NS7
C---------------------------------------------------------------------
C
C  Get data from Parsys Supernode keyboard
         CALL SNDATA(2)
C
C   ..........   COMMENT OUT CALL FOR BENCHMARK
C
         IF(.TRUE.)  RETURN
C
CL              1.         NEW RUN
C
         IF(NLRES) GO TO 200
         CALL  IDATA('NDIARY',NDIARY)
         CALL  IDATA('NIN   ',NIN   )
         CALL  IDATA('NLEDGE',NLEDGE)
         CALL  IDATA('NONLIN',NONLIN)
         CALL  IDATA('NOUT  ',NOUT  )
         CALL  IDATA('NPRINT',NPRINT)
         CALL  IDATA('NPUNCH',NPUNCH)
         CALL  IDATA('NREC  ',NREC  )
         CALL  IDATA('NRUN  ',NRUN  )
         CALL  HDATA('CHLAB5',CHLAB5)
         CALL IADATA('NADUMP',NADUMP,  20)
         CALL IADATA('NPDUMP',NPDUMP,  20)
         CALL IADATA('NVDUMP',NVDUMP,  20)
         CALL  LDATA('NLCHED',NLCHED)
         CALL LADATA('NLHEAD',NLHEAD,  9)
         CALL LADATA('NLOMT1',NLOMT1,  50)
         CALL LADATA('NLOMT2',NLOMT2,  50)
         CALL LADATA('NLOMT3',NLOMT3,  50)
         CALL  LDATA('NLREPT',NLREPT)
         CALL  RDATA('BOLTZK',BOLTZK)
         CALL  RDATA('CLIGHT',CLIGHT)
         CALL  RDATA('ELCHAG',ELCHAG)
         CALL  RDATA('ELMASS',ELMASS)
         CALL  RDATA('EMU0  ',EMU0  )
         CALL  RDATA('EPS0  ',EPS0  )
         CALL  RDATA('TIMRUN',TIMRUN)
         CALL  RDATA('B3RHS ',B3RHS )
         CALL  RDATA('BAPLY ',BAPLY )
         CALL RADATA('CAVEAM',CAVEAM,  100)
         CALL RADATA('CAVEFR',CAVEFR,  100)
         CALL RADATA('CAVRES',CAVRES,  100)
         CALL RADATA('CAVTC ',CAVTC ,  100)
         CALL  RDATA('DEVHYT',DEVHYT)
         CALL  RDATA('DEVLEN',DEVLEN)
         CALL  RDATA('DEVRAD',DEVRAD)
         CALL  RDATA('EEMIT ',EEMIT )
         CALL  RDATA('ENIT  ',ENIT  )
         CALL  RDATA('RESAX ',RESAX )
         CALL  RDATA('RESE  ',RESE  )
         CALL  RDATA('RESN  ',RESN  )
         CALL  RDATA('RESS  ',RESS  )
         CALL  RDATA('RESW  ',RESW  )
         CALL  RDATA('VOLTAG',VOLTAG)
         CALL  IDATA('LCATH ',LCATH )
         CALL  IDATA('LCAV  ',LCAV  )
         CALL  IDATA('LLEFT ',LLEFT )
         CALL  IDATA('LWVANE',LWVANE)
         CALL  IDATA('MDEPTH',MDEPTH)
         CALL  IDATA('MGAP  ',MGAP  )
         CALL  IDATA('NBCAX ',NBCAX )
         CALL IADATA('NBCCAV',NBCCAV,  100)
         CALL  IDATA('NBCE  ',NBCE  )
         CALL  IDATA('NBCN  ',NBCN  )
         CALL  IDATA('NBCS  ',NBCS  )
         CALL  IDATA('NBCW  ',NBCW  )
         CALL  IDATA('NCAV  ',NCAV  )
         CALL  IDATA('NDEV  ',NDEV  )
         CALL  RDATA('BMCUR ',BMCUR )
         CALL  RDATA('BMMOM ',BMMOM )
         CALL  RDATA('BMRIN ',BMRIN )
         CALL  RDATA('BMROUT',BMROUT)
         CALL  RDATA('CURANT',CURANT)
         CALL  RDATA('ELPERP',ELPERP)
         CALL  RDATA('TCACO ',TCACO )
         CALL  IDATA('LMAX  ',LMAX  )
         CALL  IDATA('MMAX  ',MMAX  )
         CALL  IDATA('N1MAX ',N1MAX )
         CALL  IDATA('N2MAX ',N2MAX )
         CALL  IDATA('NCASE ',NCASE )
         CALL  IDATA('NGMAX ',NGMAX )
         CALL  IDATA('NOSEP ',NOSEP )
         CALL  IDATA('NPDUM ',NPDUM )
         CALL  IDATA('NPMAX ',NPMAX )
         CALL  IDATA('NSRC  ',NSRC  )
         CALL  IDATA('NXDUM ',NXDUM )
         CALL  IDATA('NYDUM ',NYDUM )
         CALL  IDATA('NBDIM ',NBDIM )
         CALL  RDATA('BCNMAX',BCNMAX)
         CALL  RDATA('BCNMIN',BCNMIN)
         CALL  RDATA('BCVMAX',BCVMAX)
         CALL  RDATA('BCVMIN',BCVMIN)
         CALL  RDATA('CUAMAX',CUAMAX)
         CALL  RDATA('CUAMIN',CUAMIN)
         CALL  RDATA('CUEMAX',CUEMAX)
         CALL  RDATA('CUEMIN',CUEMIN)
         CALL  RDATA('ECVMAX',ECVMAX)
         CALL  RDATA('ECVMIN',ECVMIN)
         CALL  RDATA('TONS1 ',TONS1 )
         CALL  RDATA('TONS2 ',TONS2 )
         CALL  RDATA('TONS3 ',TONS3 )
         CALL  RDATA('TONS4 ',TONS4 )
         CALL  RDATA('TONS5 ',TONS5 )
         CALL  RDATA('TONS6 ',TONS6 )
         CALL  RDATA('TONS7 ',TONS7 )
         CALL  IDATA('NBCHT ',NBCHT )
         CALL  IDATA('NOPSEL',NOPSEL)
         CALL  IDATA('NS1   ',NS1   )
         CALL  IDATA('NS2   ',NS2   )
         CALL  IDATA('NS3   ',NS3   )
         CALL  IDATA('NS4   ',NS4   )
         CALL  IDATA('NS5   ',NS5   )
         CALL  IDATA('NS6   ',NS6   )
         CALL  IDATA('NS7   ',NS7   )

         RETURN
C
C---------------------------------------------------------------------
CL              2.         RUN RESTARTED
C
  200    CALL  IDATA('NDIARY',NDIARY)
         CALL  IDATA('NIN   ',NIN   )
         CALL  IDATA('NLEDGE',NLEDGE)
         CALL  IDATA('NONLIN',NONLIN)
         CALL  IDATA('NOUT  ',NOUT  )
         CALL  IDATA('NPRINT',NPRINT)
         CALL  IDATA('NPUNCH',NPUNCH)
         CALL  IDATA('NREC  ',NREC  )
         CALL  IDATA('NRUN  ',NRUN  )
         CALL  HDATA('CHLAB5',CHLAB5)
         CALL IADATA('NADUMP',NADUMP,  20)
         CALL IADATA('NPDUMP',NPDUMP,  20)
         CALL IADATA('NVDUMP',NVDUMP,  20)
         CALL  LDATA('NLCHED',NLCHED)
         CALL LADATA('NLHEAD',NLHEAD,  9)
         CALL LADATA('NLOMT1',NLOMT1,  50)
         CALL LADATA('NLOMT2',NLOMT2,  50)
         CALL LADATA('NLOMT3',NLOMT3,  50)
         CALL  LDATA('NLREPT',NLREPT)
         CALL  RDATA('TIMRUN',TIMRUN)
         CALL RADATA('CAVEAM',CAVEAM,  100)
         CALL RADATA('CAVEFR',CAVEFR,  100)
         CALL RADATA('CAVRES',CAVRES,  100)
         CALL RADATA('CAVTC ',CAVTC ,  100)
         CALL  RDATA('EEMIT ',EEMIT )
         CALL  RDATA('VOLTAG',VOLTAG)
         CALL IADATA('NBCCAV',NBCCAV,  100)
         CALL  RDATA('TCACO ',TCACO )
         CALL  IDATA('NOSEP ',NOSEP )
         CALL  IDATA('NPDUM ',NPDUM )
         CALL  IDATA('NXDUM ',NXDUM )
         CALL  IDATA('NYDUM ',NYDUM )
         CALL  RDATA('BCNMAX',BCNMAX)
         CALL  RDATA('BCNMIN',BCNMIN)
         CALL  RDATA('BCVMAX',BCVMAX)
         CALL  RDATA('BCVMIN',BCVMIN)
         CALL  RDATA('CUAMAX',CUAMAX)
         CALL  RDATA('CUAMIN',CUAMIN)
         CALL  RDATA('CUEMAX',CUEMAX)
         CALL  RDATA('CUEMIN',CUEMIN)
         CALL  RDATA('ECVMAX',ECVMAX)
         CALL  RDATA('ECVMIN',ECVMIN)
         CALL  RDATA('TONS1 ',TONS1 )
         CALL  RDATA('TONS2 ',TONS2 )
         CALL  RDATA('TONS3 ',TONS3 )
         CALL  RDATA('TONS4 ',TONS4 )
         CALL  RDATA('TONS5 ',TONS5 )
         CALL  RDATA('TONS6 ',TONS6 )
         CALL  RDATA('TONS7 ',TONS7 )
         CALL  IDATA('NBCHT ',NBCHT )
         CALL  IDATA('NOPSEL',NOPSEL)
         CALL  IDATA('NS1   ',NS1   )
         CALL  IDATA('NS2   ',NS2   )
         CALL  IDATA('NS3   ',NS3   )
         CALL  IDATA('NS4   ',NS4   )
         CALL  IDATA('NS5   ',NS5   )
         CALL  IDATA('NS6   ',NS6   )
         CALL  IDATA('NS7   ',NS7   )
C---------------------------------------------------------------------
C
         END
C/ MODULE C1S7
         SUBROUTINE RESUME
C
C 1.7  resume from the previous run
C
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C       INCLUDE 'COMDDP.inc'
C--------------------------------------------------------------------
CL                  C1.9.    DEVELOPMENT AND DIAGNOSTIC PARAMETERS
       COMMON/COMDDP/
     I   MAXDUM,   MXDUMP,   NADUMP,   NCLASS,   NPDUMP,   NPOINT,
     I   NSUB,     NVDUMP,
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       LOGICAL
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       DIMENSION
     I   NADUMP(20),         NPDUMP(20),         NVDUMP(20),
     L   NLHEAD(9),          NLOMT1(50),         NLOMT2(50),
     L   NLOMT3(50)
       CHARACTER   *8 CHTIMS,          CHDATS,      CHREFS
       CHARACTER   *48 CHLB1,CHLB2,CHLB3,CHLB4
C---------------------------------------------------------------------
       DATA        ICLASS,   ISUB/1,   7/
                                       CALL EXPERT(ICLASS,ISUB,1)
         IF(NLOMT1(ISUB))RETURN
C
C---------------------------------------------------------------------
CL              1.         read restart file
C
C     preserve allocated time
         ZTIME=ALTIME
C
C     preserve  reference and timestamp
         CHREFS=CHREFN
         CHTIMS=CHRTIM
         CHDATS=CHRDAT
C     preserve restart labelling
                 CHLB1=CHLAB1
                 CHLB2=CHLAB2
                 CHLB3=CHLAB3
                 CHLB4=CHLAB4
C     read restart coordinates
         CALL RECORD(NRESUM,2,IRET)
C     reset allocated time
         ALTIME=ZTIME
C     close restart file
C        CLOSE(NRESUM)
C
C---------------------------------------------------------------------
CL              2.         error conditions
C
C
CL                  2.1      success
         IF(IRET.EQ.1) THEN
         CALLMESAGE( ' ****RESTART COORDINATES READ SUCCESSFULLY***** ')
         CALL IVAR('NSTEP   ',NSTEP)
C
CL                  2.2      end of file
         ELSE IF(IRET.EQ.2) THEN
         CALLMESAGE( ' ****END OF FILE ON RESTART FILE*****          ' )
         CALLMESAGE('  ****RUN ABANDONED*****'                         )
         STOP
C
CL                  2.3      error
         ELSE
         CALLMESAGE( ' ****ERROR ON RESTART INPUT*****               ' )
         CALLMESAGE('  ****RUN ABANDONED*****'                         )
         STOP
         END IF
C
C---------------------------------------------------------------------
CL              3.         restart data labelling
C
C     WRITE HEADING
         CALL BLINES(8)
C        WRITE(NOUT,9001)
C        WRITE(NOUT,9002)
         CALL BLINES(4)
C
C     WRITE LABELS
C        WRITE(NOUT,9005) CHREFN
         CALL BLINES(1)
C        WRITE(NOUT,9003) CHLAB1
         CALL BLINES(1)
C        WRITE(NOUT,9003) CHLAB2
         CALL BLINES(1)
C        WRITE(NOUT,9003) CHLAB3
         CALL BLINES(1)
C        WRITE(NOUT,9003) CHLAB4
         CALL BLINES(1)
C
C9001    FORMAT(12X,'R E S T A R T   D A T A   L A B E L L I N G    ')
C9002    FORMAT(12X,'*******************************************')
C9003    FORMAT(12X,A)
C9005    FORMAT(//,12X,'old run reference no: ',A8,//)
C
C     old time stamp
C
C        WRITE(NOUT,9004) CHDATO,CHTIMO,CHRDAT,CHRTIM
C9004    FORMAT(//,12X,'old run stamp:  DATE: ',A8,'  TIME: ',A8,
C    +             12X,'new run stamp:  DATE: ',A8,'  TIME: ',A8,//)
C
C     reset stamps
         CALLMESAGE('  ****STAMPS RESET*****'                          )
         CHDATO=CHRDAT
         CHTIMO=CHRTIM
         CHRDAT=CHDATS
         CHRTIM=CHTIMS
C     set reference number and labelling
         CHREFN=CHREFS
                 CHLAB1=CHLB1
                 CHLAB2=CHLB2
                 CHLAB3=CHLB3
                 CHLAB4=CHLB4
C
         RETURN
C
C---------------------------------------------------------------------
CL              4.         file opening failure
C
  400    CALLMESAGE('  ****FAILED TO OPEN RESTART FILE*****'           )
         CALLMESAGE('  ****RUN ABANDONED*****'                         )
         STOP
C---------------------------------------------------------------------
         END
C/ MODULE c1s1
C
         SUBROUTINE LABRUN
C
C 1.1  LABEL THE RUN
C
C
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C---------------------------------------------------------------------
C
C     READ LABELS
C  .......  COMMENT OUT READ FOR BENCHMARK
C        READ(NREAD,9904)CHREFN
C        READ(NREAD,9900)CHLAB1
C        READ(NREAD,9900)CHLAB2
C        READ(NREAD,9900)CHLAB3
C        READ(NREAD,9900)CHLAB4
C
C     WRITE HEADING
         CALL BLINES(8)
C        WRITE(NOUT,9901)
C        WRITE(NOUT,9902)
         CALL BLINES(4)
C
C     WRITE LABELS
C        WRITE(NOUT,9903) CHREFN
         CALL BLINES(1)
C        WRITE(NOUT,9903) CHLAB1
         CALL BLINES(1)
C        WRITE(NOUT,9903) CHLAB2
         CALL BLINES(1)
C        WRITE(NOUT,9903) CHLAB3
         CALL BLINES(1)
C        WRITE(NOUT,9903) CHLAB4
         CALL BLINES(1)
C
         RETURN
C9900    FORMAT(A)
C9901    FORMAT(50X,)
C9902    FORMAT(50X,)
C9903    FORMAT(12X,A)
C9904    FORMAT(A8)
         END
C
         SUBROUTINE STEPON
C
C 2.1  STEP ON THE CALCULATION
C
C-----------------------------------------------------------------------
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C       INCLUDE 'COMDDP.inc'
C--------------------------------------------------------------------
CL                  C1.9.    DEVELOPMENT AND DIAGNOSTIC PARAMETERS
       COMMON/COMDDP/
     I   MAXDUM,   MXDUMP,   NADUMP,   NCLASS,   NPDUMP,   NPOINT,
     I   NSUB,     NVDUMP,
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       LOGICAL
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       DIMENSION
     I   NADUMP(20),         NPDUMP(20),         NVDUMP(20),
     L   NLHEAD(9),          NLOMT1(50),         NLOMT2(50),
     L   NLOMT3(50)
C       INCLUDE 'COMCON.inc'
C---------------------------------------------------------------------
CL                  C2.1     Physical Constants
       COMMON/COMCON/
     R   API   ,   BOLTZK,   CLIGHT,   ELCHAG,   ELMASS,   EMU0  ,
     R   EOVERM,   EPS0
C       INCLUDE 'COMSTT.inc'
C---------------------------------------------------------------------
CL                  C2.2     Physical State
       COMMON/COMSTT/
     R   B3    ,   BAV   ,   CD1   ,   CD2   ,   E1    ,   E2    ,
     R   P1    ,   P2    ,   Q1    ,   Q2    ,   REALTN,   TIMRUN
       DIMENSION
     R   B3(605,40),        BAV(605,40),       CD1(605,40),
     R   CD2(605,40),       E1(605,40),        E2(605,40),
     R   P1(20000),          P2(20000),          Q1(20000),
     R   Q2(20000)
C       INCLUDE 'COMDEV.inc'
C---------------------------------------------------------------------
CL                  C2.3     Device description
       COMMON/COMDEV/
     R   B3RHS ,   B3RHSD,   BAPLY ,   BAPLYD,   CAVEAM,   CAVEFR,
     R   CAVIC ,   CAVRES,   CAVTC ,   DEPTH ,   DEVHYT,   DEVLEN,
     R   DEVRAD,   EAPLYD,   EEMIT ,   EEMITD,   ENIT  ,   ENITD ,
     R   GAP   ,   RESAX ,   RESE  ,   RESN  ,   RESS  ,   RESW  ,
     R   RINNER,   SPACE ,   VOLTAG,   WIDTH ,
     I   LCATH ,   LCAV  ,   LLEFT ,   LWVANE,   MDEPTH,   MGAP  ,
     I   NBCAX ,   NBCCAV,   NBCE  ,   NBCN  ,   NBCS  ,   NBCW  ,
     I   NCAV  ,   NDEV
       DIMENSION
     R   CAVEAM(100),        CAVEFR(100),        CAVIC(4,100),
     R   CAVRES(100),        CAVTC(100),
     I   NBCCAV(100)
C       INCLUDE 'COMDIA.inc'
C---------------------------------------------------------------------
CL                  C2.4     Physical Diagnostics
       COMMON/COMDIA/
     R   B3POW ,   BOUT  ,   CAVPOY,   E1POW ,   E2POW ,   EJ1POW,
     R   EJ2POW,   EJENP ,   EJPOWM,   EJPOWP,   EJPWPN,   EKFLXI,
     R   EKFLXO,   ENEJ1 ,   ENEJ2 ,   ENEL1 ,   ENEL1O,   ENEL2 ,
     R   ENEL2O,   ENKIN ,   ENKINO,   ENMAG ,   ENMAGO,   ENPOYT,
     R   ENTOT ,   ENTOTO,   EOUT  ,   TOTM1 ,   TOTM2 ,   TPOYP ,
     I   LCAVEN,   LCAVST,   NPNEW ,   NPOLD
       DIMENSION
     R   BOUT(100),          CAVPOY(100),        EOUT(100),
     I   LCAVEN(100),        LCAVST(100)
C       INCLUDE 'COMNUM.inc'
C---------------------------------------------------------------------
CL                  C3.1     Numerical Parameters
       COMMON/COMNUM/
     R   C1    ,   C2    ,   CD0   ,   CURANT,   DT    ,   DX1   ,
     R   DX1DX2,   DX1OX2,   DX2   ,   DX2OX1,   ELPERP,   HLFDX1,
     R   HLFDX2,   TCACO ,
     I   LMAX  ,   LMAXP ,   LMAXP2,   MMAX  ,   MMAXP ,   MMAXP2,
     I   NEMIT ,   NP
C       INCLUDE 'COMSCA.inc'
C---------------------------------------------------------------------
CL                  C3.2     Scaling Factors
       COMMON/COMSCA/
     R   SCB3  ,   SCE1  ,   SCE2  ,   SCEMEN,   SCEPOW,   SCI1  ,
     R   SCI2  ,   SCIP  ,   SCKE  ,   SCKPOW,   SCP1  ,   SCP2  ,
     R   SCV1  ,   SCV2  ,   SCX1  ,   SCX2
C       INCLUDE 'COMHOK.inc'
C---------------------------------------------------------------------
CL                  C4.1     Housekeeping
       COMMON/COMHOK/
     R   TIMECP,   XPSMAX,   XPSMIN,   YPSMAX,   YPSMIN,
     I   N1MAX ,   N2MAX ,   NCASE ,   NGMAX ,   NOSEP ,   NPDUM ,
     I   NPMAX ,   NSRC  ,   NXDUM ,   NYDUM
       DIMENSION
     R   TIMECP(32)
C       INCLUDE 'COMGEO.inc'
C---------------------------------------------------------------------
CL                  C4.2     Device boundary data
       COMMON/COMGEO/
     R   ASCUR ,   CCTSRC,   EBEXT ,   ELSCUR,   ENSUR ,   EPOYNT,
     R   RHOC  ,   SURCHG,   SURIC ,
     I   LINDEX,   MINDEX,   NBCTYP,   NBDIM ,   NBSEG2,   NCOLOR,
     I   NDIRN ,   NG
       DIMENSION
     R   ASCUR(1500),        CCTSRC(1500),       EBEXT(2,1500),
     R   ELSCUR(1500),       ENSUR(1500),        EPOYNT(1500),
     R   RHOC(1500),         SURCHG(1500),       SURIC(4,1500),
     I   LINDEX(1500),       MINDEX(1500),       NBCTYP(1500),
     I   NCOLOR(1500),       NDIRN(1500),        NG(605,40)
C       INCLUDE 'COMOUT.inc'
C---------------------------------------------------------------------
CL                  C5.1     Output Variables
       COMMON/COMOUT/
     R   BCNMAX,   BCNMIN,   BCVMAX,   BCVMIN,   CUAMAX,   CUAMIN,
     R   CUEMAX,   CUEMIN,   ECVMAX,   ECVMIN,   TONS1 ,   TONS2 ,
     R   TONS3 ,   TONS4 ,   TONS5 ,   TONS6 ,   TONS7 ,
     I   NBCHT ,   NOPSEL,   NS1   ,   NS2   ,   NS3   ,   NS4   ,
     I   NS5   ,   NS6   ,   NS7
C-----------------------------------------------------------------------
C
C       INCLUDE 'C:\TINYV2R0\INCLUDE\TINY.INC'
C       INCLUDE 'CHAN.INC'
C
      COMMON /GRAFIX/ MASKSZ,MSPORT,SSPORT,GPORT,GBOOT,G_TASKID,
     1       IBLK,IWHT,IRED,IGRN,IBLU,IYEL,IMAG,ICYA,SRPORT
      INTEGER MASKSZ,MSPORT,SSPORT,GPORT,GBOOT,G_TASKID,SRPORT
      COMMON /MTINY/ MYNUM,NSLAV,NTASK,ISLMIN(128),ISLMAX(128)
      COMMON/BENINT/NBENSW,NBENOR,NBENCL,NBEN1,NBEN2,NBEN3,NBEN4,NBEN5
     1 ,NBEN6,NBEN7,NBEN8,NBEN9
      COMMON/PTCCOM/ ICNTLO,ICNTLI,ICNTRO,ICNTRI,ICNMAX
     1      ,IPTCLO(256),IPTCLI(256),IPTCRO(256),IPTCRI(256)
C
         COMMON/COMTIM/ SNTIME(20,20),SNTDIF(20,20),TLOOP(20)
         DIMENSION ZTARR(2)
         DATA        ICLASS,   ISUB/2,   1/
                                       CALL EXPERT(ICLASS,ISUB,1)
         IF(NLOMT2(ISUB))RETURN
C
C        IF(NSTEP .EQ. 100) CALL KXPON
C        IF(NSTEP .EQ. 100) CALL KEPON
C        IF(NSTEP .EQ. 100) CALL KCPON
C  Parasoft Express User Event to identify start of timestep
C        CALL KEPADD(1,NSTEP)
C
C-----------------------------------------------------------------------
C  SNTIME(TIMPNT,MYNUM+1) time point TIMPNT, processor number MYNUM
C  1-proc calc is in MYNUM=NSLAV, times in position 20
C
         IF(MYNUM .EQ. NSLAV) THEN 
           INUM1=20 
         ELSE 
           INUM1=MYNUM+1 
           IF(INUM1 .GT. 19) INUM1=19
         ENDIF 
C 
C  Time point 1
         CALL SECOWA(SNTIME(1,INUM1),ZTARR)
         NSTEP =NSTEP + 1
         REALTN=NSTEP*DT*1.0E9
C-----------------------------------------------------------------------
CL              1.         Move and find new current densities
C
CL                  1.1      clear & add transverse current adjustment
         ZJCOEF=TCACO/CD0
C        CALL SETCUR(B3,BAV,CD1,CD2,N1MAX,LMAXP2,MMAXP2,RINNER,
C    +   ZJCOEF,LINDEX,MINDEX,NDIRN,NBCTYP,NBSEG2)
C
CL                  1.2      find particle currents
C     Advance positions from n-1 to n, find j at n-1/2
C
         NPOLD=NP
         ENKINO=ENKIN + EKFLXI
         IF(NBENSW .EQ. 0 .AND. NBENOR .EQ. 0) THEN
C  Erase old positions (i.e. plot as black)
           NBENCL=0 
           CALL SCAPLT(2) 
C  Redraw electrodes every ten steps to repair particle damage
      IF(MOD(NSTEP,10) .EQ. 0 .AND. MYNUM .EQ. NSLAV
     1    .AND. NBEN1 .EQ. 1) CALL SCAPLT(1)
         ENDIF 
C-----------------------------------------------------------------------
C  Time point 2
         CALL SECOWA(SNTIME(2,INUM1),ZTARR)
         CALL MOVCUR(Q1,Q2,P1,P2,NP,ENKIN,EKFLXO,CD1,CD2,NG,N1MAX,
     +               LMAXP2,MMAXP2,C1,DX1OX2,NBCTYP,NBSEG2)
C-----------------------------------------------------------------------
C  Time point 20
         CALL SECOWA(SNTIME(20,INUM1),ZTARR)
         IF(NBENSW .EQ. 0) THEN
C  Plot new positions (i.e. plot in colour)
           NBENCL=1 
           CALL SCAPLT(2) 
         ENDIF 
C-----------------------------------------------------------------------
C  Time point 3
         CALL SECOWA(SNTIME(3,INUM1),ZTARR)
         NPOLD=NP-NPOLD
C  Exchange edge particles, and re-initialise particle exchange
         CALL SNXPTC(1,IDUM,ZDUM)
C-----------------------------------------------------------------------
C  Time point 12
         CALL SECOWA(SNTIME(12,INUM1),ZTARR)
C
CL                  1.3      normalise current
C  Calculate skip limits for region
         JL1M=ISLMIN(MYNUM+1)-1
         JL2P=ISLMAX(MYNUM+1)+1
         IF(JL1M .LT. 1) JL1M=1
         IF(JL2P .GT. LMAXP2) JL2P=LMAXP2
C
         DO 131 JM = 1,MMAXP2
C        DO 130 JL = 1,LMAXP2
         DO 130 JL = Jl1M,JL2P
         CD1(JL,JM)=CD1(JL,JM)*CD0
         CD2(JL,JM)=CD2(JL,JM)*CD0
  130    CONTINUE
  131    CONTINUE
C
C-----------------------------------------------------------------------
C  Time point 13
         CALL SECOWA(SNTIME(13,INUM1),ZTARR)
C
C  Exchange edge current densities
C        CALL SNXCD  -  Replaced by next 2 lines
         CALL SNXFLD(CD2,N1MAX,1,0)
         CALL SNXFLD(CD2,N1MAX,0,1)
C
C-----------------------------------------------------------------------
C  Time point 14
         CALL SECOWA(SNTIME(14,INUM1),ZTARR)
C
C  Plot C1,C2
C        CALL SNPFLD(2)
C
C-----------------------------------------------------------------------
CL              2.         Update electric and magnetic fields
C
CL                  2.1      return current or applied E ramp up
C     return currents for periodic coax only
         IF(NCASE.EQ.1.AND.NBCE.EQ.1) THEN
         ZNUM=0.0
         ZDEN=0.0
         ZR15=RINNER-1.5
         DO 211 JM=2,MMAX
         ZRADI=1.0/(JM+ZR15)
         ZCSUM=0.0
         DO 210 JL=2,LMAXP
         ZCSUM=ZCSUM+CD2(JL,JM)
  210    CONTINUE
         ZNUM=ZNUM+ZCSUM*ZRADI
         ZDEN=ZDEN+ZRADI
  211    CONTINUE
         ZIRET=ZNUM/ZDEN/(LMAX-1)
         DO 212 JM=2,MMAX
         DO 212 JL=2,LMAX
         CD2(JL,JM)=CD2(JL,JM)-ZIRET
  212    CONTINUE
         CALL RVAR(8HZIRET   ,ZIRET)
         CALL RVAR(8HZITOT   ,ZIRET*(LMAX-1)*SCI2)
         ELSE
C     Applied E ramp at lhs
         IRAMP=10.0/C1
C     SPECIAL TCH CHANGE TO ALLOW APPLIED FREQ TO VOLTAG ACROSS LHS
         EAPLY=EAPLYD*COS(2.*API*TONS7*1.E9*NSTEP*DT)
         IF(IRAMP.GT.0) CALL ERAMP(EAPLY,RINNER,NSTEP,IRAMP,NBSEG2,
     +                             LINDEX,MINDEX,NDIRN,NBCTYP,EBEXT)
         ENDIF
C
CL                  2.2      save old values
C     B fields
         DO 220 JM=1,MMAXP2
C        DO 220 JL=1,LMAXP2
C skip
         DO 220 JL=JL1M,JL2P
  220    BAV(JL,JM)=B3(JL,JM)
C     Energies
         ENEL1O=ENEL1
         ENEL2O=ENEL2
         ENMAGO=ENMAG
         ENTOTO=ENTOT
C
C-----------------------------------------------------------------------
C  Time point 4
         CALL SECOWA(SNTIME(4,INUM1),ZTARR)
CL                  2.3      update E from n-1 to n and B to n+1/2
         CALL STEPEB(E1,E2,B3,CD1,CD2,NG,N1MAX,LMAXP2,MMAXP2,
     +   C1,C2,BAPLYD,LINDEX,MINDEX,NDIRN,NBCTYP,
     +   EBEXT,SURIC,EPOYNT,CCTSRC,ASCUR,NBSEG2,
     +   ENEL1,ENEL2,ENMAG,EJ1POW,EJ2POW,RINNER)
C
C-----------------------------------------------------------------------
C  Time point 5
         CALL SECOWA(SNTIME(5,INUM1),ZTARR)
C
C  Plot E1,E2,B3
C        CALL SNPFLD(1)
C
C-----------------------------------------------------------------------
CL                  2.4      update energy & power accumulators
         TPOYP=0.0
         DO 240 JSEG=4,NBSEG2
         TPOYP=TPOYP+EPOYNT(JSEG)
  240    CONTINUE
C
         ENEJ1=ENEJ1+EJ1POW
         ENEJ2=ENEJ2+EJ2POW
         ENPOYT=ENPOYT+TPOYP
         ENEJT=ENEJ1+ENEJ2
         ENTOT=ENEL1+ENEL2+ENMAG+ENEJT
C
         E1POW=ENEL1-ENEL1O
         E2POW=ENEL2-ENEL2O
         B3POW=ENMAG-ENMAGO
         EJPOWM=EJ1POW+EJ2POW
C
CL                  2.5      find BAV
         DO 250 JM=1,MMAXP2
C        DO 250 JL=1,LMAXP2
C skip
         DO 250 JL=JL1M,JL2P
  250    BAV(JL,JM)=(BAV(JL,JM)+B3(JL,JM))*0.5
C
CL                  2.6      field extrapolation for particles
         CALL BEXTRP
C-----------------------------------------------------------------------
C  Time point 6
         CALL SECOWA(SNTIME(6,INUM1),ZTARR)
C
C        CALL SNXBAV   Replaced by next line
         CALL SNXFLD(BAV,N1MAX,0,0)
C
C-----------------------------------------------------------------------
C  Time point 17
         CALL SECOWA(SNTIME(17,INUM1),ZTARR)
C
C-----------------------------------------------------------------------
CL              3.         Electron emission from cathode
C
C     compute surface particle charge
         CALL SURDEN(Q1,Q2,NP,NG,N1MAX,LINDEX,MINDEX,
     +                     NDIRN,NBCTYP,RHOC,NBSEG2)
C-----------------------------------------------------------------------
C  Time point 7
         CALL SECOWA(SNTIME(7,INUM1),ZTARR)
C
C     emit electrons from emitting surfaces
         NPNEW=NP
         INPOL=NP
         CALL EMITEL(Q1,Q2,P1,P2,NP,NPMAX,
     +              E1,E2,N1MAX,EEMITD,CD0,C1,C2,LINDEX,
     +              MINDEX,NDIRN,NBCTYP,
     +              NCOLOR,RHOC,ENSUR,NBSEG2,RINNER,EKFLXI)
         NPNEW=NP-NPNEW
C-----------------------------------------------------------------------
C  Time point 8
         CALL SECOWA(SNTIME(8,INUM1),ZTARR)
C
C-----------------------------------------------------------------------
CL              4.         Update Momemtum
C
C     update momenta from n-1/2 to n+1/2
C
         EJPOWP=EJPWPN
         CALL ACCEL(Q1,Q2,P1,P2,INPOL,E1,E2,BAV,EJPWPN,N1MAX)
         EJENP=EJENP+EJPOWP
C-----------------------------------------------------------------------
C  Time point 9
         CALL SECOWA(SNTIME(9,INUM1),ZTARR)
C
CL                  4.1      clear E, B and J on boundary surface
C.NOTE:  This routine uses boundary tables
C.       It is assumed the first two boundary segments are repeated
C.       the end of the table. This allows look ahead (or behind) t
C.       deal with corners. Look ahead (behind) by one element
C.       is needed by this routine.
C.
         CALL EBJCLS(E1,E2,BAV,CD1,CD2,N1MAX,LMAXP2,MMAXP2,
     +                    NBSEG2,LINDEX,MINDEX,NDIRN)
C.
C. Output: E1,E2,CD1,CD2 zeroed in boundary region
C
C-----------------------------------------------------------------------
C  Time point 10
         CALL SECOWA(SNTIME(10,INUM1),ZTARR)
         IF(NBEN4 .NE. 0 .OR. MYNUM .NE. NSLAV) CALL TMANAL
         END
C
         SUBROUTINE OUTPUT(K)
C
C 3.1  Control The Output
C
C---------------------------------------------------------------------
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN


C       INCLUDE 'COMDDP.inc'
C--------------------------------------------------------------------
CL                  C1.9.    DEVELOPMENT AND DIAGNOSTIC PARAMETERS
       COMMON/COMDDP/
     I   MAXDUM,   MXDUMP,   NADUMP,   NCLASS,   NPDUMP,   NPOINT,
     I   NSUB,     NVDUMP,
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       LOGICAL
     L   NLCHED,   NLHEAD,   NLOMT1,   NLOMT2,   NLOMT3,   NLREPT
       DIMENSION
     I   NADUMP(20),         NPDUMP(20),         NVDUMP(20),
     L   NLHEAD(9),          NLOMT1(50),         NLOMT2(50),
     L   NLOMT3(50)
C       INCLUDE 'COMCON.inc'
C---------------------------------------------------------------------
CL                  C2.1     Physical Constants
       COMMON/COMCON/
     R   API   ,   BOLTZK,   CLIGHT,   ELCHAG,   ELMASS,   EMU0  ,
     R   EOVERM,   EPS0
C       INCLUDE 'COMSTT.inc'
C---------------------------------------------------------------------
CL                  C2.2     Physical State
       COMMON/COMSTT/
     R   B3    ,   BAV   ,   CD1   ,   CD2   ,   E1    ,   E2    ,
     R   P1    ,   P2    ,   Q1    ,   Q2    ,   REALTN,   TIMRUN
       DIMENSION
     R   B3(605,40),        BAV(605,40),       CD1(605,40),
     R   CD2(605,40),       E1(605,40),        E2(605,40),
     R   P1(20000),          P2(20000),          Q1(20000),
     R   Q2(20000)
C       INCLUDE 'COMDEV.inc'
C---------------------------------------------------------------------
CL                  C2.3     Device description
       COMMON/COMDEV/
     R   B3RHS ,   B3RHSD,   BAPLY ,   BAPLYD,   CAVEAM,   CAVEFR,
     R   CAVIC ,   CAVRES,   CAVTC ,   DEPTH ,   DEVHYT,   DEVLEN,
     R   DEVRAD,   EAPLYD,   EEMIT ,   EEMITD,   ENIT  ,   ENITD ,
     R   GAP   ,   RESAX ,   RESE  ,   RESN  ,   RESS  ,   RESW  ,
     R   RINNER,   SPACE ,   VOLTAG,   WIDTH ,
     I   LCATH ,   LCAV  ,   LLEFT ,   LWVANE,   MDEPTH,   MGAP  ,
     I   NBCAX ,   NBCCAV,   NBCE  ,   NBCN  ,   NBCS  ,   NBCW  ,
     I   NCAV  ,   NDEV
       DIMENSION
     R   CAVEAM(100),        CAVEFR(100),        CAVIC(4,100),
     R   CAVRES(100),        CAVTC(100),
     I   NBCCAV(100)
C       INCLUDE 'COMDIA.inc'
C---------------------------------------------------------------------
CL                  C2.4     Physical Diagnostics
       COMMON/COMDIA/
     R   B3POW ,   BOUT  ,   CAVPOY,   E1POW ,   E2POW ,   EJ1POW,
     R   EJ2POW,   EJENP ,   EJPOWM,   EJPOWP,   EJPWPN,   EKFLXI,
     R   EKFLXO,   ENEJ1 ,   ENEJ2 ,   ENEL1 ,   ENEL1O,   ENEL2 ,
     R   ENEL2O,   ENKIN ,   ENKINO,   ENMAG ,   ENMAGO,   ENPOYT,
     R   ENTOT ,   ENTOTO,   EOUT  ,   TOTM1 ,   TOTM2 ,   TPOYP ,
     I   LCAVEN,   LCAVST,   NPNEW ,   NPOLD
       DIMENSION
     R   BOUT(100),          CAVPOY(100),        EOUT(100),
     I   LCAVEN(100),        LCAVST(100)
C       INCLUDE 'COMNUM.inc'
C---------------------------------------------------------------------
CL                  C3.1     Numerical Parameters
       COMMON/COMNUM/
     R   C1    ,   C2    ,   CD0   ,   CURANT,   DT    ,   DX1   ,
     R   DX1DX2,   DX1OX2,   DX2   ,   DX2OX1,   ELPERP,   HLFDX1,
     R   HLFDX2,   TCACO ,
     I   LMAX  ,   LMAXP ,   LMAXP2,   MMAX  ,   MMAXP ,   MMAXP2,
     I   NEMIT ,   NP
C       INCLUDE 'COMSCA.inc'
C---------------------------------------------------------------------
CL                  C3.2     Scaling Factors
       COMMON/COMSCA/
     R   SCB3  ,   SCE1  ,   SCE2  ,   SCEMEN,   SCEPOW,   SCI1  ,
     R   SCI2  ,   SCIP  ,   SCKE  ,   SCKPOW,   SCP1  ,   SCP2  ,
     R   SCV1  ,   SCV2  ,   SCX1  ,   SCX2
C       INCLUDE 'COMHOK.inc'
C---------------------------------------------------------------------
CL                  C4.1     Housekeeping
       COMMON/COMHOK/
     R   TIMECP,   XPSMAX,   XPSMIN,   YPSMAX,   YPSMIN,
     I   N1MAX ,   N2MAX ,   NCASE ,   NGMAX ,   NOSEP ,   NPDUM ,
     I   NPMAX ,   NSRC  ,   NXDUM ,   NYDUM
       DIMENSION
     R   TIMECP(32)
C       INCLUDE 'COMGEO.inc'
C---------------------------------------------------------------------
CL                  C4.2     Device boundary data
       COMMON/COMGEO/
     R   ASCUR ,   CCTSRC,   EBEXT ,   ELSCUR,   ENSUR ,   EPOYNT,
     R   RHOC  ,   SURCHG,   SURIC ,
     I   LINDEX,   MINDEX,   NBCTYP,   NBDIM ,   NBSEG2,   NCOLOR,
     I   NDIRN ,   NG
       DIMENSION
     R   ASCUR(1500),        CCTSRC(1500),       EBEXT(2,1500),
     R   ELSCUR(1500),       ENSUR(1500),        EPOYNT(1500),
     R   RHOC(1500),         SURCHG(1500),       SURIC(4,1500),
     I   LINDEX(1500),       MINDEX(1500),       NBCTYP(1500),
     I   NCOLOR(1500),       NDIRN(1500),        NG(605,40)
C       INCLUDE 'COMOUT.inc'
C---------------------------------------------------------------------
CL                  C5.1     Output Variables
       COMMON/COMOUT/
     R   BCNMAX,   BCNMIN,   BCVMAX,   BCVMIN,   CUAMAX,   CUAMIN,
     R   CUEMAX,   CUEMIN,   ECVMAX,   ECVMIN,   TONS1 ,   TONS2 ,
     R   TONS3 ,   TONS4 ,   TONS5 ,   TONS6 ,   TONS7 ,
     I   NBCHT ,   NOPSEL,   NS1   ,   NS2   ,   NS3   ,   NS4   ,
     I   NS5   ,   NS6   ,   NS7
C---------------------------------------------------------------------
      COMMON /MTINY/ MYNUM,NSLAV,NTASK,ISLMIN(128),ISLMAX(128)
      COMMON/BENINT/NBENSW,NBENOR,NBENCL,NBEN1,NBEN2,NBEN3,NBEN4,NBEN5
     1 ,NBEN6,NBEN7,NBEN8,NBEN9
       DATA        ICLASS,   ISUB/3,   1/
                                       CALL EXPERT(ICLASS,ISUB,1)
         IF(NLOMT3(ISUB)) RETURN
C---------------------------------------------------------------------
C
         GO TO (100,200,300),K
C
C---------------------------------------------------------------------
CL              1.         Initialisation Output
C
  100    CONTINUE
C
         IF(.TRUE.) THEN
         IF(NBENSW .LT. 1 .OR. NBENSW .GT. 4 )THEN
         IF(NBEN1 .EQ. 1 .AND. MYNUM .EQ. NSLAV) CALL SCAPLT(1)
         ENDIF
C  For benchmarking leave out initial printout
C  Start of benchmark timing of main timestep loop
         CALL SNXPTC(0,IDUM,DUM)
         CALL BENTIM(1)
         RETURN
         ENDIF
CL                  1.1      graphical output initialisation
         CALL GHINIT
CL                  1.2      General Output
         CALL EAVCAV(1)
         CALL ENPOW(1)
         CALL CURBOD(1)
         CALL CLIST(0,0)
         CALL ARRAYS(2,3)
         CALL SURDMI('NBCTYP  ',NBCTYP,LINDEX,MINDEX,NDIRN,NBSEG2)
         CALL SURDMI('NCOLOR  ',NCOLOR,LINDEX,MINDEX,NDIRN,NBSEG2)
C        CALL SURDMR('SURIC   ',SURIC ,LINDEX,MINDEX,NDIRN,NBSEG2)
         CALL WINDOI('NG      ',NG,1,1,N1MAX,N2MAX)
         CALL RUNTIM
C
CL                  1.3      Output selection 1
         IF(NOPSEL.NE.1) GO TO 140
C
C     Graphical snapshot output initialisation
C     ========================================
C
C     density of particles scatter plot
             CALL SCAPLT(1)
C
C         magnetic field contour plot
             CALL B3CON(1)
C
C         magnetic fields at top of cavity
                 CALL B3CAVP(1)
C
C         electric fields at bottom of cavity
                 CALL E1CAVP(1)
C
C         electron current into diode end
                 CALL IPENDP(1)
C
C         electron current into anode bottom
                 CALL IPTOPP(1)
         RETURN
C
CL                  1.4      Output Selection 2

  140    CONTINUE
         IF(NOPSEL.NE.2) GO TO 150
C     NOPSEL=2 traces the orbits of selected test particles
         CALL ORBIT(1)
         RETURN
C
CL                  1.5      Output Selection 3
  150    CONTINUE
         IF(NOPSEL.NE.3) GO TO 160
C
C     Graphical snapshot output initialisation
C     ========================================
C
C     density of particles scatter plot
             CALL SCAPLT(1)
C
C         magnetic field contour plot
             CALL B3CON(1)
C
         RETURN
C
CL                  1.6      Further Output Selections
  160    CONTINUE
                                       CALL EXPERT(ICLASS,ISUB,2)
C
         RETURN
C
C---------------------------------------------------------------------
CL              2.         Periodic Output
C
  200    CONTINUE
         CALL BENTIM(2)
C
CL                  2.1      General Output
C TIME SERIES OUTPUT EVERY TONS1 ns
         IF(MOD(REALTN,TONS1).LE.DT*1.E9) THEN
C     time history file of cavity fields 
         CALL EAVCAV(2)
C     energy and power histories
         CALL ENPOW(2)
C     boundary currents
         CALL CURBOD(2)
         ENDIF
C
C
CL                  2.2      Output Selection 1
         IF(NOPSEL.EQ.1) THEN
C
C     lineprinter output summary
C     ==========================
C
C       currents
                 IF(MOD(REALTN,TONS2).LE.DT*1.E9)CALL CURROP
C
C       power and energy
                 IF(MOD(NSTEP,NS1).EQ.0)THEN
         CALL ENPWPP
         CALL ENPWOP
         ENDIF
C
C       charge conservation check
C       NOTE GAUSOP destroys contents of CD1
                 IF(MOD(NSTEP,NS2).EQ.0)CALL GAUSOP
C
C     Graphical snapshot output sequences
C     ===================================
C
C  AVERAGE ANODE CURRENT OVER 5 TIMESTEPS
C
         IF(MOD(REALTN,TONS3).LT.DT*5.E9) CALL IPENDP(3)
C
         DO 220 L=2,4
         IF(MOD(REALTN,TONS3).LT.DT*1.E9*FLOAT(L)) THEN
         CALL IPENDP(4)
         GOTO 221
         ENDIF
 220     CONTINUE
 221     CONTINUE
         IF(MOD(REALTN,TONS3).LE.DT*1.E9) THEN
C
C     density of particles scatter plot
             CALL FRAML1(REALTN,NSTEP,CHREFN)
             CALL SCAPLT(2)
C
C         magnetic field contour plot
             CALL FRAMEL(REALTN,NSTEP,CHREFN)
             CALL COULST(1)
             CALL B3CON(2)
             CALL FRAML1(REALTN,NSTEP,CHREFN)
             CALL COULST(0)
             CALL B3CON(3)
C
C         magnetic fields at top of cavity
             CALL FRAMEL(REALTN,NSTEP,CHREFN)
                 CALL B3CAVP(2)
C
C         electric fields at bottom of cavity
             CALL FRAMEL(REALTN,NSTEP,CHREFN)
                 CALL E1CAVP(2)
C         electron current into diode end
             CALL FRAMEL(REALTN,NSTEP,CHREFN)
                 CALL IPENDP(2)
C
C         electron current into anode bottom
             CALL FRAMEL(REALTN,NSTEP,CHREFN)
                 CALL IPTOPP(2)
C   FFT OF E1
C
             CALL FRAMEL(REALTN,NSTEP,CHREFN)
             CALL E1FFT
             END IF
           END IF
C
CL                  2.3      Output Selection 2
         IF(NOPSEL.EQ.2) THEN
C     test particle tracking
C        WRITE(NOUT,9009) NSTEP,Q1(1),Q2(1),P1(1),P2(1),
C    +         P1(1)**2+P2(1)**2
C9009    FORMAT(I5,5(1X,G12.5))
           CALL ORBIT(2)
           END IF
C
CL                  2.4      Output Selection 3
C
         IF(NOPSEL.EQ.3) THEN
C        IF(MOD(REALTN,TONS3).LE.DT*1.E9) THEN
C
C     Graphical snapshot output sequences
C     ===================================
C
C        IF(NSTEP .GE. 110) THEN
C     density of particles scatter plot
C            CALL FRAML1(REALTN,NSTEP,CHREFN)
C  SCAPLT now called in STEPON to allow movie display
C            CALL SCAPLT(2)
C            IF(NSTEP .GE. 55 .AND. NSTEP .LE. 60) CALL SCAPLT(2)
C
C         magnetic field contour plot
C            CALL FRAML1(REALTN,NSTEP,CHREFN)
C            CALL B3CON(3)
C             END IF
           END IF
CL                  2.5      Further Output Selections
                                       CALL EXPERT(ICLASS,ISUB,3)
         IF(NOPSEL.EQ.4) THEN
         CALL WINDOR('E1      ',E1,2,2,N1MAX,N2MAX)
         CALL WINDOR('E2      ',E2,2,2,N1MAX,N2MAX)
         CALL WINDOR('B3      ',B3,2,2,N1MAX,N2MAX)
         CALL WINDOR('CD1     ',CD1,2,2,N1MAX,N2MAX)
         CALL WINDOR('CD2     ',CD2,2,2,N1MAX,N2MAX)
         CALL SURDMR('RHOC    ',RHOC  ,LINDEX,MINDEX,NDIRN,NBSEG2)
         CALL SURDMR('ENSUR   ',ENSUR ,LINDEX,MINDEX,NDIRN,NBSEG2)
         END IF
         RETURN
C
C---------------------------------------------------------------------
CL              3.         Final Output
C
  300    CONTINUE
C  End benchmark timing of main calculational loop
         CALL BENTIM(3)
C
C
CL                  3.1      General Output
         CALL EAVCAV(3)
         CALL ENPOW(3)
         CALL CURBOD(3)
C
CL                  3.2      Output Selection 1
         IF(NOPSEL.EQ.1) THEN
                   CALL GAUSOP
           CALL GREND
           END IF
C
CL                  3.3      output Selection 2
         IF(NOPSEL.EQ.2) THEN
           CALL ORBIT(3)
           END IF
C
CL                  3.4      Output Selection 3
         IF(NOPSEL.EQ.3) THEN
           CALL GREND
           END IF
C
CL                  3.5      Further Output Selections
                                       CALL EXPERT(ICLASS,ISUB,4)
C---------------------------------------------------------------------
         END
C
       SUBROUTINE SNXE0
C  Make tangential E-fiels zero, prior to EMITEL
C
C       INCLUDE 'COMSTT.inc'
C---------------------------------------------------------------------
CL                  C2.2     Physical State
       COMMON/COMSTT/
     R   B3    ,   BAV   ,   CD1   ,   CD2   ,   E1    ,   E2    ,
     R   P1    ,   P2    ,   Q1    ,   Q2    ,   REALTN,   TIMRUN
       DIMENSION
     R   B3(605,40),        BAV(605,40),       CD1(605,40),
     R   CD2(605,40),       E1(605,40),        E2(605,40),
     R   P1(20000),          P2(20000),          Q1(20000),
     R   Q2(20000)
C ---------------------------------------------------------------------
CL                  C4.2     Device boundary data
       COMMON/COMGEO/
     R   ASCUR ,   CCTSRC,   EBEXT ,   ELSCUR,   ENSUR ,   EPOYNT,
     R   RHOC  ,   SURCHG,   SURIC ,
     I   LINDEX,   MINDEX,   NBCTYP,   NBDIM ,   NBSEG2,   NCOLOR,
     I   NDIRN ,   NG
       DIMENSION
     R   ASCUR(1500),        CCTSRC(1500),       EBEXT(2,1500),
     R   ELSCUR(1500),       ENSUR(1500),        EPOYNT(1500),
     R   RHOC(1500),         SURCHG(1500),       SURIC(4,1500),
     I   LINDEX(1500),       MINDEX(1500),       NBCTYP(1500),
     I   NCOLOR(1500),       NDIRN(1500),        NG(605,40)
C ---------------------------------------------------------------------
C
       DO 130 JSEG=3,NBSEG2-1
C
         IF(NBCTYP(JSEG) .EQ. 0) THEN
           IDC=NDIRN(JSEG)
           IL=LINDEX(JSEG)
           IM=MINDEX(JSEG)
           IF(IDC .EQ. 4)  E1(IL,IM)=0.0
           IF(IDC .EQ. 1)  E2(IL,IM)=0.0
           IF(IDC .EQ. 2)  E1(IL,IM+1)=0.0
           IF(IDC .EQ. 3)  E2(IL+1,IM)=0.0
         ENDIF
C
 130   CONTINUE
C
       END
C
C
         SUBROUTINE RUNTIM
C
C U.12 UPDATE CPU TIME (SECS) AND PRINT IT
C
C       INCLUDE 'COMBAS.inc'
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C       INCLUDE 'CHABAS.inc'
C---------------------------------------------------------------------
CL                  C1.2.    BASIC SYSTEM CHARACTER PARAMETERS
C     CHABAS INTRODUCES CHARACTER TYPE FOR LABELS IN FORTRAN77
       CHARACTER*48
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16
       CHARACTER*8
     +   CHRDAT,   CHRTIM,   CHDATO,   CHTIMO,   CHREFN
       COMMON/CHABAS/
     +   CHLAB1,   CHLAB2,   CHLAB3,   CHLAB4,   CHLAB5,   CHLAB6,
     +   CHLAB7,   CHLAB8,   CHLAB9,   CHLB10,   CHLB11,   CHLB12,
     +   CHLB13,   CHLB14,   CHLB15,   CHLB16,   CHRDAT,   CHRTIM,
     +   CHDATO,   CHTIMO,   CHREFN
C	
      COMMON /MTINY/ MYNUM,NSLAV,NTASK,ISLMIN(128),ISLMAX(128)
C
       DIMENSION   ZTAR(2)
C-----------------------------------------------------------------------
C
         CALL SECOWA(ZTIME,ZTAR)
         CPTIME = ZTIME-STIME
C        WRITE(NOUT,9001) NSTEP
C        WRITE(NOUT,9000) CPTIME
C  Print final time also to screen
C        IOUT=6
C        WRITE(IOUT,9001) NSTEP
C        WRITE(IOUT,9000) CPTIME
C
         RETURN
C9000    FORMAT(5X,'Elapse time since job start =',1PE12.4,' secs:-',/)
C    +          5X,'  equals: user   time =',1PE12.4,' secs',/,
C    +          5X,'  plus    system time =',1PE12.4,' secs')
C9001    FORMAT(5X,/,'After ',I6,' timesteps',/)
         END
C
C
C  ................................. Dummy GHOST and GRID routines  ..........
C
       SUBROUTINE lincol
       END
       SUBROUTINE normal
       END
       SUBROUTINE hsv
       END
       SUBROUTINE hls
       END
       SUBROUTINE plotcs
       END
       SUBROUTINE pcsend
       END
       SUBROUTINE plotnf
       END
       SUBROUTINE picnow
       END
       SUBROUTINE pspace
       END
       SUBROUTINE supfix
       END
       SUBROUTINE scayli
       END
       SUBROUTINE map
       END
       SUBROUTINE typeni
       END
       SUBROUTINE typenf
       END
       SUBROUTINE typecs
       END
       SUBROUTINE full
       END
       SUBROUTINE frame
       END
       SUBROUTINE grend
       END
       SUBROUTINE broken
       END
       SUBROUTINE baccol
       END
       SUBROUTINE border
       END
       SUBROUTINE mapyl
       END
       SUBROUTINE colset
       END
       SUBROUTINE ctrobl
       END
       SUBROUTINE crlnfd
       END
       SUBROUTINE cspace
       END
       SUBROUTINE ctrfnt
       END
       SUBROUTINE ctrmag
       END
       SUBROUTINE enqchr
       END
       SUBROUTINE enqmap
       END
       SUBROUTINE enqcon
       END
       SUBROUTINE paper
       END
       SUBROUTINE place
       END
       SUBROUTINE filnam
       END
       SUBROUTINE filcol
       END
       SUBROUTINE g0sizs
       END
       SUBROUTINE g0play
       END
       SUBROUTINE g0plax
       END
       SUBROUTINE g0tick
       END
       SUBROUTINE g3link
       END
       SUBROUTINE g0mesg
       END
       SUBROUTINE gpstop
       END
       SUBROUTINE space
       END
       SUBROUTINE italic
       END
       SUBROUTINE thick
       END
C %%%%%%%%%%   Simple plot routines for LPM1 on Supernode   %%%%%%%%%%
C
       FUNCTION IXPLT(PX)
C---------------------------------------------------------------------
CL                  C3.1     Numerical Parameters
       COMMON/COMNUM/
     R   C1    ,   C2    ,   CD0   ,   CURANT,   DT    ,   DX1   ,
     R   DX1DX2,   DX1OX2,   DX2   ,   DX2OX1,   ELPERP,   HLFDX1,
     R   HLFDX2,   TCACO ,
     I   LMAX  ,   LMAXP ,   LMAXP2,   MMAX  ,   MMAXP ,   MMAXP2,
     I   NEMIT ,   NP
       IXPLT=1024.0*PX/LMAX
       IF(IXPLT .GT. 1023) IXPLT=1023
       IF(IXPLT .LT. 0) IXPLT=0
       END
       FUNCTION IYPLT(PY)
       COMMON/COMNUM/
     R   C1    ,   C2    ,   CD0   ,   CURANT,   DT    ,   DX1   ,
     R   DX1DX2,   DX1OX2,   DX2   ,   DX2OX1,   ELPERP,   HLFDX1,
     R   HLFDX2,   TCACO ,
     I   LMAX  ,   LMAXP ,   LMAXP2,   MMAX  ,   MMAXP ,   MMAXP2,
     I   NEMIT ,   NP
       COMMON /MTINY/ MYNUM,NSLAV,NTASK,ISLMIN(128),ISLMAX(128)
      COMMON/BENINT/NBENSW,NBENOR,NBENCL,NBEN1,NBEN2,NBEN3,NBEN4,NBEN5
C  For full display, the default
       ZHITE=850.0
       IYPLT=ZHITE*(1.0-PY/MMAX)
       IF(NBEN1 .EQ. 1) THEN
C  For split display
         ZHITE=450.0
         ZTOP=574.0
         IF(MYNUM .NE. NSLAV) IYPLT=ZHITE*(1.0-PY/MMAX)
         IF(MYNUM .EQ. NSLAV) IYPLT=ZHITE*(1.0-PY/MMAX)+ZTOP
       ENDIF
       IF(IYPLT .GT. 1023) IYPLT=1023
       IF(IYPLT .LT. 0) IYPLT=0
       END
       SUBROUTINE plotnc(PX,PY,K)
       COMMON /GRAFIX/ MASKSZ,MSPORT,SSPORT,GPORT,GBOOT,G_TASKID,
     1        IBLK,IWHT,IRED,IGRN,IBLU,IYEL,IMAG,ICYA,SRPORT
       INTEGER MASKSZ,MSPORT,SSPORT,GPORT,GBOOT,G_TASKID,SRPORT
       COMMON /GHOST/IXL,IYL,ICOL
       COMMON /MTINY/ MYNUM,NSLAV,NTASK,ISLMIN(128),ISLMAX(128)
      COMMON/BENINT/NBENSW,NBENOR,NBENCL,NBEN1,NBEN2,NBEN3,NBEN4,NBEN5
C
      IF(NBEN1 .EQ. 0 .AND. MYNUM .EQ. NSLAV) RETURN
C
      IMOD=MOD(MYNUM,4)
      IF(IMOD .EQ. 0) ICOL=IWHT
      IF(IMOD .EQ. 1) ICOL=IGRN
      IF(IMOD .EQ. 2) ICOL=IYEL
      IF(IMOD .EQ. 3) ICOL=ICYA
      IF(MYNUM .EQ. NSLAV) ICOL=IRED
C
      IF(NBENCL .EQ. 0) ICOL=IBLK
C
       IRAD=1
       IX=IXPLT(PX)
       IY=IYPLT(PY)
C      IF(MYNUM .EQ. 1) IY=IY+155
C      IF(MYNUM .EQ. 2) IY=IY+200
C      IF(MYNUM .EQ. 3) IY=IY+245
C      IF(MYNUM .EQ. NSLAV) IY=IY+300
C      IF(MYNUM .LT. NSLAV .AND. IY .LT. 660) IY=660
C      IF(MYNUM .EQ. NSLAV .AND. IY .LT. 950) IY=950
       CALL DRAW_DISC(IX,IY,IRAD,ICOL)
       END
       SUBROUTINE positn(PX,PY)
       COMMON /GRAFIX/ MASKSZ,MSPORT,SSPORT,GPORT,GBOOT,G_TASKID,
     1        IBLK,IWHT,IRED,IGRN,IBLU,IYEL,IMAG,ICYA,SRPORT
       INTEGER MASKSZ,MSPORT,SSPORT,GPORT,GBOOT,G_TASKID,SRPORT
       COMMON /GHOST/IXL,IYL,ICOL
       IXL=IXPLT(PX)
       IYL=IYPLT(PY)
       END
       SUBROUTINE join(PX,PY)
       COMMON /GRAFIX/ MASKSZ,MSPORT,SSPORT,GPORT,GBOOT,G_TASKID,
     1        IBLK,IWHT,IRED,IGRN,IBLU,IYEL,IMAG,ICYA,SRPORT
       INTEGER MASKSZ,MSPORT,SSPORT,GPORT,GBOOT,G_TASKID,SRPORT
       COMMON /GHOST/IXL,IYL,ICOL
C      IF(.TRUE.)RETURN
       IXN=IXPLT(PX)
       IYN=IYPLT(PY)
       CALL DRAW_LINE(IXL,IYL,IXN,IYN,ICOL)
       IXL=IXN
       IYL=IYN
       END
       SUBROUTINE ptjoin(PX,PY,K1,KSIDES,K3)
       COMMON /GRAFIX/ MASKSZ,MSPORT,SSPORT,GPORT,GBOOT,G_TASKID,
     1        IBLK,IWHT,IRED,IGRN,IBLU,IYEL,IMAG,ICYA,SRPORT
       INTEGER MASKSZ,MSPORT,SSPORT,GPORT,GBOOT,G_TASKID,SRPORT
       COMMON /MTINY/ MYNUM,NSLAV,NTASK,ISLMIN(128),ISLMAX(128)
       COMMON /GHOST/IXL,IYL,ICOL
       DIMENSION PX(1024),PY(1024)
C      IF(.TRUE.)RETURN
       IF(KSIDES .GT. 1024) KSIDES=1024
       IF(KSIDES .LT. 1) KSIDES=1
       IXL=IXPLT(PX(K1))
       IYL=IYPLT(PY(K1))
       IX1=IXL
       IY1=IYL
       ICOL=IYEL
       IF(MYNUM .EQ. NSLAV) ICOL=IYEL
       DO 100 J=K1+1,KSIDES
         IXN=IXPLT(PX(J))
         IYN=IYPLT(PY(J))
         CALL DRAW_LINE(IXL,IYL,IXN,IYN,ICOL)
         IXL=IXN
         IYL=IYN
 100   CONTINUE
C  Join ends if K3 negative
       IF(K3 .LT. 0) CALL DRAW_LINE(IXN,IYN,IX1,IY1,ICOL)
       END
       SUBROUTINE box(PXM,PXU,PYM,PYU)
       COMMON /GRAFIX/ MASKSZ,MSPORT,SSPORT,GPORT,GBOOT,G_TASKID,
     1        IBLK,IWHT,IRED,IGRN,IBLU,IYEL,IMAG,ICYA,SRPORT
       INTEGER MASKSZ,MSPORT,SSPORT,GPORT,GBOOT,G_TASKID,SRPORT
       COMMON /GHOST/IXL,IYL,ICOL
       IF(.TRUE.)RETURN
       IXM=IXPLT(PXM)
       IYM=IYPLT(PYM)
       IXU=IXPLT(PXU)
       IYU=IYPLT(PYU)
       ICOL=IYEL
       CALL DRAW_LINE(IXM,IYM,IXU,IYM,ICOL)
       CALL DRAW_LINE(IXU,IYM,IXU,IYU,ICOL)
       CALL DRAW_LINE(IXU,IYU,IXM,IYU,ICOL)
       CALL DRAW_LINE(IXM,IYU,IXM,IYM,ICOL)
       END
       SUBROUTINE SNPFLD(K)
       COMMON/COMSTT/
     R   B3    ,   BAV   ,   CD1   ,   CD2   ,   E1    ,   E2    ,
     R   P1    ,   P2    ,   Q1    ,   Q2    ,   REALTN,   TIMRUN
       DIMENSION
     R   B3(605,40),        BAV(605,40),       CD1(605,40),
     R   CD2(605,40),       E1(605,40),        E2(605,40),
     R   P1(20000),          P2(20000),          Q1(20000),
     R   Q2(20000)
       COMMON/COMNUM/
     R   C1    ,   C2    ,   CD0   ,   CURANT,   DT    ,   DX1   ,
     R   DX1DX2,   DX1OX2,   DX2   ,   DX2OX1,   ELPERP,   HLFDX1,
     R   HLFDX2,   TCACO ,
     I   LMAX  ,   LMAXP ,   LMAXP2,   MMAX  ,   MMAXP ,   MMAXP2,
     I   NEMIT ,   NP
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C
C---------------------------------------------------------------------
CL                  C4.1     Housekeeping
       COMMON/COMHOK/
     R   TIMECP,   XPSMAX,   XPSMIN,   YPSMAX,   YPSMIN,
     I   N1MAX ,   N2MAX ,   NCASE ,   NGMAX ,   NOSEP ,   NPDUM ,
     I   NPMAX ,   NSRC  ,   NXDUM ,   NYDUM
       DIMENSION
     R   TIMECP(32)
C
       COMMON /GRAFIX/ MASKSZ,MSPORT,SSPORT,GPORT,GBOOT,G_TASKID,
     1        IBLK,IWHT,IRED,IGRN,IBLU,IYEL,IMAG,ICYA,SRPORT
       INTEGER MASKSZ,MSPORT,SSPORT,GPORT,GBOOT,G_TASKID,SRPORT
       COMMON /GHOST/IXL,IYL,ICOL
       COMMON /MTINY/ MYNUM,NSLAV,NTASK,ISLMIN(128),ISLMAX(128)
C
      IF(NSTEP .NE. NRUN) RETURN
C
      IMOD=MOD(MYNUM,4)
      IF(IMOD .EQ. 0) ICOL4=IWHT
      IF(IMOD .EQ. 1) ICOL4=IGRN
      IF(IMOD .EQ. 2) ICOL4=IYEL
      IF(IMOD .EQ. 3) ICOL4=ICYA
      IF(MYNUM .EQ. NSLAV) ICOL4=IRED
C
C  Row number of mesh to be plotted
      JMPLT=12
C  Dimensions of 2D mesh
      JLDIM=N1MAX
      JMDIM=N2MAX
C
      GOTO (1000,2000) K
C
 1000 CONTINUE
       IF(MYNUM .NE. NSLAV) THEN
       IX1=IXPLT(FLOAT(ISLMIN(MYNUM+1))-0.5)
       IY1=IYPLT(FLOAT(MMAX))
       IDIMX=IXPLT(FLOAT(ISLMAX(MYNUM+1))+0.5)
     1      -IXPLT(FLOAT(ISLMIN(MYNUM+1))-0.5)
       IDIMY=500
C      CALL DRAW_BLOCK(IX1,IY1,IDIMX,IDIMY,IBLK)
       ENDIF
C
       ZYPLT=MMAX-2.8
       CALL ROWPLT(E1,JLDIM,JMDIM,JMPLT,LMAX,0.10,ZYPLT)
       ZYPLT=ZYPLT-4.0
       CALL ROWPLT(E2,JLDIM,JMDIM,JMPLT,LMAX,0.1,ZYPLT)
       ZYPLT=ZYPLT-4.0
       CALL ROWPLT(B3,JLDIM,JMDIM,JMPLT,LMAX,0.1,ZYPLT)
       ZYPLT=ZYPLT-4.0
       CALL ROWPLT(BAV,JLDIM,JMDIM,JMPLT,LMAX,0.1,ZYPLT)
      RETURN
C
 2000 CONTINUE
       ZYPLT=MMAX-20.8
       CALL ROWPLT(CD1,JLDIM,JMDIM,JMPLT,LMAX,0.1,ZYPLT)
       ZYPLT=ZYPLT-9.0
       CALL ROWPLT(CD2,JLDIM,JMDIM,JMPLT,LMAX,0.1,ZYPLT)
C
       END
       SUBROUTINE ROWPLT(PFLD,KLDIM,KJDIM,KMPLT,KLMAX,PYMAX,PYPLT)
       DIMENSION PFLD(KLDIM,KJDIM)
       COMMON /GRAFIX/ MASKSZ,MSPORT,SSPORT,GPORT,GBOOT,G_TASKID,
     1        IBLK,IWHT,IRED,IGRN,IBLU,IYEL,IMAG,ICYA,SRPORT
       INTEGER MASKSZ,MSPORT,SSPORT,GPORT,GBOOT,G_TASKID,SRPORT
       COMMON /GHOST/IXL,IYL,ICOL
       COMMON /MTINY/ MYNUM,NSLAV,NTASK,ISLMIN(128),ISLMAX(128)
C
       IF(MYNUM .NE. NSLAV) THEN
         ZX=ISLMIN(MYNUM+1)
         IXL=IXPLT(ZX)
         ZY=PYPLT
         IYL=IYPLT(ZY)
         ZX=ISLMAX(MYNUM+1)
         IXN=IXPLT(ZX)
         ZY=PYPLT
         IYN=IYPLT(ZY)
         CALL DRAW_LINE(IXL,IYL,IXN,IYN,ICOL)
       ENDIF
C
       ZYMAX=PYMAX
C      IMID=(ISLMIN(MYNUM+1)+ISLMAX(MYNUM+1))/2.0
C      ZYMAX=PFLD(IMID,KMPLT)
C      IF(ZYMAX .EQ. 0) ZYMAX=1.0
C
       ZSEP=3.0
       IMIN1=ISLMIN(MYNUM+1)-1
       IXL=IXPLT(FLOAT(IMIN1))
       ZY=ZSEP*PFLD(IMIN1,KMPLT)/ZYMAX
       IF(ZY .GT. ZSEP-0.2) ZY=ZSEP-0.2
       IF(ZY .LT. -ZSEP+0.2) ZY=-ZSEP+0.2
       ZY=ZY+PYPLT
       IYL=IYPLT(ZY)
C      IYL=IYPLT(ZY)-(MYNUM+1)
C      IF(MYNUM .EQ. NSLAV) IYL=IYL-10
C
       JLMIN=ISLMIN(MYNUM+1)
       JLMAX=ISLMAX(MYNUM+1)+1
       DO 100 JL=JLMIN,JLMAX
         ZX=JL
         IXN=IXPLT(ZX)
         ZY=ZSEP*PFLD(JL,KMPLT)/ZYMAX
         IF(ZY .GT. ZSEP-0.2) ZY=ZSEP-0.2
         IF(ZY .LT. -ZSEP+0.2) ZY=-ZSEP+0.2
         ZY=ZY+PYPLT
         IYN=IYPLT(ZY)
C        IYN=IYPLT(ZY)-(MYNUM+1)
C        IF(MYNUM .EQ. NSLAV) IYN=IYN-10
         CALL DRAW_LINE(IXL,IYL,IXN,IYN,ICOL)
         IXL=IXN
         IYL=IYN
 100   CONTINUE
C
       END
C
         SUBROUTINE MARKST(K)
C---------------------------------------------------------------------
CL                  C1.1.    BASIC SYSTEM PARAMETERS
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C
      COMMON /GRAFIX/ MASKSZ,MSPORT,SSPORT,GPORT,GBOOT,G_TASKID,
     1       IBLK,IWHT,IRED,IGRN,IBLU,IYEL,IMAG,ICYA,SRPORT
      INTEGER MASKSZ,MSPORT,SSPORT,GPORT,GBOOT,G_TASKID,SRPORT
      INTEGER ISW/0/
      SAVE ISW,ICOL1,ICOL2,ICOL3,ICOL4
C
      COMMON/BENINT/NBENSW,NBENOR,NBENCL,NBEN1,NBEN2,NBEN3,NBEN4,NBEN5
      COMMON /MTINY/ MYNUM,NSLAV,NTASK,ISLMIN(128),ISLMAX(128)
C
C  DRAW RACETRACK
C
C  Only plot first five processors, except when testing, or 1-proc
      IF(MYNUM .EQ. NSLAV) GOTO 100
      IF(MYNUM .GT. 3 .AND. NBENSW .NE. 99) RETURN
 100  CONTINUE
      IMOD=MOD(MYNUM,4)
      IF(IMOD .EQ. 0) ICOL4=IWHT
      IF(IMOD .EQ. 1) ICOL4=IGRN
      IF(IMOD .EQ. 2) ICOL4=IYEL
      IF(IMOD .EQ. 3) ICOL4=ICYA
      IF(MYNUM .EQ. NSLAV) ICOL4=IRED
C
       IF(K .EQ. 1) THEN
         ICOL1=ICOL4
         ICOL2=IBLK
         ICOL3=ICOL1
         ISW=1
       ENDIF
       N1=MOD(NSTEP,100)
       IX=30+10*N1
       IF(NBEN1 .EQ. 0) THEN
         IY0=870
       ELSE
         IY0=450
       ENDIF
       IY1=IMOD
       IF(MYNUM .EQ. NSLAV) IY1=4
       IY=IY0+20*IY1
       IRAD=5
       CALL DRAW_DISC(IX,IY,IRAD,ICOL3)
       IF (N1 .EQ. 99) THEN
         IF(ICOL3 .EQ. ICOL1) THEN
           ICOL3=ICOL2
         ELSE
           ICOL3=ICOL1
         ENDIF
       ENDIF
C
       END
C
         SUBROUTINE SNXFLD(PFLD,KXMAX,K1,K2)
C  Exchange fields between neighbouring processors in a linear chain
C
C     PFLD(KXMAX,*) - Field array(2D) with values to be exchanged
C
C     K1=0:  replace existing values by those transferred
C     K1=1:  add transferred values to those existing      
C
C     K2=0:  exchanges JMIN   with JMAX+1, JMAX   with JMIN-1
C     K2=1:  exchanges JMIN-1 with JMAX,   JMAX+1 with JMIN
C
       DIMENSION PFLD(KXMAX,*)
C---------------------------------------------------------------------
CL                  C3.1     Numerical Parameters
       COMMON/COMNUM/
     R   C1    ,   C2    ,   CD0   ,   CURANT,   DT    ,   DX1   ,
     R   DX1DX2,   DX1OX2,   DX2   ,   DX2OX1,   ELPERP,   HLFDX1,
     R   HLFDX2,   TCACO ,
     I   LMAX  ,   LMAXP ,   LMAXP2,   MMAX  ,   MMAXP ,   MMAXP2,
     I   NEMIT ,   NP
C---------------------------------------------------------------------
      COMMON /GRAFIX/ MASKSZ,MSPORT,SSPORT,GPORT,GBOOT,G_TASKID,
     1       IBLK,IWHT,IRED,IGRN,IBLU,IYEL,IMAG,ICYA,SRPORT
      INTEGER MASKSZ,MSPORT,SSPORT,GPORT,GBOOT,G_TASKID,SRPORT
      COMMON /MTINY/ MYNUM,NSLAV,NTASK,ISLMIN(128),ISLMAX(128)
      COMMON/BENINT/NBENSW,NBENOR,NBENCL,NBEN1,NBEN2,NBEN3,NBEN4,NBEN5
C
      INTEGER IBUFF(256),IBUFF1(256),IBUFF2(256),IBUFF3(256)
      REAL BUFF(256),BUFF1(256),BUFF2(256),BUFF3(256)
      EQUIVALENCE(IBUFF(1),BUFF(1))
      EQUIVALENCE(IBUFF1(1),BUFF1(1))
      EQUIVALENCE(IBUFF2(1),BUFF2(1))
      EQUIVALENCE(IBUFF3(1),BUFF3(1))
C
       IF(NBEN2 .EQ. 1) RETURN
       IF(MYNUM .EQ. NSLAV) RETURN
C      PRINT *,'Entering SNXFLD'
C      PRINT *,'SSPORT=',SSPORT,' SRPORT=',SRPORT,' MYNUM=',MYNUM
C  Find neighbouring processors and make periodic
C  Master(0) and slaves(1,...,NSLAV) in a ring, which is broken as follows:
C  Processors 0,1,2,...,NSLAV-1 form a finite linear chain:
C     Proc 0 does not send left, and proc NSLAV-1 does not send right
C     Proc NSLAV calculates by itself and does not communicate
C
C  Left processor number
       ILPROC=MYNUM-1
       IF(ILPROC .LT. 0) ILPROC=NSLAV
C  Right processor number
       IRPROC=MYNUM+1
       IF(IRPROC .GT. NSLAV) IRPROC=0
C      PRINT *,'MYNUM =',MYNUM,' NSLAV=',NSLAV,
C    1         ' ILP=',ILPROC,' IRP=',IRPROC
C
       JMIN=ISLMIN(MYNUM+1)
       JMAX=ISLMAX(MYNUM+1)
C      PRINT *,'SNXFLD point 1'
C  ....................................................................
C  Exchange PFLD values
C  Fill buffers before exchange
C  Send left
      IF(MYNUM .GE. 1) THEN
       DO 300 I=1,MMAX
 300     BUFF(I)=PFLD(JMIN-K2,I)
      ENDIF
C  Send right
      IF(MYNUM .NE. NSLAV-1) THEN
       DO 302 I=1,MMAX
 302     BUFF1(I)=PFLD(JMAX+K2,I)
      ENDIF
C      PRINT *,'SNXFLD point 2'
C ############
C  Exchange data with neighbours
      IMAX=0
      IMAX1=0
      IMAX2=0
      IMAX3=0
      IF(MYNUM .GE. 1) THEN
        IMAX=MMAX
      ENDIF
      IF(MYNUM .NE. NSLAV-1) THEN
        IMAX1=MMAX
      ENDIF
      IF(MYNUM .NE. NSLAV-1) THEN
        IMAX2=MMAX
      ENDIF
      IF(MYNUM .GE. 1) THEN
        IMAX3=MMAX
      ENDIF
C
       CALL XCHINT(SSPORT,ILPROC,IBUFF,IMAX,
     1             SRPORT,IRPROC,IBUFF1,IMAX1,
     2             SSPORT,IRPROC,IBUFF2,IMAX2,
     3             SRPORT,ILPROC,IBUFF3,IMAX3)
C
C      PRINT *,'SNXFLD point 3'
C ############
C  Distribute data in buffers
C  Receive right
      IF(MYNUM .NE. NSLAV-1) THEN
       IF(K1 .EQ. 0) THEN
C  K1=0: Replace existing values
         DO 301 I=1,MMAX
 301       PFLD(JMAX+1-K2,I)=BUFF2(I)
       ELSE
C  K1=1: Add transferred values in
         DO 3011 I=1,MMAX
 3011      PFLD(JMAX+1-K2,I)=PFLD(JMAX+1-K2,I)+BUFF2(I)
       ENDIF
      ENDIF
C  Receive left
      IF(MYNUM .GE. 1) THEN
       IF(K1 .EQ. 0) THEN
         DO 303 I=1,MMAX
 303       PFLD(JMIN-1+K2,I)=BUFF3(I)
       ELSE
         DO 3031 I=1,MMAX
 3031      PFLD(JMIN-1+K2,I)=PFLD(JMIN-1+K2,I)+BUFF3(I)
       ENDIF
      ENDIF
C
C      PRINT *,'Leaving SNXFLD'
       END
C
C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
C
       SUBROUTINE SNXCOR(PX,KNPMAX)
       DIMENSION PX(KNPMAX)
C  PX - particle coordinate to be exchanged
C  KNPMAX - dimension of array
C
C---------------------------------------------------------------------
CL                  C3.1     Numerical Parameters
       COMMON/COMNUM/
     R   C1    ,   C2    ,   CD0   ,   CURANT,   DT    ,   DX1   ,
     R   DX1DX2,   DX1OX2,   DX2   ,   DX2OX1,   ELPERP,   HLFDX1,
     R   HLFDX2,   TCACO ,
     I   LMAX  ,   LMAXP ,   LMAXP2,   MMAX  ,   MMAXP ,   MMAXP2,
     I   NEMIT ,   NP
C
C---------------------------------------------------------------------
      COMMON /GRAFIX/ MASKSZ,MSPORT,SSPORT,GPORT,GBOOT,G_TASKID,
     1       IBLK,IWHT,IRED,IGRN,IBLU,IYEL,IMAG,ICYA,SRPORT
      INTEGER MASKSZ,MSPORT,SSPORT,GPORT,GBOOT,G_TASKID,SRPORT
      COMMON /MTINY/ MYNUM,NSLAV,NTASK,ISLMIN(128),ISLMAX(128)
      COMMON/PTCCOM/ ICNTLO,ICNTLI,ICNTRO,ICNTRI,ICNMAX
     1              ,IPTCLO(256),IPTCLI(256),IPTCRO(256),IPTCRI(256)
C
      INTEGER IBUFF(256),IBUFF1(256),IBUFF2(256),IBUFF3(256)
      REAL BUFF(256),BUFF1(256),BUFF2(256),BUFF3(256)
      EQUIVALENCE(IBUFF(1),BUFF(1))
      EQUIVALENCE(IBUFF1(1),BUFF1(1))
      EQUIVALENCE(IBUFF2(1),BUFF2(1))
      EQUIVALENCE(IBUFF3(1),BUFF3(1))
C
C  Find neighbouring processors and make periodic
C  Master(0) and slaves(1,...,NSLAV) in a ring, which is broken as follows:
C  Processors 0,1,2,...,NSLAV-1 form a finite linear chain:
C     Proc 0 does not send left, and proc NSLAV-1 does not send right
C     Proc NSLAV calculates by itself and does not communicate
C
C  Left processor number
       ILPROC=MYNUM-1
       IF(ILPROC .LT. 0) ILPROC=NSLAV
C  Right processor number
       IRPROC=MYNUM+1
       IF(IRPROC .GT. NSLAV) IRPROC=0
C      PRINT *,'MYNUM =',MYNUM,' NSLAV=',NSLAV,
C    1         ' ILP=',ILPROC,' IRP=',IRPROC
C
C xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
C  Exchange x-coords of particles leaving left boundary
C  Fill send buffers 
C      PRINT *,'SNXCOR point 1'
C  Send left
C  Pickup x-coords into buffer
      IF(MYNUM .GE. 1) THEN
       DO 100 I=1,ICNTLO
         IPNUM=IPTCLO(I)
         BUFF(I)=PX(IPNUM)
 100     CONTINUE
      ENDIF
C  Send right
      IF(MYNUM .NE. NSLAV-1) THEN
       DO 102 I=1,ICNTRO
         IPNUM=IPTCRO(I)
         BUFF1(I)=PX(IPNUM)
 102   CONTINUE
      ENDIF
C      PRINT *,'SNXCOR point 2'
C -----------------------------------------------
C  Exchange data with neighbours
      IMAX=0
      IMAX1=0
      IMAX2=0
      IMAX3=0
      IF(MYNUM .GE. 1) THEN
        IMAX=ICNTLO
      ENDIF
      IF(MYNUM .NE. NSLAV-1) THEN
        IMAX1=ICNTRO
      ENDIF
      IF(MYNUM .NE. NSLAV-1) THEN
        IMAX2=ICNTRI
      ENDIF
      IF(MYNUM .GE. 1) THEN
        IMAX3=ICNTLI
      ENDIF
C
       CALL XCHINT(SSPORT,ILPROC,IBUFF,IMAX,
     1             SRPORT,IRPROC,IBUFF1,IMAX1,
     2             SSPORT,IRPROC,IBUFF2,IMAX2,
     3             SRPORT,ILPROC,IBUFF3,IMAX3)
C
C      PRINT *,'SNXCOR point 3'
C -----------------------------------------------
C  Distribute received data
C  Send left
      II=1
C  Receive right
      IF(MYNUM .NE. NSLAV-1) THEN
       DO 101 I=1,ICNTRI
         PX(NP+II)=BUFF2(I)
         II=II+1
 101   CONTINUE
      ENDIF
C  Receive left
      IF(MYNUM .GE. 1) THEN
       DO 103 I=1,ICNTLI
         PX(NP+II)=BUFF3(I)
         II=II+1
 103   CONTINUE
      ENDIF
C -----------------------------------------------
C
C     PRINT *,'coords exchanged'
C
      END
C
C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
C
       SUBROUTINE SNXCNT
C
C  Exchanges particle counters
      COMMON /GRAFIX/ MASKSZ,MSPORT,SSPORT,GPORT,GBOOT,G_TASKID,
     1       IBLK,IWHT,IRED,IGRN,IBLU,IYEL,IMAG,ICYA,SRPORT
      INTEGER MASKSZ,MSPORT,SSPORT,GPORT,GBOOT,G_TASKID,SRPORT
      COMMON /MTINY/ MYNUM,NSLAV,NTASK,ISLMIN(128),ISLMAX(128)
      COMMON/PTCCOM/ ICNTLO,ICNTLI,ICNTRO,ICNTRI,ICNMAX
     1              ,IPTCLO(256),IPTCLI(256),IPTCRO(256),IPTCRI(256)
C
      INTEGER IBUFF(256),IBUFF1(256),IBUFF2(256),IBUFF3(256)
      REAL BUFF(256),BUFF1(256),BUFF2(256),BUFF3(256)
      EQUIVALENCE(IBUFF(1),BUFF(1))
      EQUIVALENCE(IBUFF1(1),BUFF1(1))
      EQUIVALENCE(IBUFF2(1),BUFF2(1))
      EQUIVALENCE(IBUFF3(1),BUFF3(1))
C
C  Find neighbouring processors and make periodic
C  Master(0) and slaves(1,...,NSLAV) in a ring, which is broken as follows:
C  Processors 0,1,2,...,NSLAV-1 form a finite linear chain:
C     Proc 0 does not send left, and proc NSLAV-1 does not send right
C     Proc NSLAV calculates by itself and does not communicate
C
C  Left processor number
       ILPROC=MYNUM-1
       IF(ILPROC .LT. 0) ILPROC=NSLAV
C  Right processor number
       IRPROC=MYNUM+1
       IF(IRPROC .GT. NSLAV) IRPROC=0
C      PRINT *,'MYNUM =',MYNUM,' NSLAV=',NSLAV,
C    1         ' ILP=',ILPROC,' IRP=',IRPROC
C
C  Exchange particle counters
C -----------------------------------------------
C  Fill send buffers
C      PRINT *,'SNXCNT point 1'
C  Send left
      IF(MYNUM .GE. 1) THEN
       IBUFF(1)=ICNTLO
      ENDIF
C  Send right
      IF(MYNUM .NE. NSLAV-1) THEN
       IBUFF1(1)=ICNTRO
      ENDIF
C      PRINT *,'SNXCNT point 2'
C -----------------------------------------------
C  Exchange data with neighbours
      IMAX=0
      IMAX1=0
      IMAX2=0
      IMAX3=0
      IF(MYNUM .GE. 1) THEN
        IMAX=1
      ENDIF
      IF(MYNUM .NE. NSLAV-1) THEN
        IMAX1=1
      ENDIF
      IF(MYNUM .NE. NSLAV-1) THEN
        IMAX2=1
      ENDIF
      IF(MYNUM .GE. 1) THEN
        IMAX3=1
      ENDIF
C
       CALL XCHINT(SSPORT,ILPROC,IBUFF,IMAX,
     1             SRPORT,IRPROC,IBUFF1,IMAX1,
     2             SSPORT,IRPROC,IBUFF2,IMAX2,
     3             SRPORT,ILPROC,IBUFF3,IMAX3)
C
C      PRINT *,'SNXCNT point 3'
C -----------------------------------------------
C  Distribute received data
C  Receive right
      IF(MYNUM .NE. NSLAV-1) THEN
       ICNTRI=IBUFF2(1)
      ENDIF
C  Receive left
      IF(MYNUM .GE. 1) THEN
       ICNTLI=IBUFF3(1)
      ENDIF
C -----------------------------------------------
C     PRINT *,'particle counters exchanged'
      END
C
         SUBROUTINE SNXPTC(K,KPNUM,PX)
C  Exchange particles between neighbouring processors
C
C    K=1 : exchange coordinates and re-initialise
C     =2 : detect particles crossing edge boundaries
C
C    KPNUM : particle-number of particle examined
C    PX    : x-coordinate of particle
C
C    ICNMAX=256 : maximum number of particles allowed in exchange tables
C    IPTCLO(ICNMAX) : array of particle-numbers of those leaving  left
C    ....LI(ICNMAX) : .................................. entering left
C    IPTCRO(ICNMAX) : .................................. leaving  right
C    ....RI(ICNMAX) : .................................. entering right
C
C    ICNTLO : count of particles leaving left
C    ICNTRO : count of particles leaving right
C
C       INCLUDE 'COMSTT.inc'
C---------------------------------------------------------------------
CL                  C2.2     Physical State
       COMMON/COMSTT/
     R   B3    ,   BAV   ,   CD1   ,   CD2   ,   E1    ,   E2    ,
     R   P1    ,   P2    ,   Q1    ,   Q2    ,   REALTN,   TIMRUN
       DIMENSION
     R   B3(605,40),        BAV(605,40),       CD1(605,40),
     R   CD2(605,40),       E1(605,40),        E2(605,40),
     R   P1(20000),          P2(20000),          Q1(20000),
     R   Q2(20000)
C       INCLUDE 'COMNUM.inc'
C---------------------------------------------------------------------
CL                  C3.1     Numerical Parameters
       COMMON/COMNUM/
     R   C1    ,   C2    ,   CD0   ,   CURANT,   DT    ,   DX1   ,
     R   DX1DX2,   DX1OX2,   DX2   ,   DX2OX1,   ELPERP,   HLFDX1,
     R   HLFDX2,   TCACO ,
     I   LMAX  ,   LMAXP ,   LMAXP2,   MMAX  ,   MMAXP ,   MMAXP2,
     I   NEMIT ,   NP
C
C---------------------------------------------------------------------
       COMMON/COMBAS/
     +   ALTIME,   CPTIME,   NLEDGE,   NLEND,    NLRES,    NONLIN,
     +   NOUT,     NPRINT,   NREAD,    NREC,     NRESUM,   NSTEP,
     +   STIME,    LABEL1,   LABEL2,   LABEL3,   LABEL4,   LABEL5,
     +   LABEL6,   LABEL7,   LABEL8,   NDIARY,   NIN,      NPUNCH,
     +   NRUN
       REAL        ALTIME,   CPTIME,   STIME
       LOGICAL     NLEND,    NLRES
       DIMENSION
     H   LABEL1(12),         LABEL2(12),         LABEL3(12),
     H   LABEL4(12),         LABEL5(12),         LABEL6(12),
     H   LABEL7(12),         LABEL8(12)
C
C       INCLUDE 'COMHOK.inc'
C---------------------------------------------------------------------
CL                  C4.1     Housekeeping
       COMMON/COMHOK/
     R   TIMECP,   XPSMAX,   XPSMIN,   YPSMAX,   YPSMIN,
     I   N1MAX ,   N2MAX ,   NCASE ,   NGMAX ,   NOSEP ,   NPDUM ,
     I   NPMAX ,   NSRC  ,   NXDUM ,   NYDUM
       DIMENSION
     R   TIMECP(32)
C       INCLUDE 'C:\TINYV2R0\INCLUDE\TINY.INC'
C       INCLUDE 'CHAN.INC'
C
      COMMON /GRAFIX/ MASKSZ,MSPORT,SSPORT,GPORT,GBOOT,G_TASKID,
     1       IBLK,IWHT,IRED,IGRN,IBLU,IYEL,IMAG,ICYA,SRPORT
      INTEGER MASKSZ,MSPORT,SSPORT,GPORT,GBOOT,G_TASKID,SRPORT
      COMMON /MTINY/ MYNUM,NSLAV,NTASK,ISLMIN(128),ISLMAX(128)
C
C     DIMENSION IPTCLO(256),IPTCLI(256),IPTCRO(256),IPTCRI(256)
C     INTEGER ICNTLO/0/,ICNTLI/0/,ICNTRO/0/,ICNTRI/0/,ICNMAX/256/
C     SAVE ICNTLO,ICNTLI,ICNTRO,ICNTRI,IPTCLO,IPTCLI,IPTCRO,IPTCRI
      COMMON/PTCCOM/ ICNTLO,ICNTLI,ICNTRO,ICNTRI,ICNMAX
     1              ,IPTCLO(256),IPTCLI(256),IPTCRO(256),IPTCRI(256)
C
      INTEGER IBUFF(256),IBUFF1(256)
      REAL BUFF(256)
      EQUIVALENCE(IBUFF(1),BUFF(1))
      COMMON/BENINT/NBENSW,NBENOR,NBENCL,NBEN1,NBEN2,NBEN3,NBEN4,NBEN5
C
       IF(NBEN2 .EQ. 1) RETURN
       IF(MYNUM .EQ. NSLAV) RETURN
       IF(K .EQ. 0) GOTO 9999
C  NSLAV does whole problem with no comms, therefore leave here
C  master(0) and slaves 1,...,NSLAV-1 do 1/NSLAV of problem each
C      PRINT *,'Entering SNXPTC, K=',K
C  Find neighbouring processors and make periodic
C  Periodic feature not now used, because NSLAV is disconnected
C  and master doesn't commun. left and NSLAV-1 doesn't right
C  Master(0) and slaves(1,...,NSLAV) in a ring
C  Left processor number
       ILPROC=MYNUM-1
       IF(ILPROC .LT. 0) ILPROC=NSLAV
C  Right processor number
       IRPROC=MYNUM+1
       IF(IRPROC .GT. NSLAV) IRPROC=0
C      PRINT *,'MYNUM =',MYNUM,' NSLAV=',NSLAV,
C    1         ' ILP=',ILPROC,' IRP=',IRPROC
C
C  Calc boundary values for this processor (MYNUM=its TASKID)
       JMIN=ISLMIN(MYNUM+1)
       JMAX=ISLMAX(MYNUM+1)
C  JMIN,JMAX are mesh point numbers; ZXMIN,ZXMAX are cell boundaries
       ZXMIN=JMIN
       ZXMAX=JMAX+1.0
C      PRINT *,'SNXPTC point 1, K=',K
C
         GOTO (1000,2000),K
C
C -------------------------------------------------------------------
C
 1000    CONTINUE
C
C  Exchange particle counters
      CALL SNXCNT
C     PRINT *,'particle counters exchanged'
C .....................................................
C
C     IF(ICNTRI .NE. 0)
C    1     PRINT *,'Particles entering right ICNTRI=',ICNTRI
C     IF(ICNTLI .NE. 0)
C    1     PRINT *,'Particles entering left  ICNTLI=',ICNTLI
C
C  Test for particle table overflow
      I=NP+ICNTLI+ICNTRI
      IF(I .GT. NPMAX) THEN
        PRINT *,' TOO MANY PARTICLES: NP=',I,' NPMAX=',NPMAX
        PRINT *,' RUN ABORTED'
        NP=NPMAX
        NLEND=.TRUE.
        GOTO 9999
      ENDIF
C
C .....................................................
C
C  Exchange coordinates, 
C  positions and momenta of particles transferred
      CALL SNXCOR(Q1,NPMAX)
      CALL SNXCOR(Q2,NPMAX)
      CALL SNXCOR(P1,NPMAX)
      CALL SNXCOR(P2,NPMAX)
C
C  Update number of particles by those input from edges
       NP=NP+ICNTLI+ICNTRI
C  Kill exchanged particles, i.e. erase them from particle table
C
       INP=NP
       DO 500 JP=1,ICNTLO
       IP=IPTCLO(JP)
       Q1(IP)=Q1(INP)
       Q2(IP)=Q2(INP)
       P1(IP)=P1(INP)
       P2(IP)=P2(INP)
       INP=INP-1
 500   CONTINUE
C
       DO 501 JP=1,ICNTRO
       IP=IPTCRO(JP)
       Q1(IP)=Q1(INP)
       Q2(IP)=Q2(INP)
       P1(IP)=P1(INP)
       P2(IP)=P2(INP)
       INP=INP-1
 501   CONTINUE
       NP=INP
C
 9999 CONTINUE
C
C  Re-initialise particle counters
      ICNTLO=0
      ICNTLI=0
      ICNTRO=0
      ICNTRI=0
      ICNMAX=256
C      PRINT *,'Leaving SNXPTC, K=',K
         RETURN
C
C -------------------------------------------------------------------
C
 2000    CONTINUE
C  Detect particles leaving and update exchange tables
C
C  Quick return if within region
       IF(PX .GE. ZXMIN .AND. PX .LE. ZXMAX) RETURN
C  Test for particle exchange tables being full
       IF(ICNTLO .EQ. ICNMAX) THEN
         PRINT *,'ERROR IN SNXPTC - NON FATAL'
         PRINT *,'LEAVING-LEFT TABLE FULL, PARTICLE LOST AT BOUNDARY'
         RETURN
       ELSEIF(ICNTRO .EQ. ICNMAX) THEN
         PRINT *,'ERROR IN SNXPTC - NON FATAL'
         PRINT *,'LEAVING-RIGHT TABLE FULL, PARTICLE LOST AT BOUNDARY'
         RETURN
       ENDIF
C
C  If leaving region put particle-number in exchange table
         IF(PX .LT. ZXMIN) THEN
           ICNTLO=ICNTLO+1
           IPTCLO(ICNTLO)=KPNUM
C          PRINT *,'Particles leaving to left ICNTLO=',ICNTLO
         ELSEIF(PX .GT. ZXMAX) THEN
           ICNTRO=ICNTRO+1
           IPTCRO(ICNTRO)=KPNUM
C          PRINT *,'Particles leaving to right ICNTRO=',ICNTRO
         ENDIF
C      PRINT *,'Leaving SNXPTC, K=',K
       END

