Trailing-Edge
-
PDP-10 Archives
-
decuslib10-09
-
43,50466/corl.cor
There are no other files named corl.cor in the archive.
C WESTERN MICHIGAN UNIVERSITY
C CORL.COR (FILENAME ON LIBRARY DECTAPE)
C CORL, 1.2.4 (CALLING NAME, SUBLST #)
C CORRELATIONS, MEANS, STANDARD DEVIATIONS
C WRITTEN AT WMU BY B. HOUCHARD (JAN. 1974) LATER MODIFIED
C BY D. SCHULZ (1975)
C BNKLIB.FOR PROGRAMS USED: GETFRI, BNKNAM, VARLST, INFO,
C SELECT, PAGE, RNORM, IO, GETID, GETMOD
C LIBRARY DECTAPE PROGRAMS USED: USAGE.MAC
C FORWMU PROGS. USED: TTYPTY, ALLCOR, GES, EXIST, DEVCHR,
C GETPPN, EXISTS, RUNUUO, PRINTS, JOBNUM
C INTERNAL SUBR. USED: MAINL, SUM, SUMP, COR, CORP,
C TVAL, ZVAL, OUT, OPTION, COLAPS, SUMT, MATRIX
C ABOVE COMMENTS AND RIGHT ADJUSTED COMMENTS PUT IN BY WG
C
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 GES READS INPUT FROM TELETYPE WITH AN A1 FORMAT
C ALLOWS TERM. OF LINE WITH AN ALT.
C
C TTYPTY (*) DETERMINE IF JOB IS ON TELETYPE OR PSEUDO-
C TELETYPE
C
C USAGE (*) COUNTER FOR LIBRARY PROGRAMS USAGE
C
C EXIST CHECK FOR EXISTENCE OF A USER SPECIFIED
C FILE NAME
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 ALLCOR (*) TO ALLOCATE CORE DYNAMICALLY
C WESTERN MICHIGAN UNIVERSITY
C CORL.COR (FILENAME ON LIBRARY DECTAPE)
C CORL, 1.2.4 (CALLING NAME, SUBLST #)
C CORRELATIONS, MEANS, STANDARD DEVIATIONS
C WRITTEN AT WMU BY B. HOUCHARD (JAN. 1974) LATER MODIFIED
C BY D. SCHULZ (1975)
C BNKLIB.FOR PROGRAMS USED: GETFRI, BNKNAM, VARLST, INFO,
C SELECT, PAGE, RNORM, IO, GETID, GETMOD
C LIBRARY DECTAPE PROGRAMS USED: USAGE.MAC
C FORWMU PROGS. USED: TTYPTY, ALLCOR, GES, EXIST, DEVCHR,
C GETPPN, EXISTS, RUNUUO, PRINTS, JOBNUM
C INTERNAL SUBR. USED: MAINL, SUM, SUMP, COR, CORP,
C TVAL, ZVAL, OUT, OPTION, COLAPS, SUMT, MATRIX
C ABOVE COMMENTS AND RIGHT ADJUSTED COMMENTS PUT IN BY WG
C
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 GES READS INPUT FROM TELETYPE WITH AN A1 FORMAT
C ALLOWS TERM. OF LINE WITH AN ALT.
C
C TTYPTY (*) DETERMINE IF JOB IS ON TELETYPE OR PSEUDO-
C TELETYPE
C
C USAGE (*) COUNTER FOR LIBRARY PROGRAMS USAGE
C
C EXIST CHECK FOR EXISTENCE OF A USER SPECIFIED
C FILE NAME
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 ALLCOR (*) TO ALLOCATE 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
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 MATRIX CREATES MATRIX FILE FOR INPUT TO PATHAN
C
C (*) MACRO SUBROUTINE
C
C
C***********************************************************************
C
DIMENSION SPACE(1),IDUM(125)
C---------------SUBR. GETID, BNKNAM, SELECT, INFO, PAGE, VARLST,
C--------------- (BNKLIB.FOR) AND CORL SUBR. MAINL, OUT, OPTION, MATRIX,
C--------------- COLAPS SHARE COMMON /IOBLK/. IDEVO, NAMO,
C--------------- IPROG, IOUT, INP, IDEVI, NAMI, IPROJ ARE IN IO SUBR.
C--------------- ARG. LIST.
COMMON/IOBLK/INP,IOUT,IDEVI,IDEVO,IBNK,NAMI,NAMO,IPROJ,IPROG
C--------------- SUBR. IO (BNKLIB.FOR) AND MAINL, CORP, TVAL,
C--------------- ZVAL, OUT, OPTION, MATRIX, COLAPS (CORL) SHARE
C--------------- COMMON /IOB/
COMMON /IOB/LFBR,IRTBR,IALT,MAXPAG,IPAGE,IPAGCT,IDLG,ICC,ICODE,
. NOUT
C---------------SUBR. GETMOD, BNKNAM, SELECT, INFO, VARLST (BNKLIB.FOR)
C--------------- AND SUM, SUMP, (CORL) SHARE COMMON /SBNK/
C---------------SUBR. BNKNAM (P. 14 OF BNKLIB.FOR) SHOWS
C--------------- ITEMP(5000) ALLOCATED TO NOGOOD, IV, NOMAT,
C--------------- NAME, NUM, MODE
COMMON/SBNK/NVBNK,NOBNK,NDBNK(2),NPBNK(2),ITEMP(5000)
C---------------SUBR. GETFR1 (BNKLIB.FOR) AND MAINL(CORL) SHARE
C--------------- COMMON /SGETFR1/
COMMON/SGETFR/ISTD,ITYPE
C---------------SUBR. INFO (BNKLIB.FOR) AND MAINL (CORL) SHARE
C--------------- COMMON /FMT/
COMMON/FMT/NOTF(80) !MSL: EXPANDED FROM 48, 10-15-76
C---------------SUBR. MAINL, OPTION, MATRIX, SUMP,
C--------------- SUMT(CORL) SHARE COMMON /SOPT/
COMMON/SOPT/IOPT(11),DEVTMP,DEVMOD
C---------------SUBR. GETID, INFO, PAGE (BNKLIB.FOR) AND MAINL(CORL)
C--------------- SHARE COMMON /SID/
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=3
MAXPAG=58
IPAGCT=0
OFFSET=0
DEVTMP='DSKC'
DEVMOD='DUMP'
C
C
C
WRITE(IDLG,9977)
9977 FORMAT('-*** W.M.U. CORRELATION PROGRAM V2 ***'//)
C CALL USAGE('CORL')
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
C---------------TTYPTY RETURNS ZERO - TTY JOB, MINUS ONE - BATCH JOB
CALL TTYPTY(ICODE)
C---------------1 IN FIRST POS. MEANS OUTPUT?; IOUT - DEVICE
C--------------- NO. (MUST BE BETWEEN 1 AND 30); DEVNAME - TWO
C--------------- WORD QUANTITY RETURNED FROM IO CONTAINING THE DEVICE
C--------------- NAME INDICATED BY USER; IDEVO - SINGLE WORD QUANTITY
C--------------- RETURNED BY IO CONTAINING 'TTY' IF THE DEVICE IS A
C--------------- TELETYPE; NAMO - TWO WORD VAR. CONTAINING THE
C--------------- FILENAME (IF NEEDED) OF THE FILE REQUESTED BY USER;
C--------------- IBNK=0 MEANS FILE IS NOT A BANK FILE; =1 MEANS FILE IS
C--------------- A BANK FILE.
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
C---------------SEE ST. 32 BELOW
ITYPE=3
C
C
11 CALL OPTION
DO 110 I=1,16
110 ID(I)=' '
ISTOP=0
C---------------OPTION RETURNS IOPT(I) IN COMMON /SOPT/
IF (IOPT(6).EQ.1) CALL GETID
C---------------IBNK=0 MEAN NON BANK FILE; =1 MEANS BANK FILE
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
C---------------ITYPE=3 (SEE ST. 10+4 ABOVE) SENT, M= NO.
C--------------- OF VARS. RETURNED
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)=' '
C---------------SUBR. BNKNAM (P. 14 OF BNKLIB.FOR) SHOWS
C--------------- ITEMP(2601--3400)=NAME, ITEMP(3401--4200)=NUM,
C--------------- ITEMP(4201--5000)=MODE
DO 411 I=4201,4200+M
411 ITEMP(I)=0
GO TO 50
C
C
C---------------IOPT(5)=0 MEANS SELECT OPTION IS NOT CHOSEN,
C--------------- =1 MEANS SELECT OPTION IS CHOSEN, RETURNED BY SUBR.
C--------------- OPTION. ITYPE=3 SENT GETFR1 THRU COMMON /SGETFR/.
C--------------- SEE ST. 11-1. ITYPE=3 MEANS 'ENTER FORMAT ENCLOSED IN
C--------------- PARENTHESIS' WILL PRINT, ITYPE=0,1,2 MEANS IN ADDITION
C--------------- F, A, OR I 'TYPE ONLY' WILL PRINT. SEE GETFR1
C--------------- ST. 100 AND 101.
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)
C---------------MODE=0 MEANS FLOATING, =1 MEANS ALPHANUM., =2 MEANS
C--------------- INTEGER
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
C---------------DELETE ALPHANUM. CHAR. FROM CORL CALCULATIONS
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 (CONVERTED FROM GTCORE/LSCORE TO ALLCOR, MSL 14-JUN-77)
C***********************************************************************
C
C---------------USED WHEN THERE IS NO MISSING DATA
51 MAX=5*M+2*KN
CALL ALLCOR(MAX,IERR,OFFSET,SPACE(1))
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 MISSING DATA METHOD
C (CONVERTED FROM GTCORE/LSCORE TO ALLCOR, MSL 14-JUN-77)
C***********************************************************************
C
C---------------USED WHEN THERE IS MISSING DATA
55 MAX=4*M+6*KN
CALL ALLCOR(MAX,IERR,OFFSET,SPACE(1))
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 AND TO GO 'INPUT ?'
C*********************************************************************
C
60 WRITE(IDLG,600)
600 FORMAT(1H-)
GO TO 10
END
*
***********************************************************************
*
C---------------M IS INPUT. ALL OTHER ARGS. ARE SPACES RESERVED
C---------------BY DYN. ALLOC. IBNK, IDEVO, IDEVI, IOUT, INPUT THRU
C--------------- COMMON /IOBLK/. IPAGCT, IPAGE, MAXPAG,
C--------------- IDLG, ICC, ICODE, INPUT THRU COMMON /IOB/
C--------------- IPAGCT IS MODIFIED.
C---------------ITEMP, NOBNK INPUT THRU COMMON /SBNK/
C---------------ISTD INPUT THRU COMMON /SGETFR/
C---------------NOTF INPUT THRU COMMON /FMT/
C---------------IOPT, DEVTMP, DEVMOD ARE INPUT THRU COMMON
C--------------- /SOPT/
C---------------NVAR, NCON, VALUE, NVAL, NOR ARE INPUT THRU COMMON
C--------------- /SELEC/
C---------------NSEC MADE AVAIL. THRU COMMON /SELEC/ BY SUBR. MAINL
C---------------ID, ISTOP INPUT THRU COMMON /SID/
C---------------INUM, I2, LOOP MADE AVAIL. THRU COMMON /SOUT/ BY
C--------------- SUBR. MAINL
C---------------NAM, NXBLK, MAXBLK, IDSK MADE AVAIL. THRU COMMON
C--------------- /MANSEG/ BY SUBR. MAINL
C---------------SUBR. CALLED BY SUBR. MAINL:INFO (BNKLIB.FOR), SUM,
C--------------- SUMP, SUMT, COLAPS, COR, CORP, MATRIX, OUT,
C--------------- TVAL, ZVAL
C---------------FORWMU PROGS. USED BY SUBR. MAINL: EXIST (ST. 8800)
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
C---------------SUBR. INFO, PAGE(BNKLIB.FOR) SHARE COMMON /SINFO/
COMMON/SINFO/CALNAM,PROG(12)
C---------------SUBR. SELECT(BNKLIB.FOR) SHARES COMMON /SELEC/
COMMON/SELEC/NSEC,NVAR(20),NCON(20),VALUE(20,20),NVAL(20),
1 NOR(20)
C---------------SUBR. OUT(CORL) SHARES COMMON /SOUT/
COMMON/SOUT/LOOP,INUM,I2
C---------------SUBR. SUMT, MATRIX, SUMP(CORL) SHARE COMMON /MANSEG/
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**AM 1.2.4-1, MSL, 10-NOV-77
C
MMISS="400000000000
C
C**END MAINL, 8800-8
C
C---------------IOPT(I) PASSED THRU COMMON /SOPT/
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
C---------------SUBR. BNKNAM (P. 14 OF BNKLIB.FOR) SHOWS ITEMP
C--------------- P(2601--3400) = NAME, ITEMP(3401--4200) = NUM,
C--------------- ITEMP(4201-5000) = MODE
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
C---------------MM=M*(M+1)/2 AND M=NO. OF VARS.
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
C---------------MORE WORK CONNECTED WITH SELECT OPTION AND MAKING
C--------------- USE OF RESULTS PASSED THRU COMMON /SELEC/ BY SUBR.
C--------------- SELECT. IN BNKLIB.FOR
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
C---------------COME HERE FROM ST. 34
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
C---------------COMES FROM ST. 34
42 NPT=2
C---------------T=NO. OF OBS.
IF (T.LE.0) GO TO 47
IF (NT.LE.0) GO TO 46
C
C
43 IF (IPAIR-1) 44,44,45
C---------------SUMX2 HERE MEANS SUMXY. SEE SUBR. SUM
44 CALL SUM(NTSUB,NNT,M,DMISS,SUMX,SUMX2)
GO TO (33,46),NPT
C---------------SUMX2 HERE MEANS SUMX*X. SEE SUBR. SUMP.
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
C---------------MORE WORK CONNECTED WITH SELECT OPTION AND MAKING
C--------------- USE OF RESULTS PASSED THRU COMMON /SELEC/ BY SUBR.
C--------------- SELECT IN BNKLIB. FOR.
C---------------NOBNK=NO. OF OBS.
50 WRITE(IDLG,310)
C---------------COMES FROM ST. 23+1, 2341+1, 235+2, 235+4
ISET=(NOBNK+124)/125
C---------------NT=5000/M, SEE ST. 1+2, M=NO. OF VARS.
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
C---------------# OF PASSES PER 125 OBSERVATIONS
510 DO 51 I=1,NPT
IST=(I-1)*NT+1
LAST=I*NT
IF (LAST.GT.125) LAST=125
C---------------ISET=# OF SETS OF 125 OBSERVATIONS
DO 52 J=1,ISET
IF ((J.NE.ISET).OR.(ISET.EQ.1)) GO TO 53
C---------------SET LAST=J1 OR 125 DEPENDING ON WHETHER # OF OBS.
C--------------- IS NOT EVEN MULT. OF 125 OR # OF OBS. IS AN EVEN
C--------------- MULT. OF 125 RESP.
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, I.E. WITH SELECT OPTION, DATA
C***********************************************************************
C PASSING QUALIFIERS ARE GOOD.
C
C---------------NSEC=# OF QUALIFIERS
53 IF (NSEC.GT.0) GO TO 55
DO 54 J1=1,125
54 IWORK(J1)=0
GO TO 63
C
C
C---------------SEE CORL FOLDER FOR FURTHER INFO ABOUT THESE CODES
55 DO 550 J2=IST,LAST
IWORK(J2)=1
J1=0
IZ1=1
56 J1=J1+1
IF (J1.GT.NSEC) GO TO 550
C---------------SEE LAST PAGE OF BANK WRITE UP FOR DATA ARRANGEMENT
C--------------- (ALL OBS. ON VAR. 1 FIRST, THEN ALL OBS. ON VAR. 2,
C--------------- ETC.) IZ DETERMINES WHICH RECORD WE WANT TO READ.
IZ=1+J+(NVAR(J1)-1)*ISET
C---------------FIRST REC. IS HEADER AND WE START WITH IZ=Z
C---------------IF VAR. # OF QUALIFIER IS SAME AS VAR. # OF PREVIOUS
C--------------- QUALIFIER, THEN BYPASS READ ST.; OTHERWISE WE READ THE
C--------------- APPROPRIATE RECORD FROM RANDOM ACCESS FILE.
C--------------- NVAR(J1)=ID OF VAR. ASSOCIATED WITH J1TH QUALIFIER.
IF (IZ.EQ.IZ1) GO TO 560
READ(INP#IZ) IDUM
IZ1=IZ
C---------------THERE ARE SIX POSSIBILITIES FOR EACH NCON(J1). THEY
C--------------- ARE: EQ, GT, GE, LT, LE, NE.
560 K=NCON(J1)
C---------------NVAL IS # OF VALS. AFTER = IN A SELECT OPTION
C--------------- FOR J1TH QUALIFIER.
DO 57 K1=1,NVAL(J1)
GO TO (571,572,573,574,575,576), K
C
C
C---------------VALUE(I,J) IS THE ITH VALUE FOR
C--------------- THE JTH QUALIFIER.
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
C---------------NOR IS LINE # OF 'OR' QUALIFIERS.
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
C---------------NUM=NUM.ID. OF A VAR.
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)
C---------------MODE=2 MEANS INTEGER, DMISS IS MISSING DATA SYMBOL
C--------------- FOR NON-BANK FILES, AMISS IS MISSING DATA SYMBOL
C--------------- FOR BANK FILES. SEE ST. 23+1
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
C---------------SUMX2 HERE MEANS SUM XY. SEE SUBR. SUM.
66 CALL SUM(NTSUB,K,M,DMISS,SUMX,SUMX2)
GO TO 52
C---------------SUMX2 HERE MEANS SUM OF X*X. SEE SUBR. SUMP.
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
C---------------MEAN IS 8TH ITEM LISTED IN DATA LIST OF SUBR. OPTION
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
*
***********************************************************************
*
C---------------K, M, NT, DMISS ARE INPUT. SUMX, SUMX2 ARE OUTPUT.
C--------------- X IS INPUT THRU COMMON /SBNK/
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
C---------------THIS OCTAL NO.=SMALLEST POSSIBLE NO. FOR
C--------------- BANK FILES. THIS IS MISSING DATA SYMBOL.
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
*
***********************************************************************
*
C---------------K, M, DMISS ARE INPUT. SUMX, SUMXY, SUMX2,
C--------------- SUMY2, SUMY, NSUB ARE OUTPUT.
C--------------- IDSK, NXBLK, MAXBLK ARE INPUT THRU COMMON /MANSEG/
C--------------- IXBLK IS RETURNED THRU COMMON /MANSEG/
C--------------- IOPT INPUT THRU COMMON /SOPT/
C--------------- X IS INPUT THRU COMMON /SBNK/
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
C---------------MISS IS DEFINED BELOW.
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
*
***********************************************************************
*
C---------------M, NTSUB, SUMX, SUMX2 ARE INPUT. SUMXY RETURNED.
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
*
***********************************************************************
*
C---------------M, NSUB, NAME, SUMX2, SUMX, SUMY, SUMY2, ARE INPUT.
C--------------- SUMXY RETURNED. IDLG INPUT THRU COMMON /IOB/
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
*
***********************************************************************
*
C---------------M, IPAIR, NAME, SUMXY, NSUB ARE INPUT. DN, SUMX2
C--------------- RETURNED. IDLG INPUT THRU COMMON /IOB/
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
*
***********************************************************************
*
C---------------M, IPAIR, NAME, SUMXY, NSUB ARE INPUT. DN, SUMX2
C--------------- RETURNED. IDLG INPUT THRU COMMON /IOB/
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
*
***********************************************************************
*
C---------------ALL ARGS. ARE INPUT. LOOP, INUM ARE INPUT
C--------------- THRU COMMON /SOUT/. IOUT INPUT THRU COMMON /IOBLK/
C--------------- IPAGE, MAXPAGE INPUT THRU COMMON /IOB/
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
C---------------PAGE IS IN BNKLIB.FOR
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
*
***********************************************************************
*
C---------------IDLG, ICODE, IALT, INPUT THRU COMMON /IOB/; IOPT,
C--------------- MAXOPT, INPUT THRU COMMON /SOPT/; IBNK INPUT THRU
C--------------- COMMON /IOBLK/
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
C---------------IOPT(1),...,IOPT(11) CORRESPOND TO OPTIONS
C--------------- TVALU, ZVALU, MISSV, MISSP, SELECT, HEADER
C--------------- FORMAT, MEAN, MATRIX, MISSM, AND MISSR RESP.
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?'/)
C---------------GES(IN FORWMU); IDUM, IRET RETURNED
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
C---------------IOPT(I)=O MEANS OPTION I IS NOT CHOSEN. LATER IOPT(I)
C--------------- IS SET TO 1 WHEN USER CHOOSES ITH OPTION. SEE ST.
C--------------- 23, 23-1, 23-2, AND ST. 25.
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
*
***********************************************************************
*
C---------------M, NAME, SUMXY, ARE INPUT. SUMX2 RETURNED.
C--------------- IDSK INPUT THRU COMMON /MANSEG/, IDLG INPUT THRU
C--------------- COMMON /IOB/, IOPT INPUT THRU COMMON /SOPT/
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'
C---------------NFILE INPUT, I=0 FILE EXISTS AND NAME IS LEGAL,
C--------------- I= -1 NAME IS ILLEGAL, I=1 FILE NOT FOUND OR NOT
C--------------- READABLE
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
*
***********************************************************************
*
C---------------ALL ARGS. ARE INPUT. SUMX2, SUMXY, SUMX, SUMY, SUMY2,
C--------------- NSUB ARE MODIFIED. IDLG INPUT THRU COMMON /IOB/
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
*
***********************************************************************
*
C---------------M, DMISS, SUMX, SUMY, SUMY2, SUMX2 ARE
C--------------- INPUT. NT RETURNED. NSUB NOT USED. SUMX, SUMX2
C--------------- ARE MODIFIED
C---------------NAM, NXBLK, IXBLK, IDSK ARE INPUT THRU COMMON /MANSEG/
C---------------IOPT, DETMP, DEVMOD INPUT THRU COMMON /SOPT/
C---------------X RETURNED THRU COMMON /SBNK/
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