Trailing-Edge
-
PDP-10 Archives
-
decus_20tap5_198111
-
decus/20-0137/bmd/bmd11d.for
There is 1 other file named bmd11d.for in the archive. Click here to see a list.
C DATA PATTERNS FOR POLYCHOTOMIES JUNE 9, 1966
C THIS IS A SIFTED VERSION OF BMD11D ORIGINALLY WRITTEN IN
C FORTRAN II. SOME MODIFICATIONS WERE MADE TO MAKE IT OPERABLE
C AND SLIGHTLY MORE EFFICIENT THAN THE SIFTED VERSION.
DIMENSION B(62),LABEL(25,6),NS(25),NOC(25),ATRIX(25,10,10),
1IMAT(25,10),TD(25),NDATA(300,20),FMULT(5),SUM(700,5),
2ITEM(700),LIM(5),TM(120),IDENT(700),NG(25),NATA(3580)
COMMON NATA
COMMON TD
DOUBLE PRECISION TM,A1,A2,A3,A4
EQUIVALENCE (NATA,SUM),(NATA(1),ATRIX),(NATA(2501),ITEM),
1(NATA(3201),IMAT),(NATA(3451),TM)
C
DIMENSION C(10)
DATA C/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
DATA A2,A3,A4,BLANK,SLASH,COMMA/6HPROBLM,6HFINISH,6HRECODE,1H ,
11H/,1H,/
920 FORMAT(55H1BMD11D - DATA PATTERNS FOR POLYCHOTOMIES - VERSION OF
118HJUNE 9, 1966 ,/
241H HEALTH SCIENCES COMPUTING FACILITY, UCLA)
C
NTAPE=5
CALL USAGEB('BMD11D')
FMULT(1)=1.0
DO18I=2,5
IX=I-1
18 FMULT(I)=10.0**IX
DO19I=1,5
19 LIM(I)=5*I
20 READ (5,932)A1,PROB,NV,N,NID,MTAPE,MAT
IF(A1.EQ.A2)GO TO 25
12 IF(A1.EQ.A3)GO TO 1000
PRINT 500,A1
GO TO 1000
501 PRINT 502
GO TO 13
503 PRINT 504
13 WRITE (6,940)
GO TO 1000
25 CALL TPWD(MTAPE,NTAPE)
17 WRITE (6,920)
IF(MAT.GT.0.AND.MAT.LE.10)GO TO 173
MAT=1
WRITE (6,4000)
173 IF(NV.LE.0.OR.NV.GE.26) GO TO 501
6001 IF(N*(701-N)) 503,503,6002
6002 IF(NID) 22,22,23
22 NJ=NV
GOTO24
23 NJ=NV+1
24 DO 50 K=1,NV
READ (5,900)A1,(LABEL(K,LM),LM=1,6),NS(K),NOC(K), (B(J),J=1,56)
IF(A1.EQ.A4)GO TO 15
14 WRITE (6,941)K
GO TO 1000
15 LEFT=0
IF(NOC(K)-1)50,27,50
27 DO 29 I=1,55
IF(B(I).NE.BLANK)GO TO 30
29 CONTINUE
30 L=1
31 II=0
26 CONTINUE
32 IF(B(I).EQ.SLASH)GO TO 40
IF(B(I).EQ.COMMA.OR.B(I).EQ.BLANK)GO TO 36
35 DO38IJ=1,10
IF(C(IJ).NE.B(I)) GO TO 38
37 II=II+1
ATRIX(K,L,II)=IJ-1
GOTO36
38 CONTINUE
IF(LEFT)61,61,49
61 LEFT=9
36 I=I+1
GOTO26
40 IMAT(K,L)=II
I=I+1
L=L+1
GOTO31
49 IMAT(K,L)=II
NG(K)=L
50 CONTINUE
MAT=MAT*12
READ (5,930)(TM(I), I=1,MAT)
56 DO 120 I=1,N
READ (NTAPE,TM)(TD(KL), KL=1,NJ)
J=0
DO110JL=1,NJ
IF(NID-JL)72,71,72
71 IDENT(I)=TD(JL)
GOTO110
72 J=J+1
IF(NOC(J))105,105,85
85 JJ=NG(J)
DO100K=1,JJ
KK=IMAT(J,K)
IF(KK)100,100,86
86 DO95II=1,KK
IF(TD(JL)-ATRIX(J,K,II))95,90,95
90 NDATA(I,J)=K-1
GOTO110
95 CONTINUE
100 CONTINUE
105 NDATA(I,J)=TD(JL)
110 CONTINUE
120 CONTINUE
WRITE (6,902)PROB
WRITE (6,908)N,NV
PRINT 505,(TM(I),I=1,MAT)
DO152I=1,5
IF(NV-LIM(I))151,151,152
151 LBD=I
GOTO390
152 CONTINUE
390 NF=1
IF(NV-5)400,400,410
400 NL=NV
GOTO415
410 NL=5
415 DO420I=1,N
SUM(I,1)=0.0
DO420J=NF,NL
DATA=NDATA(I,J)
420 SUM(I,1)=SUM(I,1)+DATA*FMULT(J)
IF(NV-5)490,490,425
425 DO480K=2,LBD
NF=1+5*(K-1)
KK=LIM(K)
IF(NV-KK)430,430,433
430 NL=NV
GOTO435
433 NL=KK
435 DO440I=1,N
SUM(I,K)=0.0
DO440J=NF,NL
JF=J-LIM(K-1)
DATA=NDATA(I,J)
440 SUM(I,K)=SUM(I,K)+DATA*FMULT(JF)
480 CONTINUE
490 DO495J=1,6
495 WRITE (6,917)(LABEL(I,J),I=1,NV)
ID=N-1
DO250M=1,ID
IF(SUM(M,1)+99.0)170,250,170
170 IT=1
ITEM(1)=M
II=M+1
DO220JUNK=II,N
IF(SUM(JUNK,1)+99.0)171,220,171
171 DO180KT=1,LBD
IF(SUM(M,KT)-SUM(JUNK,KT))175,180,175
175 GOTO220
180 CONTINUE
SUM(JUNK,1)=-99.0
IT=IT+1
ITEM(IT)=JUNK
220 CONTINUE
SUM(M,1)=-99.0
WRITE (6,806)(NDATA(M,J),J=1,NV)
IF(IT-1)223,223,224
223 WRITE (6,915)
GOTO222
224 WRITE (6,914)IT
222 MAX=23
IF(IT-MAX)225,225,230
225 WRITE (6,804)(ITEM(LL),LL=1,IT)
WRITE (6,805)
GOTO250
230 NF=1
NL=MAX
WRITE (6,804)(ITEM(LL),LL=NF,NL)
NO=IT
233 NO=NO-MAX
NF=NF+MAX
IF(NO-MAX)240,240,235
235 NL=NL+MAX
WRITE (6,808)(ITEM(LL),LL=NF,NL)
GOTO233
240 NL=NL+NO
WRITE (6,808)(ITEM(LL),LL=NF,NL)
WRITE (6,805)
250 CONTINUE
IF(SUM(N,1)+99.0)260,275,260
260 WRITE (6,806)(NDATA(N,J),J=1,NV)
WRITE (6,915)
WRITE (6,804)N
275 IF(NID)125,125,127
125 WRITE (6,911)
DO310J=1,6
310 WRITE (6,918)(LABEL(I,J),I=1,NV)
DO130I=1,N
130 WRITE (6,901)I,(NDATA(I,J),J=1,NV)
GO TO 20
127 WRITE (6,912)
DO300J=1,6
300 WRITE (6,916)(LABEL(I,J),I=1,NV)
DO128I=1,N
128 WRITE (6,913)I,IDENT(I),(NDATA(I,J),J=1,NV)
GO TO 20
500 FORMAT(' PROGRAM EXPECTED PROBLM OR FINISH CARD, INSTEAD READ THE
1FOLLOWING',1X,A6)
502 FORMAT(' NUMBER OF VARIABLES INCORRECTLY SPECIFIED')
504 FORMAT(' NUMBER OF CASES INCORRECTLY SPECIFIED')
505 FORMAT(' VARIABLE FORMAT CARD(S)'/1X,12A6)
804 FORMAT(1H 4X,11HITEM NUMBER10X,23I4)
805 FORMAT(1H0///)
806 FORMAT(1H04X,15HPATTERN OF DATA6X,30I2)
807 FORMAT(1H1)
808 FORMAT(1H 25X,23I4)
900 FORMAT(A6,6A1,2I2,56A1)
901 FORMAT(1H04X,I3,8X,25I2)
902 FORMAT(14H0PROBLEM NO. A2)
908 FORMAT(12H0SAMPLE SIZEI14/20H NUMBER OF VARIABLES I6)
911 FORMAT(12H1ITEM NUMBER5X,21HPATTERNS OF ALL ITEMS//)
912 FORMAT(12H1ITEM NUMBER3X,4HCASE3X,21HPATTERNS OF ALL ITEMS//)
913 FORMAT(1H04X,I3,6X,I5,3X,25I2)
914 FORMAT(1H 4X,I4,1X,5HITEMS)
915 FORMAT(1H 7X,6H1 ITEM)
916 FORMAT(1H 21X,25(1X,A1))
917 FORMAT(1H 25X,25(1X,A1))
918 FORMAT(1H 15X,25(1X,A1))
930 FORMAT(12A6)
940 FORMAT(22H0ERROR ON PROBLEM CARD)
941 FORMAT(26H0ERROR ON RE-CODE CARD NO.I3)
4000 FORMAT(1H023X71HNUMBER OF VARIABLE FORMAT CARDS INCORRECTLY SPECIF
1IED, ASSUMED TO BE 1.)
932 FORMAT(A6,A2,I2,I3,2I2,53X,I2)
1000 IF(NTAPE-5)1002,1002,1001
1001 REWIND NTAPE
1002 STOP
END
C SUBROUTINE TPWD FOR BMD11D JUNE 9, 1966
SUBROUTINE TPWD(NT1,NT2)
IF(NT1)40,10,12
10 NT1=5
12 IF(NT1-NT2)14,19,14
14 IF(NT2.EQ.5)GO TO 18
REWIND NT2
19 IF(NT1-5)18,24,18
18 IF(NT1-6)22,40,22
22 REWIND NT1
24 NT2=NT1
RETURN
40 WRITE (6,49)
49 FORMAT(25H ERROR ON TAPE ASSIGNMENT)
STOP
END