Trailing-Edge
-
PDP-10 Archives
-
decus_20tap2_198111
-
decus/20-0047/cross1.for
There is 1 other file named cross1.for in the archive. Click here to see a list.
C PROGRAM CROSS1
C (DATA ANALYSIS PART OF PROGRAM CROSS)
C
C DESCRIPTION
C THIS PROGRAM CORRELATES RESPONSES TO SELECTED QUESTIONS OF A
C QUESTIONNAIRE TO PRODUCE A TABLE OF MARGINAL FREQUENCIES FOR
C ANY VARIABLE OR CROSS-TABULATIONS OF PAIRS OF VARIABLES (WITH
C OR WITHOUT A CONTROL VARIABLE) GIVING FREQUENCIES, PERCENTAGES,
C OR OTHER STATISTICS DESIRED BY THE USER. AN EXCLUSION ANALYSIS
C IS MADE IN EVERY CASE. AN ITEM ANALYSIS MAY BE CARRIED OUT ON A
C SELECTED SET OF VARIABLES AND THE RESULTS TABULATED AS A MATRIX
C OF ITEM INTERCORRELATIONS. THE USER HAS ACCESS AT ALL TIMES TO
C EVERY VARIABLE IN THE SURVEY (AS MANY AS 128).
C
C SOURCE
C NORMAN W. JOHNSON, DEPARTMENT OF MATHEMATICS, WHEATON COLLEGE,
C NORTON, MASS.
C
C INSTRUCTIONS
C THE CODED RESPONSES TO THE QUESTIONNAIRE SHOULD BE READ FROM
C CARDS AND WRITTEN INTO AN ASCII DATA FILE BY THE PROGRAM SURVEY.
C A PRELIMINARY TABULATION OF MARGINAL FREQUENCIES FOR ALL VARI-
C ABLES THE USER INTENDS TO WORK WITH CAN BE OBTAINED BY RUNNING
C THE PROGRAM SORTER. MAPPING OF VARIABLES AND OTHER MANIPULATION
C OF THE DATA CAN BE CARRIED OUT USING THE PROGRAM CROSS2.
C
C THE PROGRAM WILL FIRST REQUEST THE USER TO ENTER THE NAME OF
C THE DATA FILE. AFTER THIS IS DONE, A DESCRIPTION OF THE SURVEY
C WILL BE TYPED. THE USER MAY THEN PROCEED TO ANALYZE THE DATA BY
C GIVING ONE OF THE COMMANDS "XTAB" OR "ITEM" OR MAY TERMINATE THE
C EXECUTION OF THE PROGRAM BY TYPING "STOP".
C
C COMMANDS THAT TAKE VARIABLES AS ARGUMENTS MAY HAVE THE LIST OF
C VARIABLES ENTERED ON THE SAME LINE AS THE COMMAND.
C
C THE COMMAND "XTAB" ENABLES THE USER TO OBTAIN MARGINAL FREQUEN-
C CIES FOR ANY ONE VARIABLE OR TO CROSS-TABULATE ANY PAIR OF VARI-
C ABLES, USING A THIRD VARIABLE AS A CONTROL IF DESIRED. THE
C CONTROL VARIABLE MAY BE RESTRICTED TO ONE CATEGORY BY FOLLOWING
C THE THIRD VARIABLE NUMBER WITH AN EQUALS SIGN (=) AND A CATEGORY
C NUMBER (0 TO 9). FOLLOWING THE THIRD VARIABLE NUMBER WITH AN
C INEQUALITY SIGN (<>) AND A CATEGORY NUMBER HAS THE EFFECT OF
C EXCLUDING RESPONDENTS IN THAT CATEGORY. IF TWO OR THREE VARI-
C ABLES ARE SPECIFIED, ONE OR MORE OUTPUT OPTIONS MUST BE SELECTED
C AND THE APPROPRIATE CODE NUMBERS ENTERED. THE FOLLOWING OPTIONS
C ARE AVAILABLE:
C 0--EXCLUSION ANALYSIS ONLY
C 1--FREQUENCY OF RESPONSES
C 2--PERCENTAGES ACROSS
C 3--PERCENTAGES DOWN
C 4--PERCENTAGES OF TOTAL
C 5--CHI-SQUARE, DEGREES OF FREEDOM, AND PROBABILITY
C 6--GOODMAN AND KRUSKAL'S TAU
C 7--YULE'S Q OR GOODMAN AND KRUSKAL'S GAMMA
C 8--PHI COEFFICIENT OR KENDALL'S TAU
C 9--SOMER'S D
C
C THE COMMAND "ITEM" PRODUCES A MATRIX OF ITEM INTERCORRELATIONS
C (GOODMAN AND KRUSKAL'S GAMMA) FOR AS MANY AS NINE VARIABLES. A
C VARIABLE PRECEDED BY A MINUS SIGN HAS ITS CATEGORIES REVERSED.
C WHEN THE COMMAND IS GIVEN AS "ITEM PART", A CONTROL VARIABLE MAY
C BE SPECIFIED. CORRELATIONS MAY BE LIMITED TO A CERTAIN SET OF
C RESPONDENTS BY FOLLOWING THE CONTROL VARIABLE WITH AN EQUALITY
C OR INEQUALITY SIGN AND A CATEGORY NUMBER.
C
C AFTER ANY OF THE ABOVE COMMANDS IS CARRIED OUT, A NEW COMMAND
C MAY BE GIVEN. THE USER MAY SUPPRESS THE PRINTING OF TABLES OR
C ANY OTHER OUTPUT IN ORDER TO GIVE A NEW COMMAND IMMEDIATELY BY
C TYPING <CTRL>O AND PRESSING <RETURN>. FURTHER EXECUTION OF A
C COMMAND MAY BE HALTED AT ANY BREAK POINT BY TYPING "ABORT".
C
C WHENEVER THE USER IS EXPECTED TO GIVE A COMMAND OR TO PROVIDE
C CERTAIN INFORMATION NEEDED FOR THE EXECUTION OF A COMMAND, AN
C EXPLANATION OF WHAT IS REQUIRED MAY BE OBTAINED BY TYPING THE
C WORD "EXPLAIN" OR SIMPLY A QUESTION MARK.
C
C THIS PROGRAM ASSUMES THAT OUTPUT IS TO THE USER TERMINAL. IF
C OUTPUT TO A FILE ON THE DISK IS DESIRED INSTEAD, THE DISK SHOULD
C BE ASSIGNED LOGICAL UNIT 5 PRIOR TO RUNTIME.
C
C REMARKS
C THE COMPUTED VALUE OF CHI-SQUARE WITH ONE DEGREE OF FREEDOM
C INCORPORATES A CORRECTION FOR CONTINUITY. THE CALCULATION OF
C CHI-SQUARE IS ACCOMPANIED BY A WARNING IF THE EXPECTED FREQUENCY
C IS LESS THAN 1 IN ANY CELL OR LESS THAN 5 IN MORE THAN 20 PER
C CENT OF THE CELLS. KENDALL'S TAU HAS A CORRECTION FOR TIES.
C
C REFERENCES
C JAMES A. DAVIS, 'ELEMENTARY SURVEY ANALYSIS', PRENTICE-HALL,
C ENGLEWOOD CLIFFS, N.J., 1971.
C JOHAN GALTUNG, 'THEORY AND METHODS OF SOCIAL RESEARCH', COLUMBIA
C UNIVERSITY PRESS, NEW YORK, 1967.
C E. TERRENCE JONES, 'CONDUCTING POLITICAL RESEARCH', HARPER &
C ROW, NEW YORK, 1971.
C
C ..................................................................
C
INTEGER A(48),TODAY(2),BLANK,PRIME,DIFFER,EQUAL,ROW,COL
INTEGER L(0/128),H(0/128),R(0/128)
INTEGER MAP(3,0/13),X(128),IA(10)
REAL POS,NEG
LOGICAL OPT(0/9),GROUP,ERROR,ZERO,REJECT,BLURB
DIMENSION NUM(0/13,0/13,0/13),PCT(0/9,0/9)
DIMENSION NSUB(0/2,0/9,0/9),PSUB(2,0/9)
DIMENSION NTOT(0/9),TOT(0/9)
DIMENSION G(9,9,0/9),GMEAN(9),AMEAN(9)
DIMENSION J1A(10),J2A(10)
EQUIVALENCE (R,PCT),(G,NSUB),(Q,GAMMA)
COMMON ENTRY(0/13),LIST
OPT(0) = .TRUE.
BLANK = 17315143744
PRIME = 21073240128
R(0) = 25905078336
DIFFER = 32472301568
EQUAL = 32749125632
CALL TIME(NOW)
LIST = NOW-851968
CALL DATE(TODAY)
TYPE 1, NOW,TODAY
1 FORMAT (' CROSS1',8X,A5,9X,2A5//)
C
C START: LOCATE DATA FILE.
20 TYPE 2
2 FORMAT (/' NAME OF SURVEY? ',$)
C ENTER FILE NAME.
30 ACCEPT 3, ORIG
3 FORMAT (12A5)
31 FORMAT (/A5)
32 FORMAT (//A5)
33 FORMAT (8X,A5)
34 FORMAT ('+'/$)
IF (ORIG.EQ.' ') GO TO 20
IF (ORIG.EQ.'STOP') GO TO 2000
DATA = ORIG
GROUP = RENAME(DATA,'.MAP',DATA,'.MAP')
IF (GROUP) CALL IFIL(21,DATA,'.MAP')
IF (GROUP) READ (21,31) DATA
IF (RENAME(DATA,'.DAT',DATA,'.DAT')) GO TO 40
TYPE 4, DATA
4 FORMAT (' CANNOT FIND DATA FILE ',A5/)
GO TO 20
40 CALL IFILE(1,DATA)
C INPUT DESCRIPTION OF SURVEY.
50 READ (1,5) (A(I),I=1,48)
5 FORMAT (/48A1)
DO 60 I=48,1,-1
IF (A(I).NE.BLANK) GO TO 70
60 A(I) = 0
70 TYPE 7, (A(I),I=1,48)
7 FORMAT (9X,48A1////)
LAST = 0
IF (.NOT.GROUP) GO TO 100
C GROUP RESPONSES TO EACH QUESTION.
80 READ (21,10) M
READ (21,14) (L(I),I=1,M)
READ (21,14) (H(I),I=1,M)
READ (21,16) (X(I),I=1,M)
READ (1,10) MAX
M = MIN0(M,MAX)
READ (1,32) ID
IF (LAST) 180,180,200
C INPUT NUMBER OF QUESTIONS.
100 READ (1,10) M
10 FORMAT (9I)
101 FORMAT (9I1,9L1)
102 FORMAT (I2)
103 FORMAT (3I,2A1)
104 FORMAT (I,2A1)
C INPUT LOWEST NUMBER USED AS CODED RESPONSE TO EACH QUESTION.
120 READ (1,14) (L(I),I=1,M)
C INPUT HIGHEST NUMBER USED AS CODED RESPONSE TO EACH QUESTION.
140 READ (1,14) (H(I),I=1,M)
14 FORMAT (5X,128I1)
C INPUT MAPPING INDICATOR FOR EACH QUESTION.
160 READ (1,16) (X(I),I=1,M)
16 FORMAT (5X,128A1)
180 DO 185 J=0,13
DO 185 I=1,3
185 MAP(I,J) = J
IF (LAST.GT.0) GO TO 200
190 READ (1,3) ID
IF (ID.NE.BLANK) GO TO 190
C INPUT NUMBER OF RESPONDENTS.
READ (1,10) LAST
TOTAL = LAST
GO TO 202
C
C ENTER COMMAND.
200 TYPE 201
201 FORMAT ('1')
202 TYPE 203
203 FORMAT (' ENTER COMMAND: ',$)
ACCEPT 3, (ENTRY(N),N=1,12)
CALL DECODE
READ (20,3) ANS,SAVE
IF (ANS.EQ.'START') GO TO 20
IF (ANS.EQ.' ') GO TO 200
IF (ANS.EQ.'DETAI') GO TO 210
IF (ANS.EQ.'EXPLA' .AND. SAVE.GT.'IN') GO TO 220
IF (ANS.EQ.'XTAB') GO TO 230
IF (ANS.EQ.'ITEM') GO TO 1400
IF (ANS.EQ.'STOP') GO TO 2000
IF (ANS.EQ.'MAP') TYPE 2032
IF (ANS.EQ.'UNMAP') TYPE 2032
IF (ANS.EQ.'JOIN') TYPE 2032
IF (ANS.EQ.'POOL') TYPE 2032
IF (ANS.EQ.'CUT') TYPE 2032
IF (ANS.EQ.'SAVE') TYPE 2032
IF (ANS.EQ.'RESET') TYPE 2032
2032 FORMAT (' COMMAND NOT AVAILABLE--RUN CROSS2'/)
TYPE 204
204 FORMAT (
1 ' ENTER ONE OF THE FOLLOWING:'/
2 ' XTAB, ITEM, STOP, OR DETAIL'/)
GO TO 200
210 TYPE 21
21 FORMAT (
1 ' TO OBTAIN MARGINAL FREQUENCIES FOR A VARIABLE OR'/
2 ' TO CROSS-TABULATE 2 OR 3 VARIABLES, TYPE "XTAB".'/
3 ' TO INTERCORRELATE 2 TO 9 VARIABLES, TYPE "ITEM".'/
4 ' TO TERMINATE THE PROGRAM, TYPE "STOP".'//
5 ' TO HALT EXECUTION OF A COMMAND, TYPE "ABORT".'/
6 ' TO GET HELP AT ANY POINT, TYPE "EXPLAIN" OR "?".'//
7 ' FOR A MORE COMPLETE EXPLANATION OF ANY OF THE ABOVE'/
8 ' COMMANDS, TYPE "EXPLAIN" AND THE NAME OF THE COMMAND.'/)
GO TO 200
220 REREAD 33, ANS
IF (ANS.EQ.'ABORT') TYPE 221
221 FORMAT (
1 ' FURTHER EXECUTION OF A COMMAND MAY BE HALTED AT ANY'/
2 ' BREAK POINT BY TYPING "ABORT". TO SUPPRESS THE PRINT-'/
3 ' ING OF TABLES OR OTHER OUTPUT, TYPE <CTRL>O AND PRESS'/
4 ' <RETURN>.'/)
IF (ANS.EQ.'EXPLA' .OR. ANS.EQ.'?') TYPE 222
222 FORMAT (
1 ' IF YOU NEED AN EXPLANATION OR FURTHER INSTRUCTIONS,'/
2 ' YOU MAY RESPOND TO ANY REQUEST FOR INPUT BY TYPING'/
3 ' "EXPLAIN" OR A QUESTION MARK.'/)
IF (ANS.EQ.'XTAB') TYPE 231
IF (ANS.EQ.'ITEM') TYPE 1402
IF (ANS.EQ.'STOP') TYPE 2002
GO TO 200
C
C XTAB: CROSS-TABULATE VARIABLES.
230 ZERO = ENTRY(0).NE.ANS .OR. ENTRY(1).EQ.' '
IF (ZERO) TYPE 23
23 FORMAT (' VARIABLES TO BE TABULATED? ',$)
IF (ZERO) ACCEPT 3, (ENTRY(N),N=1,12)
IF (ENTRY(1).EQ.'NONE' .OR. ENTRY(1).EQ.'ABORT') GO TO 200
IF (ENTRY(1).EQ.'STOP') GO TO 2000
IF (ENTRY(1).EQ.'EXPLA' .OR. ENTRY(1).EQ.'?') TYPE 231
231 FORMAT (
1 ' ENTER ONE VARIABLE TO OBTAIN MARGINAL FREQUENCIES OR A'/
2 ' PAIR OF VARIABLES TO BE CROSS-TABULATED. ENTER THREE'/
3 ' VARIABLES IF A CONTROL IS DESIRED. THE THIRD VARI-'/
4 ' ABLE MAY BE FOLLOWED BY AN EQUALS SIGN AND A CATEGORY'/
5 ' NUMBER (0 TO 9). AN ENTRY IN THE FORM ''V1,V2,V3=C'''/
6 ' ASKS FOR A CROSS-TABULATION OF VARIABLES V1 AND V2 FOR'/
7 ' RESPONDENTS BELONGING TO CATEGORY C OF VARIABLE V3.'/
8 ' AN ENTRY IN THE FORM ''V1,0,V3=C'' REQUESTS MARGINAL'/
9 ' FREQUENCIES FOR VARIABLE V1 FOR THOSE RESPONDENTS IN'/
/ ' CATEGORY C OF VARIABLE V3. IF THE THIRD VARIABLE IS'/
1 ' FOLLOWED BY AN INEQUALITY SIGN (<>) AND A CATEGORY'/
2 ' NUMBER, RESPONDENTS IN THAT CATEGORY WILL BE EXCLUDED.'/
3 ' IF YOU DO NOT WANT TO HAVE ANY VARIABLES TABULATED,'/
4 ' TYPE "NONE".'//
5 ' WHEN VARIABLES TO BE CROSS-TABULATED ARE LISTED ON THE'/
6 ' SAME LINE AS THE COMMAND (E.G., "XTAB 1,2"), THE OUT-'/
7 ' PUT OPTIONS WILL BE THE SAME AS IN THE LAST PREVIOUS'/
8 ' CROSS-TABULATION, IF ANY.'/)
CALL DECODE
READ (20,103) I1,I2,I3,N3,N3X
IF (I1.EQ.0) GO TO 230
ERROR = I1.LT.0 .OR. I1.GT.M .OR. I2.LT.0 .OR. I2.GT.M .OR.
1 I3.LT.0 .OR. I3.GT.M
IF (ERROR) TYPE 232, M
232 FORMAT ('+INVALID ENTRY--VARIABLES RUN FROM 1 TO ',I3/)
IF (ERROR) GO TO 230
ERROR = L(I1).GT.H(I1) .OR. L(I2).GT.H(I2) .OR. L(I3).GT.H(I3)
IF (ERROR) TYPE 233
233 FORMAT ('+INVALID ENTRY--VARIABLE WITHOUT CATEGORIES'/)
IF (ERROR) GO TO 230
J3X = JK(N3X)
IF (J3X.GT.9) J3X = -1
REJECT = (N3.EQ.'<' .OR. N3.EQ.'>') .AND. J3X.GE.0
J3 = JK(N3)
IF (J3.GT.9) J3 = -1
IF (J3.LT.0 .AND. .NOT.REJECT) J3 = J3X
IF (I2.NE.0 .OR. J3.GE.0 .OR. J3X.GE.0) GO TO 235
I2 = I3
I3 = 0
235 I3L = L(I3)
I3H = H(I3)
IF (J3.LT.0 .AND. I2.NE.0) GO TO 290
IF (J3.LT.0 .AND. I2.EQ.0) GO TO 300
L(I3) = J3
H(I3) = J3
IF (I2) 290,300,290
C TABULATE MARGINAL FREQUENCIES.
240 J3 = L(I3)
DO 245 J1=L(I1),H(I1)
245 PSUB(1,J1) = NSUB(1,J1,J3)/TOTAL+.0005
PTAB = NTAB/TOTAL+.0005
250 WRITE (5,25) I1
25 FORMAT (///
1 ' DOWN: VARIABLE ',I3)
R(3) = EQUAL
IF (REJECT) R(3) = DIFFER
IF (I3.NE.0) WRITE (5,252) I3,R(3),J3,X(I3)
252 FORMAT (
2 ' CONTROL: VARIABLE ',I3,2X,A2,' CATEGORY ',I1,A1)
WRITE (5,253)
253 FORMAT (///9X,'FREQ',4X,'PCT'/)
DO 260 J1=L(I1),H(I1)
260 WRITE (5,26) J1,X(I1),NSUB(1,J1,J3),PSUB(1,J1)
26 FORMAT (' ',I1,A1,5X,I4,4X,2PF5.1)
270 WRITE (5,27) NTAB,PTAB
27 FORMAT (/' TOT ',3X,I4,4X,2PF5.1)
GO TO 1350
C ENTER OUTPUT OPTIONS.
280 TYPE 28
28 FORMAT (
1 ' ENTER (WITHOUT PUNCTUATION) ONE OR MORE OPTIONS FOR OUTPUT:')
281 FORMAT (
2 ' 0--EXCLUSION ANALYSIS ONLY'/
3 ' 1--FREQUENCY OF RESPONSES'/
4 ' 2--PERCENTAGES ACROSS'/
5 ' 3--PERCENTAGES DOWN'/
6 ' 4--PERCENTAGES OF TOTAL'/
7 ' 5--CHI-SQUARE'/
8 ' 6--NOMINAL TAU'/
9 ' 7--YULE''S Q / GAMMA'/
/ ' 8--PHI / ORDINAL TAU'/
1 ' 9--SOMER''S D'/)
290 IF (SAVE.GT.' ' .AND. .NOT.OPT(0)) GO TO 300
TYPE 29
29 FORMAT (' OUTPUT OPTIONS? ',$)
ACCEPT 3, (ENTRY(N),N=1,4)
IF (ENTRY(1).EQ.'NONE' .OR. ENTRY(1).EQ.'ABORT') GO TO 200
IF (ENTRY(1).EQ.'STOP') GO TO 2000
BLURB = ENTRY(1).EQ.'EXPLA' .OR. ENTRY(1).EQ.'?'
IF (BLURB) TYPE 28
IF (BLURB) TYPE 281
IF (BLURB .OR. ENTRY(1).EQ.' ') GO TO 290
CALL DECODE
READ (20,101,ERR=280) (R(I),I=1,9),(OPT(J),J=1,9)
DO 295 I=1,9
295 OPT(R(I)) = .TRUE.
OPT(0) = .NOT.(OPT(1) .OR. OPT(2) .OR. OPT(3) .OR. OPT(4) .OR.
1 OPT(5) .OR. OPT(6) .OR. OPT(7) .OR. OPT(8) .OR. OPT(9))
C COUNT RESPONSES IN EACH CATEGORY.
300 MAX = MAX0(I1,I2,I3)
IF (.NOT.GROUP) GO TO 307
CALL IFIL(21,ORIG,'.MAP')
READ (21,32) ID
READ (21,32) ID
DO 305 J=0,13
READ (21,16) (R(I),I=1,MAX)
MAP(1,J) = JK(R(I1))
MAP(2,J) = JK(R(I2))
MAP(3,J) = JK(R(I3))
305 CONTINUE
307 DO 310 J3=L(I3),H(I3)
DO 310 J2=L(I2),H(I2)
DO 310 J1=L(I1),H(I1)
310 NUM(J1,J2,J3) = 0
CALL IFILE(1,DATA)
READ (1,32) ID
READ (1,32) ID
DO 315 K=1,LAST
READ (1,16) (R(I),I=1,MAX)
J1 = MAP(1,JK(R(I1)))
J2 = MAP(2,JK(R(I2)))
J3 = MAP(3,JK(R(I3)))
315 NUM(J1,J2,J3) = NUM(J1,J2,J3)+1
IF (ANS.EQ.'ITEM' .AND. .NOT.REJECT) GO TO 1450
320 IF (.NOT.REJECT) GO TO 335
DO 330 J1=L(I1),H(I1)
DO 330 J2=L(I2),H(I2)
NSUB(0,J1,J2) = 0
DO 325 J3=L(I3),H(I3)
325 NSUB(0,J1,J2) = NSUB(0,J1,J2)+NUM(J1,J2,J3)
330 NUM(J1,J2,J3X) = NSUB(0,J1,J2)-NUM(J1,J2,J3X)
IF (ANS.EQ.'ITEM') GO TO 1450
L(I3) = J3X
H(I3) = J3X
335 CONTINUE
DO 360 J3=L(I3),H(I3)
DO 340 J1=L(I1),H(I1)
340 NSUB(1,J1,J3) = 0
DO 350 J2=L(I2),H(I2)
350 NSUB(2,J2,J3) = 0
360 NTOT(J3) = 0
NTAB = 0
DO 390 J3=L(I3),H(I3)
DO 380 J2=L(I2),H(I2)
DO 370 J1=L(I1),H(I1)
NSUB(1,J1,J3) = NSUB(1,J1,J3)+NUM(J1,J2,J3)
370 NSUB(2,J2,J3) = NSUB(2,J2,J3)+NUM(J1,J2,J3)
380 NTOT(J3) = NTOT(J3)+NSUB(2,J2,J3)
TOT(J3) = NTOT(J3)
TOT(J3) = AMAX1(TOT(J3),.0001)
390 NTAB = NTAB+NTOT(J3)
NOUT = LAST-NTAB
IF (I2.EQ.0) GO TO 240
IF (OPT(0)) GO TO 1350
C BEGIN OUTPUT LOOP.
400 DO 1300 J3=L(I3),H(I3)
IF (J3.NE.L(I3)) WRITE (5,34)
IF (.NOT.(OPT(5) .OR. OPT(6) .OR. OPT(7) .OR. OPT(8) .OR. OPT(9)))
1 GO TO 430
NROW = 0
NCOL = 0
DO 410 J1=L(I1),H(I1)
IF (NSUB(1,J1,J3).EQ.0) GO TO 410
NROW = NROW+1
J1A(NROW) = J1
410 CONTINUE
NROW = MAX0(NROW,1)
DO 420 J2=L(I2),H(I2)
IF (NSUB(2,J2,J3).EQ.0) GO TO 420
NCOL = NCOL+1
J2A(NCOL) = J2
420 CONTINUE
NDF = (NROW-1)*(NCOL-1)
NADF = (H(I1)-L(I1))*(H(I2)-L(I2))
430 WRITE (5,43) I1,I2
43 FORMAT (///
1 ' DOWN: VARIABLE ',I3/
2 ' ACROSS: VARIABLE ',I3)
R(3) = EQUAL
IF (REJECT) R(3) = DIFFER
IF (I3.NE.0) WRITE (5,431) I3,R(3),J3,X(I3)
431 FORMAT (
3 ' CONTROL: VARIABLE ',I3,2X,A2,' CATEGORY ',I1,A1)
IF (OPT(1)) GO TO 440
IF (OPT(2)) GO TO 500
IF (OPT(3)) GO TO 600
IF (OPT(4)) GO TO 700
IF (OPT(5)) GO TO 800
IF (OPT(6)) GO TO 900
IF (OPT(7)) GO TO 1000
IF (OPT(8)) GO TO 1100
IF (OPT(9)) GO TO 1200
C OPTION 1--FREQUENCY OF RESPONSES
440 WRITE (5,44)
44 FORMAT (///' FREQUENCY OF RESPONSES:')
450 WRITE (5,45) (J2,X(I2),J2=L(I2),H(I2))
45 FORMAT (//5X,20(1X,I4,A1,$))
460 WRITE (5,46)
46 FORMAT ('+',4X,'TOT'/)
DO 480 J1=L(I1),H(I1)
470 WRITE (5,47) J1,X(I1),(NUM(J1,J2,J3),J2=L(I2),H(I2))
47 FORMAT (1X,I1,A1,2X,20(1X,I4,1X,$))
480 WRITE (5,48) NSUB(1,J1,J3)
48 FORMAT ('+',3X,I4)
490 WRITE (5,49) (NSUB(2,J2,J3),J2=L(I2),H(I2))
49 FORMAT (/' TOT ',20(1X,I4,1X,$))
WRITE (5,48) NTOT(J3)
IF (OPT(2)) GO TO 500
IF (OPT(3)) GO TO 600
IF (OPT(4)) GO TO 700
IF (OPT(5)) GO TO 800
IF (OPT(6)) GO TO 900
IF (OPT(7)) GO TO 1000
IF (OPT(8)) GO TO 1100
IF (OPT(9)) GO TO 1200
GO TO 1300
C OPTION 2--PERCENTAGES ACROSS
500 DO 510 J1=L(I1),H(I1)
SUB1 = NSUB(1,J1,J3)
SUB1 = AMAX1(SUB1,.0001)
DO 510 J2=L(I2),H(I2)
510 PCT(J1,J2) = NUM(J1,J2,J3)/SUB1+.0005
DO 530 J2=L(I2),H(I2)
530 PSUB(2,J2) = NSUB(2,J2,J3)/TOT(J3)+.0005
540 WRITE (5,54)
54 FORMAT (///' PERCENTAGES ACROSS:')
550 WRITE (5,45) (J2,X(I2),J2=L(I2),H(I2))
560 WRITE (5,46)
DO 580 J1=L(I1),H(I1)
570 WRITE (5,57) J1,X(I1),(PCT(J1,J2),J2=L(I2),H(I2))
57 FORMAT (1X,I1,A1,2X,20(1X,2PF5.1,$))
580 WRITE (5,48) NSUB(1,J1,J3)
590 WRITE (5,59) (PSUB(2,J2),J2=L(I2),H(I2))
59 FORMAT (/' TOT ',20(1X,2PF5.1,$))
WRITE (5,48) NTOT(J3)
IF (OPT(3)) GO TO 600
IF (OPT(4)) GO TO 700
IF (OPT(5)) GO TO 800
IF (OPT(6)) GO TO 900
IF (OPT(7)) GO TO 1000
IF (OPT(8)) GO TO 1100
IF (OPT(9)) GO TO 1200
GO TO 1300
C OPTION 3--PERCENTAGES DOWN
600 DO 610 J2=L(I2),H(I2)
SUB2 = NSUB(2,J2,J3)
SUB2 = AMAX1(SUB2,.0001)
DO 610 J1=L(I1),H(I1)
610 PCT(J1,J2) = NUM(J1,J2,J3)/SUB2+.0005
DO 620 J1=L(I1),H(I1)
620 PSUB(1,J1) = NSUB(1,J1,J3)/TOT(J3)+.0005
640 WRITE (5,64)
64 FORMAT (///' PERCENTAGES DOWN:')
650 WRITE (5,45) (J2,X(I2),J2=L(I2),H(I2))
660 WRITE (5,46)
DO 680 J1=L(I1),H(I1)
670 WRITE (5,57) J1,X(I1),(PCT(J1,J2),J2=L(I2),H(I2))
680 WRITE (5,68) PSUB(1,J1)
68 FORMAT ('+',3X,2PF5.1)
690 WRITE (5,49) (NSUB(2,J2,J3),J2=L(I2),H(I2))
WRITE (5,48) NTOT(J3)
IF (OPT(4)) GO TO 700
IF (OPT(5)) GO TO 800
IF (OPT(6)) GO TO 900
IF (OPT(7)) GO TO 1000
IF (OPT(8)) GO TO 1100
IF (OPT(9)) GO TO 1200
GO TO 1300
C OPTION 4--PERCENTAGES OF TOTAL
700 DO 710 J1=L(I1),H(I1)
DO 710 J2=L(I2),H(I2)
710 PCT(J1,J2) = NUM(J1,J2,J3)/TOT(J3)+.0005
DO 720 J1=L(I1),H(I1)
720 PSUB(1,J1) = NSUB(1,J1,J3)/TOT(J3)+.0005
DO 730 J2=L(I2),H(I2)
730 PSUB(2,J2) = NSUB(2,J2,J3)/TOT(J3)+.0005
740 WRITE (5,74)
74 FORMAT (///' PERCENTAGES OF TOTAL:')
750 WRITE (5,45) (J2,X(I2),J2=L(I2),H(I2))
760 WRITE (5,46)
DO 780 J1=L(I1),H(I1)
770 WRITE (5,57) J1,X(I1),(PCT(J1,J2),J2=L(I2),H(I2))
780 WRITE (5,68) PSUB(1,J1)
790 WRITE (5,59) (PSUB(2,J2),J2=L(I2),H(I2))
WRITE (5,48) NTOT(J3)
IF (OPT(5)) GO TO 800
IF (OPT(6)) GO TO 900
IF (OPT(7)) GO TO 1000
IF (OPT(8)) GO TO 1100
IF (OPT(9)) GO TO 1200
GO TO 1300
C OPTION 5--CHI-SQUARE
800 WRITE (5,32)
IF (NDF-1) 810,820,830
810 WRITE (5,81)
81 FORMAT (/' CHI-SQUARE IS UNDEFINED.')
IF (OPT(6)) GO TO 900
IF (OPT(7)) GO TO 1010
IF (OPT(8)) GO TO 1110
IF (OPT(9)) GO TO 1210
GO TO 1300
820 PROD1 = NSUB(1,J1A(1),J3)*NSUB(1,J1A(2),J3)
PROD2 = NSUB(2,J2A(1),J3)*NSUB(2,J2A(2),J3)
PROD = PROD1*PROD2
DET = IABS(NUM(J1A(1),J2A(1),J3)*NUM(J1A(2),J2A(2),J3)
1 -NUM(J1A(1),J2A(2),J3)*NUM(J1A(2),J2A(1),J3))
COR = AMIN1(TOT(J3),DET)/2
CS = TOT(J3)*(DET-COR)**2/PROD
830 IF (NDF.GT.1) CS = 0.0
IERR = 0
DO 840 ROW=1,NROW
DO 840 COL=1,NCOL
ENUM = NSUB(1,J1A(ROW),J3)*NSUB(2,J2A(COL),J3)/TOT(J3)
IF (ENUM.LT.1.0) IERR = -100
IF (NDF.EQ.1) GO TO 840
CS = CS+(NUM(J1A(ROW),J2A(COL),J3)-ENUM)**2/ENUM
840 CONTINUE
860 IF (IERR.EQ.0) CALL CHISQ(CS,NDF,PR)
870 WRITE (5,87) CS,NDF
87 FORMAT (/' CHI-SQUARE =',F7.2,' WITH ',I2,' D.F.')
IF (IERR.NE.0) GO TO 890
880 WRITE (5,88)
88 FORMAT (' PROBABILITY OF CHI-SQUARE THIS LARGE IS ',$)
IF (PR.GE..9995) WRITE (5,881)
881 FORMAT ('+1.')
IF (PR.GE..001 .AND. PR.LT..9995) WRITE (5,882) PR
882 FORMAT ('+',F4.3)
IF (PR.LT..001) WRITE (5,883)
883 FORMAT ('+LESS THAN .001')
GO TO 895
890 WRITE (5,89)
89 FORMAT (' NOTE: EXPECTED FREQUENCY IS LESS THAN ',$)
IF (IERR.LT.0) WRITE (5,891)
891 FORMAT ('+1 IN ONE OR MORE CELLS.')
IF (IERR.EQ.1) WRITE (5,892)
892 FORMAT ('+5 IN ONE CELL.')
IF (IERR.GT.1 .AND. IERR.LT.10) WRITE (5,893) IERR
893 FORMAT ('+5 IN ',I1,' CELLS.')
IF (IERR.GE.10) WRITE (5,894) IERR
894 FORMAT ('+5 IN ',I2,' CELLS.')
895 IF (OPT(6)) GO TO 900
IF (OPT(7)) GO TO 1000
IF (OPT(8)) GO TO 1100
IF (OPT(9)) GO TO 1200
GO TO 1300
C OPTION 6--NOMINAL TAU
900 IF (.NOT.OPT(5)) WRITE (5,32)
IF (NCOL-2) 910,920,930
910 WRITE (5,91)
91 FORMAT (/' GOODMAN AND KRUSKAL''S TAU IS UNDEFINED.')
IF (OPT(7)) GO TO 1010
IF (OPT(8)) GO TO 1110
IF (OPT(9)) GO TO 1210
GO TO 1300
920 POS = 2.*NSUB(2,J2A(1),J3)*NSUB(2,J2A(2),J3)/TOT(J3)
NEG = 0.0
DO 925 ROW=1,NROW
SUB1 = NSUB(1,J1A(ROW),J3)
925 NEG = NEG+2.*NUM(J1A(ROW),J2A(1),J3)*NUM(J1A(ROW),J2A(2),J3)/SUB1
TAU = (POS-NEG)/POS
GO TO 960
930 SUM = 0.0
DO 935 COL=1,NCOL
935 SUM = SUM+NSUB(2,J2A(COL),J3)*(NTOT(J3)-NSUB(2,J2A(COL),J3))
POS = SUM/TOT(J3)
940 NEG = 0.0
DO 950 ROW=1,NROW
SUM = 0.0
NSUB1 = NSUB(1,J1A(ROW),J3)
DO 945 COL=1,NCOL
945 SUM = SUM+NUM(J1A(ROW),J2A(COL),J3)*
1 (NSUB1-NUM(J1A(ROW),J2A(COL),J3))
SUB1 = NSUB1
950 NEG = NEG+SUM/SUB1
TAU = (POS-NEG)/POS
960 PTAU = TAU+.0005
DO 965 I=1,3
965 R(I) = 0
IF (I1.GE.100) R(1) = BLANK
IF (I2.GE.100) R(2) = BLANK
IF (PTAU.GE..1) R(3) = BLANK
970 WRITE (5,97) TAU
97 FORMAT (/' GOODMAN AND KRUSKAL''S TAU = ',F6.3)
980 WRITE (5,98) R(1),I1
98 FORMAT (' (KNOWING VARIABLE',A1,I3,$)
IF (TAU.LT..0005) WRITE (5,981) R(2),I2
981 FORMAT ('+ DOES NOT REDUCE ERROR',
1 ' IN PREDICTING VARIABLE',A1,I3,')')
IF (TAU.GE..0005.AND.TAU.LT..9995) WRITE (5,982) R(2),I2,R(3),PTAU
982 FORMAT ('+ REDUCES ERROR',
1 ' IN PREDICTING VARIABLE',A1,I3,' BY',A1,2PF4.1,'%)')
IF (TAU.GE..9995) WRITE (5,883) R(2),I2
983 FORMAT ('+ ELIMINATES ERROR',
1 ' IN PREDICTING VARIABLE',A1,I3,')')
IF (OPT(7)) GO TO 1000
IF (OPT(8)) GO TO 1100
IF (OPT(9)) GO TO 1200
GO TO 1300
C OPTION 7--YULE'S Q / GAMMA
1000 IF (.NOT.(OPT(5) .OR. OPT(6))) WRITE (5,32)
IF (NDF-1) 1010,1020,1030
1010 IF (NADF.EQ.1) WRITE (5,1011)
IF (NADF.NE.1) WRITE (5,1012)
1011 FORMAT (/' YULE''S Q IS UNDEFINED.')
1012 FORMAT (/' GOODMAN AND KRUSKAL''S GAMMA IS UNDEFINED.')
IF (OPT(8)) GO TO 1110
IF (OPT(9)) GO TO 1210
GO TO 1300
1020 POS = NUM(J1A(1),J2A(1),J3)*NUM(J1A(2),J2A(2),J3)
NEG = NUM(J1A(1),J2A(2),J3)*NUM(J1A(2),J2A(1),J3)
Q = (POS-NEG)/(POS+NEG)
SUM = 0.0
DO 1025 ROW=1,2
DO 1025 COL=1,2
1025 SUM = SUM+1.0/AMAX0(NUM(J1A(ROW),J2A(COL),J3),1)
SIGMA = (1.0-Q*Q)*SQRT(SUM)/2.
QMAX = AMIN1(Q+1.960*SIGMA, 1.)
QMIN = AMAX1(Q-1.960*SIGMA,-1.)
R(5) = (1+(QMAX.GE.0.0))*BLANK
R(6) = (1+(QMIN.GE.0.0))*BLANK
GO TO 1060
1030 POS = 0.0
NEG = 0.0
DO 1040 MROW=1,NROW-1
DO 1040 MCOL=1,NCOL-1
DO 1040 ROW=MROW+1,NROW
DO 1040 COL=MCOL+1,NCOL
1040 POS = POS+NUM(J1A(MROW),J2A(MCOL),J3)*NUM(J1A(ROW),J2A(COL),J3)
DO 1050 MROW=1,NROW-1
DO 1050 MCOL=2,NCOL
DO 1050 ROW=MROW+1,NROW
DO 1050 COL=1,MCOL-1
1050 NEG = NEG+NUM(J1A(MROW),J2A(MCOL),J3)*NUM(J1A(ROW),J2A(COL),J3)
IF (OPT(8) .AND. .NOT.OPT(7)) GO TO 1130
IF (OPT(9) .AND. .NOT.OPT(7)) GO TO 1230
GAMMA = (POS-NEG)/(POS+NEG)
1060 DO 1065 I=1,4
1065 R(I) = 0
IF (I1.GE.100) R(1) = BLANK
IF (X(I1).EQ.PRIME) R(2) = PRIME
IF (I2.GE.100) R(3) = BLANK
IF (X(I2).EQ.PRIME) R(4) = PRIME
J1 = J1A(1)
IF (Q.GT.0.0) J2 = J2A(1)
IF (Q.LT.0.0) J2 = J2A(NCOL)
1070 IF (NDF.EQ.1) WRITE (5,1071) Q
IF (NDF.GT.1) WRITE (5,1072) GAMMA
1071 FORMAT (/' YULE''S Q = ',F6.3)
1072 FORMAT (/' GOODMAN AND KRUSKAL''S GAMMA = ',F6.3)
1080 IF (ABS(Q).GE..0005) WRITE (5,108) R(1),I1,J1,R(2),R(3),I2,J2,R(4)
108 FORMAT (
1 ' (VARIABLE',A1,I3,' = CATEGORY ',I1,A1,') TENDS WITH ',
2 ' (VARIABLE',A1,I3,' = CATEGORY ',I1,A1,')')
IF (ABS(Q).LT..0005) WRITE (5,1081) R(1),I1,R(3),I2
1081 FORMAT (
1 ' VARIABLES',A1,I3,' AND',A1,I3,' ARE NOT ASSOCIATED')
1090 IF (NDF.EQ.1 .AND. ABS(Q).NE.1.) WRITE (5,109) R(5),QMAX,R(6),QMIN
109 FORMAT (' 95% CONFIDENCE LIMITS FOR Q ARE',A1,F6.3,' AND',A1,F6.3)
IF (OPT(8)) GO TO 1100
IF (OPT(9)) GO TO 1200
GO TO 1300
C OPTION 8--PHI / ORDINAL TAU
1100 IF (.NOT.(OPT(5) .OR. OPT(6) .OR. OPT(7))) WRITE (5,32)
IF (NDF.GT.1 .AND. .NOT.OPT(7)) GO TO 1030
IF (NDF-1) 1110,1120,1130
1110 IF (NADF.EQ.1) WRITE (5,1111)
IF (NADF.NE.1) WRITE (5,1112)
1111 FORMAT (/' PHI IS UNDEFINED.')
1112 FORMAT (/' KENDALL''S TAU IS UNDEFINED.')
IF (OPT(9)) GO TO 1210
GO TO 1300
1120 POS = NUM(J1A(1),J2A(1),J3)*NUM(J1A(2),J2A(2),J3)
NEG = NUM(J1A(1),J2A(2),J3)*NUM(J1A(2),J2A(1),J3)
PROD1 = NSUB(1,J1A(1),J3)*NSUB(1,J1A(2),J3)
PROD2 = NSUB(2,J2A(1),J3)*NSUB(2,J2A(2),J3)
ROOT = SQRT(PROD1*PROD2)
PHI = (POS-NEG)/ROOT
GO TO 1150
1130 PROD1 = 0.0
PROD2 = 0.0
DO 1135 MROW=1,NROW-1
DO 1135 ROW=MROW+1,NROW
1135 PROD1 = PROD1+NSUB(1,J1A(MROW),J3)*NSUB(1,J1A(ROW),J3)
DO 1140 MCOL=1,NCOL-1
DO 1140 COL=MCOL+1,NCOL
1140 PROD2 = PROD2+NSUB(2,J2A(MCOL),J3)*NSUB(2,J2A(COL),J3)
TAU = (POS-NEG)/SQRT(PROD1*PROD2)
GO TO 1170
1150 MROW = (NSUB(1,J1A(1),J3).LT.NSUB(1,J1A(2),J3))+2
MCOL = (NSUB(2,J2A(1),J3).LT.NSUB(2,J2A(2),J3))+2
IF (NSUB(1,J1A(MROW),J3).GT.NSUB(2,J2A(MCOL),J3)) GO TO 1155
ALLPOS = NSUB(1,J1A(MROW),J3)*NSUB(2,J2A(3-MROW),J3)
ALLNEG = NSUB(1,J1A(MROW),J3)*NSUB(2,J2A(MROW),J3)
GO TO 1160
1155 ALLPOS = NSUB(2,J2A(MCOL),J3)*NSUB(1,J1A(3-MCOL),J3)
ALLNEG = NSUB(2,J2A(MCOL),J3)*NSUB(1,J1A(MCOL),J3)
1160 PHIMAX = ALLPOS/ROOT
PHIMIN = -ALLNEG/ROOT
1170 IF (NDF.EQ.1) WRITE (5,1171) PHI
IF (NDF.GT.1) WRITE (5,1172) TAU
1171 FORMAT (/' PHI = ',F6.3)
1172 FORMAT (/' KENDALL''S TAU = ',F6.3)
1180 IF (NDF.EQ.1) WRITE (5,1181) PHIMAX,PHIMIN
IF (NDF.GT.1) WRITE (5,1182)
1181 FORMAT (' UPPER AND LOWER BOUNDS FOR PHI ARE',F6.3,' AND ',F6.3)
1182 FORMAT (' (RANK CORRELATION CORRECTED FOR TIES)')
IF (OPT(9)) GO TO 1200
GO TO 1300
C OPTION 9--SOMER'S D
1200 IF (.NOT.(OPT(5) .OR. OPT(6) .OR. OPT(7) .OR. OPT(8)))
1 WRITE (5,32)
IF (NDF.GT.1 .AND. .NOT.(OPT(7) .OR. OPT(8))) GO TO 1030
IF (NDF-1) 1210,1220,1230
1210 WRITE (5,121)
121 FORMAT (/' SOMER''S D IS UNDEFINED.')
GO TO 1300
1220 POS = NUM(J1A(1),J2A(1),J3)*NUM(J1A(2),J2A(2),J3)
NEG = NUM(J1A(1),J2A(2),J3)*NUM(J1A(2),J2A(1),J3)
PROD1 = NSUB(1,J1A(1),J3)*NSUB(1,J1A(2),J3)
D = (POS-NEG)/PROD1
GO TO 1260
1230 IF (OPT(8)) GO TO 1240
PROD1 = 0.0
DO 1235 MROW=1,NROW-1
DO 1235 ROW=MROW+1,NROW
1235 PROD1 = PROD1+NSUB(1,J1A(MROW),J3)*NSUB(1,J1A(ROW),J3)
1240 D = (POS-NEG)/PROD1
1260 DO 1265 I=1,2
1265 R(I) = 0
IF (I1.GE.100) R(1) = BLANK
IF (I2.GE.100) R(2) = BLANK
1270 WRITE (5,127) D
127 FORMAT (/' SOMER''S D = ',F6.3)
1280 IF (NDF.EQ.1) WRITE (5,1281)
IF (NDF.GT.1) WRITE (5,1282)
1281 FORMAT (' (PERCENTAGE DIFFERENCE',$)
1282 FORMAT (' (PROPORTION DIFFERENTIAL',$)
WRITE (5,1283) R(1),I1,R(2),I2
1283 FORMAT ('+ FOR VARIABLE',A1,I3,' RELATIVE TO VARIABLE',A1,I3,')')
C REPEAT OR CONCLUDE.
1300 CONTINUE
IF (L(I3).NE.H(I3)) WRITE (5,34)
IF (.NOT.OPT(7)) GO TO 1350
IF (NADF.NE.1 .OR. L(I3).EQ.H(I3)) GO TO 1350
NLL = 0
NLH = 0
NHL = 0
NHH = 0
1310 DO 1315 J3=L(I3),H(I3)
NLL = NLL+NUM(L(I1),L(I2),J3)
NLH = NLH+NUM(L(I1),H(I2),J3)
NHL = NHL+NUM(H(I1),L(I2),J3)
NHH = NHH+NUM(H(I1),H(I2),J3)
1315 CONTINUE
POS = NLL*NHH
NEG = NLH*NHL
IF (POS+NEG.EQ.0.0) GO TO 1350
QZERO = (POS-NEG)/(POS+NEG)
POS = 0.0
NEG = 0.0
1320 DO 1325 J3=L(I3),H(I3)
POS = POS+NUM(L(I1),L(I2),J3)*NUM(H(I1),H(I2),J3)
NEG = NEG+NUM(L(I1),H(I2),J3)*NUM(H(I1),L(I2),J3)
1325 CONTINUE
IF (POS+NEG.EQ.0.0) GO TO 1350
QPART = (POS-NEG)/(POS+NEG)
POS = 0.0
NEG = 0.0
1330 DO 1335 J3=L(I3),H(I3)
POS = POS+NUM(L(I1),L(I2),J3)*(NHH-NUM(H(I1),H(I2),J3))
NEG = NEG+NUM(L(I1),H(I2),J3)*(NHL-NUM(H(I1),L(I2),J3))
1335 CONTINUE
IF (POS+NEG.EQ.0.0) GO TO 1350
QDIFF = (POS-NEG)/(POS+NEG)
1340 WRITE (5,134) QZERO,QPART,QDIFF
134 FORMAT (///
1 ' ZERO ORDER Q = ',F6.3/
2 ' PARTIAL Q = ',F6.3/
3 ' DIFFERENTIAL Q = ',F6.3)
1350 WRITE (5,135) NTAB,NOUT,LAST
135 FORMAT (///
1 ' EXCLUSION ANALYSIS:'//
2 ' TABLE TOTAL ',I4/
3 ' EXCLUDED ',I4/
4 ' SAMPLE SIZE ',I4)
TYPE 34
L(I3) = I3L
H(I3) = I3H
WRITE (5,201)
GO TO 202
C
C ITEM: INTERCORRELATE VARIABLES.
1400 ZERO = ENTRY(0).NE.ANS
IF (ENTRY(1).EQ.'PART') CALL DECODE
ZERO = ZERO .OR. ENTRY(1).EQ.' '
IF (ZERO) TYPE 1401
1401 FORMAT (' VARIABLES TO BE CORRELATED? ',$)
IF (ZERO) ACCEPT 3, (ENTRY(N),N=1,12)
IF (ENTRY(1).EQ.'NONE' .OR. ENTRY(1).EQ.'ABORT') GO TO 200
IF (ENTRY(1).EQ.'STOP') GO TO 2000
IF (ENTRY(1).EQ.'EXPLA' .OR. ENTRY(1).EQ.'?') TYPE 1402
1402 FORMAT (
1 ' ENTER 2 TO 9 VARIABLES TO BE INTERCORRELATED. ANY'/
2 ' VARIABLE TO BE CORRELATED THAT IS PRECEDED BY A MINUS'/
3 ' SIGN WILL BE REFLECTED. IF YOU DO NOT WANT TO HAVE'/
4 ' ANY VARIABLES CORRELATED, TYPE "NONE".'//
5 ' WHEN THE COMMAND "ITEM PART" IS GIVEN, ANOTHER VARI-'/
6 ' ABLE MAY BE ENTERED SEPARATELY AS A CONTROL. IF THE'/
7 ' CONTROL VARIABLE IS FOLLOWED BY AN EQUALS SIGN AND A'/
8 ' CATEGORY NUMBER (0 TO 9), CORRELATIONS WILL BE LIMITED'/
9 ' TO RESPONDENTS IN THAT CATEGORY ONLY. IF THE CONTROL'/
/ ' VARIABLE IS FOLLOWED BY AN INEQUALITY SIGN (<>) AND A'/
1 ' CATEGORY NUMBER, RESPONDENTS IN THAT CATEGORY WILL BE'/
2 ' EXCLUDED.'/)
CALL DECODE
READ (20,10) (IA(N),N=1,9)
IA(10) = 0
IF (IA(1).EQ.0) GO TO 1400
DO 1410 N=1,9
IF (IABS(IA(N)).LE.M) GO TO 1405
TYPE 232
GO TO 1400
1405 IF (L(IA(N)).LE.H(IA(N))) GO TO 1410
TYPE 233
GO TO 1400
1410 IF (IA(N+1).EQ.0) GO TO 1415
1415 IF (N.LT.2) GO TO 1400
NVAR = N
I3 = 0
I3L = 0
I3H = 0
IF (SAVE.NE.'PART') GO TO 1430
1420 TYPE 142
142 FORMAT (' CONTROL? ',$)
1421 ACCEPT 3, (ENTRY(N),N=1,12)
IF (ENTRY(1).EQ.'ABORT') GO TO 200
IF (ENTRY(1).EQ.'STOP') GO TO 2000
BLURB = ENTRY(1).EQ.'EXPLA' .OR. ENTRY(1).EQ.'?'
IF (BLURB) TYPE 1422
1422 FORMAT (' ENTER CONTROL VARIABLE OR TYPE "NONE": ',$)
IF (BLURB) GO TO 1421
CALL DECODE
READ (20,104) I3,N3,N3X
IF (I3.GE.0 .AND. I3.LE.M) GO TO 1425
TYPE 232, M
GO TO 1420
1425 J3X = JK(N3X)
IF (J3X.GT.9) J3X = -1
REJECT = (N3.EQ.'<' .OR. N3.EQ.'>') .AND. J3X.GE.0
J3 = JK(N3)
IF (J3.LT.0 .OR. J3.GT.9) J3 = J3X
I3L = L(I3)
I3H = H(I3)
IF (J3.LT.0) GO TO 1430
I3L = J3
I3H = J3
1430 DO 1490 MJ3=I3L,I3H
IF (MJ3.NE.I3L) WRITE (5,34)
WRITE (5,143)
143 FORMAT (///' ITEM INTERCORRELATIONS:')
R(3) = EQUAL
IF (REJECT) R(3) = DIFFER
IF (I3.NE.0) WRITE (5,1431) I3,R(3),MJ3,X(I3)
1431 FORMAT (//
1 ' CONTROL: VARIABLE ',I3,2X,A2,' CATEGORY ',I1,A1)
1440 WRITE (5,144) (IA(COL),X(IABS(IA(COL))),COL=1,NVAR)
144 FORMAT (//10X,9(2X,I4,A1))
WRITE (5,34)
DO 1470 ROW=1,NVAR
G(ROW,ROW,MJ3) = 1.0
DO 1460 COL=ROW+1,NVAR
IF (MJ3.NE.I3L .OR. ROW.EQ.NVAR) GO TO 1460
I1 = IABS(IA(ROW))
I2 = IABS(IA(COL))
SGN = ISIGN(1,IA(ROW)*IA(COL))
GO TO 300
1450 DO 1460 J3=I3L,I3H
POS = 0.0
NEG = 0.0
DO 1454 MJ1=L(I1),H(I1)-1
DO 1454 MJ2=L(I2),H(I2)-1
DO 1454 J1=MJ1+1,H(I1)
DO 1454 J2=MJ2+1,H(I2)
1454 POS = POS+NUM(MJ1,MJ2,J3)*NUM(J1,J2,J3)
DO 1458 MJ1=L(I1),H(I1)-1
DO 1458 MJ2=L(I2)+1,H(I2)
DO 1458 J1=MJ1+1,H(I1)
DO 1458 J2=L(I2),MJ2-1
1458 NEG = NEG+NUM(MJ1,MJ2,J3)*NUM(J1,J2,J3)
G(ROW,COL,J3) = 0.0
IF (POS.NE.NEG) G(ROW,COL,J3) = SGN*(POS-NEG)/(POS+NEG)
G(COL,ROW,J3) = G(ROW,COL,J3)
1460 CONTINUE
GSUM = 0.0
ASUM = 0.0
DO 1465 COL=1,NVAR
GSUM = GSUM+G(ROW,COL,MJ3)
ASUM = ASUM+ABS(G(ROW,COL,MJ3))
1465 CONTINUE
GMEAN(ROW) = (GSUM-1.)/(NVAR-1)
AMEAN(ROW) = (ASUM-1.)/(NVAR-1)
1470 WRITE (5,147) IA(ROW),X(IABS(IA(ROW))),(G(ROW,COL,MJ3),COL=1,NVAR)
147 FORMAT (' ',I4,A1,4X,9F7.3)
1480 WRITE (5,148) (GMEAN(COL),COL=1,NVAR)
148 FORMAT (/' MEAN ',4X,9F7.3)
1490 WRITE (5,149) (AMEAN(COL),COL=1,NVAR)
149 FORMAT (' MEAN ABS ',9F7.3)
TYPE 34
WRITE (5,201)
GO TO 202
C
C STOP: TERMINATE EXECUTION.
2000 END FILE 5
CALL TIME(NOW)
NAME = NOW-851968
NAMEZ = NOW-1900544
IF (RENAME(NAME,'.OUT','FOR05','.DAT')) TYPE 2001, NAMEZ
2001 FORMAT (' OUTPUT SAVED AS FILE ',A5,'.OUT'/)
TYPE 34
CALL OFIL(20,LIST,'.TMP')
END FILE 20
2002 FORMAT (
1 ' THE COMMAND "STOP" MAY BE GIVEN AS A RESPONSE TO ANY'/
2 ' REQUEST FOR INFORMATION. EXECUTION OF THE PROGRAM IS'/
3 ' TERMINATED, AND THE DATA FILE REVERTS TO ITS ORIGINAL'/
4 ' FORM.'/)
STOP
END
C
FUNCTION JK(N)
JK = N/536870912-48
IF (JK.GE.0) RETURN
JK = 10-(JK-3)/6
RETURN
END
C
FUNCTION NK(J)
IF (J.GE.10) J = (13-J)*(J-7)-J-3*(J/12)
NK = (J+48)*536870912
RETURN
END
C
SUBROUTINE DECODE
COMMON ENTRY(0/13),LIST
CALL OFIL(20,LIST,'.TMP')
WRITE (20,3) (ENTRY(N),N=1,12)
3 FORMAT (12A5)
END FILE 20
CALL IFIL(20,LIST,'.TMP')
IF (ENTRY(1).LT.'MAP 0' .OR. ENTRY(1).GT.'MAP Z') GO TO 50
READ (20,4) (ENTRY(N),N=0,12)
4 FORMAT (A4,12A5)
CALL OFIL(20,LIST,'.TMP')
WRITE (20,3) (ENTRY(N),N=0,11)
END FILE 20
CALL IFIL(20,LIST,'.TMP')
RETURN
50 DO 55 N=0,12
55 ENTRY(N) = ENTRY(N+1)
RETURN
END
C
SUBROUTINE CHISQ(CS,NDF,PR)
PR = 1.
IF (CS.EQ.0) RETURN
DF = NDF
IF (CS.LT.DF) GO TO 100
A = DF
B = 10000.
F = CS/DF
GO TO 200
100 A = 10000.
B = DF
F = DF/CS
200 A1 = 2./(9.*A)
B1 = 2./(9.*B)
Y = ((1.-B1)*F**(1./3.)-1.+A1)/SQRT(B1*F**(2./3.)+A1)
Z = ABS(Y)
IF (B.LT.4.) Z = Z*(1+.08*Z**4/B**3)
PR = .5/(1+Z*(.196854+Z*(.115194+Z*(.000344+Z*.019527))))**4
IF (CS.LT.DF .AND. Y.GE.0) PR = 1.-PR
RETURN
END
C
C LOGICAL FUNCTION RENAME(NEWNAM,NEWEXT,OLDNAM,OLDEXT)
C RETURNS VALUE .FALSE. IF FILE OLDNAM.EXT DOES NOT EXIST.
C OTHERWISE, RENAME IS .TRUE. AND FILE IS RENAMED NEWNAM.EXT
C WITH PROTECTION <155>. THIS SUBPROGRAM IS WRITTEN IN THE
C MACRO-10 ASSEMBLER LANGUAGE.