home *** CD-ROM | disk | FTP | other *** search
/ Between Heaven & Hell 2 / BetweenHeavenHell.cdr / 500 / 474 / ems.arc / PC-EMS.FOR < prev    next >
Text File  |  1985-09-05  |  9KB  |  294 lines
  1. C        
  2. C                                  PC-EMS
  3. C                  A Program for Sample Size Determinations
  4. C                                Version 1.0
  5. C                             September 2, 1985
  6. C
  7. C                              Gerard E. Dallal
  8. C       
  9. C               USDA Human Nutrition Research Center on Aging
  10. C                            at Tufts University
  11. C                           711 Washington Street
  12. C                             Boston, MA  02111
  13. C
  14. C                                    and
  15. C
  16. C                    Tufts University School of Nutrition
  17. C                             132 Curtis Street
  18. C                             Medford, MA 02155
  19. C        
  20. C
  21. C
  22. C                                  NOTICE
  23. C
  24. C       Program and documentation copyright 1985 by Gerard E. Dallal.
  25. C       Reproduction  of  material  for  non-commercial  purposes  is
  26. C       permitted,  without charge,  provided that suitable reference
  27. C       is made to PC-EMS and its author.
  28. C
  29. C       Neither PC-EMS nor its documentation  should be  modified  in 
  30. C       any way without permission from the author,  except for those 
  31. C       changes  that  are  essential  to  move  PC-EMS  to   another 
  32. C       computer.  
  33. C
  34. C       Please acknowledge PC-EMS in any  manuscript  that  uses  its 
  35. C       calculations.  
  36. C
  37. C
  38. C
  39. C        A PROGRAM TO CONSTRUCT EMS TABLES FOR BALANCED DESIGNS
  40. C
  41. C        MATRICES ARE IN THE USUAL FORMAT--ROWS CORRESPOND TO
  42. C        EFFECTS;  COLUMNS CORRESPOND TO SUBSCRIPTS
  43. C
  44. C        ISUB(I,J) -- INDICATES WHETHER EFFECT I CONTAINS
  45. C                     SUBSCRIPT J:
  46. C                         1 = PRESENT, NOT CONTAINED IN PARENTHESES
  47. C                         0 = ABSENT
  48. C                        -1 = PRESENT, CONTAINED IN PARENTHESES
  49. C
  50. C        COEF(I,J) -- THE COEFFICIENT OF EFFECT i CORRESPONDING TO 
  51. C                     SUBSCRIPT J
  52. C
  53. C        SUB(J) -- THE SUBSCRIPTS
  54. C
  55. C        TYPE(J) = 'F' ('R'), MAIN EFFECT CORRESPONDING TO SUBSCRIPT J IS 
  56. C                       FIXED (RANDOM)
  57. C
  58. C        LEVELS(J) -- NUMBER OF LEVELS OF FACTOR CORRESPONDING TO 
  59. C                     SUBSCRIPT J
  60. C
  61. C        LCHAR -- MAXIMUM NUMBER OF CHARACTERS IN A SINGLE TERM
  62. C
  63. C        NCHAR(I) -- NUMBER OF CHARACTERS IN TERM I
  64. C
  65.       IMPLICIT INTEGER (A-Z)
  66.       CHARACTER*1 TYPE(50), QUERY, SUB(10), TCHAR
  67.       CHARACTER*50 FNAME
  68.       CHARACTER*79 MODEL
  69.       CHARACTER*10 TERM(50), TOUT(50), TDUM
  70.       CHARACTER*11 TERMO
  71.       LOGICAL QFILE
  72.       DIMENSION COEF(50,10), ISUB(50,10), NCHAR(50), COUT(50), 
  73.      *   LEVELS(10)
  74. C
  75.       DATA IIN /0/, IOUT /0/, IWOUT /11/
  76.       DATA LMODEL /79/, LCHAR /10/, MAXSUB /10/
  77. C
  78.       WRITE(IOUT,1)
  79.     1 FORMAT (//36X,'PC-EMS'/
  80.      *   23X,'A Program to Construct EMS Tables'/
  81.      *   34X,'Version 1.0'/31X,'September 2, 1985'//
  82.      *   32X,'Gerard E. Dallal'/
  83.      *   17X,'USDA Human Nutrition Research Center on Aging'/
  84.      *   30X,'at Tufts University'/29X,'711 Washington Street'/
  85.      *   31X,'Boston, MA  02111'///37X,'NOTICE'//9X,'Please '
  86.      *   'acknowledge  PC-EMS  in any manuscript  that uses its',/
  87.      *   9X,'calculations.')
  88.  
  89.       WRITE(IOUT,2)
  90.     2 FORMAT(//' Do you wish to save the results of this session?  ',
  91.      *  '[N]:  '$)
  92.       READ (IIN,3) QUERY
  93.     3 FORMAT (A1)
  94.       IF (QUERY.EQ.'Y' .OR. QUERY.EQ.'y') QFILE = .TRUE.
  95.       IF (.NOT. QFILE) GOTO 10
  96.       WRITE (IOUT,4)
  97.     4 FORMAT (' Enter output filename:  '$)
  98.       READ (IIN,'(A)') FNAME
  99.       OPEN (IWOUT, FILE = FNAME, STATUS = 'NEW')
  100.       WRITE (IWOUT,1)
  101.  
  102.    10 WRITE(IOUT,20) 
  103.       IF (QFILE) WRITE (IWOUT,20) 
  104.    20 FORMAT(///' Models are entered in the form:'//
  105.      *   '             A + B(A) + C + AC + B(A)C'//
  106.      *   ' Terms must be separated by ''+'' or '','' ;',
  107.      *   '  blanks are optional.'/
  108.      *   ' Grand mean and error term are NOT stated explicitly.'//
  109.      *   ' Enter the model:'/)
  110.  
  111.    30 READ (IIN,'(A)') MODEL
  112.       IF (QFILE) WRITE (IWOUT,40) MODEL
  113.    40 FORMAT (1X,A79)
  114. C
  115. C        STRIP BLANKS
  116. C
  117.       NTERM = 1
  118.       LEN = 0
  119.       DO 60 K = 1, LMODEL
  120.       IF (MODEL(K:K).EQ.' ') GOTO 60
  121.       IF (MODEL(K:K).EQ.',') MODEL(K:K) = '+'
  122.       IF (MODEL(K:K).EQ.'+') NTERM = NTERM + 1
  123.       LEN = LEN + 1
  124.       MODEL(LEN:LEN) = MODEL(K:K)
  125.    60 CONTINUE
  126.  
  127.       KK = 0
  128.       DO 100 I = 1, NTERM
  129.       NCHAR0 = 0
  130.       TERM(I) = '          '
  131.       DO 80 K = 1, LCHAR
  132.       KK = KK + 1
  133.       IF (KK.GT.LEN .OR. MODEL(KK:KK).EQ.'+') GOTO 90
  134.       NCHAR0 = NCHAR0 + 1
  135.       TERM(I)(K:K) = MODEL(KK:KK)
  136.    80 CONTINUE
  137.    90 NCHAR(I) = NCHAR0
  138.   100 CONTINUE
  139. C
  140. C        A MAIN EFFECT HAS ONLY ONE LETTER, OR ONE LETTER OUTSIDE THE
  141. C        FIRST LEVEL OF PARENTHESES
  142. C
  143.   110 NSUB = 0
  144.       IF (QFILE) WRITE(IWOUT,120)
  145.       WRITE(IOUT,120)
  146.   120 FORMAT(' ')
  147.       DO 200 I = 1, NTERM
  148.       NCHAR0 = NCHAR(I)
  149.       IF (NCHAR0.NE.1 .AND. (TERM(I)(2:2).NE.'(' .OR. 
  150.      *   TERM(I)(NCHAR0:NCHAR0).NE.')')) GOTO 200
  151. C
  152.       NSUB = NSUB + 1
  153.       IF (NSUB.LE.MAXSUB)GOTO 140
  154.       WRITE (IOUT,130) MAXSUB
  155.       IF (QFILE) WRITE (IWOUT,130) MAXSUB
  156.   130 FORMAT (/' ONLY ',I2,' FACTORS ARE ALLOWED IN THE MODEL.'/)
  157.       GOTO 10
  158.   140 SUB(NSUB) = TERM(I)(1:1)
  159. C
  160. C        GET NUMBER OF LEVELS OF EACH FACTOR
  161. C
  162.       IF (QFILE) WRITE (IWOUT,160) SUB(NSUB)
  163.   150 WRITE (IOUT,160) SUB(NSUB)
  164.   160 FORMAT (' Enter the number of levels of ',A1,' :  '$)
  165.       READ (IIN,170,ERR=150) LEVELS(NSUB)
  166.   170 FORMAT (BN,I10)
  167.       IF (QFILE) WRITE (IWOUT,180) LEVELS(NSUB)
  168.   180 FORMAT(1X,I4)
  169.   200 CONTINUE
  170. C
  171.       IF (QFILE) WRITE(IWOUT,120)
  172.       WRITE(IOUT,120)
  173.       DO 300 J = 1, NSUB
  174.       IF (QFILE) WRITE (IWOUT,220) SUB(J)
  175.   210 WRITE (IOUT,220) SUB(J)
  176.   220 FORMAT(' Is the factor ',A1,' fixed (F) or random (R)?  '$)
  177.       READ(IIN,3) QUERY
  178.       IF (QUERY.NE.'f' .AND. QUERY.NE.'F' .AND. QUERY.NE.'r' .AND. 
  179.      *   QUERY.NE.'R') GOTO 210
  180. C
  181.       IF (QUERY.EQ.'f') QUERY = 'F'
  182.       IF (QUERY.EQ.'r') QUERY = 'R'
  183.       IF (QFILE) WRITE (IWOUT,230) QUERY
  184.   230 FORMAT (3X,A1)
  185.       TYPE(J) = QUERY
  186.   300 CONTINUE
  187.  
  188.       NTERM = NTERM + 1
  189. C
  190. C        ? -- SYMBOL FOR ERROR TERM
  191. C
  192.       TERM(NTERM)(1:2) = '?('
  193.       DO 310 J = 1, NSUB
  194.   310 TERM(NTERM)(J+2:J+2) = SUB(J)
  195.  
  196.       NSUB = NSUB + 1
  197.       SUB(NSUB) = '?'
  198.       TYPE(NSUB) = 'R'
  199.       NCHAR(NTERM) = NSUB + 2
  200.       NCHAR0 = NCHAR(NTERM)
  201.       TERM(NTERM)(NCHAR0:NCHAR0) = ')'
  202.       IF (QFILE) WRITE (IWOUT,330)
  203.   320 WRITE (IOUT,330)
  204.   330 FORMAT (/' Enter the number of observations per cell:  '$)
  205.       READ(IIN,170,END=320) LEVELS(NSUB)
  206.       IF (QFILE) WRITE (IWOUT,180) LEVELS(NSUB)
  207.  
  208.       DO 500 I = 1, NTERM
  209.       NCHAR0 = NCHAR(I)
  210.       DO 400 J = 1, NSUB
  211.       NEST = 0
  212.       DO 350 K = 1, NCHAR0
  213.       TCHAR = TERM(I)(K:K)
  214.       IF (TCHAR.EQ.'(') NEST = NEST + 1
  215.       IF (TCHAR.EQ.')') NEST = NEST - 1
  216.       IF (TCHAR.NE.SUB(J)) GOTO 350
  217.       IF (NEST.EQ.0) ISUB(I,J) = 1
  218.       IF (NEST.GT.0) ISUB(I,J) = -1
  219.       GOTO 400
  220.   350 CONTINUE
  221.       ISUB(I,J) = 0
  222.   400 CONTINUE
  223.   500 CONTINUE
  224.  
  225.       DO 2050 J = 1, NSUB
  226.       DO 2040 I = 1, NTERM
  227.       IF (ISUB(I,J).EQ.-1) COEF(I,J) = 1
  228.       IF (ISUB(I,J).EQ.0) COEF(I,J) = LEVELS(J)
  229.       IF (ISUB(I,J).EQ.1 .AND. TYPE(J).EQ.'F') COEF(I,J) = 0
  230.       IF (ISUB(I,J).EQ.1 .AND. TYPE(J).EQ.'R') COEF(I,J) = 1
  231.  2040 CONTINUE
  232.  2050 CONTINUE
  233.  
  234. C
  235. C        IE -- TERM BEING EVALUATED
  236. C
  237.  
  238.       DO 5000 IE = 1, NTERM
  239.       DO 3050 I = 1, NTERM
  240.       C = 1
  241.       DO 3010 J = 1, NSUB
  242.       IF (ISUB(IE,J).NE.0 .AND. ISUB(I,J).EQ.0) C = 0
  243.       IF (C.EQ.0) GOTO 3020
  244.       IF (ISUB(IE,J).NE.0) GOTO 3010
  245.       C = C * COEF(I,J)
  246.  3010 CONTINUE
  247.  3020 COUT(I) = C
  248.  3050 CONTINUE
  249. C
  250.       NOUT = 0
  251.       DO 3100 I = 1, NTERM
  252.       IF (COUT(I).EQ.0) GOTO 3100
  253.       NOUT = NOUT + 1
  254.       COUT(NOUT) = COUT(I)
  255.       TOUT(NOUT) = TERM(I)
  256.  3100 CONTINUE
  257.  
  258.       NOUT2 = (NOUT + 1) / 2
  259.       DO 3110 I = 1, NOUT2
  260.       K = NOUT - I + 1
  261.       CDUM = COUT(I)
  262.       TDUM = TOUT(I)
  263.       COUT(I) = COUT(K)
  264.       TOUT(I) = TOUT(K)
  265.       COUT(K) = CDUM
  266.       TOUT(K) = TDUM
  267.  3110 CONTINUE
  268.       TOUT(1) = 'error     '
  269.  
  270.       NCHAR0 = NCHAR(IE) + 1
  271.       TERMO = TERM(IE)
  272.       IF (IE.LT.NTERM) GOTO 3190
  273.       NCHAR0 = 6
  274.       TERMO = 'error     '
  275.  3190 TERMO(NCHAR0:NCHAR0) = ')'
  276.       
  277.       WRITE(IOUT,3200) TERMO, (COUT(I), TOUT(I), I = 1, NOUT)
  278.       IF (QFILE)
  279.      *   WRITE(IWOUT,3200) TERMO, (COUT(I), TOUT(I), I = 1, NOUT)
  280.  3200 FORMAT(/1X,'EMS(',A11,' =',I4,' * ',A10:' +',I4,' * ',
  281.      *   A10:' +',I4,' * ',A10:' +',
  282.      *   (/18X,I4,' * ',A10:' +',I4,' * ',A10:' +',
  283.      *   I4,' * ',A10:' +'))
  284.  
  285.  5000 CONTINUE
  286.  
  287.       WRITE (IOUT,5020)
  288.  5020 FORMAT (/' Do you wish to continue?  [N]:  '$)
  289.       READ (IIN,3) QUERY
  290.       IF (QUERY.EQ.'y' .OR. QUERY.EQ.'Y') GOTO 10
  291.  
  292.       STOP ' '
  293.       END
  294.