Trailing-Edge
-
PDP-10 Archives
-
decuslib10-09
-
43,50466/tab.tab
There are no other files named tab.tab in the archive.
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