Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-09 - 43,50466/reco.for
There are 2 other files named reco.for in the archive. Click here to see a list.
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