Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-09 - 43,50466/bmdx77.f4
There are no other files named bmdx77.f4 in the archive.
C        BMDX77 - TRANSGENERATION - MAIN PROGRAM    APRIL ,   1967
      DOUBLE PRECISION DATE(2),FIN,PROB,P,PC
      DIMENSION F1(162),F2(162),A(8000),LIST(3000),YX(3000)
      DIMENSION KHALI(16)
      DATA DATE/'APRIL 14',', 1969  '/
      DATA KHALI/16*0/
      DATA ONO,FIN,YES,PROB/2HNO,6HFINISH,3HYES,6HPROBLM/
      LOGICAL BL
      INTEGER OT,OT1
      KPNTM=0
	CALL USAGEB('BMDX77')
      NPR=0
      OT1=0
 100  NPR=NPR+1
      READ (5,1) P,PC,NC,NV,NVA,IT,OT,NF1,NF2,ON1,ON2,PRNT,EAN,VSL,BLK
 1    FORMAT(2A6,7I6,4X,A2,4X,A2,4A3)
      IF(IT.EQ.0) IT=5
C
      IF(IT.EQ.5) ON1=ONO
      IF(OT.EQ.0.OR.OT.EQ.6) ON2=ONO
      IF(OT1.EQ.0) GO TO 437
      IF(OT.NE.OT1 .AND. NPR.GT.1 .AND. OT1.NE.6) GO TO 436
       GO TO 437
  436 ENDFILE  OT1
       REWIND OT1
  437  OT1=OT
      IF(P.EQ.FIN) GO TO 1000
      IF(P.NE.PROB) GO TO 181
      NFB1=0
      NFB2=0
      IF(NF1.LT.0)NFB1=-1
      IF(NF2.LT.0)NFB2=-1
      NF1=18*MAX0(1,NF1)
      NF2=18*MAX0(1,NF2)
      IF(ON1.NE.ONO) REWIND IT
      IF(ON2.NE.ONO) REWIND OT
8765  FORMAT(I)
      IF(NFB1.EQ.0)READ(5,10)(F1(I),I=1,NF1)
      IF(NFB2.EQ.0.AND.OT.NE.0) READ(5,10) (F2(I),I=1,NF2)
10    FORMAT(18A4)
      IF(EAN.NE.YES) EAN=ONO
      IF(BLK.NE.YES) BLK=ONO
      IF(ON1.NE.ONO) ON1=YES
      IF(ON2.NE.ONO) ON2=YES
      IF(PRNT.NE.YES.OR.OT.EQ.6) PRNT=ONO
      IF(VSL.NE.YES) VSL=ONO
      WRITE(6,2) DATE,PC,NC,NV,NVA,IT,OT,ON1,ON2,PRNT
 2    FORMAT(37H1BMDX77 - TRANSGENERATION - REVISED  ,2A8/
     X41H0HEALTH SCIENCES COMPUTING FACILITY, UCLA//
     X31H0PROBLEM CODE                            A6/
     X31H0NUMBER OF CASES                         I6/
     X31H0NUMBER OF VARIABLES READ IN             I6/
     X31H0NUMBER OF VARIABLES ADDED               I6/
     X31H0INPUT TAPE NUMBER                       I6/
     X31H0OUTPUT TAPE NUMBER                      I6/
     X34H0REWIND INPUT TAPE                       A6/
     X34H0REWIND OUTPUT TAPE                     A6/
     X34H0PRINT SELECTIONS                   A6)
      WRITE (6,8) EAN,VSL,BLK
 8    FORMAT(34H0MEANS AND S. DEVS. USED          A6/
     X34H0VARIABLES ARE SELECTED                 A6/
     X34H0BLANKS TREATED AS MISSING               A6)
      IF(VSL.NE.YES)GO TO 70
      CALL VARSEL(LIST,ITEM)
      IF(ITEM.EQ.9999) STOP
      WRITE(6,201)ITEM
  201 FORMAT(14H0THE FOLLOWING I5, 25H VARIABLES ARE SELECTED        /)
       WRITE(6,202)(I,LIST(I),I=1,ITEM)
  202 FORMAT(10(2H (I3,2H) I3,3H,   ))
   70 CONTINUE
      IF(NFB1.EQ.0)WRITE(6,22)(F1(I),I=1,NF1)
      IF(NFB2.EQ.0.AND.OT.NE.0)WRITE(6,3)  (F2(I),I=1,NF2)
22    FORMAT(31H0INPUT FORMAT                    18A4/(31X,18A4))
3     FORMAT(31H0OUTPUT FORMAT                   18A4/(31X,18A4))
      IF(NFB1.LT.0)WRITE(6,222)
      IF(NFB2.LT.0)WRITE(6,203)
  222 FORMAT(20H0INPUT IS BINARY         )
  203 FORMAT(20H0OUTPUT IS BINARY             )
      IF(PRNT.EQ.YES)WRITE(6,211)
  211 FORMAT(40H1SELECTED CASES AND VARIABLES PRINTED             )
      IF(OT.EQ.6) WRITE(6,212)
 212  FORMAT(1H0,'ALL CASES FOR SELECTED VARIABLES ARE PRINTED')
      NVP=NV+NVA
      NVO=MAX0(NV,NVP)
      L1=1+NVO
C
C
C
C
C
      IF(VSL.EQ.YES) GO TO 71
      DO 72 I=1,NVP
   72 LIST(I)=I
      ITEM=NVP
 71   L2=L1+NV
      L3=L2+NV
      L5=L3+NV-1
      L6=L5+ITEM
      L7=L6+ITEM
      L4=L7+ITEM+1
      MXT=(8000-L4)/NVP-1
      L8=L5+1
      L9=L4-1
      IF(MXT.LE.1) GO TO 188
8766  FORMAT(' ',12A5)
      DO  42 J=L8,L9
 42   A(J)=0
      IF(ITEM.GT.3000) GO TO 188
      MMM=0
      LL=1
C
8002  FORMAT(16I5)
      IF(EAN.NE.YES) GO TO 40
      LL=3
      REWIND 1
      CALL PASS1(A,A(L1),A(L2),A(L3),A(L4),NV,NC,IT,F1,MXT,BLK,NFB1)
      REWIND 1
C
 40   DO 41 J=1,NC
      SELECT=1.
      CALL READ (A,A(L4),IT,F1,NV,J,LL,MXT,NFB1)
      CALL TRANS(A,A(L1),A(L2),A(L3),J,NPR,NVO,SELECT)
 213  FORMAT(1H0,'CASE NO. ',I7,' IS NOT SELECTED IN THIS PASS,BUT PRINT
     XED BELOW')
      IF(SELECT.EQ.0.AND.OT.EQ.6) WRITE(6,213) J
      IF(SELECT.NE.0.0.OR.OT.EQ.6) MMM=MMM+1
      DO 60 I=1,ITEM
      II=LIST(I)
   60 YX(I)=A(II)
      IF(OT.EQ.6) WRITE(6,F2) (YX(I),I=1,ITEM)
      IF(SELECT.EQ.0) GO TO 41
      IF(NFB2.EQ.0.AND.OT.NE.0.AND.OT.NE.6) WRITE(OT,F2)(YX(I),I=1,ITEM)
      IF(NFB2.LT.0.AND.OT.NE.6)WRITE(OT   )(YX(I),I=1,ITEM)
      IF(PRNT.EQ.YES)WRITE(6,200)J,MMM,(YX(I),I=1,ITEM)
  200 FORMAT(16H0INPUT CASE NO.   I6,18H, OUTPUT CASE NO.   I6/(1X,10F12
     1.4))
      DO 141 I=1,ITEM
      IF(BLK.NE.YES) GO TO 666
      IF(BL(YX(I))) GO TO 141
 666  A(L5+I)=A(L5+I)+1
      H=A(L5+I)
      H1=H*(H-1.)
      D=(YX(I)-A(L6+I))/H
      A(L6+I)=A(L6+I)+D
      A(L7+I)=A(L7+I)+D*D*H1
 141  CONTINUE
 41   CONTINUE
      DO 44 I=1,ITEM
      IF(A(L5+I).LE.1) GO TO 44
      A(L7+I)=SQRT(A(L7+I)/(A(L5+I)-1.))
 44   CONTINUE
      WRITE(6,57)
 57   FORMAT( 65H1 VARIABLE INDEX     COUNT OF       MEAN    STANDARD DE
     1VIATION        /34H  NEW        OLD     CASES USED    /)
 56   FORMAT(I5,6X,I5,8X,F4.0,5X,F10.4,8X,F10.4)
      WRITE(6,56)(I,LIST(I),A(L5+I),A(L6+I),A(L7+I),I=1,ITEM)
      IF(OT.NE.0) WRITE(6,55) MMM,OT
 55   FORMAT(1H0,I5,27H CASES WERE WRITTEN ON TAPEI3)
      KPNTM=KPNTM+1
      IF(KPNTM.LE.16) KHALI(KPNTM)=MMM
      REWIND 1
C
C
      GO TO 100
 181  WRITE (6,182)
182   FORMAT(45H0PROBLEM CARD  INCORRECTLY ORDERED OR PUNCHED)
      STOP
 188  WRITE (6,199)
 199  FORMAT(26H0THIS PROBLEM IS TOO LARGE)
      STOP
 1000 WRITE(1,8002) (KHALI(J),J=1,16)
      STOP
      END
C        SUBROUTINE PASS1 FOR BMDX77               JANUARY 15, 1966
      SUBROUTINE PASS1(X,U,S,C,T,NV,NC,IT,F,MXT,BLK,NFB1)
      DIMENSION X(2),U(2),S(2),C(2),T(NV,2),F(162)
      LOGICAL BL
C
      DATA YES/3HYES/
      DO 1 I=1,NV
      U(I)=0.
      C(I)=0.
 1    S(I)=0.
8765  FORMAT(G)
      DO 3 J=1,NC
8766  FORMAT(' ',12A4)
      CALL READ(X,T,IT,F,NV,J,2,MXT,NFB1)
      DO 3 I=1,NV
      IF(BLK.NE.YES) GO TO 4
      IF(BL(X(I))) GO TO 3
 4    C(I)=C(I)+1.
      H=C(I)
      H1=H*(H-1.)
      D=(X(I)-U(I))/H
      U(I)=U(I)+D
      S(I)=S(I)+D*D*H1
 3    CONTINUE
      DO 5 I=1,NV
 5    S(I)=SQRT(S(I)/(C(I)-1.))
      RETURN
      END
C        SUBROUTINE READ FOR BMDX77                JANUARY 15, 1966
      SUBROUTINE READ(X,T,IT,F,NV,I,LL,MXT,NFB1)
      DIMENSION T(NV,2),X(2),F(162)
      GO TO (1,1,2),LL
    1 IF(NFB1.EQ.0) READ(IT,F)(X(J),J=1,NV)
      IF(NFB1.LT.0) READ(IT  )(X(J),J=1,NV)
      IF(LL.EQ.1) RETURN
      IF(I.GT.MXT) GO TO 3
      DO 4 J=1,NV
 4    T(J,I)=X(J)
      RETURN
 3    WRITE(1)(X(J),J=1,NV)
      RETURN
 2    IF(I.GT.MXT) GO TO 5
      DO 6 J=1,NV
 6    X(J)=T(J,I)
      RETURN
 5    READ(1)(X(J),J=1,NV)
 8000 FORMAT(20A4)
      RETURN
      END
      LOGICAL FUNCTION BL(X)
      EXTERNAL SIGN
      BL=.FALSE.
      IF(X.EQ.0.0.AND.SIGN(1.,X).NE.1.) BL=.TRUE.
      RETURN
      END
      SUBROUTINE VARSEL(LIST,ITEM)
      DIMENSION LIST(1000)
      DIMENSION IN(72),K(10)
      DOUBLE PRECISION CHCK,CHK1
      DATA NINE,IPERD,IBLANK,MINUS,KOMMA,ISLASH/1H9,1H.,1H ,1H-,1H,,1H//
      DATA CHCK/8HVARSEL  /
      DATA     K/'0','1','2','3','4','5','6','7','8','9'/
      ITEM =0
C----   LIST IS THE NAME OF THE ARRAY OF VARIABLE NUMBERS.
C----   ITEM IS THE NUMBER OF VARIABLES SELECTED. (LESS THAN 1001)
      INC=1
      IEND=NINE
      NUMBER=0
      ISTEP=NINE
      IDASH=NINE
      LAST=KOMMA
 1    READ(5,100) CHK1,(IN(KOL),KOL=1,72)
 100  FORMAT(A6,72A1)
      IF(CHK1.NE.CHCK) GO TO 50
      DO 10 KOL=1,73
      IF(KOL.EQ.73) GO TO 1
      IF(IN(KOL).EQ.IBLANK) GO TO 10
      M=-1
      DO 201 I=1,10
      M=M+1
      IF(IN(KOL).EQ.K(I))GO TO 200
  201 CONTINUE
      GO TO 2
  200 IN(KOL)=M
      NUMBER=IN(KOL)+10*NUMBER
      LAST=NINE
      GO TO 10
    2 IF(IN(KOL).NE.KOMMA) GO TO 5
   21 IF(LAST.NE.NINE) GO TO 101
      IF(IDASH.EQ.MINUS) GO TO 3
      IDASH = NINE
      ITEM=ITEM+1
      LIST(ITEM)=NUMBER
      LAST=KOMMA
      NUMBER=0
      IF(IEND.EQ.IPERD) RETURN
      GO TO 10
    3 IF(ISTEP.NE.ISLASH) GO TO 30
      INC=NUMBER
      ISTEP=NINE
      GO TO 31
   30 NLAST=NUMBER
      NLAST=NUMBER
   31 IF(NFIRST.GT.NLAST) GO TO 102
      IDASH = NINE
      DO 4 I=NFIRST,NLAST,INC
      ITEM=ITEM+1
    4 LIST(ITEM)=I
      LAST=KOMMA
      NUMBER=0
      INC=1
      IF(IEND.EQ.IPERD) RETURN
      GO TO 10
    5 IF(IN(KOL).NE.MINUS) GO TO 6
      IF(LAST.NE.NINE) GO TO 103
      NFIRST=NUMBER
      IDASH=MINUS
      LAST=MINUS
      NUMBER=0
      GO TO 10
    6 IF(IN(KOL).NE. IPERD) GO TO 7
      IEND=IPERD
      GO TO 21
    7 IF(IN(KOL).NE.ISLASH) GO TO 104
      IF(LAST.NE.NINE) GO TO 105
      IF(IDASH.NE.MINUS) GO TO 106
      ISTEP=ISLASH
      LAST=ISLASH
      NLAST=NUMBER
      NUMBER=0
   10 CONTINUE
  101 WRITE(6,1001) KOL
 1001 FORMAT(18H THE COMMA IN COL. ,I3, 27H MUST BE PRECEEDED BY A NO.)
      RETURN
  102 WRITE(6,1002) KOL
 1002 FORMAT(25H THE FIELD ENDING IN COL. ,I3,22H HAS NUMBERS REVERSED.)
      RETURN
  103 WRITE(6,1003) KOL
 1003 FORMAT(17H THE DASH IN COL. ,I3,27H MUST BE PRECEEDED BY A NO. )
      RETURN
  104 WRITE(6,1004) IN(KOL),KOL
 1004 FORMAT(16H THE CHARACTER ' ,A1,9H' IN COL. ,I3,12H IS ILLEGAL.  )
      RETURN
  105 WRITE(6,1005)
 1005 FORMAT(40H / MUST BE ASSOCIATED WITH N-M/I FIELD.                )
      RETURN
  106 WRITE(6,1006)
 1006 FORMAT(40H / MUST BE PRECEEDED BY A NUMBER.                      )
      RETURN
 50   WRITE(6,51) CHK1
 51   FORMAT(1H0,'THE PROGRAM EXPECTED VARSEL CARD.INSTEAD IT FOUND',2X,
     XA6,'. PLEASE CHECK THE DECK SETUP.')
      ITEM=9999
      RETURN
      END
      SUBROUTINE TRANS(X,U,S,C,NC,NPR,NV,SELECT)
      DIMENSION X(NV),U(NV),S(NV),C(NV)
      LOGICAL BL
C
C