C WESTERN MICHIGAN UNIVERSITY C RECO.FOR (FILENAME ON LIBRARY DECTAPE) C RECO, 1.2.3 (CALLING NAME, SUBLST. NO.) C MATRICES OF REGRESSIONS AND PARTIAL CORRELATIONS C MRS. EVA GAINES, DAVID BARRY, AND SAM ANEMA WERE THE PROGRAMMERS C OF THIS PACKAGE. PART OF THIS IS PATTERNED AFTER A PROGRAM C GIVEN BY WAYNE STATE UNIVERSITY; PART IS TAKEN FROM FORTRAN C SCIENTIFIC SUBROUTINE PACKAGE; AND SUBSTANTIAL PARTS C RESPRESENT ADDITIONAL PROGRAMMING. C LATER MODIFIED BY R.R. BARR C LIBRARY DECTAPE PROGRAMS USED: USAGE.MAC C FORWMU PROGS. USED: TTYPTY, EXISTS, DEVCHG, DEVICE, PRINTS, C MINVSQ C APLB10 PROGS. USED: IOB, GETFOR C INTERNAL SUBR. USED: CHECK, RCHECK, MORC C ABOVE COMMENTS AND RIGHT ADJUSTED COMMENTS PUT IN BY WG COMMON /IOBLK/NOUTD,IND,INP,IOUT,NDV2,NDV1,ICODE,IBNK,NAMI(2) DIMENSION NNC(50),NNX(50),SSS(10,10),SMXY(10,10) DIMENSION JEFF(64),X(50),SUMX(50),SUMXY(50,50),A(50,50),NVAR2(50) DIMENSION ID(16),S(50,50),C(50),D(50,50),NVAR(50),INV(5),F(50,50) EQUIVALENCE (X,NVAR2,NNX),(C,NNC),(F,SUMXY),(SSS,S(1,11)),(SMXY,SU 1MXY(1,11)) DOUBLE PRECISION NAME,IFLNM,IOFLNM DATA NAME /'RIN.DAT'/ IND=-4 NOUTD=-1 INP=2 IOUT=3 JUMP=' ' C---------------TTYPTY RETURNS ZERO - TTY JOB, MINUS ONE BATCH JOB CALL TTYPTY (ICODE) OPEN(UNIT=24,FILE='PCOR',MODE='ASCII',ACCESS='SEQOUT') WRITE(NOUTD,11) 11 FORMAT (18X,'WESTERN MICHIGAN UNIVERSITY'/24X,'COMPUTER 1 CENTER'/25X,'REGRESSION AND'/16X'PARTIAL 2 CORRELATION COEFFICIENTS'///) C CALL USAGE('RECO') NTIMES=0 C---------------1 MEANS OUTPUT? PRINTS, 0 - INPUT? PRINTS. C--------------- IDLG, INT, INP, IRP, IDEV, ICODE ARE INPUT THRU C--------------- COMMON /IOBLK/. IBNK, NAMI ARE RETURNED. CALL IOB(1) 3 CALL IOB(0) C---------------JEFF, ISTD ARE RETURNED. OTHER ARGS. ARE INPUT C--------------- 64=NO. OF OBJ. TIME FORMAT WORDS (4 LINES). C--------------- 2 MEANS F-TYPE FORMAT ONLY CALL GETFOR(NOUTD,IND,JEFF,ISTD,64,2) IF(ISTD.EQ.1)JEFF(1)='(10F)' NTIMES=NTIMES+1 JUMP=' ' 25 WRITE (NOUTD,4) 4 FORMAT (' TYPE 1, IF YOU WISH TO ENTER RAW DATA'/ 1' TYPE 2, IF YOU WISH TO ENTER THE CORRELATION MATRIX.'/) READ (IND,5) INPUT 5 FORMAT(I) CALL CHECK (INPUT,1,2) WRITE (NOUTD,32) 32 FORMAT (' HOW MANY VARIABLES ARE THERE?'/) READ (IND,5) N CALL CHECK (N,2,50) C READ THE RAW DATA FROM TTY OR DSK AND COMPUTE THE C CORRELATION MATRIX. KEEP TRACK OF THE NUMBER OF CARDS AND IF ON C BATCH TELL WHICH CARD. 81 DO 73 I=1,50 SUMX(I)=0 DO 73 J=1,50 73 SUMXY(I,J)=0 NCARD=0 IF(INPUT.EQ.2) GO TO 34 IF(NDV2.NE.'TTY')GO TO 31 IF(ISTD.EQ.1)WRITE(NOUTD,21) 21 FORMAT(' ENTER THE RAW DATA (AT MOST 10 PER LINE)'/) IF(ISTD.NE.1)WRITE(NOUTD,35) GO TO 46 31 WRITE(NOUTD,49) 35 FORMAT (' ENTER THE RAW DATA.'/) 49 FORMAT (' THE RAW DATA IS BEING READ.'/) 46 NCARD =NCARD+1 42 READ (INP,JEFF,END=36,ERR=37)(X(I),I=1,N) GO TO 43 37 WRITE (NOUTD,39) 39 FORMAT (' ERROR WHILE INPUTTING DATA.'/) IF (NDV2.NE.'TTY') WRITE (NOUTD,40) NCARD IF(ICODE.EQ.-1)CALL EXIT WRITE (NOUTD,41) 41 FORMAT (' RETYPE THE LAST LINE.'/) GO TO 42 40 FORMAT (' THE ERROR IS ON RECORD'1X,I4) IF(ICODE.EQ.-1) CALL EXIT GO TO 3 C COMPUTE THE SUMS OF THE VARIABLES AND THE SUMS OF THE C CROSS PRODUCTS. 43 DO 44 I=1,N DO 45 J=1,N 45 SUMXY(I,J)=SUMXY(I,J)+X(I)*X(J) 44 SUMX(I)=SUMX(I)+X(I) GO TO 46 C COMPUTE THE CORRELATION COEFFICIENTS 36 NCARD=NCARD-1 T=NCARD DO 47 I=1,N DO 47 J=1,N E=(T*SUMXY(I,I)-SUMX(I)**2)*(T*SUMXY(J,J)-SUMX(J)**2) IF (E) 88,88,108 88 WRITE (NOUTD,89) 89 FORMAT (' THE CORRELATION MATRIX CANNOT BE COMPUTED FROM 1 THE DATA GIVEN.') IF(ICODE.EQ.-1)CALL EXIT GO TO 3 108 S(I,J)=SUMXY(I,J)-(SUMX(I)*SUMX(J))/T 47 A(I,J)=(T*SUMXY(I,J)-SUMX(I)*SUMX(J))/SQRT(E) IF(N.LE.10)GO TO 1010 REWIND 21 WRITE(21)S,SUMXY GO TO 448 1010 DO 1011 I=1,10 DO 1011 J=1,10 SSS(I,J)=S(I,J) 1011 SMXY(I,J)=SUMXY(I,J) REWIND 21 WRITE(21)SSS,SMXY GO TO 448 C READ IN CORRELATION COEFFICIENTS FROM DISK OR TTY. 34 IF(NDV2.NE.'TTY')GO TO 26 IF(ISTD.EQ.1)WRITE(NOUTD,77) 77 FORMAT(' ENTER THE CORRELATION MATRIX (AT MOST 10 ENTRIES PER LINE 1)'/) IF(ISTD.EQ.1)WRITE(NOUTD,50) GO TO 78 26 WRITE(NOUTD,51) 50 FORMAT (' ENTER THE CORRELATION MATRIX.'/) 51 FORMAT (' THE CORRELATION MATRIX IS BEING READ IN.'/) 78 DO 54 I=1,N NCARD=NCARD+1 52 READ (INP,JEFF,END=56,ERR=53)(A(I,J),J=1,N) GO TO 54 53 WRITE (NOUTD,39) IF (NDV2.NE.'TTY') WRITE (NOUTD,40) NCARD IF(ICODE.EQ.-1)CALL EXIT WRITE (NOUTD,41) GO TO 52 56 WRITE (NOUTD,55) NCARD 55 FORMAT (' END OF FILE READING CARD'1X,I4) IF(ICODE.EQ.-1)CALL EXIT GO TO 3 54 CONTINUE DO 2289 I=1,N IF(A(I,I).NE.1.0)GO TO 2290 DO 2291 J=1,I IF(ABS(A(I,J)).GT.1.0)GO TO 2297 2291 IF(A(I,J).NE.A(J,I))GO TO 2292 2289 CONTINUE GO TO 448 2290 WRITE(NOUTD,2295) 2295 FORMAT(' A CORRELATION MATRIX REQUIRES A VALUE OF 1 ON THE DIAGONA 1L') CALL DEVICE(5) GO TO 34 2292 WRITE(NOUTD,2296) 2296 FORMAT(' MATRIX IS NOT SYMETRIC.') CALL DEVICE(5) GO TO 34 2297 WRITE(NOUTD,2298) 2298 FORMAT(' ALL CORRELATIONS MUST BE LESS THAN OR = 1') IF(ICODE.EQ.-1)CALL EXIT GO TO 34 448 WRITE(NOUTD,2188) 2188 FORMAT(' ENTER ONE OF THE FOLLOWING CODES:'//4X, 1'ID - TO ENTER IDENTIFICATION'/ 14X,'DEL - TO DELETE A VARIABLE'/ 14X,'INC - TO INCLUDE A VARIABLE'/ 14X,'ALL - TO INCLUDE ALL VARIABLES'/ 14X,'BEGIN - RESTART PROGRAM'/ 14X,'COR - FOR CORRELATIONS'/ 14X,'SREG - FOR SIMPLE REGRESSION ANALYSIS'/ 14X,'MREG - FOR MULTIPLE REGRESSION AND MULTIPLE CORRELATION'/12X, 1'COEFFICIENTS'/ 14X,'PCOR - FOR PARTIAL CORRELATION COEFFICIENTS'/ 14X,'PART - FOR PARTIAL CORRELATIONS[USER SPECIFIES FIXED VARIABLE 1S]'/) 2187 DO 449 I=1,N NVAR(I)=I DO 449 J=1,N 449 D(I,J)=A(I,J) M=N IALL=0 48 WRITE (NOUTD,59) 59 FORMAT (/' *',$) READ (IND,67) CHOYS 67 FORMAT (A5) 57 FORMAT (1X,A5) IF(CHOYS.EQ.'PART')GO TO 1234 IF (CHOYS.EQ.'ID') GO TO 83 IF (CHOYS.EQ.'COR') GO TO 63 IF (CHOYS.EQ.'SREG') GO TO 93 IF (CHOYS.EQ.'DEL') GO TO 303 IF (CHOYS.EQ.'INC') GO TO 313 IF (CHOYS.EQ.'ALL') GO TO 2187 IF (CHOYS.EQ.'MREG'.OR.CHOYS.EQ.'PCOR') GO TO 133 IF (CHOYS.EQ.'BEGIN') GO TO 3 NCHOY=NCHOY+1 IF (NCHOY.GT.1) GO TO 58 WRITE (NOUTD,60) 60 FORMAT(' TYPE ID,DEL,INC,ALL,BEGIN,COR,SREG,MREG,PCOR, 1 OR PART.') IF(ICODE.EQ.-1)CALL EXIT GO TO 48 58 WRITE (NOUTD,61) 61 FORMAT (' HUH?') GO TO 48 1234 DO 1235 I=1,N NVAR2(I)=I DO 1235 J=1,I 1235 S(I,J)=A(I,J) 2005 WRITE(NOUTD,1236) 1236 FORMAT(' ENTER VARIABLES TO BE HELD FIXED'/) READ(5,1237)(INV(I),I=1,5) 1237 FORMAT(5I) DO 1238 I=2,5 IF(INV(I).EQ.0)GO TO 1239 1238 CONTINUE KLM=5 GO TO 1240 1239 KLM=I-1 1240 IF(KLM.GT.N-2)GO TO 2000 GO TO 2001 2000 WRITE(NOUTD,2002) 2002 FORMAT(' TOO MANY ARE FIXED'/) CALL DEVICE(5) GO TO 2005 2001 IF(NDV1.NE.'TTY')GO TO 1300 WRITE(NOUTD,1301) 1301 FORMAT(16X,'PARTIAL CORRELATIONS'/) GO TO 1302 1300 WRITE(IOUT,1303) 1303 FORMAT('1',55X,'PARTIAL CORRELATIONS'/) 1302 WRITE(IOUT,1305)(INV(I),I=1,KLM) 1305 FORMAT(' FIXED VARIABLES ARE:',5I3) DO 3003 I=1,KLM DO 3001 J=1,N IF(INV(I).EQ.NVAR2(J))GO TO 3002 GO TO 3001 3002 INV(I)=J GO TO 3003 3001 CONTINUE 3003 CONTINUE DO 3016 I=2,5 DO 3016 J=1,I IF(INV(I).LE.INV(J))GO TO 3016 ISA=INV(I) INV(I)=INV(J) INV(J)=ISA 3016 CONTINUE MM=N DO 1257 K=1,KLM KL=INV(K) DO 1255 I=1,MM DO 1255 J=1,MM IF(I.GE.J)GO TO 1256 F(I,J)=S(J,I) GO TO 1255 1256 F(I,J)=S(I,J) 1255 CONTINUE II=0 MM=MM-1 DO 1257 I=1,MM II=II+1 IF(II.EQ.KL)II=II+1 NVAR2(I)=NVAR2(II) JJ=0 DO 1257 J=1,I JJ=JJ+1 IF(JJ.EQ.KL)JJ=JJ+1 S(I,J)=(F(II,JJ)-F(II,KL)*F(JJ,KL))/SQRT((1.0-F(II,KL)**2)*(1.0-F( 1JJ,KL)**2)) 1257 CONTINUE DO 1258 I=1,MM DO 1258 J=1,MM IF(I.GE.J)GO TO 1259 F(I,J)=S(J,I) GO TO 1258 1259 F(I,J)=S(I,J) 1258 CONTINUE DO 1310 I=1,MM 1310 WRITE(24,1309)(F(I,J),J=1,MM) WRITE(IOUT,87) K=1 KK=7 1308 IF(NDV1.NE.'TTY')KK=KK+6 IF(KK.GT.MM)KK=MM WRITE(IOUT,180)(NVAR2(I),I=K,KK) DO 1307 I=K,MM L=I IF(I.GT.KK)L=KK 1307 WRITE(IOUT,72)NVAR2(I),(S(I,J),J=K,L) IF(KK.GE.MM)GO TO 48 WRITE(IOUT,196) K=KK+1 KK=KK+7 GO TO 1308 C READ IN THE OUTPUT IDENTIFICATION 83 WRITE (NOUTD,600) 600 FORMAT (' TYPE IN ONE LINE OF IDENTIFICATION.'/) OUTID=1. READ (IND,601)(ID(I),I=1,16) 601 FORMAT (16A5) IF (ICODE.EQ.-1) WRITE (NOUTD,602)(ID(I),I=1,N) 602 FORMAT (1X,16A5) GO TO 48 C WRITE OUT THE CORRELATION MATRIX 63 DO 190 I=1,N 190 NVAR(I)=I IF (NDV1.NE.'TTY') GO TO 64 WRITE (NOUTD,66) 66 FORMAT (21X,'CORRELATION MATRIX'/) GO TO 65 64 WRITE (IOUT,70) JUMP 70 FORMAT (A1,55X,'CORRELATION MATRIX'/) JUMP='1' 65 IF (OUTID.EQ.1.) WRITE (IOUT,86)(ID(I),I=1,16) 86 FORMAT (1X,16A5) OUTID=0.0 WRITE (IOUT,87) 87 FORMAT (/) K=1 KK=7 194 IF (NDV1.NE.'TTY') KK=KK+6 IF (KK.GT.N) KK=N WRITE (IOUT,180)(NVAR(I),I=K,KK) DO 71 I=K,N L=I IF (I.GT.KK) L=KK 71 WRITE (IOUT,72)NVAR(I),(A(I,J),J=K,L) 72 FORMAT (/1X,I2,1X,13F9.5) IF (KK.GE.N) GO TO 48 WRITE (IOUT,196) 196 FORMAT (//) K=KK+1 KK=KK+7 GO TO 194 C COMPUTE AND WRITE SIMPLE REGRESSION ANALYSIS. 93 IF (INPUT.EQ.1) GO TO 94 WRITE (NOUTD,103) 103 FORMAT (' SIMPLE REGRESSION ANALYSIS CAN ONLY BE COMPUTED 1 FROM RAW DATA.') IF(ICODE.EQ.-1)CALL EXIT GO TO 48 94 IF (NDV1.NE.'TTY') GO TO 97 WRITE (NOUTD,95) 95 FORMAT (17X,'SIMPLE REGRESSION ANALYSIS'/) GO TO 98 97 WRITE (IOUT,99) JUMP 99 FORMAT (A1,51X,'SIMPLE REGRESSION ANALYSIS'/) JUMP='1' 98 IF (OUTID.EQ.1.) WRITE (IOUT,86)(ID(I),I=1,16) OUTID=0.0 WRITE (IOUT,96) NCARD 96 FORMAT (/' NUMBER OF OBSERVATIONS = 'I4/) IF (NDV1.NE.'TTY') GO TO 100 WRITE (NOUTD,101) 101 FORMAT (' INDEPENDENT'4X,'DEPENDENT'5X,'REGRESSION'6X, 1'INTERCEPT'4X,'STD. ERR.'/' VARIABLE'6X,'VARIABLE'6X, 2'COEFFICIENT'/) GO TO 105 100 WRITE (IOUT,104) 104 FORMAT (8X,'INDEPENDENT'14X,'DEPENDENT'14X,'REGRESSION'14X, 1'INTERCEPT'14X,'STANDARD ERROR'/9X,'VARIABLE'16X,'VARIABLE' 215X'COEFFICIENT'/) 105 REWIND 21 IF(N.LE.10)GO TO 2715 READ(21)S,SUMXY GO TO 2117 2715 READ(21)SSS,SMXY DO 2116 I=1,10 DO 2116 J=1,10 S(I,J)=SSS(I,J) 2116 SUMXY(I,J)=SMXY(I,J) 2117 DO 1102 I=1,M II=NVAR(I) DO 106 J=1,M JJ=NVAR(J) IF (II-JJ) 116,106,107 116 G=S(II,JJ) H=A(II,JJ)**2 GO TO 109 107 G=S(JJ,II) H=A(JJ,II)**2 109 B=G/S(II,II) AN=SUMX(JJ)/T-B*SUMX(II)/T SB=(S(JJ,JJ)-H*S(JJ,JJ))/((T-2.)*S(II,II)) IF (NDV1.NE.'TTY') GO TO 110 WRITE (NOUTD,111) II,JJ,B,AN,SB 111 FORMAT (5X,I2,12X,I2,8X,F9.4,7X,F9.4,3X,F9.4) GO TO 106 110 WRITE (IOUT,112) II,JJ,B,AN,SB 112 FORMAT (12X,I2,22X,I2,17X,F9.4,15X,F9.4,16X,F9.4) 106 CONTINUE 1102 CONTINUE GO TO 48 C WHEN USER WISHES TO DELETE VARIABLES 303 WRITE (NOUTD,507) 507 FORMAT (' HOW MANY VARIABLES ARE YOU GOING TO DELETE?'/) READ (IND,5) M CALL CHECK (M,1,50) IF (N-M-1) 510,510,511 510 WRITE (NOUTD,512) 512 FORMAT (' TOO MANY VARIABLES DELETED.') IF(ICODE.EQ.-1)CALL EXIT GO TO 303 511 WRITE (NOUTD,513) 513 FORMAT (' TYPE IN NUMBERS TO INDICATE WHICH VARIABLES 1 ARE TO BE DELETED'/' (MAX 20 PER LINE)'/) CALL RCHECK (NVAR,N,M) C CHANGE FROM VARIABLES TO DELETE TO VARIABLES TO INCLUDE II=0 DO 514 I=1,N DO 515 J=1,M 515 IF (NVAR(J).EQ.I) GO TO 514 II=II+1 X(II)=I 514 CONTINUE M=N-M DO 516 I=1,M 516 NVAR(I)=X(I) C MOVE IN ROWS AND COLUMNS CALL MORC (A,D,NVAR,N,M) IALL=0 GO TO 48 C WHEN USER WISHES TO INCLUDE VARIABLES 313 WRITE (NOUTD,517) 517 FORMAT (' HOW MANY VARIABLES ARE TO BE INCLUDED?'/) READ (IND,5) M CALL CHECK (M,1,50) IF (M.LE.N) GO TO 520 WRITE (NOUTD,519) 519 FORMAT (' THAT IS MORE VARIABLES THAN WERE READ IN.') IF(ICODE.EQ.-1)CALL EXIT GO TO 313 520 IF (M.GE.2) GO TO 521 WRITE (NOUTD,522) 522 FORMAT (' NOT ENOUGH VARIABLES INCLUDED.') IF(ICODE.EQ.-1)CALL EXIT GO TO 313 521 WRITE (NOUTD,523) 523 FORMAT (' TYPE IN NUMBERS TO INDICATE WHICH VARIABLES ARE TO BE 1 INCLUDED'/' (MAX 20 PER LINE)'/) CALL RCHECK (NVAR,N,M) CALL MORC (A,D,NVAR,N,M) IALL=0 GO TO 48 C COMPUTE PARTIAL REGRESSIONS 133 IF (M.GT.2) GO TO 144 WRITE (NOUTD,145) 145 FORMAT (' INCLUDE AT LEAST 3 VARIABLES FOR THIS ANALYSIS.') GO TO 48 144 IF (IALL.GT.0) GO TO 4144 C---------------(D)--MATRIX TO BE INVERTED, (M) - ORDER OF D, C--------------- (1.0) - TOLERANCE FOR INVERSE (IF LARGEST AVAILABLE C--------------- PIVOT (IN ABS.) IS LESS THAN .000001*TOL, INVERSE C--------------- IS CONSIDERED NON-EXISTANT. (NNC) - BOOKKEEPING C--------------- VECTOR AT LEAST M LONG, (NNX) - BOOKKEEPING VECTOR C--------------- AT LEAST M LONG, (50) - DIM. OF D IN MAINLINE, I.E., C--------------- D(50,50), (-1) IS FORTRAN UNIT NO FOR ERROR MESSAGES. C--------------- IF 0 IS INPUT ERROR MESSAGES ARE SUPPRESSED. THE C--------------- EIGHTH ARG. HAS 3 POSSIBILITIES: (0) - LEAST C--------------- ACCURATE (FASTEST) USES FIRST NON-ZERO ELEMENT IN ROW, C--------------- (1) - COMPROMISE, USES LARGEST REMAINING IN ROW, (2) - C--------------- MOST ACCURATE (SLOWEST) USES LARGEST REMAINING IN C--------------- MATRIX. (DET) - DETERMINANT OF D (CHARACTERISTIC C--------------- ONLY), (IEXP) - POWER OF TEN OF DETERMINANT. CALL MINVSQ (D,M,1.0,NNC,NNX,50,-1,0,DET,IEXP) 4144 IALL=IALL+1 IF (CHOYS.EQ.'PCOR') GO TO 203 148 IF (NDV1.NE.'TTY') GO TO 134 WRITE (NOUTD,135) 135 FORMAT (19X,'MULTIPLE REGRESSION COEFFICIENTS'/) GO TO 136 134 WRITE (IOUT,137) JUMP 137 FORMAT (A1,48X,'MULTIPLE REGRESSION COEFFICIENTS'/) JUMP='1' 136 IF (OUTID.EQ.1.) WRITE (IOUT,86)(ID(I),I=1,16) OUTID=0.0 WRITE (IOUT,87) K=1 KK=6 181 IF (ICODE.EQ.-1) KK=KK+6 IF (KK.GT.M) KK=M WRITE (IOUT,1180)(NVAR(I),I=K,KK) 180 FORMAT(' VAR ',I4,12I9) 1180 FORMAT(' DEP. COEFF. OF',10X,'INDEPENDENT VARIABLE'/ 1' VAR MULT. REG.',I3,11I9) DO 139 I=1,M DO 140 J=K,KK X(J)=-D(I,J)/D(I,I) 140 IF(I.EQ.J)X(J)=1.0E20 YX=SQRT(1.0-1.0/D(I,I)) 138 WRITE (IOUT,132)NVAR(I),YX,(X(J),J=K,KK) 132 FORMAT (/1X,I2,F9.5,3X,F7.3,11(2X,F7.3)/) 139 CONTINUE IF (KK.EQ.M) GO TO 48 WRITE (IOUT,196) K=KK+1 KK=KK+7 GO TO 181 C COMPUTE THE CORRELATIONS 203 MM=M-2 IF (NDV1.NE.'TTY') GO TO 211 WRITE (NOUTD,212) MM 212 FORMAT (12X,'PARTIAL CORRELATION COEFFICIENTS OF ORDER 'I2/) GO TO 213 211 WRITE (IOUT,214) JUMP,MM 214 FORMAT (A1,43X,'PARTIAL CORRELATION COEFFICIENTS OF ORDER 'I2/) JUMP='1' 213 IF (OUTID.EQ.1) WRITE (IOUT,86)(ID(I),I=1,16) OUTID=0.0 WRITE (IOUT,87) K=1 KK=7 215 IF (NDV1.NE.'TTY') KK=KK+6 IF (KK.GT.M) KK=M WRITE (IOUT,180)(NVAR(I),I=K,KK) DO 216 I=K,M L=I IF (I.GT.KK) L=KK DO 217 J=K,L X(J)=-D(I,J)/SQRT(D(I,I)*D(J,J)) IF(I.EQ.J)X(J)=1.0 F(I,J)=X(J) F(J,I)=X(J) 217 CONTINUE 216 WRITE (IOUT,72)NVAR(I),(X(J),J=K,L) IF (KK.GE.M) GO TO 1312 WRITE (IOUT,196) K=KK+1 KK=KK+7 GO TO 215 1312 DO 1311 I=1,M 1311 WRITE(24,1309)(F(I,J),J=1,M) 1309 FORMAT(10F8.5) GO TO 48 62 CALL EXIT END C C C---------------ALL ARGS. ARE INPUT. SUBROUTINE CHECK (IC,MIN,MAX) COMMON /IOBLK/NOUTD,IND,INP,IOUT,NDV2,NDV1,ICODE,IBNK,NAMI(2) 905 IF (IC.GE.MIN.AND.IC.LE.MAX) GO TO 900 IF(ICODE.EQ.-1)CALL EXIT WRITE (NOUTD,903) 903 FORMAT (' INVALID ENTRY, TRY AGAIN.'/) READ (IND,904) IC 904 FORMAT (I) GO TO 905 900 RETURN END C C C---------------N, M ARE INPUT. NVAR IS RETURNED SUBROUTINE RCHECK(NVAR,N,M) C---------------IND, NOUTD, ICODE ARE INPUT THRU COMMON /IOBLK/ COMMON /IOBLK/NOUTD,IND,INP,IOUT,NDV2,NDV1,ICODE,IBNK,NAMI(2) DIMENSION NVAR(1) 811 READ (IND,801)(NVAR(I),I=1,M) 801 FORMAT (20I) 804 FORMAT (1X,20I3) DO 802 I=1,M IF (NVAR(I)) 803,803,805 805 IF (NVAR(I).LE.N) GO TO 802 803 WRITE (NOUTD,806) 806 FORMAT (' VARIABLE NUMBER OUTSIDE ALLOWABLE RANGE.') IF(ICODE.EQ.-1)CALL EXIT WRITE (NOUTD,810) M 810 FORMAT (' RETYPE THE 'I3,' VARIABLE NUMBERS.'/) GO TO 811 802 CONTINUE IF (M.EQ.1) RETURN C CHECK FOR DUPLICATE VARIABLE DO 807 I=1,M-1 DO 807 J=I+1,M IF (NVAR(I).NE.NVAR(J)) GO TO 807 WRITE (NOUTD,808) 808 FORMAT (' VARIABLE NUMBER WAS DUPLICATED.') IF(ICODE.EQ.-1)CALL EXIT WRITE (NOUTD,810) M GO TO 811 807 CONTINUE C PUT IN ASCENDING ORDER DO 809 I=1,M-1 DO 809 J=1,M-1 IF (NVAR(J).LE.NVAR(J+1)) GO TO 809 ITEMP=NVAR(J) NVAR(J)=NVAR(J+1) NVAR(J+1)=ITEMP 809 CONTINUE RETURN END C C C---------------D IS RETURNED. N IS NOT USED. OTHER ARGS. ARE INPUT. SUBROUTINE MORC(A,D,NVAR,N,M) DIMENSION NVAR(1),D(50,50),A(50,50) DO 701 I=1,M DO 702 J=1,M 702 D(I,J)=A(NVAR(I),NVAR(J)) 701 CONTINUE RETURN END