PDP-10 Archive: decus/20-0137/corl/corl.for from decus_20tap5

Trailing-Edge - PDP-10 Archives - decus_20tap5_198111 - decus/20-0137/corl/corl.for

There is 1 other file named corl.for in the archive. Click here to see a list.

C
C	WESTERN  MICHIGAN  UNIVERSITY
C
C	PEARSON R CORRELATION, MEAN AND STANDARD DEVIATION PROGRAM
C
C	PROGRAMMED BY   BERENICE HOUCHARD

C			COMPUTER CENTER, WMU
C			JANUARY, 1974
C
C
C	MODIFIED BY	DAVID SCHULZ
C			COMPUTER CENTER, WMU
C			DECEMBER 1975
C
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.  BOTH F AND I-TYPE
C	VARIABLES ARE EASILY HANDLED.  SEVERAL OPTIONS EXIST FOR THE
C	USER TO ELECT.  ALL CALCULATIONS ARE DONE ON EITHER PAIRWISE
C	OR OBSERVATIONWISE METHOD AS SPECIFIED BY THE USER.  A SHORT
C	DESCRIPTION WILL TYPE OUT IN RESPONSE TO "HELP" FROM THE USER
C	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	     GETFR1          FORMAT SUBROUTINE
C
C	     GETID           HEADER SUBROUTINE
C
C	     GETMOD          DETERMINE MODES OF VARIABLES FROM FORMAT
C
C	     BNKNAM          OBTAIN VARIABLE NAMES FROM THE DATA BANK
C
C	     VARLST          OBTAIN VARIABLE NUMBER OR NAMES FROM
C		             NON-DATA BANK INPUT
C	        
C	     INFO	     WRITE A HEADER PAGE FOR NON-TTY OUTPUT
C
C	     OPTION          DETERMINE WHICH OPTIONS TO USE
C
C	     SELECT	     ALLOWS PROGRAM TO CONSIDER ONLY THOSE
C		             OBSERVATIONS MEETING USER SPECIFIED
C			     CRITERIA.
C
C	     GTCORE  (*)     TO ALLOCATE CORE DYNAMICALLY
C
C	     LSCORE  (*)     TO RETURN CORE DYNAMICALLY
C
C	     MAINL           MAIN SUBROUTINE FOR THE PROGRAM
C
C	     SUM             SUBROUTINE THAT CALCULATES SUMS AND SUMS OF
C	                     SQUARES FOR OBSERVATIONWISE METHOD
C
C	     SUMP            CALCULATES SUMS AND SUMS OF SQUARES FOR
C			     PAIR-WISE OPTION
C
C	     SUMT	     CALCULATES SUMS AND SUMS OF SQUARES FOR
C			     REPLACING MISSING DATA WITH RANDOM NUM. OR MEAN
C
C	     COR             CALCULATES CORRELATIONS FOR OBSERVATIONWISE
C			     METHOD
C
C	     CORP            CALCULATES CORRELATIONS (PAIR-WISE OPTION)
C
C	     MEAN	     OPTION TO OUTPUT MEANS AND STANDARD
C			     DEVIATIONS ONLY
C
C	     TVAL	     T-VALUE SUBROUTINE
C
C	     ZVAL            Z-VALUE SUBROUTINE
C
C	     OUT             OUTPUT SUBROUTINE
C
C            COLAPS          COLAPSES ARRAYS IN CASE OF ZERO VARIANCE
C
C            PAGE            OUTPUTS PAGE NUMBER AND HEADER
C
C	     RNORM	     FINDS RANDOM NORMAL NUMBER
C
C		(*)  MACRO SUBROUTINE
C
C
C***********************************************************************
C
C
C
C
C AAR ==================================================================
C AAR
C AAR			*** UPDATES MADE FOR ASSOC. OF  ***
C AAR			*** AMER. R.R. TO ALLOW RUNNING ***
C AAR			*** ON DEC-20...  10/10/77 WEB  ***
C AAR
C AAR 		CHANGES MADE:
C AAR
C AAR			ORIGINAL VERSION USED ROUTINE "GTCORE"
C AAR			TO DYNAMICALLY ALLOCATE CORE. THIS
C AAR			WOULD NOT RUN ON OUR SYSTEM WHEN RE-
C AAR			LOADED (TO CORRECT PROBLEM OF OUTPUT
C AAR			TO THE PRINTER). REPLACE CALLS TO 
C AAR			"GTCORE" AND "LSCORE" WITH CALLS TO
C AAR			THE ROUTINE "ALLCOR".
C AAR
C AAR			ALSO, CHANGE TEMPORARY DEVICE STORAGE
C AAR			FROM 'DSKC' TO 'DSK', AND COMMENT OUT
C AAR			CALL TO "USAGE".
C AAR
C AAR
C AAR		NOTE: 	CHANGES MADE BY AAR ARE SURROUNDED BY
C AAR			COMMENTS WITH "AAR" IN THE LEFT MARGIN.
C AAR			STATEMENTS WHICH WERE IN THE ORIGINAL 
C AAR			VERSION THAT HAVE BEEN COMMENTED OUT
C AAR			HAVE A "WMU" IN THE LEFT MARGIN.
C AAR
C AAR
C AAR ===============================================================
C
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/SGETFR/ISTD,ITYPE
	COMMON/FMT/NOTF(80)	!MSL: EXPANDED FROM 48, 10-15-76
	COMMON/SOPT/IOPT(11),DEVTMP,DEVMOD
	COMMON/SID/ID(16),ISTOP
	DOUBLE PRECISION NAMI,NAMO,DEVNAM
	INTEGER OFFSET
	EQUIVALENCE (ITEMP,IDUM)
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 SUBROUTINE IO
C
C	IDSK--DEVICE FOR TEMPORARY DISK FILE. USED FOR MISSR,
C		MISSM AND MATRIX OPTION. IT IS ALWAYS SET TO 23
C
C	DEVTMP--STRUCTURE WHERE TEMPORARY DISK FILES ARE WRITTEN
C
C	DEVMOD--MODE IN WHICH TEMPORARY DISK FILE ARE WRITTEN
C
C***********************************************************************
C
	IDLG=-1
	ICC=-4
	INP=2
	IOUT=21
	MAXPAG=58
	IPAGCT=0
	OFFSET=0
C WMU
C WMU
C WMU	DEVTMP='DSKC'
C WMU
C WMU
C
C AAR ----
C AAR    !
	DEVTMP='DSK'
C AAR    !
C AAR ----
C
	DEVMOD='DUMP'
C
C
C
	WRITE(IDLG,9977)
9977	FORMAT('-*** W.M.U. CORRELATION PROGRAM V2 ***'//)
C
C WMU
C WMU
C WMU	CALL USAGE('CORL')
C WMU
C WMU
C
C
C*********************************************************************
C	CHECK IF JOB IS ON TELETYPE OR PSEUDO-TELETYPE
C	     IF ICODE=0  JOB IS ON TELETYPE
C	        ICODE=-1 JOB IS ON PSEUDO-TELETYPE
C*********************************************************************
C
	CALL TTYPTY(ICODE)
	CALL IO(1,IOUT,DEVNAM,IDEVO,NAMO,IPROJ,IPROG,IBNK)
10	CALL IO(0,INP,DEVNAM,IDEVI,NAMI,IPROJ,IPROG,IBNK)
	IDEVO=NOUT
	IPAGE=0
	IF(IDEVO.EQ.'TTY') IPAGE=-999999
	ITYPE=3
C
C
11	CALL OPTION
	DO 110 I=1,16
110	ID(I)=' '
	ISTOP=0
	IF (IOPT(6).EQ.1) CALL GETID
	GO TO (40,30), IBNK+1
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 DATA BANK TO BE USED
C**********************************************************************
C
30	READ(INP#1) IDUM
	NVBNK=IDUM(1)
	NOBNK=IDUM(2)
	NDBNK(1)=IDUM(4)
	NDBNK(2)=IDUM(5)
	NPBNK(1)=IDUM(6)
	NPBNK(2)=IDUM(7)
	IF (IDUM(8).EQ.'V2') GO TO 32
	WRITE(IDLG,31)
31	FORMAT('-This BANK was created with an experimental version of
     1 the BANK.'/' Please update the BANK by running BANKUP from area
     2 220,220.'/' If you are not responsible for the BANK contact the
     3 owner and'/' ask him to run the updating program.'/)
	CALL EXIT
32	CALL BNKNAM(ITYPE,M)
	NOTF(1)='DATA'
	NOTF(2)='BANK'
	NOTF(3)='FORMA'
	NOTF(4)='T'
	DO 33 I=5,80		!MSL: EXPANDED FROM 48, 10-15-76
33	NOTF(I)=' '
	GO TO 50
C
C
C
C***********************************************************************
C	NON-DATA BANK ONLY
C
C	(1)  ACCEPTS VARIABLE NAMES OR DETERMINE HOW MANY VARIABLES TO
C	     BE USED
C
C	(2)  DETERMINE WHICH FORMAT TO USE
C***********************************************************************
C
40	CALL VARLST(M)
	GO TO (41,42), IOPT(7)+1
C
C
41	ISTD=1
	NOTF(1)='(20F)'
	DO 410 I=2,80		!MSL: EXPANDED FROM 48, 10-15-76
410	NOTF(I)=' '
	DO 411 I=4201,4200+M
411	ITEMP(I)=0
	GO TO 50
C
C
42	CALL GETFR1(IOPT(5),80,NOTF)	!MSL: EXPANDED FROM 48, 10-15-76
	IF(ISTD.EQ.1) GOTO 41
	CALL GETMOD(M,400,NOTF)		!MSL: EXPANDED FROM 240, 10-15-76
	K=0
	I=1
44	MODE=ITEMP(4200+I)
	IF ((MODE.EQ.0).OR.(MODE.EQ.2)) GO TO 46
	K=K+1
	ITEMP(K)=ITEMP(2600+I)
	IF (I.EQ.M) GO TO 47
	DO 45 J=I+1,M
	J1=J-1
	ITEMP(2600+J1)=ITEMP(2600+J)
	ITEMP(3400+J1)=ITEMP(3400+J)
45	ITEMP(4200+J1)=ITEMP(4200+J)
	M=M-1
	IF (M.LE.0) GO TO 52
 46	I=I+1
	IF (I.LE.M) GO TO 44
47	IF (K.GT.0) WRITE(IDLG,470) (ITEMP(I),I=1,K)
470	FORMAT('-WARNING:  The following A-type variables will not be
     1 included'/' in the calculation of MEAN,etc:'/10(1X,A5))
	WRITE(IDLG,600)
C
C***********************************************************************
C	START TO ALLOCATE CORE
C***********************************************************************
C
50	KN=(M*(M+1))/2
	GOTO (51,55),(1+(IOPT(10)+IOPT(11)+IOPT(4)+3)/4)
C
C***********************************************************************
C	ALLOCATE CORE FOR OBSERVATIONWISE METHOD
C***********************************************************************
C
51	MAX=5*M+2*KN
C
C WMU
C WMU
C WMU	IF(OFFSET.NE.0) CALL LSCORE(SPACE(1),OFFSET)
C WMU
C WMU
C
	OFFSET=0
C
C WMU
C WMU
C WMU	CALL GTCORE(MAX,SPACE(1),OFFSET,IERR,500)
C WMUC	CALL ALLCOR(MAX,IERR,OFFSET,SPACE(1))
C WMU
C WMU
C
C
C AAR
C AAR ----
C AAR    !
	CALL ALLCOR(MAX,IERR,OFFSET,SPACE(1))
C AAR    !
C AAR ----
C AAR
C
	IF(IERR) 52,53,52
C
C
C
52	WRITE(IDLG,520)
520	FORMAT('-ERROR:  Number of variables outside allowable range, 
     .Try again'/)
	IF (ICODE.LT.0) CALL EXIT
	GO TO (40,32),IBNK+1
C
C
C
53	I1=OFFSET
	I2=I1+M
	I3=I2+M
	I4=I3+M
	I5=I4+M
	I6=I5+M
	I7=I6+KN
	CALL MAINL(M,SPACE(I1),SPACE(I2),SPACE(I3),SPACE(I4),SPACE(I4),
     1 SPACE(I5),SPACE(I6),SPACE(I7),SPACE(I7),SPACE(I7),SPACE(I7))
	GO TO 60
C
C***********************************************************************
C	ALLOCATE CORE FOR PAIRWISE METHOD
C***********************************************************************
C
55	MAX=4*M+6*KN
C
C WMU
C WMU
C WMU	IF(OFFSET.NE.0) CALL LSCORE(SPACE(1),OFFSET)
C WMU
C WMU
C
	OFFSET=0
C
C WMU
C WMU
C WMU	CALL GTCORE(MAX,SPACE(1),OFFSET,IERR,1000)
C WMUC	CALL ALLCOR(MAX,IERR,OFFSET,SPACE(1))
C WMU
C WMU
C
C
C AAR
C AAR ----
C AAR    !
	CALL ALLCOR(MAX,IERR,OFFSET,SPACE(1))
C AAR    !
C AAR ----
C AAR
C
	IF(IERR) 52,61,52
61	I1=OFFSET
	I2=I1+M
	I3=I2+M
	I4=I3+M
	I5=I4+M
	I6=I5+KN
	I7=I6+KN
	I8=I7+KN
	I9=I8+KN
	I10=I9+KN
	CALL MAINL(M,SPACE(I1),SPACE(I2),SPACE(I3),SPACE(I4),SPACE(I4),
     1 SPACE(I5),SPACE(I6),SPACE(I7),SPACE(I8),SPACE(I9),SPACE(I10))
C
C*********************************************************************
C	END OF ONE SET OF DATA
C*********************************************************************
C
60	WRITE(IDLG,600)
600	FORMAT(1H-)
	GO TO 10
	END
*
***********************************************************************
*
	SUBROUTINE MAINL(M,NAME,NUM,MODE,DMISS,MISS,SUMX,SUMXY,SUMX2,
     1 SUMY2,SUMY,NSUB)
C
C**********************************************************************
C
C	MAIN SUBROUTINE OF THE PROGRAM
C
C	M-------NUMBER OF VARIABLES
C	NAME----VECTOR CONTAINING VARIABLE NAMES
C	NUM-----VECTOR CONTAINING VARIABLE NUMBERS
C	MODE----VECTOR CONTAINING VARIABLE MODES
C	DMISS---VECTOR CONTAINING MISSING DATA SYMBOLS
C	MISS----VECTOR CONTAINING MISSING DATA SYMBOLS
C		IT IS EQUIVALENCE TO DMISS
C	SUMX----VECTOR FOR SUM OF X
C	SUMXY---VECTOR FOR SUM OF X*Y
C
C	NOTE:  THE FOLLOWING VECTORS ARE USED ONLY ON PAIR-WISE METHOD
C
C	SUMX2---VECTOR FOR SUM OF X*X
C	SUMY2---VECTOR FOR SUM OF Y*Y
C	SUMY----VECTOR FOR SUM OF Y
C	NSUB----VECTOR CONTAINING THE SAMPLE SIZES
C**********************************************************************
C
	DIMENSION NAME(1),NUM(1),MODE(1),DMISS(1),MISS(1),SUMX(1),
     1 SUMXY(1),SUMX2(1),SUMY2(1),SUMY(1),NSUB(1),X(5000),
     2 DUM(125),IDUM(125),IVALUE(20,20),DD(72),VEC(200),IVEC(200),
     3 IWORK(125)
	INTEGER T
	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/SGETFR/ISTD,ITYPE
	COMMON/FMT/NOTF(80)	!MSL: EXPANDED FROM 48, 10-15-76
	COMMON/SOPT/IOPT(11),DEVTMP,DEVMOD
	COMMON/SID/ID(16),ISTOP
	COMMON/SINFO/CALNAM,PROG(12)
	COMMON/SELEC/NSEC,NVAR(20),NCON(20),VALUE(20,20),NVAL(20),
     1 NOR(20)
	COMMON/SOUT/LOOP,INUM,I2
	COMMON /MANSEG/NAM(2),IXBLK(100),MAXBLK,NXBLK,IDSK
	DOUBLE PRECISION NAMI,NAMO,NFILE
	EQUIVALENCE (ITEMP(1),X), (VALUE,IVALUE), (VEC,IVEC,DUM,
     1 IDUM,DD), (AMISS,MMISS),(NFILE,NAM)
	DATA CALNAM,PROG/'CORL','PEARSON R CORRELATION,  MEAN  &
     1  STANDARD DEVIATION  PROGRAM'/
C
C
C
	IPAIR=1+(IOPT(4)+IOPT(10)+IOPT(11)+3)/4
	IDSK=23
	IF(IOPT(10)+IOPT(11).LE.0) GOTO 1
C
C	DEFINE TEMPORARY DISK FILE (FOR MISSM AND MISSR OPTIONS ONLY)
C
	NAM(1)='00001'
	NAM(2)='.TMP'
8800	CALL EXIST(NFILE,I)
	IF(I.EQ.1) GOTO 8801
	NAM(1)=NAM(1)+1
	GOTO 8800
8801	OPEN (UNIT=IDSK,FILE=NFILE,DEVICE=DEVTMP,MODE=DEVMOD,
     .	ACCESS='SEQOUT')
	NXBLK=0
	MAXBLK=100
1	NTSUB=0
	T=0
	NT=5000/M
C
C***********************************************************************
C	TRANSFER THE NAMES, NUMBERS AND MODES INTO THE PROPER VECTORS
C***********************************************************************
C
	DO 10 I=1,M
	NAME(I)=ITEMP(2600+I)
	NUM(I)=ITEMP(3400+I)
	MODE(I)=ITEMP(4200+I)
10	MISS(I)="400000000000
	MM=M*(M+1)/2
C
C***********************************************************************
C	WRITE OUT A HEADER PAGE FOR NON-TTY OUTPUT
C***********************************************************************
C
	IF (IDEVO.EQ.'TTY') GO TO 14
	IPAGCT=IPAGCT+1
	CALL INFO(M)
	DO 11 I=1,11
	IDUM(I)='NO'
	IF (IOPT(I).EQ.1) IDUM(I)='YES'
11	CONTINUE
	WRITE(IOUT,12) (IDUM(I),I=1,11),(NAME(I),I=1,M)
12	FORMAT('-',29X,'OPTIONS AVAILABLE:',2X,'T-VALUE----',A3,3X,
     .	'Z-VALUE----',A3,3X,'MISSV------',A3/50X,'MISSP------',
     .	A3,3X,'SELECT-----',A3,3X,'HEADER-----',A3/50X,'FORMAT-----',
     .	A3,3X,'MEAN ONLY--',A3,3X,'MATRIX-----',A3/50X,'MISSM------',
     .	A3,3X,'MISSR------',A3/29X,'VARIABLES USED:'//((37X,A5),
     4 9(2X,A5)))
C
C**********************************************************************
C	SELECT OPTION
C**********************************************************************
C
14	IF (IOPT(5).NE.1) NSEC=0
	IF (IOPT(5).EQ.1) CALL SELECT(M)
	GO TO (21,22), IPAIR
C
C***********************************************************************
C	ZERO OUT ACCUMULATORS
C***********************************************************************
C
21	DO 210 I=1,M
210	SUMX(I)=0
	DO 211 I=1,MM
211	SUMX2(I)=0
	GO TO 23
C
C
22	DO 220 I=1,MM
	SUMX(I)=0
	SUMY(I)=0
	SUMXY(I)=0
	SUMX2(I)=0
	SUMY2(I)=0
220	NSUB(I)=0
C
C*********************************************************************
C	GET MISSING DATA SYMBOL(S)
C*********************************************************************
C
23	IF (IOPT(3).EQ.1) GO TO 230
	IF ((IBNK.EQ.1).OR.(IPAIR.EQ.1)) GO TO (30,50) ,IBNK+1
230	WRITE(IDLG,2300)
2300	FORMAT(' ENTER MISSING DATA VALUE, SEPARATED BY COMMAS')
	READ(ICC,231,ERR=24) DD
231	FORMAT(72A1)
	IF ((DD(1).EQ.'H').AND.(DD(2).EQ.'E').AND.(DD(3).EQ.'L').AND.
     1 (DD(4).EQ.'P')) GO TO 24
	K=0
	DO 232 I=1,72
	IF (DD(I).EQ.',') K=K+1
232	CONTINUE
	IF (K.GT.0) GO TO 235
C
C
C
234	REREAD 2340, DMISS(1)
2340	FORMAT(20F)
	IF (M.EQ.1) GO TO (30,50), IBNK+1
	DO 2341 I=2,M
2341	DMISS(I)=DMISS(1)
	GO TO (30,50), IBNK+1
C
C
C
235	K=MIN0(20,M)
	REREAD 2340, (DMISS(I),I=1,K)
	IF (K.EQ.M) GO TO (30,50), IBNK+1
	READ(ICC,2340,ERR=24) (DMISS(I),I=21,M)
	GO TO (30,50), IBNK+1
C
C**********************************************************************
C	HELP FOR MISSING DATA
C**********************************************************************
C
24	WRITE(IDLG,240) 
240	FORMAT('-There are two ways of entering missing data value(s).'/
     1/' (1)  A single value may be entered and be used as missing data
     2 symbol'/6X,'for all variables in the analysis or'//
     3 ' (2)  A value is entered for each of the variables in the order
     4 of their'/6X,'appearance, separated by commas and 20 values
     5 per line.'/)
	IF (ICODE.GE.0) GO TO 230
	CALL EXIT
C
C=====================================================================
C	FOR NON-DATA BANK ONLY
C=====================================================================
C
30	IF (IDEVI.NE.'TTY') GO TO 31
	WRITE(IDLG,300)
300	FORMAT(' ENTER DATA')
	IF (ISTD.EQ.1) WRITE(IDLG,301)
301	FORMAT(' Format assumed:  (20F)')
	GO TO 32
31	WRITE(IDLG,310)
310	FORMAT(' Please wait, your data is being processed'/)
32	NPT=1
33	NNT=0
34	READ(INP,NOTF,ERR=410,END=42) (VEC(J),J=1,M)
	T=T+1
35	IF (NSEC.LE.0) GO TO  40
C
	IZE=1
	I=0
36	I=I+1
	IF (I.GT.NSEC) GO TO 37
	J1=NCON(I)
	DO 3610 J2=1,NVAL(I)
	GO TO (361,362,363,364,365,366), J1
C
361	IF (VEC(NVAR(I)).EQ.VALUE(J2,I)) 3611,3612
362	IF (VEC(NVAR(I)).GT.VALUE(J2,I)) 3611,3612
363	IF (VEC(NVAR(I)).GE.VALUE(J2,I)) 3611,3612
364	IF (VEC(NVAR(I)).LT.VALUE(J2,I)) 3611,3612
365	IF (VEC(NVAR(I)).LE.VALUE(J2,I)) 3611,3612
366	IF (VEC(NVAR(I)).EQ.VALUE(J2,I))  GO TO 3612
C
3611	IZE=0
36110	IF (I.EQ.NSEC) GO TO 37
	IF (NOR(I).NE.NOR(I+1)) GO TO 36
	I=I+1
	GO TO 36110
C
3612	IF (J2.NE.NVAL(I)) GO TO 3610
	IF (I.NE.NSEC) GO TO 3613
36120	IZE=1
	GO TO 34
3613	IF (NOR(I).NE.NOR(I+1)) 36120,36
3610	CONTINUE
C
37	IF (IZE.NE.0) GO TO 34
C
C
40	NNT= NNT+1
	N1=(NNT-1)*M
	DO 41 J=1,M
	N1=N1+1
	J1=NUM(J)
	X(N1)=VEC(J1)
	IF (MODE(J).EQ.2)X(N1)=IVEC(J1)
41	CONTINUE
	IF (NNT-NT) 34,43,43
C
C
410	IJ=T+1
	WRITE(IDLG,411) IJ
411	FORMAT('-WARNING:  Illegal character in observation:',I7/
     1 9X,'Program proceeds ignoring the observation'/)
	GO TO 34
C
C*********************************************************************
C	EOF IN DATA FILE OR VECTOR X IS FULL
C*********************************************************************
C
42	NPT=2
	IF (T.LE.0) GO TO 47
	IF (NT.LE.0) GO TO 46
C
C
43	IF (IPAIR-1) 44,44,45
44	CALL SUM(NTSUB,NNT,M,DMISS,SUMX,SUMX2)
	GO TO (33,46),NPT
45	CALL SUMP(NNT,M,DMISS,SUMX,SUMXY,SUMX2,SUMY2,SUMY,NSUB)
	NTSUB=NTSUB+NNT
	GO TO (33,46), NPT
C
C
46	IF ((IPAIR.EQ.2).OR.((IPAIR.EQ.1).AND.(NTSUB.GT.0))) GO TO 70
47	WRITE(IDLG,470)
470	FORMAT('-ERROR:  No calculation done on ZERO observations'/)
	RETURN
C
C=======================================================================
C	FOR DATA BANK ONLY
C=======================================================================
C
50	WRITE(IDLG,310)
	ISET=(NOBNK+124)/125
	IF (NT.GT.NOBNK) GO TO 500
	IF (NT.GT.125) NT=125
	NPT=(NT+124)/NT
	GO TO 510
500	NT=NOBNK
	NPT=1
510	DO 51 I=1,NPT
	IST=(I-1)*NT+1
	LAST=I*NT
	IF (LAST.GT.125) LAST=125
	DO 52 J=1,ISET
	IF ((J.NE.ISET).OR.(ISET.EQ.1)) GO TO 53
	J1=MOD(NOBNK,125)
	IF (LAST.GT.J1) LAST=J1
	IF(LAST.EQ.0) LAST=125
C
C***********************************************************************
C	0 IN IWORK MEANS GOOD DATA
C***********************************************************************
C
53	IF (NSEC.GT.0) GO TO 55
	DO 54 J1=1,125
54	IWORK(J1)=0
	GO TO 63
C
C
55	DO 550 J2=IST,LAST
	IWORK(J2)=1
	J1=0
	IZ1=1
56	J1=J1+1
	IF (J1.GT.NSEC) GO TO 550
	IZ=1+J+(NVAR(J1)-1)*ISET
	IF (IZ.EQ.IZ1) GO TO 560
	READ(INP#IZ) IDUM
	IZ1=IZ
560	K=NCON(J1)
	DO 57 K1=1,NVAL(J1)
	GO TO (571,572,573,574,575,576), K
C
C
571	IF (DUM(J2).EQ.VALUE(K1,J1)) 5710,5720
572	IF (DUM(J2).GT.VALUE(K1,J1)) 5710,5720
573	IF (DUM(J2).GE.VALUE(K1,J1)) 5710,5720
574	IF (DUM(J2).LT.VALUE(K1,J1)) 5710,5720
575	IF (DUM(J2).LE.VALUE(K1,J1)) 5710,5720
576	IF (DUM(J2).EQ.VALUE(K1,J1)) GO TO 5720
C
C
5710	IWORK(J2)=0
5711	IF (J1.EQ.NSEC) GO TO 550
	IF (NOR(J1).NE.NOR(J1+1)) GO TO 56
	J1=J1+1
	GO TO 5711
C
5720	IF (K1.NE.NVAL(J1)) GO TO 57
	IF (J1.NE.NSEC) GO TO 5721
5722	IWORK(J2)=1
	GO TO 550
5721	IF (NOR(J1).NE.NOR(J1+1)) 5722,56
57	CONTINUE
550	CONTINUE
C
C
63	DO 64 J1=1,M
	J2=1+(NUM(J1)-1)*ISET+J
	READ(INP#J2) DUM
	K=0
	DO 65 J3=IST, LAST
	IF (IWORK(J3).EQ.1) GO TO 65
	K=K+1
	K1=(K-1)*M+J1
	X(K1)=DUM(J3)
	IF ((MODE(J1).EQ.2).AND.(DUM(J3).NE.DMISS(J1)).AND.(DUM(J3)
     1.NE.AMISS)) X(K1)=IDUM(J3)
65	CONTINUE
64	CONTINUE
	GO TO (66,67), IPAIR
66	CALL SUM(NTSUB,K,M,DMISS,SUMX,SUMX2)
	GO TO 52
67	CALL SUMP(K,M,DMISS,SUMX,SUMXY,SUMX2,SUMY2,SUMY,NSUB)
	NTSUB=NTSUB+K
52	CONTINUE
51	CONTINUE
	T=NOBNK
C
C
70	IF(IOPT(10)+IOPT(11).LE.0) GOTO 7000
C
C	THIS IS FOR MISSR & MISSM OPTIONS ONLY
C
	DO 474 I=1,M
	II=I+(I*I-I)/2
	IZE=NSUB(II)
	SUMY(I)=9999E18
	VAR=9999E18
	SUMY2(I)=9999E18
	IF(IZE.GT.0) SUMY(I)=SUMX(II)/IZE
	IF(IZE.LE.1) GOTO 474
	VAR=(IZE*SUMX2(II)-SUMX(II)**2)/(IZE*(IZE-1))
	IF(VAR.LT.0) PAUSE 'VARIANCE NEGITIVE PROGRAM ERROR!'
	SUMY2(I)=SQRT(VAR)
474	CONTINUE
	CALL SUMT(NTSUB,M,DMISS,SUMX,SUMX2,SUMY,SUMY2,NSUB)
	IPAIR=1
C
C	WRITE OUT # OF VARIABLES AND OBS.
C
7000	IF(IDEVO.EQ.'TTY') GOTO 700
	WRITE(IOUT,70222) M,NTSUB
70222	FORMAT('-',29X,'Number of variables',9X,'=',I7/
     .	30X,'Number of observations used =',I7)
	CALL PAGE
700	IF(IDEVO.EQ.'TTY') WRITE(IDLG,701) (ID(I),I=1,ISTOP)
	WRITE(IDLG,702) M,NTSUB
701	FORMAT(1H1,16A5)
702	FORMAT('-Number of variables',9X,'=',I7/' Number of observations
     1 used =',I7)
	IF (NTSUB.LE.0) RETURN
	WRITE(IOUT,703)
703	FORMAT('-VAR-',4X,'SAMPLE'/' IABLE',5X,'SIZE',11X,'M E A N',10X,
     1 'VARIANCE',9X,'STD.  DEV'/' -----',3X,6('-'),11X,7('-'),10X,
     2 8('-'),9X,9('-')/)
	IPAGE=IPAGE+6
C
C**********************************************************************
C	     CALCULATE MEAN, VARIANCE AND STANDARD DEVIATION
C**********************************************************************
C
	I=0
771	I=I+1
7771	IF(I.GT.M) GOTO 773
	II=I+(I*I-I)/2
	GO TO (72,73), IPAIR
72	I1=I
	IZE=NTSUB
	GO TO 74
73	I1=II
	IZE=NSUB(II)
74	XMEAN=9999E18
	VAR=9999E18
	SD=9999E18
	IF (IZE.GT.0) XMEAN=SUMX(I1)/IZE
	IF (IZE.LE.1) GO TO 771
	VAR=(IZE*SUMX2(II)-SUMX(I1)**2)/(IZE*(IZE-1))
	IF(VAR) 772,772,71
772	CALL COLAPS(M,I,IPAIR,NAME,NSUB,SUMX,SUMY,SUMX2,SUMY2,SUMXY)
	GOTO 7771
71	SD=SQRT(VAR)
	IF(IPAGE+1.LE.MAXPAG) GOTO 85
	CALL PAGE
	WRITE(IOUT,703)
	IPAGE=IPAGE+5
85	IPAGE=IPAGE+1
	WRITE(IOUT,710) NAME(I),IZE,XMEAN,VAR,SD
710	FORMAT(1X,A5,I9,3F18.4)
	GOTO 771
C
C**********************************************************************
C	NO CORRELATION CALCULATED IF NUMBER OF VARIABLE IS 0 OR 1,
C	     OR IF MEAN OPTION ELECTED.
C**********************************************************************
C
773	IF (M.LE.1) RETURN
	IF (IOPT(8).EQ.1) RETURN
C
C**********************************************************************
C	     CALCULATE CORRELATION
C**********************************************************************
C
75	IF(IPAGE+12.GT.MAXPAG) CALL PAGE
	IPAGE=IPAGE+5
	WRITE(IOUT,750)
750	FORMAT(//'-CORRELATIONS')
	INUM=7
	IF (IDEVO.NE.'TTY') INUM=13
	I2=INUM-1
	LOOP=(M+I2)/INUM
	IF (IPAIR.EQ.1) CALL COR(M,NTSUB,SUMX,SUMX2,SUMXY)
	IF (IPAIR.EQ.2) CALL CORP(M,NSUB,SUMX,SUMY,SUMXY,SUMX2,
     1 SUMY2,NAME)
C#######################################################
C
C	PATCH 1
C	THIS PATCH IS TO INSURE DIAGONAL IS 1.00
C	9-17-75  D.S.
C
	K=0
	DO 71000 I=1,M
	DO 71000 J=1,I
	K=K+1
	IF(I.EQ.J) SUMXY(K)=1.
71000	CONTINUE
C#####################################################
C
	CALL OUT(1,M,NAME,SUMXY,NSUB)
	IF (IOPT(9).EQ.1) CALL MATRIX(M,NAME,SUMXY,SUMX2)
	GO TO (77,76),IPAIR
76	IF(IPAGE+12.GT.MAXPAG) CALL PAGE
	IPAGE=IPAGE+5
	WRITE(IOUT,760)
760	FORMAT(//'-SAMPLE SIZES')
	CALL OUT(2,M,NAME,SUMXY,NSUB)
C
C***********************************************************************
C	T-VALUE
C***********************************************************************
C
77	IF (IOPT(1).NE.1) GO TO 80
C
C	Z AND T VALUES ARE INVALID FOR "MISSM" AND "MISSR" OPTONS
C
	IF(IOPT(10)+IOPT(11).GT.0) RETURN
	IF(IPAGE+12.GT.MAXPAG) CALL PAGE
	IPAGE=IPAGE+5
	WRITE(IOUT,790)
790	FORMAT(//'-T-VALUE')
	IF  (IPAIR.NE.1) GO TO 79
	IF (NTSUB.GT.2) GO TO 78
	WRITE(IDLG,770)
770	FORMAT('-WARNING:  Sample size too small for T-value calculat
     .ion'/)
	GO TO 80
C
C
78	DN=NTSUB-2
79	CALL TVAL(M,IPAIR,DN, SUMXY,SUMX2,NSUB,NAME)
	CALL OUT(1,M,NAME,SUMX2,NSUB)
C
C***********************************************************************
C	Z-VALUE
C***********************************************************************
C
80	IF (IOPT(2).NE.1) RETURN
	IF(IPAGE+12.GT.MAXPAG) CALL PAGE
	IPAGE=IPAGE+5
	WRITE(IOUT,84)
84	FORMAT(//'-Z-VALUE')
	IF (IPAIR.NE.1) GO TO 83
	IF (NTSUB.GT.3) GO TO 82
	WRITE(IDLG,81)
81	FORMAT('-WARNING:  Sample size too small for Z-value calculat
     .ion'/)
	RETURN
C
C
82	DN=NTSUB-3
83	CALL ZVAL(M,IPAIR,DN,SUMXY,SUMX2,NSUB,NAME)
	CALL OUT(1,M,NAME,SUMX2,NSUB)
	RETURN
	END
*
***********************************************************************
*
	SUBROUTINE SUM(NT,K,M,DMISS,SUMX,SUMX2)
C
C***********************************************************************
C	SUBROUTINE THAT CALCULATES SUMS AND SUMS OF SQUARES OF VARIABLES
C	IT ALSO REJECTS ENTIRE OBSERVATION SHOULD THERE BE ANY
C	MISSING DATA SYMBOL PRESENT.
C
C	NT------NUMBER OF OBSERVATIONS CONSIDERED SO FAR
C	K-------NUMBER OF OBSERVATIONS TO BE CONSIDERED
C	M-------NUMBER OF VARIABLES
C	DMISS---VECTOR CONTAINING MISSING DATA SYMBOL(S)
C	SUMX----VECTOR CONTAINING SUM OF X
C	SUMX2---VECTOR CONTAINING SUM OF XY
C***********************************************************************
C
	DIMENSION DMISS(1),SUMX(1),SUMX2(1)
	COMMON/SBNK/NVBNK,NOBNK,NDBNK(2),NPBNK(2),X(5000)
	EQUIVALENCE (AMISS,MISS)
	IF (K.LE.0) RETURN
	MISS="400000000000
	DO 10 L=1,K
	L1=(L-1)*M
	DO 11 J=L1+1,L*M
	J1=L1-J
	IF ((X(J).EQ.DMISS(J-L1)).OR.(X(J).EQ.AMISS)) GO TO 10
11	CONTINUE
	NT=NT+1
	DO 12 I=1,M
	SUMX(I)=SUMX(I)+X(L1+I)
	II=(I*I-I)/2
	DO 12 J=1,I
	JI=J+II
12	SUMX2(JI)=SUMX2(JI)+X(L1+I)*X(L1+J)
10	CONTINUE
	RETURN
	END
*
***********************************************************************
*
	SUBROUTINE SUMP(K,M,DMISS,SUMX,SUMXY,SUMX2,SUMY2,SUMY,NSUB)
C
C**********************************************************************
C	SUBROUTINE THAT CALCULATES SUMS AND SUMS OF SQUARES OF VARIABLES
C	FOR THE PAIR-WISE METHOD.
C
C	K------# OF OBSERVATIONS TO BE CONSIDERED
C	M------# OF VARIABLES
C	DMISS--VECTOR CONTAINING MISSING DATA SYMBOLS
C	SUMX---SUM OF X VECTOR
C	SUMXY--SUM OF X*Y VECTOR
C	SUMX2--SUM OF X*X VECTOR
C	SUMY2--SUM OF Y*Y VECTOR
C	SUMY---SUM OF Y VECTOR

C	NSUB---# OF CASES IN EACH CELL
C***********************************************************************
C
	DIMENSION DMISS(1),SUMX(1),SUMXY(1),SUMX2(1),SUMY2(1),
     1 SUMY(1),NSUB(1)
	COMMON/SBNK/NVBNK,NOBNK,NDBNK(2),NPBNK(2),X(5000)
	COMMON /MANSEG/NAM(2),IXBLK(100),MAXBLK,NXBLK,IDSK
	COMMON /SOPT/IOPT(11),DEVTMP,DEVMOD
	EQUIVALENCE (AMISS,MISS)
	IF (K.LE.0) RETURN
	MISS="400000000000
	DO 10 L=1,K
	K1=1
	L1=(L-1)*M
	DO 20 I=1,M
	X1=X(L1+I)
	IF ((X1.EQ.AMISS).OR.(X1.EQ.DMISS(I))) GO TO 21
	DO 30 J=1,I
	Y=X(L1+J)
	IF ((Y.EQ.AMISS).OR.(Y.EQ.DMISS(J))) GO TO 31
	SUMX(K1)=SUMX(K1)+X1
	SUMY(K1)=SUMY(K1)+Y
	SUMX2(K1)=SUMX2(K1)+X1*X1
	SUMY2(K1)=SUMY2(K1)+Y*Y
	SUMXY(K1)=SUMXY(K1)+X1*Y
	NSUB(K1)=NSUB(K1)+1
31	K1=K1+1
30	CONTINUE
	GO TO 20
21	K1=K1+I
20	CONTINUE
10	CONTINUE
	IF(IOPT(10)+IOPT(11).LE.0) RETURN
	NXBLK=NXBLK+1
	IF(NXBLK.GT.MAXBLK) PAUSE 'DATA SET TOO LARGE CONTACT CENTER'
	IXBLK(NXBLK)=K
	WRITE(IDSK) X
	RETURN
	END
*
***********************************************************************
*

	SUBROUTINE COR(M,NTSUB,SUMX,SUMX2,SUMXY)
C
C***********************************************************************
C	SUBROUTINE THAT CALCULATES CORRELATIONS
C***********************************************************************
C
	DIMENSION NAME(1),SUMX(1),SUMX2(1),SUMXY(1)
	K=0
	DO 10 I=1,M
	I1=(I*I-I)/2+I
	D1=NTSUB*SUMX2(I1)-SUMX(I)*SUMX(I)
	DO 11 J=1,I
	J1=(J*J-J)/2+J
	D2=NTSUB*SUMX2(J1)-SUMX(J)*SUMX(J)
	D=D1*D2
	K=K+1
	IF (D.GT.0) GO TO 12
	SUMXY(K)=9999.999999
	GO TO 11
12	SUMXY(K)=(NTSUB*SUMX2(K)-SUMX(I)*SUMX(J))/SQRT(D)
11	CONTINUE
10	CONTINUE
	RETURN
	END
*
***********************************************************************
*
	SUBROUTINE CORP(M,NSUB,SUMX,SUMY,SUMXY,SUMX2,SUMY2,NAME)
C
C***********************************************************************
C	SUBROUTINE THAT CALCULATES CORRELATIONS ON PAIR-WISE METHOD
C***********************************************************************
C
	DIMENSION NSUB(1),NAME(1),SUMX(1),SUMY(1),SUMXY(1),SUMX2(1),
     1 SUMY2(1)
	COMMON /IOB/LFBR,IRTBR,IALT,MAXPAG,IPAGE,IPAGCT,IDLG
	K=0
	DO 10 I=1,M
	DO 11 J=1,I
	K=K+1

	IF (NSUB(K).GT.1) GO TO 12
	WRITE(IDLG,122)NAME(I),NAME(J)
	WRITE(IDLG,121)
121	FORMAT(11X,'FEWER THAN 2 VALID OBSERVATIONS')
110	SUMXY(K)=9999.999999
	GO TO 11
C	DX IS VARIANCE OF VARIABLE I
C	DY IS VARIANCE OF VARIABLE J
12	DX=(NSUB(K)*SUMX2(K)-SUMX(K)*SUMX(K))
	DY=(NSUB(K)*SUMY2(K)-SUMY(K)*SUMY(K))
	D=DX*DY
	IF (D.GT.0) GO TO 1101
	WRITE(IDLG,122)NAME(I),NAME(J)

122	FORMAT('-WARNING:  CORRELATION UNDEFINED AT POINT:  (',A5,
     1  ',',A5,')')
	IF(DX.EQ.0)WRITE(IDLG,123)NAME(I)
	IF(DY.EQ.0)WRITE(IDLG,123)NAME(J)
123	FORMAT(11X,'ZERO VARIANCE IN VALID OBSERVATIONS OF ',
     1  'VARIABLE:  ',A5)
	GO TO 110
1101	SUMXY(K)=(NSUB(K)*SUMXY(K)-SUMX(K)*SUMY(K))/SQRT(D)
11	CONTINUE
10	CONTINUE
	RETURN
	END
*
***********************************************************************
*
	SUBROUTINE TVAL(M,IPAIR,DN,SUMXY,SUMX2,NSUB,NAME)
C
C**********************************************************************
C	SUBROUTINE THAT CALCULATES T VALUES
C**********************************************************************
C
	DIMENSION SUMXY(1),SUMX2(1),NSUB(1),NAME(1)
	COMMON /IOB/LFBR,IRTBR,IALT,MAXPAG,IPAGE,IPAGCT,IDLG
	K=0
	DO 10 I=1,M
	DO 20 J=1,I
	K=K+1
	IF (I.NE.J) GO TO 21
	SUMX2(K)=0
	GO TO 20
21	T=SUMXY(K)
	ABST=ABS(T)
	IF (ABST.LT.1)GO TO (23,22), IPAIR
	WRITE(IDLG,30)NAME(I),NAME(J)
30	FORMAT('-WARNING:  T-VALUE UNDEFINED AT POINT:  (',A5,
     1  ',',A5,')')
	IF(ABST.EQ.1)WRITE(IDLG,31)
31	FORMAT(11X,'ABSOLUTE VALUE OF CORRELATION EQUAL TO 1')
	IF(ABST.NE.1)WRITE(IDLG,32)
32	FORMAT(11X,'CORRELATION UNDEFINED')
210	SUMX2(K)=9999.999999
	GO TO 20
22	IF (NSUB(K).GT.2) GO TO 221
	WRITE(IDLG,30)NAME(I),NAME(J)
	WRITE(IDLG,33)
33	FORMAT(11X,'FEWER THAN 3 VALID OBSERVATIONS')
	GO TO 210
221	DN=NSUB(K)-2
23	SUMX2(K)=T*SQRT(DN/(1-T**2))
20	CONTINUE
C20	CONTINUE
10	CONTINUE
	RETURN
	END
*
***********************************************************************
*
	SUBROUTINE ZVAL(M,IPAIR,DN,SUMXY,SUMX2,NSUB,NAME)
C
C**********************************************************************
C	SUBROUTINE THAT CALCULATES Z VALUES
C**********************************************************************
C
	DIMENSION SUMXY(1),SUMX2(1),NSUB(1),NAME(1)
	COMMON /IOB/LFBR,IRTBR,IALT,MAXPAG,IPAGE,IPAGCT,IDLG
	K=0
	DO 10 I=1,M
	DO 20 J=1,I
	K=K+1
	IF (I.NE.J) GO TO 21
	SUMX2(K)=0
	GO TO 20
21	T=SUMXY(K)
	ABST=ABS(T)
	IF (ABST.LT.1) GO TO (23,22), IPAIR
	WRITE(IDLG,30)NAME(I),NAME(J)
30	FORMAT('-WARNING:  Z-VALUE UNDEFINED AT POINT:  (',A5,
     1  ',',A5,')')
	IF(ABST.EQ.1)WRITE(IDLG,31)
31	FORMAT(11X,'ABSOLUTE VALUE OF CORRELATION EQUAL TO 1')
	IF(ABST.NE.1)WRITE(IDLG,32)
32	FORMAT(11X,'CORRELATION UNDEFINED')
210	SUMX2(K)=9999.999999
	GO TO 20
22	DN=NSUB(K)-3
	IF (DN.GT.0) GO TO 23
	WRITE(IDLG,30)NAME(I),NAME(J)
	WRITE(IDLG,33)
33	FORMAT(11X,'FEWER THAN 4 VALID OBSERVATIONS')
	GO TO 210
23	SUMX2(K)=.5*SQRT(DN)*ALOG((1+T)/(1-T))
20	CONTINUE
10	CONTINUE
	RETURN
	END
*
***********************************************************************
*
	SUBROUTINE OUT(IWHERE,M,NAME,SUMXY,NSUB)
C
C**********************************************************************
C	OUTPUT SUBROUTINE
C**********************************************************************
C
	DIMENSION NAME(1),SUMXY(1),NSUB(1)
	COMMON/IOBLK/INP,IOUT,IDEVI,IDEVO,IBNK,NAMI,NAMO,IPROJ,IPROG
	COMMON /IOB/LFBR,IRTBR,IALT,MAXPAG,IPAGE,IPAGCT,IDLG,ICC,ICODE
	COMMON/SOUT/LOOP,INUM,I2
	DOUBLE PRECISION DOT,NAMI,NAMO
	DATA DOT/'.........'/
	DO 10 J=1,LOOP
	NPT=(J-1)*INUM+1
	LAST=J*INUM
	IF (M.LE.LAST) LAST=M
	IF(IPAGE+7.GT.MAXPAG) CALL PAGE
	IPAGE=IPAGE+5
	WRITE(IOUT,11) (NAME(I),I=NPT,LAST)
11	FORMAT('-',5X,13(4X,A5))
	WRITE(IOUT,12) (DOT,NDOT=NPT,LAST)
12	FORMAT(6X,'..',13A9)
	WRITE(IOUT,13)
13	FORMAT(6X,'.')
	INC=-1
	DO 20 I=NPT, M
	INC=INC+1
	IF (INC.GE.INUM) INC=I2
	J1=(I*I-I)/2+NPT
	J2=J1+INC
	GO TO (200,201),IWHERE
200	IPAGE=IPAGE+1
	IF(IPAGE.LE.MAXPAG) GOTO 14
	CALL PAGE
	WRITE(IOUT,11) (NAME(II),II=NPT,LAST)
	WRITE(IOUT,12) (DOT,NDOT=NPT,LAST)
	IPAGE=IPAGE+5
14	WRITE(IOUT,21) NAME(I), (SUMXY(K),K=J1,J2)
21	FORMAT(1X,A5,'.',1X,13F9.5)
	GO TO 20
201	IPAGE=IPAGE+1
	IF(IPAGE.LE.MAXPAG) GOTO 15
	CALL PAGE
	WRITE(IOUT,11) (NAME(II),II=NPT,LAST)
	WRITE(IOUT,12) (DOT,NDOT=NPT,LAST)
	IPAGE=IPAGE+5
15	WRITE(IOUT,202) NAME(I), (NSUB(K),K=J1,J2)
202	FORMAT(1X,A5,'.',1X,13(I7,2X))
20	CONTINUE
10	CONTINUE
	RETURN
	END
*
***********************************************************************
*
	SUBROUTINE OPTION
C
C**********************************************************************
C	SUBROUTINE THAT DETERMINES WHICH OPTION IS ELECTED
C**********************************************************************
C
	DIMENSION IDUM(72),LIST(11),ISAVE(5)
C
C
C
	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(11),DEVTMP,DEVMOD
	DOUBLE PRECISION NAMI,NAMO
C
C
C
	DATA LIST/'TVALU','ZVALU','MISSV','MISSP','SELEC','HEADE',
     1 'FORMA','MEAN','MATRI','MISSM','MISSR'/
	DATA IDOL/'$'/
C
C
C
1	NPT=1
	WRITE(IDLG,100)
100	FORMAT(' OPTIONS?'/)
	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 10 I=1,11
10	IOPT(I)=0
C
C
C
	DO 2 LAST=72,1,-1
	IF (IDUM(LAST).NE.' ') GO TO 200
2	CONTINUE
	RETURN
C
C
C
200	DO 20 I=1,5
20	ISAVE(I)=' '
	IS=0
	DO 21 I=1,LAST
	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.5) GO TO 21
	IS=IS+1
	ISAVE(IS)=L
	GO TO 21
C
C
C
22	K=' '
	ENCODE(5,220,K) ISAVE
220	FORMAT(5A1)
	IF (K.EQ.'HELP') GO TO 40
	IF (K.EQ.'NONE') RETURN
	IF ((K.EQ.'ALL').OR.(K.EQ.'*')) GO TO 26
	DO 23 J=1,11
	IF (K.EQ.LIST(J)) GO TO 25
23	CONTINUE
	WRITE(IDLG,24) K
24	FORMAT('-ERROR:  Option code "',A5,'" Does not exist,
     1 Try again'/)
	IF (ICODE.GE.0) GO TO 1
	CALL EXIT
C
C
C
25	IF ((IBNK.NE.1).OR.(J.NE.7)) IOPT(J)=1
	IF ((IBNK.EQ.1).AND.(J.EQ.7)) WRITE(IDLG,252)
252	FORMAT('-WARNING:  Cannot use FORMAT with a data BANK'/9X,'Pr
     .ogram will ignore this option'/)
	IF(IOPT(10)+IOPT(11)+IOPT(4).GT.1) GOTO 991
253	IF ((NPT.GT.1).OR.((I.EQ.LAST).AND.((L.EQ.IALT).OR.(L.EQ.IDOL)))
     1) RETURN
	DO 250 J=1,5
250	ISAVE(J)=' '
	IS=0
21	CONTINUE
	IF (IS.LE.0) RETURN
	NPT=2
	GO TO 22
C
C
C
26	LAST=7
	IF (IBNK.NE.1) GO TO 260
	LAST=6
	WRITE(IDLG,252)
260	DO 27 J=1,LAST
27	IOPT(J)=1
30	RETURN
C
C
C
C	ERROR MISSP-MISSM-MISSR USED TOGETHER
C
991	WRITE(IDLG,992)
992	FORMAT('-ERROR:  Options "MISSP","MISSM" or "MISSR" may
     . not be used together'/' Please reenter the line'/)
	IOPT(10)=0
	IOPT(11)=0
	IOPT(4)=0
	GOTO 1
C
C
40	WRITE(IDLG,41)
41	FORMAT('-Options available are:'//' CODE     DESCRIPTION'/
     1 1X,4('-'),5X,11('-')/' TVALUE   T-value statistics'/
     2 ' ZVALUE   Z-value statistics'/' MISSV    Option to enter
     3 missing value symbol(s).  In the case of a'/10X,'data BANK file,
     4  This option enables other symbol(s) to be'/10X,'treated
     5 as missing data without altering the BANK.'/' MISSP    This
     6 option is mandatory if missing data is to be treated'/10X,'Pair-
     7wise instead of observation-wise.'/' MISSM	 This option
     . replaces MEANS for missing data'/' MISSR	 This option
     . replaces a random normal number'/10X,'with the same mean and 
     . standard deviation for missing data'/' SELECT   Option to consider
     8 only those observations meeting user'/10X,'specified criteria'/
     9 ' HEADER   A line of at most 80 columns to be used as HEADER'/
     .' MATRIX   Option to output Correlations on a disk file'/
     1' FORMAT   Option to enter own FORMAT; default: (20F)'/' MEAN',5x,
     2 'Output MEAN and Standard Deviation only'/1X,12('-')/
     3 ' ALL      All of the options listed above'/' NONE     None
     4 of the options listed'/' SAME     Maintain the options used
     5 in the previous run'//' Enter the desired options in a line
     6 separated by commas.'/)
	IF (ICODE.GE.0) GO TO 1
	CALL EXIT
	END
*
***********************************************************************
*
	SUBROUTINE MATRIX(M,NAME,SUMXY,SUMX2)
C
C***********************************************************************
C	THIS IS A SPECIAL SUBROUTINE WRITTEN FOR SAM ANEMA AND MICHAEL
C	STOLINE OF WMU.  IT CREATES A DATA FILE CONSISTING THE
C	CORRELATION MATRIX AND THE VECTOR CONTAINING THE NAMES OF THE
C	VARIABLES.  THE FILE IS TO BE USED AS AN INPUT TO ANOTHER WMU
C	LIBRARY PROGRAM. 
C**********************************************************************
C
	DIMENSION NAME(1),SUMXY(1),SUMX2(1)
	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(11),DEVTMP,DEVMOD
	COMMON /MANSEG/NAM(2),IXBLK(100),MAXBLK,NXBLK,IDSK
	DOUBLE PRECISION NAMI,NAMO,NFILE
	EQUIVALENCE (NFILE,NAM)
	NAM(1)='00001'
	NAM(2)='.MAT'
10	CALL EXIST(NFILE,I)
	IF (I.EQ.1) GO TO 11	
	NAM(1)=NAM(1)+1
	GO TO 10
11	OPEN(UNIT=IDSK,FILE=NFILE,MODE='ASCII',ACCESS='SEQOUT',PROTECTION=
     1 "155)
	J2=0
	DO 20 J=1,M-1
	J1=J2+1
	J2=(J*J-J)/2+J
	I1=0
	DO 21 I=J1,J2
	I1=I1+1
21	SUMX2(I1)=SUMXY(I)
	DO 22 I=J+1,M
	I1=I1+1
	IJ=(I*I-I)/2+J
22	SUMX2(I1)=SUMXY(IJ)
20	WRITE(IDSK,23) (SUMX2(I),I=1,I1)
23	FORMAT(10F8.5)
	WRITE(IDSK,23) (SUMXY(I),I=J2+1,J2+M)
C	WRITE(IDSK,24) (NAME(I),I=1,M)
C24	FORMAT(16A5)
	CLOSE(UNIT=IDSK)
	WRITE(IDLG,30) NFILE
30	FORMAT('-Matrix file called ',A10)
	IF(IOPT(4).EQ.1) WRITE(IDLG,31)
31	FORMAT('-WARNING:  Pairwise deletion can result in "impossible
     ." Covariance '/' matrices and subsequent analysis will be
     . erroneous as a result.'/)
	RETURN
	END
*
***********************************************************************
*
	SUBROUTINE COLAPS(NUM,IDEL,IPAIR,NAME,NSUB,SUMX,SUMY,SUMX2,SUMY2
     .	,SUMXY)
***********************************************************************
*
*	THIS SUBROUTINE COLAPSES ALL ARRAYS IN THE EVENT OF ZERO VARIANCE
*	IT ALSO TELLS THE USER THAT IT IS DELETING A VARIABLE
*
************************************************************************
	COMMON /IOBLK/INP,IOUT,IDEVI,IDEVO,IBNK,NAMI,NAMO,IPROJ,IPROG
	COMMON /IOB/LFBR,IRTBR,IALT,MAXPAG,IPAGE,IPAGCT,IDLG,ICC,ICODE
	DIMENSION NAME(1),NSUB(1),SUMX(1),SUMY(1),SUMX2(1),SUMY2(1),
     .	SUMXY(1)
	DOUBLE PRECISION NAMI,NAMO
C
C	OUTPUT WARNING MESSAGE
C
	WRITE(IDLG,100) NAME(IDEL)
100	FORMAT('-WARNING:  Variable "',A5,'" was deleted due
     . to ZERO variance'/)
C
C	SHIFT NAME VECTOR
C
	IF(IDEL.GE.NUM) GOTO 999
	DO 1 I=IDEL,NUM-1
1	NAME(I)=NAME(I+1)
	IPOS=(IDEL*(IDEL-1))/2
	GOTO (2,3),IPAIR
C
C	NOT PAIR WISE
C
2	N=IPOS+IDEL-1
	DO 4 I=1,NUM-IDEL
	N=N+IDEL
	DO 4 J=1,I
	N=N+1
	SUMX2(N)=SUMX2(N+1)
4	SUMXY(N)=SUMXY(N+1)
	N=IPOS
	DO 5 I=IDEL,NUM-1
	SUMX(I)=SUMX(I+1)
	DO 5 J=1,I
	N=N+1
	SUMX2(N)=SUMX2(N+I)
5	SUMXY(N)=SUMXY(N+I)
	GOTO 999
C
C	PAIR WISE
C
3	N=IPOS+IDEL-1
	DO 6 I=1,NUM-IDEL
	N=N+IDEL
	DO 6 J=1,I
	N=N+1
	NSUB(N)=NSUB(N+1)
	SUMX(N)=SUMX(N+1)
	SUMY(N)=SUMY(N+1)
	SUMX2(N)=SUMX2(N+1)
	SUMY2(N)=SUMY2(N+1)
6	SUMXY(N)=SUMXY(N+1)
	N=IPOS
	DO 7 I=IDEL,NUM-1
	DO 7 J=1,I
	N=N+1
	NSUB(N)=NSUB(N+I)
	SUMX(N)=SUMX(N+I)
	SUMY(N)=SUMY(N+I)
	SUMX2(N)=SUMX2(N+I)
	SUMY2(N)=SUMY2(N+I)
7	SUMXY(N)=SUMXY(N+I)
C
C	SUBTRACT ONE VARIABLE
C
999	NUM=NUM-1
	RETURN
	END
*
***********************************************************************
*
	SUBROUTINE SUMT(NT,M,DMISS,SUMX,SUMX2,SUMY,SUMY2,NSUB)
C
C***********************************************************************
C	SUBROUTINE THAT CALCULATES SUMS AND SUMS OF SQUARES OF VARIABLES
C	IT ALSO ENTERS EITHER THE MEAN OR A RANDOM NORMAL FOR 
C	MISSING DATA SYMBOL PRESENT.
C
C	NT------NUMBER OF OBSERVATIONS
C	M-------NUMBER OF VARIABLES
C	DMISS---VECTOR CONTAINING MISSING DATA SYMBOL(S)
C	SUMX----VECTOR CONTAINING SUM OF X
C	SUMX2---VECTOR CONTAINING SUM OF XY
C	SUMY----VECTOR CONTAINING MEANS
C	SUMY2---VECTOR CONTAINING STDEV.
***********************************************************************
C
	DIMENSION DMISS(1),SUMX(1),SUMX2(1),SUMY(1),SUMY2(1),NSUB(1)
	COMMON/SBNK/NVBNK,NOBNK,NDBNK(2),NPBNK(2),X(5000)
	COMMON /SOPT/IOPT(11),DEVTMP,DEVMOD
	COMMON /MANSEG/NAM(2),IXBLK(100),MAXBLK,NXBLK,IDSK
	DOUBLE PRECISION NFILE
	EQUIVALENCE (AMISS,MISS),(NFILE,NAM)
	MISS="400000000000
C
C	ZERO SUMX & SUMX2
C
	DO 13 I=1,M
13	SUMX(I)=0.
	DO 14 I=1,(M*(M+1)/2)
14	SUMX2(I)=0.
C
C	READ BACK INFO
C
	CLOSE (UNIT=IDSK)
	OPEN (UNIT=IDSK,DEVICE=DEVTMP,MODE=DEVMOD,ACCESS='SEQIN',FILE=
     .	NFILE)
	NT=0
	DO 1 IBLK=1,NXBLK
	READ(IDSK) X
	DO 10 L=1,IXBLK(IBLK)
	L1=(L-1)*M
	DO 11 J=L1+1,L*M
	J1=L1-J
	IF ((X(J).NE.DMISS(J-L1)).AND.(X(J).NE.AMISS)) GO TO 11
	IF(IOPT(10).EQ.1) X(J)=SUMY(J-L1)
	IF(IOPT(11).EQ.1) X(J)=RNORM(SUMY(J-L1),SUMY2(J-L1))
11	CONTINUE
	NT=NT+1
	DO 12 I=1,M
	SUMX(I)=SUMX(I)+X(L1+I)
	II=(I*I-I)/2
	DO 12 J=1,I
	JI=J+II
12	SUMX2(JI)=SUMX2(JI)+X(L1+I)*X(L1+J)
10	CONTINUE
1	CONTINUE
	CLOSE (UNIT=IDSK,DISPOSE='DELETE')
	RETURN
	END