Trailing-Edge
-
PDP-10 Archives
-
decuslib10-09
-
43,50466/srho.f4
There are no other files named srho.f4 in the archive.
C WESTERN MICHIGAN UNIVERSITY
C SRHO.F4 (FILE NAME ON LIBRARY DECTAPE)
C SRHO, 1.11.1 (CALLING NAME, SUBLST NO.)
C SPEARMAN'S RHO
C THIS PROGRAM IS A COMBINATION OF ONE GIVEN BY WAYNE STATE
C UNIVERSITY WITH REVISIONAL AND ADDITIONAL PROGRAMMING BY
C B. GRANET AND MRS. EVA GAINES.
C LIBRARY DECTAPE PROGRAMS USED: USAGE.MAC
C FORWMU PROGS. USED: DEVCHG, EXISTS, PRINTS
C APLIB PROGS. USED: IO, GETFOR, FISHER
C ABOVE COMMENTS AND RIGHT ADJUSTED COMMENTS PUT IN BY WG
C
C---------------X(200,25) ALLOWS FOR 200 OBS. ON 25 VARS.,
C--------------- VECTO(200) IS TEMPORARY STORAGE FOR ALL OBS.
C--------------- ON A VAR.
DIMENSION X(200 , 25 ) , TIES(200) , T(25) , IND(200) ,
1 BSQU(25) , VECTO(200),ID(16),IFMT(96),L(25)
INT=5
IDLG=-1
IOUT=2
C---------------TTYPTY RETURNS ZERO - TTY JOB, MINUS ONE - BATCH JOB
CALLTTYPTY(ICODE)
INP=1
WRITE(IDLG,9876)
9876 FORMAT(//,' WMU',/,' SPEARMAN''S RHO',//)
C CALL USAGE('SRHO')
C---------------IDEV IS RETURNED, OTHER ARGS. ARE INPUT.
C--------------- 1 MEANS OUTPUT? PRINTS, 0 MEANS INPUT? PRINTS.
CALL IO(2,IDEV,IDLG,INT,1,ICODE)
5 CALL IO(INP,IDEV,IDLG,INT,0,ICODE)
NOBS=0
WRITE(IDLG,80012)
80012 FORMAT('-IF YOU DESIRE OUTPUT IDENTIFICATION,ENTER UP TO 80'/
1' CHARACTERS. OTHERWISE,JUST RETURN CARRIAGE'/)
READ(INT,84)(ID(I),I=1,16)
84 FORMAT(16A5)
WRITE(IDLG,13113)
13113 FORMAT(' ENTER THE NUMBER OF VARIABLES'/)
READ(INT,3)NVAR
3 FORMAT(I)
IF(NVAR.GE.2.AND.NVAR.LE.25) GO TO 1
6 WRITE(IDLG,7)
7 FORMAT(1X,'YOUR RESPONSE VIOLATED A LIMITATION. TRY AGAIN.'/)
CALL DEVICE(INT)
GO TO 13113
C---------------IFMT, ISTD ARE RETURNED. OTHER ARGS. ARE INPUT.
C--------------- 96=NO. OF OBJ. TIME FORMAT WORDS (6 LINES). 2 MEANS
C--------------- F-TYPE FORMAT ONLY.
1 CALL GETFOR(IDLG,INT,IFMT,ISTD,96,2)
IF(IDEV.NE.'TTY') GO TO 9
WRITE(IDLG,40006)
40006 FORMAT(' ENTER DATA'/)
2 IF(ISTD )3322,3321,3322
3322 READ(INP,2003,END=4) (VECTO(K),K=1,NVAR)
2003 FORMAT(10F)
GO TO 8030
3321 READ(INP,IFMT,END=4) (VECTO(K),K=1,NVAR)
8030 NOBS=NOBS+1
DO 7031 K=1,NVAR
7031 X(NOBS,K)=VECTO(K)
GO TO 2
4 WRITE(IOUT,556)(ID(I),I=1,16)
556 FORMAT(1H-,16A5/)
NROW=NOBS
NCOL=NVAR
IF(NOBS-1) 9998,9998,100
9998 WRITE (IDLG,2010)NROW,NCOL
2010 FORMAT(1H0, 20X, 25HNON EXECUTABLE PROGRAM /1H , 5X,
1 5HNOBS= , 2X, I5, 5X, 5HNVAR= ,2X, I5 )
19002 FORMAT(' NOTE: SINCE THE NUMBER OF OBSERVATIONS IS LESS THAN 10,'/
1 ' T-VALUE IS NOT APPLICABLE')
9 WRITE(IDLG,10)
10 FORMAT(1X,'DATA BEING PROCESSED'/)
GO TO 2
100 CONTINUE
WRITE(IOUT,20)
20 FORMAT(1H1, 25X, 26HWEST. MICH. UNIVERSITY )
WRITE(IOUT,21)
21 FORMAT (1H ,25X, 17HCOMPUTER CENTER )
WRITE(IOUT,24)
24 FORMAT (1H , 25X, 28HSPEARMAN-S RHO COMPUTATION )
NCOL1=NCOL-1
LARGE=NROW+1
A6=LARGE*(LARGE-1)*(LARGE-2)
A6=A6/6.
SMALL=-.99999999E38
BIG=.99999999E38
DO 900 J=1,NCOL
INDPR=0
DO 120 I=1 ,NROW
TEMP=X(I,J)
ATIES=0.
DO 118 I1=1,NROW
IF(TEMP-X(I1,J) ) 118, 101,118
101 ATIES=ATIES+1.
118 CONTINUE
TIES(I)=ATIES
120 CONTINUE
DO 4000 I=1,NROW
VECTO(I)=X(I,J)
4000 CONTINUE
TRESU=0.
4001 CONTINUE
DO 4002 I=1,NROW
IF(BIG-VECTO(I)) 4003,4002,4003
4002 CONTINUE
GO TO 5000
4003 ELEM=VECTO(I)
CTIES=0.
DO 4010 I1=1,NROW
IF(ELEM-VECTO(I1)) 4010, 4009, 4010
4009 CTIES=CTIES+1 .
VECTO(I1)=BIG
4010 CONTINUE
4011 TRESU=TRESU+CTIES*(CTIES-1.)*(CTIES+1.)
GO TO 4001
5000 T(J)=TRESU
TEMP=T(J)
T(J)=TEMP/12.
BSQU(J)=A6-2.*T(J)
DO 220 I=1,NROW
XMAX=X(1,J)
IXMAX=1
DO 215 I1=1,NROW
IF(XMAX-X(I1,J)) 201,215,215
201 XMAX=X(I1,J)
IXMAX=I1
215 CONTINUE
IND(IXMAX)=INDPR+1
INDPR=IND(IXMAX)
X(IXMAX,J)=SMALL
220 CONTINUE
MIN=1
225 CONTINUE
AMIN=MIN
DO 240 K=1,NROW
IF(MIN-IND(K )) 240, 230 , 240
230 IMIN=K
GO TO 250
240 CONTINUE
250 KOUNT=TIES(IMIN )
DIV=KOUNT
LIMIT=MIN+KOUNT-1
RANK=0.
DO 260 K=1,KOUNT
AK=K
RANK=RANK+AMIN+AK-1.
260 CONTINUE
RANK=RANK/DIV
DO 290 I1=1,NROW
IF(MIN-IND(I1)) 290,270,290
270 X(I1,J)=RANK
MIN=MIN+1
IF(MIN-LIMIT) 290 , 290 , 300
290 CONTINUE
300 IF(LIMIT-NROW) 225 , 900, 900
900 CONTINUE
IF (NOBS-10)903,905,905
903 WRITE (IOUT,19002)
905 DO 1000 I=1,NCOL1
JLIM=I+1
DO 1000 J=JLIM,NCOL
SD2=0.
DO 910 K=1 ,NROW
TEMP=X(K,I)-X(K,J)
SD2=SD2+TEMP*TEMP
910 CONTINUE
FI=BSQU(I)
FJ=BSQU(J)
TEMP=FI*FJ
930 TEMP=SQRT (TEMP)
A1=A6-SD2-T(I)-T(J)
RHO=A1/TEMP
IF(NOBS-10)943,19001,19001
943 WRITE(IOUT,10005)I,J,RHO
10005 FORMAT( 1H0 , 4HVAR( , I3 , 2H) , 1X , 4HVAR( , I3 ,
1 2H) , 2X, 4HRHO= , F10.4 )
GO TO 1000
19001 IF(RHO)945,942,945
945 IF(RHO-1.)946,942,946
942 AN=0.
GO TO 19000
946 AN=NOBS-2
RHO2=RHO*RHO
AN=AN/(1.0-RHO2)
AN= SQRT (AN)
AN=RHO*AN
19000 TPRB=FISHER(1,NOBS-2,AN*AN)
WRITE(IOUT,8)I,J,RHO,AN,TPRB
1000 CONTINUE
8 FORMAT( 1H0 , 4HVAR( , I3 , 2H) , 1X , 4HVAR( , I3 ,
1 2H) , 2X, 4HRHO= , F7.4 , 2X, 8HT VALUE= , F10.4,
#2X,'T-PROB. =',F8.5)
WRITE(IOUT,2070)
2070 FORMAT(1H1 )
GO TO 5
END