Trailing-Edge
-
PDP-10 Archives
-
decuslib20-05
-
decus/20-0137/bmd/bmdx82.for
There is 1 other file named bmdx82.for in the archive. Click here to see a list.
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