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