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