Trailing-Edge
-
PDP-10 Archives
-
decuslib20-05
-
decus/20-0137/srho/srho.for
There is 1 other file named srho.for in the archive. Click here to see a list.
00100 C WESTERN MICHIGAN UNIVERSITY
00200 C SRHO.F4 (FILE NAME ON LIBRARY DECTAPE)
00300 C SRHO, 1.11.1 (CALLING NAME, SUBLST NO.)
00400 C SPEARMAN'S RHO
00500 C THIS PROGRAM IS A COMBINATION OF ONE GIVEN BY WAYNE STATE
00600 C UNIVERSITY WITH REVISIONAL AND ADDITIONAL PROGRAMMING BY
00700 C B. GRANET AND MRS. EVA GAINES.
00800 C LIBRARY DECTAPE PROGRAMS USED: USAGE.MAC
00900 C FORWMU PROGS. USED: DEVCHG, EXISTS, PRINTS
01000 C APLIB PROGS. USED: IO, GETFOR, FISHER
01100 C ABOVE COMMENTS AND RIGHT ADJUSTED COMMENTS PUT IN BY WG
01200 C
01300 C---------------X(200,25) ALLOWS FOR 200 OBS. ON 25 VARS.,
01400 C--------------- VECTO(200) IS TEMPORARY STORAGE FOR ALL OBS.
01500 C--------------- ON A VAR.
01600 DIMENSION X(200 , 25 ) , TIES(200) , T(25) , IND(200) ,
01700 1 BSQU(25) , VECTO(200),ID(16),IFMT(96),L(25)
01800 INT=5
01900 IDLG=-1
02000 IOUT=2
02100 C---------------TTYPTY RETURNS ZERO - TTY JOB, MINUS ONE - BATCH JOB
02200 CALLTTYPTY(ICODE)
02300 INP=1
02400 WRITE(IDLG,9876)
02500 9876 FORMAT(//,' WMU',/,' SPEARMAN''S RHO',//)
02600 C CALL USAGE('SRHO')
02700 C---------------IDEV IS RETURNED, OTHER ARGS. ARE INPUT.
02800 C--------------- 1 MEANS OUTPUT? PRINTS, 0 MEANS INPUT? PRINTS.
02900 CALL IO(2,IDEV,IDLG,INT,1,ICODE)
03000 5 CALL IO(INP,IDEV,IDLG,INT,0,ICODE)
03100 NOBS=0
03200 WRITE(IDLG,80012)
03300 80012 FORMAT('-IF YOU DESIRE OUTPUT IDENTIFICATION,ENTER UP TO 80'/
03400 1' CHARACTERS. OTHERWISE,JUST RETURN CARRIAGE'/)
03500 READ(INT,84)(ID(I),I=1,16)
03600 84 FORMAT(16A5)
03700 WRITE(IDLG,13113)
03800 13113 FORMAT(' ENTER THE NUMBER OF VARIABLES'/)
03900 99 READ(INT,3)NVAR
04000 3 FORMAT(I)
04100 IF(NVAR.GE.2.AND.NVAR.LE.25) GO TO 1
04200 6 WRITE(IDLG,7)
04300 7 FORMAT(1X,'YOUR RESPONSE VIOLATED A LIMITATION. TRY AGAIN.'/)
04400 CALL DEVICE(INT)
04500 GO TO 99
04600 C---------------IFMT, ISTD ARE RETURNED. OTHER ARGS. ARE INPUT.
04700 C--------------- 96=NO. OF OBJ. TIME FORMAT WORDS (6 LINES). 2 MEANS
04800 C--------------- F-TYPE FORMAT ONLY.
04900 1 CALL GETFOR(IDLG,INT,IFMT,ISTD,96,2)
05000 IF(IDEV.NE.'TTY') GO TO 9
05100 WRITE(IDLG,40006)
05200 40006 FORMAT(' ENTER DATA'/)
05300 2 IF(ISTD )3322,3321,3322
05400 3322 READ(INP,2003,END=4) (VECTO(K),K=1,NVAR)
05500 2003 FORMAT(10F)
05600 GO TO 8030
05700 3321 READ(INP,IFMT,END=4) (VECTO(K),K=1,NVAR)
05800 8030 NOBS=NOBS+1
05900 DO 7031 K=1,NVAR
06000 7031 X(NOBS,K)=VECTO(K)
06100 GO TO 2
06200 4 WRITE(IOUT,556)(ID(I),I=1,16)
06300 556 FORMAT(1H-,16A5/)
06400 NROW=NOBS
06500 NCOL=NVAR
06600 IF(NOBS-1) 9998,9998,100
06700 9998 WRITE (IDLG,2010)NROW,NCOL
06800 2010 FORMAT(1H0, 20X, 25HNON EXECUTABLE PROGRAM /1H , 5X,
06900 1 5HNOBS= , 2X, I5, 5X, 5HNVAR= ,2X, I5 )
07000 19002 FORMAT(' NOTE: SINCE THE NUMBER OF OBSERVATIONS IS LESS THAN 10,'/
07100 1 ' T-VALUE IS NOT APPLICABLE')
07200 9 WRITE(IDLG,10)
07300 10 FORMAT(1X,'DATA BEING PROCESSED'/)
07400 GO TO 2
07500 100 CONTINUE
07600 WRITE(IOUT,20)
07700 20 FORMAT(1H1, 25X, 26HWEST. MICH. UNIVERSITY )
07800 WRITE(IOUT,21)
07900 21 FORMAT (1H ,25X, 17HCOMPUTER CENTER )
08000 WRITE(IOUT,24)
08100 24 FORMAT (1H , 25X, 28HSPEARMAN-S RHO COMPUTATION )
08200 NCOL1=NCOL-1
08300 LARGE=NROW+1
08400 A6=LARGE*(LARGE-1)*(LARGE-2)
08500 A6=A6/6.
08600 SMALL=-.99999999E38
08700 BIG=.99999999E38
08800 DO 900 J=1,NCOL
08900 INDPR=0
09000 DO 120 I=1 ,NROW
09100 TEMP=X(I,J)
09200 ATIES=0.
09300 DO 118 I1=1,NROW
09400 IF(TEMP-X(I1,J) ) 118, 101,118
09500 101 ATIES=ATIES+1.
09600 118 CONTINUE
09700 TIES(I)=ATIES
09800 120 CONTINUE
09900 DO 4000 I=1,NROW
10000 VECTO(I)=X(I,J)
10100 4000 CONTINUE
10200 TRESU=0.
10300 4001 CONTINUE
10400 DO 4002 I=1,NROW
10500 IF(BIG-VECTO(I)) 4003,4002,4003
10600 4002 CONTINUE
10700 GO TO 5000
10800 4003 ELEM=VECTO(I)
10900 CTIES=0.
11000 DO 4010 I1=1,NROW
11100 IF(ELEM-VECTO(I1)) 4010, 4009, 4010
11200 4009 CTIES=CTIES+1 .
11300 VECTO(I1)=BIG
11400 4010 CONTINUE
11500 4011 TRESU=TRESU+CTIES*(CTIES-1.)*(CTIES+1.)
11600 GO TO 4001
11700 5000 T(J)=TRESU
11800 TEMP=T(J)
11900 T(J)=TEMP/12.
12000 BSQU(J)=A6-2.*T(J)
12100 DO 220 I=1,NROW
12200 XMAX=X(1,J)
12300 IXMAX=1
12400 DO 215 I1=1,NROW
12500 IF(XMAX-X(I1,J)) 201,215,215
12600 201 XMAX=X(I1,J)
12700 IXMAX=I1
12800 215 CONTINUE
12900 IND(IXMAX)=INDPR+1
13000 INDPR=IND(IXMAX)
13100 X(IXMAX,J)=SMALL
13200 220 CONTINUE
13300 MIN=1
13400 225 CONTINUE
13500 AMIN=MIN
13600 DO 240 K=1,NROW
13700 IF(MIN-IND(K )) 240, 230 , 240
13800 230 IMIN=K
13900 GO TO 250
14000 240 CONTINUE
14100 250 KOUNT=TIES(IMIN )
14200 DIV=KOUNT
14300 LIMIT=MIN+KOUNT-1
14400 RANK=0.
14500 DO 260 K=1,KOUNT
14600 AK=K
14700 RANK=RANK+AMIN+AK-1.
14800 260 CONTINUE
14900 RANK=RANK/DIV
15000 DO 290 I1=1,NROW
15100 IF(MIN-IND(I1)) 290,270,290
15200 270 X(I1,J)=RANK
15300 MIN=MIN+1
15400 IF(MIN-LIMIT) 290 , 290 , 300
15500 290 CONTINUE
15600 300 IF(LIMIT-NROW) 225 , 900, 900
15700 900 CONTINUE
15800 IF (NOBS-10)903,905,905
15900 903 WRITE (IOUT,19002)
16000 905 DO 1000 I=1,NCOL1
16100 JLIM=I+1
16200 DO 1000 J=JLIM,NCOL
16300 SD2=0.
16400 DO 910 K=1 ,NROW
16500 TEMP=X(K,I)-X(K,J)
16600 SD2=SD2+TEMP*TEMP
16700 910 CONTINUE
16800 FI=BSQU(I)
16900 FJ=BSQU(J)
17000 TEMP=FI*FJ
17100 930 TEMP=SQRT (TEMP)
17200 A1=A6-SD2-T(I)-T(J)
17300 RHO=A1/TEMP
17400 IF(NOBS-10)943,19001,19001
17500 943 WRITE(IOUT,10005)I,J,RHO
17600 10005 FORMAT( 1H0 , 4HVAR( , I3 , 2H) , 1X , 4HVAR( , I3 ,
17700 1 2H) , 2X, 4HRHO= , F10.4 )
17800 GO TO 1000
17900 19001 IF(RHO)945,942,945
18000 945 IF(RHO-1.)946,942,946
18100 942 AN=0.
18200 GO TO 19000
18300 946 AN=NOBS-2
18400 RHO2=RHO*RHO
18500 AN=AN/(1.0-RHO2)
18600 AN= SQRT (AN)
18700 AN=RHO*AN
18800 19000 TPRB=FISHER(1,NOBS-2,AN*AN)
18900 WRITE(IOUT,8)I,J,RHO,AN,TPRB
19000 1000 CONTINUE
19100 8 FORMAT( 1H0 , 4HVAR( , I3 , 2H) , 1X , 4HVAR( , I3 ,
19200 1 2H) , 2X, 4HRHO= , F7.4 , 2X, 8HT VALUE= , F10.4,
19300 #2X,'T-PROB. =',F8.5)
19400 WRITE(IOUT,2070)
19500 2070 FORMAT(1H1 )
19600 GO TO 5
19700 END