Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-05 - decus/20-0137/tab/tab.for
There is 1 other file named tab.for in the archive. Click here to see a list.
C
C	WESTERN  MICHIGAN  UNIVERSITY
C
C	GENERALIZED  CROSS-TABULATION  PROGRAM
C
C	PROGRAMMED BY  BERENICE HOUCHARD
C		       COMPUTER CENTER, WMU
C		       AUGUST, 1974
C
C
C	MODIFIED BY    DAVID C. SCHULZ
C		       COMPUTER CENTER WMU
C		       JANUARY 1976
C
C
C	THIS IS PART OF THE BANK SYSTEM DESIGNED BY RICHARD A. HOUCHARD.
C	IT ACCEPTS DATA FROM A STRUCTURED DATA BANK FILE, THE TELETYPE
C	AS WELL AS AN UNSTRUCTURED DATA FILE. A, I, F-TYPE VARIABLES
C	ARE EASILY HANDLED.  OPTIONS EXISTS TO ENTER VARIABLE NAMES,
C	TO SUBSET DATA BY SPECIFYING CERTAIN CRITERIA, TO ENTER USER'S
C	OWN FORMAT, AND NUMEROUS STATISTICAL TESTS.  OUTPUT IS IN A
C	MATRIX FORM WITH CHI-SQUARE AND PROBABILITY CALCULATED
C	AUTOMATICALLY WHEN APPLICABLE.  MISSING DATA DEFINED IN A DATA 
C	BANK CAN BE TREATED AS MISSING.  A SHORT DESCRIPTION WILL TYPE
C	OUT IN RESPONSE TO "HELP" FROM THE USER IN MAJOR KEY PLACES.
C
C
C	SUBROUTINES USED:
C
C	     TTYPTY  (*)  DETERMINE IF JOB IS ON TELETYPE OR PSEUDO-
C			  TELETYPE
C
C	     USAGE   (*)  COUNTER FOR LIBRARY PROGRAMS USAGE
C
C	     IO 	  INPUT/OUTPUT SUBROUTINE
C
C	     OPTION	  DETERMINE WHICH OPTONS TO USE
C
C	     GETID	  HEADER SUBROUTINE
C
C	     BNKNAM	  DETERMINE WHICH VARIABLES FROM THE DATA BANK
C			  TO BE USED
C
C	     VARLST	  OBTAIN VARIABLE NAMES OR NUMBERS FROM THE NON-
C			  DATA BANK INPUT
C
C	     GETFR1	  FORMAT SUBROUTINE
C
C	     GETMOD	  DETERMINE MODES OF VARIABLES FROM THE FORMAT
C
C	     GTCORE  (*)  TO ALLOCATE CORE DYNAMICALLY
C
C	     LSCORE  (*)  TO RETURN CORE DYNAMICALLY
C
C	     MAINL	  MAIN SUBROUTINE FOR THE PROGRAM
C
C	     INFO	  SUBROUTINE TO WRITE A HEADER PAGE FOR NON-TTY
C			  OUTPUT
C
C	     SELECT	  SUBROUTINE THAT ALLOWS PROGRAM TO CONSIDER
C			  ONLY THOSE OBSERVATIONS MEETING USER SPECIFIED
C			  CRITERIA
C
C	     LIST	  SUBROUTINE THAT ACCEPTS THE CROSS-TAB LIST
C
C	     EXIST   (*)  TO DETERMINE IF A FILE ALREADY EXISTS IN THE
C			  USER'S AREA
C
C	     COUNT	  SUBROUTINE THAT COUNTS  THE NUMBER OF
C			  OCCURENCES OF SYMBOLS
C
C	     OUT	  ONE OF THE OUTPUT SUBROUTINES
C
C	     GES     (*)  SUBROUTINE TO READ IN ONE LINE OF INFORMATION
C
C	     EDCODE	  SUBROUTINE THAT ENCODE A STRING
C
C	     SORT	  SORTS THE SYMBOLS IN ASCENDING ORDER
C
C	     LOOK	  ONE OF THE OUTPUT SUBROUTINES
C
C	     OUT1	  ONE OF THE OUTPUT SUBROUTINES
C
C	     TABLE	  OUTPUT THE CONTINGENCY TABLE, ETC
C
C	     CHIPRB	  CALCULATES THE PROBABILITY ASSOCIATED WITH
C	 		  THE CHI-SQUARE
C
C	     CONP	  USED IN CONJUNCTION WITH CHIPRB
C
C	     LAMBDA	  SUBROUTINE THAT CALCULATES THE LAMBDA STATISTICS
C
C	     THETA	  SUBROUTINE THAT CALCULATES THETA STATISTICS
C
C	     GAMTAU	  SUBROUTINE THAT CALCULATES GAMMA AND TAU A,B,C
C			  STATISTICS
C
C	     PAGE         OUTPUTS PAGE NUMBER AND HEADER
C
C	     CUNO	  USED IN CONJUNCTION WITH CHIPRB
C
C	       (*)  MACRO SUBROUTINE
C
C***********************************************************************
C
	DIMENSION SPACE(1),IDUM(125)
	COMMON/IOBLK/INP,IOUT,IDEVI,IDEVO,IBNK,NAMI,NAMO,IPROJ,IPROG
	COMMON /IOB/LFBR,IRTBR,IALT,MAXPAG,IPAGE,IPAGCT,IDLG,ICC,ICODE
     .	,NOUT
	COMMON/SBNK/NVBNK,NOBNK,NDBNK(2),NPBNK(2),ITEMP(5000)
	COMMON/SOPT/IOPT(15),MAXTAB,DEVTMP,DEVMOD,MAXSYM
	COMMON/SGETFR/ISTD,ITYPE
	COMMON/FMT/NOTF(80)	!MSL: EXPANDED FROM 48, 10-15-76
	COMMON/SID/ID(16),ISTOP
	COMMON /SINFO/CALNAM,PROG(12)
	INTEGER OFFSET
	DOUBLE PRECISION NAMI,NAMO
	EQUIVALENCE (ITEMP,IDUM)
	DATA CALNAM,PROG/'TAB','GENERALIZED   CROSS-TABULATION
     .   PROGRAM',4*' '/
C
C***********************************************************************
C	DEVICES USED :
C
C	     IDLG--DEVICE USED TO COMMUNICATE WITH USER
C		   IT IS ALWAYS SET TO -1
C
C	     ICC---DEVICE USED TO ACCEPT USER'S RESPONSE
C		   IT IS ALWAYS SET TO -4
C
C	     INP---DEVICE USED TO READ DATA
C		   ITS LOGICAL NUMBER IS DETERMINED BY IO SUBROUTINE
C
C	     IOUT--DEVICE TO WRITE OUT THE RESULT
C		   ITS LOGICAL NUMBER IS DETERMINED BY THE IO SUBROUTINE
C
C	AUXILIARY DEVICES USED IN SUBROUTINE MAINL TO WRITE TEMPORARY
C	FILES:
C
C	DEVTMP-- IS DEVICE WHERE TEMPORARY FILE ARE WRITTEN
C
C	DEVMOD-- IS MODE OF TEMPORARY STORAGE FILES
C
C
C	     IDSK--IT IS ALWAYS SET TO 20
C	     LDSK--IT IS ALWAYS SET TO 1
C	     IDV---IT IS ALWAYS SET TO 22
C***********************************************************************
C
	DEVMOD='DUMP'
	DEVTMP='DSKC'
	OFFSET=0
	IDLG=-1
	ICC=-4
	INP=2
	IOUT=3
	ITYPE=3
	MAXPAG=58
	IPAGCT=0
C
	WRITE(IDLG,9977)
9977	FORMAT('-*** W.M.U. CROSS-TABULATION PROGRAM ***'//)
C	CALL USAGE('TAB')
C
	CALL TTYPTY(ICODE)
	CALL IO(1,IOUT,DEVNAM,IDEVO,NAMO,IPROJ,IPROG,IBNK)
1	CALL IO(0,INP,DEVNAM,IDEVI,NAMI,IPROJ,IPROG,IBNK)
	IDEVO=NOUT
	IPAGE=0
	IF(IDEVO.EQ.'TTY') IPAGE=-999999
C
C
101	CALL OPTION
	DO 1010 I=1,16
1010	ID(I)=' '
	ISTOP=0
	IF (IOPT(2).EQ.1) CALL GETID
	GO TO (23,100),IBNK+1
C
C
C*******************************************************************
C	FOR DATA BANK ONLY
C
C	(1)  READ HEADER RECORD IN THE DATA BANK:
C
C	     NVBNK--NUMBER OF VARIABLES IN THE BANK
C	     NOBNK--NUMBER OF OBSERVATIONS IN THE BANK
C	     NDBNK--DATE THE BANK WAS CREATED
C	     NPBNK--PROJ-PROG NUMBER THAT CREATED THE BANK
C
C	(2)  DETERMINE WHICH VARIABLES FROM THE BANK TO BE USED IF
C	     THE NUMBER OF VARIABLES IN THE BANK EXCEED 600
C*********************************************************************
C
100	READ(INP#1) IDUM
	IF (IDUM(8).EQ.'V2') GO TO 11
	WRITE(IDLG,10)
10	FORMAT('-ERROR:  This BANK was created with an
     . experimental version of BANK.'/' Please update the BANK by
     . running "BANKUP" from area [220,220].'/' If you are not
     . responsible for the BANK, contact the owner and'/' ask him
     . to run the updating program.'/)
102	CALL EXIT
C
C
11	NVBNK=IDUM(1)
	NOBNK=IDUM(2)
	NDBNK(1)=IDUM(4)
	NDBNK(2)=IDUM(5)
	NPBNK(1)=IDUM(6)
	NPBNK(2)=IDUM(7)
	N=NVBNK
	IF (N.LE.600) GO TO 120
12	CALL BNKNAM(4,N)
120	NOTF(1)='DATA'
	NOTF(2)='BANK'
	NOTF(3)='FORMA'
	NOTF(4)='T'
	DO 13 I=5,80		!MSL: EXPANDED FROM 48, 10-15-76
13	NOTF(I)=' '
	GO TO 30
C
C**********************************************************************
C	NON-DATA BANK ONLY
C
C	(1)  ACCEPTS VARIABLE NAMES OR DETERMINE HOW MANY VARIABLES
C	     TO BE USED
C
C	(2)  DETERMINE WHICH FORMAT TO USE AND OBTAIN MODES OF THE
C	     VARIABLES
C**********************************************************************
C
23	CALL VARLST(N)
	IF (IOPT(1).NE.1) GO TO 24
	ISTD=0
	CALL GETFR1(IOPT(3),80,NOTF)	!MSL: EXPANDED FROM 48, 10-15-76
	IF(ISTD.EQ.1) GOTO 24
	CALL GETMOD(N,400,NOTF)		!MSL: EXPANDED FROM 240, 10-15-76
	GO TO 30
C
C
24	ISTD=1
	NOTF(1)='(80A1'
	NOTF(2)=')'
	DO 25 I=3,80		!MSL: EXPANDED FROM 48, 10-15-76
25	NOTF(I)=' '
	DO 28 I=4201,4200+N
28	ITEMP(I)=1
C
C***********************************************************************
C	EXPAND OPTION ELECTED
C***********************************************************************
C
30	IF (IOPT(4).EQ.1) GO TO 301
	MAXTAB=100
	GO TO 300
301	WRITE(IDLG,302)
302	FORMAT(' SPECIFY UPPER LIMIT FOR # OF CROSS-TABS--',$)
	READ(ICC,303) MAXTAB
303	FORMAT(I)
	IF (MAXTAB.GT.0) GO TO 300
	WRITE(IDLG,304) MAXTAB
304	FORMAT('-ERROR:  ',I3,' for upper limit is illegal, Try again'/)
	IF (ICODE) 102,301,301
C
C**********************************************************************
C
C	EXPAND SYMBOLS OPTION
C
300	MAXSYM=600
	IF(IOPT(15).NE.1) GOTO 305
	WRITE(IDLG,306)
306	FORMAT('-WARNING:  OPTION NOT AVAILABLE AT THIS TIME'/)
	IOPT(15)=0
C
C**********************************************************************
C	ALLOCATE CORE
C**********************************************************************
C
305	MAX=3*N+6*MAXTAB
C	IF(OFFSET.NE.0) CALL LSCORE(SPACE(1),OFFSET)
C	OFFSET=0
C	CALL GTCORE(MAX,SPACE(1),OFFSET,IERR,500)
	CALL ALLCOR(MAX,IERR,OFFSET,SPACE(1))
	IF(IERR) 331,32,331
331	WRITE(IDLG,31) N
31	FORMAT('-ERROR:  Number of variables', I6,' outside allowable
     1 range, Try again'/)
	IF (ICODE.LT.0) CALL EXIT
	GO TO (23,12), IBNK+1
C
C
32	I1=OFFSET
	I2=I1+N
	I3=I2+N
	I4=I3+N
	I5=I4+MAXTAB
	I6=I5+MAXTAB
	CALL MAINL(N,SPACE(I1),SPACE(I2),SPACE(I3),SPACE(I4),SPACE(I5),
     1 SPACE(I6))
C
C********************************************************************
C	END OF ONE DATA SET
C********************************************************************
C
40	WRITE(IDLG,41)
41	FORMAT('-')
	GO TO 1
	END
*
**************************************************************************
*
	SUBROUTINE MAINL(N,NAME,NUM,MODE,NSIZE,NWAY,ITAB)
C
C**********************************************************************
C	MAIN SUBROUTINE FOR THE PROGRAM
C
C	N------NUMBER OF VARIABLES
C	NAME---VECTOR CONTAINING VARIABLE NAMES
C	NUM----VECTOR CONTAINING VARIABLE NUMBERS
C	MODE---VECTOR CONTAINING VARIABLE MODES
C	NSIZE--VECTOR CONTAINING NUMBER OF SYMBOLS PER CROSS-TAB
C	ITAB---VECTOR CONTAINING VARIABLES TO BE CROSS-TABULATED
C**********************************************************************
C
	DIMENSION NAME(1),NUM(1),MODE(1),NSIZE(1),NWAY(1),ITAB(1),
     1 NNS(18,6),IDUM(125),DUM(125),IVALUE(20,20),IX(1250),X(1250),
     2 IS(4,600),S(4,600),ISYM(2400),SYM(2400),KOUNT(600),IDATA(125,4),
     3 DATA(125,4),ISEC(125),LL(4),NAM1(2),NAM2(2)
	DOUBLE PRECISION NFILE1,NFILE2,NAMI,NAMO
	COMMON/IOBLK/INP,IOUT,IDEVI,IDEVO,IBNK,NAMI,NAMO,IPROJ,IPROG
	COMMON /IOB/LFBR,IRTBR,IALT,MAXPAG,IPAGE,IPAGCT,IDLG,ICC,ICODE
	COMMON/SBNK/NVBNK,NOBNK,NDBNK(2),NPBNK(2),ITEMP(5000)
	COMMON/SOPT/IOPT(15),MAXTAB,DEVTMP,DEVMOD,MAXSYM
	COMMON/SGETFR/ISTD,ITYPE
	COMMON/FMT/NOTF(80)	!MSL: EXPANDED FROM 48, 10-15-76
	COMMON/SID/ID(16),ISTOP
	COMMON/SELEC/NSEC,NVAR(20),NCON(20),VALUE(20,20),NVAL(20),
     1 NOR(20)
	COMMON/SCOUNT/ISIZE,IACT,NMISS,L(4),NWAYI,KI,LENGTH
	COMMON/STABLE/NPT,NUSED,NAME1,NAME2,IOPT6,IALL,IDV,LMODE(4)
	EQUIVALENCE (ITEMP,IS,S,ISYM,SYM), (ITEMP(2401),KOUNT),
     1 (ITEMP(3001),IX,X), (ITEMP(4251),IDATA,DATA), (ITEMP(4751),ISEC),
     2 (IDUM,DUM,NNS), (VALUE, IVALUE), (MISS,AMISS), (NFILE1,NAM1),
     3 (NFILE2,NAM2)
	INTEGER T
C
C
	MISS="400000000000
	IDSK=20
	LDSK=1
	IDV=22
C
C**********************************************************************
C	WRITE OUT A HEADER PAGE FOR NON-TTY OUTPUT
C**********************************************************************
C
	IF (IDEVO.EQ.'TTY') GO TO 2
	CALL INFO(0)
	IPAGCT=IPAGCT+1
	DO 10 I=1,15
	IDUM(I)='NO'
	IF (IOPT(I).EQ.1) IDUM(I)='YES'
10	CONTINUE
	WRITE(IOUT,11) (IDUM(I),IDUM(I+6),I=1,5),IDUM(12),IDUM(6),
     1 IDUM(13),IDUM(14),IDUM(15)
11	FORMAT('-',29X,'OPTIONS AVAILABLE:  FORMAT',13('-'),A3,5X,'TOTAL
     1 %',10('-'),A3/50X,'HEADER',13('-'),A3,5X,'COLUMN %',9('-'),A3/
     2 50X,'SELECT',13('-'),A3,5X,'ROW %',12('-'),A3/50X,'EXPAND',
     3 13('-'),A3,5X,'PHI COEFFICIENT',2('-'),A3/50X,'EXPECTED VALUE',
     4 5('-'),A3,5X,'LAMBDA STAT',6('-'),A3/50X,'MISSING DATA INCLUDED',
     5 6X,'THETA STAT',7('-'),A3/52X,'IN CALCULATIONS--',A3,5X,
     6 'GAMMA STAT',7('-'),A3/50X,'TAU A,B&C',10('-'),A3,5X,
     .	'EXPAND SYMBOLS---',A3)
C
C
C**********************************************************************
C	OBTAIN VARIABLE NAMES, MODES AND NUMBERS FROM THE DATA BANK
C	     IF THE NUMBER OF VARIABLES DOES NOT EXCEED 600
C**********************************************************************
C
2	IF ((IBNK.NE.1).OR.(N.NE.NVBNK)) GO TO 200
	IZ=1+(NOBNK+124)/125*NVBNK
	NTIMES=(NVBNK+5)/6
	I1=6
	DO 202 I=1,NTIMES
	I2=(I-1)*6
	IZ=IZ+1
	READ(INP#IZ) IDUM
	IF (I.EQ.NTIMES) I1=NVBNK-I2
	DO 203 J=1,I1
	J1=I2+J
	NAME(J1)=NNS(1,J)
	MODE(J1)=NNS(10,J)
203	NUM(J1)=J1
202	CONTINUE
	GO TO 201
C
C********************************************************************
C	TRANSFER THE NAMES, NUMBERS AND MODES INTO THE PROPER VECTORS
C	     IF APPLICABLE
C**********************************************************************
C
200	DO 20 I=1,N
	NAME(I)=ITEMP(2600+I)
	NUM(I)=ITEMP(3400+I)
20	MODE(I)=ITEMP(4200+I)
C
C**********************************************************************
C	SELECT OPTION
C**********************************************************************
C
201	IF (IOPT(3).NE.1) NSEC=0
	IF (IOPT(3).EQ.1) CALL SELECT(N)
C
C***********************************************************************
C	OBTAIN CROSS TAB LIST
C***********************************************************************
C
	CALL LIST(N,NAME,NUM,ITAB,NWAY,IWAY)
C
C
	IOPT6=IOPT(6)+1
	IALL=1
	DO 22 I=11,14
	IF (IOPT(I).EQ.1) IALL=2
22	CONTINUE
C
C
230	DO 23 I=1,IWAY
23	NSIZE(I)=0
	GO TO (30,70), IBNK+1
C
C**********************************************************************
C	NON-DATA BANK ONLY
C**********************************************************************
C
30	T=0
	IF (IWAY.LE.1) GO TO 3020
	NAM1(1)='00001'
	NAM1(2)='.001'
	NAM2(1)=NAM1(1)
	NAM2(2)='.002'
3021	CALL EXIST(NFILE1,I)
	CALL EXIST(NFILE2,J)
	IF ((I.EQ.1).AND.(J.EQ.1)) GO TO 3020
	NAM1(1)=NAM1(1)+1
	NAM2(1)=NAM2(1)+1
	GO TO 3021
C
3020	NUSED=0
	NPT=1
	IFIRST=1
	LENGTH=N
	IF (IDEVI.EQ.'TTY') GO TO 3010
	WRITE(IDLG,3000)
3000	FORMAT(' Please wait, your data is being processed'/)
	GO TO 301
3010	WRITE(IDLG,3011)
3011	FORMAT(' ENTER DATA')
	IF (ISTD.EQ.1) WRITE(IDLG,3012)
3012	FORMAT(' Format assumed: (80A1)')
C
C
301	KI=1
300	I1=(KI-1)*N+1
	I2=KI*N
	IF (I2.GT.1250) GO TO 34
31	READ(INP,NOTF,ERR=48,END=33) (IX(II),II=I1,I2)
	T=T+1
	IF (NSEC.LE.0) GO TO 320
	IZ=1
	J=0
32	J=J+1
	IF (J.GT.NSEC) GO TO 3220
	JJ=NVAR(J)+I1-1
	J1=NCON(J)
	DO 3210 J2=1,NVAL(J)
	GO TO (321,322,323,324,325,326), J1
321	IF (IX(JJ).EQ.IVALUE(J2,J)) 3211,3212
322	IF (IX(JJ).GT.IVALUE(J2,J)) 3211,3212
323	IF (IX(JJ).GE.IVALUE(J2,J)) 3211,3212
324	IF (IX(JJ).LT.IVALUE(J2,J)) 3211,3212
325	IF (IX(JJ).LE.IVALUE(J2,J)) 3211,3212
326	IF (IX(JJ).EQ.IVALUE(J2,J)) GO TO 3212
C
C
3211	IZ=0
32110	IF (J.EQ.NSEC) GO TO 3220
	IF (NOR(J).NE.NOR(J+1)) GO TO 32
	J=J+1
	GO TO 32110
C
C
3212	IF (J2.NE.NVAL(J)) GO TO 3210
	IF (J.NE.NSEC) GO TO 3213
32120	IZ=1
	GO TO 31
3213	IF (NOR(J).NE.NOR(J+1)) 32120,32
3210	CONTINUE
3220	IF (IZ.NE.0) GO TO 31
320	KI=KI+1
	GO TO 300
C
C
33	NPT=2
	IF (KI.LE.1) GO TO 50
C
C
C
34	KI=KI-1
	NUSED=NUSED+KI
C
C
	IF (IWAY.LE.1) GO TO 340
	IF (IFIRST.EQ.1) GO TO 343
	NAM1(1)='00001'
	NAM1(2)='.001'
341	CALL EXIST(NFILE1,I)
	IF (I.EQ.1) GO TO 343
	NAM1(1)=NAM1(1)+1
	GO TO 341
343	OPEN(UNIT=IDSK,MODE=DEVMOD,ACCESS='SEQOUT',FILE=NFILE1,
     .	DEVICE=DEVTMP)
	IF (IFIRST.EQ.1) GO TO 340
342	OPEN(UNIT=LDSK,MODE=DEVMOD,ACCESS='SEQIN',FILE=NFILE2,
     .	DEVICE=DEVTMP)
340	IW=0
	DO 41 I=1,IWAY
	IACT=NSIZE(I)
	ISIZE=MIN0(IACT,MAXSYM)
	IF ((IFIRST.EQ.1).OR.(IWAY.EQ.1)) GO TO 440
C
C
410	I1=(ISIZE+124)/125
	K=0
	DO 42 J=1,I1
	READ(LDSK) IDUM
	DO 42 J1=1,125
	K=K+1
	IF (K.GT.ISIZE) GO TO 420
42	KOUNT(K)=IDUM(J1)
420	NSW=ISIZE*4
	I1=(NSW+124)/125
	K=0
	DO 43 J=1,I1
	READ(LDSK) IDUM
	DO 43 J1=1,125
	K=K+1
	IF (K.GT.NSW) GO TO 440
43	ISYM(K)=IDUM(J1)
C
C
440	NWAYI=NWAY(I)
	DO 44 J=1,NWAYI
	IW=IW+1
44	L(J)=ITAB(IW)
	CALL COUNT
	NSIZE(I)=IACT
	IF (IWAY.EQ.1) GO TO (301,50), NPT
C
C**********************************************************************
C	STORE COUNTS
C**********************************************************************
C
45	K=0
	DO 46 J=1,ISIZE
	K=K+1
	IF (K.GT.125) GO TO 460
	IDUM(K)=KOUNT(J)
	GO TO 46
C
C
C
460	WRITE(IDSK) IDUM
	IDUM(1)=KOUNT(J)
	K=1
46	CONTINUE
	IF (K.GT.0) WRITE(IDSK) IDUM
C
C**********************************************************************
C	STORE SYMBOLS
C**********************************************************************
C
	K=0
	I1=ISIZE*4
	DO 47 J=1,I1
	K=K+1
	IF (K.GT.125) GO TO 470
	IDUM(K)=ISYM(J)
	GO TO 47
470	WRITE(IDSK) IDUM
	IDUM(1)=ISYM(J)
	K=1
47	CONTINUE
	IF (K.GT.0) WRITE(IDSK) IDUM
41	CONTINUE
	IF (IFIRST.NE.1) CLOSE(UNIT=LDSK,DISPOSE='DELETE')
	CLOSE(UNIT=IDSK,DISPOSE='RENAME',FILE=NFILE2)
	NAM2(1)=NAM1(1)
	IFIRST=2
	GO TO (301,50), NPT
C
C
48	II=T+1
	WRITE(IDLG,480) II
480	FORMAT('-Warning:  Illegal character in observation:',I7/
     1 9X,'Program proceeds ignoring the observation'/)
	GO TO 31
C
C
C
50	IF (IDEVO.EQ.'TTY') WRITE(IOUT,5021) (ID(I),I=1,ISTOP)
	WRITE(IDLG,502) T,NUSED,IWAY
	IF(IDEVO.EQ.'TTY') GOTO 5031
	WRITE(IOUT,501) T,NUSED,IWAY
	CALL PAGE
501	FORMAT('-',29X,'Number of observation read in.', 6(' .'),I9/
     1 30X,'Number of observations used.', 7(' .'),I9/
     1 30X,'Number of cross-tabs requested',6(' .'),I9/)
5021	FORMAT(1H1,16A5)
502	FORMAT(' NUMBER OF OBSERVATIONS READ IN =',I9/' NUMBER OF
     1 OBSERVATIONS USED',4X,'=',I9/' NUMBER OF CROSS-TABS REQUESTED =',
     2 I9/)
C
C
5031	IF (NUSED.GT.0) GO TO 505
5030	WRITE(IDLG,503)
503	FORMAT('-ERROR:  No calculation done on 0 observations.'/)
	IF (ICODE.GE.0) GO TO (510,71),IBNK+1
	CALL EXIT
C
505	IF (IWAY.GT.1) OPEN(UNIT=LDSK,MODE=DEVMOD,ACCESS='SEQIN',
     1 FILE=NFILE2,DEVICE=DEVTMP)
	I1=0
	DO 51 I=1,IWAY
	IACT=NSIZE(I)
	ISIZE=MIN0(IACT,MAXSYM)
	NWAYI=NWAY(I)
	DO 52 J=1,NWAYI
	I1=I1+1
	L(J)=ITAB(I1)
	LL(J)=L(J)
52	LMODE(J)=MODE(L(J))
	IF (IWAY.EQ.1) GO TO 55
53	NTIMES=(ISIZE+124)/125
	J1=0
	DO 530 J=1,NTIMES
	READ(LDSK) IDUM
	DO 530 J2=1,125
	J1=J1+1
	IF (J1.GT.ISIZE) GO TO 54
530	KOUNT(J1)=IDUM(J2)
C
54	NSW=ISIZE*4
	NTIMES=(NSW+124)/125
	J1=0
	DO 540 J=1,NTIMES
	READ(LDSK) IDUM
	DO 540 J2=1,125
	J1=J1+1
	IF (J1.GT.NSW) GO TO 55
540	ISYM(J1)=IDUM(J2)
C
55	CALL OUT(NAME,LL)
51	CONTINUE
	IF (IWAY.GT.1) CLOSE(UNIT=LDSK,DISPOSE='DELETE')
510	RETURN
C
C***********************************************************************
C	DATA BANK ONLY
C***********************************************************************
C
70	WRITE(IDLG,3000)
	NT=(NOBNK+124)/125
	IW=0
	DO 71 I=1,IWAY
	NUSED=0
	ISIZE=0
	IACT=0
	NMISS=0
	NWAYI=NWAY(I)
	LENGTH=NWAYI
	DO 710 J=1,NWAYI
	L(J)=J
	IW=IW+1
	LL(J)=ITAB(IW)
710	LMODE(J)=MODE(ITAB(IW))
	LAST=125
	KK=0
	DO 72 J=1,NT
	J1=(J-1)*125
	J2=J+1
	IF (J.EQ.NT) LAST=NOBNK-J1
	IF (NSEC.GT.0) GO TO 74
	DO 73 K=1,LAST
73	ISEC(K)=0
	GO TO 76
C
C********************************************************************
C	SELECTS
C********************************************************************
C
74	DO 740 K=1,LAST
	ISEC(K)=1
	I3=0
	IZ1=1
741	I3=I3+1
	IF (I3.GT.NSEC) GO TO 740
	IZ=(NVAR(I3)-1)*NT+J2
	IF (IZ.EQ.IZ1) GO TO 742
	READ(INP#IZ) IDUM
	IZ1=IZ
742	I1=NCON(I3)
	DO 7420 I2=1,NVAL(I3)
	GO TO (7421,7422,7423,7424,7425,7426), I1
C
7421	IF (IDUM(K).EQ.IVALUE(I2,I3)) 7430,7440
7422	IF (IDUM(K).GT.IVALUE(I2,I3)) 7430,7440
7423	IF (IDUM(K).GE.IVALUE(I2,I3)) 7430,7440
7424	IF (IDUM(K).LT.IVALUE(I2,I3)) 7430,7440
7425	IF (IDUM(K).LE.IVALUE(I2,I3)) 7430,7440
7426	IF (IDUM(K).EQ.IVALUE(I2,I3)) GO TO 7440
C
7430	ISEC(K)=0
7431	IF (I3.EQ.NSEC) GO TO 740
	IF (NOR(I3).NE.NOR(I3+1)) GO TO 741
	I3=I3+1
	GO TO 7431
C
7440	IF (I2.NE.NVAL(I3)) GO TO 7420
	IF (I3.NE.NSEC) GO TO 7441
7442	ISEC(K)=1
	GO TO 740
7441	IF (NOR(I3).NE.NOR(I3+1)) 7442,741
C
7420	CONTINUE
740	CONTINUE
C
C
C
C
75	DO 750 K=1,LAST
	IF (ISEC(K).EQ.0) GO TO 76
750	CONTINUE
	GO TO 72
C
C
76	DO 760 K=1,NWAYI
	K1=(NUM(LL(K))-1)*NT+J2
760	READ(INP#K1) (IDATA(K2,K),K2=1,125)
	DO 77 K=1,LAST
	IF (ISEC(K).EQ.1) GO TO 77
	DO 770 K1=1,NWAYI
	KK=KK+1
770	IX(KK)=IDATA(K,K1)
77	CONTINUE
	KI=KK/NWAYI
	KK=0
	NUSED=NUSED+KI
	CALL COUNT
72	CONTINUE
	IF (KK.LE.0) GO TO 720
	KI=KK/NWAYI
	NUSED=NUSED+KI
	CALL COUNT
720	IF (I.NE.1) GO TO 721
	IF (IDEVO.EQ.'TTY') WRITE(IOUT,5021) (ID(K),K=1,ISTOP)
	WRITE(IDLG,502) NOBNK,NUSED,IWAY
	IF(IDEVO.EQ.'TTY') GOTO 7203
	WRITE(IOUT,501) NOBNK,NUSED,IWAY
	CALL PAGE
7203	IF (NUSED.LE.0) GO TO 5030
C
C
721	CALL OUT(NAME,LL)
C
C
71	CONTINUE
	RETURN
	END
*
**************************************************************************
*
	SUBROUTINE OPTION
C
C*******************************************************************
C	SUBROUTINE THAT DETERMINES WHICH OPTIONS ARE ELECTED
C*******************************************************************
C
	DIMENSION IDUM(72),KEY(15),ISAVE(4)
	COMMON/IOBLK/INP,IOUT,IDEVI,IDEVO,IBNK,NAMI,NAMO,IPROJ,IPROG
	COMMON /IOB/LFBR,IRTBR,IALT,MAXPAG,IPAGE,IPAGCT,IDLG,ICC,ICODE
	COMMON/SOPT/IOPT(15),MAXTAB,DEVTMP,DEVMOD,MAXSYM
C
C
C
	DATA KEY/'FORM','HEAD','SELE','EXPA','EXPE','MISS','TOTA',
     1 'COLU','ROW','PHI','LAMB','THET','GAMM','TAU','EXPS'/
	DATA IDOL/'$'/
C
C
1	WRITE(IDLG,100)
100	FORMAT(' OPTIONS?'/)
101	NPT=1
	CALL GES(IDUM,72,IRET)
	IF (IRET.EQ.2) CALL EXIT
	IF ((IDUM(1).EQ.'S').AND.(IDUM(2).EQ.'A').AND.(IDUM(3).EQ.'M')
     1.AND.(IDUM(4).EQ.'E')) RETURN
	DO 11 I=1,15
11	IOPT(I)=0
C
C
C
2	DO 20 I=1,4
20	ISAVE(I)=' '
	IS=0
	DO 21 I=1,72
	L=IDUM(I)
	IF (L.EQ.' ') GO TO 21
	IF ((L.EQ.',').OR.(L.EQ.IALT).OR.(L.EQ.IDOL)) GO TO 22
	IF (IS.GE.4) GO TO 21
	IS=IS+1
	ISAVE(IS)=L
	GO TO 21
C
C
C
22	K=' '
	ENCODE(4,224,K) ISAVE
224	FORMAT(4A1)
	IF (K.EQ.'HELP') GO TO 40
	IF (K.EQ.'NONE') RETURN
	IF ((K.EQ.'ALL').OR.(K.EQ.'*')) GO TO 30
	DO 23 J=1,15
	IF (K.EQ.KEY(J)) GO TO 25
23	CONTINUE
	WRITE(IDLG,24) K
24	FORMAT('-ERROR:  Option code "',A5,'" does not exist, Try again'
     1 /)
	IF (ICODE.GE.0) GO TO 1
240	CALL EXIT
C
C
C
25	IF ((IBNK.NE.1).OR.(J.NE.1)) IOPT(J)=1
	IF ((IBNK.EQ.1).AND.(J.EQ.1)) WRITE(IDLG,250)
250	FORMAT('-Warning:  Cannot use FORMAT with a data BANK'/9X,
     .	'Program will ignore this option'/)
	IF (NPT.EQ.2) RETURN
260	DO 26 J=1,4
26	ISAVE(J)=' '
	IS=0
21	CONTINUE
	NPT=2
	IF (IS.GT.0) GO TO 22
	RETURN
C
C
30	IST=1
	IF (IBNK.NE.1) GO TO 300
	IST=2
	WRITE(IDLG,250)
300	DO 31 I=IST,14
31	IOPT(I)=1
	RETURN
C
C
C
40	WRITE(IDLG,41)
41	FORMAT('-Options available are:'//' 	CODE	DESCRIPTION'/
     .	' 	----	-----------'/
     .	'	FORMat	Option to enter own format; default: (80a1)'/
     .	' 	HEADer	A line of at most 80 columns to be used as
     . header'/' 	SELEct	Option to consider only those
     . observations meeting'/' 		user specified criteria'/
     .	'	EXPAnd	User specified upper limit for
     . number of cross-tabs (initially  set to 100)'/' 
     .	EXPEct	Expected values for cells'/' 	MISS	To include
     . the missing data counts in all calculations'/' 
     .	TOTAl	Percentage of total for each cell'/' 
     .	ROW	Percentage of row total for each cell'/' 
     .	COLUmn	Percentage of column total for each cell'/' 
     .	GAMMa	Gamma statistics'/' 	LAMBda	Lambda statistics'/' 
     .	PHI	Phi coefficients'/' 	TAU	Tau A,B and C
     . statistics'/' 	THETa	Theta statistics'/' 
     .	ALL	All options listed above'/' 	NONE	None of the
     . options listed above'/' 	SAME	Maintain the same
     . options used in the preceeding run'///' Enter the
     . desired option codes in a line separated by commas.'//)
	IF (ICODE.GE.0) GO TO 1
	CALL EXIT
	END
*
**************************************************************************
*
	SUBROUTINE LIST(N,NAME,NUM,ITAB,NWAY,IWAY)
C
C*******************************************************************
C	SUBROUTINE THAT OBTAIN THE CROSS-TAB LIST
C
C	ARGUMENTS COMING FROM CALLING PROGRAM:
C	N------NUMBER OF VARIABLES
C	NAME---VECTOR CONTAINING VARIABLE NAMES
C	NUM----VECTOR CONTAINING VARIABLE NUMBERS
C
C	ARGUMENTS RETURNED TO THE CALLING PROGRAM:
C	ITAB---VECTOR CONTAINING VARIABLES TO BE CROSS-TABULATED
C	NWAY---VECTOR CONTAINING NUMBERS FROM 1 TO 4 TO INDICATE THE
C	       LEVEL OF CROSS-TAB TO BE PERFORMED
C	IWAY---NUMBER OF CROSS-TABS TO PERFORM
C**********************************************************************
C
	DIMENSION NAME(1),NUM(1),ITAB(1),NWAY(1),NPT(4),ISAVE(5),
     1 IDUM(72),ITB(900,4),LINE(72)
	COMMON/IOBLK/INP,IOUT,IDEVI,IDEVO,IBNK,NAMI,NAMO,IPROJ,IPROG
	COMMON /IOB/LFBR,IRTBR,IALT,MAXPAG,IPAGE,IPAGCT,IDLG,ICC,ICODE
	COMMON/SBNK/NVBNK,NOBNK,NDBNK(2),NPBNK(2),ITEMP(5000)
	COMMON/SOPT/IOPT(15),MAXTAB,DEVTMP,DEVMOD,MAXSYM
C
	DOUBLE PRECISION NAMI,NAMO
	EQUIVALENCE (ITEMP,ITB), (ITEMP(3601),LINE)
C
	DATA IDOL/'$'/
	IF (IDEVO.NE.'TTY') WRITE(IOUT,1004)
1004	FORMAT('-',29X,'CROSS-TAB LIST:')
C
C
1000	WRITE(IDLG,1001)
1001	FORMAT(' ENTER CROSS-TAB LIST'/)
	CALL GES(IDUM,72,IRET)
	IF (IRET.EQ.2) CALL EXIT
	IF ((IDUM(1).EQ.'H').AND.(IDUM(2).EQ.'E').AND.(IDUM(3).EQ.'L')
     1.AND.(IDUM(4).EQ.'P')) GO TO 90
	IF ((IDUM(1).EQ.'S').AND.(IDUM(2).EQ.'A').AND.(IDUM(3).EQ.'M')
     1.AND.(IDUM(4).EQ.'E')) GO TO 93
	DO 10010 I=1,MAXTAB
10010	NWAY(I)=0
	IWAY=0
	NTAB=0
C
C
1003	DO 10011 I=1,72
10011	LINE(I)=' '
	DO 1 IC= 72,1,-1
	IF (IDUM(IC).NE.' ') GO TO 1002
1	CONTINUE
	IF (IWAY.LE.0) GO TO 710
	RETURN
C
C
1002	IF ((IDUM(1).EQ.IALT).OR.(IDUM(1).EQ.IDOL)) GO TO 70
	IL=0
	I=0
100	IDASH=1
	LEVEL=1
	IST=I+1
	DO 101 I1=1,4
101	NPT(I1)=0
102	IS=0
	DO 103 I1=1,5
103	ISAVE(I1)=' '
C
C
10	I=I+1
	IF (I.LE.IC) GO TO 104
	IF (IS) 61,61,20
C
C
104	L=IDUM(I)
	IF (L.EQ.' ') GO TO 10
	IF ((L.EQ.'/').OR.(L.EQ.';').OR.(L.EQ.',').OR.(L.EQ.'-')
     1.OR.(L.EQ.IALT).OR.(L.EQ.IDOL)) GO TO 12
	IS=IS+1
	IF (IS.LE.5) ISAVE(IS)=L
	GO TO 10
CC
12	IF (IS.GT.0) GO TO 20
130	WRITE(IDLG,13) (IDUM(J),J=IST,IC)
13	FORMAT('-ERROR:  Program will ignore the following illegal
     1 CROSS-TAB string:'/9X,72A1)
132	IF (ICODE.LT.0) CALL EXIT
	IF ((IST.NE.1).AND.(IDEVO.NE.'TTY')) WRITE(IOUT,63) LINE
	WRITE(IDLG,133)
133	FORMAT(9X,'Re-enter the string'/)
	CALL GES(IDUM,72,IRET)
	GO TO 1003
C
131	K1=I+1
	IF (K1.GT.IC) GO TO 61
	DO 14 I1=K1,IC
	K=IDUM(I1)
	IF (K.EQ.';') GO TO 100
	IF ((K.EQ.IALT).OR.(K.EQ.IDOL)) GO TO 70
14	CONTINUE
	GO TO 61
C
C
20	CALL EDCODE(ISAVE,N,IRET,NEW)
	GO TO (30,41,321), IRET
C
30	IF ((NEW.EQ.'ALL').OR.(NEW.EQ.'*')) GO TO 33
	DO 32 J=1,N
	IF (NEW.EQ.NAME(J)) GO TO 40
32	CONTINUE
321	WRITE(IDLG,320) ISAVE, (IDUM(J),J=IST,IC)
320	FORMAT('-ERROR:  ',5A1,' does not exist, Program will ignore the
     1 CROSS-TAB string:'/9X,72A1)
	GO TO 132
C
C
C
C
33	J1=0
	NEW=NUM(N)
	GO TO 440
C
C
40	NEW=NUM(J)
41	IF (L.NE.'-') GO TO (42,43) IDASH
	IDASH=2
42	NPT(LEVEL)=NPT(LEVEL)+1
	ITB(NPT(LEVEL),LEVEL)=NEW
	GO TO 50
C
C
C
43	J1=ITB(NPT(LEVEL),LEVEL)
440	DO 44 JJ=J1+1,NEW
	NPT(LEVEL)=NPT(LEVEL)+1
44	ITB(NPT(LEVEL),LEVEL)=NUM(JJ)
	IDASH=1
C
C	GENERATE TAB LIST
C
50	IF ((L.EQ.',').OR.(L.EQ.'-')) GO TO 102
	IF (L.NE.'/') GO TO 500
	LEVEL=LEVEL+1
	IF (LEVEL-4) 102,102,130
C
500	MAX=1
	DO 51 J=1,LEVEL
51	MAX=NPT(J)*MAX
	IW=IWAY+MAX
	IF (IW.LE.MAXTAB) GO TO 53
	WRITE(IDLG,52) IW,MAXTAB,(IDUM(J),J=IST,IC)
52	FORMAT('-ERROR:  ',I4,' Number of CROSS-TABS outside allowable
     1 range'/9X,'Maximum is set at',I5,'.  Program will ignore the
     . string:'/9x,72A1)
	IF (ICODE.LT.0) CALL EXIT
	IF (IDEVO.NE.'TTY') WRITE(IOUT,63) LINE
	RETURN
C
C
53	DO 54 J=1,MAX
54	NWAY(J+IWAY)=LEVEL
	IWAY=IWAY+MAX
	NT=MAX/NPT(LEVEL)
	II=NTAB+LEVEL
	DO 55 I1=1,NT
	DO 55 J=1,NPT(LEVEL)
	ITAB(II)=ITB(J,LEVEL)
55	II=II+LEVEL
	NTIMES=1
	DO 56 I1=LEVEL-1,1,-1
	II=NTAB+I1
	NTIMES=NTIMES*NPT(I1+1)
	NT=MAX/(NTIMES*NPT(I1))
	DO 57 IJ=1,NT
	DO 57 J=1,NPT(I1)
	K1=ITB(J,I1)
	DO 58 K=1,NTIMES
	ITAB(II)=K1
58	II=II+LEVEL
57	CONTINUE
56	CONTINUE
	NTAB=NTAB+MAX*LEVEL
	DO 59 IJ=IST,I
	IL=IL+1
59	LINE(IL)=IDUM(IJ)
60	IF (I.LT.IC) GO TO 100
C
C
61	IF (IDEVO.NE.'TTY') WRITE(IOUT,63) LINE
63	FORMAT(35X,72A1)
	IF ((IDUM(IC).EQ.IALT).OR.(IDUM(IC).EQ.IDOL)) GO TO 70
	IF(IDUM(IC).NE.',') GOTO 70
62	CALL GES(IDUM,72,IRET)
	GO TO 1003
C
C
C
70	IF (IWAY.GT.0) RETURN
710	WRITE(IDLG,71)
71	FORMAT('-ERROR:  No CROSS-TAB contained in the list'/)
	IF (ICODE) 92,1000,1000
C
C
90	WRITE(IDLG,91)
91	FORMAT('-The CROSS-TAB list defines how variables are to be
     1 tabulated.  Either'/' variable NAMES (if assigned) or numbers
     2 may be used.  The list must'/' terminate with an altmode<ALT>
     .,dollar sign or a carriage return<CR>.  '/' More
     . than one line may be used to specify a list provided the last'/
     .	' character in the list is a comma.'//' Several
     . symbols are mandatory to be used with the list:'//
     .	'	SYMBOL	FUNCTION'/' 	-----	--------'/
     .	'	  ,	Separates  variables within a level'/
     .	'	  -	Separates ranges within a level'/
     .	'	  /	Separates levels within the CROSS-TAB'/
     .	'	  ;	Separates CROSS-TABS within the list'/
     .	'-Examples:'/' AGE/SEX;5-7/SEX<ALT>'/
     .	' 1/2/3/4;AGE/15,20/HT;IQ/AGE<CR>'//)
 	IF (ICODE.GE.0) GO TO 1000
92	CALL EXIT
C
C
93	IF (IDEVO.NE.'TTY') WRITE(IOUT,94)
94	FORMAT(35X,'SAME AS THE PRECEEDING RUN'/)
	RETURN
	END
*
**************************************************************************
*
	SUBROUTINE EDCODE(ISAVE,N,IRET,NEW)
C
C***********************************************************************
C	SUBROUTINE THAT ENCODE AND DECODE A STRING OF CHARACTERS
C
C	ARGUMENTS COMING FROM THE CALLING PROGRAM:
C	ISAVE--VECTOR CONTAINING THE STRING OF CHARACTERS
C	N------NUMBER OF VARIABLES
C
C	ARGUMENTS RETURNED TO CALLING PROGRAM:
C	IRET---=1  IF NEW CONTAINS A NAME
C	       =2  IF NEW CONTAINS A NUMBER
C	       =3  ERROR
C	NEW----CONTAIN THE NEWLY ENCODED WORD
C**********************************************************************
C
	DIMENSION ISAVE(5)
C
	IRET=1
	IF ((ISAVE(1).LT.'0').OR.(ISAVE(1).GT.'9')) GO TO 30
	IRET=2
22	IF (ISAVE(5).NE.' ') GO TO 222
	DO 220 J=4,1,-1
220	ISAVE(J+1)=ISAVE(J)
	ISAVE(1)=' '
	GO TO 22
222	J1=' '
	ENCODE(5,31,J1) ISAVE
	NEW=' '
	DECODE(5,223,J1) NEW
223	FORMAT(I5)
	IF ((NEW.LT.1).OR.(NEW.GT.N)) IRET=3
	RETURN
30	NEW=' '
	ENCODE(5,31,NEW) ISAVE
31	FORMAT(5A1)
	RETURN
	END
*
**************************************************************************
*
	SUBROUTINE LOOK(NS,NPT,IST,LAST)
C
C**********************************************************************
C	ONE OF THE OUTPUT SUBROUTINES.  IT DETERMINES THE NUMBER OF
C	SYMBOLS TO WRITE OUT BY GIVING THE STARTING AND ENDING POINTS.
C
C	ARGUMENTS COMING FROM CALLING PROGRAM:
C	NS-----TOTAL NUMBER OF SYMBOLS
C	NPT----LEVEL OF CROSS TAB
C
C	ARGUMENTS RETURNED TO CALLING PROGRAM:
C	IST----STARTING POINT TO CONSIDER IN VECTOR IS
C	LAST---ENDING POINT TO CONSIDER IN VECTOR IS
C**********************************************************************
C
	DIMENSION IS(4,600)
	COMMON/SBNK/NVBNK,NOBNK,NDBNK(2),NPBNK(2),ITEMP(5000)
	EQUIVALENCE (ITEMP,IS)
C
C
	IF (IST.LT.NS) GO TO 10
	LAST=IST
	RETURN
C
C
10	LOOKAT=IS(NPT,IST)
	DO 20 LAST=IST+1,NS
	IF (IS(NPT,LAST).NE.LOOKAT) GO TO 30
20	CONTINUE
30	LAST=LAST-1
	RETURN
	END
*
**************************************************************************
*
	SUBROUTINE COUNT
C
C***********************************************************************
C	SUBROUTINE THAT COUNTS THE NUMBER OF OCCURRENCES OF SYMBOLS
C
C	X------VECTOR CONTAINING THE DATA
C	IS-----VECTOR CONTAINING THE SYMBOLS
C	KOUNT--VECTOR CONTAINING THE COUNTS
C	ISIZE--NUMBER OF SYMBOLS
C	IACT---ACTUAL NUMBER OF SYMBOLS; COULD BE MORE THAN 600
C	NMISS--NUMBER OF MISSING DATA SYMBOLS ENCOUNTERED
C	L------VECTOR CONTAINING THE XTAB VARIABLES
C	NWAY---INDICATE WHETHER IT IS 2,3,OR 4 WAY XTAB
C	MANY---NUMBER OF RECORDS
C	LN-----LENGTH OF THE RECORDS
C********************************************************************
C
	DIMENSION IX(1250),X(1250),IS(4,600),S(4,600),KOUNT(600),
     1 LDATA(4)
	COMMON/IOBLK/INP,IOUT,IDEVI,IDEVO,IBNK,NAMI,NAMO,IPROJ,IPROG
	COMMON /IOB/LFBR,IRTBR,IALT,MAXPAG,IPAGE,IPAGCT,IDLG,ICC,ICODE
	COMMON /SOPT/IOPT(15),MAXTAB,DEVTMP,DEVMOD,MAXSYM
	COMMON/SBNK/NVBNK,NOBNK,NDBNK(2),NPBNK(2),ITEMP(5000)
	COMMON/SCOUNT/ISIZE,IACT,NMISS,L(4),NWAY,MANY,LN
	DOUBLE PRECISION NAMI,NAMO
	EQUIVALENCE (ITEMP,IS,S), (ITEMP(2401),KOUNT), (ITEMP(3001),
     1 IX,X), (MISS,AMISS)
C
C
	MISS="400000000000
	NIST=1
	IF (ISIZE.GT.0) GO TO 30
	NMISS=0
	ISIZE=1
	IACT=1
	DO 20 I=1,NWAY
	IS(I,1)=IX(L(I))
	IF (IX(L(I)).EQ.' ') IS(I,1)='BLANK'
20	CONTINUE
	KOUNT(1)=1
	IF (IS(1,1).EQ.MISS) NMISS=1
	IF (MANY.LE.1) RETURN
	NIST=2
C
C
C
30	DO 31 I=NIST,MANY
	LL=(I-1)*LN
	DO 32 J=1,NWAY
	LDATA(J)=IX(LL+L(J))
	IF (IX(LL+L(J)).EQ.' ') LDATA(J)='BLANK'
32	CONTINUE
	IF (LDATA(1).NE.MISS) GO TO 70
	IF (NMISS-1) 33,50,65
33	IACT=IACT+1
	IF (IACT.GT.MAXSYM) GO TO 31
	ISIZE=ISIZE+1
40	DO 41 J=ISIZE,2,-1
	KOUNT(J)=KOUNT(J-1)
	DO 41 K1=1,NWAY
41	IS(K1,J)=IS(K1,J-1)
	KOUNT(1)=1
	NMISS=1
	DO 42 K1=1,NWAY
42	IS(K1,1)=LDATA(K1)
	GO TO 31
C
C
C
C
50	DO 51 J=1,NWAY
	IF (IS(J,1).NE.LDATA(J)) GO TO 60
51	CONTINUE
	KOUNT(1)=KOUNT(1)+1
	GO TO 31
C
C
60	IACT=IACT+1
	IF (IACT.GT.MAXSYM) GO TO 31
	ISIZE=ISIZE+1
	NMISS=NMISS+1
	I1=1
	IF (LDATA(J).LT.IS(J,1)) GO TO 61
	I1=2
	IF (NMISS.LT.ISIZE) GO TO 61
	I1=ISIZE
	GO TO 63
61	DO 62 K1=ISIZE,1+I1,-1
	KOUNT(K1)=KOUNT(K1-1)
	DO 62 J1=1,NWAY
62	IS(J1,K1)=IS(J1,K1-1)
C
C
63	DO 64 J1=1,NWAY
64	IS(J1,I1)=LDATA(J1)
	KOUNT(I1)=1
	GO TO 31
C
C
65	IST=1
	CALL SORT(1,IST,LDATA)
	GO TO 31
C
C
C
70	IF (ISIZE.GT.1) GO TO 75
	I1=1
71	DO 710 J=1,NWAY
	IF (LDATA(J).NE.IS(J,I1)) GO TO 711
710	CONTINUE
	KOUNT(I1)=KOUNT(I1)+1
	GO TO 31
711	ISIZE=ISIZE+1
	IACT=IACT+1
	IF (LDATA(J).LT.IS(J,I1)) GO TO 73
	KOUNT(ISIZE)=1
	DO 72 K1=1,NWAY
72	IS(K1,ISIZE)=LDATA(K1)
	GO TO 31
C
C
73	KOUNT(ISIZE)=KOUNT(ISIZE-1)
	KOUNT(ISIZE-1)=1
	DO 74 K1=1,NWAY
	IS(K1,I1+1)=IS(K1,I1)
74	IS(K1,I1)=LDATA(K1)
	GO TO 31
C
C
C
75	IF (ISIZE.NE.NMISS) GO TO 76
	IACT=IACT+1
	IF (IACT.GT.MAXSYM) GO TO 31
	ISIZE=ISIZE+1
	I1=ISIZE
	GO TO 63
C
76	IST=NMISS+1
	I1=IST
	IF (ISIZE.EQ.IST) GO TO 71
	CALL SORT(0,IST,LDATA)
31	CONTINUE
	RETURN
	END
*
**************************************************************************
*
	SUBROUTINE SORT(MISS,IST,LDATA)
C
C**********************************************************************
C	SUBROUTINE THAT SORT THE SYMBOLS
C
C	MISS---=1  IF SORTING MISSING DATA
C	    ---=2  OTHERWISE
C	IST----STARTING POINT
C	LDATA--CONTAINING DATA TO BE SORTED
C********************************************************************
C
	DIMENSION IS(4,600),S(4,600),KOUNT(600),LDATA(4)
	COMMON/IOBLK/INP,IOUT,IDEVI,IDEVO,IBNK,NAMI,NAMO,IPROJ,IPROG
	COMMON /IOB/LFBR,IRTBR,IALT,MAXPAG,IPAGE,IPAGCT,IDLG,ICC,ICODE
	COMMON /SOPT/IOPT(15),MAXTAB,DEVTMP,DEVMOD,MAXSYM
	COMMON/SBNK/NVBNK,NOBNK,NDBNK(2),NPBNK(2),ITEMP(5000)
	COMMON/SCOUNT/ISIZE,IACT,NMISS,L(4),NWAY,MANY,LN
	DOUBLE PRECISION NAMI,NAMO
	EQUIVALENCE (ITEMP,IS,S), (ITEMP(2401),KOUNT)
C
C
	LAST=ISIZE
	IF (MISS.EQ.1) LAST=NMISS
	DO 10 J=1,NWAY
	IDATA=LDATA(J)
	IPOS=IST
	IF (IDATA.GT.IS(J,IST)) GO TO 20
	IF (IDATA.EQ.IS(J,IST)) GO TO 400
	KK=IST
C
C
11	IF (IACT.GE.MAXSYM) GO TO 60
110	DO 12 K1=ISIZE,KK,-1
	KOUNT(K1+1)=KOUNT(K1)
	DO 12 K3=1,NWAY
12	IS(K3,K1+1)=IS(K3,K1)
13	ISIZE=ISIZE+1
	IACT=IACT+1
	IF (MISS.EQ.1) NMISS=NMISS+1
	KOUNT(KK)=1
	DO 14 K1=1,NWAY
14	IS(K1,KK)=LDATA(K1)
	GO TO 70
C
C
C
20	IPOS=LAST
	IF (IDATA.LT.IS(J,LAST)) GO TO 30
	IF (IDATA.EQ.IS(J,LAST)) GO TO 400
	IF (IACT.GE.MAXSYM) GO TO 60
	KK=LAST+1
	IF (LAST-ISIZE) 110,13,110
C
C
C
30	MID=(IST+LAST)/2
	IF (IDATA.EQ.IS(J,MID)) GO TO 33
	IF (IDATA.LT.IS(J,MID)) LAST=MID
	IF (IDATA.GT.IS(J,MID)) IST=MID
	IF ((LAST-IST)-1) 32,31,30
31	KK=LAST
	GO TO 11
32	KK=LAST+1
	GO TO 11
C
C
C
33	IPOS=MID
C
400	IF (IPOS.EQ.IST) GO TO 42
	DO 41 K1=IPOS-1,IST,-1
	IF (IS(J,K1).EQ.IDATA) GO TO 41
	IST=K1+1
	GO TO 42
41	CONTINUE
C
C
42	IF (IPOS.EQ.LAST) GO TO 44
	DO 43 K1=IPOS+1,LAST
	IF (IS(J,K1).EQ.IDATA) GO TO 43
	LAST=K1-1
	GO TO 44
43	 CONTINUE
C
C
C
44	IF ((LAST-IST).LT.1) GO TO 50
10	CONTINUE
	GO TO 70
C
C
C
50	IF (J.EQ.NWAY) GO TO 56
	DO 54 K1=J+1,NWAY
	IF (LDATA(K1).EQ.IS(K1,IST)) GO TO 54
51	IF (IACT.GE.MAXSYM) GO TO 60
	K2=IST
	IF (LDATA(K1).GT.IS(K1,IST)) K2=IST+1
	DO 53 J1=ISIZE,K2,-1
	KOUNT(J1+1)=KOUNT(J1)
	DO 53 J2=1,NWAY
53	IS(J2,J1+1)=IS(J2,J1)
	DO 58 J1=1,NWAY
58	IS(J1,K2)=LDATA(J1)
	KOUNT(K2)=1
	IACT=IACT+1
	ISIZE=ISIZE+1
	IF (MISS.EQ.1) NMISS=NMISS+1
	GO TO 70
54	CONTINUE
C
C
C
55	KOUNT(IST)=KOUNT(IST)+1
	GO TO 70
C
C
56	IF (IDATA.EQ.IS(NWAY,IST)) GO TO 55
	CALL EXIT
C
C
C
C	ISIZE.GT.MAXSYM
C
60	ISIZE=MAXSYM
	IACT=MAXSYM+1
C
C
70	RETURN
	END
*
**************************************************************************
*
	SUBROUTINE OUT(NAME,L)
C
C*******************************************************************
C	ONE OF THE OUTPUT SUBROUTINES.   IT CALLS THE PROPER
C	SUBROUTINES AND WRITES OUT ONE TABLE AT A TIME.
C
C	NAME--VECTOR CONTAINING VARIABLE NAMES
C	L-----VECTOR CONTAINING VARIABLE NUMBERS
C*******************************************************************
C
	DIMENSION NAME(1),IS(4,600),S(4,600),L(4)
	COMMON/IOBLK/INP,IOUT,IDEVI,IDEVO,IBNK,NAMI,NAMO,IPROJ,IPROG
	COMMON /IOB/LFBR,IRTBR,IALT,MAXPAG,IPAGE,IPAGCT,IDLG,ICC,ICODE
	COMMON /SOPT/IOPT(15),MAXTAB,DEVTMP,DEVMOD,MAXSYM
	COMMON/SBNK/NVBNK,NOBNK,NDBNK(2),NPBNK(2),ITEMP(5000)
	COMMON/SCOUNT/NS,ISZ,NMISS,LL(4),NW,KI,LENGTH
	COMMON/STABLE/NPT,NUSED,NAME1,NAME2,IOPT6,IALL,IDV,LMODE(4)
C
	DOUBLE PRECISION NAMI,NAMO
	EQUIVALENCE (ITEMP,IS,S)
C
	DATA COMMA/','/
C
C
	IF(IPAGE.GT.5) CALL PAGE
	IPAGE=IPAGE+3
	WRITE(IOUT,10) NW, (NAME(L(J)),COMMA,J=1,NW-1),NAME(L(NW))
10	FORMAT(1H-,I1,'-WAY CROSS-TAB BETWEEN VARIABLES : ',4(A5,A1,1X))
	IF (ISZ.GT.MAXSYM) WRITE(IDLG,100) MAXSYM
100	FORMAT('-WARNING:  More than',I4,' sets of symbols encountered.
     1 No further symbols'/8X,'will be added to the table, but the
     2 counts for those symbols'/8X,'in the table will be accurate.')
20	IST=1
	LAST=NS
	IF (NW-3) 50,40,30
C
C	4-WAY
C
30	IF(IPAGE+4.GT.MAXPAG) CALL PAGE
	IPAGE=IPAGE+4
	WRITE(IOUT,300)
300	FORMAT('-*****************************************'/)
	CALL LOOK(NS,1,IST,LAST)
31	IST1=IST
32	CALL LOOK(LAST,2,IST1,LAST1)
	CALL OUT1(LMODE(1),NAME(L(1)),IST,1)
	CALL OUT1(LMODE(2),NAME(L(2)),IST1,2)
	NAME1=NAME(L(3))
	NAME2=NAME(L(4))
	NPT=3
	CALL TABLE(IST1,LAST1)
	IST1=LAST1+1
	IF (IST1.GT.LAST) GO TO 33
	IF(IPAGE+4.GT.MAXPAG) CALL PAGE
	IPAGE=IPAGE+4
	WRITE(IOUT,300)
	GO TO 32
33	IST=LAST+1
	IF (IST.LE.NS) 30, 60
C	3-WAY
C
40	IF(IPAGE+4.GT.MAXPAG) CALL PAGE
	IPAGE=IPAGE+4
	WRITE(IOUT,300)
	CALL LOOK(NS,1,IST,LAST)
	CALL OUT1(LMODE(1),NAME(L(1)),IST,1)
	NAME1=NAME(L(2))
	NAME2=NAME(L(3))
	NPT=2
	CALL TABLE(IST,LAST)
	IST=LAST+1
	IF (IST.LE.NS) 40,60
C
C	2-WAY
C
50	NAME1=NAME(L(1))
	NAME2=NAME(L(2))
	NPT=1
	CALL TABLE(IST,LAST)
C
C	OPTIONS
60	RETURN
	END
*
**************************************************************************
*
	SUBROUTINE OUT1(MODE,NAME,IST,NPT)
C
C*********************************************************************
C	ONE OF THE OUTPUT SUBROUTINES.  IT WRITES THE VARIABLE NAME
C	AND SYMBOL PER TABLE
C*********************************************************************
C
	DIMENSION IS(4,600), S(4,600)
	COMMON/IOBLK/INP,IOUT,IDEVI,IDEVO,IBNK,NAMI,NAMO,IPROJ,IPROG
	COMMON /IOB/LFBR,IRTBR,IALT,MAXPAG,IPAGE,IPAGCT,IDLG,ICC,ICODE
	COMMON/SBNK/NVBNK,NOBNK,NDBNK(2),NPBNK(2),ITEMP(5000)
	DOUBLE PRECISION NAMI,NAMO
	EQUIVALENCE (ITEMP,IS,S) , (MISS,AMISS)
C
	MISS="400000000000
	IF (IS(NPT,IST).NE.MISS) GO TO (20,30,40), MODE+1
	IF(IPAGE+1.GT.MAXPAG) CALL PAGE
	IPAGE=IPAGE+1
	WRITE(IOUT,10) NAME
10	FORMAT(6X,'VARIABLE: ',A5,' = MISSING')
	RETURN
C
C
20	IF(IPAGE+1.GT.MAXPAG) CALL PAGE
	IPAGE=IPAGE+1
	WRITE(IOUT,21) NAME, S(NPT,IST)
21	FORMAT(6X,'VARIABLE: ',A5, ' =', F12.3)
	RETURN
C
C
30	IF(IPAGE+1.GT.MAXPAG) CALL PAGE
	IPAGE=IPAGE+1
	WRITE(IOUT,31) NAME, IS(NPT,IST)
31	FORMAT(6X,'VARIABLE: ',A5,' = ',A5)
	RETURN
C
C
40	IF(IPAGE+1.GT.MAXPAG) CALL PAGE
	IPAGE=IPAGE+1
	WRITE(IOUT,41) NAME, IS(NPT,IST)
41	FORMAT(6X,'VARIABLE: ',A5, ' =',I12)
	RETURN
	END
*
**************************************************************************
*
	SUBROUTINE TABLE(IST,LAST)
C
C**********************************************************************
C	SUBROUTINE THAT WRITES OUT THE CONTINGENCY TABLE; CALCULATES
C	CHI-SQUARE AND THE PROBABILITY ASSOCIATED WITH IT IF APPLICABLE;
C	AND CALL THE PROPER SUBROUTINES FOR ANY STATISTICAL TESTS
C	IF ELECTED.
C
C	IST---STARTING POINT TO CONSIDER IN VECTOR IS
C	LAST--ENDING POINT TO CONSIDER IN VECTOR IS
C*********************************************************************
C
	DIMENSION IS(4,600),KOUNT(600),IVER(600),VER(600),IHOR(600),
     1 HOR(600),ISUMC(600),ISUMR(600),PER(15),LINE(15),OFMT(7),
     2 OFR(7),OFC(7),OFT(7),OFS(8),OFF1(10),OFF2(10),OFAI(9),OFE(6),
     3 EXP(15),L(3,3),IDUM(2000),OFF(5),NAM3(2)
C
C
	DOUBLE PRECISION NFILE3
	COMMON/IOBLK/INP,IOUT,IDEVI,IDEVO,IBNK,NAMI,NAMO,IPROJ,IPROG
	COMMON /IOB/LFBR,IRTBR,IALT,MAXPAG,IPAGE,IPAGCT,IDLG,ICC,ICODE
	COMMON/SBNK/NVBNK,NOBNK,NDBNK(2),NPBNK(2),ITEMP(5000)
	COMMON/SOPT/IOPT(15),MAXTAB,DEVTMP,DEVMOD,MAXSYM
	COMMON/STABLE/NPT,NUSED,NAME1,NAME2,IOPT6,IALL,IDV,LMODE(4)
	COMMON/STAT/ITOT,IV,IH,IKV,IKH
C
C
	DOUBLE PRECISION NAMI,NAMO
	EQUIVALENCE (ITEMP,IS), (ITEMP(2401),KOUNT), (ITEMP(3001),
     1 IVER,VER,IDUM), (ITEMP(3601),IHOR,HOR), (ITEMP(4201),ISUMC),
     2 (ITEMP(4801),PER), (ITEMP(4816),LINE), (ITEMP(4831),EXP),
     3 (ITEMP(4846),L),(OFAI,OFF),(MISS,AMISS),(NFILE3,NAM3)
C
C
	DATA (OFMT(I),I=2,3),(OFMT(J),J=5,7)/'1H./' , '1X,' , ',1H.,' ,
     1 '15(I7' , ',1X))'/
	DATA OFF1(7),OFF2(5),OFF2(7)/ ',3X)' , '(3X,' , ')' /
	DATA (OFR(I),I=2,3),(OFR(J),J=5,7)/'7H RO' , 'W %.,' , '15(F7' ,
     1 '.2,1H' , '%))'/
	DATA (OFC(I),I=2,3),(OFC(J),J=5,7)/'7H CO' , 'L %.,' , '15(F7' ,
     1 '.2,1H' , '%))'/
	DATA (OFT(I),I=2,3),(OFT(J),J=5,7)/'7H TO' , 'T %.,' , '15(F7' ,
     1 '.2,1H' , '%))'/
	DATA OFS(2),(OFS(I),I=4,5),(OFS(J),J=7,8)/ '1H./' , '6HTOT' ,
     1  'AL.,' , '15(I7' , ',1X))'/
	DATA OFE(2),OFE(3),OFE(5),OFE(6)/ '7H EX' , 'PCT.,' , '15F8' ,
     1 '.1)'/
	DATA BLANK,DOTS/' ','.'/
C
C
C
	MISS="400000000000
	FNS=100./NUSED
	IF (IALL.NE.2) GO TO 10
	NAM3(1)='00001'
	NAM3(2)='.003'
100	CALL EXIST(NFILE3,I)
	IF (I.EQ.1) GO TO 101
	NAM3(1)=NAM3(1)+1
	GO TO 100
101	OPEN(UNIT=IDV,FILE=NFILE3,MODE=DEVMOD,ACCESS='SEQOUT',
     .	DEVICE=DEVTMP)
C
C
C
10	DO 11 I=1,600
	ISUMC(I)=0
11	ISUMR(I)=0
C
C	HORIZONTAL SYMBOLS
C
C	     NOMISH--1  NO HORIZONTAL MISSING SYMBOL
C	           --2  OTHERWISE
C
12	NOMISH=1
	IH=1
	N2=NPT+1
	I1=IST
	IHOR(1)=IS(N2,IST)
	IF (IHOR(1).EQ.MISS) GO TO 13
	IF ((IS(NPT,IST).NE.MISS).OR.(IOPT6.NE.1)) ISUMC(1)=KOUNT(I1)
	GO TO 14
C
13	NOMISH=2
131	IF (IOPT6.EQ.2) ISUMC(1)=ISUMC(1)+KOUNT(I1)
C
14	I1=I1+1
	IF (I1.GT.LAST) GO TO 20
C
C
	IF (IS(N2,I1).NE.MISS) GO TO 17
	IF (IHOR(1).EQ.MISS) GO TO 131
	NBR=0
	NOMISH=2
C
15	IH=2
	IHOR(2)=IHOR(1)
	ISUMC(2)=ISUMC(1)
	IHOR(1)=IS(N2,I1)
	ISUMC(1)=0
	IF ((IOPT6.EQ.2).OR.(NBR.EQ.1)) ISUMC(1)=KOUNT(I1)
16	I1=I1+1
	IF (I1-LAST) 19,19,20
C
C
17	IF (IHOR(1).NE.MISS) GO TO 18
170	IH=2
	IHOR(2)=IS(N2,I1)
	IF ((IS(NPT,I1).NE.MISS).OR.(IOPT6.NE.1)) ISUMC(2)=KOUNT(I1)
	GO TO 16
C
C
18	IF (IS(N2,I1).GT.IHOR(1)) GO TO 170
	NBR=1
	IF (IS(N2,I1).LT.IHOR(1)) GO TO 15
	IF ((IS(NPT,I1).NE.MISS).OR.(IOPT6.NE.1)) ISUMC(IH)=ISUMC(IH)+
     1 KOUNT(I1)
	GO TO 16
C
C
19	DO 190 J=I1,LAST
	IF (IS(N2,J).NE.MISS) GO TO 1920
	IF (IHOR(1).NE.MISS) GO TO 1910
	IF (IOPT6.EQ.2) ISUMC(1)=ISUMC(1)+KOUNT(J)
	GO TO 190
C
1910	NOMISH=2
	IH=IH+1
	DO 1911 K=IH,2,-1
	IHOR(K)=IHOR(K-1)
1911	ISUMC(K)=ISUMC(K-1)
	IHOR(1)=IS(N2,J)
	ISUMC(1)=0
	IF (IOPT6.EQ.2) ISUMC(1)=KOUNT(J)
	GO TO 190
C
1920	NBR=1
	IF (IHOR(1).EQ.MISS) NBR=2
	DO 1921 K=NBR,IH
	IF (IS(N2,J).NE.IHOR(K)) GO TO 1922
	IF ((IS(NPT,J).NE.MISS).OR.(IOPT6.NE.1)) ISUMC(K)=ISUMC(K)+
     1 KOUNT(J)
	GO TO 190
C
1922	IF (IS(N2,J).GT.IHOR(K)) GO TO 1921
	IH=IH+1
	DO 1923 K1=IH,K+1,-1
	IHOR(K1)=IHOR(K1-1)
1923	ISUMC(K1)=ISUMC(K1-1)
	IF ((IS(NPT,J).NE.MISS).OR.(IOPT6.NE.1)) ISUMC(K)=KOUNT(J)
	IHOR(K)=IS(N2,J)
	GO TO 190
C
1921	CONTINUE
	IH=IH+1
	IHOR(IH)=IS(N2,J)
	IF ((IS(NPT,J).NE.MISS).OR.(IOPT6.NE.1)) ISUMC(IH)=KOUNT(J)
190	CONTINUE
C
C
C	VERTICAL SYMBOLS
C
C	     NOMISV--1  NO VERTICAL MISSING SYMBOL
C		   --2  OTHERWISE
C
20	NOMISV=1
	IDSFLG=NOMISH
	IV=1
	IVER(1)=IS(NPT,IST)
	IF (IVER(1).EQ.MISS) GO TO 21
	IF ((IS(N2,IST).NE.MISS).OR.(IOPT6.NE.1)) ISUMR(1)=KOUNT(IST)
	GO TO 22
C
21	NOMISV=2
	IF (IOPT6.EQ.2) ISUMR(1)=KOUNT(IST)
C
22	IF (IST.EQ.LAST) GO TO 28
	DO 23 I=IST+1,LAST
	IF (IS(NPT,I).NE.MISS) GO TO 26
	IF (IVER(1).NE.MISS) GO TO 24
	IF (IOPT6.EQ.2) ISUMR(1)=ISUMR(1)+KOUNT(I)
	GO TO 23
C
24	IV=IV+1
	DO 25 K=IV,2,-1
	IVER(K)=IVER(K-1)
25	ISUMR(K)=ISUMR(K-1)
	IVER(1)=IS(NPT,I)
	ISUMR(1)=0
	IF (IOPT6.EQ.2) ISUMR(1)=KOUNT(I)
	GO TO 23
C
26	IF (IS(NPT,I).EQ.IVER(IV)) GO TO 27
	IV=IV+1
	IVER(IV)=IS(NPT,I)
27	IF ((IS(N2,I).NE.MISS).OR.(IOPT6.NE.1)) ISUMR(IV)=ISUMR(IV)+
     1KOUNT(I)
23	CONTINUE
C
C	OBTAIN MARGINAL TOTAL ITOT
C	FIND DEGREES OF FREEDOM
C
28	ITOT=0
	CHI=0
	IDF=0
	IKV=1
	IKH=1
	IF (IOPT6.EQ.2) GO TO 281
	IF (NOMISV.EQ.2) IKV=2
	IF (NOMISH.EQ.2) IKH=2
281	MAXR=0
	K=0
	K1=0
	DO 280 I=IKV,IV
	IF (ISUMR(I).GT.MAXR) MAXR=ISUMR(I)
	IF (ISUMR(I).NE.0) K=K+1
280	ITOT=ITOT+ISUMR(I)
	IF ((IV.EQ.1).OR.(IH.EQ.1)) GO TO 30
	DO 282 I=IKH,IH
	IF (ISUMC(I).NE.0) K1=K1+1
282	CONTINUE
300	IDF=(K-1)*(K1-1)
C
C	ADJUST PART OF FORMAT
C
C	LM--1  IF LMODE(NPT)=0  OR  LMODE(NPT)=2 AND IVER(IV) > 99999
C
30	IF (LMODE(NPT)-1) 31,34,32
C
C	FLOAT
C
31	OFMT(4)='F13.3'
310	OFMT(1)='(14X,'
	OFS(1)='(14X,'
	LM=1
	LENGTH=14
	IF (IDEVO.EQ.'TTY') LENGTH=7
	OFR(1)='(8X,'
	OFC(1)='(8X,'
	OFT(1)='(8X,'
	OFS(3)='9X,'
	OFE(1)='(8X,'
	OFF1(1)='(17X,'
	OFF2(1)='(6X,'
	OFAI(1)='(14X,'
	IF(IPAGE+3.GT.MAXPAG) CALL PAGE
	IPAGE=IPAGE+5
	WRITE(IOUT,311) NAME2,NAME1
311	FORMAT('-',5X,'VAR:',17X,'VAR: ',A5/6X,A5)
	GO TO 35
C
C	FIXED
C
32	IF (IVER(IV).LE.99999) GO TO 320
	OFMT(4)='I13'
	OFAI(1)='(14X,'
	GO TO 310
C
320	OFMT(4)='I5'
	GO TO 340
C
C	ALPHA
C
34	OFMT(4)='A5'
340	LM=2
	OFMT(1)='(6X,'
	OFS(1)='(6X,'
	OFAI(1)='(6X,'
	LENGTH=15
	IF (IDEVO.EQ.'TTY') LENGTH=8
	OFR(1)='('
	OFC(1)='('
	OFT(1)='('
	OFS(3)='1X,'
	OFE(1)='('
	OFF1(1)='(1X,'
	OFF2(1)='(6X,'
	IF(IPAGE+13.GT.MAXPAG) CALL PAGE
	IPAGE=IPAGE+4
	WRITE(IOUT,341) NAME2,NAME1
341	FORMAT('-VAR:',17X,'VAR: ',A5/1X,A5)
C	WRITE HORIZONTAL SYMBOLS
C
35	NTIMES=IH/LENGTH+1
	K1=0
	INC=0
	DO 40 I=1,NTIMES
	I1=(I-1)*LENGTH+1
	I2=I*LENGTH
	IF (I2.GT.IH) I2=IH
	MUCH=I2-I1+1
	OFR(4)=' '
	OFC(4)=' '
	OFT(4)=' '
	OFS(6)=' '
	OFE(4)=' '
	DO 4010 J=2,9
4010	OFAI(J)=' '
	DO 4011 J=2,4
	OFF1(J)=' '
4011	OFF2(J)=' '
	OFF1(5)=' '
	OFF1(6)=' '
	OFF2(6)=' '
	DO 4012 J=8,10
	OFF1(J)=' '
4012	OFF2(J)=' '
	IF (I.EQ.NTIMES) INC=1
C
C	NOMIS--0  NO MISSING
C	      --1  OTHERWISE
C
C	IP--1  START FROM THE FIRST SYMBOL
C	  --2  START FROM THE SECOND SYMBOL
C
	NOMIS=0
	IP=1
	IF (I.GT.1) GO TO 42
C
C	INC--0  NO TOTAL
C	   --1  OTHERWISE
C
	IF ((MUCH.GT.1).OR.(NOMISH.EQ.1)) GO TO 410
	IFLAG=1
	GO TO 70
C
C
C
410	IF (NOMISH.EQ.1) GO TO 42
	NOMIS=1
	OFAI(2)='7HMIS'
	OFAI(3)='SING,'
	GO TO (411,413),LM
411	OFF2(1)='(15X,'
	OFF2(2)='7HMIS'
	OFF2(3)='SING,'
	GO TO 414
413	OFF1(1)='(7X,'
	OFF1(2)='7HMIS'
	OFF1(3)='SING,'
	OFF1(4)='3X,'
414	IF (IOPT6.EQ.1) IP=2
	GO TO (415,42), IOPT6
415	OFR(4)='8X,'
	OFC(4)='8X,'
	OFT(4)='8X,'
	OFS(6)='8X,'
	OFE(4)='8X,'
C
C
C
42	IF (MUCH-1) 4204,421,420
4204	F=100./ITOT
	IF(IPAGE+6.GT.MAXPAG) CALL PAGE
	WRITE(IOUT,7700)
7700	FORMAT('-',16X,'TOTAL'/14X,8('.'))
	IPAGE=IPAGE+4
	GO TO (4201,4202), NOMISV
C
C	FIRST LINE IS NOT MISSING
C
4201	DO 7100 J=IP,IV
	IF(IPAGE+2.LT.MAXPAG) GOTO 7701
	CALL PAGE
	WRITE(IOUT,7700)
	IPAGE=IPAGE+4
7701	IPAGE=IPAGE+2
	IF(LMODE(NPT)-1) 7101,7102,7103
C
C	FLOAT
C
7101	WRITE(IOUT,7702) IVER(J),ISUMR(J)
7702	FORMAT(14X,'.'/1X,F13.3,'.',I7)
	GOTO 7104
C
C	ALPHA
C
7102	WRITE(IOUT,7703) IVER(J),ISUMR(J)
7703	FORMAT(14X,'.'/9X,A5,'.',I7)
	GOTO 7104
C
C	FIXED
C
7103	WRITE(IOUT,7704) IVER(J),ISUMR(J)
7704	FORMAT(14X,'.'/1X,I13,'.',I7)
7104	IF(IOPT(7).NE.1) GOTO 7100
	PER(1)=ISUMR(J)*F
	IF(IPAGE.LT.MAXPAG) GOTO 7705
	CALL PAGE
	WRITE(IOUT,7700)
	IPAGE=IPAGE+4
7705	IPAGE=IPAGE+1
	WRITE(IOUT,7706) PER(1)
7706	FORMAT(9X,'TOT %.',F6.2,'%')
7100	CONTINUE
	IF(IPAGE+2.LT.MAXPAG) GOTO 7106
	CALL PAGE
	WRITE(IOUT,7700)
	IPAGE=IPAGE+4
7106	IPAGE=IPAGE+2
	WRITE(IOUT,7707) ITOT
7707	FORMAT(14X,'.'/9X,'TOTAL.',I7)
	GOTO 40
C
C	FIRST SYMBOL IS MISSING SYMBOL
C
4202	IF (IP.EQ.2) GO TO 4201
	IP=2
	IF(IPAGE+2.LT.MAXPAG) GOTO 7108
	CALL PAGE
	WRITE(IOUT,7700)
	IPAGE=IPAGE+4
7108	IPAGE=IPAGE+2
	IF(IOPT6.NE.1) GOTO 7107
	WRITE(IOUT,7710)
7710	FORMAT(14X,'.'/6X,'MISSING .')
	GOTO 4201
C
C	MISSING INFO INCLUDED
C
7107	IF(IPAGE+2.LT.MAXPAG) GOTO 7109
	CALL PAGE
	WRITE(IOUT,7700)
	IPAGE=IPAGE+4
7109	IPAGE=IPAGE+1
	WRITE(IOUT,7709) ISUMR(1)
7709	FORMAT(14X,'.'/6X,'MISSING .',I7)
	IF(IOPT(7).NE.1) GOTO 4201
	PER(1)=ISUMR(1)*F
	IF(IPAGE.LT.MAXPAG) GOTO 7110
	CALL PAGE
	WRITE(IOUT,7700) 
	IPAGE=IPAGE+4
7110	IPAGE=IPAGE+1
	WRITE(IOUT,7706) PER(1)
	GOTO 4201
C
C
C
C
C
421	IF ((LMODE(N2).EQ.1).OR.((LMODE(N2).EQ.2).AND.(IHOR(I2).LT.
     1 9999999))) GO TO 420
	OFF(1)='(9X,'
	IF (LM.EQ.2) OFF(1)='(1X,'
	OFF(2)='F13.3'
	IF (LMODE(N2).EQ.2) OFF(2)='I13'
	OFF(3)=',3X,5'
	OFF(4)='HTOTA'
	OFF(5)='L)'
	IFLAG=2
	GOTO 70
C
C
C
420	OFF1(8)=')'
	OFF2(8)=')'
	IF (I.EQ.NTIMES) GO TO 60
	OFAI(7)=')'
	GO TO (50,43,46), LMODE(N2)+1
C
C	ALPHA
C
43	OFAI(5)='(A3,A'
	OFAI(6)='5)'
44	I11=I1+NOMIS
	MUC=I2-I11+1
	ENCODE(2,440,OFAI(4)) MUC
440	FORMAT(I2)
	IFLAG=3
	GOTO 70
C
C	FIXED
C
46	IF (IHOR(I2).GT.9999999) GO TO 461
460	OFAI(5)='(A1,I'
	OFAI(6)='7)'
	GO TO 44
C
C
461	OFF1(6)='I13'
	OFF2(6)='I13'
	I11=I1
	GO TO (47,49), LM
C
47	IUP=MUCH/2
	IDOWN=(MUCH+1)/2
	M=IUP
	MM=IDOWN-NOMIS
C
C
470	ENCODE(3,471,OFF1(5)) M
471	FORMAT(I2,'(')
	ENCODE(2,440,OFF2(4)) MM
	IF (INC.EQ.0) GO TO (48,480), LM
	IF (((IUP.EQ.IDOWN).AND.(LM.EQ.2)).OR.((IUP.NE.IDOWN).AND.
     1(LM.EQ.1))) GO TO 472
C
	OFF2(8)=',11X,'
	OFF2(9)='5HTOT'
	OFF2(10)='AL)'
	GO TO (48,480), LM
472	OFF1(8)=',8X,5'
	OFF1(9)='HTOTA'
	OFF1(10)='L)'
	GO TO (48,480), LM
C
48	IFLAG=4
	IF(IDSFLG.NE.2) OFF2(1)='(6X,'
	IDSFLG=0
	GOTO 70
C
C
480	IFLAG=5
	GO TO 70
C
C
49	IUP=(MUCH+1)/2
	IDOWN=MUCH/2
	M=IUP-NOMIS
	MM=IDOWN
	GO TO 470
C
C	FLOAT
C
50	OFF1(6)='F13.3'
	OFF2(6)='F13.3'
	I11=I1
	IF (NOMIS.EQ.1) I11=I1+2
	GO TO (47,49), LM
C
C
60	IF (MUCH.LE.0) GO TO 4204
	IF (LMODE(N2)-1) 50,61,62
C
C	ALPHA
C
61	OFAI(7)=',3X,5'
	OFAI(8)='HTOTA'
	OFAI(9)='L)'
	GO TO 43
C
62	IF (IHOR(I2).GT.9999999) GO TO 461
	OFAI(7)=',3X,5'
	OFAI(8)='HTOTA'
	OFAI(9)='L)'
	GO TO 460
C
C	WRITE OUT COUNTS AND %'S
C
70	CALL TABHOZ(IFLAG,LM,MUCH,INC,I1,I11,I2,BLANK,IHOR,OFF,
     .	OFF1,OFF2,OFAI,DOTS)
	M1=IST
	M=MUCH+INC
	J3=I1-1
	DO 71 K=1,IV
	NEED=0
	DO 720 J=1,MUCH
720	LINE(J)=0
	IF (ITOT.EQ.0) GO TO 721
	TCHI=FLOAT(ISUMR(K))/ITOT
	DO 72 J=IP,MUCH
72	EXP(J)=TCHI*ISUMC(J3+J)
C
721	IF (M1.LT.LAST) GO TO 740
	J=M1
	GO TO 75
740	DO 74 J=M1,LAST-1
	IF (IS(NPT,J+1).NE.IS(NPT,M1)) GO TO 75
74	CONTINUE
	J=LAST
75	DO 750 JJ=M1,J
	DO 751 KK=1,MUCH
	IF (IS(N2,JJ).NE.IHOR(J3+KK)) GO TO 751
	NEED=1
	LINE(KK)=KOUNT(JJ)
	GO TO 750
751	CONTINUE
750	CONTINUE
	M1=J+1
	IF (NEED.NE.0) GO TO 7500
	IF ((I.NE.NTIMES).AND.(IOPT(5).NE.1)) GO TO 79
	IF (I.NE.NTIMES) GO TO 7500
C
	LINE(M)=ISUMR(K)
	IF ((NOMISV.EQ.1).OR.(K.GT.1)) GO TO 7520
	IF (IOPT6.EQ.2) GO TO 7501
	DO 7502 J=1,MUCH
	IF (LINE(J).NE.0) GO TO 7501
7502	CONTINUE
	GO TO 71
C
7500	IF (INC.EQ.1) LINE(M)=ISUMR(K)
	IF(K.NE.1) GOTO 7520
	IF(NOMISV.NE.2) GOTO 7520
7501	MMU=M
	IF (IOPT6.EQ.1) MMU=MUCH
	IPAGE=IPAGE+2
	IF (LM.EQ.1) WRITE(IOUT,7511) (LINE(J),J=1,MMU)
7511	FORMAT(14X,'.'/6X,'MISSING .',14(I7,1X))
	IF (LM.EQ.2) WRITE(IOUT,7513) (LINE(J),J=1,MMU)
7513	FORMAT(6X,'.'/' MISS..',15(I7,1X))
	GO TO (791,760),IOPT6
C
C	THIS DEPENDS ON PRINTER PAGE OF 60 BUT MAXPAG OF 58
C
7520	IF(IPAGE+5.LE.MAXPAG) GOTO 7720
	CALL PAGE
	CALL TABHOZ(IFLAG,LM,MUCH,INC,I1,I11,I2,BLANK,IHOR,OFF,
     .	OFF1,OFF2,OFAI,DOTS)
7720	IPAGE=IPAGE+2
	WRITE(IOUT,OFMT) IVER(K),(LINE(J),J=1,M)
760	IF(IOPT(5).EQ.1) IPAGE=IPAGE+1
	IF (IOPT(5).EQ.1) WRITE(IOUT,OFE) (EXP(J),J=IP,MUCH)
	IF (IOPT(7).NE.1) GO TO 77
	LM1=MUCH
	F=100./ITOT
	IF(INC.EQ.1) LM1=MUCH+1
	IF(INC.EQ.1) PER(LM1)=LINE(LM1)*F
	DO 76 J=IP,LM1
76	PER(J)=LINE(J)*F
	IPAGE=IPAGE+1
	WRITE(IOUT,OFT) (PER(J),J=IP,LM1)
C
C
77	IF (IOPT(8).NE.1) GO TO 78
	IF (ITOT.EQ.0) GO TO 71
	DO 770 J=IP,MUCH
	IF(ISUMC(J3+J).EQ.0) GOTO 770
	PER(J)=FLOAT(LINE(J))/ISUMC(J3+J)*100.
770	CONTINUE
	IPAGE=IPAGE+1
	WRITE(IOUT,OFC) (PER(J),J=IP,MUCH)
CC
78	IF (IOPT(9).NE.1) GO TO 79
	IF (ITOT.EQ.0) GO TO 71
	P=0.
	IF(ISUMR(K).NE.0) P=100./ISUMR(K)
	DO 780 J=IP,MUCH
780	PER(J)=LINE(J)*P
	IPAGE=IPAGE+1
	WRITE(IOUT,OFR) (PER(J),J=IP,MUCH)
C
C	COMPUTE CHI-SQUARE
C
79	IF (IDF.LE.0) GO TO 71
	IF ((K.EQ.1).AND.(IKV.EQ.2)) GO TO 791
	KK=0
	K1=K1+1
	DO 790 J=IP,MUCH
	IF (EXP(J).NE.0) CHI=CHI+(LINE(J)-EXP(J))**2/EXP(J)
	IF (IDF.NE.1) GO TO 790
	KK=KK+1
	L(KK,K1)=LINE(J)
790	CONTINUE
791	IF (IALL.EQ.2) WRITE(IDV) LINE
C
71	CONTINUE
	IPAGE=IPAGE+1
	IF (I.NE.NTIMES) WRITE(IOUT,OFS) (ISUMC(J),J=I1+IP-1,I2)
	IF (I.EQ.NTIMES) WRITE(IOUT,OFS) (ISUMC(J),J=I1+IP-1,I2),ITOT
	IF(IOPT(7).NE.1) GO TO 40
	J1=0
	DO 710 J=I1+IP-1,I2
	J1=J1+1
710	PER(J1)=ISUMC(J)*FNS
	IPAGE=IPAGE+1
	WRITE(IOUT,OFT)(PER(J),J=1,J1)
C
C
40	IF(IPAGE+4.GT.MAXPAG) CALL PAGE
	IPAGE=IPAGE+3
	WRITE(IOUT,400)
400	FORMAT('-')
C
C	WRITE OUT CHI-SQUARE
C
81	IF (IDF.LE.0) GO TO 9
	CALL CHIPRB(IDF,CHI,PROB,IERR)
	IF(IPAGE+6.GT.MAXPAG) CALL PAGE
	IPAGE=IPAGE+2
	WRITE(IOUT,810) CHI,IDF
810	FORMAT(' CHI-SQUARE =', F13.3, ' WITH ', I7, ' DEGREES OF
     1 FREEDOM'/)
	IF(IERR.EQ.1) GOTO 7712
	IF(IPAGE+4.GT.MAXPAG) CALL PAGE
	IPAGE=IPAGE+2
	WRITE(IOUT,812) PROB
812	FORMAT('+HAVING A PROBABILITY OF ',F10.7//)
7712	IF (IDF.NE.1) GO TO 82
	DO 814 J=1,2
	L(3,J)=L(1,J)+L(2,J)
814	L(J,3)=L(J,1)+L(J,2)
	L(3,3)=L(1,3)+L(2,3)
	CHI=(IABS(L(1,1)*L(2,2)-L(2,1)*L(1,2))-ITOT/2.)**2
	CHI=CHI*ITOT/(L(3,1)*L(3,2)*L(1,3)*L(2,3))
	IF(IPAGE+2.GT.MAXPAG) CALL PAGE
	IPAGE=IPAGE+1
	WRITE(IOUT,811) CHI
811	FORMAT('+CORRECTED CHI-SQUARE (YATES) =',F13.3/)
	CALL CHIPRB(IDF,TCHI,PROB,IERR)
	IF(IERR.EQ.1) GOTO 7711
	IF(IPAGE+1.GT.MAXPAG) CALL PAGE
	IPAGE=IPAGE+1
	WRITE(IOUT,812) PROB
7711	CALL CONP(L,3,3,PT,PS,PC)
	IF(IPAGE+8.GT.MAXPAG) CALL PAGE
	IPAGE=IPAGE+7
	WRITE(IOUT,813) PT,PS
813	FORMAT(/' FISHER''S EXACT PROBABILITY FOR OBTAINING'/4X,
     1 '(1)  THE GIVEN TABLE =',F10.7/4X,'(2)  A TABLE AS PROBABLE,
     2 OR LESS PROBABLE'/9X,'THAN THE GIVEN TABLE = ', F10.7//)
	IF (IALL.NE.2) GO TO 9
C
C	PHI COEFFICIENT
C
82	IF (IOPT(10).NE.1) GO TO (9,83) ,IALL
	P=SQRT(CHI/ITOT)
	IF(IPAGE+2.GT.MAXPAG) CALL PAGE
	IPAGE=IPAGE+1
	WRITE(IOUT,820) P
820	FORMAT(' PHI-COEFFICIENT   =',1PG16.8)
	GO TO (9,83), IALL
C
C
83	LM=IH*IV
	IF (LM.LT.2000) GO TO 84
	WRITE(IDLG,830) LM
830	FORMAT('-WARNING:  Program cannot handle ',I7,' cells in a
     1 contingency table'/9X,'for the following statistical tests:
     2 LAMBDA,THETA,GAMMA,TAU A,B&C'/9X,'Maximum is set at 2000.'//)
	RETURN
C
C
84	IF (IOPT(11).NE.1) GO TO 85
	MAXC=0
	DO 840 I=IKH,IH
	IF (ISUMC(I).GT.MAXC) MAXC=ISUMC(I)
840	CONTINUE
C
C	READ TABLE BACK
C
85	IF (IDF.GT.1) GO TO 850
	IDUM(1)=L(1,1)
	IDUM(2)=L(2,1)
	IDUM(3)=L(1,2)
	IDUM(4)=L(2,2)
	GO TO 87
850	CLOSE (UNIT=IDV)
	OPEN (UNIT=IDV,MODE=DEVMOD,ACCESS='SEQIN',FILE=NFILE3,
     .	DEVICE=DEVTMP)
	NTIMES=(IH+LENGTH-1)/LENGTH
	LAS=IH-(NTIMES-1)*15
	I11=15
	DO 86 I=1,NTIMES
	IST=(I-1)*15
	IF (I.EQ.NTIMES) I11=LAS
	DO 860 J=1,IV
	J1=(J-1)*IH+IST
	READ(IDV) LINE
	DO 860 K=1,I11
860	IDUM(J1+K)=LINE(K)
86	CONTINUE
C
87	IF (IOPT(11).EQ.1) CALL LAMBDA(MAXR,MAXC)
	IF (IOPT(12).EQ.1) CALL THETA(ISUMR)
	IF ((IOPT(13).EQ.1).OR.(IOPT(14).EQ.1)) CALL GAMTAU
	CLOSE (UNIT=IDV,DISPOSE='DELETE')
C
C
9	RETURN
	END
*
**************************************************************************
*
	SUBROUTINE TABHOZ(IFLAG,LM,MUCH,INC,I1,I11,I2,BLANK,IHOR,OFF,
     .	OFF1,OFF2,OFAI,DOTS)
	COMMON /IOBLK/INP,IOUT,IDEVI,IDEVO,IBNK,NAMI,NAMO,IPROJ,IPROG
	COMMON /IOB/LFBR,IRTBR,IALT,MAXPAG,IPAGE,IPAGCT,IDLG,ICC,ICODE
	DIMENSION IHOR(1),OFF(5),OFF1(10),OFF2(10),OFAI(9)
C
C	THIS ROUTINE PRINTS HORIZONTAL SYMBOLS AND HEADERS
C
C	IFLAG TELLS WHICH KIND
C
	NDOT=(MUCH+INC)*8+1
	IF(IPAGE+7.LE.MAXPAG) GOTO 200
	CALL PAGE
	GOTO 220
200	IF((IPAGE.LT.5).AND.(IDEVO.NE.'TTY')) GOTO 220
	WRITE(IOUT,1000)
1000	FORMAT(1X)
	IPAGE=IPAGE+1
220	IPAGE=IPAGE+1
	GOTO (10,20,30,40,50), IFLAG
C
C
10	NDOT=17
	IF(LM.EQ.1) WRITE(IOUT,1001)
1001	FORMAT(14X,'MISSING',3X,'TOTAL')
	IF(LM.EQ.2) WRITE(IOUT,1002)
1002	FORMAT(6X,'MISSING',3X,'TOTAL')
	GOTO 100
C
C
20	WRITE(IOUT,OFF) IHOR(I1)
	GOTO 100
C
C
30	WRITE(IOUT,OFAI) (BLANK,IHOR(J),J=I11,I2)
	GOTO 100
C
C
40	IPAGE=IPAGE+1
	WRITE(IOUT,OFF1) (IHOR(J),J=I1+1,I2,2)
	WRITE(IOUT,OFF2) (IHOR(J),J=I11,I2,2)
	GOTO 100
C
C
50	IPAGE=IPAGE+1
	WRITE(IOUT,OFF1) (IHOR(J),J=I11,I2,2)
	WRITE(IOUT,OFF2) (IHOR(J),J=I1+1,I2,2)
C
C
100	IPAGE=IPAGE+1
	IF(LM.EQ.1) WRITE(IOUT,1004) (DOTS,J=1,NDOT)
1003	FORMAT(6X,121A1)
	IF(LM.EQ.2) WRITE(IOUT,1003) (DOTS,J=1,NDOT)
1004	FORMAT(14X,113A1)
	RETURN
	END
*
**************************************************************************
*
	SUBROUTINE LAMBDA(MAXR,MAXC)
C
C**********************************************************************
C	SUBROUTINE THAT CALCULATES THE LAMBDA STATISTICS.
C**********************************************************************
C
	DIMENSION L(2000)
	COMMON/IOBLK/INP,IOUT,IDEVI,IDEVO,IBNK,NAMI,NAMO,IPROJ,IPROG
	COMMON /IOB/LFBR,IRTBR,IALT,MAXPAG,IPAGE,IPAGCT,IDLG,ICC,ICODE
	COMMON/SBNK/NVBNK,NOBNK,NDBNK(2),NPBNK(2),ITEMP(5000)
	COMMON/STAT/ITOT,IV,IH,IKV,IKH
	DOUBLE PRECISION NAMI,NAMO
	EQUIVALENCE (ITEMP(3001),L)
C
	SUM=0
	DO 10 I=IKV,IV
	I1=(I-1)*IH
	MAX=0
	DO 11 J=IKH,IH
	IF (L(J+I1).GT.MAX) MAX=L(J+I1)
11	CONTINUE
10	SUM=SUM+MAX
C
C
	DO 20 I=IKH,IH
	MAX=0
	DO 21 J=IKV,IV
	I1=I+(J-1)*IH
	IF (L(I1).GT.MAX) MAX=L(I1)
21	CONTINUE
20	SUM=SUM+MAX
	R=MAXR+MAXC
	R=(SUM-R)/(2*ITOT-R)
	IF(IPAGE+2.GT.MAXPAG) CALL PAGE
	IPAGE=IPAGE+2
	WRITE(IOUT,30) R
30	FORMAT(' LAMBDA STATISTICS =',1PG16.8)
	RETURN
	END
*
**************************************************************************
*
	SUBROUTINE GAMTAU
C
C***********************************************************************
C	SUBROUTINE THAT CALCULATES THE GAMMA STATISTICS AND TAU A,B,C
C***********************************************************************
C
	DIMENSION L(2000)
	COMMON/IOBLK/INP,IOUT,IDEVI,IDEVO,IBNK,NAMI,NAMO,IPROJ,IPROG
	COMMON /IOB/LFBR,IRTBR,IALT,MAXPAG,IPAGE,IPAGCT,IDLG,ICC,ICODE
	COMMON/SBNK/NVBNK,NOBNK,NDBNK(2),NPBNK(2),ITEMP(5000)
	COMMON/SOPT/IOPT(15),MAXTAB,DEVTMP,DEVMOD,MAXSYM
	COMMON/STAT/ITOT,IV,IH,IKV,IKH
	DOUBLE PRECISION NAMI,NAMO
	EQUIVALENCE (ITEMP(3001),L)
C
C
	IV1=IV-1
	IH1=IH-1
	FA=0
	FI=0
	X=0
	Y=0
	DO 10 I=IKH,IH1
	I1=I+1
	DO 10 J=IKV,IV1
	J1=J+1
	JJ=(J-1)*IH
	IJ=JJ+I
	S=0
	T=0
	DO 20 K=I1,IH
	T=T+L(JJ+K)
	DO 21 K1=J1,IV
	KK=(K1-1)*IH+K
21	S=S+L(KK)
20	CONTINUE
	Y=Y+T*L(IJ)
10	FA=FA+S*L(IJ)
C
C
	IJ=IV1*IH
	DO 11 I=IKH,IH1
	T=0
	DO 12 J=I+1,IH
12	T=T+L(IJ+J)
11	Y=Y+T*L(IJ+I)
C
C
	DO 30 I=IKH+1,IH
	DO 30 J=IKV,IV1
	J1=(J-1)*IH
	IJ=J1+I
	S=0
	DO 40 K=IKH,I-1
	DO 40 K1=J+1,IV
	KK=(K1-1)*IH+K
40	S=S+L(KK)
30	FI=FI+S*L(IJ)
C
C
	DO 50 I=IKH,IH
	DO 51 J=IKV,IV1
	IJ=(J-1)*IH+I
	J1=J+1
	T=0
	DO 60  K=J1,IV
	KK=(K-1)*IH+I
60	T=T+L(KK)
51	X=X+T*L(IJ)
50	CONTINUE
C
C
	PLUS=FA+FI
	MINUS=FA-FI
	IF (IOPT(13).NE.1) GO TO 71
	G=MINUS/PLUS
	IF(IPAGE+2.GT.MAXPAG) CALL PAGE
	IPAGE=IPAGE+2
	WRITE(IOUT,70) G
70	FORMAT(' GAMMA STATISTICS  =',1PG16.8)
C
71	IF (IOPT(14).NE.1) RETURN
	TA=(MINUS*2.)/(ITOT*(ITOT-1))
	TB=MINUS/SQRT((PLUS+X)*(PLUS+Y))
	M1=IH-IKH+1
	M2=IV-IKV+1
	M=MIN0(M1,M2)
	TC=(MINUS*2.*M)/(ITOT*ITOT*(M-1))
	IF(IPAGE+2.GT.MAXPAG) CALL PAGE
	IPAGE=IPAGE+2
	WRITE(IOUT,72) TA,TB,TC
72	FORMAT(' TAU A =',1PG16.8,'  TAU B =',G16.8,'  TAU C =',
     .	G16.8)
	RETURN
	END
*
**************************************************************************
*
	SUBROUTINE THETA(ISUMR)
C
C***********************************************************************
C	SUBROUTINE THAT CALCULATES THE THETA STATISTICS.
C***********************************************************************
C
	DIMENSION L(2000),ISUMR(600)
	COMMON/IOBLK/INP,IOUT,IDEVI,IDEVO,IBNK,NAMI,NAMO,IPROJ,IPROG
	COMMON /IOB/LFBR,IRTBR,IALT,MAXPAG,IPAGE,IPAGCT,IDLG,ICC,ICODE
	COMMON/SBNK/NVBNK,NOBNK,NDBNK(2),NPBNK(2),ITEMP(5000)
	COMMON/STAT/ITOT,IV,IH,IKV,IKH
	DOUBLE PRECISION NAMI,NAMO
	EQUIVALENCE (ITEMP(3001),L)
C
	T=0
	D=0
	DO 10 I=IKV,IV-1
	I1=(I-1)*IH
	DO 10 J=I+1,IV
	FA=0
	FB=0
	T=T+ISUMR(I)*ISUMR(J)
	J1=(J-1)*IH
C
C
	DO 20 K=IKH,IH-1
	M=0
	DO 21 KK=K+1,IH
21	M=M+L(J1+KK)
20	FA=FA+L(I1+K)*M
C
C
	DO 30 K=IKH+1,IH
	M=0
	DO 31 KK=IKH,K-1
31	M=M+L(J1+KK)
30	FB=FB+L(I1+K)*M
10	D=D+ABS(FB-FA)
C
	R=D/T
	IF(IPAGE+2.GT.MAXPAG) CALL PAGE
	IPAGE=IPAGE+2
	WRITE(IOUT,40) R
40	FORMAT(' THETA STATISTICS  =',1PG16.8)
	RETURN
	END
*
**************************************************************************
*
C	THIS SUBROUTINE IS TAKEN FROM STP11.STP
C                                  *** STAT PACK ***
C     SUBROUTINE IS PART OF STAT PACK CHISQUARE USED TO CALCULATE
C     THE EXACT PROBABILITY OF A 2X2 TABLE OR THE PROBABILITY OF
C     HAVING THAT TABLE OR A TABLE LESS PROBABLE THAN IT.
C     ROUTINE FROM COMMUNICATIONS OF ACM NOVEMBER 1972
C      WHERE MATRIX - IS A 3X3 TABLE FOR WHICH THE PROB IS FOUND
C            NR - IS THE NUMBER OF ROWS (HERE ALWAYS 2)
C            NC - IS THE NUMBER OF COLUMNS (HERE ALWAYS 2)
C            PT - PROBABILITY OF GIVEN TABLE
C            PS - PROBABILITY OF TABLE AS PROBABLE AS GIVEN TABLE
C            PC - NOT USED IN STP, BUT IT IS THE PROBABILITY OF
C                 OBTAINING SOME OF THE TABLES POSSIBLE WITHIN
C                 THE CONSTRAINTS OF THE MARGINAL TOTALS
C
C
      SUBROUTINE CONP(MATRIX,NR,NC,PT,PS,PC)
      DIMENSION MATRIX(NR,NC)
      COMMON/IFLAG1/IFLAG
      INTEGER R,C,TEMP
      IFLAG=0
      R=NR-1
      C=NC-1
      QXLOG=-FACLOG(MATRIX(NR,NC))
      DO 10 I=1,R
10    QXLOG=QXLOG+FACLOG(MATRIX(I,NC))
      DO 20 J=1,C
20    QXLOG=QXLOG+FACLOG(MATRIX(NR,J))
      RXLOG=0.0
      DO 50 I=1,R
      DO 50 J=1,C
50    RXLOG=RXLOG+FACLOG(MATRIX(I,J))
      PT=10.0**(QXLOG-RXLOG)
      PS=0
      PC=0
      DO 100 I=2,R
      DO 100 J=2,C
100   MATRIX(I,J)=MIN0(MATRIX(I,NC),MATRIX(NR,J))
      GO TO 300
200   DO 220 I=2,R
      DO 220 J=2,C
      MATRIX(I,J)=MATRIX(I,J)-1
      IF(MATRIX(I,J).GE.0) GO TO 300
220   MATRIX(I,J)=MIN0(MATRIX(I,NC),MATRIX(NR,J))
      RETURN
300   DO 320 I=2,R
      TEMP=MATRIX(I,NC)
      DO 310 J=2,C
310    TEMP=TEMP-MATRIX(I,J)
      IF(TEMP.LT.0) GO TO 200
320   MATRIX(I,1)=TEMP
      DO 340 J=1,C
      TEMP=MATRIX(NR,J)
      DO 330 I=2,R
330   TEMP=TEMP-MATRIX(I,J)
      IF(TEMP.LT.0) GO TO 200
340   MATRIX(1,J)=TEMP
      RXLOG=0.0
      DO 350 I=1,R
      DO 350 J=1,C
350   RXLOG=RXLOG+FACLOG(MATRIX(I,J))
      PX=10.0**(QXLOG-RXLOG)
      PC=PC+PX
      IF((PT/PX).GT.0.9999) PS=PS+PX
      GO TO 200
      END
C                                            *** STAT PACK ***
C     FUNCTION IS PART OF STP TAKEN FOR COMMUNICATIONS OF ACM
C     NOVEMBER 1972. USED TOR FINDING LOG BASE 10 OF N FACTORIAL.
C     USES STIRLINGS APPROX. IF N.GT.100
C
C     FIRST TIME THRU IT CREATES A TABLE IT USES.  IFLAG IS THE 
C     INDICATOR USED TO ESTABLISH RATHER A TABLE NEED BE CREATED
C
      FUNCTION FACLOG(N)
      DIMENSION TABLE (101)
      COMMON /IFLAG1/IFLAG
      TPILOG=.3990899342
      ELOG=.4342944819
      IF(N.GT.100) GO TO 50
      IF(IFLAG.EQ.0) GOTO 100
10    FACLOG=TABLE(N+1)
      RETURN
50    X=FLOAT(N)
      FACLOG=(X+.5)*ALOG10(X)-X*ELOG+TPILOG+ELOG/(12.0*X)-ELOG
     1/(360.0*X**3)
      RETURN
C
C     CREATE TABLE TO BE USED FOR REST OF TIME
C
100   TABLE(1)=0.0
      DO 120 I=2,101
      X=FLOAT(I-1)
120   TABLE(I)=TABLE(I-1)+ALOG10(X)
      IFLAG=1
      GOTO 10
      END
C     SUBROUTINE USED FOR DETERMINING CHI SQUARE PROBABILITIES
C     CALLING SEQUENCE: CALL CHIPRB(K,X,Y,IERR)
C     WHERE K - NUMBER OF DEGREES OF FREEDOM
C           X - CHI SQUARE VALUE
C           Y - PROBABILITY ASSOCIATED WITH CHI SQUARE
C           IERR - ERROR WAS ENCOUNTERED WHEN ATTEMPTING TO CALCULATE
C                  PROBABILITY
C
C     ROUTINE WAS WRITTEN BY CHARLES NAGY OF WMU.
C	CALLS SUBROUTINE CUNO.
      SUBROUTINE CHIPRB(K,X,Y,IERR)
      DIMENSION F(25)
      F(1)=.5
      F(2)=.598706326
      F(3)=.691462461
      F(4)=.773372648
      F(5)=.841344746
      F(6)=.894350226
      F(7)=.933192799
      F(8)=.959940843
      F(9)=.977249868
      F(10)=.987775527
      F(11)=.993790335
      F(12)=.997020237
      F(13)=.998650102
      F(14)=.999422975
      F(15)=.999767371
      F(16)=.999911583
      F(17)=.999968329
      F(18)=.999989311
      F(19)=.999996602
      F(20)=.999998983
      F(21)=.999999713
      F(22)=.999999924
      F(23)=.999999981
      F(24)=.999999996
      F(25)=.999999999
      IERR=0
      Y=0
      IF((K.LE.0).OR.(K.GT.100)) IERR=1
      IF(X.GT.141) IERR=1
      IF(IERR.EQ.1) RETURN
      IF(X.LE.0) GO TO 13
      IF(K.GE.4) GO TO 4
      GO TO (1,2,3),K
1     P=SQRT(X)
      CALL CUNO(P,S,IERR,F)
      IF(IERR.EQ.1) RETURN
      Y=2.*S-1
      GO TO 13
2      Y=1.-(1./EXP(X/2.))
      GO TO 13
3     P=SQRT(X)
      CALL CUNO(P,S,IERR,F)
      IF(IERR.EQ.1) RETURN
      Y=(2.*S-1)-P/(1.25331414*EXP(X/2.))
      GO TO 13
4     M=K/2
      IF(K.EQ.2*M) GO TO 6
      P=SQRT(X)
      CALL CUNO(P,S,IERR,F)
      IF(IERR.EQ.1) RETURN
      Y=2.*S-1.
      S=X/2.
      C=1./(.62665707*P*EXP(S))
      P=S
      T=.5
      GO TO 7
6     C=1./EXP(X/2.)
      Y=1.-C
      S=0
      P=1
      T=0
7     DO 8 I=1,M-1
      T=T+1
      P=P*(X/(T*2.))
8     S=S+P
      Y=Y-C*S
13    Y=1.-Y
      END
C     SUBROUTINE USED IN FINDING PROB FOR CHI SQUARE
C     CALLING SEQUENCE: CALL CUNO(X,Y,IERR,F)
C     ORIGINALLY WRITTEN BY CHARLES NAGY OF WMU.
C
      SUBROUTINE CUNO(X,Y,IERR,F)
      DIMENSION F(1)
      W=X
      IF(W.LT.0) W=-W
      IF(W.LE.6.125) GO TO 2
1      Z=1
      GO TO 7
2     K=INT(4.*W)+1
      A=.25*(K-1.)
      IF(W-A) 10,3,4
3     Z=F(K)
      GO TO 7
4     IF(W-(A+.125))6,6,5
5     K=K+1
      A=A+.25
6     H=W-A
      ASQ=A*A
      C1=((-ASQ+10.)*ASQ-15.)*A
      C2=(6.*ASQ-36.)*ASQ+18.
      C3=(-30.*ASQ+90.)*A
      C4=120.*(ASQ-1.)
      C5=-360.*A
      C6=(((((C1*H+C2)*H+C3)*H+C4)*H+C5)*H+720.)*H
      Z=F(K)+C6/(720.*SQRT(6.28318531*EXP(ASQ)))
7     Y=Z
      IF(X.LT.0.) Y=1.-Z
      RETURN
10    IERR=1
      RETURN
      END