Google
 

Trailing-Edge - PDP-10 Archives - decus_20tap5_198111 - decus/20-0137/bmd/bmd01v.for
There is 1 other file named bmd01v.for in the archive. Click here to see a list.
C              ANALYSIS OF VARIANCE FOR ONE-WAY DESIGN JUNE 15, 1966
C        THIS IS A SIFTED VERSION OF BMD01V 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 PROBLM,CODE,FINISH,SAMSIZ,SPECTG,PROBNO
      DIMENSION  DATE(2), X(9000), NC(5000), FMT(180), FT(12),
     1 SDEV(12),XBAR(12),NUSE(20),LCODE(72),CONST(72),L1(8),D2(8)
      COMMON  X      , NCI    , NCUE   , FMT    , NTAPE  , LUMP
      COMMON  LCODE  , CONST  , NH     , FM     , NTG    , CASE
C
  200 FORMAT('1BMD01V - ANALYSIS OF VARIANCE FOR ONE-WAY DESIGN - REVISE
     1D JUNE 24, 1969'/
     341H HEALTH SCIENCES COMPUTING FACILITY, UCLA//)
C
      DATA YES,XNO,PROBLM,FINISH,SAMSIZ,SPECTG/3HYES,2HNO,6HPROBLM,
     16HFINISH,6HSAMSIZ,6HSPECTG/
	CALL USAGEB('BMD01V')
      DO  666  I = 1, 20
  666 NUSE(I) = 0
      NEVER = 0
      WRITE (6,200)
 1111 READ (5,300)CODE,PROBNO,NP,OUT,NTG,BIN,WIND,NTAPE,IVF
      IF(CODE.EQ.FINISH)GO TO 1914
      IF(CODE.EQ.PROBLM) GO TO 2
  608 WRITE(6,6080)
 6080 FORMAT(87H0PROBLM OR FINISH IS PUNCHED WRONG ON THE PROPER CARD OR
     1 EITHER CARD IS OUT OF SEQUENCE)
      STOP
    2 IF((NP-1)*(NP-5001)) 6001,6002,6002
 6002 WRITE (6,6102)
 6102 FORMAT(72H0ERROR ON PROBLM CARD, CHECK PROGRAM LIMITS ON NUMBER OF
     1 TREATMENT GROUP)
      STOP
 6005 WRITE(6,6015)
 6015 FORMAT(58H0 WRONG PROBLEM CARD, THE NUMBER OF SPECTG CARD IS TOO B
     1IG)
      STOP
  609 WRITE(6,6019)
 6019 FORMAT(55H00 AND 5 CAN NOT BE SPECIFIED AS INPUT BINARY TAPE UNIT)
      STOP
  610 WRITE(6,6110)
 6110 FORMAT(33H0TOTAL NUMBER OF CASES IS TOO BIG)
      STOP
  406 WRITE(6,4016)J,NI
 4016 FORMAT(11H0THE NUMBER,I3,15H SPECTG CODE ON,I3,23H SPECTG CARD IS 
     1ILLEGAL)
      STOP
  605 WRITE(6,6050)
 6050 FORMAT(31H0ILLEGAL NUMBER OF SPECTG CARDS)
      STOP
  613 WRITE(6,6013)I
 6013 FORMAT(' THE NUMBER OF CASES IN GROUP',I5,' IS OUTSIDE THE RANGE O
     *F BETWEEN 1 AND 9000, PROBLEM WILL BE IGNORED')
      STOP
 6001 IF(NTG-9) 6003,6003,6005
 6003 NCUE=1
      IF(BTWEEN(NP,2,500).LE.0) GO TO 6002
      IF(BIN.NE.YES)GO TO 1113
 1112 NCUE=2
 1113 IF  (BTWEEN(NP, 2, 5000)*BTWEEN(IVF, 0, 10)*BTWEEN(NCUE, 1, 2)*
     1 (BTWEEN(NTAPE, 0, 5) + BTWEEN(NTAPE, 7, 15)))  607, 607, 3
    3 NUTS=NTAPE*(NTAPE-5)
      GO TO  (4, 5), NCUE
    5 IF  (NUTS)  7, 609, 7
    4 IF(IVF.GT.0.AND.IVF.LE.10)GO TO 6
      IVF=1
      WRITE(6,4000)
    6 IF  (NUTS)  7, 8, 7
    8 NTAPE = 5
      GO TO  9
    7 NUSE(NTAPE) = 1
      IF(WIND.EQ.XNO)GO TO 9
  667 REWIND  NTAPE
    9 IF  (NEVER)  10, 10, 11
   11 WRITE (6,200)
   10 NEVER = NEVER + 1
      WRITE (6,400)PROBNO, NP
      NCARDS=(NP+12)/13
      I2=0
      DO 17 J=1,NCARDS
      I1=I2+1
      I2=I2+13
      IF(NP-I2)15,16,16
   15 I2=NP
   16 READ (5,700)CODE,(NC(I),I=I1,I2)
      IF(CODE.EQ.SAMSIZ)GO TO 17
      WRITE(6,7000)
7000  FORMAT(55H0SAMSIZ IS SPELLED WRONG OR SAMSIZ CARD OUT OF SEQUENCE)
      CALL EXIT
  165 NCARDS=-NCARDS
   17 CONTINUE
      IF(-NCARDS)18,18,6002
   18 CASE=0.0
      DO 19 I=1,NP
      IF(BTWEEN(NC(I),1,9000))613,613,181
  181 CASE1=NC(I)
      CASE=CASE+CASE1
   19 CONTINUE
      IF(CASE-(10.0**8))195,195,610
  195 IF(NTG)605,499,401
  401 NH=0
      DO 445 NI=1,NTG
      READ(5,425)CODE,M,(L1(I),D2(I),I=1,M)
      IF(CODE.EQ.SPECTG)GO TO 404
  403 WRITE (6,405)
      STOP
  404 DO 6004  J=1,M
      IF(L1(J)*(L1(J)-11)) 6004,406,406
 6004 CONTINUE
      DO 415 NG=1,M
      NG1=NH+NG
      LCODE(NG1)=L1(NG)
  415 CONST(NG1)=D2(NG)
  445 NH=NH+M
  499 GO TO (12,13),NCUE
   12 WRITE (6,500)IVF, NTAPE
      WRITE(6,750)
  750 FORMAT(20H0THE VARIABLE FORMAT)
      IVF = IVF*18
      READ (5,100)(FMT(I), I = 1, IVF)
      WRITE(6,101)(FMT(I),I=1,IVF)
 101  FORMAT(1X,18A4)
      GO TO  14
   13 READ (5,601)LUMP
      WRITE (6,600)LUMP, NTAPE
   14 IF(NTG)605,439,426
  426 WRITE (6,427)
      DO 428 NG=1,NH
  428 WRITE (6,431)LCODE(NG),CONST(NG)
  439 SPSQ=0.0
      SMSQ = 0.0
      GT = 0.0
      NP1 = NP - 1
      NCI = NC(1)
      TOBS = NCI
      CALL  READIN
      DO  20  I = 1, NCI
   20 GT = GT + X(I)
      Y = GT/TOBS
      DO  21  J = 1, NCI
   21 SPSQ = SPSQ + (X(J) - Y)**2
      NGO = 1
      IF(OUT.EQ.YES)GO TO 31
   30 WRITE (6,801)
      GO TO  40
   31 SDV = SQRT( SPSQ/(TOBS - 1.0) )
      CALL  DECFND(Y, LY)
      CALL  DECFND(SDV, LSDV)
      IF  (NP - 12)  32, 32, 33
   33 WRITE (6,900)
      LY= MAX0(0, 7 - LY)
      LSDV= MAX0(0, 7 - LSDV)
      WRITE (6,901)NGO, NCI, Y, SDV
      NGO = 3
      GO TO  40
   32 LY= MAX0(LY, LSDV)
      LSDV= MAX0(0, 5 - LY)
      XBAR(1) = Y
      SDEV(1) = SDV
      NGO = 2
   40 DO  50  I = 2, NP
      NCI = NC(I)
      XNI = NCI
      TOBS = TOBS + XNI
      CALL  READIN
      AVE = 0.0
      DO  51  J = 1, NCI
   51 AVE = AVE + X(J)
      GT = GT + AVE
      AVE = AVE/XNI
      SDV = 0.0
      DO  52  J = 1, NCI
   52 SDV = (X(J) - AVE)**2 + SDV
      SPSQ = SPSQ + SDV
      SMSQ = SMSQ + XNI*(AVE - Y)**2
      SDV = SQRT( SDV/(XNI - 1.0) )
      GO TO  (50, 61, 62), NGO
   61 XBAR(I) = AVE
      SDEV(I) = SDV
      GO TO  50
   62 WRITE (6,901)I, NCI, AVE, SDV
   50 CONTINUE
      GO TO  (70, 71, 70), NGO
   71 WRITE (6,1000)(I, I = 1, NP)
 1000 FORMAT(////22H TREATMENT GROUP       , 12(I7, 2X) )
      WRITE (6,1001)(NC(I), I = 1, NP)
      WRITE (6,1002)(XBAR(I), I = 1, NP)
      WRITE (6,1003)(SDEV(I), I = 1, NP)
   70 WRITE (6,1100)
      GT = GT/TOBS
      SMSQ = SMSQ - TOBS*(GT - Y)**2
      GT = SMSQ + SPSQ
      TOBS = TOBS - 1.0
      TLEVEL = NP1
      DF = TOBS - TLEVEL
      AVE = SMSQ/TLEVEL
      SDV = SPSQ/DF
      FRATIO = AVE/SDV
      WRITE (6,1200)SMSQ, NP1, AVE, FRATIO
      INTDF=DF +.0000001
      INTOBS=TOBS+.0000001
      WRITE (6,1500)SPSQ, INTDF   , SDV
      WRITE (6,1600)GT, INTOBS
      GO TO  1111
  607 WRITE (6,6070)
      STOP
 1914 DO  73  I = 1, 20
      IF  (NUSE(I))  72, 73, 72
   72 IF(I.NE.5)REWIND I
   73 CONTINUE
      WRITE (6,1900)
 1915 STOP
 100  FORMAT(18A4)
  300 FORMAT(2A6,I4,A3,I1,43X,A3,A2,2I2)
  400 FORMAT(///// 15H PROBLEM CODE   , A6, /  20H NUMBER OF TREATMENT ,
     1 9H GROUPS  , I4  )
  405 FORMAT(51H0ERROR ON TRANS-GENERATION CARD, SPECTG IS MISSPELT)
  425 FORMAT(A6,I1,8(I2,F6.0))
  427 FORMAT(1H023HSPECIAL TRANSGENERATION/1H 3X4HCODE4X8HCONSTANT)
  431 FORMAT(1H 5XI2,1XF11.5)
  500 FORMAT(34H NUMBER OF VARIABLE FORMAT CARDS   , I2  /
     1 18H DATA INPUT TAPE   , I2 )
  600 FORMAT(23H BINARY RECORD LENGTH  , I3 / 18H DATA INPUT TAPE  , I2)
  601 FORMAT(I3)
  700 FORMAT(A6, 1X, 13I5)
  801 FORMAT(////41H LISTING OF TREATMENT MEANS NOT REQUESTED   )
  900 FORMAT(//// 49H TREATMENT    SAMPLE SIZE      MEAN      STANDARD
     1 10H DEVIATION   //)
  901 FORMAT    (1X,I6,8X,I6,F16.5,        F17.5)
 1001 FORMAT(/ 22H SAMPLE SIZE           , 12(I7, 2X)   )
 1002 FORMAT    (/22H MEAN                 , 12F9.4)
 1003 FORMAT    (/22H STANDARD DEVIATION   , 12F9.4)
 1100 FORMAT(/////  33X, 21H ANALYSIS OF VARIANCE     ///
     1 19X, 15H SUM OF SQUARES, 6X, 2HDF, 5X, 12H MEAN SQUARE , 5X,
     2 8H F RATIO     /  )
 1200 FORMAT(15H0BETWEEN GROUPS      , F17.4, I10, 2F15.4  )
 1300 FORMAT(2F11.0)
 1400 FORMAT(2A5, 1X, 2A5)
 1500 FORMAT(15H0WITHIN GROUPS    , F17.4, I10, F15.4)
 1600 FORMAT(// 1H , 5X, 5HTOTAL, F21.4, I10)
 1900 FORMAT(40H1COMPUTATION HALTED BY  FINISH  CARD.   )
 4000 FORMAT(1H023X71HNUMBER OF VARIABLE FORMAT CARDS INCORRECTLY SPECIF
     1IED, ASSUMED TO BE 1.)
 6070 FORMAT(123H0PROBLEM CARD IS SET UP WRONG, EITHER INPUT TAPE UNIT I
     1S SPECIFIED WRONG OR THE NUMBER OF F-TYPE VARIABLE FORMAT IS TOO B
     2IG)
      END
C        FUNCTION BTWEEN FOR BMD01V                   JUNE 15, 1966
C        BTWEEN = 1.0 IF N IS BETWEN I AND J
      FUNCTION  BTWEEN(N, I, J)
      BTWEEN=0.0
      IF(N.GE.I.AND.N.LE.J)BTWEEN=1.0
      RETURN
      END
C        SUBROUTINE DECFND FOR BMD01V                 JUNE 15, 1966
C        X HAS A MAGNITUDE BETWEEN 10**(LEFT-1) AND 10**(LEFT)
      SUBROUTINE  DECFND(X, LEFT)
      A=10.
      DO 1 LEFT=1,19
      IF(A.GT.X) GO TO 2
    1 A=A*10.
    2 RETURN
      END
C        SUBROUTINE DIVALG FOR BMD01V                 JUNE 15, 1966
C        DIVISION ALGORITHM
      SUBROUTINE  DIVALG(NA, NB, NQ, NR, NCODE)
      NN = NA
      IF  (NCODE)  1, 1, 2
    2 NN = NN - 1
    1 NQ = NN/NB
      NR = NA - NB*NQ
      RETURN
      END
C        SUBROUTINE READIN FOR BMD01V                 JUNE 15, 1966
      SUBROUTINE  READIN
      DIMENSION X(9000),LCODE(72),CONST(72),FMT(180)
      COMMON  X      , NCI    , NCUE   , FMT    , NTAPE  , LUMP
      COMMON  LCODE  , CONST  , NH     , FM     , NTG
      GO TO  (1, 2), NCUE
    1 READ (NTAPE,FMT)(X(I), I = 1, NCI)
    6 IF(NTG)7,8,7
    7 CALL TRNGEN
    8 RETURN
    2 CALL  DIVALG(NCI, LUMP, NDO, LEFT, 1)
      N2 = 0
      IF  (NDO)  3, 3, 4
    4 DO  5  J = 1, NDO
      N1 = N2 + 1
      N2 = N2 + LUMP
    5 READ(NTAPE,9876)(X(I),I=N1,N2)
    3 N1 = N2 + 1
      READ(NTAPE,9876)(X(I),I=N1,NCI)
      GO TO 6
 9876 FORMAT(20A4)
      END
C        SUBROUTINE TRNGEN FOR BMD01V                 JUNE 15, 1966
      SUBROUTINE TRNGEN
      DIMENSION X(9000),LCODE(72),CONST(72),FMT(180)
      COMMON  X      , NCI    , NCUE   , FMT    , NTAPE  , LUMP
      COMMON  LCODE  , CONST  , NH     , FM     , NTG    , SAMP
      ASN(XX)=ATAN(XX/SQRT(1.0-XX**2))
      DO 210 I=1,NH
      FM=CONST(I)
      JUMP=LCODE(I)
      DO 85 J=1,NCI
      D=X(J)
      GO TO(10,20,30,40,50,60,70,80,90,110),JUMP
   10 IF(D)99,11,12
   11 D=0.0
      GO TO 8
   12 D=SQRT(D)
      GO TO 8
   20 IF(D)99,21,22
   21 D=1.0
      GO TO 8
   22 D=SQRT(D)+SQRT(D+1.0)
      GO TO 8
   30 IF(D)99,99,31
   31 D=ALOG10(D)
      GO TO 8
   40 D=EXP(D)
      GO TO 8
   50 IF(-D)52,11,99
   52 IF(D-1.0)53,54,99
   54 D=3.14159265/2.0
      GO TO 8
   53 D=ASN(SQRT(D))
      GO TO 8
   60 A=D/(SAMP+1.0)
      B=A+1.0/(SAMP+1.0)
      IF(A)99,61,62
   61 IF(-B)64,11,99
   64 D=ASN(SQRT(B))
      GO TO 8
   62 IF(B)99,65,66
   65 D=ASN(SQRT(A))
      GO TO 8
   66 D=ASN(SQRT(A))+ASN(SQRT(B))
      GO TO 8
   70 IF(D)71,99,71
   71 D=1.0/D
      GO TO 8
   80 D=D+FM
      GO TO 8
   90 D=D*FM
      GO TO 8
  110 IF(D)111,11,111
  111 D=D**FM
    8 X(J)=D
   85 CONTINUE
  210 CONTINUE
      GO TO 1000
   99 WRITE(6,105)I,D
      STOP
  105 FORMAT(23H0TRANS-GENERATION ERROR//10H PASS NO.=I3,9H X VALUE=F10.
     15)
 1000 RETURN
      END