Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-05 - decus/20-0137/bmd/bmd10d.for
There is 1 other file named bmd10d.for in the archive. Click here to see a list.
C  PROGRAM WAS CONVERTED FROM FORTRAN 2 TO 7090 FORTRAN 4
C        IT WAS THEN CONVERTED TO 360 FORTRAN IV (H-LEVEL)
C        DATA PATTERNS FOR DICHOTOMIES                JUNE  9, 1966
C        THIS IS A SIFTED VERSION OF BMD10D ORIGINALLY WRITTEN IN
C        FORTRAN II. SOME MODIFICATIONS WERE MADE TO MAKE IT OPERABLE
C        AND SLIGHTLY MORE EFFICIENT THAN THE SIFTED VERSION.
      DIMENSION TD(30),NDATA(400,20),L(15),IPRNT(30),
     1NSUM(400,3),TM(180),NUMBER(400),ITEM(400)
      COMMON  NUMBER
      COMMON  NDATA  , NSUM   , ITEM   , IPRNT  , L      , NJ
      COMMON  N      , NPRINT , II
      DATA   A2,FINISH/4HPROB,4HFINI/
C
      EQUIVALENCE(NUMBER(1),TM),(NUMBER(121),TD)
C
  920 FORMAT(53H1BMD10D - DATA PATTERNS FOR DICHOTOMIES - VERSION OF      
     118HJUNE  9, 1966     ,/
     241H HEALTH SCIENCES COMPUTING FACILITY, UCLA)
C
      NTAPE=5
	CALL USAGEB('BMD10D')
      L(1)=2
      DO 30 I=2,15
 30   L(I)=L(I-1)+L(I-1)
 20   READ (5,902)A1,PROB,NJ,N,TESMIS,NPRINT,ICODE,MTAPE,MAT
      IF(A1 .EQ. A2)     GO TO 25
   21 IF(A1 .EQ. FINISH)     GO TO 1000
   22 WRITE (6,901)
      GO TO 1000
   25 CALL TPWD(MTAPE,NTAPE)
 31   WRITE (6,920)
      WRITE (6,907)PROB
      IF(NJ*(31-NJ)) 22,22,6001
 6001 IF(N*(701-N)) 22,22,6002
 6002 WRITE (6,908)N,NJ
      DO32I=1,N
   32 NSUM(I,3)=0
      IF(NJ-15)35,35,36
 35   ASSIGN 200 TO NAME
      ASSIGN 455 TO KSKIP
      DO33I=1,N
   33 NSUM(I,2)=0
      GOTO39
C
 36   ASSIGN 210 TO NAME
      ASSIGN 410 TO KSKIP
   39 IF(MAT.GT.0.AND.MAT.LE.10) GO TO 40
      MAT=1
      WRITE(6,4000)
 40   MAT=MAT*18
      READ (5,910)(TM(I), I=1,MAT)
   55 DO111I=1,N
      READ (NTAPE,TM)(TD(K), K=1,NJ)
      DO 95 J=1,NJ
      IF(TD(J)-TESMIS)80,90,80
   80 NDATA(I,J)=1
      GOTO95
   90 NDATA(I,J)=0
   95 CONTINUE
  111 CONTINUE
      DO 200 I=1,N
      GO TO NAME,(200,210)
 210  NSUM(I,2)=NDATA(I,16)
  200 NSUM(I,1)=NDATA(I,1)
 220  II=0
      CALL PATTEN
  310 IF(ICODE) 20, 20, 330
 330  DO500II=1,NJ
      WRITE (6,900)II
      DO460I=1,N
      NSUM(I,1)=NDATA(I,1)
      GO TO KSKIP,(410,455)
 410  NSUM(I,2)=NDATA(I,16)
      GO TO 460
C
 455  NSUM(I,2)=0
  460 NSUM(I,3)=0
      CALL PATTEN
  500 CONTINUE
  550 GOTO20
C
  900 FORMAT(11H1VARIABLE (I2,16H) IS ELIMINATED.)
  901 FORMAT(22H0ERROR ON PROBLEM CARD)
  902 FORMAT(A4,2X,A2,I2,I3,F3.0,3I2,48X,I2)
  907 FORMAT(14H0PROBLEM NO.  A2)
  908 FORMAT(12H0SAMPLE SIZEI4/20H NUMBER OF VARIABLESI4)
  910 FORMAT(18A4)
 4000 FORMAT(1H023X71HNUMBER OF VARIABLE FORMAT CARDS INCORRECTLY SPECIF
     1IED, ASSUMED TO BE 1.)
C
 1000 IF(NTAPE-5)1002,1002,1001
 1001 REWIND NTAPE
 1002 STOP
      END
C             SUBROUTINE PATTEN  FOR BMD10D           JUNE  9, 1966
      SUBROUTINE PATTEN
      DIMENSION TD(30),NDATA(400,20),L(15),IPRNT(30),
     1NSUM(400,3),TM(120),NUMBER(400),ITEM(400)
      COMMON  NUMBER
      COMMON  NDATA  , NSUM   , ITEM   , IPRNT  , L      , NJ
      COMMON  N      , NPRINT , IA
      EQUIVALENCE(NUMBER(1),TM),(NUMBER(121),TD)
C
      IF(IA)1,1,2
 1    NJK=NJ
      GO TO 3
C
 2    NJK=NJ-1
 3    IF(NJ-15)50,50,96
   50 KV=NJ
      GOTO98
   96 KV=15
 98   DO 19 J=1,NJ
      IF(J-IA)15,19,15
 15   DO20I=1,N
      NSUM(I,3)=NSUM(I,3)+NDATA(I,J)
 20   CONTINUE
 19   CONTINUE
      IF(NJ-16)30,35,25
 25   DO 29 J=17,NJ
      IF(J-IA)26,29,26
 26   JJ=J-16
      DO 28 I=1,N
      NSUM(I,2)=NSUM(I,2)+NDATA(I,J)*L(JJ)
 28   CONTINUE
 29   CONTINUE
   30 IF(KV-1)35,35,32
   32  DO 36 I=1,N
   36  NSUM(I,1) = 0
       DO 34 J=2,KV
      IF(J-IA)33,345,33
 33   JJ=J-1
      DO 34 I=1,N
      NSUM(I,1)=NSUM(I,1)+NDATA(I,J)*L(JJ)
 34   CONTINUE
 345  CONTINUE
   35 DO250K=1,NJK
      NFL=NJK-K
      ID=0
      DO140I=1,N
      IF(NSUM(I,3)+99)120,140,120
  120 IF(NSUM(I,3)-K)140,130,140
  130 ID=ID+1
      NUMBER(ID)=I
      NSUM(I,3)=-99
  140 CONTINUE
      IF(ID)250,250,150
  150 WRITE (6,890)
      WRITE (6,900)NFL
      WRITE (6,901)ID
  405 WRITE (6,902)(NUMBER(KK),KK=1,ID)
  300 IF(ID-1)310,310,320
  310 IV=NUMBER(1)
      J=0
      DO 315 I=1,NJ
      IF(I-IA)311,315,311
 311  J=J+1
      IPRNT(J)=NDATA(IV,I)
 315  CONTINUE
      WRITE (6,903)(IPRNT(I),I=1,NJK)
      GOTO250
C
  320 IDT=ID-1
      DO202M=1,IDT
      JUNK=NUMBER(M)
      IF(NSUM(JUNK,1)+99)155,202,155
  155 IT=1
      ITEM(IT)=JUNK
      II=M+1
      DO160LM=II,ID
      JAX=NUMBER(LM)
      IF(NSUM(JAX,1)+99)165,160,165
 165  IF(NSUM(JUNK,1)-NSUM(JAX,1))160,171,160
  171 IF(NSUM(JUNK,2)-NSUM(JAX,2))160,181,160
  181 NSUM(JAX,1)=-99
      IT=IT+1
      ITEM(IT)=JAX
  160 CONTINUE
      NSUM(JUNK,1)=-99
      J=0
      DO 175 I=1,NJ
      IF(I-IA)174,175,174
 174  J=J+1
      IPRNT(J)=NDATA(JUNK,I)
 175  CONTINUE
      WRITE (6,903)(IPRNT(I),I=1,NJK)
      IF(IT-1)90,90,95
   90 WRITE (6,913)
      GOTO425
   95 WRITE (6,912)IT
  425 WRITE (6,904)(ITEM(LL),LL=1,IT)
  202 CONTINUE
      IX=NUMBER(ID)
      IF(NSUM(IX,1)+99)230,250,230
 230  J=0
      DO 240 I=1,NJ
      IF(I-IA)235,240,235
 235  J=J+1
      IPRNT(J)=NDATA(IX,I)
 240  CONTINUE
      WRITE (6,903)(IPRNT(I),I=1,NJK)
      WRITE (6,913)
      WRITE (6,904)IX
  250 CONTINUE
      ID=0
      DO270I=1,N
      IF(NSUM(I,3))270,260,270
  260 ID=ID+1
      NUMBER(ID)=I
  270 CONTINUE
      IF(ID)280,280,285
  285 WRITE (6,900)NJK
      IX=NUMBER(ID)
      J=0
      DO 295 I=1,NJ
      IF(I-IA)292,295,292
 292  J=J+1
      IPRNT(J)=NDATA(IX,I)
 295  CONTINUE
      WRITE (6,903)(IPRNT(I),I=1,NJK)
      IF(ID-1)450,450,455
  450 WRITE (6,913)
      GO TO 435
  455 WRITE (6,912)ID
  435 WRITE (6,904)(NUMBER(KK),KK=1,ID)
  280 IF(NPRINT-1)500,286,500
 286  WRITE (6,914)
      NJJ=NJK+1
      DO 2865 I=1,NJJ
 2865 NUMBER(I)=I
      IF(-IA)287,290,290
 287  WRITE (6,915)IA
      DO 2875 I=1,NJJ
      IF(I-IA)2875,2874,2874
 2874 NUMBER(I)=NUMBER(I+1)
 2875 CONTINUE
  290 WRITE (6,910)(NUMBER(I),I=1,NJK)
      WRITE (6,905)
      DO305I=1,N
      J=0
      DO 304 II=1,NJ
      IF(II-IA)303,304,303
 303  J=J+1
      IPRNT(J)=NDATA(I,II)
 304  CONTINUE
  305 WRITE (6,911)I,(IPRNT(J),J=1,NJK)
      GOTO500
C
  890 FORMAT(1H0//)
  900 FORMAT(1H0/25H NUMBER OF MISSING VALUESI5)
  901 FORMAT(16H NUMBER OF ITEMS I6)
  902 FORMAT(12H ITEM NUMBER14X,23I4,(/26X23I4))
  903 FORMAT(1H04X,15HPATTERN OF DATA8X,30I2)
  904 FORMAT(1H 4X,11HITEM NUMBER10X,23I4,(/26X23I4))
 905  FORMAT(1H )
 910  FORMAT(12H ITEM NUMBER10X15HVARIABLE NUMBER/16X30I3)
  911 FORMAT(1H 4X,I3,8X,30I3)
  912 FORMAT(1H 7X,I4,1X,5HITEMS)
  913 FORMAT(1H 10X,6H1 ITEM)
 914  FORMAT(1H115X27HDATA PATTERNS FOR ALL ITEMS)
 915  FORMAT(11H VARIABLE (I2,16H) IS ELIMINATED.//)
C
  500 RETURN
      END
C             SUBROUTINE TPWD FOR BMD10D              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
   17 REWIND NT2
   19 IF(NT1-5)18,24,18
 18   IF(NT1-6)22,40,22
 22   REWIND NT1
 24   NT2=NT1
 28   RETURN
 40   WRITE (6,49)
 49   FORMAT(25H ERROR ON TAPE ASSIGNMENT)
      STOP
      END