C     PROGRAM EDEX
C
C     EDEX MAIN PROGRAM
C
C-IV- INTEGER*4 NDNAME
      CHARACTER NDNAME*4,MCI
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      COMMON/EDEXIO/ KINST,NINSTK,INSTK(5),MAXSTK,MININ,MAXIN,
     .               KOUTST,MINOUT,MAXOUT,KIECHO,KOECHO,KINLEN,KOUTLN
      COMMON/LOCALS/ LOCAL(27)
C-IV- COMMON/XIOCOM/ IOCOM(236)
      COMMON/XICBUF/ MCI(80) /XIOCOM/ IOCOM(236)
C
C     SET UP INTERNAL CONSTANTS
C
      CALL OPENED
      CALL SETUP
      CALL BANNER (KOUTST)
C
C     LOOK FOR A DIRECTIVE
C
10    JLEVEL = 1
15    CALL DIRECT (NDIRNO,JL,NDNAME)
      IF (NDIRNO.LT.1) GO TO 91
      IF (JL.GT.JLEVEL) GO TO 93
      IF (JL.NE.0) JLEVEL = JL
      GO TO (21,22,23,24,25,26,27,28,29,  35,  41,42,43,47,48,50,54,57,
     .       60,65,  71,72,75,76,79),NDIRNO
C
C     ANY-LEVEL DIRECTIVES
C
21    NSHRI = 1
      GO TO 15
22    CALL TERDIR
      GO TO 85
23    CALL COMDIR
      GO TO 15
24    CALL XNPAGE
      GO TO 15
C
C INPUT
25    CALL NEWCHA (IN,1)
      IF (IN.LE.0) GO TO 96
      IF (NINSTK.GT.MAXSTK) GO TO 96
      NINSTK = NINSTK+1
      INSTK(NINSTK) = IN
      KINST = IN
      CALL XISSET (IN)
      GO TO 15
C RETURN
26    IF (NINSTK.LE.1) GO TO 96
      NINSTK = NINSTK-1
      KINST = INSTK(NINSTK)
      CALL XISSET (KINST)
      GO TO 15
C REWIND
27    CALL NEWCHA (N,1)
      IF (N.LT.0) GO TO 96
      REWIND N
      GO TO 15
28    CALL NEXDIR
      CALL XNPAGE
      GO TO 10
29    CALL NEXDIR
      CALL CLOSED
      CALL EXIT
C
C     PARAMETERS - SWITCH TO LEVEL 2
C
35    CALL PARDIR
      IF (MISTAK.GT.0) GO TO 98
      JLEVEL = 2
      GO TO 15
C
C     LEVEL-2 DIRECTIVES
C
41    CALL BLODIR
      GO TO 85
42    CALL TREDIR
      GO TO 85
43    CALL SPEDIR
      GO TO 85
47    NDATAL = -1
      GO TO 15
48    CALL PLADIR
      GO TO 85
50    CALL DATDIR
      GO TO 85
54    CALL DERDIR
      GO TO 85
57    CALL LISDIR
      GO TO 85
C
C     ANALYSE AND WRITE
C
60    CALL ANADIR
      IF (MISTAK.NE.0) GO TO 98
      JLEVEL = 3
      NADJUS = 0
      CALL CANADJ
      GO TO 15
65    CALL WRIDIR
      GO TO 85
C
C     LEVEL-3 DIRECTIVES
C
71    CALL TABDIR
      GO TO 85
72    CALL ADJDIR
      GO TO 85
75    NINSER = 1
      GO TO 15
76    NRESID = 1
      GO TO 15
79    CALL PRIDIR
      CALL CANADJ
      GO TO 85
C
85    IF (MISTAK) 98,15,98
C
C     FAULTS
C
91    MISTAK = 1
      GO TO 98
93    MISTAK = 3
      GO TO 98
96    MISTAK = 26
C
98    CALL FAULT (NDNAME)
      MISTAK = 0
      GO TO 15
      END
      SUBROUTINE NEWCHA (N,INOUT)
C
C     READS A CHANNEL NUMBER (N) FOR INPUT (INOUT=1) OR OUTPUT (INOUT=0)
C     CHECKS THAT IT IS IN THE CORRECT RANGE AND IS NOT ON THE INPUT STACK.
C     FOR INPUT, ALSO CHECKS THAT IT IS NOT BEING USED FOR OUTPUT
C
      COMMON/EDEXIO/ KINST,NINSTK,INSTK(5),MAXSTK,MININ,MAXIN,
     .               KOUTST,MINOUT,MAXOUT,KIECHO,KOECHO,KINLEN,KOUTLN
      CALL XIREAD (N,IND)
      IF (IND.NE.0) GO TO 16
      IF (INOUT.EQ.1) GO TO 10
      IF (N.LT.MINOUT.OR.N.GT.MAXOUT) GO TO 16
      GO TO 12
10    IF (N.LT.MININ.OR.N.GT.MAXIN) GO TO 16
      IF (N.EQ.KOUTST.OR.N.EQ.KIECHO.OR.N.EQ.KOECHO) GO TO 16
12    DO 14 J = 1,NINSTK
      IF (N.EQ.INSTK(J)) GO TO 16
14    CONTINUE
      GO TO 17
16    N = -1
17    RETURN
      END
      SUBROUTINE DIRECT (NDIRNO,JL,NDNAME)
C
C     READS A DIRECTIVE
C     NDIRNO = DIRECTIVE NUMBER.    NDNAME = DIRECTIVE NAME
C     JL = LEVEL NUMBER, 0 MEANS ANY LEVEL
C
C-IV- INTEGER*4 NDNAME,NAME
      CHARACTER*4 NDNAME,NAME
      DIMENSION KLEVEL(25),LSKIP(25),NAME(25)
      DATA NAME/'SHR','TER','COM','NEW','INP','RET','REW','NEX','END',
     .'PAR','BLO','TRE','SPE','CAN','PLA','DAT','DER','LIS',
     .'ANA','WRI','TAB','ADJ','INS','RES','PRI'/
      DATA KLEVEL/7*0,1,0,1,9*2,0,5*3/,NDIRS/25/
      DATA LSKIP/1,0,1,1,0,1,0,18*1/
C
C     THE DIRECTIVE IS THE FIRST THREE NON-SPACE CHARACTERS ON THE RECORD
C
      CALL XNFOUR (NDNAME,3,IND)
      IF (IND.EQ.1) GO TO 22
      DO 20 J = 1,NDIRS
      IF (NDNAME.EQ.NAME(J)) GO TO 25
20    CONTINUE
C DIRECTIVE NOT KNOWN
22    NDIRNO = 0
      GO TO 26
C DIRECTIVE IS KNOWN - IGNORE REST OF THE RECORD
C EXCEPT FOR THOSE DIRECTIVES WHOSE DATA CAN FOLLOW ON THE SAME LINE
25    NDIRNO = J
      IF (LSKIP(J).EQ.1) CALL XLSKIP
      JL = KLEVEL(J)
26    RETURN
      END
      SUBROUTINE MVPRIN (M,N)
C
C     PRINTS A MISSING VALUE AS * IN A FIELD WIDTH CORRESPONDING
C     TO PRINT (A,M,N)
C
      CALL XSPACE (M+N)
      IF (N.GT.0) CALL XSPACE (1)
      CALL XPTEXT ('*',1)
      RETURN
      END
      SUBROUTINE LNPRIN (KFAC,KLEV,KWIDTH)
C
C     PRINTS THE LEVEL NAME OF LEVEL KLEV OF FACTOR KFAC RIGHT-JUSTIFIED
C     IN A FIELD WIDTH OF KWIDTH
C
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      CALL XSPACE (1)
      JN = LLABST+KFAC
      JL = IA(JN)+1
      IF (KLEV.EQ.0) GO TO 15
      DO 12 J = 1,KLEV
      JL = JL+IA(JL)+1
12    CONTINUE
15    L = IA(JL)
      CALL XSPACE (KWIDTH-L-1)
      DO 25 K = 1,L
      JL = JL+1
      CALL XCPRIN (IA(JL))
25    CONTINUE
      RETURN
      END
      SUBROUTINE READR (R,IND)
      DOUBLE PRECISION R,B
C -S- REAL R,B
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      EQUIVALENCE (KOPER(1),KPLUS),(KOPER(2),MINUS)
C
C     READS A REAL NUMBER AND PRINTS IT OUT IN THE FORM IN
C     WHICH IT IS READ
C
      JSIGN = 1
      JPOINT = 0
      IP = (KNINE-KZERO)/9
      B = 1.
      R = 0.
C
C     FIRST SYMBOL
C
      CALL XCFIND (JT,0)
      IF (JT.EQ.KPLUS) GO TO 20
      IF (JT.NE.MINUS) GO TO 12
      JSIGN = -1
      GO TO 20
12    IF (JT.NE.KDOT) GO TO 15
      JPOINT = 1
      GO TO 20
15    IF (JT.LT.KZERO.OR.JT.GT.KNINE) GO TO 98
      R = (JT-KZERO)/IP
C
C     NEXT SYMBOL CAN BE DECIMAL POINT (FAULT IF MORE THAN ONE)
C
20    CALL XCPRIN (JT)
      CALL XCSKIP
      CALL XCNEXT (JT)
      IF (JT.NE.KDOT) GO TO 25
      IF (JPOINT.EQ.1) GO TO 98
      JPOINT = 1
      GO TO 30
C
C     OR A DIGIT
C
25    IF (JT.LT.KZERO.OR.JT.GT.KNINE) GO TO 99
      JN = (JT-KZERO)/IP
      IF (JPOINT.EQ.1) GO TO 28
      R = R*10.0+JN
      GO TO 30
28    B = B*0.1
      R = R + B*JN
30    CONTINUE
      GO TO 20
C
98    IND = 1
      RETURN
99    IND = 0
      R = R*JSIGN
      RETURN
      END
      SUBROUTINE FINDNA (NAME,IST,N,LPOS)
C
C     FINDS THE NAME 'NAME' IN THE ARRAY IA
C     RETURNS LPOS = K IF THE NAME IS IN IA(K-IST+1), OTHERWISE -1
C
      DIMENSION NAME(2)
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      IF (N.LT.1) GO TO 17
      K = IST
      DO 15 J = 1,N
      IF (NAME(1).NE.IA(K)) GO TO 12
      IF (NAME(2).EQ.IA(K+1)) GO TO 19
12    K = K+2
15    CONTINUE
17    LPOS = -1
      RETURN
19    LPOS = J
      RETURN
      END
      SUBROUTINE LISTRD (JLP,K,LTERM)
C
C     READS A LIST OF FACTOR EFFECTS X1.X2. ... XN INTO
C     THE ARRAY BEGINNING AT IA(JLP)
C     LTERM = THE NUMBER OF ELEMENTS IN THE ARRAY
C     K = THE NUMBER OF TREATMENTS, FACTORS OR NAMES, AS APPROPRIATE
C
      DIMENSION N(2)
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      JQ = 0
C
C     READ A NAME
11    CALL XCFIND (N(1),0)
      CALL XCSKIP
      N(2) = KSPACE
      CALL XCFIND (NS,1)
      IF (NS.LT.LETERA.OR.NS.GT.LETERZ) GO TO 15
C  SPECIAL EFFECT
      N(2) = NS
      CALL XCSKIP
      CALL XCFIND (NS,1)
15    CONTINUE
      CALL FINDNA (N,LNAME+1,K,JT)
      IF (JT.LT.0) GO TO 97
      JR = JT
      IF (JT.LE.NFACTO) GO TO 16
      JR = LSPFPT+JT-NFACTO
      JR = IA(JR)
16    L = LFCHEK+JR
      IF (IA(L).EQ.0) GO TO 92
      JQ = JQ+1
      IF (JQ.GT.LTERM) GO TO 98
      JQP = JLP+JQ
      IA(JQP) = JT
C
C     SORT THE NAMES INTO FACTOR ORDER; FAULT DUPLICATES
C
      IF (JQ.EQ.1) GO TO 26
      JR = JLP+JQ
18    JW = IA(JR-1)
      JV = IA(JR)
      IF (JV-JW) 20,98,26
20    IA(JR) = JW
      IA(JR-1) = JV
      JR = JR-1
      IF (JR.GT.JLP+1) GO TO 18
26    IF (NS.NE.KDOT) GO TO 30
      CALL XCSKIP
      GO TO 11
30    IA(JLP) = JQ
      MISTAK = 0
      RETURN
C
C     FAULTS - NAME NOT ASSIGNED OR DECLARED, OR APPEARS TWICE
92    MISTAK = 12
      GO TO 99
97    MISTAK = 7
      GO TO 99
98    MISTAK = 8
99    RETURN
      END
      SUBROUTINE FACPRI (J)
C
C     PRINTS A LIST OF THE FACTORS IN A TERM
C     IA(J) = NUMBER OF FACTORS
C     IA(J+1)...IA(J+IA(J)) = POSITION NUMBERS OF FACTORS
C
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      K = IA(J)
      DO 11 JT = 1,K
      JP = J+JT
      IF (JT.GT.1) CALL XPTEXT ('.',1)
      JN = IA(JP)*2 + LNAME
      CALL XCPRIN (IA(JN-1))
      IF (IA(JP).GT.NFACTO) CALL XCPRIN (IA(JN))
11    CONTINUE
      RETURN
      END
      SUBROUTINE SETUP
C
C     SETS UP INPUT/OUTPUT STREAMS AND SOME GENERAL CONANTS
C
C-IV- INTEGER MCHARS
      CHARACTER MCHARS
      DIMENSION KCHARS(27),MCHARS(27)
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      COMMON/EDEXIO/ KINST,NINSTK,INSTK(5),MAXSTK,MININ,MAXIN,
     .               KOUTST,MINOUT,MAXOUT,KIECHO,KOECHO,KINLEN,KOUTLN
      EQUIVALENCE (NTER,KCHARS(1))
      DATA MCHARS/':','*','.',',',' ',' ','+','-','*','/','(',')',
     .'=','0','9','A','C','D','E','F','M','N','P','R','S','V','Z'/
C
C     SET UP INPUT AND OUTPUT STREAMS.  WRITE HEADING BANNER
C
      NINSTK = 1
      INSTK(1) = KINST
      MAXSTK = 5
      MININ = 11
      MINOUT = 11
      MAXIN = 17
      MAXOUT = 17
      CALL XINOUT (KINST,KINLEN,KOUTST,KOUTLN)
      CALL XIECHO (-KIECHO)
      CALL XOECHO (KOECHO)
C
C MISSING VALUES
      RMV = -1D20
C -S- RMV = -1E20
C ARRAY SIZES
      LENDRA = 16382
      LMAXRA = 0
      LENDIA = 2048
      LMAXIA = 0
C OTHERS (F-TEST SWITCH, ERROR MARKER, CHARACTERS)
      NSHRI = 0
      MISTAK = 0
      DO 64 J = 1,27
C-IV- KCHARS(J) = MCHARS(J)
      KCHARS(J) = ICHAR (MCHARS(J))
64    CONTINUE
      CALL XNLSYM (NLINE)
      RETURN
      END
      SUBROUTINE BANNER (LP)
C
C     PRINTS THE INTRODUCTORY BANNER ON CHANNEL LP
C
      WRITE (LP,27)
27    FORMAT (' ...........................'/
     .        ' .        EDEX 6H.2        .'/
     .        ' .    Program written by   .'/
     .        ' . AFRC Unit of Statistics .'/
     .        ' .        Edinburgh        .'/
     .        ' ...........................'//1X)
      RETURN
      END
      SUBROUTINE FAULT (NDNAME)
C
C     PRINTS A FAULT MESSAGE AND SKIPS TO THE NEXT DIRECTIVE
C
C-IV- INTEGER*4 NDNAME
      CHARACTER*4 NDNAME
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      CALL XNLINE (1)
      CALL XPTEXT ('Fault in directive ',19)
      CALL XPTEXT (NDNAME,3)
      CALL XNLINE (1)
      GO TO (1,2,3,4,5,6,7,8,9,10,90,12,13,14,15,16,17,18,90,
     .      20,90,22,23,90,90,26,27,28,29),MISTAK
1     CALL XPTEXT ('Directive name not recognised',29)
      GO TO 90
2     CALL XPTEXT ('Syntax error',12)
      GO TO 90
3     CALL XPTEXT ('Directive called at wrong level',31)
      GO TO 90
4     CALL XPTEXT ('Adjustment for unlisted effects',31)
      GO TO 90
5     CALL XPTEXT ('Essential directive missing',27)
      GO TO 90
6     CALL XPTEXT ('Letter V used as a factor name',30)
      GO TO 90
7     CALL XPTEXT ('Undeclared factor name',22)
      GO TO 90
8     CALL XPTEXT ('Interaction or table wrongly coded',34)
      GO TO 90
9     CALL XPTEXT ('Item given twice',16)
      GO TO 90
10    CALL XPTEXT ('Variate number zero or too large',32)
      GO TO 90
12    CALL XPTEXT ('Identifier not assigned',23)
      GO TO 90
13    CALL XPTEXT ('Expression too complex to analyse',33)
      GO TO 90
14    CALL XPTEXT ('Wrong number of levels',22)
      GO TO 90
15    CALL XPTEXT ('Illegal dimension statement',27)
      GO TO 90
16    CALL XPTEXT ('Level number too large',22)
      GO TO 90
17    CALL XPTEXT ('Standard order cannot be used',29)
      GO TO 90
18    CALL XPTEXT ('Data out of order or missing',28)
      GO TO 90
20    CALL XPTEXT ('PF parameter not set',20)
      GO TO 90
22    CALL XPTEXT ('Fewer than two units declared',29)
      GO TO 90
23    CALL XPTEXT ('SEN parameter not set',21)
      GO TO 90
26    CALL XPTEXT ('Invalid file specification',26)
      GO TO 90
27    CALL XPTEXT ('Store full',10)
      GO TO 90
28    CALL XPTEXT ('Nothing to analyse',18)
      GO TO 90
29    CALL XPTEXT ('Too much data',13)
C
90    CALL XNLINE (2)
      CALL XPTEXT ('Skipping to next directive',26)
      CALL XNLINE (1)
C
C     READ AND PRINT THE INPUT UNTIL A LINE IS REACHED BEGINNING WITH A
C     LETTER (EXCEPT V). THIS IS ASSUMED TO BE A NEW DIRECTIVE
C
      CALL XCFIND (JS,1)
      IF (JS.EQ.KSPACE) GO TO 93
92    CALL XCREAD (JS)
      CALL XCPRIN (JS)
      IF (JS.NE.NLINE) GO TO 92
93    CALL XCFIND (JS,0)
      IF (JS.EQ.LETERV) GO TO 92
      CALL XCPRIN (JS)
      IF (JS.GE.LETERA.AND.JS.LT.LETERZ) GO TO 99
      CALL XCSKIP
      GO TO 92
99    CALL XNLINE (2)
      RETURN
      END
      SUBROUTINE XINOUT (IN,IMARG,IOUT,IOMARG)
C SETS UP INITIAL VALUES FOR THE INPUT/OUTPUT PACK
      INTEGER NSYM(9)
C-IV- INTEGER KSYM(9)
      CHARACTER KSYM(9)
      COMMON/XIOCOM/ MID,MI,MLI,MRI,LBI,MBI(81),MEI,LNO,
     .MSP,MA,MZ,MZERO,MNINE,MPL,MMIN,MDP,MAT,NLSYM,
     .MOD,MO,MLO,MRO,LBO,MBO(132),MEO
      EQUIVALENCE (NSYM(1),MSP)
      DATA KSYM/' ','A','Z','0','9','+','-','.','E'/
C INPUT
      MID = IN
      LBI = 80
      MLI = 1
      MRI = IMARG
      IF (MRI.LT.1) MRI = 1
      IF (MRI.GT.LBI) MRI = LBI
      MI = MRI+1
      MEI = 0
      LNO = 0
C OUTPUT
      MOD = IOUT
      LBO = 132
      MLO = 1
      MRO = IOMARG
      IF (MRO.LT.1) MRO = 1
      IF (MRO.GT.LBO) MRO = LBO
      MO = 0
      MEO = 0
C SYMBOLS
      DO 12 K = 1,9
C-IV- NSYM(K) = KSYM(K)
      NSYM(K) = ICHAR (KSYM(K))
12    CONTINUE
      NLSYM = -30048
      MBI(MI) = NLSYM
      DO 20 K = 1,MRO
20    MBO(K) = MSP
      RETURN
      END
      SUBROUTINE XNLSYM(NS)
C RETURNS THE VALUE OF THE NEWLINE SYMBOL
      COMMON/XIOCOM/ MID,MI,MLI,MRI,LBI,MBI(81),MEI,LNO,
     .MSP,MA,MZ,MZERO,MNINE,MPL,MMIN,MDP,MAT,NLSYM,
     .MOD,MO,MLO,MRO,LBO,MBO(132),MEO
      NS = NLSYM
      RETURN
      END
      SUBROUTINE XISSET(IN)
C PREPARES TO READ INPUT FROM STREAM IN
      COMMON/XIOCOM/ MID,MI,MLI,MRI,LBI,MBI(81),MEI,LNO,
     .MSP,MA,MZ,MZERO,MNINE,MPL,MMIN,MDP,MAT,NLSYM,
     .MOD,MO,MLO,MRO,LBO,MBO(132),MEO
      MID=IN
      MLI=1
      MRI = LBI
      MI=MRI+1
      MBI(MI)=NLSYM
      RETURN
      END
      SUBROUTINE XCREAD(I)
C READS THE NEXT CHARACTER ON THE INPUT STREAM
      COMMON/XIOCOM/ MID,MI,MLI,MRI,LBI,MBI(81),MEI,LNO,
     .MSP,MA,MZ,MZERO,MNINE,MPL,MMIN,MDP,MAT,NLSYM,
     .MOD,MO,MLO,MRO,LBO,MBO(132),MEO
      IF (MI.LT.1) GO TO 1
      IF(MBI(MI).EQ.NLSYM) CALL XCRDIN
1     I=MBI(MI+1)
      MI = MI+1
      RETURN
      END
      SUBROUTINE XCNEXT(I)
C RETURNS THE VALUE OF THE NEXT CHARACTER ON THE INPUT
C STREAM !UT DOES NOT MOVE THE POINTER.BUT IF POINTER=MRI.THEN NEW INPUT
C RECORD READ AND POINTER=MLI-1
      COMMON/XIOCOM/ MID,MI,MLI,MRI,LBI,MBI(81),MEI,LNO,
     .MSP,MA,MZ,MZERO,MNINE,MPL,MMIN,MDP,MAT,NLSYM,
     .MOD,MO,MLO,MRO,LBO,MBO(132),MEO
      IF (MI.LT.1) GO TO 1
      IF(MBI(MI).EQ.NLSYM) CALL XCRDIN
1     I=MBI(MI+1)
      RETURN
      END
      SUBROUTINE XCFIND(I,IND)
      COMMON/XIOCOM/ MID,MI,MLI,MRI,LBI,MBI(81),MEI,LNO,
     .MSP,MA,MZ,MZERO,MNINE,MPL,MMIN,MDP,MAT,NLSYM,
     .MOD,MO,MLO,MRO,LBO,MBO(132),MEO
C IF IND=0 THEN NEXT NON-SPACE CHARACTER ON INPUT STREAM IS RETURNED, AND
C THE POINTER IS POSITIONED SO THAT IT IS THE NEXT CHARACTER TO BE READ.
C IF IND=1 THEN IF NO NON-SPACE CHARACTER IS FOUND IN THE CURRENT BUFFER
C THEN SPACE IS RETURNED AND NO NEW RECORD IS READ.
      IF (MI.LT.1) GO TO 20
      IF (MBI(MI).EQ.NLSYM) GO TO 30
20    I = MBI(MI+1)
      IF (I.EQ.NLSYM) GO TO 30
      IF (I.NE.MSP) RETURN
      MI = MI+1
      GO TO 20
30    IF (IND.EQ.1) GO TO 40
      CALL XCRDIN
      GO TO 20
40    I = MSP
      RETURN
      END
      SUBROUTINE XCSKIP
C CAUSES THE NEXT CHARACTER TO BE SKIPPED
      COMMON/XIOCOM/ MID,MI,MLI,MRI,LBI,MBI(81),MEI,LNO,
     .MSP,MA,MZ,MZERO,MNINE,MPL,MMIN,MDP,MAT,NLSYM,
     .MOD,MO,MLO,MRO,LBO,MBO(132),MEO
      IF (MI.LT.1) GO TO 1
      IF(MBI(MI).EQ.NLSYM) GO TO 2
1     MI=MI+1
      RETURN
2     CALL XCRDIN
      RETURN
      END
      SUBROUTINE XCBACK
C MOVES THE INPUT POINTER BACK ONE PLACE (BACKSPACE)
      COMMON/XIOCOM/ MID,MI,MLI,MRI,LBI,MBI(81),MEI,LNO,
     .MSP,MA,MZ,MZERO,MNINE,MPL,MMIN,MDP,MAT,NLSYM,
     .MOD,MO,MLO,MRO,LBO,MBO(132),MEO
      IF (MI.GE.MLI) MI = MI-1
      RETURN
      END
      SUBROUTINE XLSKIP
C SKIPS THE REMAINDER OF THE CURRENT INPUT RECORD
      COMMON/XIOCOM/ MID,MI,MLI,MRI,LBI,MBI(81),MEI,LNO,
     .MSP,MA,MZ,MZERO,MNINE,MPL,MMIN,MDP,MAT,NLSYM,
     .MOD,MO,MLO,MRO,LBO,MBO(132),MEO
      MI = MRI+1
      RETURN
      END
      SUBROUTINE XIECHO(I)
C CAUSES INPUT RECORDS TO BE COPIED TO STREAM I.IF I=0
C  PRINTING IS SUPPRESSED
      COMMON/XIOCOM/ MID,MI,MLI,MRI,LBI,MBI(81),MEI,LNO,
     .MSP,MA,MZ,MZERO,MNINE,MPL,MMIN,MDP,MAT,NLSYM,
     .MOD,MO,MLO,MRO,LBO,MBO(132),MEO
      MEI=I
      RETURN
      END
      SUBROUTINE XNFOUR (NAME,NL,IND)
C VERSION OF XNFOUR FOR FORTRAN 77
C READS THE NEXT ALPHAMERIC WORD IGNORING LEADING SPACES
C ANY NON ALPHAMERIC CHARACTER WILL TERMINATE WORD.
C WORDS OF MORE THAN NL CHARACTERS WILL BE TRUNCATED (NL.LE.4)
C IF FIRST NON-SPACE CHARACTER IS NOT ALPHABETIC THEN IND=1
C AND NAME IS EMPTY, OTHERWISE WORD IS STORED IN PACKED FORM IN NAME
      CHARACTER*4 NAME,FILE
      CHARACTER*1 MCI,KSP,NOM(4)
      COMMON/XICBUF/ MCI(80)
      COMMON/XIOCOM/ MID,MI,MLI,MRI,LBI,MBI(81),MEI,LNO,
     .MSP,MA,MZ,MZERO,MNINE,MPL,MMIN,MDP,MAT,NLSYM,
     .MOD,MO,MLO,MRO,LBO,MBO(132),MEO
      DATA KSP/' '/
      DO 1 J = 1,4
1     NOM(J) = KSP
C FIRST CHARACTER
      CALL XCFIND(NX,0)
      I = 0
      IND = 1
      GO TO 4
    7 MI=MI+1
      I = I+1
      IND = 0
      IF (I.GT.NL) GO TO 3
      NOM(I) = MCI(MI)
C     SUBSEQUENT CHA RACTERS
    3 NX=MBI(MI+1)
      IF (NX.GE.MZERO.AND.NX.LE.MNINE) GO TO 7
4     IF(NX.GE.MA.AND.NX.LE.MZ) GO TO 7
      WRITE (FILE,41) NOM
41    FORMAT (4A1)
      READ (FILE,44) NAME
44    FORMAT (A4)
      RETURN
      END
C      SUBROUTINE XNFOUR (NAME,NL,IND)
CC VERSION OF XNFOUR FOR FORTRAN IV
CC READS THE NEXT ALPHAMERIC WORD IGNORING LEADING SPACES
CC ANY NON ALPHAMERIC CHARACTER WILL TERMINATE WORD.
CC WORDS OF MORE THAN NL CHARACTERS WILL BE TRUNCATED (NL.LE.4)
CC IF FIRST NON-SPACE CHARACTER IS NOT ALPHABETIC THEN IND=1
CC AND NAME IS EMPTY, OTHERWISE WORD IS STORED IN PACKED FORM IN NAME
C      INTEGER*4 NAME,KSP,INAME
C      COMMON/XIOCOM/ MID,MI,MLI,MRI,LBI,MBI(81),MEI,LNO,
C     .MSP,MA,MZ,MZERO,MNINE,MPL,MMIN,MDP,MAT,NLSYM,
C     .MOD,MO,MLO,MRO,LBO,MBO(132),MEO
C      DATA KSP/' '/
C      INAME = KSP
CC FIRST CHARACTER
C      CALL XCFIND(NX,0)
C      I = 0
C      IND = 1
C      GO TO 4
C    7 MI=MI+1
C      I = I+1
C      IND = 0
C      IF (I.GT.NL) GO TO 3
C      CALL XCMOVE (MBI(MI),1,INAME,I)
CC     SUBSEQUENT CHARACTERS
C    3 NX=MBI(MI+1)
C      IF (NX.GE.MZERO.AND.NX.LE.MNINE) GO TO 7
C4     IF(NX.GE.MA.AND.NX.LE.MZ) GO TO 7
C      NAME = INAME
C      RETURN
C      END
      SUBROUTINE XIREAD (I,IND)
C READS AN INTEGER NUMBER - IF ERROR IND=1
C PERMISSIBLE RANGE -32759 <= I <= +32759
      COMMON/XIOCOM/ MID,MI,MLI,MRI,LBI,MBI(81),MEI,LNO,
     .MSP,MA,MZ,MZERO,MNINE,MPL,MMIN,MDP,MAT,NLSYM,
     .MOD,MO,MLO,MRO,LBO,MBO(132),MEO
      DATA MAX10/3276/
      IP = (MNINE-MZERO)/9
      IND = 0
      ISGN=0
      I=0
      CALL XCFIND(NX,0)
      MIK = MI
      IF(NX.EQ.MPL) GO TO 20
      IF(NX.NE.MMIN) GO TO 25
      ISGN=1
20    MI = MI+1
      NX = MBI(MI+1)
   25 IF(NX.LT.MZERO.OR.NX.GT.MNINE) GO TO 90
   30 I=10*I + (NX-MZERO)/IP
      MI=MI+1
      NX=MBI(MI+1)
      IF(NX.LT.MZERO.OR.NX.GT.MNINE) GO TO 40
      IF(I.GE.MAX10) GO TO 100
      GO TO 30
   40 IF(ISGN.EQ.1) I=-I
      RETURN
C NON-NUMERIC SYMBOL OR NUMBER TOO BIG
90    MI = MIK
100   IND = 1
      RETURN
      END
      SUBROUTINE XDREAD(X,IFLT)
C READS A REAL NUMBER
      DOUBLE PRECISION X
C -S- REAL X
      COMMON/XIOCOM/ MID,MI,MLI,MRI,LBI,MBI(81),MEI,LNO,
     .MSP,MA,MZ,MZERO,MNINE,MPL,MMIN,MDP,MAT,NLSYM,
     .MOD,MO,MLO,MRO,LBO,MBO(132),MEO
      IP = (MNINE-MZERO)/9
      NEXP=0
      ISGN=0
      IFLT = 0
      IDP=-1
      X=0.0
      CALL XCFIND(NX,0)
      MIK = MI
      IF(NX.EQ.MPL) GO TO 10
      IF(NX.NE.MMIN) GO TO 15
      ISGN=1
   10 MI=MI+1
      NX=MBI(MI+1)
   15 IF(NX.NE.MDP) GO TO 20
      IDP=0
      MI=MI+1
      NX=MBI(MI+1)
   20 IF(NX.LT.MZERO.OR.NX.GT.MNINE) GO TO 90
   30 IF (IDP.GE.0) IDP = IDP+1
      X = 10.0*X + (NX-MZERO)/IP
35    MI=MI+1
      NX=MBI(MI+1)
      IF(NX.GE.MZERO.AND.NX.LE.MNINE) GO TO 30
      IF(NX.NE.MDP) GO TO 50
      IF(IDP.GE.0) GO TO 70
      IDP=0
      GO TO 35
C  LOOK FOR EXPONENT
   50 IF(NX.NE.MAT) GO TO 70
      MIK = MI
      MI = MI+1
      CALL XCFIND (NX,1)
      IF (NX.EQ.MSP) GO TO 65
      CALL XIREAD(NEXP,IFLT)
      IF (IFLT.EQ.0) GO TO 70
65    MI = MIK
      GO TO 111
   70 IF(IDP.GT.0) NEXP=NEXP-IDP
      IF (X.EQ.0.0) GO TO 111
      IF (DABS(DLOG10(X)+NEXP).GT.38.0) GO TO 100
C -S- IF ( ABS(ALOG10(X)+NEXP).GT.38.0) GO TO 100
      X=X * 10.0**NEXP
      IF(ISGN.EQ.1) X=-X
      GO TO 111
C FIRST SYMBOL NOT NUMERIC OR SIGN
90    MI = MIK
  100 IFLT=1
111   RETURN
      END
      SUBROUTINE XOSSET (N)
C PREPARES TO PRINT OUTPUT TO CHANNEL N
C IF N>0 THEN OUTPUT HAS A CARRIAGE CONTROL CHARACTER
C IF N<0 THEN OUTPUT IS TO CHANNEL -N WITHOUT CARRIAGE CONTROL
      COMMON/XIOCOM/ MID,MI,MLI,MRI,LBI,MBI(81),MEI,LNO,
     .MSP,MA,MZ,MZERO,MNINE,MPL,MMIN,MDP,MAT,NLSYM,
     .MOD,MO,MLO,MRO,LBO,MBO(132),MEO
      IF (MO.GE.MLO) CALL XNLINE (0)
      MOD=N
      MLO=1
      MRO = LBO
      MO = MLO-1
      RETURN
      END
      SUBROUTINE XOMARG(ML,MR)
C SETS THE MARGINS FOR THE OUTPUT STREAM
      COMMON/XIOCOM/ MID,MI,MLI,MRI,LBI,MBI(81),MEI,LNO,
     .MSP,MA,MZ,MZERO,MNINE,MPL,MMIN,MDP,MAT,NLSYM,
     .MOD,MO,MLO,MRO,LBO,MBO(132),MEO
      IF (MO.GE.MLO) CALL XNLINE (0)
      MLO = ML
      MRO=MR
      IF (MLO.LT.1) MLO = 1
      IF (MRO.GT.LBO) MRO = LBO
      IF (MLO.GT.MRO) MRO = MLO
      MO = MLO-1
      RETURN
      END
      SUBROUTINE XOECHO (N)
C CAUSES SUBSEQUENT OUTPUT TO BE ECHOED ON STREAM N. NO ECHO IF N=0
C IF N>0 THEN THE ECHO HAS CARRIAGE CONTROL CHARACTERS
C IF N<0 THEN ECHO IS TO STREAM -N WITHOUT CARRIAGE CONTROL
      COMMON/XIOCOM/ MID,MI,MLI,MRI,LBI,MBI(81),MEI,LNO,
     .MSP,MA,MZ,MZERO,MNINE,MPL,MMIN,MDP,MAT,NLSYM,
     .MOD,MO,MLO,MRO,LBO,MBO(132),MEO
      MEO = N
      RETURN
      END
      SUBROUTINE XNPAGE
C     CAUSES A PAGE CHANGE
      COMMON/XIOCOM/ MID,MI,MLI,MRI,LBI,MBI(81),MEI,LNO,
     .MSP,MA,MZ,MZERO,MNINE,MPL,MMIN,MDP,MAT,NLSYM,
     .MOD,MO,MLO,MRO,LBO,MBO(132),MEO
      CALL XNLINE(0)
      IF (MOD.GT.0) WRITE (MOD,1000)
      IF (MEO.GT.0) WRITE (MEO,1000)
 1000 FORMAT(1H1)
      RETURN
      END
      SUBROUTINE XIPRIN (INT,N)
C PRINTS AN INTEGER
C IF N<1 THEN INTEGER IS PUT AS FAR LEFT AS POSSIBLE
C OTHERWISE INTEGER IS PRINTED IN A FIELD WIDTH OF N + SPACE FOR SIGN
      COMMON/XIOCOM/ MID,MI,MLI,MRI,LBI,MBI(81),MEI,LNO,
     .MSP,MA,MZ,MZERO,MNINE,MPL,MMIN,MDP,MAT,NLSYM,
     .MOD,MO,MLO,MRO,LBO,MBO(132),MEO
      DATA ND/4/
      I1 = IABS(INT)
      M = 10
C I2  IS NO. OF DIGITS PRINTED, NF THE FIELD WIDTH
      DO 8 I2 = 1,ND
      IF (I1.LT.M) GO TO 9
8     M = M*10
      I2 = ND+1
9     IF (N.GT.0) GO TO 19
      NF = I2
      IF (INT.LT.0) NF = NF+1
      GO TO 22
19    NF = N+1
      IF (NF.LE.I2) NF = I2+1
22    IF (NF.GT.MRO-MO) CALL XNLINE (0)
C CONVERT INTEGER AND PUT IT IN THE OUTPUT BUFFER
      MO = MO+NF
      M2 = MO-I2
      CALL XNOCHA (I1,M2+1,MO)
      IF (INT.LT.0) MBO(M2) = MMIN
      RETURN
      END
      SUBROUTINE XNLINE (N)
C     VERSION OF XNLINE FOR FORTRAN 77
C PRINT N NEWLINES
      CHARACTER BUFFER
      DIMENSION BUFFER(132)
      COMMON/XIOCOM/ MID,MI,MLI,MRI,LBI,MBI(81),MEI,LNO,
     .MSP,MA,MZ,MZERO,MNINE,MPL,MMIN,MDP,MAT,NLSYM,
     .MOD,MO,MLO,MRO,LBO,MBO(132),MEO
      NOD = IABS(MOD)
      NEO = IABS(MEO)
      IF (MO.GE.1) GO TO 12
      N1 = N
      IF (N1.LT.1) N1 = 1
      GO TO 37
12    CONTINUE
      DO 16 J = 1,MO
16    BUFFER(J) = CHAR(MBO(J))
      IF (MOD) 20,22,21
20    WRITE (NOD,1000) (BUFFER(J),J = 1,MO)
      GO TO 22
21    WRITE (NOD,1001) (BUFFER(J),J = 1,MO)
22    IF (MEO) 25,27,26
25    WRITE (NEO,1000) (BUFFER(J),J = 1,MO)
      GO TO 27
26    WRITE (NEO,1001) (BUFFER(J),J = 1,MO)
27    CONTINUE
      N1 = N-1
      IF (N1.LE.0) GO TO 44
37    DO 39 J = 1,N1
      IF (MEO.NE.0) WRITE (NEO,1002)
39    IF (MOD.NE.0) WRITE (NOD,1002)
1000  FORMAT (132A1)
1001  FORMAT (1X,132A1)
1002  FORMAT (1X)
44    DO 45 J = 1,MRO
45    MBO(J) = MSP
      MO = MLO-1
      RETURN
      END
C      SUBROUTINE XNLINE (N)
CC     VERSION OF XNLINE FOR FORTRAN IV
CC PRINT N NEWLINES
C      COMMON/XIOCOM/ MID,MI,MLI,MRI,LBI,MBI(81),MEI,LNO,
C     .MSP,MA,MZ,MZERO,MNINE,MPL,MMIN,MDP,MAT,NLSYM,
C     .MOD,MO,MLO,MRO,LBO,MBO(132),MEO
C      NOD = IABS(MOD)
C      NEO = IABS(MEO)
C      IF (MO.GE.1) GO TO 12
C      N1 = N
C      IF (N1.LT.1) N1 = 1
C      GO TO 37
C12    CONTINUE
C      IF (MOD) 20,22,21
C20    WRITE (NOD,1000) (MBO(J),J = 1,MO)
C      GO TO 22
C21    WRITE (NOD,1001) (MBO(J),J = 1,MO)
C22    IF (MEO) 25,27,26
C25    WRITE (NEO,1000) (MBO(J),J = 1,MO)
C      GO TO 27
C26    WRITE (NEO,1001) (MBO(J),J = 1,MO)
C27    CONTINUE
C      N1 = N-1
C      IF (N1.LE.0) GO TO 44
C37    DO 39 J = 1,N1
C      IF (MEO.NE.0) WRITE (NEO,1002)
C39    IF (MOD.NE.0) WRITE (NOD,1002)
C1000  FORMAT (132A1)
C1001  FORMAT (1X,132A1)
C1002  FORMAT (1X)
C44    DO 45 J = 1,MRO
C45    MBO(J) = MSP
C      MO = MLO-1
C      RETURN
C      END
      SUBROUTINE XDPRFX (X,N1,N2)
C PRINTS A REAL VARIABLE X ALLOWING UP TO N1 DIGITS
C BEFORE THE DECIMAL POINT AND N2 AFTER IT, ALSO SPACE FOR SIGN
      DOUBLE PRECISION X,X2,X3,D10,TEN
C -S- REAL X,X2,X3,D10,TEN
      COMMON/XIOCOM/ MID,MI,MLI,MRI,LBI,MBI(81),MEI,LNO,
     .MSP,MA,MZ,MZERO,MNINE,MPL,MMIN,MDP,MAT,NLSYM,
     .MOD,MO,MLO,MRO,LBO,MBO(132),MEO
      DATA ND/4/,D10/1.0D4/,TEN/1.0D1/
C -S- DATA ND/4/,D10/10000.0/,TEN/10.0/
      IF (N2.LT.0) N2 = 0
      X2 = DABS(X*TEN**N2) + 0.5
C -S- X2 =  ABS(X*TEN**N2) + 0.5
C I2 IS THE NO. OF DIGITS, NF THE FIELD WIDTH
      IF (DABS(X).LT.1.0) GO TO 5
C -S- IF ( ABS(X).LT.1.0) GO TO 5
      I2 = IDINT(DLOG10(X2)) + 1
C -S- I2 = INT(ALOG10(X2)) + 1
      GO TO 7
5     I2 = N2+1
7     NF = N1+N2+1
      IF (NF.LE.I2) NF = I2+1
      IF (N2.GT.0) NF = NF+1
      IF (MO+NF.GT.MRO) CALL XNLINE (0)
      MO = MO+NF
      M1 = MO-I2+1
      M = M1
      N = I2-ND
C IF X EXCEEDS D10 THEN SPLIT IT INTO TWO OR MORE SECTIONS
      IF (X2.LT.D10) GO TO 10
9     X3 = TEN**N
      K = IDINT (X2/X3)
C -S- K = INT(X2/X3)
      CALL XNOCHA (K,M1,M1+ND-1)
      M1 = M1+ND
      N = N-ND
      X2 = X2-K*X3
      IF (N.GT.0) GO TO 9
10    CONTINUE
      K = IDINT(X2)
C -S- K = INT(X2)
      CALL XNOCHA (K,M1,MO)
C PUT THE DECIMAL POINT IN
      IF (N2.EQ.0) GO TO 15
      L = MO-N2
      DO 12 J = M,L
12    MBO(J-1) = MBO(J)
      MBO(L) = MDP
      M = M-1
15    IF (X.LT.0) MBO(M-1) = MMIN
      RETURN
      END
      SUBROUTINE XNOCHA (N,IST,LAST)
      COMMON/XIOCOM/ MID,MI,MLI,MRI,LBI,MBI(81),MEI,LNO,
     .MSP,MA,MZ,MZERO,MNINE,MPL,MMIN,MDP,MAT,NLSYM,
     .MOD,MO,MLO,MRO,LBO,MBO(132),MEO
      IP = (MNINE-MZERO)/9
      NUM = N
      L1 = LAST
      DO 10 J = IST,LAST
      NUMA = NUM/10
      NUMB = NUM - 10*NUMA
      NUM = NUMA
      MBO(L1) = NUMB*IP + MZERO
10    L1 = L1-1
      RETURN
      END
      SUBROUTINE XSPACE (N)
C PRINTS UP TO N SPACES
      COMMON/XIOCOM/ MID,MI,MLI,MRI,LBI,MBI(81),MEI,LNO,
     .MSP,MA,MZ,MZERO,MNINE,MPL,MMIN,MDP,MAT,NLSYM,
     .MOD,MO,MLO,MRO,LBO,MBO(132),MEO
      IF (N.LT.1) RETURN
      MO = MO+N
      IF (MO.GT.MRO) MO = MRO
      RETURN
      END
      SUBROUTINE XCPRIN (K)
C PRINTS THE CHARACTER K
      COMMON/XIOCOM/ MID,MI,MLI,MRI,LBI,MBI(81),MEI,LNO,
     .MSP,MA,MZ,MZERO,MNINE,MPL,MMIN,MDP,MAT,NLSYM,
     .MOD,MO,MLO,MRO,LBO,MBO(132),MEO
      IF (K.NE.NLSYM) GO TO 10
      CALL XNLINE (0)
      RETURN
10    IF (MO.GE.MRO) CALL XNLINE (0)
      MO = MO+1
      MBO(MO) = K
      RETURN
      END
      SUBROUTINE XPTEXT (ITEXT,LENGTH)
C  PRINTS THE CONTENTS OF A TEXT STRING (ITEXT) HELD IN PACKED FORMAT
C  LENGTH IS THE NUMBER OF CHARACTERS TO BE PRINTED
C-IV- INTEGER ITEXT(LENGTH)
      CHARACTER ITEXT(LENGTH)
      COMMON/XIOCOM/ MID,MI,MLI,MRI,LBI,MBI(81),MEI,LNO,
     .MSP,MA,MZ,MZERO,MNINE,MPL,MMIN,MDP,MAT,NLSYM,
     .MOD,MO,MLO,MRO,LBO,MBO(132),MEO
      DO 9 J = 1,LENGTH
      IF (MO.GE.MRO) CALL XNLINE (0)
      MO = MO+1
C-IV- CALL XCMOVE (ITEXT,J,MBO(MO),1)
      MBO(MO) = ICHAR(ITEXT(J))
9     CONTINUE
      RETURN
      END
      SUBROUTINE TERDIR
C
C     READS THE TERMINATOR SYMBOL
C     SYMBOLS NOT ALLOWED ARE LETTERS, DIGITS, DOT, COMMA, STAR,
C                             PARENTHESIS OR ARITHMETIC OPERATOR
C
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      CALL XCFIND (JS,0)
      CALL XCSKIP
      IF (JS.GE.LETERA.AND.JS.LE.LETERZ) GO TO 92
      IF (JS.GE.KZERO.AND.JS.LE.KNINE) GO TO 92
      IF (JS.EQ.KDOT.OR.JS.EQ.KOMMA.OR.JS.EQ.KSTAR) GO TO 92
      IF (JS.EQ.LBRACK.OR.JS.EQ.KBRACK) GO TO 92
      DO 64 J = 1,4
      IF (JS.EQ.KOPER(J)) GO TO 92
64    CONTINUE
      NTER = JS
      RETURN
C
C     SYNTAX ERROR - DISALLOWED SYMBOL
92    MISTAK = 2
      RETURN
      END
      SUBROUTINE COMDIR
C
C     READS AND PRINTS A COMMENT
C
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      CALL XPTEXT ('* * * * * Comment * * * * *',27)
      CALL XNLINE (1)
25    CALL XCREAD (N)
      IF (N.EQ.NTER) GO TO 35
      CALL XCPRIN (N)
      GO TO 25
35    CALL XNLINE (2)
      RETURN
      END
      SUBROUTINE NEXDIR
C
C     PRINTS A SUMMARY OF THE JOB
C
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      CALL XPTEXT ('End of analysis',15)
      CALL XNLINE (2)
C
C     WRITE THE AMOUNT OF STORE USED, THEN RESET IT
C
      CALL XPTEXT ('Store used: Real',16)
      CALL XIPRIN (LMAXRA,1)
      CALL XPTEXT (', Integer',9)
      CALL XIPRIN (LMAXIA,1)
      CALL XPTEXT ('      Left: Real',16)
      CALL XIPRIN (LENDRA-LMAXRA,1)
      CALL XPTEXT (', Integer',9)
      CALL XIPRIN (LENDIA-LMAXIA,1)
      CALL XNLINE (2)
C
      LMAXRA = 0
      LMAXIA = 0
      RETURN
      END
      SUBROUTINE PARDIR
C
C     READS EDEX PARAMETERS
C
      DIMENSION JPAR(5)
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      CALL XPTEXT ('    P    V   PF   TF  SEN',25)
      CALL XNLINE(1)
      DO 20 J = 1,5
      CALL XIREAD(JPAR(J),IND)
      IF (IND.NE.0) GO TO 92
      IF (JPAR(J).LT.0) GO TO 92
      CALL XIPRIN (JPAR(J),4)
20    CONTINUE
      CALL XNLINE (2)
      NUNITS = JPAR(1)
      IF (NUNITS.LT.2) GO TO 93
      NVSTOR = JPAR (2)
      IF (NVSTOR.EQ.0) NVSTOR  = 1
      NBLOCK = JPAR(3)
      NTREAT = JPAR(4)
      IF (NTREAT.EQ.0) NTREAT = 1
      NFACTO = NBLOCK+NTREAT
      NEFFEC = JPAR(5)
      NNAMES = NFACTO+NEFFEC
C
C     SET UP ARRAY SPACE
C
C REAL
      AR = FLOAT(NUNITS)*FLOAT(NVSTOR)
      AI = 5.0*FLOAT(NNAMES) + FLOAT(NFACTO)*FLOAT(NUNITS) +
     .     3.0*FLOAT(NVSTOR) + FLOAT(NTREAT)
      IF (AR.GT.FLOAT(LENDRA).OR.AI.GT.FLOAT(LENDIA)) GO TO 97
      LDATA = 0
      LEV2RA = LDATA+NUNITS*NVSTOR
      LSPEFF = LEV2RA
C
C INTEGER
      LNAME = 0
      LLEVEL = LNAME + 2*NNAMES
      LLABST = LLEVEL+NFACTO
      LSPFPT = LLABST+NTREAT
      LSECOF = LSPFPT+NEFFEC
      LCODE = LSECOF+NEFFEC
      LFCHEK = LCODE+NUNITS*NFACTO
      LCHECK = LFCHEK+NFACTO
      LHALT = LCHECK+NVSTOR
      LINDEX = LHALT+NVSTOR
      LROINT = LINDEX+NVSTOR
      LLABEL = LROINT+NNAMES
      LEV2IA = LLABEL
      LEV3IA = 0
      LEV3RA = 0
      IF (LEV2RA.GT.LMAXRA) LMAXRA = LEV2RA
      IF (LEV2IA.GT.LMAXIA) LMAXIA = LEV2IA
C
C OTHER VARIABLES
C
      DO 28 J = 1,LEV2IA
28    IA (J) = 0
      DO 38 J = 1,LEV2RA
38    RA(J) = 0.0
C
      NDATAL = 0
      NDFLAG(1) = NBLOCK
      NDFLAG(2) = NTREAT
      NDFLAG(3) = NEFFEC
      MAXLN = 8
      MAXWID = 12
      NWIDTH = MAXWID
      NTERMS = 0
      CALL XLSKIP
      RETURN
C
C     FAULTS
C
C     SYNTAX ERROR
92    MISTAK = 2
      GOTO 99
C     TOO FEW UNITS
93    MISTAK = 22
      GOTO 99
C     STORE FULL
97    MISTAK = 27
99    RETURN
      END
      SUBROUTINE BLODIR
C
C     READS THE BLOCKS DIRECTIVE
C
      DIMENSION NOM(2)
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
C     BLOCKS CANCELS ANY PREVIOUS LIST
C
      NDFLAG(1) = NBLOCK
      NTERMS = 0
      CALL XPTEXT ('Blocks',6)
      CALL XNLINE(1)
      IF (NBLOCK.EQ.0) GOTO 90
      JLEVEP = LLEVEL+NTREAT
      JCHECP = LFCHEK+NTREAT
      JNAMEP = LNAME+NTREAT*2
      NOM(2) = KSPACE
C
C FACTORNAME
C
      DO 25 J = 1,NBLOCK
      CALL XCFIND (N,0)
      CALL XCSKIP
      CALL XCPRIN (N)
      IF (N.EQ.LETERV) GOTO 96
      IF (N.LT.LETERA.OR.N.GT.LETERZ) GOTO 92
      NOM(1) = N
C
C     CHECK THAT THE FACTOR IS NOT ALREADY DECLARED
C
      IF (J.EQ.1) GO TO 17
      JN = LNAME+NTREAT*2+1
      CALL FINDNA (NOM,JN,J-1,K)
      IF (K.GT.0) GO TO 89
17    IF (NDFLAG(2).NE.0) GO TO 20
      CALL FINDNA (NOM,LNAME+1,NTREAT,K)
      IF (K.GT.0) GO TO 89
C
C NO OF LEVELS
C
20    CALL XIREAD (L,IND)
      IF (IND.NE.0) GOTO 92
      CALL XIPRIN (L,2)
      CALL XNLINE (1)
      IF (L.LE.1) GOTO 94
      JLEVEP = JLEVEP+1
      IA (JLEVEP) = L
      JCHECP = JCHECP+1
      IA(JCHECP) = 0
      JNAMEP = JNAMEP+2
      IA (JNAMEP-1) = N
      IA(JNAMEP) = KSPACE
25    CONTINUE
      NDFLAG(1) = 0
      CALL XNLINE (1)
      CALL XLSKIP
      RETURN
C
C     FAULTS
C
C     FACTOR DECLARED TWICE
89    MISTAK = 9
      GO TO 99
C     NO BLOCKS PARAMETER
90    MISTAK = 20
      GOTO 99
C     SYNTAX ERROR
92    MISTAK = 2
      GOTO 99
C     NUMBER OF LEVELS
94    MISTAK = 14
      GOTO 99
C     LETTER V NOT ALLOWED AS A FACTOR NAME
96    MISTAK = 6
C
99    RETURN
      END
      SUBROUTINE TREDIR
C
C     READS THE TREATMENTS DIRECTIVE
C
      DIMENSION NOM(2)
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
C     TREATMENTS CANCELS ANY PREVIOUS SPECIAL EFFECTS OR LIST
C
      NDFLAG(2) = NTREAT
      NDFLAG(3) = NEFFEC
      NTERMS = 0
      CALL XPTEXT ('Treatments',10)
      CALL XNLINE(1)
      JLABEL = 0
      JLABSP = LLABST
      JLABEP = LLABEL
      JLEVEP = LLEVEL
      JCHECP = LCHECK
      JNAMEP = LNAME
      NOM(2) = KSPACE
C
C     FACTOR NAME
C
      DO 25 JT = 1,NTREAT
      CALL XCFIND (N,0)
      CALL XCSKIP
      CALL XCPRIN (N)
      IF (N.EQ.LETERV) GOTO 96
      IF (N.LT.LETERA.OR.N.GT.LETERZ) GOTO 92
      NOM(1) = N
C
C     CHECK THAT THE FACTOR IS NOT ALREADY DECLARED
C
      IF (JT.EQ.1) GO TO 17
      CALL FINDNA (NOM,LNAME+1,JT-1,K)
      IF (K.GT.0) GO TO 89
17    IF (NDFLAG(1).NE.0) GO TO 20
      JN = LNAME+NTREAT*2+1
      CALL FINDNA (NOM,JN,NBLOCK,K)
      IF (K.GT.0) GO TO 89
C
C     NUMBER OF LEVELS
C
20    CALL XIREAD (L,IND)
      IF (IND.NE.0) GOTO 92
      CALL XIPRIN (L,2)
      CALL XSPACE (2)
      IF (L.LE.1) GO TO 94
      JLEVEP = JLEVEP+1
      IA(JLEVEP) = L
      JCHECP = JCHECP+1
      IA(JCHECP) = 0
      JNAMEP = JNAMEP+2
      IA(JNAMEP-1) = N
      IA(JNAMEP) = KSPACE
      JLABSP = JLABSP+1
      IA(JLABSP) = JLABEP
C
C     LEVEL NAMES
C
      DO 35 K = 1,L
      IF (JLABEP+MAXLN.GT.LENDIA) GO TO 97
      JLABEP = JLABEP+1
      JLABER = JLABEP
      N = 0
      CALL XCFIND (J,0)
      CALL XCSKIP
      CALL XCPRIN (J)
      IF (J.EQ.NTER.OR.J.EQ.KOMMA) GOTO 92
27    N = N+1
      JLABEP = JLABEP+1
      IA(JLABEP) = J
28    CALL XCFIND (J,0)
      CALL XCSKIP
      CALL XCPRIN (J)
      IF (J.EQ.NTER.OR.J.EQ.KOMMA)GOTO 30
      IF (N-MAXLN) 27,28,28
30    IA(JLABER) = N
      IF (K.EQ.L) GOTO 38
      IF (J.NE.KOMMA) GO TO 94
35    CONTINUE
38    IF (J.NE.NTER) GO TO 94
      CALL XNLINE (1)
25    CONTINUE
      NDFLAG(2) = 0
      CALL XNLINE (1)
      CALL XLSKIP
      LEV2IA = JLABEP
      IF (LEV2IA.GT.LMAXIA) LMAXIA = LEV2IA
      LLIST = LEV2IA
      RETURN
C
C     FAULTS
C
C     FACTOR DECLARED TWICE
89    MISTAK = 9
      GO TO 99
C     SYNTAX ERROR
92    MISTAK = 2
      GOTO 99
C     NUMBER OF LABELS
94    MISTAK = 14
      GOTO 99
C     LETTER V NOT ALLOWED AS A FACTOR NAME
96    MISTAK = 6
      GO TO 99
C     STORE FULL
97    MISTAK = 27
C
99    RETURN
      END
      SUBROUTINE SPEDIR
C
C     READS THE SPECIAL EFFECTS DIRECTIVE
C
      DOUBLE PRECISION C
C -S- REAL C
      DIMENSION NOM(2)
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
C     SPECIAL EFFECTS CANCELS PREVIOUS LIST
C
      NDFLAG(3) = NEFFEC
      JSPEFP = LSPEFF
      NTERMS = 0
      CALL XPTEXT ('Special Effects',15)
      CALL XNLINE(1)
      IF (NEFFEC.EQ.0) GO TO 93
      IF (NDFLAG(2).NE.0) GO TO 95
C
C     FACTOR AND EFFECT NAMES
C
      DO 25 JE = 1,NEFFEC
      CALL XCFIND (J,0)
      CALL XCPRIN (J)
      CALL XCSKIP
      NOM(1) = J
      NOM(2) = KSPACE
      CALL FINDNA (NOM,LNAME+1,NTREAT,JT)
      IF (JT.LT.1) GOTO 97
      CALL XCREAD (J2)
      CALL XCPRIN (J2)
      IF (J2.LT.LETERA.OR.J2.GT.LETERZ) GOTO 92
      NOM(2) = J2
C
C     CHECK THAT IT HAS NOT BEEN DECLARED
C
      IF (JE.EQ.1) GO TO 17
      JN = LNAME+NFACTO*2+1
      CALL FINDNA (NOM,JN,JE-1,K)
      IF (K.GT.0) GO TO 89
17    JSPFPP = LSPFPT+JE
      IA(JSPFPP) = JT
      JSECOF = LSECOF+JE
      IA(JSECOF) = JSPEFP
      JNAMEP = LNAME+(NFACTO+JE)*2
      IA(JNAMEP-1) = J
      IA(JNAMEP) = J2
C
C     READ AND STORE THE COEFFICIENTS
C
      LT = LLEVEL+JT
      LEVS = IA(LT)
      IF (JSPEFP+LEVS.GT.LENDRA) GO TO 87
      DO 20 JM  = 1,LEVS
      CALL XSPACE(2)
      CALL READR (C,IND)
      IF (IND.NE.0) GO TO 94
      JSPEFP = JSPEFP+1
      RA(JSPEFP) = C
20    CONTINUE
      CALL XCFIND (J,1)
      IF (J.EQ.KSPACE) GO TO 23
      CALL READR (C,IND)
      IF (IND.EQ.0) GO TO 94
23    CALL XNLINE (1)
25    CONTINUE
C
      CALL XNLINE(1)
      CALL XLSKIP
      NDFLAG(3) = 0
      LEV2RA = JSPEFP
      IF (LEV2RA.GT.LMAXRA) LMAXRA = LEV2RA
      RETURN
C
C     FAULTS
C
C     STORE FULL
87    MISTAK = 27
      GO TO 99
C     EFFECT DECLARED TWICE
89    MISTAK = 9
      GO TO 99
C     NO EFFECTS PARAMETER
93    MISTAK = 23
      GO TO 99
C     SYNTAX ERROR
92    MISTAK = 2
      GOTO 99
C     NUMBER OF LEVELS
94    MISTAK = 14
      GO TO 99
C     TREATMENT NOT DECLARED
97    MISTAK = 7
      GOTO 99
C     NO TREATMENT DIRECTIVE
95    MISTAK = 5
C
99    RETURN
      END
      SUBROUTINE PLADIR
C
C     READS THE PLAN DIRECTIVE
C
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
C     CHECK THAT BLOCKS, TREATMENTS HAVE BEEN DECLARED
C
      NTERMS = 0
      IF (NDFLAG(1).NE.0.OR.NDFLAG(2).NE.0) GO TO 95
C
      IF (NDATAL.GT.0) NDATAL = 0
      NWIDTH = MAXWID
C
C     LOOK FOR * OPTION
C
      CALL XCFIND(JS,0)
      IF (JS.NE.KSTAR) GO TO 42
      CALL XCSKIP
      CALL XCFIND (JS,0)
      CALL XCSKIP
      IF (JS.EQ.LETERC) GO TO 52
      IF (JS.NE.LETERS) GO TO 92
C
C     STANDARD ORDER - CHECK THAT IT CAN BE DONE
C
      CALL STANDA
      GO TO 76
C
C     OTHER TYPES OF PLAN - READ, PRINT AND ASSIGN THE BLOCK STRUCTURE
C
42    CALL RDPLAN (0)
      GO TO 76
52    CALL RDPLAN (1)
C
76    CALL XNLINE (2)
      CALL XLSKIP
      RETURN
C
C     FAULTS
C
C     SYNTAX ERROR
92    MISTAK = 2
      GO TO 99
C     NO BLOCKS OR NO TREATMENTS
95    MISTAK = 5
C
99    RETURN
      END
      SUBROUTINE RDPLAN (ISEC)
C
C     READ THE PLAN UNIT BY UNIT
C     ISEC = 1 IF THE *C OPTION HAS BEEN READ, OTHERWISE 0
C
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      COMMON/EDEXIO/ KINST,NINSTK,INSTK(5),MAXSTK,MININ,MAXIN,
     .               KOUTST,MINOUT,MAXOUT,KIECHO,KOECHO,KINLEN,KOUTLN
C
      CALL XPTEXT ('Plan',4)
      CALL XNLINE (1)
C
C     MARK ALL FACTORS AS 'UNASSIGNED'
C     IF ANY FACTOR HAS MORE THAN TEN LEVELS THEN LEVELS FOR ALL FACTORS
C     MUST BE GIVEN AS TWO-DIGIT NUMBERS
C
      IP = (KNINE-KZERO)/9
      JLDIG = 1
      JLP = LLEVEL
      JCP = LFCHEK
      DO 37 J = 1,NFACTO
      JCP = JCP+1
      IA(JCP) = 0
      IF (J.GT.NTREAT) GO TO 37
      JLP = JLP+1
      IF (IA(JLP).GT.10) JLDIG = 2
37    CONTINUE
C
C     READ, PRINT AND ASSIGN THE BLOCK STRUCTURE
C
      JINST = KINST
      IF (NBLOCK.EQ.0) GO TO 48
      JC = KOMMA
      CALL RDIMEN (JQ,NWIDTH,KSTAR,JC,IND)
      IF (IND.NE.0) GO TO 92
      DO 46 JR = 1,NBLOCK
      IF (JR.EQ.NBLOCK) JC = NTER
      CALL RDIMEN (JS,JK,KSTAR,JC,IND)
      IF (IND.NE.0) GO TO 92
      JLEVEP = LLEVEL+NTREAT+JR
      JCODEP = LCODE+NTREAT+JR
      IF (MOD(JQ,JS).NE.0.OR.MOD(NWIDTH,JK).NE.0
     ..OR. NUNITS/(JS*JK).NE.IA(JLEVEP)) GO TO 85
      JL = JS*NWIDTH
      JS = NWIDTH/JK
      DO 45 JU = 1,NUNITS
      JV = JU-1
      JT = MOD(JV,NWIDTH)
      IA(JCODEP) = JS*(JV/JL)+(JT/JK)
      JCODEP = JCODEP+NFACTO
45    CONTINUE
46    CONTINUE
      CALL XNLINE (1)
      IF (NWIDTH.GT.MAXWID) NWIDTH = MAXWID
C
C     TREATMENT STRUCTURE
C
48    IF (ISEC.EQ.1) GO TO 52
      CALL XCFIND (JS,0)
      IF (JS.NE.KSTAR) GO TO 55
      CALL XCSKIP
      CALL XCREAD (JS)
      IF (JS.NE.LETERC) GO TO 92
C
C     NEW STREAM
C
52    CALL NEWCHA (JINST,1)
      IF (JINST.LT.0) GO TO 96
      CALL XISSET (JINST)
C
C     TREATMENT LEVELS
C
55    J = KSPACE
      JW = 1
      JCODEP = LCODE
      DO 72 JU = 1,NUNITS
      IF (NDATAL.LT.0) GO TO 57
      IF (J.NE.KSPACE) GO TO 57
      NDATAL = NDATAL+1
      CALL XIREAD (JN,IND)
      IF (IND.GT.0.OR.JN.NE.NDATAL) GO TO 88
57    CALL XCFIND (J,0)
      DO 60 L = 1,NTREAT
      JLEVEP = LLEVEL+L
      M = 0
      DO 58 K = 1,JLDIG
      CALL XCREAD (N)
      IF (N.LT.KZERO.OR.N.GT.KNINE) GO TO 92
      CALL XCPRIN (N)
      M = M*10+ (N-KZERO)/IP
58    CONTINUE
      IF(M.GE.IA(JLEVEP)) GO TO 86
      JCODEP = JCODEP+1
      IA(JCODEP) = M
60    CONTINUE
      IF (JW.LT.NWIDTH) GO TO 63
      JW = 1
      CALL XNLINE (1)
      GO TO 64
63    JW = JW+1
      CALL XSPACE (2)
64    CONTINUE
      CALL XCFIND (J,1)
      JCODEP = JCODEP+NBLOCK
72    CONTINUE
C
C     MARK ALL THE FACTORS AS 'ASSIGNED'
C
      JCHECP = LFCHEK
      DO 77 J = 1,NFACTO
      JCHECP = JCHECP+1
      IA(JCHECP) = 1
77    CONTINUE
      GO TO 99
C
C     FAULTS
C
C     INCONSISTENT BLOCK STRUCTURE
85    MISTAK = 15
      GO TO 99
C     LEVEL NUMBER TOO LARGE
86    MISTAK = 16
      GO TO 99
C     OUT OF SEQUENCE
88    MISTAK = 18
      GO TO 99
C     SYNTAX ERROR
92    MISTAK = 2
      GO TO 99
C     ILLEGAL STREAM
96    MISTAK = 26
C
99    IF (JINST.NE.KINST) CALL XISSET (KINST)
      RETURN
      END
      SUBROUTINE RDIMEN (JROWS,JCOLS,KSTAR,KTER,IND)
C
C     READS THE DIMENSION OF THE N'TH BLOCK STRUCTURE, I.E.
C     ROWS*COLS FOLLOWED BY TERMINATOR KTER
C
      CALL XIREAD (JROWS,IND)
      IF (IND.GT.0)  GO TO 99
      CALL XIPRIN (JROWS,0)
      CALL XCFIND (JS,1)
      IF (JS.EQ.KSTAR) CALL XCSKIP
      CALL XCPRIN (KSTAR)
      CALL XIREAD (JCOLS,IND)
      IF (IND.GT.0) GO TO 99
      CALL XIPRIN (JCOLS,0)
      CALL XCFIND (JS,1)
      IF (JS.EQ.KTER) CALL XCSKIP
      CALL XCPRIN (KTER)
99     RETURN
      END
      SUBROUTINE STANDA
C
C     ASSIGNS THE PLAN USING STANDARD ORDER *S1 OR *S2
C
      DIMENSION NOM(2),IX(25)
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      CALL XIREAD (JN,IND)
      IF (IND.NE.0) GO TO 92
      IF (JN.EQ.1) GO TO 14
      IF (JN.EQ.2) GO TO 40
      GO TO 87
C
C     STANDARD ORDER 1 - CHECK THAT IT CAN BE DONE
C
14    JPRODL = 1
      JXP = NTREAT
      JLP = LLEVEL+NTREAT
      L = 1
      DO 22 J = 1,NTREAT
      IX(JXP) = JPRODL
      JPRODL = JPRODL*IA(JLP)
      IF (JPRODL.LE.MAXWID) NWIDTH = JPRODL
      JLP = JLP-1
      JXP = JXP-1
22    CONTINUE
      IF (NBLOCK-1) 30,25,87
25    JLEVEP = LLEVEL+NTREAT+1
      L = IA(JLEVEP)
      IX(NTREAT+1) = JPRODL
30    IF (NUNITS.NE.L*JPRODL) GO TO 87
      GO TO 50
C
C     STANDARD ORDER 2 - READ THE FACTORS AND THE NUMBER OF TIMES EACH
C     LEVEL IS REPEATED FOR THOSE FACTORS
C
40    NOM(2) = KSPACE
      NWIDTH = 1
      DO 42 J = 1,NFACTO
42    IX(J) = 0
C
44    CALL XIREAD (N,IND)
      IF (IND.NE.0) GO TO 92
      CALL XCFIND (NOM(1),0)
      CALL XCSKIP
      CALL FINDNA (NOM,LNAME+1,NFACTO,JF)
      IF (JF.LT.1) GO TO 88
      K = LLEVEL+JF
      IF (MOD(NUNITS,IA(K)).NE.0) GO TO 87
      IX(JF) = N
      IF (N.GT.NWIDTH.AND.N.LT.MAXWID) NWIDTH = N
      CALL XCFIND (JS,0)
      CALL XCSKIP
      IF (JS.EQ.KOMMA) GO TO 44
      IF (JS.NE.NTER) GO TO 92
C
C     ALL TYPES: ASSIGN THE FACTOR LEVELS TO THE UNITS
C
50    DO 60 JF = 1,NFACTO
      L = IX(JF)
      IF (L.EQ.0) GO TO 60
      JCODEP = LCODE+JF
      N = 0
      M = 0
      JLP = LLEVEL+JF
      JCP = LFCHEK+JF
      IA(JCP) = 1
      DO 58 JU = 1,NUNITS
         IA(JCODEP) = N
         M = M+1
         IF (M.LT.L) GO TO 56
         M = 0
         N = N+1
         IF (N.GE.IA(JLP)) N = 0
56       JCODEP = JCODEP+NFACTO
58    CONTINUE
60    CONTINUE
      IF (NWIDTH.EQ.1) NWIDTH = MAXWID
C
      RETURN
C
C     FAULT - STANDARD ORDER NOT POSSIBLE
87    MISTAK = 17
      GO TO 99
C     FACTOR NOT DECLARED
88    MISTAK = 7
      GO TO 99
C     ILLEGAL SYMBOL
92    MISTAK = 2
99    RETURN
      END
      SUBROUTINE DATDIR
C
C     PERFORMS THE DATA DIRECTIVE
C
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      COMMON/LOCALS/ LWRK(17),
     . LX,LDEC1,LDEC2,LNEWNA,LLSOFA,LLABSB,JINST,ITEMS,IHEAD,IPRINT
      COMMON/EDEXIO/ KINST,NINSTK,INSTK(5),MAXSTK,MININ,MAXIN,
     .                KOUTST,MINOUT,MAXOUT,KIECHO,KOECHO,KINLEN,KOUTLN
C
C     MAKE ROOM FOR LOCAL ARRAYS
C
      IHEAD = 0
      IF (NDATAL.GT.0) NDATAL = 0
      JINST = KINST
      JFV = NFACTO+NVSTOR
      LX = LEV2IA
      LDEC1 = LX+JFV
      LDEC2 = LDEC1+JFV
      LNEWNA = LDEC2+JFV
      JEND = LNEWNA+MAXLN
      IF (NBLOCK.EQ.0) GO TO 72
      LLSOFA = JEND
      LLABSB = LLSOFA+NBLOCK
C
C     NO BLOCK NAMES HAVE BEEN DECLARED SO FAR
C
      JD = LLSOFA
      JL = LLEVEL+NTREAT
      JP = LLABSB
      JS = LLABSB+NBLOCK
      DO 70 J = 1,NBLOCK
      JD = JD+1
      IA(JD) = 0
      JP = JP+1
      JL = JL+1
      IA(JP) = JS
      JS = JS+IA(JL)*(MAXLN+1)
70    CONTINUE
      JEND = JS
72    IF (JEND.GT.LMAXIA) LMAXIA = JEND
      IF (JEND.GT.LENDIA) GO TO 97
C
C     READ THE NEXT SET OF VARIATES
C
76    CALL FVLIST
      IF (MISTAK.NE.0) GO TO 99
      IF (ITEMS.EQ.0) GO TO 99
      CALL REDATA
      IF (JINST.NE.KINST) CALL XISSET (KINST)
      IF (MISTAK.GT.0) GO TO 99
      IF (IPRINT.NE.0) CALL DATPRI
      GO TO 76
C
C STORE FULL
97    MISTAK = 27
C
99    RETURN
      END
      SUBROUTINE FVLIST
C
C     READS A LIST OF FATORS AND VARIATES TO BE READ IN PARALLEL
C     BY THE DATA DIRECTIVE
C
      DIMENSION NOM(2)
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      COMMON/LOCALS/ LWRK(17),
     . LX,LDEC1,LDEC2,LNEWNA,LLSOFA,LLABSB,JINST,ITEMS,IHEAD,IPRINT
C
      ITEMS = 0
      IPRINT = 0
      CALL XCFIND (JS,0)
      IF (JS.LT.LETERA.OR.JS.GT.LETERZ) GO TO 92
      IF (JS.EQ.LETERV) GO TO 30
      CALL XCSKIP
      CALL XCNEXT (JT)
      IF (JT.LT.LETERA.OR.JT.GT.LETERZ) GO TO 23
C TWO CONSECUTIVE LETTERS, PRESUMABLY A DIRECTIVE. BACKTRACK
      CALL XCBACK
      GO TO 70
C
C FACTOR NAME. IF IT ISN'T, ASSUME IT TO BE THE FIRST ITEM OF DATA
23    NOM(1) = JS
      NOM(2) = KSPACE
      CALL FINDNA (NOM,LNAME+1,NFACTO,N)
      IF (N.LE.0) IF (ITEMS) 97,97,70
      CALL XCSKIP
      GO TO 34
C
C VARIATE NAME
30    CALL XCSKIP
      CALL XIREAD (N,IND)
      IF (IND.GT.0) GO TO 92
      IF (N.LT.1.OR.N.GT.NVSTOR) GO TO 90
      N = -N
C
C     CHECK THAT NO ITEM APPEARS TWICE
C
34    JXP = LX+1
      IF (ITEMS.EQ.0) GO TO 37
      DO 36 J = 1,ITEMS
      IF (IA(JXP).EQ.N) GO TO 98
      JXP = JXP+1
36    CONTINUE
37    ITEMS = ITEMS+1
      IA(JXP) = N
C
C     DEFAULT - NO PRINTING
C
      JDEC1P = LDEC1+ITEMS
      IA(JDEC1P) = -1
      JDEC2P = LDEC2+ITEMS
      IA(JDEC2P) = 0
C
C     LOOK FOR THE NEXT ITEM - ANOTHER FACTOR OR VARIATE, *P(F), *F(P),
C     *C, OR THE DATA
C
   38 CALL XCFIND (JS,0)
      IF (JS.EQ.KSTAR) GO TO 46
      IF (JS.EQ.LETERV) GO TO 30
      IF (JS.GE.LETERA.AND.JS.LE.LETERZ) GO TO 23
      GO TO 70
   46 CALL XCSKIP
      JF = 0
      CALL XCREAD (JS)
      IF (JS.NE.LETERC) GO TO 50
C *C - FIND THE NEW CHANEL AND SWITCH TO IT.  ALSO TERMINATES THE LIST
      CALL NEWCHA (JINST,1)
      IF (JINST.LT.0) GO TO 96
      CALL XISSET (JINST)
      GO TO 70
   50 IF (JS.EQ.LETERP) GO TO 54
      IF (JS.NE.LETERF) GO TO 92
C
C *P, *PF, *FP FOLLOWED BY FIELD WIDTHS, OR *F
      JF = N
      CALL XCREAD (JS)
      IF (JS.NE.LETERP) GO TO 67
      GO TO 62
54    CALL XCNEXT (JS)
      IF (JS.NE.LETERF) GO TO 62
      JF = N
      CALL XCSKIP
   62 CALL XIREAD (J,IND)
      IF (IND.NE.0) GO TO 92
      IA(JDEC1P) = J
      IND = 1
      CALL XCFIND (JS,1)
      IF (JS.NE.KSPACE) CALL XIREAD (J2,IND)
      IF (IND.NE.0) J2 = 0
      IF (N.GT.0) J2 = 0
      IA(JDEC2P) = J2
      IPRINT = 1
67    IF (JF.GT.0) IA(JDEC2P) = 1
      GO TO 38
   70 RETURN
C
C     FAULTS
C
C     VARIATE NUMBER TOO BIG
90    MISTAK = 10
      GO TO 99
C     SYNTAX ERROR
92    MISTAK = 2
      GO TO 99
C     ILLEGAL CHANNEL
96    MISTAK = 26
      GO TO 99
C     FACTOR NOT DECLARED
97    MISTAK = 7
      GO TO 99
C     FACTOR OR VARIATE APPEARS TWICE
98    MISTAK = 9
C
99    RETURN
      END
      SUBROUTINE REDATA
C
C     READS THE DATA VALUES IN THE 'DATA' DIRECTIVE
C
      DOUBLE PRECISION A,C
C -S- REAL A,C
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      COMMON/LOCALS/ LWRK(17),
     . LX,LDEC1,LDEC2,LNEWNA,LLSOFA,LLABSB,JINST,ITEMS,IHEAD,IPRINT
C
C   MARK THE VARIATES AS 'UNASSIGNED' IN CASE OF  ERROR
C
      DO 30 JP = 1,ITEMS
      JXP = LX+JP
      N = IA(JXP)
      IF (N.LT.0) GO TO 28
      JCHEKP = LFCHEK+N
      GO TO 29
28    JCHEKP = LCHECK-N
29    IA(JCHEKP) = 0
30    CONTINUE
C
C     READ THE DATA UNIT BY UNIT
C
      J = KSPACE
      DO 56 JU = 1, NUNITS
      DO 55 JP = 1,ITEMS
      JXP = LX+JP
      N = IA(JXP)
      IF (NDATAL.LT.0) GO TO 34
      IF (J.NE.KSPACE)GO TO 34
C  NEW RECORD - CHECK ORDER
      NDATAL = NDATAL+1
      CALL XIREAD (JN,IND)
      IF (IND.NE.0) GO TO 88
      IF (JN.NE.NDATAL) GO TO 88
34    CONTINUE
      IF (N.LT.0) GO TO 35
C
C     FACTOR LEVEL
C
      CALL FACVAL (JU,N,JP)
      IF (MISTAK) 54,54,99
C
C     VARIATE
C
35    N = -N
      CALL XDREAD (A,IND)
      IF (IND.EQ.0) GO TO 52
      CALL XCREAD (J)
      IF (J.NE.LETERM.AND.J.NE.KSTAR) GO TO 36
C   MISSING
      A = RMV
      GO TO 52
C   TOTAL OR MEAN
36    IF (J.NE.LBRACK) GO TO 92
      A = 0
      JB = 0
      JQ = 1
      CALL XCFIND (J,1)
      IF (J.NE.LBRACK) GO TO 39
      JQ = 2
      CALL XCSKIP
39    CALL XCFIND (J,1)
      IF (NDATAL.LT.0) GO TO 42
      IF (J.NE.KSPACE) GO TO 42
      NDATAL = NDATAL+1
      CALL XIREAD (JN,IND)
      IF (IND.GT.0.OR.JN.NE.NDATAL) GO TO 88
      CALL XCFIND (J,1)
42    IF (J.EQ.KBRACK) GO TO 46
C  READ ONE VALUE AND ADD TO TOTAL
      CALL XDREAD (C,IND)
      IF (IND.GT.0) GO TO 92
      A = A+C
      JB = JB+1
      GO TO 39
46    IF (JB.EQ.0) GO TO 92
      CALL XCSKIP
      IF (JQ.EQ.2) GO TO 50
C  FORM THE MEAN
      A = A/JB
      GO TO 52
50    CALL XCREAD (J)
      IF (J.NE.KBRACK) GO TO 92
C STORE THE DATA
52    CONTINUE
      JDATAP = (JU-1)*NVSTOR - IA(JXP) + LDATA
      RA(JDATAP) = A
C
54    CALL XCFIND (J,1)
55    CONTINUE
56    CONTINUE
C
C     CHECK THAT THERE IS NO MORE DATA ON THIS LINE
C
      IF (J.NE.KSPACE) GO TO 89
C
C     MARK THE VARIATES JUST READ AS 'ASSIGNED'
C
      DO 63 JP = 1,ITEMS
      JXP = LX+JP
      N = IA(JXP)
      IF (N.LT.0) GO TO 60
      JCHEKP = LFCHEK+N
      IA(JCHEKP) = 1
      GO TO 63
60    JCHEKP = LCHECK-N
      IA(JCHEKP) = 1
      JHALTP = LHALT-N
      IA(JHALTP) = 0
63    CONTINUE
      CALL XNLINE (1)
      RETURN
C
C     FAULTS
C
C     DATA IN WRONG ORDER
88    MISTAK = 18
      GO TO 99
C     TOO MUCH DATA
89    MISTAK = 29
      GO TO 99
C     SYNTAX ERROR
92    MISTAK = 2
C
99    RETURN
      END
      SUBROUTINE FACVAL (KUNIT,KFAC,KITEM)
C
C     READS A LEVEL NAME AND LOOKS FOR IT IN THE LIST OF LEVEL NAMES
C     DECLARED SO FAR FOR FACTOR KFAC (ITEM KITEM IN CURRENT DATA LIST)
C
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      COMMON/LOCALS/ LWRK(17),
     . LX,LDEC1,LDEC2,LNEWNA,LLSOFA,LLABSB,JINST,ITEMS,IHEAD,IPRINT
C
      L = LLEVEL+KFAC
      JLEVLS = IA(L)
      L = LDEC2+KITEM
      IF (IA(L).GT.0) GO TO 54
C
C     LEVEL NAME EXPECTED - READ IT
C
      L = LNEWNA
      CALL XCFIND (JS,0)
      LENGTH = 0
20    LENGTH = LENGTH+1
      L = L+1
      IA(L) = JS
23    CALL XCSKIP
      CALL XCNEXT (JS)
      IF (JS.EQ.KSPACE.OR.JS.EQ.NLINE) GO TO 25
      IF (LENGTH.GE.MAXLN) GO TO 23
      GO TO 20
C
C     GET THE LIST OF DECLARED LEVEL NAMES
C
25    IF (KFAC.GT.NTREAT) GO TO 35
C     TREATMENT
      JB = LLABST+KFAC
      JB = IA(JB)+1
      JLEVLD = JLEVLS
      GO TO 39
C     BLOCKS
35    JB = LLABSB+KFAC-NTREAT
      JB = IA(JB)+1
      JLS = LLSOFA+KFAC-NTREAT
      JLEVLD = IA(JLS)
      IF (JLEVLD.EQ.0) GO TO 48
C
C COMPARE THE NEW NAME WITH THOSE ASSIGNED SO FAR
C
39    DO 46 J = 1,JLEVLD
      IF (LENGTH.NE.IA(JB)) GO TO 45
      L = LNEWNA
      M = JB
      DO 42 K = 1,LENGTH
      L = L+1
      M = M+1
      IF (IA(L).NE.IA(M)) GO TO 45
42    CONTINUE
C FOUND
      KLEV = J-1
      GO TO 58
45    JB = JB+IA(JB)+1
46    CONTINUE
C NOT FOUND - ADD THE NAME TO THE LIST IF THERE IS ROOM
      IF (JLEVLD.GE.JLEVLS) GO TO 94
48    L = LNEWNA
      M = JB
      IA(M) = LENGTH
      DO 50 K = 1,LENGTH
      L = L+1
      M = M+1
      IA(M) = IA(L)
50    CONTINUE
      IA(JLS) = JLEVLD+1
      KLEV = JLEVLD
      GO TO 58
C
C     FORMAL LEVEL - SHOULD BE 0 TO (LEVELS-1)
C
54    CALL XIREAD (K,IND)
      IF (IND.NE.0) GO TO 92
      IF (K.LT.0.OR.K.GE.JLEVLS) GO TO 96
      KLEV = K
C
C     STORE
C
58    JCODEP = LCODE + (KUNIT-1)*NFACTO + KFAC
      IA(JCODEP) = KLEV
      RETURN
C
C     FAULTS
C
C NOT AN INTEGER
92    MISTAK = 2
      GO TO 99
C LEVEL NAME NOT DECLARED OR TOO MANY LEVELS
94    MISTAK = 14
      GO TO 99
C LEVEL NUMBER TOO LARGE
96    MISTAK = 16
99    RETURN
      END
      SUBROUTINE DATPRI
C
C     PRINTS THE DATA VALUES READ IN BY THE DATA DIRECTIVE
C
      DOUBLE PRECISION A
C -S- REAL A
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      COMMON/LOCALS/ LWRK(17),
     . LX,LDEC1,LDEC2,LNEWNA,LLSOFA,LLABSB,JINST,ITEMS,IHEAD,IPRINT
      DO 64 JV = 1,ITEMS
      JDEC1P = LDEC1+JV
      JB = IA(JDEC1P)
      IF (JB.LT.0) GO TO 64
C
C     PRINT THE HEADING IF NONE HAS BEEN PRINTED
C
      IF (IHEAD.NE.0) GO TO 20
      CALL XPTEXT ('Data values input',17)
      CALL XNLINE (2)
      IHEAD = 1
20    IF (JB.GT.1) JB = JB-1
      JDEC2P = LDEC2+JV
      N = IA(JDEC2P)
      JXP = LX+JV
      JP = IA(JXP)
      JU = 0
      IF (JP.LT.0) GO TO 44
C
C FACTOR
      JC = LNAME+JP*2-1
      CALL XCPRIN (IA(JC))
      JCODEP = LCODE+JP
      GO TO 47
C
C VARIATE
44    CALL XCPRIN (LETERV)
      CALL XIPRIN (-JP,0)
      JDATAP = LDATA-JP
C
C     PRINT THE VALUES
C
47    CALL XNLINE (1)
      DO 61 JW = 1,NWIDTH
      JU = JU+1
      IF (JP.LT.0) GO TO 55
C
C FACTOR
      L = IA(JCODEP)
      JCODEP = JCODEP+NFACTO
      IF (JP.GT.NTREAT) GO TO 53
C TREATMENTS - ACTUAL LEVELS
      CALL LNPRIN (JP,L,JB+1)
      GO TO 60
C BLOCKS - FORMAL LEVELS
   53 CALL XIPRIN (L,JB)
      GO TO 60
C
C VARIATE
55    A = RA(JDATAP)
      JDATAP = JDATAP+NVSTOR
      IF (A.EQ.RMV) GO TO 56
C KNOWN VALUE
      CALL XDPRFX (A,JB,N)
      GO TO 60
C MISSING VALUE
   56 CALL MVPRIN (JB,N)
   60 CONTINUE
C
      IF (JU.EQ.NUNITS) GO TO 63
61    CONTINUE
      GO TO 47
C
63    CALL XNLINE (2)
   64 CONTINUE
      RETURN
      END
      SUBROUTINE WRIDIR
C
C     PRINTS OUT THE FACTORS AND VARIATES GIVEN IN THE WRITE DIRECTIVE
C
      DOUBLE PRECISION A
C -S- REAL A
      DIMENSION NOM(2)
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      COMMON/EDEXIO/ KINST,NINSTK,INSTK(5),MAXSTK,MININ,MAXIN,
     .               KOUTST,MINOUT,MAXOUT,KIECHO,KOECHO,KINLEN,KOUTLN
C     SET UP ARRAYS TO HOLD THE FIELD WIDTHS AND FACTOR/VARIATE NUMBERS
C
      LDEC1 = LEV2IA
      IF (LEV3IA.NE.0) LDEC1 = LEV3IA
      K = NFACTO+NVSTOR
      LDEC2 = LDEC1+K
      LX = LDEC2+K
      JEND = LX+K
      IF (JEND.GT.LENDIA) GO TO 97
      IF (JEND.GT.LMAXIA) LMAXIA = JEND
C
      JOUTST = KOUTST
      JOUTLN = KOUTLN
C
C     READ THE FACTOR AND VARIATE NAMES
C
      ITEMS = 0
      CALL XCFIND (JS,0)
      CALL XCSKIP
14    IF (JS.EQ.LETERV) GO TO 20
      IF (JS.LT.LETERA.OR.JS.GT.LETERZ) GO TO 92
C FACTOR
      NOM(1) = JS
      NOM(2) = KSPACE
      CALL FINDNA (NOM,LNAME+1,NFACTO,JF)
      IF (JF.LT.1) GO TO 87
      JCHECP = JF+LFCHEK
      GO TO 23
C VARIATE
20    CALL XIREAD (JV,IND)
      IF (IND.EQ.1) GO TO 92
      IF (JV.LT.1.OR.JV.GT.NVSTOR) GO TO 90
      JCHECP = JV+LCHECK
      JF = -JV
C FAULT IF IS HAS NOT BEEN ASSIGNED
23    IF (IA(JCHECP).EQ.0) GO TO 82
      ITEMS = ITEMS+1
      L = ITEMS+LX
      IA(L) = JF
C
C     READ NUMBER OF DECIMAL PLACES. 2ND FIGURE IS IGNORED FOR FACTORS
C
      CALL XIREAD (J,IND)
      IF (IND.NE.0) GO TO 92
      CALL XIREAD (J2,IND)
      IF (IND.NE.0) J2 = 0
      IF (JF.GT.0) J2 = 0
      L = ITEMS+LDEC1
      IA(L) = J
      L = ITEMS+LDEC2
      IA(L) = J2
C
C     LOOK FOR TERMINATOR, *C (SELECT OUTPUT) OR ANOTHER NAME
C
      CALL XCFIND (JS,0)
      CALL XCSKIP
      IF (JS.EQ.NTER) GO TO 34
      IF (JS.NE.KSTAR) GO TO 14
C
C     SELECT OUTPUT.  READ THE OUTPUT CHANNEL AND SWITCH TO IT
C     UNLESS THE CHANNEL IS OUT OF RANGE OR USED FOR INPUT
C
      CALL XCFIND (JS,1)
      IF (JS.NE.LETERC) GO TO 92
      CALL XCSKIP
      CALL NEWCHA (JOUTST,0)
      IF (JOUTST.LT.0) GO TO 86
      CALL XOSSET (-JOUTST)
      CALL XOMARG (1,80)
      JOUTLN = 78
      CALL XPTEXT ('''''',2)
      CALL XNLINE (1)
C
C     GET AS MANY FIELDS AS POSSIBLE THAT CAN FIT ON ONE LINE
C
34    LAST = 0
35    IST = LAST+1
      JW = 0
      DO 51 K = IST,ITEMS
      J = LDEC1+K
      JP = IA(J)
      J2 = LDEC2+K
      JQ = IA(J2)
      IF (JQ.GT.0) JQ = JQ+1
      IF (JW+JP+JQ.GT.JOUTLN) GO TO 53
      IF (JOUTST.EQ.KOUTST) GO TO 50
C
C WRITE THE FACTOR/VARIATE NAME IF USING SECONDARY OUTPUT
C
      JF = LX+K
      JF = IA(JF)
      IF (JF.GT.0) GO TO 42
C VARIATE
      CALL XSPACE (JP+JQ-3)
      IF (JF.GT.-10) CALL XSPACE (1)
      CALL XCPRIN (LETERV)
      CALL XIPRIN (-JF,0)
      GO TO 49
C FACTOR
42    CALL XSPACE (JP-1)
      JNAMEP = JF*2 + LNAME-1
      CALL XCPRIN (IA(JNAMEP))
49    CONTINUE
C
50    JW = JW+JP+JQ
51    CONTINUE
      K = ITEMS+1
53    LAST = K-1
      IF (JOUTST.EQ.KOUTST) GO TO 56
      CALL XPTEXT ('''''',2)
      CALL XNLINE (1)
56    CONTINUE
C
C     CYCLE THROUGH THE UNITS, PRINTING EACH VALUE AS APPROPRIATE
C
      DO 75 JU = 1,NUNITS
      DO 73 JF = IST,LAST
      L = LX+JF
      JV = IA(L)
      J = LDEC1+JF
      JP = IA(J)
      J2 = LDEC2+JF
      JQ = IA(J2)
C
      IF (JV.GT.0) GO TO 63
C
C     VARIATE - SPECIAL ACTION FOR MISSING VALUES
C
      JD = LDATA + (JU-1)*NVSTOR - JV
      A = RA(JD)
      IF (A.EQ.RMV) GO TO 60
      CALL XDPRFX (A,JP-1,JQ)
      GO TO 61
60    CALL MVPRIN (JP-1,JQ)
61    CONTINUE
      GO TO 71
C
C     FACTOR - LEVEL NAMES FOR TREATMENTS, FORMAL LEVELS FOR BLOCKS
C
63    JD = LCODE + (JU-1)*NFACTO + JV
      K = IA(JD)
      IF (JV.GT.NTREAT) GO TO 65
      CALL LNPRIN (JV,K,JP)
      GO TO 66
65    CALL XIPRIN (K,JP-1)
66    CONTINUE
C
71    CONTINUE
73    CONTINUE
      CALL XNLINE (1)
75    CONTINUE
C
C     END OF LIST - IF SECONDARY OUTPUT, PRINT 'EOD' AND SWITCH BACK TO
C     PRIMARY OUTPUT
C
      IF (JOUTST.NE.KOUTST)  CALL XPTEXT ('''EOD''',5)
      CALL XNLINE (1)
      IF (LAST.LT.ITEMS) GO TO 35
      IF (JOUTST.EQ.KOUTST) GO TO 79
      CALL XOSSET (KOUTST)
      CALL XOMARG (1,KOUTLN)
      CALL XCFIND (JS,0)
      IF (JS.EQ.NTER) CALL XCSKIP
79    CONTINUE
      RETURN
C
C     FAULTS
C
C     FACTOR/VARIATE NOT ASSIGNED
82    MISTAK = 12
      GO TO 99
C     INVALID OUTPUT CHANEL
86    MISTAK = 26
      GO TO 99
C     FACTOR NOT DECLARED
87    MISTAK = 7
      GO TO 99
C     VARIATE NUMBER TOO LARGE OR TOO SMALL
90    MISTAK = 10
      GO TO 99
C     ILLEGAL CHARACTER
92    MISTAK = 2
      GO TO 99
C     STORE FULL
97    MISTAK = 27
C
99    CONTINUE
      RETURN
      END
      SUBROUTINE DERDIR
C
C     CALCULATES DERIVED VARIATES
C
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      COMMON/LOCALS/ MCODE(20),
     .MAXCOD,LENCOD,LCON,NCON,JHALT,JDESTV,LAST
C
C     DECODE AND ANALYSE THE INSTRUCTIONS
C
      CALL XPTEXT ('Derived variate instructions',28)
      CALL XNLINE (1)
15    CALL DVREAD
      IF (LAST.EQ.-1) GO TO 29
      IF (MISTAK.NE.0) GO TO 30
      CALL DVCALC
      IF (MISTAK.NE.0) GO TO 30
      IF (LAST.EQ.0) GO TO 15
29    CALL XCSKIP
C
C     PRINT OUT A LIST OF THE HALTED VARIATES
C
30    JH = 0
      DO 35 J = 1,NVSTOR
      JHP = LHALT+J
      IF (IA(JHP).EQ.0) GO TO 35
      IF (JH.EQ.1) CALL XPTEXT (', ',2)
      CALL XCPRIN (LETERV)
      CALL XIPRIN (J,0)
      JH = 1
35    CONTINUE
      IF (JH.EQ.0) GO TO 40
      CALL XPTEXT (' not available for analysis',27)
      CALL XNLINE (1)
40    CONTINUE
      CALL XNLINE (2)
      RETURN
      END
      SUBROUTINE VREAD (JV,IND)
C
C     READS A VARIATE NAME AND PRINTS IT
C     RETURNS IND = 1 (NOT A V)   2 (V NOT FOLLOWED BY NUMBER)
C                   3 (VARIATE NO. ZERO OR TOO LARGE)   4 (OK)
C     RETURNS JV = VARIATE NUMBER IF IND=1 OR 2, OTHERWISE JV=UNDEFINED
C
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      IND = 1
      CALL XCFIND (JS,1)
      IF (JS.NE.LETERV) GO TO 19
      IND = 2
      CALL XCPRIN (JS)
      CALL XCSKIP
      CALL XCFIND (JS,1)
      IF (JS.EQ.KSPACE) GO TO 19
      CALL XIREAD (JV,N)
      IF (N.NE.0) GO TO 19
      CALL XIPRIN (JV,0)
      IND = 3
      IF (JV.GE.1.AND.JV.LE.NVSTOR) IND = 4
19    RETURN
      END
      SUBROUTINE DVREAD
C
C     ENCODES A DERIVED-VARIATE INSTRUCTION
C
C-IV- INTEGER*4 NAMFUN,KFNAME,KSUM
      CHARACTER*4 NAMFUN,KFNAME,KSUM
      DIMENSION NAMFUN(6)
      DOUBLE PRECISION A
C -S- REAL A
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      COMMON/LOCALS/ MCODE(20),
     .MAXCOD,LENCOD,LCON,NCON,JHALT,JDESTV,LAST
C
C     JDESTV = VARIATE ON LEFT OF EQUALS SIGN
C     JHALT = 1 IF ANY VARIATE ON RIGHT OF EQUALS SIGN IS HALTED
C     MAXCOD = LENGTH OF ARRAY MCODE
C     LENCOD = LENGTH OF THE EXPRESSION
C     NCON = NUMBER OF CONSTANTS IN THE EXPRESSION
C     LAST = 1 IF INSTRUCTION ENDS WITH TERMINATOR,
C            -1 IF TERMINATOR OCCURS ALONE, OTHERWISE 0
C
C     EACH ITEM OF THE EXPRESSION IS STORED AS FOLLOWS:
C
C         ITEM      CODE              ITEM      CODE
C     VARIATE N      -N              SUM(VA-VB)  10 -A -B
C           +         1              EXP(        11
C           -         2              LOG(        12
C           *         3             SQRT(        13
C           /         4              ANG(        14
C           (         8              DEG(        15
C           )         9              PCT(        16
C          END        0
C       CONSTANT    100+N, THE CONSTANT BEING STORED IN RA(LCON+N)
C
      DATA NFUNC/6/,KSUM/'SUM'/
      DATA NAMFUN/'EXP','LOG','SQR','ANG','DEG','PCT'/
      NTO = KOPER(2)
      MPLUS = KOPER(1)
      MINUS = KOPER(2)
      MAXCOD = 20
      LCON = LEV2RA
      LAST = 0
C
C     READ THE DESTINATION VARIATE VN=
C
      CALL XCFIND (JS,0)
      IF (JS.NE.NTER) GO TO 11
      LAST = -1
      GO TO 70
11    CALL VREAD (JDESTV,IND)
      GO TO (92,92,90,13),IND
13    CALL XCFIND (JS,1)
      IF (JS.NE.IQUAL) GO TO 92
      CALL XCPRIN (JS)
      CALL XCSKIP
C
C     DECODE THE EXPRESSION
C
      LEVEL = 0
      LENCOD = 0
      JHALT = 0
      NCON = 0
15    CALL XCFIND (JS,1)
      IF (JS.EQ.MPLUS) GO TO 16
C UNARY PLUS IGNORED
      IF (JS.NE.MINUS) GO TO 17
C
C     UNARY MINUS, TREATED AS 0-
      NCON = NCON+1
      JC = NCON+LCON
      IF (JC.GT.LENDRA) GO TO 93
      RA(JC) = 0.0
      LENCOD = LENCOD+2
      IF (LENCOD.GE.MAXCOD) GO TO 93
      MCODE(LENCOD) = 2
      MCODE(LENCOD-1) = 100+NCON
16    CALL XCPRIN(JS)
      CALL XCSKIP
      CALL XCFIND (JS,1)
C
17    IF (JS.NE.LBRACK) GO TO 20
C
C     OPENING BRACKET
      KODE = 8
18    LEVEL = LEVEL+1
19    CALL XCPRIN (JS)
      CALL XCSKIP
      LENCOD = LENCOD+1
      IF (LENCOD.GE.MAXCOD) GO TO 93
      MCODE(LENCOD) = KODE
      GO TO 15
C
C     VARIATE
20    CALL VREAD (JV,IND)
      GO TO (25,92,90,23),IND
23    JCHECP = LCHECK+JV
      IF (IA(JCHECP).EQ.0) GO TO 91
      JHALTP = LHALT+JV
      IF (IA(JHALTP).EQ.1) JHALT = 1
      KODE = -JV
      GO TO 52
C
25    CALL XCFIND (JS,1)
      IF (JS.EQ.KSPACE) GO TO 92
      CALL READR (A,IND)
      IF (IND.NE.0) GO TO 30
C
C     CONSTANT
      NCON = NCON+1
      JC = LCON+NCON
      IF (JC.GT.LENDRA) GO TO 93
      RA(JC) = A
      KODE = 100+NCON
      GO TO 52
C
C     NOT (, V, CONSTANT - FAULT IF NOT A FUNCTION
30    CALL XNFOUR (KFNAME,3,IND)
      CALL XPTEXT (KFNAME,3)
      IF (KFNAME.EQ.KSUM) GO TO 40
C
C     FUNCTION TAKING AN EXPRESSION
      DO 35 J = 1,NFUNC
      IF (KFNAME.EQ.NAMFUN(J)) GO TO 37
35    CONTINUE
      GO TO 92
37    CALL XCFIND (JS,1)
      IF (JS.NE.LBRACK) GO TO 92
      KODE = J+10
      GO TO 18
C
C     SUM(VA-VB)
40    CALL XCFIND (JS,1)
      IF (JS.NE.LBRACK) GO TO 92
      CALL XCPRIN (JS)
      CALL XCSKIP
      CALL VREAD (JVA,IND)
      GO TO (92,92,90,43),IND
43    CALL XCFIND (JS,1)
      IF (JS.NE.NTO) GO TO 92
      CALL XCPRIN (JS)
      CALL XCSKIP
      CALL VREAD (JVB,IND)
      GO TO (92,92,90,44),IND
44    IF (JVB.LT.JVA) GO TO 90
C CHECK THE VARIATES VA-VB ARE ASSIGNED AND NOT HALTED
      JHALTP = LHALT+JVA
      JCHECP = LCHECK+JVA
      DO 47 J = JVA,JVB
      IF (IA(JCHECP).EQ.0) GO TO 91
      IF (IA(JHALTP).NE.0) JHALT = 1
      JCHECP = JCHECP+1
      JHALTP = JHALTP+1
47    CONTINUE
      CALL XCFIND (JS,1)
      IF (JS.NE.KBRACK) GO TO 92
      CALL XCPRIN (JS)
      CALL XCSKIP
      LENCOD = LENCOD+3
      IF (LENCOD.GE.MAXCOD) GO TO 93
      MCODE(LENCOD-2) = 10
      MCODE(LENCOD-1) = -JVA
      MCODE(LENCOD) = -JVB
C
C     END OF OPERAND - LOOK FOR CLOSING BRACKET OR OPERATOR
C
50    CALL XCFIND (JS,1)
      IF (JS.NE.KBRACK) GO TO 55
      CALL XCPRIN (JS)
      CALL XCSKIP
      KODE = 9
      LEVEL = LEVEL-1
      IF (LEVEL.LT.0) GO TO 92
C
52    LENCOD = LENCOD+1
      IF (LENCOD.GE.MAXCOD) GO TO 93
      MCODE(LENCOD) = KODE
      GO TO 50
C
C    OPERATOR
55    DO 58 KODE = 1,4
      IF (JS.EQ.KOPER(KODE)) GO TO 19
58    CONTINUE
C
C     IF END OF LINE OR TERMINATOR FOLLOWS, THIS IS THE END.
C     OTHERWISE FAULT
      IF (JS.NE.KSPACE.AND.JS.NE.NTER) GO TO 92
      IF (LEVEL.NE.0) GO TO 92
      LENCOD = LENCOD+1
      IF (LENCOD.GT.MAXCOD) GO TO 93
      MCODE(LENCOD) = 0
      IF (JS.EQ.NTER) LAST = 1
C
70    CALL XNLINE (1)
      RETURN
C
C     FAULTS
C
C     VARIATE NUMBER OUT OF RANGE
90    MISTAK = 10
      GO TO 99
C     VARIATE NOT ASIGNED
91    MISTAK = 12
      GO TO 99
C     SYNTAX ERROR
92    MISTAK = 2
      GO TO 99
C     EXPRESSION TOO LNONG TO ANALYSE
93    MISTAK = 13
C
99    CALL XNLINE (1)
      RETURN
      END
      SUBROUTINE DVCALC
C
C     CALCULATES DERIVED VARIATES FROM INSTRUCTIONS CODED BY DVREAD
C
      DOUBLE PRECISION HIGHEX,B,C
C -S- REAL HIGHEX,B,C
      DIMENSION KRANK(18),LRANK(18),JOPSTK(10)
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      COMMON/LOCALS/ MCODE(20),
     .MAXCOD,LENCOD,LCON,NCON,JHALT,JDESTV,LAST
      DATA LRANK/5,0,2,2,3,3,0,0,0,4,1,0,6*4/
      DATA KRANK/0,5,2,2,3,3,0,0,0,1,4,0,6*1/
      DATA HIGHEX/87.49/
C
      JVSTKP = LEV2RA+NCON
      JOPSTK(1) = -1
      JOPP = 1
      JMCP = 0
C
C     FIND THE NEXT ITEM IN THE EXPRESSION
C
16    JMCP = JMCP+1
      JCH = MCODE(JMCP)
      JEND = JVSTKP+NUNITS
      IF (JCH.GT.100) GO TO 23
      IF (JCH.EQ.10) GO TO 30
      IF (JCH.GE.0) GO TO 40
C
C     VARIATE - ADD IT TO THE VARIATES STACK
C
      IF (JEND.GT.LENDRA) GO TO 97
      IF (JEND.GT.LMAXRA) LMAXRA = JEND
      JDATAP = LDATA-JCH
      DO 20 JU = 1,NUNITS
      JVSTKP = JVSTKP+1
      RA(JVSTKP) = RA(JDATAP)
      JDATAP = JDATAP+NVSTOR
20    CONTINUE
      GO TO 16
C
C     CONSTANT
C
23    JC = LCON+JCH-100
      B = RA(JC)
      IF (JEND.GT.LENDRA) GO TO 97
      IF (JEND.GT.LMAXRA) LMAXRA = JEND
      DO 25 JU = 1,NUNITS
      JVSTKP = JVSTKP+1
      RA(JVSTKP) = B
25    CONTINUE
      GO TO 16
C
C     SUM(VJ-VK)
C     ADD THE VARIATES TOGETHER AND PUT THE TOTAL ON THE VARIATES STACK
C
30    IF (JEND.GT.LENDRA) GO TO 97
      IF (JEND.GT.LMAXRA) LMAXRA = JEND
      J = -MCODE(JMCP+1)
      K = -MCODE(JMCP+2)
      JMCP = JMCP+2
      JDATAP = LDATA+J
      JNOT = NVSTOR-K+J-1
      DO 36 JU = 1,NUNITS
      JVSTKP = JVSTKP+1
      B = 0.0
      DO 35 JV = J,K
      B = B+RA(JDATAP)
      JDATAP = JDATAP+1
35    CONTINUE
      JDATAP = JDATAP+JNOT
      RA(JVSTKP) = B
36    CONTINUE
      GO TO 16
C
C     OPERATOR (PARENTHESIS, FUNCTION, BINARY OP. OR END)
C     COMPARE THE LEFT RANK OF THE INCOMING OPERATOR (NCH) WITH THE
C     RIGHT RANK OF THE OPERATOR ON THE TOP OF THE STACK (KOP)
C     IF LEFT .GT. RIGHT THEN STACK, OTHERWISE UNSTACK
C
40    JLR = LRANK(JCH+2)
41    KOP = JOPSTK(JOPP)
      IF (JLR.LE.KRANK(KOP+2)) GO TO 45
      JOPP = JOPP+1
      JOPSTK(JOPP) = JCH
      GO TO 16
45    JOPP = JOPP-1
      IF (KOP.EQ.-1) GO TO 90
C
C     PERFORM THE OPERATION
C
      IF (KOP.GT.10) GO TO 60
      IF (KOP.GT.4) GO TO 16
C
C     BINARY OPERATION ( + - * / )
C
      JVSTK2 = JVSTKP-NUNITS
      JVSTKP = JVSTK2-NUNITS
      DO 59 JU = 1,NUNITS
      JVSTKP = JVSTKP+1
      B = RA(JVSTKP)
      JVSTK2 = JVSTK2+1
      C = RA(JVSTK2)
      IF (B.EQ.RMV.OR.C.EQ.RMV) GO TO 57
      GO TO (51,52,53,54),KOP
C +
51    B = B+C
      GO TO 58
C -
52    B = B-C
      GO TO 58
C *
53    B = B*C
      GO TO 58
C DIVISION - CHECK DENOMINATOR IS NOT NEAR ZERO
54    CONTINUE
      IF (DABS(C).LT.1.0D-10) GO TO 55
C -S- IF (ABS(C).LT.1.0E-10) GO TO 55
      B = B/C
      GO TO 58
55    CALL XPTEXT ('Divisor zero, unit',18)
      CALL XIPRIN (JU,1)
      CALL XNLINE (0)
      JHALT = 1
57    B = RMV
58    CONTINUE
      RA(JVSTKP) = B
59    CONTINUE
      GO TO 41
C
C     FUNCTION (EXCEPT SUM)
C
60    K = KOP-10
      JVSTKP = JVSTKP-NUNITS
      DO 88 JU = 1,NUNITS
      JVSTKP = JVSTKP+1
      B = RA(JVSTKP)
      IF (B.EQ.RMV) GO TO 86
      GO TO (70,73,75,77,77,79),K
C EXP
70    IF (B.GT.-HIGHEX) GO TO 71
      B = 0.0
      GO TO 87
71    IF (B.GT.HIGHEX) GO TO 72
      B = DEXP(B)
C -S- B = EXP(B)
      GO TO 87
72    CALL XPTEXT ('EXP argument too large (',24)
      GO TO 85
C LOG
73    IF (B.LE.0.0) GO TO 74
      B = DLOG(B)
C -S- B = ALOG(B)
      GO TO 87
74    CALL XPTEXT ('LOG argument not positive (',27)
      GO TO 85
C SQRT
75    IF (B.LT.0.0) GO TO 76
      B = DSQRT(B)
C -S- B = SQRT(B)
      GO TO 87
76    CALL XPTEXT ('SQRT argument negative (',24)
      GO TO 85
C ANG, DEG
77    IF (B.GT.1.0.OR.B.LT.0.0) GO TO 78
      B = DATAN2 (DSQRT(B),DSQRT(1.0-B))
C -S- B = ATAN2 (SQRT(B),SQRT(1.0-B))
      IF (KOP.EQ.15) B = B*57.29578
      GO TO 87
78    CALL XPTEXT ('ANG/DEG argument out of range (',30)
      GO TO 85
C PCT
79    B = B*100.0
      GO TO 87
C
C     FAULT - MARK THE VARIATE AS 'HALTED'
C
85    CALL XDPRFX (B,1,4)
      CALL XPTEXT ('), unit',7)
      CALL XIPRIN (JU,1)
      CALL XNLINE (0)
      JHALT = 1
86    B = RMV
C
87    CONTINUE
      RA(JVSTKP) = B
88    CONTINUE
      GO TO 16
C
C     END - COPY THE RESULT  BACK TO THE DATA ARRAY
C     AND MARK THE VARIATE AS ASSIGNED
C
90    CONTINUE
      JDATAP = LDATA+JDESTV
      JVSTKP = LEV2RA+NCON
      DO 92 JU = 1,NUNITS
      JVSTKP = JVSTKP+1
      RA(JDATAP) = RA(JVSTKP)
      JDATAP = JDATAP+NVSTOR
92    CONTINUE
      JCP = LCHECK+JDESTV
      IA(JCP) = 1
      JHP = LHALT+JDESTV
      IA(JHP) = JHALT
      RETURN
C
C     STORE FULL
C
97    MISTAK = 13
      RETURN
      END
      SUBROUTINE LISDIR
C
C     READS THE LIST DIRECTIVE
C
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      IF (NDFLAG(1)+NDFLAG(2)+NDFLAG(3).NE.0) GO TO 95
      CALL LISVAR
      IF (MISTAK.NE.0) GO TO 99
      CALL LISEFF
      IF (MISTAK.NE.0) GO TO 99
      IF (NTERMS.GE.3) CALL SAVTIM
      RETURN
C
C FAULT - NOT ALL FACTORS DECLARED
95    MISTAK = 5
99    NTERMS = 0
      RETURN
      END
      SUBROUTINE LISVAR
C
C     READS THE LIST OF VARIATES IN THE LIST DIRECTIVE
C
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      NVARIA = 0
17    CALL XCFIND (J,0)
      CALL XCSKIP
      IF (J.NE.LETERV) GO TO 92
      CALL XIREAD(K,IND)
      IF (IND.GT.0) GO TO 92
      IF (K.LT.1.OR.K.GT.NVSTOR) GO TO 90
      JCHECP = LCHECK+K
      IF (IA(JCHECP).EQ.0) GO TO 82
      JHALTP = LHALT+K
      IF (IA(JHALTP).EQ.0) GO TO 20
      CALL XPTEXT ('Variate V',9)
      CALL XIPRIN (K,0)
      CALL XPTEXT
     .(' cannot be analysed because of derived-variate faults',53)
      CALL XNLINE (1)
      GO TO 25
20    IF (NVARIA.EQ.0) GO TO 23
      DO 21 N = 1,NVARIA
      JINDXP = LINDEX+N
      IF (IA(JINDXP).EQ.K) GO TO 91
21    CONTINUE
23    NVARIA = NVARIA+1
      JINDXP = LINDEX+NVARIA
      IA(JINDXP) = K
25    CALL XCFIND (J,0)
      CALL XCSKIP
      IF (J.EQ.KOMMA) GO TO 17
      IF (J.NE.NTER) GO TO 92
      RETURN
C
C     VARIATE NOT ASSIGNED
82    MISTAK = 12
      GO TO 99
C     VARIATE NUMBER OUT OF RANGE
90    MISTAK = 10
      GO TO 99
C     VARIATE DECLARED TWICE
91    MISTAK = 9
      GO TO 99
C     SYNTAX ERROR
92    MISTAK = 2
C
99    RETURN
      END
      SUBROUTINE LISEFF
C
C     READS THE LIST OF EFFECTS IN THE LIST DIRECTIVE
C
      INTEGER IERROR(2,9)
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      DATA MAXEMS/9/
C
      DO 15 J=1,NNAMES
      JROINP = LROINT+J
      IA(JROINP) = -1
15    CONTINUE
C
C     BLOCKS ARE ALWAYS INCLUDED
C
      JLISTP = LLIST+1
      IF (NBLOCK.EQ.0) GO TO 37
      IF (LLIST+NBLOCK*(NNAMES+1).GT.LENDIA) GO TO 97
      DO 34 J = 1,NBLOCK
      JT = J+NTREAT
      JROINP = LROINT+JT
      IA(JROINP) = 1
      IA(JLISTP) = 1
      IA(JLISTP+1) = JT
      JLISTP = JLISTP+NNAMES+1
34    CONTINUE
37    NTERMS = NBLOCK
C
C     READ THE LIST OF EFFECTS
C
      NCOVAR = 0
      NEMSQS = 0
      JQ = 0
39    CALL XCFIND (J,0)
      IF (J.NE.LBRACK) GO TO 42
C START OF ERROR TERM
      IF (JQ.NE.0) GO TO 92
      JQ = 1
      NEMSQS = NEMSQS+1
      CALL XPTEXT ('Error(',6)
      CALL XIPRIN (NEMSQS,0)
      CALL XPTEXT (') = ',4)
      IF (NEMSQS.GT.MAXEMS) GO TO 84
      CALL XCSKIP
      CALL XCFIND (J,0)
      IERROR(1,NEMSQS) = NTERMS+1
42    NTERMS=NTERMS+1
      IF (JLISTP+NNAMES+1.GT.LENDIA) GO TO 97
      IF (J.NE.LETERV) GO TO 50
C COVARIATE - NOT ALLOWED IN ERROR TERM. CHECK THAT IT IS ASSIGNED
      IF (JQ.EQ.1) GO TO 88
      CALL XCSKIP
      CALL XIREAD (JR,IND)
      IF (IND.NE.0) GO TO 92
      IF (JR.LT.1.OR.JR.GT.NVSTOR) GO TO 90
      LCHECP = LCHECK+JR
      IF (IA(LCHECP).EQ.0) GO TO 82
      JHALTP = LHALT+JR
      IF (IA(JHALTP).EQ.0) GO TO 45
      CALL XPTEXT ('Covariate V',11)
      CALL XIPRIN (JR,0)
      CALL XPTEXT
     .(' cannot be included because of derived-variate faults',53)
      CALL XNLINE (1)
      NTERMS = NTERMS-1
      JLISTP = JLISTP-(NNAMES+1)
      GO TO 46
45    NCOVAR = NCOVAR+1
      IA(JLISTP) = -JR
46    CONTINUE
      GO TO 61
C FACTOR EFFECT
50    CALL LISTRD (JLISTP,NNAMES+0,NFACTO+0)
      IF (MISTAK.GT.0) GO TO 99
      IF (JQ.EQ.1) CALL FACPRI (JLISTP)
      JLTZ = IA(JLISTP)
      IF (JLTZ.NE.1) GO TO 56
      J = IA(JLISTP+1)
      IF (J.LE.NFACTO) GO TO 54
      JS = LSPFPT+J
      J = IA(JS)
54    JROINP = LROINT+J
      IF (IA(JROINP).EQ.-1) IA(JROINP) = NEMSQS+1
56    CONTINUE
C
61    CALL XCFIND (NS,0)
      IF (NS.NE.KBRACK) GO TO 63
C END OF ERROR TERM
      IF (JQ.NE.1) GO TO 92
      JQ = 0
      IERROR(2,NEMSQS) = NTERMS
      CALL XNLINE (1)
      CALL XCSKIP
      CALL XCFIND (NS,0)
C NEXT ITEM OR END OF LIST
63    CALL XCSKIP
      IF (JQ.EQ.1) CALL XPTEXT (', ',2)
      JLISTP = JLISTP+NNAMES+1
      IF (NS.EQ.KOMMA) GO TO 39
      IF (NS.NE.NTER) GO TO 92
      IF (JQ.NE.0) GO TO 92
C
C     SET UP SPACE FOR OTHER ARRAYS
C
      LAID = JLISTP-1
      LSTART = LAID+NTERMS*2
      LERROR = LSTART+NTERMS+1
      LEV2IA = LERROR+NEMSQS*2
      IF (LEV2IA.GT.LENDIA) GO TO 97
      IF (LEV2IA.GT.LMAXIA) LMAXIA = LEV2IA
C
      IF (NEMSQS.EQ.0) GO TO 66
      DO 65 JT = 1,NEMSQS
      J = LERROR+JT*2
      IA(J-1) = IERROR(1,JT)
      IA(J)   = IERROR(2,JT)
65    CONTINUE
66    NEMSQS = NEMSQS+1
C
C     FIND THE NUMBER OF DEGREES OF FREEDOM IN THE LIST OF EFFECTS
C     AND THE LENGTH OF THE LONGEST NAME COMBINATION
C
      NSPACE = 5
      IF (NEMSQS.GT.1) NSPACE = 8
      JLISTP = LLIST+1
      JSTARP = LSTART+1
      IA(JSTARP) = 1
      NDFS = 0
C
      DO 76 JT = 1,NTERMS
      J = LAID+JT*2
      IA(J-1) = 0
      IA(J)   = 0
      JW = IA(JLISTP)
      M = 2*JW-1
C COVARIATE HAS 1 D.F.
      JDFS = 1
      IF (JW.LE.0) GO TO 74
C OTHER TERM HAS D.F. = PRODUCT OF D.F. FOR EACH EFFECT
      DO 71 N = 1,JW
      JL = JLISTP+N
      IF (IA(JL).LE.NFACTO) GO TO 70
C SPECIAL EFFECT HAS 1 D.F. AND AN EXTRA LETTER
      M = M+1
      GO TO 71
C FACTOR.  D.F. = FACTOR LEVELS-1
70    JLP = LLEVEL+IA(JL)
      JDFS = JDFS*(IA(JLP)-1)
71    CONTINUE
74    CONTINUE
      NDFS = NDFS+JDFS
      JSTARP = JSTARP+1
      IA(JSTARP) = NDFS+1
      IF (M.GT.NSPACE) NSPACE = M
      JLISTP = JLISTP+NNAMES+1
76    CONTINUE
C
C     ASSIGN REMAINING TREATMENTS TO THE LAST ERROR TERM
C
      DO 79 J = 1,NTREAT
      JROINP = LROINT+J
      IF (IA(JROINP).EQ.-1) IA(JROINP) = NEMSQS
79    CONTINUE
C
      RETURN
C
C     FAULTS
C
C     VARIATE NOT ASSIGNED
82    MISTAK = 12
      GO TO 99
C     TOO MANY ERROR TERMS
84    MISTAK = 13
      GO TO 99
C     COVARIATE IN ERROR TERM
88    MISTAK = 8
      GO TO 99
C     VARIATE OUT OF RANGE
90    MISTAK = 10
      GO TO 99
C     SYNTAX ERROR
92    MISTAK = 2
      GO TO 99
C     STORE FULL
97    MISTAK = 27
C
99    NTERMS = 0
      RETURN
      END
      SUBROUTINE SAVTIM
C
C     FOR EACH TERM OF THE FORM A.B THIS FINDS OUT IF A AND B HAVE BEEN
C     PERVIOUSLY FITTED SEPARATELY; IF SO, IT SETS MARKERS IN AID TO
C     RECOGNIZE THE FACT AND HELP TO SAVE TIME IN CALCULATIONS LATER ON
C
      DIMENSION IX(25)
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      INCR = NNAMES+1
      JT = NTERMS
      ILISTP = LLIST + (JT-1)*INCR+1
23       N = IA(ILISTP)
         IF (N.LE.0) GO TO 82
         J = JT-1
         JLISTP = ILISTP-INCR
26          JP = IA(JLISTP)
            IF (JP.LT.1.OR.JP.GE.N) GO TO 73
            M = 0
            DO 41 K = 1,N
               K1 = ILISTP+K
               DO 37 L = 1,JP
               L1 = JLISTP+L
               IF (IA(L1).EQ.IA(K1)) GO TO 41
37             CONTINUE
               M = M+1
               IX(M) = IA(K1)
41          CONTINUE
            IF (M.EQ.0) GO TO 70
               K = J-1
               KLISTP = JLISTP-INCR
45             IF (IA(KLISTP).NE.M) GO TO 61
               DO 55 L = 1,M
                  L2 = KLISTP+L
                  IF (IX(L).NE.IA(L2)) GO TO 64
55             CONTINUE
               JAP = LAID+JT*2
               IA(JAP-1) = K
               IA(JAP)   = J
61             CONTINUE
64             K = K-1
               KLISTP = KLISTP-INCR
               IF (K.GT.0) GO TO 45
70          CONTINUE
73          CONTINUE
            J = J-1
            JLISTP = JLISTP-INCR
         IF (J.GE.2) GO TO 26
82       CONTINUE
         JT = JT-1
         ILISTP = ILISTP-INCR
      IF (JT.GE.3) GO TO 23
      RETURN
      END
      SUBROUTINE ANADIR
C
C     PERFORMS THE ANALYSE DIRECTIVE
C
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
C     CHECK THAT LIST HAS BEEN DONE
C     AND THAT THERE IS SOMETHING TO ANALYSE
C
      IF (NTERMS.EQ.0.OR.NVARIA.LT.1) GO TO 98
C
      CALL ANASET
      IF (MISTAK.GT.0) GO TO 99
      CALL ANAONE
      IF (MISTAK.GT.0) GO TO 99
      CALL ANATWO
      NSSSET = 0
      LTABLE = LEV3IA
      RETURN
C
C     FAULTS
C
C     NO VARIATES OR TERMS
98    MISTAK = 28
99    RETURN
      END
      SUBROUTINE ANASET
C
C     INITIALIZES ARRAYS FOR THE ANALYSE DIRECTIVE
C
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
C REAL ARRAYS
C
      AD = FLOAT(NDFS)
      AV = FLOAT(NVARIA)
      AR = FLOAT(LEV2RA) + AD*(AD+1.0)/2.0 + 4.0*AD +
     .     AV*FLOAT(NTERMS+4+NEMSQS+NDFS)
      IF (AR.GT.FLOAT(LENDRA)) GO TO 97
      LSS = LEV2RA
      LPART = LSS+NDFS*(NDFS+1)/2
      LTPART = LPART+NVARIA*NDFS
      LANOVA = LTPART+NDFS
      LVAR = LANOVA+NVARIA*(NTERMS+2)
      LMEAN = LVAR+NEMSQS*NVARIA
      LRMEAN = LMEAN+NDFS+NVARIA
      LXX = LRMEAN+NDFS
      LMVR = LXX+NDFS+NVARIA
      LEV3RA = LMVR
      IF (LEV3RA.GT.LMAXRA) LMAXRA = LEV3RA
C
C INTEGER ARRAYS
      LXXIND = LEV2IA
      LDF = LXXIND+NTERMS
      LMVIND = LDF+NTERMS+2
      LEV3IA = LMVIND+1
      IF (LEV3IA.GT.LENDIA) GO TO 97
      IF (LEV3IA.GT.LMAXIA) LMAXIA = LEV3IA
C
C     SET ALL CUMULATIVE ARRAYS TO ZERO
C
      JXXP = LXXIND
      JDFP = LDF
      DO 15 J = 1,NTERMS
      JXXP = JXXP+1
      IA(JXXP) = 1
      JDFP = JDFP+1
      IA(JDFP) = 0
15    CONTINUE
C
      JC = LEV2RA+1
      JD = LEV3RA
      DO 20 J = JC,JD
      RA(J) = 0.0
20    CONTINUE
      RETURN
C
C     STORE FULL
C
97    MISTAK = 27
      RETURN
      END
      SUBROUTINE CONSTR (JY,JU,MIS,JT)
C
      DOUBLE PRECISION B,A
C -S- REAL B,A
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      JT = 0
      DO 59 JS = 1,NTERMS
      JXXINP = LXXIND+JS
      IF (IA(JXXINP).EQ.0.AND.JY.EQ.0) GO TO 59
      JSTARP = LSTART+JS
      IE = IA(JSTARP)
      JAP = LAID+JS*2
      JV = IA(JAP-1)
      IF (JV.EQ.0) GO TO 20
         JW = IA(JAP)
         JSTARP = LSTART+JW
         M1 = IA(JSTARP)
         M2 = IA(JSTARP+1) -1
         JSTARP = LSTART+JV
         L1 = IA(JSTARP)
         L2 = IA(JSTARP+1) -1
         DO 18 L = L1,L2
         JXXP = LXX+L
         B = RA(JXXP)
         DO 17 M = M1,M2
         JE = LXX+IE
         JM = LXX+M
         RA(JE) = B*RA(JM)
         IE = IE+1
17       CONTINUE
18       CONTINUE
         GO TO 59
C
20    JLISTP = LLIST+(JS-1)*(NNAMES+1) + 1
      IF (IA(JLISTP).GT.0) GO TO 29
         IF (MIS.NE.0) GO TO 25
         JDATAP = LDATA + (JU-1)*NVSTOR - IA(JLISTP)
         A = RA(JDATAP)
         IF (A.EQ.RMV) JT = 1
         GO TO 26
25       JMEANP = LMEAN+IE
         A = RA(JMEANP)
26       JXXP = LXX+IE
         RA(JXXP)=A
         GO TO 59
29    CONTINUE
C
      JP = 1
      JLTZ = IA(JLISTP)
      DO 58 JQ = 1,JLTZ
         M = JLISTP+JQ
         M = IA(M)
         IF (M.GT.NFACTO) GO TO 50
            JCODEP = (JU-1)*NFACTO + M + LCODE
            IF = IA(JCODEP)
            JLEVEP = LLEVEL+M
            ID = IA(JLEVEP)-1
            K = IE+JP*ID
            L = IE+JP-1
34          IF (JQ.NE.1) GO TO 36
            B = 1.0
            GO TO 37
36          JXXP = LXX+L
            B = RA(JXXP)
37          CONTINUE
            N = ID
39             IF (N-IF) 40,41,42
40             A = 0.0
               GO TO 43
41             A = N
               GO TO 43
42             A = -1.0
43             CONTINUE
               K = K-1
               JXXP = LXX+K
               RA(JXXP) = B*A
               N = N-1
               IF (N.GE.1) GO TO 39
            L = L-1
            IF (L.GE.IE) GO TO 34
            JP = JP*ID
            GO TO 58
C
50       M = M-NFACTO
         N = LSPFPT+M
         JCODEP = LCODE+IA(N)+(JU-1)*NFACTO
         N = LSECOF+M
         JSPEFP = IA(N)+IA(JCODEP)+1
         B = RA(JSPEFP)
         IF (JQ.NE.1) GO TO 53
         JXXP = LXX+IE
         RA(JXXP) = B
         GO TO 56
53       IF = IE+JP-1
         DO 55 K=IE,IF
         JXXP = LXX+K
         RA(JXXP) = RA(JXXP)*B
55       CONTINUE
56       CONTINUE
58       CONTINUE
59    CONTINUE
      RETURN
      END
      SUBROUTINE ANAONE
C
C    FIRST PART 0F ANALYSE DIRECTIVE
C
      DOUBLE PRECISION A,B,C,D
C -S- REAL A,B,C,D
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      JV = 0
      NMVUNI = 0
      DO 85 JU = 1,NUNITS
      CALL CONSTR (1,JU,0,JT)
      IF (JT.EQ.1) GO TO 70
C CHECK FOR MISSING VALUES
      DO 30 J = 1,NVARIA
      JP = LINDEX+J
      JP = LDATA+(JU-1)*NVSTOR+IA(JP)
      A = RA(JP)
      IF (A.EQ.RMV) GO TO 70
      JXXP = LXX+NDFS+J
      RA(JXXP) = A
30    CONTINUE
C
C NO MISSING VALUES
      JV = JV+1
      D = 1.0/JV
      A = 1.0-D
      J = LSS
C
      DO 41 N = 1,NDFS
         JXXP = LXX+N
         JMEANP = LMEAN+N
         JTPARP = LTPART+N
         C = RA(JXXP)-RA(JMEANP)
         RA(JMEANP) = RA(JMEANP)+D*C
         RA(JTPARP) = C
         C = C*A
         DO 40 JP = 1,N
         J = J+1
         KTPARP = LTPART+JP
         RA(J) = RA(J)+C*RA(KTPARP)
40       CONTINUE
41    CONTINUE
C
      JXXP = LXX+NDFS
      JMEANP = LMEAN+NDFS
      JANOVP = LANOVA+(NTERMS+1)*NVARIA
      JPARTP = LPART
      DO 50 JP = 1,NVARIA
         JXXP = JXXP+1
         JMEANP = JMEANP+1
         JANOVP = JANOVP+1
         B = RA(JXXP)-RA(JMEANP)
         RA(JMEANP) = RA(JMEANP)+D*B
         C = B*A
         RA(JANOVP) = RA(JANOVP)+C*B
         JTPARP = LTPART
         DO 47 N = 1,NDFS
            JPARTP = JPARTP+1
            JTPARP = JTPARP+1
            RA(JPARTP) = RA(JPARTP)+C*RA(JTPARP)
47       CONTINUE
50    CONTINUE
      GO TO 85
C
C MISSING VALUE FOUND
70    NMVUNI = NMVUNI+1
      IF (LMVIND+NMVUNI.GE.LENDIA.OR.LMVR+NMVUNI.GE.LENDRA) GO TO 97
      DO 76 JS = 1,NDFS
      JRMEAP = LRMEAN+JS
      JXXP = LXX+JS
      RA(JRMEAP) = RA(JRMEAP)+RA(JXXP)
76    CONTINUE
      JMVINP = LMVIND+NMVUNI
      IA(JMVINP) = JU
85    CONTINUE
C
      B = 1.0 - FLOAT(NMVUNI)/NUNITS
      JLISTP = LLIST+1
      JSTARP = LSTART
      DO 92 JT = 1,NTERMS
         JSTARP = JSTARP+1
         JS1= IA(JSTARP)
         JMEANP = LMEAN+JS1
         JRMEAP = LRMEAN+JS1
         IF (IA(JLISTP).GE.0) GO TO 87
         RA(JRMEAP) = RA(JMEANP)
         GO TO 91
87       JS2 = IA(JSTARP+1)-1
         DO 89 JS = JS1,JS2
            RA(JRMEAP) = B*RA(JMEANP) + RA(JRMEAP)/NUNITS
            JRMEAP = JRMEAP+1
            JMEANP = JMEANP+1
89       CONTINUE
91       JLISTP = JLISTP+NNAMES+1
92    CONTINUE
C
      JMVINP = LMVIND+NMVUNI+1
      IA(JMVINP) = -1
      LEV3IA = JMVINP
      IF (LEV3IA.GT.LMAXIA) LMAXIA = LEV3IA
      LEV3RA = LMVR+NMVUNI
      IF (LEV3RA.GT.LMAXRA) LMAXRA = LEV3RA
      RETURN
C
C FAULT - STORE FULL
97    MISTAK = 27
      RETURN
      END
      SUBROUTINE ANATWO
C
C     ANALYSE DIRECTIVE (INTERACTIONS BETWEEN UNITS)
C
      DOUBLE PRECISION A,B,C,D,P,DEL
C -S- REAL A,B,C,D,P,DEL
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      DATA DEL/1.0D-6/
C -S- DATA DEL/1.0E-5/
C
      IF (RA(LSS+1).LT.DEL) GO TO 10
      RA(LTPART+1) = 1.0/RA(LSS+1)
      GO TO 11
10    RA(LTPART+1) = 0.0
11    CONTINUE
      IF (NDFS.EQ.1) GO TO 22
      J = 1
      DO 21 JS = 2,NDFS
         K = J
         N = J
         J = J+JS
         JSSJ = LSS+J
         A = RA(JSSJ)
         DO 18 JT = JS,NDFS
            B = 0.0
            JS1 = JS-1
            JSSN = LSS+N
            JSSK = LSS+K
            JTPARP = LTPART
            DO 15 JR = 1,JS1
               JSSN = JSSN+1
               JSSK = JSSK+1
               JTPARP = JTPARP+1
               C = RA(JSSN)
               D = RA(JSSK)
               P = RA(JTPARP)
               IF (DABS(C).GT.1D-10.AND.DABS(D).GT.1D-10) B = B + C*D*P
C -S-          IF ( ABS(C).GT.1E-10.AND. ABS(D).GT.1E-10) B = B + C*D*P
15          CONTINUE
            L = K+JS
            JSSL = LSS+L
            RA(JSSL) = RA(JSSL)-B
            K = K+JT
18       CONTINUE
         JTPARP = LTPART+JS
         IF (RA(JSSJ).GT.DEL*A) GO TO 19
         RA(JSSJ) = 0.0
         RA(JTPARP) = 0.0
         GO TO 20
19       RA(JTPARP) = 1.0/RA(JSSJ)
20       CONTINUE
21    CONTINUE
22    CONTINUE
C
      JW = NTERMS+1
      JANOVW = LANOVA+NVARIA*NTERMS
      JANOVZ = JANOVW+NVARIA
      DO 27 JV = 1,NVARIA
      JANOVW = JANOVW+1
      JANOVZ = JANOVZ+1
      RA(JANOVW) = RA(JANOVZ)
27    CONTINUE
C
      JQ = NUNITS-NMVUNI-1
      JDFP = LDF+NTERMS+2
      IA(JDFP) = JQ
      K =0
      DO 59 JR = 1,NTERMS
         JSTARP = JR+LSTART
         JS1 = IA(JSTARP)
         JS2 = IA(JSTARP+1)-1
         JDFP = LDF+JR
         DO 58 JT = JS1,JS2
            JTPARP = JT+LTPART
            IF (RA(JTPARP).EQ.0.0) GO TO 55
            IF (JT.EQ.1) GO TO 44
            JT1 = JT-1
            DO 43 JS = 1,JT1
               JTPARS = LTPART+JS
               IF (RA(JTPARS).EQ.0.0) GO TO 42
               JSSP = LSS+K+JS
               A = RA(JSSP)
               JPARTT = LPART+JT
               JPARTS = LPART+JS
               DO 41 J = 1,NVARIA
               RA(JPARTT) = RA(JPARTT) - RA(JPARTS)*A
               JPARTT = JPARTT+NDFS
               JPARTS = JPARTS+NDFS
41             CONTINUE
42             CONTINUE
43          CONTINUE
44          CONTINUE
            A = RA(JTPARP)
            JANOVR = LANOVA+(JR-1)*NVARIA
            JANOVW = LANOVA+NTERMS*NVARIA
            JPARTT = LPART+JT
            DO 52 J = 1,NVARIA
               B = RA(JPARTT)
               C = A*B*B
               JANOVR = JANOVR+1
               JANOVW = JANOVW+1
               RA(JANOVR) = RA(JANOVR)+C
               RA(JANOVW) = RA(JANOVW)-C
               RA(JPARTT) = B*A
               JPARTT = JPARTT+NDFS
52          CONTINUE
            IA(JDFP) = IA(JDFP)+1
            JQ = JQ-1
55          CONTINUE
            K = K+JT
            JSSP = LSS+K
            RA(JSSP) = 1.0
58       CONTINUE
59    CONTINUE
      JDFP = LDF+NTERMS+1
      IA(JDFP) = JQ
C
      IF (NEMSQS.EQ.1) GO TO 81
      NE = NEMSQS-1
      DO 80 M = 1,NE
         JERROP = LERROR+M+M
         K = IA(JERROP-1)
         L = IA(JERROP)
         N = 0
         DO 68 JT = K,L
         JDFP = LDF+JT
         N = N+IA(JDFP)
68       CONTINUE
         JDFP = LDF+L
         IA(JDFP) = N
         JANOVL = LANOVA+(L-1)*NVARIA
         JVARP = LVAR+(M-1)*NVARIA
         DO 79 JV = 1,NVARIA
            A = 0
            JANOVT = LANOVA+JV+(K-1)*NVARIA
            DO 74 JT = K,L
            A = A+RA(JANOVT)
            JANOVT = JANOVT+NVARIA
74          CONTINUE
            JANOVL = JANOVL+1
            RA(JANOVL) = A
            JVARP = JVARP+1
            IF (N.LE.0) GO TO 77
            RA(JVARP) = A/N
            GO TO 78
77          RA(JVARP) = RMV
78          CONTINUE
79       CONTINUE
80    CONTINUE
81    CONTINUE
C
      JANOVW = LANOVA+NTERMS*NVARIA
      JVARP = LVAR+(NEMSQS-1)*NVARIA
      DO 85 JV = 1,NVARIA
         JANOVW = JANOVW+1
         JVARP = JVARP+1
         IF (RA(JANOVW).LT.0.0) RA (JANOVW) = 0.0
         IF (JQ.LE.0) GO TO 83
         RA(JVARP) = RA(JANOVW)/JQ
         GO TO 84
83       RA(JVARP) = RMV
84       CONTINUE
85    CONTINUE
      RETURN
      END
      SUBROUTINE TABDIR
C
C     READS THE TABLE DIRECTIVE
C
      DIMENSION NOM(2)
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      NOM(2) = KSPACE
      NTABLE = 0
      JTABLP = LTABLE+1
11    JQ = 0
      IF (JTABLP+NFACTO.GT.LENDIA) GO TO 87
C
C     READ THE LIST OF TREATMENTS. CHECK THAT NO TREATMENT OCCURS TWICE
C
13    CALL XCFIND (JS,0)
      CALL XCSKIP
      IF (JS.LT.LETERA.OR.JS.GT.LETERZ) GO TO 92
      NOM(1) = JS
      CALL FINDNA (NOM,LNAME+1,NTREAT,JT)
      IF (JT.LT.1) GO TO 97
      L = LFCHEK+JT
      IF (IA(L).EQ.0) GO TO 82
      JTABLR = JTABLP
      IF (JQ.EQ.0) GO TO 30
      DO 20 J = 1,JQ
      JTABLR = JTABLR+1
      IF (IA(JTABLR).EQ.JT) GO TO 98
20    CONTINUE
30    JTABLR = JTABLR+1
      JQ = JQ+1
      IA(JTABLR) = JT
      CALL XCFIND (JS,0)
      CALL XCSKIP
      IF (JS.EQ.KDOT) GO TO 13
      IA(JTABLP) = JQ
      JTABLP = JTABLP+NTREAT+1
      NTABLE = NTABLE+1
      IF (JS.EQ.KOMMA) GO TO 11
      IF (JS.NE.NTER) GO TO 92
C
      LADJIT = JTABLP-1
      LAJITC = LADJIT+NTABLE*NTERMS
      LEV3IA= LAJITC+NTABLE
      IF (LEV3IA.GT.LENDIA) GO TO 87
      IF (LEV3IA.GT.LMAXIA) LMAXIA = LEV3IA
      RETURN
C
C     FAULTS
C
C     UNASSIGNED FACTOR
82    MISTAK = 12
      GO TO 99
C     NOT ENOUGH STORE
87    MISTAK = 27
      GO TO 99
C     SYNTAX ERROR
92    MISTAK = 2
      GO TO 99
C     ILLEGAL NAME IN TABLE
97    MISTAK = 7
      GO TO 99
98    MISTAK = 8
C
99    RETURN
      END
      SUBROUTINE ADJDIR
C
C     READS THE ADJUST DIRECTIVE
C
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      LXXADJ = LEV3IA
      IF (LXXADJ+NFACTO.GT.LENDIA) GO TO 97
C
      CALL XNLINE (2)
      CALL  XPTEXT ('Tables adjusted for ',20)
      NADJUS = 0
C
C     READ AN ADJUSTMENT EFFECT
C
15    CALL LISTRD (LXXADJ+1,NNAMES+0,NFACTO+0)
      IF (MISTAK.NE.0) GO TO 99
      CALL FACPRI (LXXADJ+1)
      CALL XCFIND (JS,0)
      IF (JS.EQ.NTER) GO TO 17
      IF (JS.NE.KOMMA) GO TO 92
      CALL XPTEXT (', ',2)
17    CALL XCSKIP
C
C     CHECK THAT THE EFFECT IS IN 'LIST'
C
      JLISTP = LLIST+1
      DO 28 JT = 1,NTERMS
      JLISTR = JLISTP
      JXXADP = LXXADJ+1
      N = IA(JLISTP)
      IF (IA(JXXADP).NE.N) GO TO 26
      DO 23 K = 1,N
      JXXADP = JXXADP+1
      JLISTR = JLISTR+1
      IF (IA(JXXADP).NE.IA(JLISTR)) GO TO 26
23    CONTINUE
      GO TO 33
26    CONTINUE
      JLISTP = JLISTP+NNAMES+1
28    CONTINUE
      GO TO 94
C MATCH FOUND
33    JXXINP = LXXIND+JT
      IA(JXXINP) = 1
      NADJUS = NADJUS+1
      IF (JS.NE.NTER) GO TO 15
      CALL XNLINE (2)
C
C     MARK THOSE ADJUSTMENTS FOR EFFECTS MENTIONED IN 'SAVETIME'
C
      JT = NTERMS
38    JXXINP = LXXIND+JT
      JAIDP = LAID+JT*2
      IF (IA(JXXINP).LE.0.OR.IA(JAIDP).EQ.0) GO TO 40
      JR = IA(JAIDP-1) + LXXIND
      IF (IA(JR).EQ.0) IA(JR) = 10
      JR = IA(JAIDP) + LXXIND
      IF (IA(JR).EQ.0) IA(JR) = 10
40    CONTINUE
      JT = JT-1
      IF (JT.GE.NBLOCK+1) GO TO 38
      RETURN
C
C     FAULTS
C
C     SYNTAX ERROR
92    MISTAK = 2
      GO TO 99
C EFFECT NOT IN 'LIST'
94    MISTAK = 4
      GO TO 99
C STORE FULL
97    MISTAK = 27
99    RETURN
      END
      SUBROUTINE CANADJ
C
C     CANCELS THE ADJUSTMENT DIRECTIVE
C
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      JLISTP = LLIST + NBLOCK*(NNAMES+1) +1
      JXXINP = LXXIND+NBLOCK+1
      JB = NBLOCK+1
      DO 12 JT = JB,NTERMS
      IF (IA(JLISTP).GE.0) GO TO 10
      IA(JXXINP) = -1
      GO TO 11
10    IA(JXXINP) = 0
11    CONTINUE
      JXXINP = JXXINP+1
      JLISTP = JLISTP+NNAMES+1
12    CONTINUE
      IF (NADJUS.EQ.0) GO TO 18
      CALL XPTEXT ('Adjust directive cancelled',26)
      CALL XNLINE (0)
      NADJUS = 0
18    NINSER = 0
      NRESID = 0
      NTABLE = 0
      RETURN
      END
      SUBROUTINE PRIDIR
C
C     PERFORMS THE PRINT DIRECTIVE
C
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      COMMON/LOCALS/ LRESUL,LROWTO,LCOLTO,LADJ,LEV4RA,
     .LCOUNT,LROWCN,LCOLCN,LDFPOI,LSSPOI,LEV4IA,
     .NADJKN,NROWS,NCOLS,NDATAP,NDIMEN,NDEC,NID,NIE,NG,NH,
     .NPRSED,NTABSI,NFPRIN,NCURTA,NDFAJT,NADJDF
C
      NADJKN = 0
      IF (NTABLE.GT.0) CALL DEFADJ
C
C     FIND THE NEXT VARIATE
C
10    CALL NEXVAR
      IF (MISTAK.NE.0) GO TO 70
      CALL DATAPR
      CALL ANOVA
      IF (NSSSET.NE.0) GO TO 17
      IF ((NBLOCK+NADJUS)*NTABLE+NMVUNI+NCOVAR+NRESID.EQ.0) GO TO 17
      CALL ADJPAR
      NSSSET = 1
17    IF (NCOVAR.NE.0) CALL REGRES
      IF (NMVUNI.NE.0) CALL ESTIMA
C
C     TABLES
C
      IF (NTABLE.EQ.0) GO TO 62
      DO 45 N = 1,NTABLE
      NCURTA = N
      CALL TFORM
      IF (MISTAK.GT.0) GO TO 33
      JP = LAJITC+N
      IF (IA(JP).NE.0) CALL ADJUST
      CALL TPRINT
      CALL TABSE
33    MISTAK = 0
45    CONTINUE
62    NADJKN = 1
      IF (NRESID.GT.0) CALL RESIDS
C
70    CALL XCFIND (JS,0)
      IF (JS.EQ.LETERV) GO TO 10
C
      MISTAK = 0
      RETURN
      END
      SUBROUTINE DEFADJ
C
C     ASSUMES THAT ALL TABLES ARE TO BE ADJUSTED FOR EVERYTHING
C     ADJUSTABLE, FINDING THE NUMBER OF D.F. CONCERNED (NDFAJT)
C
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      COMMON/LOCALS/ LRESUL,LROWTO,LCOLTO,LADJ,LEV4RA,
     .LCOUNT,LROWCN,LCOLCN,LDFPOI,LSSPOI,LEV4IA,
     .NADJKN,NROWS,NCOLS,NDATAP,NDIMEN,NDEC,NID,NIE,NG,NH,
     .NPRSED,NTABSI,NFPRIN,NCURTA,NDFAJT,NADJDF
C
      NQ = NBLOCK+NCOVAR+NADJUS
      JCP = LAJITC
      JAP = LADJIT
      DO 30 J = 1,NTABLE
      JCP = JCP+1
      IA(JCP) = NQ
      DO 25 JT = 1,NTERMS
      JAP = JAP+1
      JXP = JT+LXXIND
      IA(JAP) = IA(JXP)
25    CONTINUE
30    CONTINUE
C
      NDFAJT = 0
      DO 35 JT = 1,NTERMS
      JXP = LXXIND+JT
      IF (IABS(IA(JXP)).NE.1) GO TO 35
      JSTARP = LSTART+JT
      NDFAJT = NDFAJT + IA(JSTARP+1) - IA(JSTARP)
35    CONTINUE
      RETURN
      END
      SUBROUTINE NEXVAR
C
C     FINDS THE NEXT VARIATE TO BE ANALYSED IN 'PRINT'
C
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      COMMON/LOCALS/ LRESUL,LROWTO,LCOLTO,LADJ,LEV4RA,
     .LCOUNT,LROWCN,LCOLCN,LDFPOI,LSSPOI,LEV4IA,
     .NADJKN,NROWS,NCOLS,NDATAP,NDIMEN,NDEC,NID,NIE,NG,NH,
     .NPRSED,NTABSI,NFPRIN,NCURTA,NDFAJT,NADJDF
C
      MISTAK = 0
      NFPRIN = 0
      NPRSED = 0
      NDATAP = 0
      NRESID = NRESID - 2*(NRESID/2)
C
C     READ THE VARIATE NUMBER
C
      CALL XNLINE (3)
      CALL XCFIND (NS,0)
      IF (NS.NE.LETERV) GO TO 82
      CALL XCSKIP
      CALL XIREAD (NG,IND)
      IF (IND.NE.0) GO TO 82
C
C     OPTIONS
      CALL XCFIND (K,0)
      IF (K.NE.KSTAR) GO TO 22
15    CALL XCSKIP
      CALL XCFIND (K,1)
      IF (K.NE.LETERD) GO TO 18
      NDATAP = 1
      GO TO 15
18    IF (K.NE.LETERE) GO TO 19
      NPRSED = 1
      GO TO 15
19    IF (K.NE.LETERN) GO TO 20
      CALL XNPAGE
      GO TO 15
20    IF (K.NE.LETERR) GO TO 21
      IF (NRESID.LT.2) NRESID = NRESID+2
      GO TO 15
21    IF (K.NE.LETERF) GO TO 22
      NFPRIN = 1
      GO TO 15
22    CONTINUE
      CALL XPTEXT ('V',1)
      CALL XIPRIN (NG,0)
C
C     CHECK THAT IT HAS BEEN ANALYSED
C
      DO 25 N = 1,NVARIA
      JINDEP = LINDEX+N
      IF (IA(JINDEP).EQ.NG) GO TO 26
25    CONTINUE
      GO TO 27
26    J = LHALT+NG
      NH = N
      IF (IA(J).EQ.0) GO TO 30
27    MISTAK = -1
      CALL XPTEXT (' (not analysed)',15)
      CALL XNLINE (1)
C
C     READ DECIMAL PLACES - NID BEFORE, NIE AFTER THE POINT
C
30    CALL XIREAD (NID,IND)
      IF (IND.NE.0) GO TO 92
      IF (NID.GT.1) NID = NID-1
      CALL XIREAD (NIE,IND)
      IF (IND.NE.0) GO TO 92
      NDEC = NID+NIE
      IF (NIE.EQ.0) NDEC = NDEC-1
C
C     TITLE
C
35    CALL XCREAD (JT)
      IF (JT.EQ.NTER) GO TO 38
      CALL XCPRIN (JT)
      GO TO 35
38    CONTINUE
      CALL XNLINE (2)
      RETURN
C
C     FAULT
C
82    CALL XNLINE (0)
      CALL XPTEXT ('Variate specification missing in PRINT',38)
      GO TO 96
92    CALL XNLINE (0)
      CALL XPTEXT ('Invalid specification for variate V',35)
      CALL XIPRIN (NG,0)
96    CALL XNLINE (0)
      CALL XPTEXT ('Skipping to next variate',24)
      CALL XNLINE (0)
      MISTAK = 2
      GO TO 35
      END
      SUBROUTINE DATAPR
C
C     PRINTS MAX, MIN, MEAN AND DATA VALUES
C
      DOUBLE PRECISION A,B,C,D
C -S- REAL A,B,C,D
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      COMMON/LOCALS/ LRESUL,LROWTO,LCOLTO,LADJ,LEV4RA,
     .LCOUNT,LROWCN,LCOLCN,LDFPOI,LSSPOI,LEV4IA,
     .NADJKN,NROWS,NCOLS,NDATAP,NDIMEN,NDEC,NID,NIE,NG,NH,
     .NPRSED,NTABSI,NFPRIN,NCURTA,NDFAJT,NADJDF
C
      A = 1.0D20
C -S- A = 1.0E20
      B = -A
      JDATAP = LDATA+NG
      DO 48 K = 1,NUNITS
      C = RA(JDATAP)
      JDATAP = JDATAP+NVSTOR
      IF (C.EQ.RMV) GO TO 47
      IF (C.LT.A) A = C
      IF (C.GT.B) B = C
47    CONTINUE
48    CONTINUE
      JP = LMEAN+NDFS+NH
      D = RA(JP)
C
      CALL XPTEXT ('Mean',4)
      CALL XDPRFX (D,NID,NIE)
      CALL XNLINE (2)
      CALL XPTEXT (' Min',4)
      CALL XDPRFX (A,NID,NIE)
      CALL XNLINE (2)
      CALL XPTEXT (' Max',4)
      CALL XDPRFX (B,NID,NIE)
      CALL XNLINE (2)
C
      IF (D.EQ.A) GO TO 66
      C = (B-D)/(D-A)
      IF (C.LT.3.0.AND.C.GT.0.3333) GO TO 66
      CALL XPTEXT ('Skew distribution of variate values: ',37)
      CALL XPTEXT ('data may contain an outlier',27)
      CALL XNLINE (1)
      CALL XPTEXT ('Please check Max and Min',24)
      CALL XNLINE (2)
      CALL XPTEXT ('Data checked by ........',24)
      CALL XNLINE (2)
66    CONTINUE
C
C     PRINT THE DATA IF A PRINT IS REQUIRED
C
      IF (NDATAP.EQ.0) GO TO 77
      CALL XPTEXT ('Data values analysed',20)
      JW = NWIDTH
      JV = LMVIND+1
      JDATAP = LDATA+NG
      DO 76 JU = 1,NUNITS
      IF (JW.GE.NWIDTH) GO TO 71
      JW = JW+1
      GO TO 72
71    JW = 1
      CALL XNLINE (0)
72    CONTINUE
      IF (JU.EQ.IA(JV)) GO TO 74
      CALL XDPRFX (RA(JDATAP),NID,NIE)
      GO TO 75
74    CALL MVPRIN (NID,NIE)
      JV = JV+1
75    CONTINUE
      JDATAP = JDATAP+NVSTOR
76    CONTINUE
      CALL XNLINE (2)
77    RETURN
      END
      SUBROUTINE ANOVA
C
C     PRINT THE ANALYSIS-OF-VARIANCE TABLE
C
      DOUBLE PRECISION A,C,D,F,FPROB,TOTSS
C -S- REAL A,C,D,F,FPROB,TOTSS
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      COMMON/LOCALS/ LRESUL,LROWTO,LCOLTO,LADJ,LEV4RA,
     .LCOUNT,LROWCN,LCOLCN,LDFPOI,LSSPOI,LEV4IA,
     .NADJKN,NROWS,NCOLS,NDATAP,NDIMEN,NDEC,NID,NIE,NG,NH,
     .NPRSED,NTABSI,NFPRIN,NCURTA,NDFAJT,NADJDF
C
      CALL XPTEXT ('Analysis-of-Variance Table',26)
      CALL XNLINE (2)
      CALL XSPACE (NSPACE+3)
      CALL XPTEXT ('DF',2)
      CALL XSPACE (NID+NIE+8)
      CALL XPTEXT ('SS',2)
      CALL XSPACE (NID+NIE+4)
      CALL XPTEXT ('MS',2)
      IF (NSHRI.EQ.1.OR.NFPRIN.EQ.1) CALL XPTEXT ('        F  Prob',15)
      CALL XNLINE (1)
      K = 1
C
C     ENTRIES FOR EACH TERM
C
      JANOVP = LANOVA+NH
      JT1 = NTERMS+1
      JP = LANOVA + (NTERMS+1)*NVARIA + NH
      TOTSS = RA(JP)
      DO 79 JT = 1,JT1
         JSTARP = LSTART+JT
         A = RA(JANOVP)
         JDFP = LDF+JT
         L = IA(JDFP)
         IF (JT.GT.NTERMS) GO TO 20
         IF (K.GE.NEMSQS) GO TO 37
         JP = LERROR+K+K
         JQ = IA(JP-1)
         JR = IA(JP)
         IF (JT.EQ.JR) GO TO 22
         IF (JT.LT.JR.AND.JT.GE.JQ) GO TO 78
         GO TO 39
C    ERROR TERM
20       JDROP = 0
         GO TO 25
22       J = LSTART+JQ
         JDROP = IA(JSTARP+1) - IA(J) - L
25       IF (NEMSQS.GT.1) GO TO 29
         CALL XSPACE (NSPACE-5)
         CALL XPTEXT ('Error',5)
         GO TO 35
29       CALL XSPACE (NSPACE-8)
         CALL XPTEXT ('Error(',6)
         CALL XIPRIN (K,0)
         CALL XPTEXT (')',1)
         K = K+1
35       CONTINUE
         JE = 1
         GO TO 53
C    NOT AN ERROR TERM
37       JR = NTERMS+1
39       CONTINUE
         JE = 0
         JDROP = IA(JSTARP+1) - IA(JSTARP) - L
         JLISTP = LLIST+(JT-1)*(NNAMES+1)+1
         J = IA(JLISTP)
         IF (J.GE.0) GO TO 44
C    COVARIATE
         CALL XSPACE (NSPACE-3)
         IF (J.GT.-10) CALL XSPACE (1)
         CALL XPTEXT ('V',1)
         CALL XIPRIN (-J,0)
         GO TO 53
C    FACTOR COMBINATION
44       J = IA(JLISTP)
         M = 2*J-1
         DO 49 N = 1,J
         JP = JLISTP+N
         IF (IA(JP).GT.NFACTO) M = M+1
49       CONTINUE
         CALL XSPACE (NSPACE-M)
         CALL FACPRI (JLISTP)
53       CONTINUE
C
C    DF,SS,MS
         CALL XIPRIN (L,4)
         IF (JDROP.GT.0) GO TO 55
         CALL XSPACE (4)
         GO TO 57
55       CALL XPTEXT ('(',1)
         CALL XIPRIN (JDROP,0)
         CALL XPTEXT (')',1)
         IF (JDROP.LT.10) CALL XSPACE (1)
57       CONTINUE
         IF (L.EQ.0) GO TO 77
         CALL XDPRFX (A,NID+2,NIE+2)
         CALL XDPRFX (A/L,NID+2,NIE+2)
         IF (JE.EQ.1) GO TO 77
         JP = LDF+JR
         JDFR = IA(JP)
         IF (NSHRI.EQ.0.AND.NFPRIN.EQ.0) GO TO 77
C
C    F TEST
         JP = LVAR+(K-1)*NVARIA+NH
         D = RA(JP)
         IF (L*D.GT.1.0D-6*TOTSS.AND.D.NE.RMV.AND.JDFR.GT.0) GO TO 59
C -S-    IF (L*D.GT.1.0E-5*TOTSS.AND.D.NE.RMV.AND.JDFR.GT.0) GO TO 59
         CALL XPTEXT ('      N/A',9)
         GO TO 77
59       F = A/(L*D)
         CALL XDPRFX (F,4,3)
         IF (F.LT.1.5) GO TO 77
         IF (F.LT.500.0) GO TO 62
         CALL XPTEXT ('   ***',6)
         GO TO 77
62       C = FPROB (L,JDFR,F)
         IF (C.LE.0.050) CALL XPTEXT ('   *',4)
         IF (C.LE.0.010) CALL XPTEXT ('*',1)
         IF (C.LE.0.001) CALL XPTEXT ('*',1)
77       CALL XNLINE (1)
78       JANOVP = JANOVP+NVARIA
79    CONTINUE
C
C     TOTALS
C
      JP = LVAR+(NEMSQS-1)*NVARIA + NH
      RVAR11 = RA(JP)
      CALL XNLINE (1)
      CALL XSPACE (NSPACE-5)
      CALL XPTEXT ('Total',5)
      JP = LDF+NTERMS+2
      CALL XIPRIN (IA(JP),4)
      CALL XDPRFX (TOTSS,NID+6,NIE+2)
      CALL XNLINE (2)
C
C     COEFFICIENT OF VARIATION
C
      CALL XPTEXT ('CV ',3)
      JP = LMEAN+NDFS+NH
      D = DABS (RA(JP))
C -S- D = ABS (RA(JP))
      IF (RVAR11.EQ.RMV.OR.D.LT.1.0D-6) GO TO 85
C -S- IF (RVAR11.EQ.RMV.OR.D.LT.1.0E-5) GO TO 85
      CALL XPTEXT ('=',1)
      CALL XDPRFX (1.0D2*DSQRT(RVAR11)/D,1,2)
C -S- CALL XDPRFX (1.0E2* SQRT(RVAR11)/D,1,2)
      CALL XPTEXT (' per cent',9)
      GO TO 86
85    CALL XPTEXT ('not defined',11)
86    CALL XNLINE (2)
      RETURN
      END
      DOUBLE PRECISION FUNCTION FPROB (NU,NV,F)
C -S- REAL FUNCTION FPROB (NU,NV,F)
C
C     F PROBABILITY VIA CONVERGENT SERIES OF POSITIVE TERMS
C
      DOUBLE PRECISION A,B,TEMP,X,XC,SUM,TERM,TOP,BOT,F,LOGGAM
C -S- REAL A,B,TEMP,X,XC,SUM,TERM,TOP,BOT,F,LOGGAM
      IF (F.GT.0.AND.NU.GT.0.AND.NV.GT.0) GO TO 18
      FPROB = -1.0
      GO TO 34
18    A = 0.5*NU
      B = 0.5*NV
      TEMP = B+A*F
      X = A*F/TEMP
      XC = B/TEMP
      TOP = A+B
      BOT = B+1.0
      SUM = 1.0
      TERM = 1.0
C
27    TERM = TERM*(TOP/BOT)*XC
      SUM = SUM+TERM
      TOP = TOP+1.0
      BOT = BOT+1.0
      IF (TERM.GT.SUM*1.0D-8) GO TO 27
C -S- IF (TERM.GT.SUM*1.0E-6) GO TO 27
      TEMP = A*DLOG(X) + B*DLOG(XC) + LOGGAM(A+B) - LOGGAM(A)-LOGGAM(B)
C -S- TEMP = A*ALOG(X) + B*ALOG(XC) + LOGGAM(A+B) - LOGGAM(A)-LOGGAM(B)
      FPROB = DEXP(TEMP) * SUM/B
C -S- FPROB =  EXP(TEMP) * SUM/B
34    RETURN
      END
      DOUBLE PRECISION FUNCTION LOGGAM (A)
C -S- REAL FUNCTION LOGGAM (A)
C
C     CALCULATES LOG-GAMMA OF 'A'
C
      DOUBLE PRECISION A,TEMP,TEMP2,W,W2
C -S- REAL A,TEMP,TEMP2,W,W2
      W = A
      TEMP = 1.0
      IF (W.GT.13) GO TO 12
      N = IDINT(14.0D0-W)
C -S- N = INT(14.0-W)
      DO 11 NP = 1,N
      TEMP = TEMP*W
      W = W+1.0
11    CONTINUE
12    W2 = W*W
      TEMP2 = 0.0833333333 - (0.00277777777 - 7.93650793D-4/W2) / W2
C -S- TEMP2 = 0.0833333333 - (0.00277777777 - 7.93650793E-4/W2) / W2
      LOGGAM = TEMP2/W + 0.918938533-W + (W-0.5)*DLOG(W) - DLOG(TEMP)
C -S- LOGGAM = TEMP2/W + 0.918938533-W + (W-0.5)*ALOG(W) - ALOG(TEMP)
      RETURN
      END
      SUBROUTINE REGRES
C
C     CALCULATE AND PRINT REGRESSION COEFFICIENTS
C
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      COMMON/LOCALS/ LRESUL,LROWTO,LCOLTO,LADJ,LEV4RA,
     .LCOUNT,LROWCN,LCOLCN,LDFPOI,LSSPOI,LEV4IA,
     .NADJKN,NROWS,NCOLS,NDATAP,NDIMEN,NDEC,NID,NIE,NG,NH,
     .NPRSED,NTABSI,NFPRIN,NCURTA,NDFAJT,NADJDF
C
      CALL XPTEXT ('Regression Coefficient',22)
      IF (NCOVAR.GT.1) CALL XPTEXT ('s',1)
      IF (NEMSQS.EQ.1) GO TO 45
      CALL XPTEXT (', minimising Error(',19)
      CALL XIPRIN (NEMSQS,0)
      CALL XPTEXT (')',1)
45    CALL XNLINE (1)
      JLISTP = LLIST+1
      JPARTH = LPART+(NH-1)*NDFS
      DO 64 JT = 1,NTERMS
      J = -IA(JLISTP)
      IF (J.LE.0) GO TO 63
      CALL XPTEXT ('V',1)
      CALL XIPRIN (J,0)
      IF (J.LT.10) CALL XSPACE(1)
      JSP = LSTART+JT
      JS = IA(JSP)
      JP = JPARTH+JS
      CALL XDPRFX (RA(JP),NID+2,NIE+2)
      CALL XPTEXT ('    SE',6)
      JP = LSS + (JS*(JS+1)/2)
      CALL XDPRFX (DSQRT(RA(JP)*RVAR11),NID,NIE+2)
C -S- CALL XDPRFX ( SQRT(RA(JP)*RVAR11),NID,NIE+2)
      CALL XNLINE (1)
63    CONTINUE
      JLISTP = JLISTP+NNAMES+1
64    CONTINUE
      CALL XNLINE (1)
      RETURN
      END
      SUBROUTINE ADJPAR
C
      DOUBLE PRECISION A,B,S,T,P
C -S- REAL A,B,S,T,P
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      IF (NDFS.LT.2) GO TO 49
      J = NDFS*(NDFS-1)/2
      JT = NDFS
13       L = J-JT+1
         JS = JT-1
15          B = 0.0
            N = L+JS+JS
            JS1 = JS+1
            DO 20 JR = JS1,JT
            JSSJ = LSS+J+JR
            JSSN = LSS+N
            B = B+RA(JSSJ)*RA(JSSN)
            N = N+JR
20          CONTINUE
            JSS = LSS+JS+J
            JTP = LTPART+JS
            RA(JSS) = -B*RA(JTP)
            L = L-JS+1
            JS = JS-1
         IF (JS.GE.1) GO TO 15
         J = J-JT+1
         JT = JT-1
      IF (JT.GE.2) GO TO 13
C
      K = 0
      DO 48 JT= 1,NDFS
      JP = LTPART+JT
      IF (RA(JP).NE.0.0) GO TO 34
         JPARTP = LPART+JT
         DO 32 J = 1,NVARIA
         RA(JPARTP) = RMV
         JPARTP = JPARTP+NDFS
32       CONTINUE
         GO TO 46
34    IF (JT.EQ.NDFS) GO TO 45
         L = K+JT+JT
         JT1 = JT+1
         JSSL = LSS+L
         DO 44 JF = JT1,NDFS
         JTPARP = LTPART+JF
         IF (RA(JTPARP).EQ.0.0) GO TO 42
            A = RA(JSSL)
            JPARTF = LPART+JF
            JPARTT = LPART+JT
            DO 41 J = 1,NVARIA
            RA(JPARTT) = RA(JPARTT)+RA(JPARTF)*A
            JPARTF = JPARTF+NDFS
            JPARTT = JPARTT+NDFS
41          CONTINUE
42       CONTINUE
         JSSL = JSSL+JF
44       CONTINUE
45    CONTINUE
46    CONTINUE
      K = K+JT
48    CONTINUE
C
49    JP = 0
      DO 67 JS = 1,NDFS
      JQ = JP+JS
      JP = JQ
      JT = 0
58       JR = JQ
         B = 0.0
         JTS = JT+JS
         DO 63 N = JTS,NDFS
         JRS = LSS+JR
         JRT = JR+JT+LSS
         JTP = LTPART+N
         S = RA(JRS)
         T = RA(JRT)
         P = RA(JTP)
         IF (DABS(S).GT.1D-10.AND.DABS(T).GT.1D-10) B = B + S*T*P
C -S-    IF ( ABS(S).GT.1E-10.AND. ABS(T).GT.1E-10) B = B + S*T*P
         JR = JR+N
63       CONTINUE
         JQS = LSS+JQ
         RA(JQS) = B
         JQ = JQ+JT+JS
         JT = JT+1
         IF (JT.LE.NDFS-JS) GO TO 58
67    CONTINUE
      RETURN
      END
      SUBROUTINE ESTIMA
C
C     ESTIMATES AND INSERTS MISSING VALUES
C
      DOUBLE PRECISION EXD,B
C -S- REAL EXD,B
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      COMMON/LOCALS/ LRESUL,LROWTO,LCOLTO,LADJ,LEV4RA,
     .LCOUNT,LROWCN,LCOLCN,LDFPOI,LSSPOI,LEV4IA,
     .NADJKN,NROWS,NCOLS,NDATAP,NDIMEN,NDEC,NID,NIE,NG,NH,
     .NPRSED,NTABSI,NFPRIN,NCURTA,NDFAJT,NADJDF
C
      CALL XPTEXT ('Estimated missing values',24)
      IF (NEMSQS.EQ.1) GO TO 75
      CALL XPTEXT (', minimising Error(',19)
      CALL XIPRIN (NEMSQS,0)
      CALL XPTEXT (')',1)
75    CALL XNLINE (2)
      CALL XPTEXT ('Plot',4)
      CALL XSPACE (NID+NIE+1)
      CALL XPTEXT ('Value',5)
      CALL XNLINE (1)
C
      DO 85 J = 1,NMVUNI
      JP = LMVIND+J
      JU = IA(JP)
      CALL XIPRIN (JU,3)
      CALL CONSTR (1,JU,1,JT)
      B = EXD (JU,1)
      JP = LMVR+J
      RA(JP) = B
      IF (B.NE.RMV) GO TO 77
      CALL XPTEXT ('    cannot be estimated',23)
      GO TO 79
77    CALL XDPRFX (B,NID+2,NIE+2)
79    JP = LDATA+(JU-1)*NVSTOR+NG
      IF (RA(JP).NE.RMV) GO TO 82
      IF (NINSER.EQ.1) RA (JP) = B
      GO TO 83
82    CALL XPTEXT ('  Data value is not missing - ',30)
      CALL XPTEXT ('program recognises only one MV pattern',38)
83    CONTINUE
      CALL XNLINE (1)
85    CONTINUE
      IF (NINSER.EQ.0) GO TO 87
      CALL XNLINE (1)
      CALL XPTEXT ('Missing values inserted',23)
87    CALL XNLINE (2)
      RETURN
      END
      DOUBLE PRECISION FUNCTION EXD (JU,L)
C -S- REAL FUNCTION EXD (JU,L)
C
C     CALCULATES THE EXPECTED VALUE FOR UNIT JU IN THIS ANALYSIS
C     IF L=1 THEN COVARIATES ARE NOT TAKEN INTO ACCOUNT: IF L=0 THEY ARE
C
      DOUBLE PRECISION A,D
C -S- REAL A,D
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      COMMON/LOCALS/ LRESUL,LROWTO,LCOLTO,LADJ,LEV4RA,
     .LCOUNT,LROWCN,LCOLCN,LDFPOI,LSSPOI,LEV4IA,
     .NADJKN,NROWS,NCOLS,NDATAP,NDIMEN,NDEC,NID,NIE,NG,NH,
     .NPRSED,NTABSI,NFPRIN,NCURTA,NDFAJT,NADJDF
C
      JD = LDATA+(JU-1)*NVSTOR+NG
      D = RA(JD)
      JP = LMEAN+NDFS+NH
      A = RA(JP)
      DO 99 JV = 1,NTERMS
      JX = LXXIND+JV
      JX = IA(JX)
      IF (JX.EQ.-1.AND.L.EQ.1) GO TO 95
C
C     IF THE UNIT IS MISSING THEN LOOK THROUGH ALL OTHER UNITS WITH THE SAME
C     LEVELS OF THE FACTOR IN THE CURRENT TERM.  IF ALL ARE MISSING THEN
C     SET EXD TO MISSING
C
      IF (D.NE.RMV) GO TO 70
      JVP = LLIST+(JV-1)*(NNAMES+1)+1
      JVO = IA(JVP)
      IF (JVO.LE.0) GO TO 70
      DO 59 JP = 1,NUNITS
         DO 45 JF = 1,JVO
            KF = JVP+JF
            KF = IA(KF)
            IF (KF.LE.NFACTO) GO TO 41
            N = LSPFPT + KF-NFACTO
            KF = IA(N)
41          CONTINUE
            KU = LCODE+(JU-1)*NFACTO+KF
            KP = LCODE+(JP-1)*NFACTO+KF
            IF (IA(KU).NE.IA(KP)) GO TO 59
45       CONTINUE
         JD = LDATA + (JP-1)*NVSTOR + NG
         IF (RA(JD).NE.RMV) GO TO 70
59    CONTINUE
      EXD = RMV
      RETURN
C
C     NOT ALL VALUES MISSING: EXD CAN BE CALCULATED
C
70    CONTINUE
      JSP = LSTART+JV
      M1 = IA(JSP)
      M2 = IA(JSP+1)-1
      DO 93 M = M1,M2
         JP = LPART+(NH-1)*NDFS+M
         IF (RA(JP).EQ.RMV) GO TO 93
         JXXP = LXX+M
         JMEANP = LMEAN+M
         A = A+(RA(JXXP)-RA(JMEANP))*RA(JP)
93    CONTINUE
95    CONTINUE
99    CONTINUE
      EXD = A
      RETURN
      END
      SUBROUTINE RESIDS
C
C     FINDS RESIDUALS, PRINTING AND INSERTING AS REQUIRED
C
      DOUBLE PRECISION A,EXD
C -S- REAL A,EXD
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      COMMON/LOCALS/ LRESUL,LROWTO,LCOLTO,LADJ,LEV4RA,
     .LCOUNT,LROWCN,LCOLCN,LDFPOI,LSSPOI,LEV4IA,
     .NADJKN,NROWS,NCOLS,NDATAP,NDIMEN,NDEC,NID,NIE,NG,NH,
     .NPRSED,NTABSI,NFPRIN,NCURTA,NDFAJT,NADJDF
C
      IF (NRESID.GE.2) CALL XPTEXT ('Residuals in plot order',23)
      JV = LMVIND+1
      JW = NWIDTH
      N = 1
      IF (NID.GT.2) N = NID-2
      JDATAP = LDATA+NG
      DO 57 JU = 1,NUNITS
         IF (IA(JV).NE.JU) GO TO 37
         A = RMV
         JV = JV+1
         GO TO 39
37       CALL CONSTR (1,JU,0,JT)
         A = EXD(JU,0)
         IF (A.NE.RMV) A = RA(JDATAP)-A
39       CONTINUE
         IF (NRESID.LT.2) GO TO 55
         IF (JW.LT.NWIDTH) GO TO 42
         JW = 1
         CALL XNLINE (1)
         GO TO 43
42       JW = JW+1
43       CONTINUE
         IF (A.NE.RMV) GO TO 49
         CALL MVPRIN (N,NIE+2)
         GO TO 50
49       CALL XDPRFX (A,N,NIE+2)
50       CONTINUE
55    CONTINUE
      IF (NRESID.EQ.1.OR.NRESID.EQ.3) RA(JDATAP) = A
      JDATAP = JDATAP+NVSTOR
57    CONTINUE
C
      IF (NRESID.EQ.0.OR.NRESID.EQ.2) GO TO 60
      CALL XNLINE (2)
      CALL XPTEXT ('Residuals inserted',18)
60    CALL XNLINE (2)
      RETURN
      END
      SUBROUTINE TFORM
C
C     MAKES ROOM FOR A TABLE AND FORMS TOTALS
C
      DOUBLE PRECISION F
C -S- REAL F
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      COMMON/LOCALS/ LRESUL,LROWTO,LCOLTO,LADJ,LEV4RA,
     .LCOUNT,LROWCN,LCOLCN,LDFPOI,LSSPOI,LEV4IA,
     .NADJKN,NROWS,NCOLS,NDATAP,NDIMEN,NDEC,NID,NIE,NG,NH,
     .NPRSED,NTABSI,NFPRIN,NCURTA,NDFAJT,NADJDF
C
      JTABLP = LTABLE+(NCURTA-1)*(NTREAT+1)+1
      CALL FACPRI (JTABLP)
      CALL XPTEXT (' Table',6)
      CALL XNLINE (1)
C
C     FIND THE SIZE AND SHAPE OF THE TABLE
C
      NDIMEN = IA(JTABLP)
      NTABSI = 1
      DO 15 K = 1,NDIMEN
      JTABLK = JTABLP+K
      JLP = IA(JTABLK) + LLEVEL
      NTABSI = NTABSI*IA(JLP)
15    CONTINUE
      NCOLS = IA(JLP)
      NROWS = NTABSI/NCOLS
      IF (NDIMEN.LT.3) NCOLS = NCOLS+1
C
C     MAKE ROOM FOR TABLE STORAGE
C
C REAL
      JCP = LAJITC+NCURTA
      JAD = IA(JCP)
      IF (JAD.GT.0) JAD = 1
      TRC = FLOAT(NTABSI)+FLOAT(NROWS)+FLOAT(NCOLS)
      RDF = FLOAT(NDFAJT*JAD)
      AR = FLOAT(LEV3RA)+TRC+RDF*FLOAT(NTABSI)
      AI = FLOAT(LEV3IA)+TRC+RDF+RDF
      IF (AR.GT.FLOAT(LENDRA).OR.AI.GT.FLOAT(LENDIA)) GO TO 97
      LRESUL = LEV3RA
      LROWTO = LRESUL + NTABSI
      LCOLTO = LROWTO + NROWS
      LADJ = LCOLTO+NCOLS
      LEV4RA = LADJ + NTABSI*NDFAJT*JAD
C
C INTEGER
      LCOUNT = LEV3IA
      LROWCN = LCOUNT+NTABSI
      LCOLCN = LROWCN+NROWS
      LDFPOI = LCOLCN+NCOLS
      LSSPOI = LDFPOI+NDFAJT*JAD
      LEV4IA = LSSPOI+NDFAJT*JAD
      J4 = LEV4IA+NDIMEN
      IF (LEV4RA.GT.LMAXRA) LMAXRA = LEV4RA
      IF (J4.GT.LMAXIA) LMAXIA = J4
C
C     SET ALL ARRAYS TO ZERO
C
      J = LEV3IA+1
      DO 33 K = J,LEV4IA
      IA(K) = 0
33    CONTINUE
      J = LEV3RA+1
      DO 34 K = J,LEV4RA
      RA(K) = 0.0
34    CONTINUE
C
      JV = 1
      JMP = LMVIND+JV
      DO 67 JP = 1,NUNITS
C
C     TOTALS AND COUNTS
C
         N = 0
C    FIND THE CELL
         DO 48 L = 1,NDIMEN
         JTABLK = JTABLP+L
         K = IA(JTABLK)
         JLP = LLEVEL+K
         JCP = LCODE+(JP-1)*NFACTO+K
         N = N*IA(JLP) + IA(JCP)
48       CONTINUE
         N = N+1
C    DATA VALUES
         IF (JP.NE.IA(JMP)) GO TO 53
         JRP = LMVR+JV
         F = RA(JRP)
         JV = JV+1
         JMP = LMVIND+JV
         M = 1
         IF (F.EQ.RMV) GO TO 66
         GO TO 54
53       JRP = LDATA+(JP-1)*NVSTOR+NG
         F = RA(JRP)
         M = 0
54       JRESUP  = LRESUL+N
         RA(JRESUP)  = RA(JRESUP)+F
         JCOUNP = LCOUNT+N
         IA(JCOUNP) = IA(JCOUNP)+1
C
C        FIND ADJUSTMENTS IF THEY ARE NEEDED
C
         JACP = LAJITC+NCURTA
         IF (IA(JACP).EQ.0) GO TO 66
         CALL CONSTR (0,JP,M,JT)
         JADJP = LADJ+(N-1)*NDFAJT
         DO 65 JT = 1,NTERMS
            JXXP = LXXIND+JT
            IF (IABS(IA(JXXP)).NE.1) GO TO 64
            JSTARP = LSTART+JT
            JS1 = IA(JSTARP)
            JS2 = IA(JSTARP+1)-1
            DO 63 JS = JS1,JS2
               JADJP = JADJP+1
               JXXP = LXX+JS
               JRMP = LRMEAN+JS
               RA(JADJP) = RA(JADJP)+RA(JXXP)-RA(JRMP)
63          CONTINUE
64          CONTINUE
65       CONTINUE
66       CONTINUE
67    CONTINUE
      RETURN
97    MISTAK = 27
      CALL XPTEXT ('Store full: table cannot be formed',34)
      CALL XNLINE (1)
      RETURN
      END
      SUBROUTINE ADJUST
C
C     ADJUSTS TABLE VALUES
C
      DOUBLE PRECISION A,D
C -S- REAL A,D
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      COMMON/LOCALS/ LRESUL,LROWTO,LCOLTO,LADJ,LEV4RA,
     .LCOUNT,LROWCN,LCOLCN,LDFPOI,LSSPOI,LEV4IA,
     .NADJKN,NROWS,NCOLS,NDATAP,NDIMEN,NDEC,NID,NIE,NG,NH,
     .NPRSED,NTABSI,NFPRIN,NCURTA,NDFAJT,NADJDF
C
      JAJITC = LAJITC+NCURTA
      IF (NADJKN.NE.0) GO TO 51
C
C     SEE IF ADJUSTMENT FOR FACTOR TERMS MADE ANY DIFFERENCE
C     (IF SO, SUBSEQUENT VARIATES WON'T NEED IT)
C
      JAJITP = LADJIT+(NCURTA-1)*NTERMS
      JA = 0
      DO 50 JT = 1,NTERMS
         JAJITP = JAJITP+1
         JXXP = LXXIND+JT
         IF (IA(JXXP).EQ.-1) JA = JA+1
         IF (IA(JXXP).NE.1) GO TO 50
         JSTARP = LSTART+JT
         JS1 = IA(JSTARP)
         JS2 = IA(JSTARP+1)-1
         DO 47 JS = JS1,JS2
            JA = JA+1
            JRMP = LRMEAN+JS
            D = RA(JRMP)
            JAP = LADJ+JA
            DO 46 N = 1,NTABSI
            JCP = LCOUNT+N
            IF (DABS(RA(JAP) - IA(JCP)*D).GT.0.00001) GO TO 49
C -S-       IF (ABS (RA(JAP) - IA(JCP)*D).GT.0.0001 ) GO TO 49
            JAP = JAP+NDFAJT
46          CONTINUE
47       CONTINUE
         IA(JAJITP) = 0
         IA(JAJITC) = IA(JAJITC)-1
         GO TO 50
49       CONTINUE
         JA = JA+JS2-JS
50    CONTINUE
51    CONTINUE
C
      IF (IA(JAJITC).EQ.0) GO TO 78
C
C     ADJUSTMENTS ARE NEEDED - ALTER THE TABLE
C
      JQ = 0
      JAJITP  = LADJIT+(NCURTA-1)*NTERMS
      JPARTP = LPART+(NH-1)*NDFS
      JA = 0
      DO 75 JT = 1,NTERMS
         JXXP = LXXIND+JT
         JAJITP = JAJITP+1
         IF (IABS(IA(JXXP)).NE.1) GO TO 74
         JSTARP = LSTART+JT
         K   = IA(JSTARP)
         JS2 = IA(JSTARP+1)-1
         IF (IABS(IA(JAJITP)).EQ.1) GO TO 55
         JA = JA+JS2-K+1
         GO TO 74
55       JW = K*(K-1)/2
         DO 73 JS = K,JS2
            JA = JA+1
            JP = JPARTP+JS
            A = RA(JP)
            IF (A.EQ.RMV) GO TO 71
            JQ = JQ+1
            JPP  = LDFPOI+JQ
            IA(JPP) = JS
            JPP = LSSPOI+JQ
            IA(JPP) = JW
            JADJP = LADJ
            DO 70 N = 1,NTABSI
               JRP = LRESUL+N
               JAS = JADJP+JA
               RA(JRP) = RA(JRP)-RA(JAS)*A
               JAQ = JADJP+JQ
               JCP = LCOUNT+N
               JCN = IA(JCP)
               IF (JCN.GT.0) GO TO 68
               RA(JAQ) = 0.0
               GO TO 69
68             RA(JAQ) = RA(JAS)/JCN
69             JADJP = JADJP+NDFAJT
70          CONTINUE
71          CONTINUE
            JW = JW+JS
73       CONTINUE
74       CONTINUE
75    CONTINUE
      NADJDF = JQ
78    RETURN
      END
      SUBROUTINE TPRINT
C
C     PRINTS THE CURRENT TABLE, WITH MARGINS IF 1 OR 2 DIMENSIONS
C
      DIMENSION IX(25)
      DOUBLE PRECISION A,B
C -S- REAL A,B
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      COMMON/LOCALS/ LRESUL,LROWTO,LCOLTO,LADJ,LEV4RA,
     .LCOUNT,LROWCN,LCOLCN,LDFPOI,LSSPOI,LEV4IA,
     .NADJKN,NROWS,NCOLS,NDATAP,NDIMEN,NDEC,NID,NIE,NG,NH,
     .NPRSED,NTABSI,NFPRIN,NCURTA,NDFAJT,NADJDF
C
      COMMON/EDEXIO/ KINST,NINSTK,INSTK(5),MAXSTK,MININ,MAXIN,
     .               KOUTST,MINOUT,MAXOUT,KIECHO,KOECHO,KINLEN,KOUTLN
C     SET UP AN ARRAY HOLDING CURRENT LEVELS
C
      DO 13 K = 1,NDIMEN
13    IX(K) = 0
      MDEC = NDEC
      ID = NID
      IF (NDEC.GT.MAXLN) GO TO 14
      MDEC = MAXLN-1
      ID = NID+MDEC-NDEC
14    CONTINUE
      NPCOLS = (KOUTLN - (MAXLN-1)*(NDIMEN-1)) / (MDEC+2)
      NSPLIT = ((NCOLS-1)/NPCOLS)+1
      JTABLP = LTABLE + (NCURTA-1)*(NTREAT+1) + 1
C
      DO 99 K = 1,NSPLIT
C
C     TOP HEADINGS
C
      JQ = (K-1)*NPCOLS
      IF (K.NE.NSPLIT) GO TO 16
      N = NCOLS-JQ
      IF (NDIMEN.LT.3) N = N-1
      GO TO 17
16    N = NPCOLS
17    CONTINUE
C PUT THE NAME OF THE LAST FACTOR ABOVE EACH COLUMN
      JF = JTABLP+NDIMEN
      JF = IA(JF)*2 + LNAME
      CALL XSPACE ((MAXLN+1)*(NDIMEN-1))
      DO 22 JS = 1,N
      CALL XSPACE (MDEC+1)
      CALL XCPRIN (IA(JF-1))
22    CONTINUE
      CALL XNLINE (1)
C FACTOR NAMES OF ROW HEADINGS
      IF (NDIMEN.EQ.1) GO TO 30
         DO 26 JS = 2,NDIMEN
         JF = JTABLP+JS-1
         JF = IA(JF)*2+LNAME
         CALL XSPACE (MAXLN)
         CALL XCPRIN (IA(JF-1))
26       CONTINUE
30    CONTINUE
C
C LEVEL NAMES OF LAST FACTOR (COLUMN HEADINGS)
      JF = JTABLP+NDIMEN
      JF = IA(JF)
      IF (N.EQ.0) GO TO 38
      JQ1 = JQ+1
      JQN = JQ+N
      DO 37 JS = JQ1,JQN
      CALL LNPRIN (JF,JS-1,MDEC+2)
37    CONTINUE
38    CONTINUE
C
      IF (NDIMEN.GT.2.OR.K.NE.NSPLIT) GO TO 40
      CALL XSPACE (MDEC-1)
      CALL XPTEXT ('Mean',4)
40    JR = 0
      JW = 1
      CALL XNLINE (1)
C
C     LEFT HEADINGS
C
43    IF (NDIMEN.EQ.1) GO TO 53
      CALL XSPACE ((MAXLN+1)*(JW-1))
      JD1 = NDIMEN-1
      DO 52 JS = JW,JD1
         JF = JTABLP+JS
         CALL LNPRIN (IA(JF),IX(JS),MAXLN+1)
52    CONTINUE
53    CONTINUE
      JR = JR+1
      JRP = LROWTO+JR
      A = RA(JRP)
      JCP = LROWCN+JR
      JT = IA(JCP)
C
C     BODY OF TABLE
C
      IF (N.EQ.0) GO TO 71
      DO 69 JS = JQ1,JQN
      JW = JS+(JR-1)*(NCOLS-1)
      IF (NDIMEN.GT.2) JW = JW+JR-1
      JRP = LRESUL+JW
      B = RA(JRP)
      JCP = LCOUNT+JW
      JV = IA(JCP)
      IF (JV.GT.0) GO TO 63
      CALL MVPRIN (ID,NIE)
      GO TO 68
63    CALL XDPRFX (B/JV,ID,NIE)
      A = A+B
      JT = JT+JV
      JTP = LCOLTO+JS
      RA(JTP) = RA(JTP)+B
      JCP = LCOLCN+JS
      IA(JCP) = IA(JCP)+JV
68    CONTINUE
69    CONTINUE
      JTP = LROWTO+JR
      RA(JTP) = A
      JCP = LROWCN+JR
      IA(JCP) = JT
71    CONTINUE
C
C     RIGHT MARGIN
C
      IF (NDIMEN.GT.2.OR.K.NE.NSPLIT) GO TO 78
      IF (JT.NE.0) GO TO 74
      CALL MVPRIN (ID+1,NIE)
      GO TO 77
74    CALL XDPRFX (A/JT,ID+1,NIE)
      JTP = LCOLTO+NCOLS
      RA(JTP) = RA(JTP)+A
      JCP = LCOLCN+NCOLS
      IA(JCP) = IA(JCP)+JT
77    CONTINUE
78    CONTINUE
C
C     ANY MORE ROWS?
C
      IF (NDIMEN.EQ.1) GO TO 97
      JW = NDIMEN-1
82    IX(JW) = IX(JW)+1
      JTP = JTABLP+JW
      JTP = IA(JTP)+LLEVEL
      IF (IA(JTP).EQ.IX(JW)) GO TO 84
      CALL XNLINE (1)
      GO TO 43
84    IX(JW) = 0
      JW = JW-1
      IF (JW.GE.1) GO TO 82
C
C     NO - PRINT COLUMN MEANS IF 2 DIMENSIONS
C
      CALL XNLINE (2)
      IF (NDIMEN.NE.2) GO TO 97
      CALL XSPACE (MAXLN-3)
      CALL XPTEXT ('Mean',4)
      IF (N.EQ.0) GO TO 94
      DO 92 JS = JQ1,JQN
      JCP = LCOLCN+JS
      JT = IA(JCP)
      IF (JT.NE.0) GO TO 91
      CALL MVPRIN(ID,NIE)
      GO TO 92
91    JTP = LCOLTO+JS
      CALL XDPRFX (RA(JTP)/JT,ID,NIE)
92    CONTINUE
      IF (K.NE.NSPLIT) GO TO 97
94    CONTINUE
C
C     GRAND MEAN
C
      JCP = LCOLCN+NCOLS
      JT = IA(JCP)
      IF (JT.NE.0) GO TO 96
      CALL MVPRIN (ID+1,NIE)
      GO TO 97
96    JTP = LCOLTO+NCOLS
      CALL XDPRFX (RA(JTP)/JT,ID+1,NIE)
97    CONTINUE
      CALL XNLINE (2)
99    CONTINUE
      IF (NDIMEN.LE.2) NCOLS = NCOLS-1
      RETURN
      END
      SUBROUTINE TABSE
C
C     CALCULATES AND PRINTS STANDARD ERRORS
C
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      COMMON/LOCALS/ LRESUL,LROWTO,LCOLTO,LADJ,LEV4RA,
     .LCOUNT,LROWCN,LCOLCN,LDFPOI,LSSPOI,LEV4IA,
     .NADJKN,NROWS,NCOLS,NDATAP,NDIMEN,NDEC,NID,NIE,NG,NH,
     .NPRSED,NTABSI,NFPRIN,NCURTA,NDFAJT,NADJDF
C
C     SEE IF ALL ENTRIES IN THE TABLE HAVE THE SAME FREQUENCY
C
      CALL FREQUE (NFREQ)
C
C     IGNORE SE IF THERE IS NO ERROR TERM
C
      JDFP = LDF+NTERMS+1
      IF (IA(JDFP).EQ.0) GO TO 88
C
C     FOR 2-DIMENSIONAL TABLES, SEE IF THE FACTORS ARE IN THE SAME ERROR
C
      NSEIND = 0
      IF (NDIMEN.NE.2) GO TO 40
      JTABLP = LTABLE+(NCURTA-1)*(NTREAT+1)+1
      JR1 = IA(JTABLP+1) + LROINT
      JR2 = IA(JTABLP+2) + LROINT
      IF (IA(JR1)-IA(JR2)) 32,40,31
31    NSEIND = 1
      GO TO 40
32    NSEIND = 2
40    CONTINUE
C
C     CALCULATE THE STANDARD ERROR, THE METHOD DEPENDING ON THE
C     COMPLEXITY OF THE DESIGN
C
      JAP = LAJITC+NCURTA
      IF (IA(JAP).NE.0) GO TO 56
      IF (NFREQ.EQ.0.AND.NSEIND.NE.0) GO TO 87
      CALL SESIMP (NSEIND,NFREQ)
      GO TO 88
56    IF (NSEIND.GT.0) GO TO 87
      CALL SEDIFF
      GO TO 88
C
87    CALL XPTEXT ('The experiment has a complicated structure',42)
      CALL XNLINE (1)
      CALL XPTEXT ('Please calculate your own errors',32)
      CALL XNLINE (2)
C
88    RETURN
      END
      SUBROUTINE FREQUE (NFREQ)
C
C     CHECKS THAT ALL NON-EMPTY TABLE CELLS HAVE THE SAME FREQUENCY
C     IF SO, NFREQ = FREQUENCY
C     IF NOT, NFREQ = 0 AND A TABLE OF FREQUENCIES IS PRINTED
C
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      COMMON/LOCALS/ LRESUL,LROWTO,LCOLTO,LADJ,LEV4RA,
     .LCOUNT,LROWCN,LCOLCN,LDFPOI,LSSPOI,LEV4IA,
     .NADJKN,NROWS,NCOLS,NDATAP,NDIMEN,NDEC,NID,NIE,NG,NH,
     .NPRSED,NTABSI,NFPRIN,NCURTA,NDFAJT,NADJDF
C
      CALL FRECAL (IA(LCOUNT+1),NTABSI,NFREQ)
      IF (NFREQ.EQ.0) GO TO 46
C
C     FOR 2-DIMENSIONAL TABLES, CHECK THAT ALL ROW MARGIN COUNTS
C     ARE THE SAME, ALSO ALL COLUMN MARGIN COUNTS
C
      IF (NDIMEN.NE.2) GO TO 70
      CALL FRECAL (IA(LROWCN+1),NROWS,N)
      IF (N.EQ.0) GO TO 44
      CALL FRECAL (IA(LCOLCN+1),NCOLS,N)
      IF (N.NE.0) GO TO 70
44    NFREQ = 0
C
C     PRINT THE TABLE OF FREQUENCIES, INCLUDING MARGINS FOR 2-WAY TABLE
C
46    CALL XPTEXT ('Unequal frequencies',19)
      CALL XNLINE (1)
      JCP = LCOUNT
      DO 64 JR = 1,NROWS
         CALL XNLINE (1)
         DO 50 JC = 1,NCOLS
         JCP = JCP+1
         CALL XIPRIN (IA(JCP),3)
50       CONTINUE
         IF (NDIMEN.NE.2) GO TO 55
         JT = LROWCN+JR
         CALL XIPRIN (IA(JT),5)
55       CONTINUE
64    CONTINUE
      IF (NDIMEN.NE.2) GO TO 69
      CALL XNLINE (2)
      DO 68 JC = 1,NCOLS
      JT = LCOLCN+JC
      CALL XIPRIN (IA(JT),3)
68    CONTINUE
69    CONTINUE
      CALL XNLINE (2)
70    CONTINUE
      RETURN
      END
      SUBROUTINE FRECAL (KOUNTS,NSIZ,NFREQ)
C
C     LOOKS THROUGH AN ARRAY KOUNTS(NSIZ).  IF ALL NON-ZERO ELEMENTS ARE
C     EQUAL THEN NFREQ = VALUE OF THOSE ELEMENTS, OTHERWISE NFREQ = 0.
C     IT IS ASSUMED THAT AT LEAST ONE ELEMENT OF THE ARRAY IS NON-ZERO
C
      INTEGER KOUNTS(NSIZ)
      NFREQ = 0
      K = 0
32    K = K+1
      IF (KOUNTS(K).EQ.0) GO TO 32
      N = KOUNTS(K)
      DO 35 L = K,NSIZ
      IF (KOUNTS(L).NE.0.AND.KOUNTS(L).NE.N) GO TO 50
35    CONTINUE
      NFREQ = N
50    RETURN
      END
      SUBROUTINE SESIMP (NSEIND,NFREQ)
C
C     CALCULATES AND PRINTS SIMPLE STANDARD ERRORS
C     NFREQ = NO. OF ENTRIES IN EACH CELL, 0 IF UNEQUAL FREQUENCY
C     SEIND = 0 IF THE FACTORS (FOR A 2-DIMENSIONAL TABLE) ARE IN THE
C     SAME ERROR TERM
C
      DOUBLE PRECISION V0,V1,V2,V3,A,B
C -S- REAL V0,V1,V2,V3,A,B
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      COMMON/LOCALS/ LRESUL,LROWTO,LCOLTO,LADJ,LEV4RA,
     .LCOUNT,LROWCN,LCOLCN,LDFPOI,LSSPOI,LEV4IA,
     .NADJKN,NROWS,NCOLS,NDATAP,NDIMEN,NDEC,NID,NIE,NG,NH,
     .NPRSED,NTABSI,NFPRIN,NCURTA,NDFAJT,NADJDF
C
C     FIND THE VARIANCE
C
      JTABLP = LTABLE+(NCURTA-1)*(NTREAT+1)+1
      IF (NDIMEN.EQ.2) GO TO 29
      K = 0
      DO 27 JD = 1,NDIMEN
      JTP = JTABLP+JD
      JRP = IA(JTP)
      JRP = LROINT+JRP
      L = IA(JRP)
      IF (L.GT.K) K = L
27    CONTINUE
      JVARP = LVAR+(K-1)*NVARIA+NH
      V1 = RA(JVARP)
      GO TO 39
C
C     FOR 2-DIMENSIONAL TABLES, FIND VARIANCES FOR ROWS (V2), COLUMNS
C     (V3), HORIZONTAL COMPARISONS (V0) AND VERTICAL COMAPRISONS (V1)
C
29    JRP = IA(JTABLP+1) + LROINT
      J = IA(JRP)
      JVARP = LVAR+(J-1)*NVARIA+NH
      B = RA(JVARP)
      V2 = B
      JRP = IA(JTABLP+2) + LROINT
      K = IA(JRP)
      JVARP = LVAR+(K-1)*NVARIA+NH
      A = RA(JVARP)
      V3 = A
      IF (J.NE.K) GO TO 35
      V1 = A
      GO TO 38
35    JSP = JTABLP+NSEIND
      JSP = IA(JSP)+LLEVEL
      L = IA(JSP)
      IF (J.LE.K) GO TO 37
      V0 = (A+(L-1)*B)/L
      V1 = B
      GO TO 38
37    V1 = (B+(L-1)*A)/L
      V0 = A
38    CONTINUE
39    CONTINUE
C
      JP = NIE+1
      IF (NFREQ.EQ.0) GO TO 79
C
C     UNADJUSTED TABLES, EQUAL FREQUENCIES
C
      CALL XPTEXT ('SE',2)
      IF (NSEIND.EQ.0) GO TO 67
      CALL XPTEXT ('  H',3)
      IF (NSEIND.EQ.1) CALL XPTEXT ('I',1)
      CALL XDPRFX (DSQRT(V0/NFREQ),NID,JP)
C -S- CALL XDPRFX ( SQRT(V0/NFREQ),NID,JP)
      CALL XPTEXT ('  V',3)
      IF (NSEIND.EQ.2) CALL XPTEXT ('I',1)
67    CONTINUE
      CALL XDPRFX (DSQRT(V1/NFREQ),NID,JP)
C -S- CALL XDPRFX ( SQRT(V1/NFREQ),NID,JP)
      IF (NDIMEN.NE.2) GO TO 75
C
      J = LROWCN
68    J = J+1
      IF (IA(J).EQ.0) GO TO 68
      CALL XDPRFX (DSQRT(V2/IA(J)),NID,JP)
C -S- CALL XDPRFX ( SQRT(V2/IA(J)),NID,JP)
      CALL XNLINE (1)
      CALL XSPACE (2)
      IF (NSEIND.GT.0) CALL XSPACE (NID+NIE+10)
      J = LCOLCN
72    J = J+1
      IF (IA(J).EQ.0) GO TO 72
      CALL XDPRFX (DSQRT(V3/IA(J)),NID,JP)
C -S- CALL XDPRFX ( SQRT(V3/IA(J)),NID,JP)
75    CALL XNLINE (2)
      GO TO 95
C
C     SIMPLE ERRORS, UNEQUAL FREQUENCIES
C
79    CALL AVERR (IA(LCOUNT+1),NTABSI,V1,NID,JP)
      IF (NDIMEN.NE.2) GO TO 85
      CALL AVERR (IA(LROWCN+1),NROWS, V2,NID,JP)
      CALL AVERR (IA(LCOLCN+1),NCOLS, V3,NID,JP)
85    CONTINUE
      CALL XNLINE (1)
C
95    RETURN
      END
      SUBROUTINE AVERR (KOUNTS,NSIZ,V,ID,IE)
C
C     CALCULATES THE AVERAGE SE OF A TABLE WITH SIMPLE STRUCTURE BUT
C     UNEQUAL FREQUENCIES
C
      DOUBLE PRECISION A,B,C,D,V
C -S- REAL A,B,C,D,V
      INTEGER KOUNTS(NSIZ)
      A = 0.0
      B = 2.0
      D = 0.0
      M = 0
      L1 = NSIZ-1
      DO 58 J = 1,L1
      N = KOUNTS(J)
      IF (N.EQ.0) GO TO 57
      J1 = J+1
      DO 56 K = J1,NSIZ
      IF (KOUNTS(K).EQ.0) GO TO 55
      C = 1.0/N + 1.0/KOUNTS(K)
      IF (C.GT.A) A = C
      IF (C.LT.B) B = C
      D = D+C
      M = M+1
55    CONTINUE
56    CONTINUE
57    CONTINUE
58    CONTINUE
C
      CALL XPTEXT ('Av SE =',7)
      CALL XDPRFX (DSQRT(D*V/(2.0*M)),ID,IE)
C -S- CALL XDPRFX ( SQRT(D*V/(2.0*M)),ID,IE)
      IF (A.LT.1.001*B) GO TO 68
      CALL XPTEXT ('  (SE of diff',13)
      CALL XDPRFX (DSQRT(B*V),ID,IE)
C -S- CALL XDPRFX ( SQRT(B*V),ID,IE)
      CALL XPTEXT ('  to',4)
      CALL XDPRFX (DSQRT(A*V),ID,IE)
C -S- CALL XDPRFX ( SQRT(A*V),ID,IE)
      CALL XPTEXT (')',1)
68    CONTINUE
      CALL XNLINE (1)
      RETURN
      END
      SUBROUTINE SEDIFF
C
C     CALCULATES STANDARD ERRORS OF ADJUSTED TABLES
C
      DOUBLE PRECISION A,B
C -S- REAL A,B
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      COMMON/LOCALS/ LRESUL,LROWTO,LCOLTO,LADJ,LEV4RA,
     .LCOUNT,LROWCN,LCOLCN,LDFPOI,LSSPOI,LEV4IA,
     .NADJKN,NROWS,NCOLS,NDATAP,NDIMEN,NDEC,NID,NIE,NG,NH,
     .NPRSED,NTABSI,NFPRIN,NCURTA,NDFAJT,NADJDF
C
C     MAKE ROOM FOR LOCAL ARRAYS
C
      AD = FLOAT(LEV4RA)+FLOAT(NTABSI)
      AE = AD
      IF (NDIMEN.EQ.2)
     .   AE = FLOAT(LEV4RA)+(FLOAT(NROWS)+FLOAT(NCOLS))*FLOAT(NADJDF+1)
      IF (AE.GT.AD) AD = AE
      IF (AD.GT.FLOAT(LENDRA)) GO TO 97
      LTVAR = LEV4RA
      JEND = LTVAR+NTABSI
      IF (NDIMEN.NE.2) GO TO 15
      LADJRO = LTVAR+NROWS+NCOLS
      LADJCO = LADJRO+NROWS*NADJDF
      JEND1 = LADJCO+NCOLS*NADJDF
      IF (JEND1.GT.JEND) JEND = JEND1
15    IF (JEND.GT.LMAXRA) LMAXRA = JEND
C
      CALL SEDCAL (LADJ+0,LCOUNT+0,NTABSI+0,0)
      IF (NDIMEN.NE.2) GO TO 50
      DO 43 JS = 1,NADJDF
         N = LADJ+JS
         JCP = LADJCO+JS
         DO 32 K = 1,NCOLS
         RA(JCP) = 0.0
         JCP = JCP+NADJDF
32       CONTINUE
         JRP = LADJRO+JS
         JNT = LCOUNT
         JNR = LROWCN
         DO 42 JR = 1,NROWS
         A = 0.0
         JCP = LADJCO+JS
         JNC = LCOLCN
         DO 40 K = 1,NCOLS
            JNT = JNT+1
            JNC = JNC+1
            B = RA(N)*IA(JNT)
            N = N+NDFAJT
            A = A+B
            RA(JCP) = RA(JCP) + B/IA(JNC)
            JCP = JCP+NADJDF
40       CONTINUE
         JNR = JNR+1
         RA(JRP) = A/IA(JNR)
         JRP = JRP+NADJDF
42       CONTINUE
43    CONTINUE
      CALL SEDCAL (LADJRO+0,LROWCN+0,NROWS+0,1)
      CALL SEDCAL (LADJCO+0,LCOLCN+0,NCOLS+0,2)
50    CONTINUE
      RETURN
C
C     NOT ENOUGH STORE
C
97    CALL XPTEXT ('Store full: ',12)
      CALL XPTEXT ('standard errors cannot be calculated',36)
      CALL XNLINE (2)
      RETURN
      END
      SUBROUTINE SEDCAL (KADJ,KCOUNT,KTABSI,KPASS)
C
C     CALCULATES AND PRINTS STANDARD ERRORS OF DIFFERENCES OF MEANS
C     PASS = 0 (BODY OF TABLE)  1 (ROW MARGIN)  2 (COLUMN MARGIN)
C
      DOUBLE PRECISION RMAX,RMIN,A,C,D,F
C -S- REAL RMAX,RMIN,A,C,D,F
      DOUBLE PRECISION RA,RMV,RVAR11
C -S- REAL RA,RMV,RVAR11
      COMMON/AREAL/ RMV,RVAR11,RA(16382)
      COMMON/ARAPTS/ LDATA,LSPEFF,LSS,LPART,LTPART,LANOVA,LVAR,
     .LMEAN,LRMEAN,LXX,LMVR,LENDRA,LEV2RA,LEV3RA,LMAXRA,
     .LNAME,LLEVEL,LLABST,LSPFPT,LSECOF,LCODE,LFCHEK,LCHECK,LHALT,
     .LINDEX,LROINT,LLABEL,LLIST,LAID,LSTART,LERROR,LXXIND,LDF,LMVIND,
     .LTABLE,LADJIT,LAJITC,LENDIA,LEV2IA,LEV3IA,LMAXIA,IA(2048)
      COMMON/CONSTS/
     .NSHRI,MISTAK,NUNITS,NVSTOR,NBLOCK,NTREAT,NEFFEC,NNAMES,NFACTO,
     .MAXLN,MAXWID,NWIDTH,NDATAL,NDFLAG(3),NCOVAR,NSPACE,NTERMS,NDFS,
     .NEMSQS,NVARIA,NMVUNI,NRESID,NINSER,NADJUS,NTABLE,NSSSET,
     .NTER,KSTAR,KDOT,KOMMA,KSPACE,NLINE,KOPER(4),
     .LBRACK,KBRACK,IQUAL,KZERO,KNINE,LETERA,LETERC,LETERD,LETERE,
     .LETERF,LETERM,LETERN,LETERP,LETERR,LETERS,LETERV,LETERZ
C
      COMMON/LOCALS/ LRESUL,LROWTO,LCOLTO,LADJ,LEV4RA,
     .LCOUNT,LROWCN,LCOLCN,LDFPOI,LSSPOI,LEV4IA,
     .NADJKN,NROWS,NCOLS,NDATAP,NDIMEN,NDEC,NID,NIE,NG,NH,
     .NPRSED,NTABSI,NFPRIN,NCURTA,NDFAJT,NADJDF
C
      COMMON/EDEXIO/ KINST,NINSTK,INSTK(5),MAXSTK,MININ,MAXIN,
     .               KOUTST,MINOUT,MAXOUT,KIECHO,KOECHO,KINLEN,KOUTLN
C
      LTVAR = LEV4RA
      JPCOLS = (KOUTLN-4)/(NDEC+4)
      RMIN = 1.0D20
C -S- RMIN = 1.0E20
      RMAX = -RMIN
      JDF = NDFAJT
      IF (KPASS.NE.0) JDF = NADJDF
C
C     PRINT TABLE OR MARGIN FACTOR NAMES
C
      IF (NPRSED.NE.0) GO TO 11
      JSPLIT = 1
      GO TO 17
11    JSPLIT = (KTABSI-2)/JPCOLS + 1
      CALL XPTEXT ('Standard errors of differences of ',34)
      JTABLP = LTABLE+(NCURTA-1)*(NTREAT+1)+1
      IF (KPASS.NE.0) GO TO 15
      CALL FACPRI (JTABLP)
      GO TO 16
15    J = JTABLP+KPASS
      J = LNAME+IA(J)*2-1
      CALL XCPRIN (IA(J))
16    CALL XPTEXT (' table means',12)
      CALL XNLINE (2)
17    CONTINUE
C
C     FORM THE TABLE. IF PRINTING, WIDE TABLES ARE SPLIT
C
      M = 0
      JQ = 0
      D = 0.0
      DO 86 K = 1,JSPLIT
         JSTART = M+1
         M = M+JPCOLS
         IF (K.EQ.JSPLIT) M = KTABSI-1
C
C        NEXT ROW
C        WRITE CELL NUMBER
C
         DO 76 N = JSTART,KTABSI
            IF (N.EQ.JSTART.OR.NPRSED.EQ.0) GO TO 28
            IF (N.LT.10) CALL XSPACE (1)
            CALL XPTEXT ('(',1)
            CALL XIPRIN (N,0)
            CALL XPTEXT (')',1)
28          CONTINUE
C
C           EMPTY CELL - PRINT ROW AS *
C
            JEND = N-1
            IF (N-1.GT.M) JEND = M
            JTVARN = LTVAR+N
            JCP = KCOUNT+N
            IF (IA(JCP).GT.0) GO TO 40
            IF (N.EQ.JSTART.OR.NPRSED.EQ.0) GO TO 36
            DO 35 JR = JSTART,JEND
            CALL MVPRIN (NID,NIE+2)
35          CONTINUE
            CALL XNLINE (1)
36          CONTINUE
            GO TO 76
C
40          JADJP = KADJ+(N-1)*JDF
            DO 50 JR = 1,NADJDF
               F = 0.0
               JADJR = JADJP+JR
               A = RA(JADJR)
               JSP = LSSPOI+JR
               JW = IA(JSP)
               DO 48 JS = 1,JR
               JSP = LDFPOI+JS
               JV = JW+IA(JSP)
               JSSV = LSS+JV
               JADJS = JADJP+JS
               F = F + RA(JSSV)*RA(JADJS)
               IF (JR.EQ.JS) GO TO 49
               JXXS = LXX+JS
               RA(JXXS) = RA(JXXS) + RA(JSSV)*A
48             CONTINUE
49             JXXR = LXX+JR
               RA(JXXR) = F
50          CONTINUE
C
            IF (K.NE.1) GO TO 58
            A = 0.0
            DO 56 JS = 1,NADJDF
            JXXS = LXX+JS
            JADJS = JADJP+JS
            A = A+RA(JXXS)*RA(JADJS)
56          CONTINUE
            RA(JTVARN) = A
58          CONTINUE
            IF (N.EQ.JSTART) GO TO 76
C
            JCN = KCOUNT+N
            F = 1.0/IA(JCN) + RA(JTVARN)
            JADJR = KADJ+(JSTART-1)*JDF
            DO 75 JR = JSTART,JEND
               JCR = KCOUNT+JR
               IF (IA(JCR).GT.0) GO TO 65
               IF (NPRSED.EQ.1) CALL MVPRIN (NID,NIE+2)
               GO TO 74
65             JTVARR = LTVAR+JR
               C=F+1.0/IA(JCR) + RA(JTVARR)
               DO 69 JS = 1,NADJDF
               JXXS = LXX+JS
               JADJS = JADJR+JS
               C = C-RA(JXXS)*RA(JADJS)*2
69             CONTINUE
               JQ = JQ+1
               D = D+C
               IF (C.LT.RMIN) RMIN = C
               IF (C.GT.RMAX) RMAX = C
               IF (NPRSED.EQ.1) CALL XDPRFX (DSQRT(C*RVAR11),NID,NIE+2)
C -S-          IF (NPRSED.EQ.1) CALL XDPRFX ( SQRT(C*RVAR11),NID,NIE+2)
74             CONTINUE
               JADJR = JADJR+JDF
75          CONTINUE
            IF (NPRSED.EQ.1) CALL XNLINE (1)
76       CONTINUE
C
C        PRINT TABLE CELL NOS. AT FOOT OF TABLE
C
         IF (NPRSED.NE.1) GO TO 85
         CALL XSPACE (4)
         DO 83 JS = JSTART,M
         CALL XSPACE (NDEC)
         IF (JS.LT.10) CALL XSPACE (1)
         CALL XPTEXT ('(',1)
         CALL XIPRIN (JS,0)
         CALL XPTEXT (')',1)
83       CONTINUE
         CALL XNLINE (2)
85       CONTINUE
86    CONTINUE
C
C     PRINT AV SE, MAX & MIN SE OF DIFF
C
      CALL XPTEXT ('Av SE =',7)
      CALL XDPRFX (DSQRT(D*RVAR11/(2.0*JQ)),NID,NIE+1)
C -S- CALL XDPRFX ( SQRT(D*RVAR11/(2.0*JQ)),NID,NIE+1)
      IF (RMAX.LT.1.001*RMIN) GO TO 96
      CALL XPTEXT ('   (SE of diff',14)
      CALL XDPRFX (DSQRT(RMIN*RVAR11),NID,NIE+1)
C -S- CALL XDPRFX ( SQRT(RMIN*RVAR11),NID,NIE+1)
      CALL XPTEXT ('  to',4)
      CALL XDPRFX (DSQRT(RMAX*RVAR11),NID,NIE+1)
C -S- CALL XDPRFX ( SQRT(RMAX*RVAR11),NID,NIE+1)
      CALL XPTEXT (')',1)
96    CALL XNLINE (2)
      RETURN
      END