C-------------------------------------------------------------------------- C C Program name: MULTI C C Description: Computes multivariate sample statistics C C Last revised: August 1988 C C-------------------------------------------------------------------------- C REAL XBAR(10),COV(10,10),D(500,10),X,XF(10),COVF(10,10), + MEAN(10),B(10),B1(10),C,Q INTEGER P,S,U,IPIVOT(10) C WRITE(*,1) 1 FORMAT(8(/),25X,'MULTI', +2(/),12X,'Multivariate sample statistics') C C Get the multivariate data: C CALL INPUT(P,M,N,D) C C Zero out the covariance matrix: C DO 11 I=1,P XF(I)=0.0 DO 12 J=1,P COVF(I,J)=0.0 12 CONTINUE 11 CONTINUE C C Write titles for output: C WRITE(*,181) 181 FORMAT(4(/),2X,'SAMPLE #',2X,'SAMPLE MEAN', + 10X,'SAMPLE COVARIANCE') C C Compute and print means and sample covariance values: C DO 70 S=1,N L=(S-1)*M+1 U=S*M C DO 10 J=1,P X=0.0 DO 20 I=L,U X=X+D(I,J) 20 CONTINUE XBAR(J)=X/FLOAT(M) XF(J)=XF(J)+XBAR(J)/FLOAT(N) 10 CONTINUE C DO 30 I=1,P DO 40 J=1,P C=0.0 DO 50 K=L,U C=C+(D(K,I)-XBAR(I))*(D(K,J)-XBAR(J)) 50 CONTINUE COV(I,J)=C/FLOAT(M-1) COVF(I,J)=COVF(I,J)+COV(I,J)/FLOAT(N) 40 CONTINUE 30 CONTINUE DO 60 I=1,P IF (I .EQ. 1) THEN WRITE(*,101) S,XBAR(1),(COV(1,K),K=1,P) 101 FORMAT(//,4X,I2,7X,F9.4,2X,10(2X,F9.4)) ELSE WRITE(*,102) XBAR(I),(COV(I,K),K=1,P) 102 FORMAT(/,13X,F9.4,2X,10(2X,F9.4)) END IF 60 CONTINUE CALL PAUSE 70 CONTINUE C C If there is only one sample, exit program C IF (N.EQ.1) GOTO 999 C C If there are two or more samples, compute and display C pooled mean and pooled covariance matrix: C WRITE(*,80) 80 FORMAT(4(/),2X,'POOLED SAMPLE MEAN', + 10X,'POOLED SAMPLE COVARIANCE',/) C DO 90 I=1,P WRITE(*,100) XF(I),(COVF(I,K),K=1,P) 100 FORMAT(/,7X,F9.4,5X,10(2X,F9.4)) 90 CONTINUE C 999 WRITE(*,81) 81 FORMAT(////) C C Give user option to save input multivariate data: C CALL SAVE(P,M,N,D) C STOP END C C C------------------------------------------------------------------------------ C SUBROUTINE INPUT(P,M,N,D) C REAL D(500,10) INTEGER P,M,N,SEL C 201 WRITE(*,203) 203 FORMAT(8(/),1X,'CHOOSE OPTION FOR ENTERING DATA: ', +////,5X,' (1) ENTER DATA FROM KEYBOARD', +/,5X,' (2) FETCH STORED DATA FILE ', +////,1X,'ENTER NUMBER OF SELECTION: ',/) C READ(*,*) SEL IF (SEL.GE.1.AND.SEL.LE.2) GOTO 207 C WRITE(*,205) 205 FORMAT(//,1X,'INVALID SELECTION. PLEASE TRY ', +'AGAIN') GOTO 201 C 207 GOTO (310,320), SEL C 310 CALL KEYBD(P,M,N,D) GOTO 330 C 320 CALL FETCH(P,M,N,D) C 330 RETURN END C C C------------------------------------------------------------------------------ C SUBROUTINE KEYBD(P,M,N,D) C REAL D(500,10) INTEGER P,M,N C WRITE(*,160) 160 FORMAT(//,1X,'ENTER NUMBER OF QUALITY CHARACTERISTICS ', + '(P<=10):',/) READ(*,*) P C WRITE(*,170) 170 FORMAT(//,1X,'ENTER NUMBER OF VECTOR OBSERVATIONS ', + 'PER SAMPLE (M<=25):',/) READ(*,*) M C WRITE(*,180) 180 FORMAT(//,1X,'ENTER NUMBER OF SAMPLES (N<=20):',/) READ(*,*) N C MN=M*N WRITE(*,190) 190 FORMAT(//,1X,'ENTER DATA: ', + /,5X,'ENTER ONE VECTOR OBSERVATION PER ROW,', + /,5X,'LEAVE ONE BLANK SPACE BETWEEN NUMBERS, AND', + /,5X,'HIT RETURN KEY AFTER EACH ROW OF DATA ENTERED.',/) READ(*,*) ((D(I,J),J=1,P),I=1,MN) C RETURN END C C---------------------------------------------------------------- C SUBROUTINE FETCH(P,M,N,DATA) C INTEGER P,M,N REAL DATA(500,10) CHARACTER*8 FILENAME C 70 WRITE(*,61) 61 FORMAT(//,' PLEASE ENTER DATA FILE NAME: ',/) READ(*,63) FILENAME 63 FORMAT(A8) IF (FILENAME.EQ.' ') GO TO 70 OPEN (1,FILE=FILENAME,STATUS='OLD') READ(1,192) P READ(1,192) M READ(1,192) N 192 FORMAT(I3) MN=M*N READ(1,*) ((DATA(I,J),J=1,P),I=1,MN) CLOSE(1) C RETURN END C C C---------------------------------------------------- C SUBROUTINE SAVE(P,M,N,DATA) C REAL DATA(500,10) INTEGER P,M,N,SEL CHARACTER*8 FILENAME C 100 WRITE(*,7001) 7001 FORMAT(8(/),1X,'CHOOSE OPTION:', +//,5X,'(1) SAVE INPUT DATA, THEN EXIT PROGRAM', +/,5X,'(2) EXIT PROGRAM', +///,1X,'ENTER NUMBER OF SELECTION: ',/) C READ(*,*) SEL IF (SEL.GE.1.AND.SEL.LE.2) GOTO 110 C WRITE(*,105) 105 FORMAT(//,1X,'INVALID SELECTION. PLEASE TRY AGAIN') GOTO 100 C 110 GOTO (130,140),SEL C 130 WRITE(*,80) 80 FORMAT(//,' PLEASE ENTER DATA FILE NAME (UP TO 8 CHARS): ',/) READ(*,81) FILENAME 81 FORMAT(A8) IF (FILENAME.EQ.' ') GO TO 130 OPEN (1,FILE=FILENAME,STATUS='NEW') WRITE(1,92) P WRITE(1,92) M WRITE(1,92) N 92 FORMAT(I3) MN=M*N WRITE(1,*) ((DATA(I,J),J=1,P),I=1,MN) CLOSE(1) C 140 RETURN END C C C---------------------------------------------------- C SUBROUTINE PAUSE C CHARACTER*1 GO C C Pause to let user view the display C WRITE(*,70) 70 FORMAT(/,1X,'STRIKE CARRIAGE RETURN WHEN YOU ', +'WISH TO CONTINUE',/) READ(*,75) GO 75 FORMAT(A1) C RETURN END C C----------------------------------------------------