Trailing-Edge
-
PDP-10 Archives
-
decus_20tap5_198111
-
decus/20-0137/colchi/colchi.for
There is 1 other file named colchi.for in the archive. Click here to see a list.
C WESTERN MICHIGAN UNIVERSITY
C COLCHI.F4 (FILENAME ON LIBRARY DECTAPE)
C COLCHI, 1.1.3 (CALLING NAME, SUBLST NO.)
C CHI SQUARE, GAMMA, TAU-A,B,C, AND SOMER'S D WITH
C COLLAPSING OF CONTINGENCY TABLE CAPABILITIES.
C COLCHI WAS PROGRAMMED BY SAM ANEMA AND LATER MODIFIED BY
C R. R. BARR.
C LIBRARY DECTAPE PROGS. USED: USAGE.MAC
C APLIB.F4 PROGS. USED: CHIPRB, NORMCV
C INTERNAL SUBR. USED: CLAP, CHIS, SOMER, THETA
C ABOVE COMMENTS AND RIGHT ADJUSTED COMMENTS WERE PUT IN BY WG
C
DIMENSION NFRE(40,40),NFQ(40,40),ID(14)
DIMENSION NSR(40),NSC(40)
IOUT=-1
INP=-4
C CALL USAGE('COLCHI')
WRITE(IOUT,99)
99 FORMAT(//,' WMU - COLLAPSING CHI SQUARE',//)
100 WRITE(IOUT,101)
101 FORMAT(' ','HOW MANY ROWS?'/)
READ(INP,102)NR
102 FORMAT(I)
WRITE(IOUT,103)
103 FORMAT(' ','HOW MANY COLUMNS?'/)
READ(INP,102)NC
107 WRITE(IOUT,109)
109 FORMAT(' ','ENTER IDENTIFICATION.'/)
READ(INP,110)(ID(I),I=1,14)
110 FORMAT(14A5)
106 WRITE(IOUT,213)
213 FORMAT(' ','ENTER FREQUENCIES.'/)
DO 290 J=1,NR
290 READ(INP,113)(NFRE(I,J),I=1,NC)
113 FORMAT(40I)
WRITE(IOUT,300)(ID(I),I=1,14)
300 FORMAT(' ',14A5)
DO 301 I=1,NR
DO 301 J=1,NC
301 NFQ(J,I)=NFRE(J,I)
NNR=NR
NNC=NC
302 CALL CHIS(NFQ,NNR,NNC,NTOT,NSR)
304 WRITE(IOUT,303)
303 FORMAT(' ','TYPE:'/3X,'1 TO TERMINATE'/3X,'2 TO ENTER',
1' MORE DATA'/3X,'3 TO COLLAPSE'/3X,'4 FOR GAMMA STATISTICS'/
23X,'5 FOR THETA'/)
READ(INP,102)NTO
GO TO (1000,100,305,306,320),NTO
305 CALL CLAP(NFRE,NR,NC,NFQ,NNR,NNC)
GO TO 302
306 CALL SOMER(NFQ,NNR,NNC,NTOT)
GO TO 304
320 CALL THETA(NFQ,NNR,NNC,NSR)
GO TO 304
1000 CALL EXIT
END
C---------------NFRE, NC ARE INPUT. NFG, NNR, NNC ARE RETURNED.
C--------------- NR APPARENTLY NOT USED.
SUBROUTINE CLAP(NFRE,NR,NC,NFQ,NNR,NNC)
DIMENSION NFRE(40,40),IR(40),NFQ(40,40)
IOUT=-1
INP=-4
WRITE(IOUT,10)
10 FORMAT(' ','WHAT IS THE NEW NUMBER OF ROW CATEGORIES?'/)
READ(INP,20)NNR
20 FORMAT(40I)
WRITE(IOUT,30)
30 FORMAT(' ','ENTER NEW ROW CATEGORIZATION'/)
DO 50 I=1,NNR
READ(INP,20)(IR(K),K=1,40)
KK=0
DO 40 K=1,40
IF(IR(K))70,70,60
60 KK=KK+1
40 CONTINUE
70 DO 80 K=1,NC
LM=0
DO 100 KR=1,KK
IRT=IR(KR)
100 LM=LM+NFRE(K,IRT)
80 NFQ(K,I)=LM
50 CONTINUE
DO 400 I=1,40
400 IR(I)=0
WRITE(IOUT,200)
200 FORMAT(' ','WHAT IS THE NEW NUMBER OF COLUMN CATEGORIES?'/)
READ(INP,20)NNC
WRITE(IOUT,210)
210 FORMAT(' ','ENTER NEW COLUMN CATEGORIZATION.'/)
DO 220 I=1,NNC
READ(INP,20)(IR(K),K=1,40)
KK=0
DO 230 K=1,40
IF(IR(K))240,240,250
250 KK=KK+1
230 CONTINUE
240 DO 260 K=1,NNR
LM=0
DO 270 KR=1,KK
IRT=IR(KR)
270 LM=LM+NFQ(IRT,K)
260 NFQ(I,K)=LM
220 CONTINUE
RETURN
END
C---------------NTOT, NSR RETURNED. OTHER ARGS. ARE INPUT.
SUBROUTINE CHIS(NFRE,NR,NC,NTOT,NSR)
DIMENSION NFRE(40,40),NSR(40),NSC(40)
INP=-4
IOUT=-1
DO 200 J=1,NR
200 NSR(J)=0
DO 210 I=1,NC
210 NSC(I)=0
NTOT=0
DO 220 J=1,NR
DO 220 I=1,NC
NSR(J)=NSR(J)+NFRE(I,J)
NSC(I)=NSC(I)+NFRE(I,J)
220 CONTINUE
DO 230 J=1,NR
230 NTOT=NTOT+NSR(J)
CHI=0.
IDF=(NR-1)*(NC-1)
DO 300 I=1,NC
DO 300 J=1,NR
IF(NR.EQ.1.OR.NC.EQ.1)GO TO 377
GO TO 378
377 E=FLOAT(NTOT)/FLOAT(NR*NC)
GO TO 379
378 E=FLOAT(NSR(J)*NSC(I))/FLOAT(NTOT)
379 CHI=CHI+((FLOAT(NFRE(I,J))-E)**2)/E
300 CONTINUE
CALL CHIPRB(CHI,IDF,CPRB)
WRITE(IOUT,310)
310 FORMAT(' ',20X,'CONTINGENCY TABLE'//)
WRITE(IOUT,320)(I,I=1,NC)
320 FORMAT(' ','VAR',I3,40I6)
DO 330 J=1,NR
330 WRITE(IOUT,340)J,(NFRE(I,J),I=1,NC),NSR(J)
340 FORMAT(/' ',I2,I4,41I6)
WRITE(IOUT,350)(NSC(I),I=1,NC),NTOT
350 FORMAT(/' ',41I6)
WRITE(IOUT,360)CHI,CPRB
360 FORMAT(//' ','CHI-SQUARE = ',F12.5,4X,'PROB =',F8.5)
IF(NR.LT.2.OR.NC.LT.2)RETURN
CONCOF=SQRT(CHI/(FLOAT(NTOT)+CHI))
PS=CHI/FLOAT(NTOT)
L=MIN0(NC,NR)
PP=SQRT(PS/(FLOAT(L)-1.))
IF(NC.NE.2.OR.NR.NE.2)GO TO 371
A=NFRE(1,1)
B=NFRE(1,2)
C=NFRE(2,1)
D=NFRE(2,2)
TOT=NTOT
CHI=TOT*(ABS(A*D-B*C)-TOT/2.0)**2/((A+B)*(C+D)*(A+C)*(B+D))
CALL CHIPRB(CHI,IDF,CPRB)
WRITE(IOUT,372)CHI,CPRB
372 FORMAT(' 2X2 CORRECTED CHI-SQUARE = 'F12.5,4X,'PROB =',F8.5)
371 WRITE(IOUT,370)CONCOF,PS,PP,IDF
370 FORMAT(' ','CONTINGENCY COEFFICIENT = ',F12.5/' PHI-SQUARE = ',
1F12.5/' PHI-PRIME = ',F12.5/ ' DEGREES OF FREEDOM = ',I4)
RETURN
END
SUBROUTINE SOMER(NFRE,NR,NC,NTOT)
DIMENSION NFRE(40,40)
IOUT=-1
INP=-4
NC1=NC-1
NR1=NR-1
NP=0
DO 400 K2=1,NC1
DO 400 K=1,NR1
NT=0
LL=K2+1
KK=K+1
DO 410 I=LL,NC
DO 410 J=KK,NR
NT=NT+NFRE(I,J)
410 CONTINUE
NP=NP+NT*NFRE(K2,K)
400 CONTINUE
NQ=0
DO 420 K2=2,NC
DO 420 K=1,NR1
NT=0
LL=K2-1
KK=K+1
DO 430 I=1,LL
DO 430 J=KK,NR
NT=NT+NFRE(I,J)
430 CONTINUE
NQ=NQ+NT*NFRE(K2,K)
420 CONTINUE
NX=0
DO 440 K=1,NC
DO 440 L=1,NR1
L1=L+1
DO 440 J=L1,NR
NX=NX+NFRE(K,L)*NFRE(K,J)
440 CONTINUE
NY=0
DO 450 K=1,NR
DO 450 L=1,NC1
L1=L+1
DO 450 J=L1,NC
NY=NY+NFRE(L,K)*NFRE(J,K)
450 CONTINUE
500 FORMAT(' ',8I7)
P=NP
Q=NQ
TOT=NTOT
X=NX
Y=NY
GAMMA=(P-Q)/(P+Q)
TAUA=(2.*(P-Q))/(TOT*(TOT-1.))
TAUB=(P-Q)/SQRT((P+Q+X)*(P+Q+Y))
EM=AMIN0(NR,NC)
TAUC=((P-Q)*2.*EM)/(TOT**2*(EM-1.))
DYX=(P-Q)/(P+Q+Y)
DXY=(P-Q)/(P+Q+X)
WRITE(IOUT,460)GAMMA,TAUA,TAUB,TAUC,DYX,DXY
460 FORMAT(/' ','GAMMA = ',F12.5/' TAU-A = ',F12.5/' TAU-B = ',
1F12.5/' TAU-C = ',F12.5/' DYX = ',F12.5/' DXY = ',F12.5)
RETURN
END
C---------------ALL ARGS. ARE INPUT
SUBROUTINE THETA(NFQ,NR,NC,NSR)
DIMENSION NFQ(40,40),NSR(40)
IOUT=-1
INP=-4
NTT=0
NC1=NC-1
NR1=NR-1
DO 500 I=1,NR1
II=I+1
DO 500 J=II,NR
NTT=NTT+NSR(I)*NSR(J)
500 CONTINUE
ND=0
DO 510 J=1,NR1
JJ=J+1
DO 510 K=JJ,NR
NB=0
DO 530 I=1,NC1
II=I+1
DO 530 L=II,NC
NB=NB+NFQ(I,J)*NFQ(L,K)
530 CONTINUE
NA=0
DO 540 I=2,NC
II=I-1
DO 540 L=1,II
NA=NA+NFQ(I,J)*NFQ(L,K)
540 CONTINUE
ND=ND+IABS(NB-NA)
510 CONTINUE
THET=FLOAT(ND)/FLOAT(NTT)
WRITE(IOUT,520)ND,NTT,THET
520 FORMAT(' ','D = ',I5/' T2 = ',I5/' THETA = ',F12.5)
RETURN
END