Google
 

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