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