home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Between Heaven & Hell 2
/
BetweenHeavenHell.cdr
/
500
/
474
/
ems.arc
/
PC-PLAN.FOR
< prev
next >
Wrap
Text File
|
1986-02-21
|
12KB
|
418 lines
C
C IPMAX -- LARGEST NUMBER OF THREATMENTS THAT CAN BE PERMUTED
C IPERM IS (IPMAX,FACTORIAL(IPMAX))
C LMAX -- LARGEST NUMBER OF TREATMENTS THAT CAN BE ASSIGNED RANDOMLY
C ISMAX -- LARGEST NUMBER OF SUBJECTS PER BLOCK
C NPERPG -- NUMBER OF SUBJECTS PER PRINTED PAGE FOR TREATMENTS
C ASSIGNED AT RANDOM
C
C TREATMENT LABELS CAN CONTAIN UP TO 15 CHARACTERS. SEE ALSO
C SUBROUTINE RPERMC
C BLOCK LABELS CAN CONTAIN UP TO 40 CHARACTERS.
C
DIMENSION KTR(20), IP(400), IPERM(5,120), IPERM0(5), IPERM1(5)
CHARACTER*15 TLAB(20), SLAB(400), SLABP(20)
CHARACTER*40 FNAME, BLAB(20)
CHARACTER*1 QUERY
LOGICAL QFILE
DOUBLE PRECISION DCSEED, DTSEED
DATA IIN /0/, IOUT/0/, IWOUT/10/
DATA LMAX /20/, ISMAX /400/, IPMAX /5/, NPERPG /80/
C
QFILE = .FALSE.
DO 70 I = 1, IPMAX
IPERM0(I) = I
IPERM1(I) = I
70 CONTINUE
DO 80 I = 1, LMAX
BLAB(I) = ' '
TLAB(I) = ' '
SLABP(I) = ' '
80 CONTINUE
DO 90 I = 1, ISMAX
90 SLAB(I) = ' '
C
WRITE(IOUT,91)
91 FORMAT(/' Do you wish to save the results of this session? ',
* '(Y or N): '$)
READ (IIN,200) QUERY
IF (QUERY.EQ.'Y' .OR. QUERY.EQ.'y') QFILE = .TRUE.
IF (.NOT. QFILE) GOTO 93
WRITE (IOUT,92)
92 FORMAT (' Enter filename: '$)
READ (IIN,'(A)') FNAME
OPEN (IWOUT, FILE = FNAME, STATUS = 'NEW')
C
C SET SEEDS
C
93 CALL SEEDER(IX,IY,IZ,IIN,IOUT)
WRITE(IOUT,94) IX,IY,IZ
IF (QFILE) WRITE(IWOUT,94) IX,IY,IZ
94 FORMAT(/' The initial seeds for the random number generator',
* ' are: '/10X,3I15)
C
100 WRITE (IOUT,110) LMAX
110 FORMAT(/' Enter the number of blocks [.LE.',I2,']: '$)
READ (IIN,*,ERR=100) NBLK
IF (NBLK.LT.1 .OR. NBLK.GT.LMAX) GOTO 100
IF (NBLK.EQ.1) GOTO 150
C
WRITE (IOUT,130)
130 FORMAT (' Enter block labels, one per line:')
READ (IIN,'(A)') (BLAB(I),I=1,NBLK)
C
150 WRITE (IOUT,160)
160 FORMAT (/' Enter number of subjects per block: '$)
READ (IIN,*,ERR=150) NSUBJ
IF (NSUBJ.GT.ISMAX) STOP 'Too many subjects...recompile'
C
170 WRITE (IOUT,180)
180 FORMAT (/' Do you wish to assign treatments to subjects (A),'/
* ' or permute treatments within subject (P)?: '$)
READ (IIN,200) QUERY
200 FORMAT(A1)
IF (QUERY.NE.'A' .AND. QUERY.NE.'a' .AND.
* QUERY.NE.'P' .AND. QUERY.NE.'p') GOTO 170
C
IF (QUERY.EQ.'P' .OR. QUERY.EQ.'p') GOTO 1300
C
C ASSIGN TREATMENTS TO SUBJECTS
C
300 WRITE (IOUT,310) LMAX
310 FORMAT(/' Enter the number of treatments [.LE.',I2,']: '$)
READ (IIN,*,ERR=300) NTR
IF (NTR.LT.2 .OR. NTR.GT.LMAX) GOTO 300
FNTR = NTR
C
WRITE (IOUT,330)
330 FORMAT (' Enter treatment labels, one per line:')
READ (IIN,'(A)') (TLAB(I),I=1,NTR)
C
340 WRITE (IOUT,350)
350 FORMAT (/' Are treatments:'//
* ' 1 -- assigned at random without any forced balancing,'/
* ' 2 -- assigned at random with an equal number per'
* ' treatment, or'/
* ' 3 -- assigned at random with a prespecified number per',
* ' treatment?: '$)
C
READ (IIN,*,ERR=340) NPICK
IF (NPICK.LT.1 .OR. NPICK.GT.3) GOTO 340
IF (NPICK - 2) 400, 351, 360
C
351 IF (NSUBJ.EQ.NSUBJ/NTR*NTR) GOTO 400
WRITE (IOUT,352)
352 FORMAT(/'** Numbers of subjects and treatments do not mesh'/)
GOTO 340
C
360 WRITE (IOUT,370)
370 FORMAT (' Enter the number of subjects for each treatment: '$)
READ (IIN,*,ERR=360) (KTR(I),I=1,NTR)
KTRSUM = 0
DO 380 I = 1, NTR
380 KTRSUM = KTRSUM + KTR(I)
IF (KTRSUM.EQ.NSUBJ) GOTO 400
WRITE (IOUT,390)
390 FORMAT(/'** Total number of subjects and number of subjects'/
* ' per treatment do not mesh.'/)
GOTO 360
C
400 DO 800 I = 1, NBLK
C
GOTO (410,430,450), NPICK
C
C TOTALLY AT RANDOM
C
410 DO 420 K = 1, NSUBJ
RAND = RANDOM(IX,IY,IZ)
INDEX = 1. + FNTR * RAND
SLAB(K) = TLAB(INDEX)
420 CONTINUE
GOTO 500
C
C EQUAL NUMBER PER GROUP
C
430 NPERTR = NSUBJ / NTR
K = 0
DO 440 I1 = 1, NTR
DO 440 I2 = 1, NPERTR
K = K + 1
SLAB(K) = TLAB(I1)
440 CONTINUE
C
CALL RPERMC(SLAB,NSUBJ,IX,IY,IZ)
GOTO 500
C
C PRESPECIFIED NUMBER PER GROUP
C
450 K = 0
DO 460 I1 = 1, NTR
NPERTR = KTR(I1)
DO 460 I2 = 1, NPERTR
K = K + 1
SLAB(K) = TLAB(I1)
460 CONTINUE
C
CALL RPERMC(SLAB,NSUBJ,IX,IY,IZ)
C
500 IF (NBLK.GT.1) WRITE(IOUT,510) BLAB(I)
IF (NBLK.GT.1 .AND. QFILE) WRITE(IWOUT,510) BLAB(I)
510 FORMAT (////5X,A40)
C
NPAGE = 1 + (NSUBJ - 1) / NPERPG
DO 700 IPDEX = 1, NPAGE
C
ISTART = 1 + (IPDEX - 1) * NPERPG
IEND = MIN0(NSUBJ,IPDEX*NPERPG)
NHALF = (ISTART + IEND) / 2
INCR = NHALF - ISTART + 1
C
WRITE(IOUT,515)
IF (QFILE) WRITE(IWOUT,515)
515 FORMAT (///)
C
DO 600 IW = ISTART, NHALF - 1
WRITE(IOUT,520) IW, SLAB(IW), IW+INCR, SLAB(IW+INCR)
IF (QFILE)
* WRITE(IWOUT,520) IW, SLAB(IW), IW+INCR, SLAB(IW+INCR)
520 FORMAT(8X,I3,'.',5X,A15,10X,I3,'.',5X,A15)
600 CONTINUE
IODD = MOD(IEND - ISTART + 1,2)
IF (IODD.EQ.0) WRITE(IOUT,520) NHALF, SLAB(NHALF),
* NHALF+INCR, SLAB(NHALF+INCR)
IF (IODD.EQ.1) WRITE(IOUT,520) NHALF, SLAB(NHALF)
IF (IODD.EQ.0 .AND. QFILE) WRITE(IWOUT,520) NHALF, SLAB(NHALF),
* NHALF+INCR, SLAB(NHALF+INCR)
IF (IODD.EQ.1 .AND. QFILE) WRITE(IWOUT,520) NHALF, SLAB(NHALF)
700 CONTINUE
800 CONTINUE
STOP ' '
C
C PERMUTE WITHIN SUBJECT
C
1300 WRITE (IOUT,1310) IPMAX
1310 FORMAT(/' Enter the number of treatments [.LE.',I1,']: '$)
READ (IIN,*,ERR=1300) NTR
IF (NTR.LT.2 .OR. NTR.GT.IPMAX) GOTO 1300
FNTR = NTR
NPERM = 1
DO 1320 I = 2, NTR
1320 NPERM = NPERM * I
FNPERM = NPERM
C
DO 1325 J = 1, NPERM
CALL PERMUT(IPERM1,IPERM0,NTR)
DO 1325 K = 1, NTR
IPERM(K,J)= IPERM1(K)
1325 CONTINUE
C
WRITE (IOUT,1330)
1330 FORMAT (' Enter treatment labels, one per line:')
READ (IIN,'(A)') (TLAB(I),I=1,NTR)
C
NPICK = 1
IF (NSUBJ.NE.NSUBJ/NPERM*NPERM) GOTO 1360
1340 WRITE (IOUT,1350)
1350 FORMAT (' Are permutations:'//
* ' 1 -- assigned at random without any forced balancing'
* ' or'/
* ' 2 -- assigned at random with an equal number of',
* ' each?: '$)
C
READ (IIN,*,ERR=1340) NPICK
IF (NPICK.LT.1 .OR. NPICK.GT.2) GOTO 1340
C
1360 DO 1800 I = 1, NBLK
C
GOTO (1410,1430), NPICK
C
C TOTALLY AT RANDOM
C
1410 DO 1420 K = 1, NSUBJ
RAND = RANDOM(IX,IY,IZ)
1420 IP(K) = 1. + FNPERM * RAND
C
GOTO 1500
C
C EQUAL NUMBER PER GROUP
C
1430 NPERTR = NSUBJ / NPERM
K = 0
DO 1440 I1 = 1, NPERM
DO 1440 I2 = 1, NPERTR
K = K + 1
IP(K) = I1
1440 CONTINUE
C
CALL RPERMI(IP,NSUBJ,IX,IY,IZ)
C
C OUTPUT
C
1500 IF (NBLK.GT.1) WRITE(IOUT,510) BLAB(I)
IF (NBLK.GT.1 .AND. QFILE) WRITE(IWOUT,510) BLAB(I)
C
DO 1600 I1 = 1, NSUBJ
DO 1510 K = 1, NTR
1510 SLABP(K) = TLAB(IPERM(K,IP(I1)))
C
WRITE(IOUT,1520) I1, (SLABP(K),K=1,NTR)
IF (QFILE) WRITE(IWOUT,1520) I1, (SLABP(K),K=1,NTR)
1520 FORMAT (8X,I3,'.',5X,A15,5X,A15,5X,A15,:/
* (25X,A15,5X,A15,5X,A15))
C
1600 CONTINUE
1800 CONTINUE
STOP ' '
END
C
SUBROUTINE RPERMI(LIST,N,IX,IY,IZ)
C
C A RANDOM PERMUTATION OF THE ITEMS IN LIST
C
DIMENSION LIST(N)
C
NM1 = N - 1
DO 10 I = 1, NM1
II = N - I + 1
J = FLOAT(II) * RANDOM(IX,IY,IZ) + 1.
IDUMMY = LIST(II)
LIST(II) = LIST(J)
LIST(J) = IDUMMY
10 CONTINUE
RETURN
END
C
SUBROUTINE RPERMC(LIST,N,IX,IY,IZ)
C
C A RANDOM PERMUTATION OF THE ITEMS IN LIST
C
CHARACTER*15 LIST(N),IDUMMY
C
NM1 = N - 1
DO 10 I = 1, NM1
II = N - I + 1
J = FLOAT(II) * RANDOM(IX,IY,IZ) + 1.
IDUMMY = LIST(II)
LIST(II) = LIST(J)
LIST(J) = IDUMMY
10 CONTINUE
RETURN
END
C
SUBROUTINE PERMUT(IX,IP,N)
C
C CACM ALGORITHM 86
C PERMUTE
C BY PECK, J.E.L. AND G.F. SCHRACK
C
C TRANSLATED INTO FORTRAN BY
C Gerard E. Dallal
C USDA-Human Nutrition Research Center on Aging
C at Tufts University
C 711 Washington Street
C Boston, MA 02111
C
DIMENSION IX(N), IP(N)
DO 100 K = 2, N
IT = IX(1)
KM = K - 1
DO 50 I = 1, KM
50 IX(I) = IX(I+1)
IX(K) = IT
IP(K) = IP(K) - 1
IF(IP(K).NE.0) RETURN
IP(K) = K
100 CONTINUE
RETURN
END
C
FUNCTION RANDOM(IX,IY,IZ)
C
C ALGORITHM AS 183 APPL. STATIST. (1982) VOL.31, NO.2
C
C RETURNS A PSEUDO-RANDOM NUMBER RECTANGULARLY DISTRIBUTED
C BETWEEN 0 AND 1.
C
C IX, IY AND IZ SHOULD BE SET TO INTEGER VALUES BETWEEN
C 1 AND 30000 BEFORE FIRST ENTRY
C
IX = 171 * MOD(IX, 177) - 2 * (IX / 177)
IY = 172 * MOD(IY, 176) - 35 * (IY / 176)
IZ = 170 * MOD(IZ, 178) - 63 * (IZ / 178)
C
IF (IX .LT. 0) IX = IX + 30269
IF (IY .LT. 0) IY = IY + 30307
IF (IZ .LT. 0) IZ = IZ + 30323
C
C IF INTEGER ARITHMETIC UP TO 5212632 IS AVAILABLE,
C THE PRECEDING 6 STATEMENTS MAY BE REPLACED BY
C
C IX = MOD(171 * IX, 30269)
C IY = MOD(172 * IY, 30307)
C IZ = MOD(170 * IZ, 30323)
C
C ON SOME MACHINES, THIS MAY SLIGHTLY INCREASE
C THE SPEED. THE RESULTS WILL BE IDENTICAL.
C
RANDOM = AMOD(FLOAT(IX) / 30269.0 + FLOAT(IY) / 30307.0 +
* FLOAT(IZ) / 30323.0, 1.0)
RETURN
END
C DATTIM.FOR program - To access the date and time:
INTERFACE TO SUBROUTINE TIME (N,STR)
CHARACTER*10 STR [NEAR,REFERENCE]
INTEGER*2 N [VALUE]
END
C
C
SUBROUTINE SEEDER(IX,IY,IZ,IIN,IOUT)
C
C SEEDS MUST BE BETWEEN 1 AND 30000
C
CHARACTER*1 QUERY
CHARACTER*10 TSTR
DIMENSION ITIME(8)
C
WRITE(IOUT,50)
50 FORMAT(/' Do you wish to enter the random number generator''s',
* ' seeds yourself? (Y or N): '$)
READ (IIN,60) QUERY
60 FORMAT(A1)
IF (QUERY.NE.'Y' .AND. QUERY.NE.'y') GOTO 200
C
C ENTER SEEDS
C
70 WRITE(IOUT,80)
80 FORMAT(/' Enter three seeds between 1 and 30000 separated',
* ' by commas:')
READ(IIN,*,ERR=70) IX,IY,IZ
IF (IX.LE.1 .OR. IX.GE.30000 .OR. IY.LE.1 .OR. IY.GE.30000
* .OR. IZ.LE.1 .OR. IZ.GE.30000) GOTO 70
RETURN
C
C GET SEEDS FROM CLOCK
C
200 CALL TIME (10,TSTR)
DO 210 I = 1,8
210 ITIME(I) = ICHAR(TSTR(I:I)) - 48
C
IX = ITIME(8) + 10 * (ITIME(7) + 10 * (ITIME(5) + 10 * (ITIME(4) +
* 10 * (ITIME(2) + 10 * ITIME(1)))))
IY = ITIME(2) + 10 * (ITIME(1) + 10 * (ITIME(8) + 10 * (ITIME(7) +
* 10 * (ITIME(5) + 10 * ITIME(4)))))
IZ = ITIME(5) + 10 * (ITIME(4) + 10 * (ITIME(2) + 10 * (ITIME(1) +
* 10 * (ITIME(8) + 10 * ITIME(7)))))
IY = 1 + MOD(IY,29999)
IZ = 1 + MOD(IZ,29999)
RETURN
END