COMMON/GETNXT/NEXT COMMON/GETNCW/NCHW COMMON/MEMORY/LENGTH,LEXICN,IBLOCK(8000) COMMON/CONTR/NV,NG,NI,NT,IFMT(180),NC C DOUBLE PRECISION PROBLM,TITLE,THIS,FORMAT,TAPE,PNAME,LABELS,VARIAB 1,GROUPS,INPUT,INDEX DATA PROBLM,TITLE,INPUT,FORMAT,TAPE,INDEX,VARIAB,GROUPS,LABELS/ 16HPROBL.,6HTITLE.,6HINPUT.,6HFORMA.,6HTAPE. ,6HINDEX.,6HVARIA., 26HGROUP.,6HLABEL./ DATA COVI,XBARI,COV,XBAR,GUSE,VUSE,IUSE,GRN,X,SMALL,BIG,TEMP,VRBL, 1GRPS / 2 4HCOVI,4HXBRI ,3HCOV,4HXBAR,4HGUSE,4HVUSE,4HIUSE,3HGRN,1HX, 3 4HSMAL ,3HBIG,4HTEMP,4HVRBL,4HGRPS / DATA IFM1,IFM2,IBLANK/'(12F','6.0)',' '/ C 1000 FORMAT(//1H ,30A5) 1001 FORMAT(/// 1 20H NUMBER OF VARIABLES, I6 / 20H NUMBER OF GROUPS , I6 / 2 20H GROUP INDICATOR VAR, I6 / 20H INPUT TAPE'S NUMBER, I6 ) 1012 FORMAT(7H FORMAT,30A5,/(' ',6X,30A5)) 1971 FORMAT(// 80H SUBSCRIPT OF GROUP INDICATES VARIABLE IS GREATER TH 1AN NUMBER OF VARIABLES. ) 2000 FORMAT('1BMDX82 - ANALYSIS OF COVARIANCE - REVISED ', X'MAY 10, 1968'/ 1 50H HEALTH SCIENCES COMPUTING FACILITY, U.C.L.A. ) C NEXT=0 CALL USAGEB('BMDX82') 1 CALL SETUP IFMT(1)=IFM1 IFMT(2)=IFM2 DO 2 I2=3,180 2 IFMT(I2) = IBLANK NT=5 NI=0 CALL GETME(PROBLM,TITLE,120,1,MANY,IBLOCK,IERROR) IF(IERROR.EQ.1) GO TO 999 WRITE(6,2000) IF(MANY.GT.0) WRITE(6,1000)(IBLOCK(I),I=1,30) CALL GETME(INPUT,FORMAT,720,1,MANY,IFMT,IERROR) CALL GETME(INPUT,TAPE ,1,1,MANY,NT,IERROR) CALL GETME(INPUT,INDEX ,1,1,MANY,NI,IERROR) CALL GETME(INPUT,VARIAB,1,1,MANY,NV,IERROR) CALL GETME(INPUT,GROUPS,1,1,MANY,NG,IERROR) WRITE(6,1001)NV,NG,NI,NT WRITE(6,1012)(IFMT(I),I=1,180) CALL RECORD(VRBL,LVNAME,NV) II=LVNAME DO 10 I=1,NV IBLOCK(II)=IBLANK IF(I.LE.9) *CALL PUTCHR(IBLOCK(II),NCHW,(MOD(I,100)+240)*2**24) IF(I.GT.9) 1CALL PUTCHR(IBLOCK(II),NCHW,((MOD(I,100)-(MOD(I,100)/10)*10)+240)* 22**24) IF(I.GT. 9) CALL PUTCHR(IBLOCK(II),NCHW-1,(MOD(I,100)/10+240)*2** 1 24) IF(I.GT.99) CALL PUTCHR(IBLOCK(II),NCHW-2,(I/100+240)*2**24) 10 II=II+1 CALL GETME(LABELS,VARIAB,NCHW,NV,MANY,IBLOCK(LVNAME),IERROR) CALL RECORD(GRPS,LGNAME,NG) II=LGNAME DO 20 I=1,NG IBLOCK(II)=IBLANK CALL PUTCHR(IBLOCK(II),NCHW,(MOD(I,100)+240)*2**24) IF(I.GT. 9) CALL PUTCHR(IBLOCK(II),NCHW-1,(MOD(I,100)/10+240)*2** 1 24) IF(I.GT.99) CALL PUTCHR(IBLOCK(II),NCHW-2,(I/100+240)*2**24) 20 II=II+1 CALL GETME(LABELS,GROUPS,NCHW,NG,MANY,IBLOCK(LGNAME),IERROR) IF(NI.GT.NV) GO TO 971 CALL RESERV(COVI,LCOVI,NG*NV*(NV+1)/2) CALL RESERV(XBARI,LXBARI,NV*NG) CALL RESERV(COV,LCOV,NV*(NV+1)/2) CALL RESERV(XBAR,LXBAR,NV) CALL RESERV(GUSE,LGUSE,NG) CALL RESERV(VUSE,LVUSE,NV) CALL RESERV(IUSE,LIUSE,NV) CALL RESERV(GRN,LGRN,NG) NGG=MAX0(NV,NG) CALL RESERV(X,LX,NGG) NGG=MAX0(NG,3) CALL RESERV(SMALL,LSMALL,NV*NGG) NGG=MAX0(NG*(NG+1)/2,NG*NV) CALL RESERV(BIG,LBIG,NGG) NGG=MAX0(NV*(NV+1)/2,NG*(NG+1)/2) CALL RESERV(TEMP,LTEMP,NGG) NC=(LENGTH-LEXICN)/NG CALLCOVANA(IBLOCK(LCOVI),IBLOCK(LXBARI),IBLOCK(LCOV),IBLOCK(LXBAR) 1 ,IBLOCK(LGUSE),IBLOCK(LVUSE),IBLOCK(LIUSE),IBLOCK(LGRN), 2IBLOCK(LX),IBLOCK(LX),IBLOCK(LSMALL),IBLOCK(LBIG),IBLOCK(LVNAME) 3 ,IBLOCK(LGNAME),IBLOCK(LTEMP),IBLOCK(LEXICN),NV,NG) GO TO 1 971 WRITE(6,1971) 999 STOP END SUBROUTINE GETSEQ(COEF,NCC,USEG,USEV,USEI,MORE) COMMON/GETNXT/NEXT COMMON/CONTR/NV,NG,NI,NT,FMT(180),NC DIMENSION USEG(1),USEV(1),USEI(1),USE(99),COEF(1) DOUBLE PRECISION SUBPRO,TITLE,INDEPE,DEPEND,CONTRA,GROUPS DATA SUBPRO,DEPEND,INDEPE,GROUPS,CONTRA,TITLE/ 1 6HSUBPR.,6HDEPEN.,6HINDEP.,6HGROUP.,6HCONTR. ,6HTITLE. / C 1000 FORMAT(1H ,30A5) 1001 FORMAT(1H1) C WRITE(6,1001) NEXT=0 MORE=1 NCC=0 DO 1 I=1,NV IF(USEI(I).NE.0.0) USEV(I)=0.0 1 CONTINUE CALL GETME(SUBPRO,TITLE,120,1,MANY,USE,IERROR) IF(IERROR.NE.0) GO TO 77 IF(MANY.GT.0)WRITE(6,1000)(USE(I),I=1,30) CALL GETME(SUBPRO,INDEPE,2,NV,MANY,USE,IERROR) IF(MANY.LE.0) GO TO 19 DO 10 I=1,NV 10 USEI(I)=0.0 DO 15 I=1,MANY II=USE(I)+.00001 15 USEI(II)=1.0 19 CALL GETME(SUBPRO,DEPEND,2,NV,MANY,USE,IERROR) IF(MANY.LE.0) GO TO 29 DO 20 I=1,NV 20 USEV(I)=0.0 DO 25 I=1,MANY II=USE(I)+.00001 25 USEV(II)=1.0 29 CALL GETME(SUBPRO,GROUPS,2,NG,NGG ,USE,IERROR) IF(NGG.GT.NG) NGG=NG IF(NGG .LE.0) GO TO 49 DO 30 I=1,NG 30 USEG(I)=0.0 DO 35 I=1,NGG II=USE(I)+.00001 35 USEG(II)=1.0 CALL GETME(SUBPRO,CONTRA,2,NC*NG,MANY,COEF,IERROR) NCC=MANY/NGG IF(NCC .LE.0) GO TO 49 IF(NGG.EQ.NG) GO TO 49 MANY1=NCC*NGG+1 LAST=NCC*NG DO 38 I=MANY1,LAST 38 COEF(I)=0.0 DO 40 J=1,NCC JJ=NCC+1-J DO 40 I=1,NGG MANY1=MANY1-1 II=NGG+1-I II=USE(II)+.00001 LOC=(JJ-1)*NG+II COEF(LOC)=COEF(MANY1) IF(LOC.NE.MANY1) COEF(MANY1)=0.0 40 CONTINUE 49 DO 50 I=1,NV IF(USEI(I).EQ.1.0) USEV(I)=1.0 50 CONTINUE RETURN 77 IF(IERROR.EQ.1) MORE=0 RETURN END SUBROUTINE COVANA(COVI,XBARI,COV,XBAR,GUSE,VUSE,IUSE,GRN,X,IX, 1 SMALL,BIG,VNAME,GNAME,TEMP,WORK,N,NG) DOUBLE PRECISION GROUP,TOTAL,WITHIN,BETWEN,MEANS,STDS DIMENSION WORK(NG,1 ),TEMP(1),IX(1) DIMENSION COVI(1),XBARI(N,NG),COV(1),XBAR(N),GUSE(N),VUSE(NG), 1 IUSE(1),GRN(NG),X(N),SMALL(N,NG),BIG(N,NG),VNAME(N),GNAME(NG) DATA GROUP,TOTAL,WITHIN,BETWEN/'GROUP ','TOTAL ','WITHIN', 1'BETWEEN'/ C DATA ULINE/4H* / C 1000 FORMAT(1X,A6,5X,12F9.4) 1001 FORMAT(1H ) 1005 FORMAT( ///30H NUMBER OF CASES PER GROUPS //(1X,A6,5X,F6.0 )) 1010 FORMAT(10X,6HD.F.= ,F6.0) 1040 FORMAT(/// 24H ANALYSIS OF VARIANCE //20H SOURCE OF VARIANCE * 10X, 50H D.F. SUM OF SQ. MEAN SQ. F-VALUE ) 1041 FORMAT( 30H EQUALITY OF ADJ. CELL MEANS ,I5,3F15.4) 1042 FORMAT( 30H ZERO SLOPE ,I5,3F15.4) 1043 FORMAT( 30H ERROR ,I5,2F15.4 ) 1044 FORMAT( 30H EQUALITY OF SLOPES ,I5,3F15.4) 1050 FORMAT( ///30H OBSERVED MINIMUMS //11X,12(3X,A6)) 1060 FORMAT( ///30H OBSERVED MAXIMUMS //11X,12(3X,A6)) 1070 FORMAT( ///30H ESTIMATES OF MEANS //11X,12(3X,A6)) 1078 FORMAT(1H1,23H SUBPROBLEM FOR GROUPS 12(2X,A6)) 1080 FORMAT( ///30H VARIANCE-COVARIANCE MATRIX ,A8) 1084 FORMAT(// 62H GROUP N GRP.MEAN ADJ.GRP.MEAN *STD.ERR. ) 1085 FORMAT(//53H COVARIATE REG.COEFF. STD.ERR. T-VALUE) 1086 FORMAT(3X,A6,F6.0,3X,4F15.5) 1087 FORMAT(3X,A6 ,3X,4F15.5) 1088 FORMAT(/// 45H T-TEST MATRIX FOR ADJUSTED GROUP MEANS ) 1090 FORMAT(/// 51H CORRELATION MATRIX FOR THE REGRESSION COEFFICIENTS) 1091 FORMAT(/// 50H CORRELATION MATRIX FOR THE ADJUSTED GROUP MEANS ) 1095 FORMAT( ///24H DEPENDENT VARIABLE IS ,A6) 1096 FORMAT(1X,120A1) 1110 FORMAT( // 50H VARIANCE-COVARIANCE MATRIX TOTAL IS SINGULAR ) 1120 FORMAT( // 50H VARIANCE-COVARIANCE MATRIX WITHIN IS SINGULAR ) 1130 FORMAT(/ 37H VARIANCE-COVARIANCE MATRIX OF GROUP ,A6, * 60H IS SINGULAR. F-TEST FOR EQUALITY OF SLOPES IS NOT COMPUTED.) C NN=N*(N+1)/2 DO 10 IG=1,NG GRN(IG)=0.0 DO 10 I=1,N VUSE(I)=1.0 SMALL(I,IG)= 10.0**10 10 BIG(I,IG)=-SMALL(I,IG) 20 CALL READIN(X,IX,IG) IF(IG.EQ.0) GO TO 50 II=NN*(IG-1)+1 CALL MACLOM(COVI(II),XBARI(1,IG),X,XBAR,GRN(IG),N) DO 30 I=1,N IF(SMALL(I,IG).GT.X(I)) SMALL(I,IG)=X(I) IF(BIG(I,IG).LT.X(I)) BIG(I,IG)=X(I) 30 CONTINUE GO TO 20 50 WRITE(6,1005)(GNAME(I),GRN(I),I=1,NG) NPRNT=0 51 IPRNT=NPRNT+1 NPRNT=MIN0(N,NPRNT+12) WRITE(6,1050)(VNAME(I),I=IPRNT,NPRNT) WRITE(6,1001) DO 52 IG=1,NG 52 WRITE(6,1000)GNAME(IG),(SMALL(I,IG),I=IPRNT,NPRNT) IF(NPRNT.LT.N) GO TO 51 NPRNT=0 61 IPRNT=NPRNT+1 NPRNT=MIN0(N,NPRNT+12) 60 WRITE(6,1060)(VNAME(I),I=IPRNT,NPRNT) WRITE(6,1001) DO 62 IG=1,NG 62 WRITE(6,1000)GNAME(IG),(BIG (I,IG),I=IPRNT,NPRNT) IF(NPRNT.LT.N) GO TO 61 NPRNT=0 71 IPRNT=NPRNT+1 NPRNT=MIN0(N,NPRNT+12) 70 WRITE(6,1070)(VNAME(I),I=IPRNT,NPRNT) WRITE(6,1001) DO 72 IG=1,NG 72 WRITE(6,1000)GNAME(IG),(XBARI(I,IG),I=IPRNT,NPRNT) IF(NPRNT.LT.N) GO TO 71 DO 90 IG=1,NG II=NN*(IG-1)+1 WRITE(6,1080)GROUP,GNAME(IG) GRN1=GRN(IG)-1.0 WRITE(6,1010)GRN1 90 CALL PRDLOM(COVI(II),N,GRN1 ,X,VNAME,VUSE) 75 CALL GETSEQ(WORK,NCC,GUSE,VUSE,IUSE,MORE) IF(MORE.EQ.0) RETURN WRITE(6,1096)(ULINE,LINE=1,240) CALL BARTOT(XBARI,XBAR,GRN,NG,N,GUSE) NPRNT=0 77 IPRNT=NPRNT+1 NPRNT=MIN0(N,NPRNT+12) WRITE(6,1070)(VNAME(I),I=IPRNT,NPRNT) DO 78 IG=1,NG IF(GUSE(IG).NE.1.0) GO TO 78 WRITE(6,1000)GNAME(IG),(XBARI(I,IG),I=IPRNT,NPRNT) 78 CONTINUE WRITE(6,1000)TOTAL,(XBAR(I),I=IPRNT,NPRNT) IF(NPRNT.LT.N) GO TO 77 WRITE(6,1080)TOTAL CALL TOTLOM(COVI,XBARI,COV,GRN,NG,N,GUSE,DFT) DFT1=DFT-1.0 WRITE(6,1010)DFT1 CALL PRDLOM(COV,N,DFT-1.0,X,VNAME,VUSE) CALL INVLOM(COV,IUSE,X,BIG,N) IF(X(1).EQ.1.0)WRITE(6,1110) IF(X(1).EQ.1.0) GO TO 75 II=0 L=0 DO 80 I=1,N II=II+I IF(IUSE(I).EQ.0) GO TO 80 L=L+1 80 SMALL(I,1)=COV(II) WRITE(6,1080)BETWEN CALL BETLOM(XBARI,COV,GRN,NG,N,GUSE,DFB) DFB1=DFB-1. WRITE(6,1010)DFB1 CALL PRDLOM(COV,N,DFB-1.0,X,VNAME,VUSE) WRITE(6,1080)WITHIN CALL WITLOM(COVI,COV,NG,N,GUSE,DFW,GRN) II=0 DO 81 I=1,N II=II+I 81 SMALL(I,2)=COV(II) WRITE(6,1010)DFW CALL PRDLOM(COV,N,DFW,X,VNAME,VUSE) WRITE(6,1090) CALL INVLOM(COV,IUSE,X,BIG,N) IF(X(1).EQ.1.0)WRITE(6,1120) IF(X(1).EQ.1.0) GO TO 75 CALL PRDLOM(COV,N,0.0 ,X,VNAME,IUSE) WRITE(6,1091) CALL CAGLOM(COV,XBARI,XBAR,BIG ,GRN,NG,N,GUSE,IUSE,-1.0) CALL PRDLOM(BIG ,NG,0.0 ,X,GNAME,GUSE) DFL=DFW-FLOAT(L) II=0 DO 85 I=1,N II=II+I IF((IUSE(I).NE.0).OR.(VUSE(I).NE.1.0)) GO TO 85 WRITE(6,1095)VNAME(I) WRITE(6,1096)(ULINE,LINE=1,120) WRITE(6,1085) IJ=II-I DO 82 J=1,N IF(IUSE(J).EQ.0) GO TO 82 IJJ=IJ+J IF(J.GT.I) IJJ=J*(J-1)/2+I JJ=J*(J+1)/2 STD=SQRT(-COV(II)*COV(JJ)/DFL) T=COV(IJJ)/STD WRITE(6,1087)VNAME(J),COV(IJJ),STD,T 82 CONTINUE WRITE(6,1001) WRITE(6,1084) IFL=DFL +.001 IFB1=DFB1 +.001 SUME=0.0 DFE=0.0 ISIGN=0 DO 86 IG=1,NG IF(GUSE(IG).EQ.0.0) GO TO 86 ADJMN =XBARI(I,IG) DO 87 J=1,N IF(IUSE(J).EQ.0) GO TO 87 JJ=II-I+J IF(J.GT.I) JJ=J*(J-1)/2+I ADJMN=ADJMN- (XBARI(J,IG)-XBAR(J))*COV(JJ) 87 CONTINUE IGG=IG*(IG+1)/2 STD=SQRT(BIG(IGG,1)/DFL*COV(II)) WRITE(6,1086)GNAME(IG),GRN(IG),XBARI(I,IG),ADJMN,STD IF(GRN(IG)-FLOAT(L+1).LE.0.0) GO TO 86 IJ=NN*(IG-1) DO 84 J=1,NN JJ=J+IJ 84 TEMP(J)=COVI(JJ) CALL INVLOM(TEMP,IUSE,X,SMALL(1,3),N) IF(X(1).EQ.1.0)WRITE(6,1130)GNAME(IG) IF(X(1).EQ.1.0) ISIGN=1 SUME=SUME+TEMP(II) DFE=DFE+GRN(IG)-FLOAT(L+1) 86 CONTINUE WRITE(6,1040) WRITE(6,1001) SME=COV(II)/DFL SS=SMALL(I,1)-COV(II) SM=SS/DFB1 FVAL=SM/SME WRITE(6,1041)IFB1,SS,SM,FVAL SS=SMALL(I,2)-COV(II) SM=SS/FLOAT(L) FVAL=SM/SME WRITE(6,1042)L,SS,SM,FVAL WRITE(6,1043)IFL,COV(II),SME WRITE(6,1001) IF(ISIGN.NE.0) GO TO 95 SS=COV(II)-SUME IDFS=DFL-DFE+.001 SM=SS/(DFL-DFE) SME=SUME/DFE IFE=DFE+.001 FVAL=SM/SME WRITE(6,1044)IDFS,SS,SM,FVAL WRITE(6,1043)IFE,SUME,SME 95 DO 89 IG=1,NG X(IG)=XBARI(I,IG) DO 89 J=1,N IF(GUSE(IG).EQ.0.0) GO TO 89 IF(IUSE(J).EQ.0) GO TO 89 JJ=II-I+J IF(J.GT.I) JJ=J*(J-1)/2+I X(IG)=X(IG)-(XBARI(J,IG)-XBAR(J))*COV(JJ) 89 CONTINUE KK=0 DO 88 K=1,NG K1=K*(K+1)/2 DO 88 J=1,K KK=KK+1 IF(GUSE(K ).EQ.0.0) GO TO 88 IF(GUSE(J ).EQ.0.0) GO TO 88 J1=J*(J+1)/2 KJ=K*(K-1)/2+J TEMP(KK) = 0.0 HSTUFF = SQRT((BIG(K1,1) + BIG(J1,1) - 2.0 * BIG(KJ,1)) * COV(II) 1 / DFL) IF(HSTUFF .NE. 0.0) TEMP(KK) = (X(K) - X(J)) / HSTUFF 88 CONTINUE WRITE(6,1088) CALLPRDLOM(TEMP,NG,-1.,SMALL(1,3),GNAME,GUSE) CALL TCONTR(WORK,NCC,BIG,X,DFL/COV(II),GUSE,NG,GNAME,TEMP) 85 CONTINUE GO TO 75 END SUBROUTINE READIN(X,IX,IG) COMMON/CONTR/NV,NG,NI,NT,FMT(180) DIMENSION X(1),IX(1) DATA IIG/1/ C IG=0 1 READ (NT,FMT,END=2) (X(I), I=1,NV) IF(NI.LE.0) GO TO 10 IF(IX(NI).LT.1 .OR. IX(NI).GT.NG) IX(NI) = X(NI) + .00001 IG = IX(NI) X(NI)=IX(NI) C IF((IG.LT.1).OR.(IG.GT.NG)) IG=0 2 RETURN 10 IG=IIG DO 15 I=1,NV IF(X(I).NE.0.0) RETURN 15 CONTINUE IIG=IIG+1 IF(IIG.LE.NG) GO TO 1 IG=0 IIG=1 RETURN END SUBROUTINE TCONTR(WORK,NCC,BIG,X,DF,GUSE,NG,GNAME,TEMP) DIMENSION WORK(NG,NCC),BIG(1),X(1),GUSE(1),GNAME(1),TEMP(1) DATA TVALUE/4H T / C 1000 FORMAT(/// 50H T-VALUES FOR CONTRASTS IN ADJUSTED GROUP MEANS * //12(3X,A6)) 1010 FORMAT(12F9.5) C IF(NCC.EQ.0) RETURN II=0 DO 10 I=1,NG IF(GUSE(I).EQ.0.0) GO TO 10 II=II+1 TEMP(II)=GNAME(I) 10 CONTINUE WRITE(6,1000)(TEMP(I),I=1,II),TVALUE DO 100 ICC=1,NCC T=0.0 SIG=0.0 II=0 DO 30 I=1,NG IF(GUSE(I).EQ.0.0) GO TO 30 II=II+1 TEMP(II)=WORK(I,ICC) T=T+WORK(I,ICC)*X(I) DO 20 J=1,NG IF(GUSE(J).EQ.0.0) GO TO 20 IJ=I*(I-1)/2+J IF(J.GT.I) IJ=J*(J-1)/2+I SIG=SIG+WORK(I,ICC)*WORK(J,ICC)*BIG(IJ) 20 CONTINUE 30 CONTINUE T=T/SQRT(SIG/DF) 100 WRITE(6,1010)(TEMP(I),I=1,II),T RETURN END SUBROUTINE PRDLOM(A,N,DF,W,ANAME,USE) DIMENSION A(1),W(1),ANAME(1),USE(1) DOUBLE PRECISION STD DATA STD/6HST.DEV / C 1000 FORMAT( 1X,A6,3X,10F11.4) 1001 FORMAT( / 7X,10(5X,A6)) 1002 FORMAT(1H ) C IC=0 1 ICP=IC+1 II=0 5 IC=IC+1 IF(USE(IC).EQ.0.0) GO TO 6 II=II+1 W(II)=ANAME(IC) 6 IF(IC.LT.N.AND.II.LT.10) GO TO 5 WRITE(6,1001)(W(I),I=1,II) WRITE(6,1002) DO 30 I=ICP,N IF(USE(I).EQ.0.0) GO TO 30 II=0 J=ICP-1 10 J=J+1 IF(USE(J).EQ.0.0) GO TO 20 II=II+1 IJ=I*(I-1)/2+J IF(DF.NE.0.0) GO TO 15 I1=I*(I+1)/2 J1=J*(J+1)/2 W(II)= A(IJ) /SQRT( A(I1)*A(J1) ) *A(I1)/ABS(A(I1)) GO TO 20 15 W(II)=A(IJ)/DF 20 IF(J.LT.I.AND.II.LT.10) GO TO 10 WRITE(6,1000)ANAME(I),(W(IJ),IJ=1,II) 30 CONTINUE WRITE(6,1002) II=0 I=ICP-1 35 I=I+1 IF(USE(I).EQ.0.0) GO TO 40 II=II+1 IJ=I*(I+1)/2 IF(DF.GT.0.0) W(II)=SQRT(ABS(A(IJ)/DF)) 40 IF(I.LT.N.AND.II.LT.10) GO TO 35 IF(DF.GT.0.0)WRITE(6,1000)STD,(W(J),J=1,II) 100 IF(I.LT.N) GO TO 1 RETURN END SUBROUTINE MACLOM(COV,XBAR,X,W,PREVNO,N) DIMENSION COV(1),XBAR(N),X(N),W(N) C IF(PREVNO.NE.0.0) GO TO 30 M=0 DO 10 I=1,N XBAR(I)=0.0 DO 10 J=1,I M=M+1 10 COV(M)=0.0 30 M=0 PREVP1=PREVNO+1.0 DO 50 I=1,N XDELTA=(X(I)-XBAR(I))*PREVNO W(I) =(X(I)-XBAR(I))/PREVP1 XBAR(I)=XBAR(I)+W(I) DO 50 J=1,I M=M+1 50 COV(M)=COV(M)+XDELTA*W(J) PREVNO=PREVP1 RETURN END SUBROUTINE BARTOT(XBI,XB,GRN,NG,N,P) DIMENSION XBI(N,NG),XB(1),GRN(NG),P(NG) C TOTN=0.0 DO 10 I=1,N 10 XB(I)=0.0 DO 20 IG=1,NG IF(P(IG).EQ.0.0) GO TO 20 TOTN=TOTN+GRN(IG) DO 15 I=1,N 15 XB(I)=XB(I)+XBI(I,IG)*GRN(IG) 20 CONTINUE DO 30 I=1,N 30 XB(I)=XB(I)/TOTN RETURN END SUBROUTINE WITLOM(WI,W,NG,N,P,DF,GRN) DIMENSION WI(1),W(1),P(1),GRN(1) C DF=0.0 NN=N*(N+1)/2 DO 10 I=1,NN 10 W(I)=0.0 DO 30 IG=1,NG IF(P(IG).EQ.0.0) GO TO 30 DF=DF+GRN(IG)-1.0 M=NN*(IG-1) DO 20 I=1,NN M=M+1 20 W(I)=W(I)+WI(M) 30 CONTINUE RETURN END SUBROUTINE BETLOM(XBI,B,GRN,NG,N,P,DF) DIMENSION XBI(N,NG),B(1),GRN(NG),P(NG) C DF=0.0 TOTN=0.0 DO 10 I=1,NG IF(P(I).EQ.0.0) GO TO 10 DF=DF+1.0 TOTN=TOTN+GRN(I) 10 CONTINUE M=N*(N-1)/2+1 CALL BARTOT(XBI,B(M),GRN,NG,N,P) MI=M-1 MII=M-1 M=0 DO 20 I=1,N MJ=MII MI=MI+1 DO 20 J=1,I MJ=MJ+1 M=M+1 B(M)=-B(MI)*B(MJ)*TOTN DO 20 IG=1,NG IF(P(IG).NE.0.0) B(M)=B(M)+XBI(I,IG)*XBI(J,IG)*GRN(IG) 20 CONTINUE RETURN END SUBROUTINE TOTLOM(WI,XBI,T,GRN,NG,N,P,DF) DIMENSION WI(1),XBI(N,NG),T(1),GRN(1),P(1) C CALL BETLOM(XBI,T,GRN,NG,N,P,DF) DF=0.0 NN=N*(N+1)/2 DO 30 IG=1,NG IF(P(IG).EQ.0.0) GO TO 30 DF=DF+GRN(IG) M=NN*(IG-1) DO 20 I=1,NN M=M+1 20 T(I)=T(I)+WI(M) 30 CONTINUE RETURN END SUBROUTINE INVLOM(A,P,U,V,N) DIMENSION A(1),P(N),U(N),V(N) C M=0 KOUNT=0 DO 1 I=1,N M=M+I V(I)=A(M)*P(I) IF(P(I).NE.0.0) KOUNT=KOUNT+1 IF(V(I).NE.0.) K=I 1 CONTINUE 6 M=K*(K-1)/2 L=1 DO 2 I=1,N M=M+L IF(I.GE.K) L=I U(I)=A(M) 2 A(M)=0. B=U(K) V(K)=0.0 U(K)=-1. M=0 KOUNT=KOUNT-1 T=0.0 DO 5 I=1,N Y=-U(I)/B DO 4 J=1,I M=M+1 4 A(M)=A(M)+Y*U(J) IF(V(I).EQ.0.0) GO TO 5 H=A(M)/V(I) IF(H.LT.T) GO TO 5 T=H K=I 5 CONTINUE IF(T.GT.1.E-5) GO TO 6 U(1)=0.0 IF(KOUNT.EQ.0) RETURN U(1)=1.0 RETURN END SUBROUTINE CAGLOM(COV,XBARI,XBAR,CAG,GRN,NG,NV,USEG,USEI,DF) DIMENSION COV(1),XBARI(NV,NG),XBAR(NV),CAG(1),GRN(NG),USEG(NG), * USEI(NV) C DO 100 I=1,NG IF(USEG(I).EQ.0.0) GO TO 100 DO 90 J=1,I IF(USEG(J).EQ.0.0) GO TO 90 II=I*(I-1)/2+J CAG(II)=0.0 IF(I.EQ.J) CAG(II)=1.0/GRN(I) DO 80 K=1,NV IF(USEI(K).EQ.0.0) GO TO 80 DO 70 L=1,K IF(USEI(L).EQ.0.0) GO TO 70 KK=K*(K-1)/2+L COVDF=COV(KK)/DF CAG(II)=CAG(II)+(XBARI(K,I)-XBAR(K))*(XBARI(L,J)-XBAR(L))*COVDF IF(K.NE.L) *CAG(II)=CAG(II)+(XBARI(L,I)-XBAR(L))*(XBARI(K,J)-XBAR(K))*COVDF 70 CONTINUE 80 CONTINUE 90 CONTINUE 100 CONTINUE RETURN END SUBROUTINE SETUP COMMON/MEMORY/LENGTH,LEXICN,IBLOCK(8000) C LENGTH=8000 LEXICN=1 DO 10 I=1,LENGTH 10 IBLOCK(I)=0 RETURN END SUBROUTINE RECORD(LABEL,LOC,NO) COMMON/MEMORY/LENGTH,LEXICN,IBLOCK(8000) C 100 FORMAT(// 80H THIS PROBLEM REQUIRES MORE DYNAMICALLY ALLOCATABLE *MEMORY THAN IS AVAILABLE. ) C IBLOCK(LEXICN)=LABEL IBLOCK(LEXICN+1)=NO LOC=LEXICN+2 LEXICN=LOC+NO IF(LEXICN.LE.LENGTH) RETURN WRITE(6,100) STOP END SUBROUTINE LOOKUP(LABEL,LOC,NO) COMMON/MEMORY/LENGTH,LEXICN,IBLOCK(8000) C I=1 10 IF(IBLOCK(I).EQ.LABEL) GO TO 20 I=I+IBLOCK(I+1)+2 IF(I.LT.LEXICN) GO TO 10 LOC=0 NO=0 RETURN 20 LOC=I+2 NO=IBLOCK(I+1) RETURN END SUBROUTINE DELETE(LABEL) COMMON/MEMORY/LENGTH,LEXICN,IBLOCK(8000) C CALL LOOKUP(LABEL,LOC,NO) IF(LOC.LE.0) RETURN LOC=LOC-2 NO=NO+2 LEXICN=LEXICN-NO DO 10 I=LOC,LEXICN J=I+NO IBLOCK(I)=IBLOCK(J) 10 IBLOCK(J)=0 RETURN END SUBROUTINE DUMPB COMMON/MEMORY/LENGTH,LEXICN,IBLOCK(8000) C 1000 FORMAT(/1H4,A6,2I8//) 2000 FORMAT(I4,E18.8,5X,A6,2X,I10) 3000 FORMAT(1H1,49H DYNAMIC STORAGE DUMP. NEXT AVAILABLE LOCATION =I6) C WRITE(6,3000)LEXICN M=0 10 N=M+3 M=N+IBLOCK(N-1)-1 WRITE(6,1000)IBLOCK(N-2),N,M JBLOCK=IBLOCK(N)+1 NEXT=IBLOCK(N) L=1 DO 20 J=N,M LAST=JBLOCK JBLOCK=NEXT NEXT=IBLOCK(J+1) IF((LAST.NE.JBLOCK).OR.(JBLOCK.NE.NEXT))WRITE(6,2000)L,(JBLOCK,K=1 1,3) 20 L=L+1 IF((M+1).GE.LEXICN) GO TO 10 RETURN END SUBROUTINE RESERV(LABEL,LOCATE,NO) C CALL DELETE(LABEL) CALL RECORD(LABEL,LOCATE,NO) RETURN END BLOCK DATA LOGICAL PRINT,FATAL C IF 'NEXT'=0 A NEW BATCH OF PARAGRAPHS WILL BE READ. C IF 'NEXT'.LE.0 INFORMATION WILL BE READ FROM THE P.R.R.-BUFFER. COMMON/GETNXT/NEXT DATA NEXT /0/ C IF 'PRINT'=.TRUE. REPORTS OF DETECTED SYNTAX ERRORS WILL BE PRINTED. COMMON/GETPRT/PRINT DATA PRINT /.TRUE./ C IF 'FATAL'=.TRUE. PROGRAM STOPS WHEN SYNTAX ERROR IS DETECTED. COMMON/GETFTL/FATAL DATA FATAL /.FALSE./ C 'IN'= INPUT UNIT NUMBER. COMMON/GETINT/IN DATA IN /5/ C 'IFMT'=INPUT FORMAT. COMMON/GETIFM/IFMT(2) DATA IFMT(1)/4H(16A/,IFMT(2)/2H5)/ C 'NCR'=NO. OF CHARACTERS READ FROM A UNIT RECORD OF THE INPUT UNIT. COMMON/GETNCR/NCR DATA NCR /80/ C 'NCHW=NO. OF CHARACTERS PER MEMORY WORD. COMMON/GETNCW/NCHW DATA NCHW /5/ C 'PARBUF' IS THE P.R.R.-BUFFER. COMMON/GETBUF/PARBUF(200) DATA PARBUF/200*1H / C 'NCHB'=P.R.R.-BUFFER SIZE (NO. OF CHARACTERS). COMMON/GETBSZ/NCHB DATA NCHB /1000/ C 'THING' IS THE P.R.R.-ITEM-BUFFER. COMMON/GETTNG/THING(2) DATA THING /2*1H0/ C 'NCHN'=NO. OF CHARACTERS PER VARIABLE NAMES (P.R.R.-ITEM-BUFFER SIZE) COMMON/GETNCN/NCHN DATA NCHN /8/ END SUBROUTINE GETME(PNAME,THIS,KIND,LENGTH,MANY,VALUES,IERROR ) C 'PNAME'= NAME OF THE PARAGRAPH FROM WHICH INFORMATION IS TO BE READ. C 'THIS'= NAME OF THE VARIABLE FOR WHICH VALUES ARE TO BE READ. C IF 'KIND'=0 LOGICAL IS EXPECTED, C IF 'KIND'=1 INTEGER VALUE IS EXPECTED, C IF 'KIND'=2 REAL VALUE IS EXPECTED, C IF 'KIND'.GE.3 LITERAL VALUE IS EXPECTED (KIND=NO. OF CHARACTERS TO C 'LENGTH'= MAXIMUM NUMBER OF VALUES TO BE STORED. C 'MANY'= NUMBER OF VALUES FOUND. C 'VALUES' IS THE ARRAY WHERE THE VALUES ARE TO BE STORED. C 'IERROR' IS THE ERROR INDICATOR (IERROR=0 MEANS NO ERROR). COMMON/GETNXT/NEXT COMMON/GETNCW/NCHW COMMON/GETBUF/PARBUF(200) COMMON/GETTNG/THING(2) COMMON/GETNCN/NCHN COMMON/GETPRT/PRINT COMMON/GETFTL/FATAL DIMENSION LOGIC(4,8),E(12,12),EFE(144),VALUES(LENGTH),TIMES(2) DOUBLE PRECISION PNAME,THIS LOGICAL TOFLAG,BYFLAG,EQUAL,GETSAM,NO,PRINT,FATAL LOGICAL OK EQUIVALENCE (F,EFE) EQUIVALENCE (THING,ITHING),(NO,VALOGC) EQUIVALENCE(DEL,IDEL) EQUIVALENCE (ICTO,CTO),(ICFROM,CFROM) DATA AND,THE,OF,HIS,ARE,HNO,TO,BY,TIMES(1),TIMES(2) / 14HAND ,4HTHE ,4HOF ,4HIS ,4HARE ,4HNO ,4HTO ,4HBY ,4HTIME, 24HS / DATA STAR,COMMA,DOT,PLUS,DASH,EQUALS,BLANK / 14H* ,4H, ,4H. ,4H+ ,4H- ,4H= ,4H / DATA EFE /'PARA','GRAP','H NA','ME N','OT F','OUND','. ', 1' ',' ',' ',' ',' ', 'ILLE','GAL ','SPEC','IAL ','CHAR','ACTE', 2'R EN','COUN','TERE','D. ',' ',' ', 3 'ILLE','GAL ','SEQU','ENCE',' OF ','ITEM','S. ', 4' ',' ',' ',' ',' ','NO V','ARIA','BLE ','MENT','IONE','D IN', 5' FRO','NT O','F EQ','UAL ','SIGN','. ', 6 'NO ','EQUA','L P','RECE','EDS ','THE ','NUMB', 7'ER O','R LI','TERA','L. ',' ', 7 'NUMB','ER F','OUND',' WHE','RE L','ITER','AL I', 8'S EX','PECT','ED. ',' ',' ', 9 'LITE','RAL ','FOUN','D WH','ERE ','NUMB','ER I', 1'S EX','PECT','ED. ',' ',' ','MORE',' THA','N ON','E T', 2'O OR',' A ','TIME','S I','N AN',' IMP','LIED',' DO.','MORE', 3' THA','N ON','E T','O OR',' A ','TIME','S I','N AN', 4' IMP','LIED',' DO.','MORE',' THA','N ON','E B','Y O','R NO', 4' TO',' OR',' TIM','ES ','IN L','IST.','IMPL','IED ', 5 'IED ','LIST','S AR','E NO','T AL','LOWE','D WI','THIM',' A B', 6'AND.','RANG','E OF',' IMP','LIED',' LIS','T IS',' LES', 7'S TH','AN S','TEP-','SIZE','. '/ C C A N L = C DATA LOGIC / 7, 6, 6, 9, 1 9, 3, 3, 3, 2 9, 4, 4, 4, 4 2, 9, 9, 9, 5 9, 5, 5, 5, 6 1, 1, 1, 1, 7 8, 1, 1, 9, 8 10, 10, 10, 9/ C C INITIALIZATIONS FOR THE WHOLE SUBROUTINE OK=.TRUE. IF(KIND.GE.0) GO TO 3 WRITE(6,2)KIND 2 FORMAT(42H1THE VALUE OF KIND MUST BE .GE.0 , BUT IS ,I6) STOP 3 CONTINUE CALL GETSTR(PNAME,IERROR) IF(IERROR.NE.0)GO TO 90 IWIDTH = 1 LOC=0 MANY=-1 EQUAL=.FALSE. 4 ITYPE=2 NTIMES=0 TOFLAG=.FALSE. C INITIALIZATIONS FOR VALUES 5 IPHASE=MOD(KOUNTV,IWIDTH)+1 KOUNTV=KOUNTV+1 6 SIGN=1. C THE LOOP 8 LAST=ITYPE NO=.TRUE. 10 CALL GETHNG(THING,NCHN,LONG,ITYPE) IF (ITYPE.EQ.3) GO TO 7 IF(THING(1) .EQ. STAR) ITYPE = 8 IF(THING(1).EQ.COMMA .OR. THING(1).EQ.AND .OR. THING(1).EQ.THE 1 .OR. THING(1).EQ.OF) ITYPE = 6 IF(THING(1) .EQ. DOT) ITYPE = 7 IF(THING(1).EQ.PLUS .OR. THING(1).EQ.DASH) ITYPE = 5 IF(THING(1) .EQ. HNO) GO TO 150 IF(THING(1) .EQ. TO) GO TO 161 IF(THING(1) .EQ. BY) GO TO 162 IF(THING(1) .EQ. TIMES(1)) GO TO 163 7 IERROR=2 IF(THING(1).NE.EQUALS .AND. ITYPE.EQ.4) GO TO 90 IF((THING(1).EQ.HIS.OR.THING(1).EQ.ARE).AND.ITYPE.NE.3) ITYPE=4 9 IGO TO=LOGIC(LAST,ITYPE) IERROR=3 GO TO (165,20,200,200,50,60,70,80,90,100),IGOTO 20 IERROR=4 IF(IWIDTH.EQ.0)GO TO 90 EQUAL=.TRUE. GO TO 5 30 IERROR=6 ITIMES=THING(1)+.0000001 IF(KIND.NE.1.AND.KIND.NE.2)GO TO 89 THING(1)=SIGN*THING(1) IF(KIND.EQ.1) ITHING=THING(1)+SIGN*.0000001 VALUES(MANY)=THING(1) GO TO 5 40 IERROR=7 IF(KIND.LT.3) GO TO 90 LOW=(KIND-1)/NCHW+1 LOWW=LOW*MANY-LOW +1 NEXT=NEXT-LONG-3 CALL GETHNG(VALUES(LOWW),KIND,LONG,ITYPE) GO TO 5 50 IF(THING(1) .EQ. DASH) SIGN = -1.0 GO TO 10 60 IF(TOFLAG.OR.NTIMES.NE.0)GO TO 166 EQUAL=.FALSE. IF(LOC.NE.0) GO TO 999 IWIDTH=0 NTIMES=0 KOUNTV=0 TOFLAG=.FALSE. BYFLAG=.FALSE. 70 IF(GETSAM(PNAME,THING))GO TO 10 IWIDTH=IWIDTH+1 IF(.NOT.GETSAM(THIS,THING))GO TO 8 MANY=1 VALUES(1)=VALOGC IF(KIND.EQ.0)GO TO 999 MANY=0 LOC=IWIDTH GO TO 8 80 ITYPE=2 GO TO 8 C ERROR REPORTS 89 NEXTT=NEXT CALL GETHNG(THING,5,LONG,ITYPE) IF(THING(1) .EQ. TIMES(1)) GO TO 163 NEXT=NEXTT 90 NEXTT=(NEXT-2)/NCHW OK=.FALSE. IF(IERROR.EQ.1) GO TO 94 WORDL=PARBUF(NEXTT+1) LOW=MOD(NEXT-1,NCHW)+1 IF(LOW.EQ.1)GO TO 92 DO 91 J=LOW,NCHW 91 CALL PUTCHR(WORDL,J,BLANK) 92 IF(PRINT)WRITE(6,93)(E(J,IERROR),J=1,12),(PARBUF(J),J=1,NEXTT),WOR 1DL 93 FORMAT(48H1SYNTAX ERROR IN LAST FIELD OF PARAGRAPH BELOW. // 11X,12A5//(1X,20A5)) 94 IF(FATAL)STOP 100 IF(TOFLAG.OR.NTIMES.NE.0)GO TO 166 IF(KIND.NE.0.OR.MANY.GT.0)GO TO 999 MANY=0 NO=.FALSE. VALUES(1)=VALOGC 999 IF(OK)IERROR=0 RETURN 150 NO=.FALSE. GO TO 10 161 IF(LOC.EQ.0)GO TO 10 IERROR=9 IF(TOFLAG.OR.NTIMES.NE.0)GO TO 90 TOFLAG=.TRUE. CFROM=VALUES(MANY) MANY=MANY-1 GO TO 10 162 IF(LOC.EQ.0)GO TO 10 IERROR=10 IF(BYFLAG.OR..NOT.TOFLAG.OR.NTIMES.NE.0)GO TO 90 CTO=VALUES(MANY) MANY=MANY-1 BYFLAG=.TRUE. GO TO 10 163 IF(LOC.EQ.0)GO TO 10 IERROR=8 IF(TOFLAG.OR.NTIMES.NE.0)GO TO 90 NTIMES=ITIMES MANY=MANY-1 GO TO 10 165 IF(.NOT.TOFLAG.AND.NTIMES.EQ.0) GO TO 10 166 IERROR=11 IF(IWIDTH.NE.1) GO TO 90 IF(.NOT.TOFLAG)GO TO 169 IF(BYFLAG)GO TO 167 CTO = VALUES(MANY) IDEL=1 IF(KIND.EQ.2)DEL=1.0 VALUES(MANY)=DEL 167 DEL=VALUES(MANY) IF(KIND.EQ.2)NTIMES=ABS((CTO-CFROM)/DEL)+1.0000001 IF(KIND.NE.2)NTIMES=IABS((ICTO-ICFROM)/IDEL)+1 VALUES(MANY)=CFROM 169 L=1 IF(KIND.GE.3) L=(KIND-1)/NCHW+1 LLL=MANY*L IERROR=12 IF(NTIMES.LT.2) GO TO 90 DO 170 I=2,NTIMES MANY=MANY+1 IF(MANY.GT.LENGTH) GO TO 170 IF(KIND.EQ.2)VALUES(MANY)=VALUES(MANY-1)+DEL IF(KIND.EQ.2) GO TO 170 DO 168 LL=1,L LLL=LLL+1 LOWER=LLL-L THING(1)=VALUES(LOWER) IF(KIND.EQ.1)ITHING=ITHING+IDEL 168 VALUES(LLL)=THING(1) 170 CONTINUE TOFLAG=.FALSE. BYFLAG=.FALSE. NTIMES=0 GO TO 9 200 IERROR=5 IF(.NOT.EQUAL) GO TO 90 IF(LOC.EQ.0) GO TO 6 IF(IPHASE.NE.LOC) GO TO 5 MANY=MANY+1 IF(MANY.GT.LENGTH) GO TO 5 GO TO (90,90,30,40),IGOTO RETURN END SUBROUTINE GETHNG(THING,NNK,NK,ITYPE) C DELIMITER OTHER THAN BLANK=4 C LITERAL DEFINED BY '*XXX* WHERE * NOT EQUAL X =3 C NUMERIC REAL INCLUDING DECIMAL POINT, UNSIGNED =2 C ALPHABETIC NOT INCLUDING BLANK OR SPECIALS = 1 COMMON/GETNXT/NEXT COMMON/GETBUF/PARBUF(200) COMMON/GETNCW/NCHW DIMENSION THING(2) DATA BLANK/4H / C NNKK =((NNK - 1) / NCHW + 1)*NCHW DO 3 I=1,NNKK 3 CALL PUTCHR(THING,I,BLANK) ITYPE=4 NK=0 1 NK=NK+1 2 CONTINUE CHR=GETINP(NEXT) ICH=IBCD(CHR) GO TO (101,201,301,500),ITYPE 500 IF(ICH.EQ.1) GO TO 2 IF(ICH.LE.11) GO TO 200 IF(ICH.LE.37) GO TO 100 IF(ICH.EQ.45) GO TO 300 C TERMINATORS IC=IBCD(GETINP(NEXT)) NEXT=NEXT-1 IF(ICH.EQ.48.AND.IC.GE.2.AND.IC.LE.11) GO TO 200 THING(1) = CHR 5 RETURN C ALPHABETIC 100 ITYPE=1 101 IF(ICH.LT.2.OR.ICH.GT.37) GO TO 299 102 IF(NK.LE.NNK) CALL PUTCHR(THING,NK,CHR) GO TO 1 C NUMBERS 200 ITYPE=2 THING(1) = 0.0 FIRST=10. SECOND=1.0 IF(ICH.EQ.48) GO TO 290 201 IF(ICH.LT.2.OR.ICH.GT.11) GO TO 290 SECOND=SECOND*FIRST/10. THING(1) = THING(1) * FIRST + FLOAT(ICH-2) * SECOND GO TO 1 290 IF(ICH.NE.48.OR.FIRST.NE.10.) GO TO 299 FIRST=1.0 GO TO 1 299 NEXT=NEXT-1 298 NK=NK-1 RETURN C LITERAL 300 STOPCH=GETINP(NEXT) ITYPE=3 GO TO 2 301 IF(CHR.EQ.STOPCH)GO TO 298 GO TO 102 END FUNCTION GETINP(NEXT) COMMON/GETINT/IN COMMON/GETIFM/IFMT(2) COMMON/GETNCR/NCR COMMON/GETNCW/NCHW COMMON/GETBUF/PARBUF(200) COMMON/GETBSZ/NCHB DATA BLANKS /4H / C 10 IF(NEXT.GT.0)GO TO 3 NINCOL=0 ISTART=1 NEXT=1 NWORDS=(NCR-1)/NCHW+1 1 IEND=ISTART+NWORDS-1 NINCOL=NINCOL+NCR IF(IEND*NCHW.GT.NCHB) GO TO 4 READ (IN,IFMT)(PARBUF(I),I=ISTART,IEND) ISTART=IEND+1 GO TO 6 3 MYNEXT=NEXT-NINCOL IF(MYNEXT.EQ.1)GO TO 1 6 DO 2 I=1,NCHW 2 CALL PUTCHR (GETINP,I,BLANKS) CALL GETCHR(PARBUF,NEXT,GETINP) NEXT=NEXT+1 7 RETURN 4 WRITE(6,5) 5 FORMAT(32H1PARAMETER BUFFER SIZE EXCEEDED.) STOP END SUBROUTINE GETSTR(PNAME,IERROR) COMMON/GETNXT/NEXT COMMON/GETTNG/THING(2) COMMON/GETNCN/NCHN DOUBLE PRECISION PNAME LOGICAL GETSAM DATA STAR,ENDW,THE/4H* ,4HEND ,4HTHE / C 10 IERROR=0 IF(NEXT.GT.0) NEXT=1 INDEX=1 1 CALL GETHNG(THING,NCHN,LENGTH,ITYPE) IF(THING(1).EQ.THE .OR. THING(1).EQ.STAR) GO TO 1 IF(GETSAM(PNAME,THING)) INDEX=NEXT 8765 FORMAT(3X,A5) IF(THING(1) .EQ. ENDW) GO TO 3 2 CALL GETHNG(THING,1,LENGTH,ITYPE) IF(THING(1) .EQ. STAR) GO TO 1 GO TO 2 3 IF(INDEX.EQ.1) IERROR=1 NEXT=INDEX RETURN END FUNCTION GETSAM(THIS,THING) COMMON/GETNCN/NCHN COMMON /GETNCW/ NCHW DATA BLANKS /4H / DIMENSION THING(2) DOUBLE PRECISION THIS LOGICAL GETSAM DATA A,E,AI,O,U,DOTEND/4HA ,4HE ,4HI ,4HO ,4HU ,4H. / C DO 6 I=1,NCHW CALL PUTCHR (C,I,BLANKS) CALL PUTCHR (CH,I,BLANKS) CALL PUTCHR (DUM,I,BLANKS) 6 CALL PUTCHR (DUM1,I,BLANKS) L=1 GETSAM=.TRUE. DO 2 I=1,NCHN CALL GETCHR(THIS,I,C) IF(C.EQ.DOTEND)GO TO 5 CALL GETCHR(THING,L,CH) IF(C.EQ.CH)GO TO 1 IF(C.EQ.A.OR.C.EQ.E.OR.C.EQ.AI.OR.C.EQ.O.OR.C.EQ.U)GO TO 2 IF(.NOT.GETSAM)GO TO 3 GETSAM=.FALSE. IF(I.EQ.1.OR.L.EQ.1) RETURN GO TO 2 1 L=L+1 2 CONTINUE GETSAM=.TRUE. RETURN 3 GETSAM=.TRUE. DO 4 I=1,NCHN CALL GETCHR(THIS,I,DUM) IF(DUM .EQ. DOTEND) GO TO 5 CALL GETCHR(THING,I,DUM1) IF(DUM .EQ. DUM1) GO TO 4 IF(.NOT.GETSAM)RETURN GETSAM=.FALSE. 4 CONTINUE 5 GETSAM=.TRUE. RETURN END FUNCTION IBCD(A) C ASSIGNS AN INTEGER VALUE TO AN ALPHABETIC CHARACTER DIMENSION SEQ(48) DATA SEQ/4H ,4H0 ,4H1 ,4H2 ,4H3 ,4H4 ,4H5 ,4H6 , 14H7 ,4H8 ,4H9 ,4HA ,4HB ,4HC ,4HD ,4HE ,4HF , 24HG ,4HH ,4HI ,4HJ ,4HK ,4HL ,4HM ,4HN ,4HO , 34HP ,4HQ ,4HR ,4HS ,4HT ,4HU ,4HV ,4HW ,4HX , 44HY ,4HZ ,4H+ ,4H- ,4H$ ,4H* ,4H( ,4H) ,4H, , 54H' ,4H/ ,4H= ,4H. / C DO 1 I=1,48 IF (A.EQ.SEQ(I)) GO TO 2 1 CONTINUE I=49 2 IBCD=I RETURN END