C             DESCRIPTION OF STRATA                   JUNE 22, 1966
C        THIS IS A SIFTED VERSION OF BMD06D ORIGINALLY WRITTEN IN
C        FORTRAN II. SOME MODIFICATIONS WERE MADE TO MAKE IT OPERABLE
C        AND SLIGHTLY MORE EFFICIENT THAN THE SIFTED VERSION.
      DOUBLE PRECISION A1,A2,A3,FINISH,PROBLM
      DIMENSION X(400,25),SCALE(30),NCO(29),XMEAN(30),XINT(22),VAR(30),
     1STD(30),SUM(30),SQ(30),STE(30),R(30,30),CD(30,30),NT(30),TD(30),
     2FMT(180)
C
      DATA PROBLM,FINISH,A2,A3/6HPROBLM,6HFINISH,6HSELECT,6HINTRVL/
C
      NTAPE=5
	CALL USAGEB('BMD06D')
      EXT=10000.0*10000.0*10000.0
C
 921  FORMAT (45H1BMD06D - DESCRIPTION OF STRATA - VERSION OF               
     118HJUNE 22, 1966     ,/
     241H HEALTH SCIENCES COMPUTING FACILITY, UCLA)
C
 5    READ (5,900)A1,PROB,NV,N,NVG,NJ,NS,MTAPE,KVR
      IF(A1.EQ.PROBLM)     GO TO 10
    6 IF(A1.EQ.FINISH)GO TO 200
      WRITE(6, 400) A1
 7    WRITE (6,922)
      GO TO 200
   10 CALL TPWD(MTAPE,NTAPE)
 19   WRITE (6,921)
      MV=NV+NJ
      WRITE (6,901)PROB,N,MV
      IF(KVR.GT.0.AND.KVR.LE.10)GO TO 20
      KVR=1
      WRITE(6,4000)
 20   KVR=KVR*18
      READ (5,919)(FMT(I), I=1,KVR)
      WRITE(6, 8000) (FMT(I), I=1,KVR)
 8000 FORMAT(' VARIABLE FORMAT CARD(S)'/1X,18A4)
      IF((N-2)*(N-701)) 205,500,500
  205 IF((NV-1)*(NV-31)) 207,501,501
  207 IF((MV-1)*(MV-31)) 21,502,502
  500 WRITE(6, 600)
      GO TO 7
  501 WRITE(6, 601)
      GO TO 7
  502 WRITE(6, 602)
      GO TO 7
 21   DO 23 I=1,N
 23   READ (NTAPE,FMT)(X(I,J), J=1,NV)
      IF(NVG)30,30,27
 27   CALL TRANZ  (X,NV,N,IERROR,NVG)
      NV=NV+NJ
      IF(IERROR)28,30,30
 28   DO 29 IJ=1,NS
      READ (5,904)A1,NC,NI,NN,(NCO(I),I=1,29)
      NB=NI+1
      L1=2
      IF(20-NI)281,282,282
 281  NI=20
 282  IF(11-NI)283,288,288
 283  L1=13
      READ (5,905)A1,(XINT(I),I=2,12)
 288  READ (5,905)A1,(XINT(I),I=L1,NB)
 29   CONTINUE
      GO TO 5
   30 DO 120 IJ=1,NS
      TEST=0.0
      WRITE (6,914)IJ
      READ (5,904)A1,NC,NI,NN,(NCO(I),I=1,29)
      IF(A1  .EQ.  A2)     GO TO 25
      WRITE(6, 401) A1
 24   WRITE (6,923)IJ
      TEST=-1.0
 25   NB=NI+1
      L1=2
      IF(20-NI)251,252,252
 251  NI=20
      WRITE(6, 402)
      GO TO 24
 252  IF(11-NI)253,258,258
 253  L1=13
      READ (5,905)A1,(XINT(I),I=2,12)
      IF(A1  .NE.  A3)     GO TO 26
 258  READ (5,905)A1,(XINT(I),I=L1,NB)
      IF(A1  .EQ.  A3)     GO TO 275
      WRITE(6, 403) A1
 26   WRITE (6,924)IJ
      GO TO 120
 275  IF(TEST)120,285,285
 285  ASSIGN 105 TO NNN
      NA=2
      ND=NI+2
      XINT(1)=-EXT
      XINT(ND)=EXT
 31   DO 100 IK=NA,NB
      IV=IK-1
      ON=0.0
      DO 32 I=1,NV
      SUM(I)=0.0
      SQ(I)=0.0
      DO 32 J=1,NV
 32   CD(I,J)=0.0
      NNP=NN+1
      DO 45 JK=1,N
      IF(X(JK,NC)-XINT(IK-1)) 45, 33, 33
 33   IF(X(JK,NC)-XINT(IK)) 35, 45, 45
 35   STD(1)=X(JK,NC)
      ON=ON+1.0
      DO 37 I=1,NN
      L=I+1
      LL=NCO(I)
 37   STD(L)=X(JK,LL)
      DO 40 I=1,NNP
      SUM(I)=SUM(I)+STD(I)
      SQ(I)=SQ(I)+STD(I)*STD(I)
      DO 40 J=1,NNP
 40   CD(I,J)=CD(I,J)+STD(I)*STD(J)
 45   CONTINUE
      IF(ON-1.0) 60, 60, 46
 46   ONN=SQRT(ON)
      DO 50 I=1,NNP
      XMEAN(I)=SUM(I)/ON
      SCALE(I)=SQ(I)-((SUM(I)*SUM(I))/ON)
      IF(SCALE(I))47,48,48
C
C     SCALE(I) CANNOT BE NEGATIVE. IF IT IS IT IS JUST A ROUNDING ERROR.
C
 47   SCALE(I)=0.0
 48   VAR(I)=SCALE(I)/(ON-1.0)
      STD(I)=SQRT(VAR(I))
 50   STE(I)=STD(I)/ONN
      DO 55 I=1,NNP
      DO 55 J=1,NNP
      R(I,J)=CD(I,J)-((SUM(I)*SUM(J))/ON)
      IF(SCALE(I)*SCALE(J))1000,1000,53
 1000 R(I,J)=999.99
      GO TO 55
   53 R(I,J)=R(I,J)/SQRT(SCALE(I)*SCALE(J))
   55 CONTINUE
 60   IF(IK-2) 62, 62, 70
 62   WRITE (6,906)IV,XINT(2)
 65   IF(ON-1.0)66,166,90
 166  WRITE (6,920)
      WRITE (6,911)
      LL=ON
      WRITE (6,913)NC,LL,SUM(1)
      WRITE (6,912)
      DO 170 I=1,NN
      L=I+1
 170  WRITE (6,913)NCO(I),LL,SUM(L)
      GO TO 100
 66   MM=ON
      WRITE (6,907)MM
      GO TO 100
 70   IF(IK-ND) 75, 80, 80
 75   WRITE (6,915)
      WRITE (6,908)IV,XINT(IV),XINT(IK)
      GO TO 65
 80   WRITE (6,915)
      WRITE (6,909)IV,XINT(IV)
      GO TO 65
 90   WRITE (6,910)
      WRITE (6,911)
      LL=ON
      WRITE (6,913)NC,LL,XMEAN(1),VAR(1),STD(1),STE(1)
      WRITE (6,912)
      DO 95 I=1,NN
      L=I+1
 95   WRITE (6,913)NCO(I),LL,XMEAN(L),VAR(L),STD(L),STE(L)
      WRITE (6,916)
      WRITE (6,917)NC
      WRITE (6,918)(R(1,J),J=1,NNP)
      DO 97 I=2,NNP
      II=I-1
      WRITE (6,917)NCO(II)
 97   WRITE (6,918)(R(I,J),J=1,NNP)
 100  CONTINUE
      GO TO NNN, (105, 110)
 105  ASSIGN 110 TO NNN
      NA=ND
      NB=ND
      GO TO 31
 110  CONTINUE
 120  CONTINUE
      GO TO 5
C
  400 FORMAT(' PROGRAM EXPECTED PROBLM OR FINISH CARD INSTEAD READ THE
     1 FOLLOWING'/1X,A6)
  401 FORMAT(' PROGRAM EXPECTED SELECT CARD INSTEAD READ THE FOLLOWING'/
     11X,A6)
  402 FORMAT(' NUMBER OF CONSTANTS USED TO DEFINE INTERVALS CANNOT EXCEE
     1D 20')
  403 FORMAT(' PROGRAM EXPECTED INTRVL CARD INSTEAD READ THE FOLLOWING'/
     11X,A6)
  600 FORMAT(' NUMBER OF CASES INCORRECTLY SPECIFIED')
  601 FORMAT(' NUMBER OF VARIABLES INCORRECTLY SPECIFIED')
  602 FORMAT(' NUMBER OF VARIABLES AFTER TRANSGENERATION CANNOT EXCEED 3
     10')
 900  FORMAT(A6,A2,I2,I3,4I2,49X,I2)
 901  FORMAT(14H0PROBLEM NO.  A2/12H SAMPLE SIZEI4/20H NUMBER OF VARIABL
     1ESI4)
 904  FORMAT(A6,32I2)
 905  FORMAT(A6,11F6.0)
 906  FORMAT(9H0INTERVALI3,8H  (BELOWF10.2,1H))
 907  FORMAT(30H0FREQUENCY IN THIS INTERVAL ISI4)
 908  FORMAT(9H0INTERVALI3,24H  (EQUAL OR GREATER THANF10.2,15H  BUT LES
     1S THANF10.2,1H))
 909  FORMAT(9H0INTERVALI3,24H  (EQUAL OR GREATER THANF10.2,1H))
 910  FORMAT(95H0                           FREQUENCY      MEAN          
     1VARIANCE       STD. DEV.     STD. ERROR)
 911  FORMAT(22H CONDITIONING VARIABLE)
 912  FORMAT(22H CONDITIONED VARIABLES)
 913  FORMAT(5X,I6,15X,I7,F17.5,3F15.5)
 914  FORMAT(1H0////10H SELECTIONI4//)
 915  FORMAT(1H0)
 916  FORMAT(25H0CORRELATION COEFFICIENTS)
 917  FORMAT(9H0VARIABLEI3)
 918  FORMAT(10F12.5)
 919  FORMAT(18A4)
 920  FORMAT(1H027X,11HSINGLE CASE5X,5HVALUE)
 922  FORMAT(22H0ERROR ON PROBLEM CARD)
 923  FORMAT(24H0ERROR ON SELECTION CARDI4)
 924  FORMAT(23H0ERROR ON INTERVAL CARDI4)
 4000 FORMAT(1H023X71HNUMBER OF VARIABLE FORMAT CARDS INCORRECTLY SPECIF
     1IED, ASSUMED TO BE 1.)
C
 200  IF(NTAPE-5)202,202,201
  201 REWIND NTAPE
  202 STOP
      END
C        SUBROUTINE TPWD FOR BMD06D                   JUNE 22, 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
C             SUBROUTINE TRANZ FOR BMD06D             JUNE 22, 1966
      SUBROUTINE TRANZ (DATA,NVAR,NSAM,IERROR,NVG)
      DOUBLE PRECISION A1,A2
      DIMENSION DATA(400,25)
      ASN(XX)=ATAN(XX/SQRT(1.0-XX**2))
      DATA A2/6HTRNGEN/
      MARY=0
      FN=NSAM
      WRITE (6,1403)
      WRITE (6,1400)
      IERROR=0
      DO1000 J=1,NVG
      READ (5,1100)A1,NEWA,LCODE,LVA,BNEW
      IF(A1  .EQ.  A2)     GO TO 2
      WRITE(6, 400) A1
    1 WRITE (6,1406)J
      IERROR=-999
    2 IF(IERROR)1000,6,6
    6 WRITE (6,1402)J,NEWA,LCODE,LVA,BNEW
      IF(LCODE-11)4,5,5
    5 NEWB=BNEW
    4 DO 300 I=1,NSAM
      D=DATA(I,LVA)
      IF(LCODE*(LCODE-15)) 200,500,500
  500 WRITE(6, 600)
      GO TO 1
 200  GOTO(10,20,30,40,50,60,70,80,90,100,110,120,130,140),LCODE
   10 IF(D)99,7,8
    7 D1=0.0
      GO TO 3
    8 D1=SQRT(D)
      GO TO 3
   20 IF(D)99,11,12
   11 D1=1.0
      GO TO 3
   12 D1=SQRT(D)+SQRT(D+1.0)
      GO TO 3
   30 IF(-D)14,99,99
   14 D1=ALOG10(D)
      GO TO 3
   40 D1=EXP(D)
      GO TO 3
   50 IF(-D)17,7,99
   17 IF(D-1.0)18,19,99
   18 D1=ASN(SQRT(D))
      GO TO 3
   19 D1=3.14159265/2.0
      GO TO 3
   60 A=D/(FN+1.0)
      B=A+1.0/(FN+1.0)
      IF(A)99,23,24
   23 IF(-B)27,7,99
   27 D1=ASN(SQRT(B))
      GO TO 3
   24 IF(B)99,28,29
   28 D1=ASN(SQRT(A))
      GO TO 3
   29 D1=ASN(SQRT(A))+ASN(SQRT(B))
      GO TO 3
   70 IF(D)31,99,31
   31 D1=1.0/D
      GO TO 3
   80 D1=D+BNEW
      GO TO 3
   90 D1=D*BNEW
      GO TO 3
  100 IF(D)33, 7,33
   33 D1=D**BNEW
      GO TO 3
  110 D1=D+DATA(I,NEWB)
      GO TO 3
  120 D1=D-DATA(I,NEWB)
      GO TO 3
  130 D1=D*DATA(I,NEWB)
      GO TO 3
  140 IF(DATA(I,NEWB))34,99,34
   34 D1=D/DATA(I,NEWB)
      GO TO 3
   99 IF(MARY)43,44,44
   44 MARY=-999
      IERROR=-999
      WRITE (6,1404)J
   43 WRITE (6,1405)I
      GO TO 300
    3 DATA(I,NEWA)=D1
  300 CONTINUE
 1000 CONTINUE
      IF(IERROR)42,1111,1111
   42 WRITE (6,1401)
  400 FORMAT(' PROGRAM EXPECTED TRNGEN CARD INSTEAD READ THE FOLLOWING'/
     11X,A6)
  600 FORMAT(' ONLY CODES 01 THROUGH 14 OF THE TRANSGENERATION LIST MAY
     1 BE USED')
 1100 FORMAT(A6,I3,I2,I3,F6.0)
 1400 FORMAT(46H0CARD    NEW     TRANS    ORIG.   ORIG. VAR(B)/45H  NO.   
     1VARIABLE   CODE    VAR(A)   OR CONSTANT)
 1401 FORMAT(41H0PROGRAM CANNOT CONTINUE FOR THIS PROBLEM)
 1402 FORMAT(2H  I2,I8,2I9,4X,F10.5)
 1403 FORMAT(1H06X,23HTRANS GENERATOR CARD(S))
 1404 FORMAT(55H0THE INSTRUCTIONS INDICATED ON TRANS GENERATOR CARD NO.I
     12,1X,3HRE-/60H SULTED IN THE VIOLATION OF A RESTRICTION FOR THIS T
     2RANSFOR-/59H MATION. THE VIOLATION OCCURRED FOR THE ITEMS LISTED B
     3ELOW.)
 1405 FORMAT(10H ITEM NO. I5)
 1406 FORMAT(34H0ERROR ON TRANSGENERATION CARD NO.I4)
 1111 RETURN
      END









