C BMDX94 - TRANSGENERATION - MAIN PROGRAM MARCH 26, 1968 DOUBLE PRECISION DATE(2),FIN,PROB,P,PC,PASS,PAS DIMENSION F1(162),F2(162),A(8000),LIST(1000),YX(1000) DIMENSION ADUM(1000),BDUM(1000) DIMENSION KHALI(16) DATA KHALI/16*0/ DATA DATE/' MAY 1, ','1969 '/ DATA PASS/8HPSDATA / DATA ONO,FIN,YES,PROB/2HNO,6HFINISH,3HYES,6HPROBLM/ DATA BLANK/' '/ LOGICAL BL INTEGER OT,OT1 KPNTR=0 CALL USAGEB('BMDX94') NPR=0 100 NPR=NPR+1 READ(5,1) P,PC,NC,NV,NVA,NF1,IT,NF2,OT,ON1,ON2,EAN1,EAN2,VSL,PRNT, XBLK,NPASS,NGEN 1 FORMAT(2A6,3I6,4I3,2A2,5A3,3X,2I3) SAME=ONO IPASS=0 NPASS=NPASS+1 NCHECK=NPASS NVR=NV INDTEM=1 NF4=NF2 LL=1 IF(IT.EQ.0) IT=5 IF(IT.EQ.5) ON1=ONO IF(P.EQ.FIN) GO TO 8001 IF(P.NE.PROB) GO TO 181 NFB1=0 NFB2=0 IF(NF1.LT.0)NFB1=-1 NF1=18*MAX0(1,NF1) IF(ON1.NE.ONO) REWIND IT IF(NFB1.EQ.0)READ(5,10)(F1(I),I=1,NF1) 10 FORMAT(18A4) IF(ON1.NE.ONO) ON1=YES IF(EAN1.NE.YES) EAN1=ONO IF(EAN2.NE.YES) EAN2=ONO IF(VSL.NE.YES) VSL=ONO IF(PRNT.NE.YES) PRNT=ONO IF(BLK.NE.YES) BLK=ONO 301 IF(IPASS.EQ.0) GO TO 300 READ(5,900)PAS,NF3,OT,ON2,EAN1,EAN2,VSL,PRNT,NGEN 900 FORMAT(A6,30X,2I3,2X,A2,4A3,9X,I3) IF(PASS.NE.PAS) GO TO 400 IF(NF3.EQ.0.AND.OT.NE.0) SAME=YES IF(SAME.EQ.YES) NF3=NF4 NF2=NF3 NF4=NF2 300 CONTINUE IF(OT.EQ.6.OR.OT.EQ.0) ON2=ONO IF(ON2.NE.ONO) REWIND OT IF(ON2.NE.ONO) ON2=YES IF(IPASS.EQ.0) WRITE(6,2) DATE,PC,NC,NV,NVA,IT,OT,ON1,ON2 2 FORMAT(46H1BMDX94 - MULTI-PASS 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/) IF(EAN1.NE.YES) EAN1=ONO IF(EAN2.NE.YES) EAN2=ONO IF(VSL.NE.YES) VSL=ONO IF(PRNT.NE.YES.OR.OT.EQ.6) PRNT=ONO IF(BLK.NE.YES) BLK=ONO 303 IF(NF2.LT.0) NFB2=-1 NF2=18*MAX0(1,NF2) IF(NFB2.LT.0) GO TO 307 IF(IPASS.NE.0.AND.SAME.EQ.YES) GO TO 307 IF(OT.NE.0) READ(5,10) (F2(I),I=1,NF2) 307 IPASS=IPASS+1 WRITE(6,302) IPASS 302 FORMAT(1H1,45X,8(2H *),2X,'P A S S ',I3,2X,8(2H *) ,1X//) WRITE(6,304) EAN1,EAN2,VSL,PRNT,BLK 304 FORMAT(40H0MEANS AND STD. DEVS. USED ,A6/ X40H0GEOM. AND HARMO. MEANS USED ,A6/ X40H0VARIABLES ARE SELECTED ,A6/ X40H0SELECTIONS ARE PRINTED ,A6/ X40H0BLANKS ARE TREATED AS MISSING ,A6/) IF(IPASS.NE.1) WRITE(6,902) OT,ON2 902 FORMAT(19H0REWIND OUTPUT TAPE,3X,I2,17X,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.AND.IPASS.EQ.1) 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.AND.IPASS.EQ.1) WRITE(6,222) IF(NFB2.LT.0.AND.OT.NE.0) WRITE(6,203) 222 FORMAT(20H0INPUT IS BINARY ) 203 FORMAT(20H0OUTPUT IS BINARY ) C 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) L4=16*NVO+1 L17=13*NVO+1 L18=14*NVO+2 C C C C C IF(VSL.EQ.YES) GO TO 71 ITEM=NVR+NGEN DO 72 I=1,ITEM 72 LIST(I)=I 71 IF(IPASS-1) 326,325,326 325 JET=NV JY=NV GO TO 327 326 JET=ITEMPR JY=ITEM 327 L1=1+NVO L2=L1+JET L3=L2+JET L10=L3+JET L11=L10+JET IF(IPASS.EQ.1) GO TO 328 K12=L6+1 K11=L6-L1+1 DO 330 K=K12,L7 330 A(K-K11)=A(K) K12=L7+1 K11=L7-L2+1 DO 331 K=K12,L12 331 A(K-K11)=A(K) K12=L12+1 K11=L12-L10+1 DO 334 K=K12,L14 334 A(K-K11)=A(K) K12=L14+1 K1=L14+ITEMPR K11=L14-L11+1 DO 339 K=K12,K1 339 A(K-K11)=A(K) K12=L5+1 K11=L5-L3+1 DO 340 K=K12,L6 340 A(K-K11)=A(K) 328 L5=L11+JET -1 L6=L5+ITEM L7=L6+ITEM L12=L7+ITEM L14=L12+ITEM L15=L14+ITEM L16=L15+JY L8=L5+1 L9=L4-1 MXT=(8000-L4)/NVP-1 IF(MXT.LE.1) GO TO 188 KK1=L9 IF(IPASS.NE.1) KK1=L16+ITEM DO 42 J=L8,KK1 42 A(J)=0 999 IF(ITEM.GT.3000) GO TO 188 MMMMMM=0 IDELET=0 C IF(EAN1.EQ.EAN2) GO TO 500 IF(EAN1.EQ.YES) GO TO 501 IDELET=3 GO TO 502 500 IF(EAN1.NE.YES) GO TO 40 IDELET=1 GO TO 502 501 IDELET=2 502 CONTINUE IF(IPASS.NE.1) GO TO 40 LL=3 REWIND 1 M1=L15+1 M2=L16+1 M3=L17+1 M4=L18+1 CALL PASS1(A,A(L1),A(L2),A(L3),A(L10),A(L11),A(M1),A(M2),A(M3),A(M 14),A(L4),NV,NC,IT,F1,MXT,BLK,NFB1,IDELET,NVP,NVR,INDTEM) REWIND 1 C IF(NCHECK.EQ.1.OR.ITEM.GT.NV) L16=L15+ITEM 40 IF(NCHECK.EQ.IPASS) IDELET=1 M3=L17+1 M4=L18+1 IF(INDTEM.EQ.1)INDKOL=2 IF(INDTEM.EQ.2) INDKOL=1 DO 41 J=1,NC SELECT=1. CALL READ (A,A(L4),IT,F1,NV,J,LL,MXT,NFB1,NVP,NVR,INDTEM) LLL=NVR+NGEN LOW=NVR+1 IF(LOW.GT.LLL) GO TO 256 DO 2000 KZ11= LOW,LLL 2000 A(KZ11)=BLANK 256 CONTINUE CALL TRANS 1 (A,A(L1),A(L2),A(L3),A(L10),A(L11),A(M3),J,NVR,NPR, 2IPASS,SELECT) KKK=1 KTEST=(J-1)*NVP IF(J.GT.MXT) GO TO 1051 DO 1050 MMM=KKK,LLL 1050 A(L4+MMM+KTEST-1)=A(MMM) GO TO 1052 1051 WRITE(INDKOL)(A(NNN),NNN=KKK,LLL) 8000 FORMAT(20A4) 1052 IF(SELECT.EQ.0.AND.OT.EQ.6) WRITE(6,213) J 213 FORMAT(1H0,'CASE NO. ',I7,'IS NOT SELECTED IN THIS PASS BUT PRINTE 1D BELOW.') IF(SELECT.NE.0.0.OR.OT.EQ.6) MMMMMM=MMMMMM+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(OT.NE.0.AND.OT.NE.6.AND.NFB2.EQ.0) WRITE(OT,F2)(YX(I),I=1,ITEM) IF(NFB2.LT.0.AND.OT.NE.6)WRITE(OT )(YX(I),I=1,ITEM) 1082 IF(PRNT.EQ.YES) WRITE(6,200) J,MMMMMM,(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 1059 IF(BL(YX(I))) GO TO 141 1059 IF(IDELET.EQ.0) GO TO 41 IF(IDELET.EQ.3) GO TO 611 A(L5+I)=A(L5+I)+1.0 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 IF(A(L5+I).EQ.1.0) ADUM(I)=YX(I) IF(A(L5+I).EQ.1.0) BDUM(I)=YX(I) ADUM(I)=AMIN1(ADUM(I),YX(I)) BDUM(I)=AMAX1(BDUM(I),YX(I)) IF(IDELET.EQ.2) GO TO 141 611 IF(YX(I))622,622,623 623 A(L15+I)=A(L15+I)+1.0 D=(ALOG(YX(I))-A(L12+I))/(A(L15+I)) A(L12+I)=A(L12+I)+D 621 A(L16+I)=A(L16+I)+1.0 A(L14+I)=A(L14+I)+(1.0/YX(I)) 622 CONTINUE 141 CONTINUE 41 CONTINUE DO 44 I=1,ITEM IF(A(L15+I).GT.0.)A(L12+I)=EXP(A(L12+I)) IF(A(L15+I).GT.0.0)A(L14+I)=A(L15+I)/A(L14+I) IF(A(L5+I).LE.1) GO TO 44 A(L7+I)=SQRT(A(L7+I)/(A(L5+I)-1.)) 44 CONTINUE IF(IDELET.EQ.0) GO TO 625 GO TO (626,626,627),IDELET 626 WRITE(6,57) 57 FORMAT( 65H1 VARIABLE INDEX COUNT OF MEAN STANDARD DE 1VIATION ,3X,11HMAX. VALUES,4X,11HMIN. VALUES/ 2 34H NEW OLD CASES USED ) 56 FORMAT(I5,6X,I5,8X,F4.0,5X,F10.4,8X,F10.4,5X,F10.4,5X,F10.4) WRITE(6,56)(I,LIST(I),A(L5+I),A(L6+I),A(L7+I),BDUM(I),ADUM(I),I=1, 1ITEM) WRITE(6,1071) 1071 FORMAT(1H0,3X////) IF(IDELET.EQ.2) GO TO 625 627 WRITE(6,59) 59 FORMAT( 74H0 VARIABLE INDEX COUNT OF GEOM. MEAN HARM X. MEAN ,1X/61H NEW OLD CASES USED X /) WRITE(6,61) (I,LIST(I),A(L15+I),A(L12+I),A(L14+I),I=1,ITEM) C 61 FORMAT(I5,6X,I5,7X,F5.0,5X,F10.4,7X,F10.4) 625 IF(OT.NE.0) WRITE(6,55) MMMMMM,OT 55 FORMAT(1H0,I5,27H CASES WERE WRITTEN ON TAPEI3) LL=3 ITEMPR=ITEM NPASS=NPASS-1 IF(((OT-6)*OT).NE.0) ENDFILE OT K12=L15+1 K11=L15+ITEM K1=M3-L15-1 DO 1003 K=K12,K11 ADUM(K-L15)=0.0 BDUM(K-L15)=0.0 1003 A(K+K1)=A(K) C KPNTR=KPNTR+1 IF(KPNTR.LE.16) KHALI(KPNTR)=MMMMMM C 8002 FORMAT(16I5) IF(NPASS.EQ.0) GO TO 100 DO 1010 K=M3,L9 1010 A(K)=0.0 K12=L16+1 K11=L16+ITEM K1=M4-L16-1 DO 1004 K=K12,K11 1004 A(K+K1)=A(K) NVR=NVR+NGEN INDTEM=INDKOL REWIND 1 REWIND 2 NFB2=0 SAME=ONO GO TO 301 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 400 WRITE(6,401) PAS 401 FORMAT(1H0,5X,'THE PROGRAM EXPECTED PSDATA CARD',3X/ X1H0,'WHEREAS IT FOUND',A6,'PLEASE CHECK THE CONTROL CARDS') STOP 8001 WRITE(1,8002) (KHALI(IZ),IZ=1,16) STOP END SUBROUTINE PASS1(X,U,S,C,GM,HM,GC,HC,GS,HS,T,NV,NC,IT,F,MXT,BLK, XNFB1,ID,NVP,NVR,INDTEM) DIMENSION GS(2),HS(2) DIMENSION HM(2),GM(2),GC(2),HC(2) 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 GC(I)=0.0 HC(I)=0.0 U(I)=0. C(I)=0. HM(I)=0.0 GM(I)=0.0 1 S(I)=0. DO 3 J=1,NC CALL READ(X,T,IT,F,NV,J,2,MXT,NFB1,NVP,NVR,INDTEM) 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) GO TO (11,11,31),ID 11 H1=H*(H-1.) D=(X(I)-U(I))/H U(I)=U(I)+D S(I)=S(I)+D*D*H1 IF(ID.EQ.2) GO TO 3 31 IF(X(I)) 622,622,623 623 GC(I)=GC(I)+1.0 D=(ALOG(X(I))-GM(I))/GC(I) GM(I)=GM(I)+D 621 HC(I)=HC(I)+1.0 HM(I)=HM(I)+(1.0/X(I)) 622 CONTINUE 3 CONTINUE DO 5 I=1,NV IF(ID.EQ.2) GO TO 5 GM(I)=EXP(GM(I)) IF (HM(I).NE.0.0) HM(I)=GC(I)/HM(I) GS(I)=GC(I) HS(I)=HC(I) GC(I)=0.0 HC(I)=0.0 5 S(I)=SQRT(S(I)/(C(I)-1.)) RETURN END C SUBROUTINE READ FOR BMDX94 JANUARY 15, 1966 SUBROUTINE READ(X,T,IT,F,NV,I,LL,MXT,NFB1,NVP,NVR,INDTEM) DIMENSION T(NVP,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,NVR 4 T(J,I)=X(J) RETURN 3 WRITE(1) (X(J),J=1,NVR) RETURN 2 IF(I.GT.MXT) GO TO 5 DO 6 J=1,NVR 6 X(J)=T(J,I) RETURN 5 READ(INDTEM) (X(J),J=1,NVR) 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 CHECK,CHCK DATA CHCK /8HVARSEL / DATA NINE,IPERD,IBLANK,MINUS,KOMMA,ISLASH/1H9,1H.,1H ,1H-,1H,,1H// 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) CHECK,(IN(KOL),KOL=1,72) 100 FORMAT(A6,72A1) IF(CHECK.NE.CHCK) GO TO 51 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 51 ITEM=9999 WRITE(6,52) 52 FORMAT(73H0THE PROGRAM DIDNOT FIND VARSEL CARD AS EXPECTED.PLEASE 1CHECK DECK SET UP) RETURN END SUBROUTINE TRANS(X,U,S,C,GMN,HMN,GMC,NC,NVR,NPR,NPS, 1SELECT) DIMENSION X(NVR),U(NVR),S(NVR),GMN(NVR),HMN(NVR),GMC(NVR) DIMENSION C(NVR) LOGICAL BL C C THE FOLLOWING CARDS ARE USED WITH THE HSCF TEST DECK, C THEY ARE NORMALLY SUPPLIED BY THE USER. C C FIRST, IF ANY VARIABLE IS BLANK WE SUBSTITUTE THE MEAN OF THAT VARIA DO 1 I=1,NVR IF (BL(X(I))) X(I)=U(I) 1 CONTINUE C VARIABLE 6 IS VARIABLE 1 TIMES THE INVERSE OF VARIABLE 2 X(6)=X(1)*(1./X(2)) C VARIABLE 7 IS THE STANDARD SCORE FOR VARIBLE 3, AND THE CASE IS PRIN C IF IT IS OUTSIDE 4 STANDARD DEVIATIONS FROM THE0MEAN. X(7)=(X(3)-U(3))/S(3) IF (ABS(X(7)).GT.4.) PRINT 3,NC,(X(I),I=1,NVR) 3 FORMAT (' CASE NO.=',I5,' A VALUE OF X(7) WAS MORE THAN FOUR STAND 1ARD DEVIATIONS OUT'/7F12.3) RETURN END