Trailing-Edge
-
PDP-10 Archives
-
decuslib20-03
-
decus/20-0093/mess3b.for
There are no other files named mess3b.for in the archive.
C MICHIGAN EXPERIMENTAL SIMULATION SUPERVISOR
C VERSION 3-SB
C JANUARY, 1973
C ROBERT L. STOUT
C REVISED SEPT. 1975
C
C
IMPLICIT INTEGER*4 (A-H,P-Z), INTEGER*4 (O)
C
C------------------------------
C
C SIMULATION VARIABLES
INTEGER*4 VLIST(8,50),VNUM(50),GVNPTR(36),VSPTR(36),TYPE(36),
1 KWR(2,36), KWLIST(8,120)
INTEGER*4 SPECI(12,32),DSPECI(12),SPECF(12,32),DSPECF(12)
INTEGER*4 KVAL(120),IVARS(12,32),DIVARS(12)
REAL*4 FVARS(12,32), DFVARS(12)
LOGICAL*4 ENTERD(36),FLAGS(12,32),DFLAGS(12)
C
C
COMMON /VARS/ IVARS, FVARS, SPECI, SPECF, FLAGS, ENTERD
C
INTEGER*4 SI(12), SF(12)
INTEGER*4 IV(12)
REAL*4 FV(12)
LOGICAL*4 FLGS(12)
C
COMMON /VARS1/ IV,FV,SI,SF,FLGS
C
INTEGER*4 CONDS
C MAXCWS IS THE MAXIMUM NUMBER OF CONDITIONS WHICH CAN BE
C APPLIED TO A GIVEN SUBJECT IN A WITHIN-SUBJECTS DESIGN FOR
C ANY MODEL. PARTICULAR MODELS MAY FURTHER LIMIT THE NUMBER OF
C CONDITIONS TO A MINIMUM OF 1 (BETWEEN SUBJECTS DESIGNS ONLY)
C BY GIVING APPROPRIATE VALUES TO THE GSC VARIABLE MAXCONDS
C (INTERNAL FORTRAN NAME MAXC1).
!! DATA MAXCWS/16/
COMMON /CNDTNS/NC1,CONDS(16)
C
C VARIABLES-CONSTANT-ACROSS-CONDITIONS-IN-WITHIN-SUBJECTS-DESIGNS
C STUFF
INTEGER*4 VCWS(12)
C
C------------------------------
C
C SYSTEM PARAMETERS
C NIVMAX IS THE MAXIMUM NUMBER OF INTEGER (NUMI,KWD,KI,IND) VARS
C NFVMAX IS THE MAXIMUM NUMBER OF FLOATING POINT (NUMF,KF) VARS
C NFGMAX IS THE MAXIMUM NUMBER OF LOGICAL (FLAG) VARS
C MAXC IS THE MAXIMUM NUMBER OF CONDITIONS WHICH CAN BE DEFINED
!! DATA NIVMAX/12/,NFVMAX/12/,NFGMAX/12/
!! DATA MAXC/32/
C
C------------------------------
C
C ODDS AND ENDS
INTEGER*4 NVEC(8,3),KWVEC(8,3),NAME(8)
REAL*4 FVEC(3)
INTEGER*4 RCTR(36),RPTR(36),ICOND(2,25),CC(2), TESTS(3,40)
REAL*4 RANGE(2,50), TCONS(40)
REAL*4 FNUM,X,X1,X2
!! DATA BLANK/' '/
INTEGER*4 LINE
C
COMMON /IO/IDEV1,IDEV2,IDEV3,IDEV4,ODEV1,ODEV2,ODEV3,ODEV4,
1 LINE(80)
C
C NOVNAM IS THE MAXIMUM NUMBER OF OUTPUT VARIABLE NAMES (2ND
C DIMENSION OF OVNAM)
!! DATA NOVNAM/6/
INTEGER*4 SINK
INTEGER*4 OVNAM(8,6)
LOGICAL*4 COSTPT, DATOUT
COMMON /IO1/NOV,SINK,OVNAM,COSTPT,DATOUT
C
LOGICAL*4 WDES
INTEGER*4 NPG(32),REPMES(8,3),CCH(2,16)
!! DATA REPMES/'R','*',6*' ', 'W','*',6*' ', 'S','*',6*' '/
C
LOGICAL*4 EOK,EXPTON,SHORT,VSHORT,VF(36),EPRNT,TV,PF
!! DATA EXPTON/.FALSE./
!! DATA SHORT/.FALSE./, VSHORT/.FALSE./
INTEGER*4 IDLINE(80), EOSIND(4)
!! DATA EOSIND/'@','E','N','D'/
C
LOGICAL*4 LOK,T,F,ECHOF
!! DATA T/.TRUE./, F/.FALSE./
C
C------------------------------
C
C COMMAND DECODER STUFF
!! DATA NCMDS/22/, NCNAM/0/, NCNMAX/44/, NRUNS/0/, TNGRPS/0/
INTEGER*4 CMD(8),CMDTBL(8,44),CNUM(44)
INTEGER*4 CMDRTN
C
C CPFX CONTAINS THE ALLOWABLE SUPERVISOR COMMAND PREFIX CHARACTER
C PAIRS, AND NCPFX IS THE NUMBER OF SUCH CHARACTER PAIRS.
C TO CHANGE PREFIX CHARACTERS, ALTER THE DATA BELOW AND IN SUB-
C ROUTINE INPUT
INTEGER*4 CPFX(2,3)
!! DATA NCPFX/3/, CPFX/'>','>','<','<','&','&'/
LOGICAL*4 RPT
!! DATA RPT/.FALSE./
C
C STATISTICS OPTIONS STUFF
LOGICAL*4 STTIND, DSTIND(5),LT,AUTDEF
COMMON /STAT1/ STTIND(5)
!! DATA AUTDEF/.FALSE./, DSTIND/5*.FALSE./
!! DATA NAMSTT/21/, NSTATS/5/
INTEGER*4 STATNM(8,21), STATNO(21), GSONM(5)
!! DATA STATNO/1,1,1,2,2,2,3,3,3,4,4,5,5,5,-1,-2,-3,-3,-3,-4,-4/
!! DATA GSONM/1,4,7,10,12/
!! DATA STATNM/'M','E','A','N',4*' ','M','*',6*' ','A','*','V','*',
!! X4*' ','V','A','R','I','A','N','C','E','V','*',6*' ','S','*','D',
!! X'*',4*' ','S','U','M','S','Q','R','S',' ','S','S',6*' ','S','*',
!! X'Q','*',4*' ','C','O','V',5*' ','C','*','V','*',4*' ','C','O',
!! X'R','R',4*' ','C','*','R','*',4*' ','R','*',6*' ','A','L','L',
!! X5*' ','O','F','F',5*' ','A','U','T','O','D','E','F',' ','A','*',
!! X'D','*',4*' ','A','*','F','*',4*' ','N','O','A','U','T','O','D',
!! X'F','N','*','A','*',4*' '/
C
C**************************************************
C
C SYSTEM INITIALIZATION
C
DOUBLE PRECISION MODNM1,MODNM2,MODNM3
COMMON /DATANM/ MODNM1,MODNM2,MODNM3
C
C ACTIVE DATA STATEMENTS
DATA MAXCWS/16/
DATA NIVMAX/12/,NFVMAX/12/,NFGMAX/12/
DATA MAXC/32/
DATA BLANK/' '/
DATA NOVNAM/6/
DATA REPMES/'R','*',6*' ', 'W','*',6*' ', 'S','*',6*' '/
DATA EXPTON/.FALSE./
DATA SHORT/.FALSE./, VSHORT/.FALSE./
DATA EOSIND/'@','E','N','D'/
DATA T/.TRUE./, F/.FALSE./
DATA NCMDS/22/, NCNAM/0/, NCNMAX/44/, NRUNS/0/, TNGRPS/0/
DATA NCPFX/3/, CPFX/'>','>','<','<','&','&'/
DATA RPT/.FALSE./
DATA AUTDEF/.FALSE./, DSTIND/5*.FALSE./
DATA NAMSTT/21/, NSTATS/5/
DATA STATNO/1,1,1,2,2,2,3,3,3,4,4,5,5,5,-1,-2,-3,-3,-3,-4,-4/
DATA GSONM/1,4,7,10,12/
DATA STATNM/'M','E','A','N',4*' ','M','*',6*' ','A','*','V','*',
X4*' ','V','A','R','I','A','N','C','E','V','*',6*' ','S','*','D',
X'*',4*' ','S','U','M','S','Q','R','S',' ','S','S',6*' ','S','*',
X'Q','*',4*' ','C','O','V',5*' ','C','*','V','*',4*' ','C','O',
X'R','R',4*' ','C','*','R','*',4*' ','R','*',6*' ','A','L','L',
X5*' ','O','F','F',5*' ','A','U','T','O','D','E','F',' ','A','*',
X'D','*',4*' ','A','*','F','*',4*' ','N','O','A','U','T','O','D',
X'F','N','*','A','*',4*' '/
C*****************************************************************
C
C DEFINE LOCATION OF DATA FILES TO BE READ BY SUPERVISOR PROGRAM
C 24=INPUT DEVICE NUMBER; MODNMI=ASCII MODEL NAME
C DEFINED IN MODEL SUBROUTINE
C 4030=PROJECT NUMBER USED AT U MONTANA
C 11=PROGRAMMER NUMBER USED AT U MONTANA
C
OPEN(UNIT=24,ACCESS='SEQIN',MODE='BINARY',FILE=MODNM3,
1DIRECTORY='4030,11')
C
C STUDENT INPUT
IDEV1=5
C
C SIMULATION COMMANDS AND VARIABLES:
C READS SIMULATOR DATA DECK
IDEV2=24
C
C SIMULATION PARAMETERS (NUMBERS):
C READS MODEL INITIALIZATION DECK(NOT USED FOR ALL MODELS)
IDEV3=23
C
C NOT USED
IDEV4=0
C
C STUDENT OUTPUT
C BATCHK SETS ODEV1=5 IF A TERMINAL JOB; ODEV1=3 IF A BATCH JOB
C BATCHK MAY BE SPECFIC TO THE MONTANA-SYSTEM 10
C HOWEVER A SMALL AMOUNT OF REPROGRAMING IN THE MACRO PROGRAM
C BATCH.MAC WILL CORRECT ANY DIFFICULTIES.
CALL BATCHK(ODEV1)
C
C DATA OUT
ODEV2=21
C
C XPRINT OUTPUT
ODEV3=3
C
C USED FOR SAVBIN AND SAVCARD FILES(NOT NORMALLY USED)
ODEV4=20
SINK=ODEV1
DATOUT=.FALSE.
C
C PRINT SYSTEM ID
WRITE(ODEV1,1000)
1000 FORMAT(1H1,'MICHIGAN-MONTANA EXPERIMENTAL SIMULATION SUPERVISOR '/
1 1X,'VERSION 3-SB.3',5X,'SEPTEMBER, 1975'/
2 1X,'WRITTEN BY ROBERT L STOUT',/
3 1X,'ADAPTED TO THE DEC-SYSTEM-10 BY'
4 /1X,'JAMES R ULLRICH AND ROY F TOUZEAU',
5 /1H0)
1102 FORMAT(1X,80A1)
C
C------------------------------
C
C JIGGLE RANDOM NOS. GENERATOR
CALL JIGGLE
C
C MODEL INITIALIZATION
CALL MINIT(&10)
GO TO 11
C MODEL INITIALIZATION FAILURE
10 STOP '10'
11 CONTINUE
C
C
C**************************************************
C
C THIS SECTION LOADS SIMULATION DATA
C
C LIST MODEL IDENTIFICATION LINES
101 LPTR=1
READ(IDEV2)LINE
C
C SEARCH FOR EOS INDICATOR IN LINE
CALL SFIND(EOSIND,LINE,4,80,LPTR,I,J,&104)
C END OF MODEL IDENT LINES
GO TO 107
C
C LIST LINE ON ODEV1
104 JMAX=JMAXX(LINE,80)
WRITE (ODEV1,1102) (LINE(III),III=1,JMAX)
GO TO 101
C
C------------------------------
C
C READ SIMULATION DATA PREPARED BY PROGRAMMER'S VERSION
107 READ(IDEV2)VLIST,VNUM,GVNPTR,VSPTR,TYPE,KWR
READ(IDEV2)KWLIST
READ(IDEV2)KVAL,DIVARS,DFVARS,DSPECI,DSPECF,DFLAGS
READ(IDEV2)RANGE,TCONS,RCTR,RPTR,ICOND,TESTS
READ(IDEV2)NOV,NDEF,MAXC1,NOVER,NGRP,NVCWS,NVARS,NVN,NKW,NRUSED,
1 NTESTS,NICOND,OVNAM,VCWS,DSTIND,COSTPT,ECHOF
DO 109 I=1,NSTATS
109 STTIND(I)=DSTIND(I)
C
C READ TABLE OF COMMANDS
I=1
110 READ(IDEV2,END=111)(CMDTBL(J,I),J=1,8),CNUM(I)
I=I+1
GO TO 110
C
C END OF LOADING
111 NCNAM=I-1
C
C**************************************************
C
C COMMAND DECODER SECTION
C
C
C THIS SECTION WAITS FOR A LINE CONTAINING A SUPERVISOR
C COMMAND
C
C REQUEST SUPERVISOR COMMAND
490 WRITE(ODEV1,5002)
C
C WAIT FOR COMMAND
491 ASSIGN 490 TO CMDRTN
CALL INPUT(IDEV1,ECHOF,&492,&500)
C
C GOT A LINE WITHOUT A SUPERVISOR COMMAND
493 WRITE(ODEV1,5001)
GO TO 491
C
C
C THIS SECTION IMPLEMENTS THE STOP COMMAND
C END-OF-FILE INTERPRETED SAME AS STOP COMMAND
C PRINT STATISTICS
492 WRITE(ODEV1,5003)NRUNS,TNGRPS
STOP
C
GO TO 490
C
C
C COMMAND DECODER PROPER
C COME HERE WITH COMMAND IN LINE(80)
C
500 DO 501 IC3=1,NCPFX
CALL SFIND(CPFX(1,IC3),LINE,2,80,1,IC1,IC2,&501)
GO TO 504
501 CONTINUE
GO TO 493
C
C TRY TO FIND OUT WHICH COMMAND IT IS
504 IC2=IC2+1
CALL NEXT(IC2,CMD,CBC,NUMC,FNUMC,F,&502,&502,&502)
C DECODE COMMAND, IF POSSIBLE
CALL NSRCH(CMD,CMDTBL,1,NCNAM,NCN,&502)
C GET NUMBER OF COMMAND
NCMD=CNUM(NCN)
C
C BRANCH TO COMMAND EXECUTION SECTION
GO TO (492,599,600,510,511,502,502,599,520,508,513,514,
1 515,540,516,509,502,502,562,563,564,565),NCMD
STOP '500'
C
C
C ILLEGAL COMMAND, OR NONE AT ALL
502 JMAX=JMAXX(LINE,80)
WRITE(ODEV1,5005)(LINE(IC2),IC2=IC1,JMAX)
GO TO 599
C
C RETURN FROM COMMAND DECODER
598 WRITE(ODEV1,5006)
599 GO TO CMDRTN,(490,601,603,607,700,750)
C
C------------------------------
C
C THIS SECTION IMPLEMENTS THE COMMANDS COMMAND
508 IC1=0
WRITE(ODEV1,5007)
DO 507 IC2=1,NCNAM
IF(IC1.EQ.CNUM(IC2))GO TO 507
WRITE(ODEV1,1542)(CMDTBL(IC1,IC2),IC1=1,8)
IC1=CNUM(IC2)
507 CONTINUE
WRITE(ODEV1,1525)
GO TO 599
C
C
C THIS SECTION IMPLEMENTS THE ECHO COMMAND
510 ECHOF=.TRUE.
WRITE(ODEV1,5006)
GO TO 599
C
C
C THIS SECTION IMPLEMENTS THE NOECHO COMMAND
511 ECHOF=.FALSE.
GO TO 598
C
C
C THIS SECTION IMPLEMENTS THE SHORT COMMAND
513 SHORT=.TRUE.
VSHORT=.FALSE.
GO TO 598
C
C
C THIS SECTION IMPLEMENTS THE VSHORT COMMAND
514 VSHORT=.TRUE.
SHORT=.FALSE.
GO TO 598
C
C
C THIS SECTION IMPLEMENTS THE LONG COMMAND
515 SHORT=.FALSE.
VSHORT=.FALSE.
GO TO 598
C
C
C THIS SECTION IMPLEMENTS THE REPEAT COMMAND
516 RPT=.TRUE.
NRPT1=0
C DEFAULT REPEAT COUNT IS 2
NRPT=2
C LOOK FOR COUNT IN COMMAND
517 CALL NEXT(IC2,CMD,CBC,NUMC,FNUMC,F,&518,&517,&598)
GO TO 519
C
C HAVE COUNT
518 NRPT=NUMC
IF(NRPT.GT.0 .AND. NRPT.LE.500)GO TO 598
519 RPT=.FALSE.
GO TO 502
C
C
C THIS SECTION IMPLEMENTS THE NORPT COMMAND
509 RPT=.FALSE.
GO TO 598
C
C
C THIS SECTION IMPLEMENTS THE DATAOUT COMMAND
562 DATOUT=.TRUE.
GO TO 598
C
C
C THIS SECTION IMPLEMENTS THE NODATOUT COMMAND
563 DATOUT=.FALSE.
GO TO 598
C
C
C THIS SECTION IMPLEMENTS THE XPRINT COMMAND
564 SINK=ODEV3
GO TO 598
C
C
C THIS SECTION IMPLEMENTS THE NOXPRINT COMMAND
565 SINK=ODEV1
GO TO 598
C
C------------------------------
C
5001 FORMAT(' NO SUPERVISOR COMMAND IN PRECEDING LINE.')
5002 FORMAT(1H0,'ENTER SUPERVISOR COMMAND')
5003 FORMAT(1H0,4X,'NUMBER OF EXPERIMENTAL RUNS',I5/
1 5X,'NUMBER OF GROUPS SIMULATED ',I5)
5005 FORMAT(' ILLEGAL COMMAND: ',80A1)
5006 FORMAT(' OK')
5007 FORMAT(1H0,'COMMANDS AVAILABLE:')
C
C------------------------------
C
C THIS SECTION IMPLEMENTS THE VARS COMMAND
C PRINT HEADING
520 WRITE(ODEV1,1520)
C
DO 521 NV5=1,NVARS
C SKIP INTERNAL-ONLY VARIABLES
IF(TYPE(NV5).GT.7)GO TO 521
C GET VARIABLE NAME
J50=GVNPTR(NV5)
DO 522 K50=1,8
522 NAME(K50)=VLIST(K50,J50)
C
C BRANCH ON TYPE
I50=TYPE(NV5)
GO TO (523,523,524,524,524,524,525),I50
STOP '521'
C
C FLAG VARIABLES ARE EASY
525 WRITE(ODEV1,1522)NAME
GO TO 521
C
C KWD,KI,KF,IND VARIABLES
524 J50=KWR(1,NV5)
K50=KWR(2,NV5)
L50=1000
M50=KVAL(J50)+1
C
C PRINT LIST OF ALL KEYWORD VALUES
DO 526 N50=J50,K50
C JUST PRINT 1ST KWD NAME FOR EACH KWD VALUE
IF(KVAL(N50).EQ.M50)GO TO 526
M50=KVAL(N50)
IF(L50.LE.51)GO TO 527
IF(N50.EQ.J50)GO TO 528
C
C PRINT LINE
JMAX=JMAXX(LINE,80)
WRITE(ODEV1,1522) NAME,(LINE(III),III=1,JMAX)
C ERASE NAME
DO 529 I51=1,8
529 NAME(I51)=BLANK
C ERASE LINE
528 DO 530 I51=1,80
530 LINE(I51)=BLANK
L50=1
C
C INSERT KWD IN LINE
527 DO 531 I51=1,8
LINE(L50)=KWLIST(I51,N50)
531 L50=L50+1
L50=L50+2
526 CONTINUE
C
C FINISH LAST LINE
JMAX=JMAXX(LINE,80)
WRITE(ODEV1,1522) NAME,(LINE(III),III=1,JMAX)
C
DO 532 I51=1,8
532 NAME(I51)=BLANK
C
C BRANCH ON TYPE AGAIN
IF(TYPE(NV5).NE.4 .AND. TYPE(NV5).NE.5)GO TO 521
C
C NUMI,NUMF,KI, AND KF VARIABLES
523 IF(RCTR(NV5).GT.0)GO TO 533
C
C NO LIMITATIONS ON VALUE OF VARIABLE
WRITE(ODEV1,1523)NAME
GO TO 521
C
C PRINT NUMERIC RANGES
533 J50=RCTR(NV5)
K50=RPTR(NV5)
DO 534 L50=1,J50
M50=K50+L50-1
WRITE(ODEV1,1524)NAME,RANGE(1,M50),RANGE(2,M50)
DO 535 I51=1,8
535 NAME(I51)=BLANK
534 CONTINUE
521 CONTINUE
WRITE(ODEV1,1525)
GO TO 599
C
C------------------------------
C
1520 FORMAT(1H0,'VARIABLE LEGAL VALUES')
1522 FORMAT(1X,8A1,3X,80A1)
1523 FORMAT(1X,8A1,3X,'ANY NUMERIC VALUE')
1524 FORMAT(1X,8A1,2X,G10.4,' TO ',G10.4)
1525 FORMAT('0 ')
C
C------------------------------
C
C THIS SECTION IMPLEMENTS THE STAT COMMAND
C
C READ NEXT STAT OPTION FROM LIST
540 CALL NEXT(IC2,CMD,CBC,NUMC,FNUMC,F,&540,&540,&541)
C
C DECODE OPTION
542 CALL NSRCH(CMD,STATNM,1,NAMSTT,NCN,&543)
NCMD=STATNO(NCN)
IF(NCMD.LT.0)GO TO 544
C
C ENABLE THE OPTION SPECIFIED
STTIND(NCMD)=.TRUE.
GO TO 540
C
C BRANCH ON VALUE
544 NCMD=-NCMD
GO TO (546,547,552,553),NCMD
STOP '544'
C
C -1 = ALL
546 DO 548 IC1=1,NSTATS
548 STTIND(IC1)=.TRUE.
GO TO 540
C
C -2 = OFF
547 DO 549 IC1=1,NSTATS
549 STTIND(IC1)=.FALSE.
GO TO 540
C
C -3 = AUTODEF
552 AUTDEF=.TRUE.
GO TO 540
C
C -4 = NOAUTODF
553 AUTDEF=.FALSE.
GO TO 540
C
C EOL MEANS END OF STAT OPTIONS
C PRINT THE OPTIONS CURRENTLY ENABLED
541 LT=.TRUE.
WRITE(ODEV1,1541)
DO 551 IC1=1,NSTATS
IF(.NOT.STTIND(IC1))GO TO 551
LT=.FALSE.
IC2=GSONM(IC1)
C WRITE GENERIC NAME OF STATISTIC
WRITE(ODEV1,1542)(STATNM(I551,IC2),I551=1,8)
551 CONTINUE
IF(LT)WRITE(ODEV1,1543)
GO TO 599
C
C UNIDENTIFIABLE STAT OPTION
543 WRITE(ODEV1,1540)CMD
GO TO 540
C
C------------------------------
C
1540 FORMAT(' ''',8A1,''' IS UNIDENTIFIABLE.')
1541 FORMAT(' STATISTICS OPTIONS ENABLED:')
1542 FORMAT(4X,8A1)
1543 FORMAT(4X,'NONE')
C
C**************************************************
C
C THIS SECTION RUNS SIMULATED EXPERIMENTS
C
600 EOK=.TRUE.
IF(.NOT.EXPTON)GO TO 617
WRITE(ODEV1,1614)
IF(.NOT.AUTDEF)GO TO 617
C
C SET UP DEFAULT STATISTICS
DO 618 I=1,NSTATS
618 STTIND(I)=DSTIND(I)
WRITE(ODEV1,1706)
C
617 EXPTON=.TRUE.
NRUNS=NRUNS+1
C
C GET ID LINE
601 WRITE(ODEV1,1600)
ASSIGN 601 TO CMDRTN
CALL INPUT(IDEV1,ECHOF,&492,&500)
DO 602 I=1,80
602 IDLINE(I)=LINE(I)
C
C REQUEST NO. OF EXPTL CONDITIONS
ASSIGN 603 TO CMDRTN
603 WRITE(ODEV1,1601)
CALL INPUT(IDEV1,ECHOF,&492,&500)
LPTR=1
605 CALL NEXT(LPTR,NAME,BC,NUM,FNUM,F,&604,&605,&699)
GO TO 697
C
C TEST LEGALITY
604 IF(NUM.LE.0 .OR. NUM.GT.MAXC)GO TO 696
NC=NUM
C
C------------------------------
C
C ASK STUDENT TO DEFINE EXPERIMENTAL CONDITIONS
NPC=0
IERROR=0
606 ASSIGN 607 TO CMDRTN
WRITE(ODEV1,1602)
CALL INTERP(IDEV1,0,ECHOF,NVARS,NVN,NKW,NIVMAX,NFVMAX,NFGMAX,
1 NERR,MAXC,NPC,NCG,VLIST,VNUM,GVNPTR,VSPTR,TYPE,ENTERD,KWR,
2 KWLIST,KVAL,IVARS,SPECI,DIVARS,DSPECI,FVARS,SPECF,DFVARS,DSPECF,
3 FLAGS,DFLAGS,&492,&500)
C
609 IERROR=IERROR+NERR
NPC=NPC+NCG
WRITE(ODEV1,1603)NPC
IF(NC-NPC)695,608,606
C
C
607 WRITE(ODEV1,1615)
CALL INTP1(NERR,NCG,&492,&500)
GO TO 609
C
C
C ALL CONDITIONS HAVE BEEN DEFINED
608 IF(IERROR.GT.0)GO TO 694
C
DO 610 I=1,NVARS
610 VF(I)=.FALSE.
C
IF(VSHORT .OR. NC.EQ.1)GO TO 615
C
C PRINT LIST OF VARIABLES WHOSE SETTINGS ARE CONSTANT
C ACROSS ALL CONDITIONS, UNLESS SHORT OR VSHORT IN EFFECT
C
C FIGURE OUT WHICH VARIABLES IN FACT ARE CONSTANT
DO 611 I=1,NVARS
VP=VSPTR(I)
TP=TYPE(I)
CALL VALUE(VP,TP,1,X1,IX1,&613)
613 DO 612 J=2,NC
JTMP=J
CALL VALUE(VP,TP,JTMP,X2,IX2,&614)
IF(X1.NE.X2 .OR. IX1.NE.IX2)GO TO 611
GO TO 612
614 IF((FLAGS(VP,1).AND. .NOT.FLAGS(VP,J)) .OR.
1 (.NOT.FLAGS(VP,1).AND.FLAGS(VP,J)))GO TO 611
612 CONTINUE
VF(I)=.TRUE.
611 CONTINUE
IF(SHORT)GO TO 615
C
C PRINT LIST
NC1=1
WRITE(SINK,1604)
ASSIGN 615 TO I670
GO TO 670
C
615 DO 616 I=1,NVARS
616 VF(I)=.NOT.VF(I)
IF((SHORT.OR.NC.EQ.1) .AND. .NOT.VSHORT)WRITE(SINK,1612)
C
C
C PRINT VALUES FOR EACH CONDITION (UNLESS VSHORT=T) WITH ERROR
C MESSAGES AS APPROPRIATE
DO 620 NC1=1,NC
EPRNT=.TRUE.
NC1TMP=NC1
CALL CCHARS(NC1TMP,CC)
IF(VSHORT)GO TO 621
C
C CONDITION HEADER
WRITE(SINK, 1607)CC
C PRINT VALUES
ASSIGN 621 TO I670
GO TO 670
C
C------------------------------
C
C SEE IF VALUES ARE IN PROPER RANGES
621 DO 622 NV=1,NVARS
IF(RCTR(NV).LE.0)GO TO 622
I1=RCTR(NV)
I2=RPTR(NV)
NVTMP=NV
CALL VALUE(VSPTR(NVTMP),TYPE(NVTMP),NC1TMP,X1,IX1,&622)
IF(IX1.NE.0)GO TO 622
C
DO 623 I=1,I1
J=I2+I-1
IF(RANGE(1,J).LE.X1 .AND. X1.LE.RANGE(2,J))GO TO 622
623 CONTINUE
C
C ILLEGAL VALUE
IF(EPRNT.AND.VSHORT)WRITE(ODEV1,1613)CC
EPRNT=.FALSE.
I1=GVNPTR(NV)
WRITE(ODEV1,1608)(VLIST(J,I1),J=1,8)
EOK=.FALSE.
622 CONTINUE
C
C------------------------------
C
C TEST FOR OTHER ILLEGAL CONDITIONS, IF ANY
IF(NICOND.LE.0)GO TO 620
DO 625 I=1,NICOND
I1=ICOND(1,I)
I2=ICOND(2,I)
C
C CHECK FOR ILLEGAL CONDITION
DO 626 J=I1,I2
NV1=TESTS(1,J)
NV1=IABS(NV1)
C
C GET VALUE FOR 1ST VARIABLE
CALL EVAL(TESTS(1,J),TYPE(NV1),VSPTR(NV1),NC1TMP,X1,&625)
C
K=TESTS(2,J)
K=IABS(K)
IF(K.NE.1)GO TO 630
C
C RANGE TEST
K=TESTS(3,J)
TV=RANGE(1,K).LE.X1 .AND. X1.LE.RANGE(2,K)
GO TO 631
C
C GET X2 VALUE
630 IF(TESTS(3,J).NE.0)GO TO 632
C X2=CONSTANT
X2=TCONS(J)
GO TO 633
C X2=VARIABLE
632 NV2=TESTS(3,J)
NV2=IABS(NV2)
CALL EVAL(TESTS(3,J),TYPE(NV2),VSPTR(NV2),NC1TMP,X2,&625)
C
633 TV=(K.EQ.2 .AND. X1.EQ.X2).OR.(K.EQ.3 .AND. X1.GT.X2).OR.
1 (K.EQ.4 .AND. X1.LT.X2)
C
631 IF(TESTS(2,J).LT.0)TV=.NOT.TV
IF(.NOT.TV)GO TO 625
626 CONTINUE
C
C ILLEGAL CONDITION HOLDS
EOK=.FALSE.
IF(EPRNT.AND.VSHORT)WRITE(ODEV1,1613)CC
EPRNT=.FALSE.
WRITE(ODEV1,1609)
C
C PRINT LIST OF VARIABLES INVOLVED IN ERROR
PF=.FALSE.
LPTR=100
DO 634 J=I1,I2
M=1
638 K=TESTS(M,J)
K=IABS(K)
K=GVNPTR(K)
C
IF(LPTR.LE.64)GO TO 635
IF(PF)WRITE(ODEV1,1102)LINE
PF=.TRUE.
DO 636 L=1,80
636 LINE(L)=BLANK
LPTR=1
C
635 DO 637 L=1,8
LINE(LPTR)=VLIST(L,K)
637 LPTR=LPTR+1
LPTR=LPTR+1
C
IF(M.NE.1)GO TO 634
IF(TESTS(2,J).EQ.1 .OR. TESTS(2,J).EQ.-1 .OR. TESTS(3,J).EQ.0)
1 GO TO 634
M=3
GO TO 638
634 CONTINUE
WRITE(ODEV1,1102)LINE
C
625 CONTINUE
620 CONTINUE
NC1=NC
IF(.NOT.EOK)GO TO 694
GO TO 700
C
C------------------------------
C
C THIS SECTION PRINTS VALUES FOR ALL EXTERNAL VARIABLES
C INDICATED BY TRUE VALUES IN VF
C VALUES ARE THOSE FOR CONDITION NC1
C
670 NVPTD=0
C
C FIRST PRINT ALL VARIABLES WITH KWD VALUES
N67=1
DO 671 I67=1,NVARS
IF(.NOT.VF(I67))GO TO 671
J67=TYPE(I67)
GO TO (671,671,672,673,673,672,671,671,671,671),J67
STOP '670'
C
C KI/KF VARIABLES
673 CALL VALUE(VSPTR(I67),TYPE(I67),NC1,X,IX,&695)
IF(IX.EQ.0)GO TO 671
GO TO 674
C
C KWD/IND VARIABLES
672 J67=VSPTR(I67)
IX=IVARS(J67,NC1)
C
C GET GENERIC KWD NAME
674 NVPTD=NVPTD+1
L67=KWR(1,I67)
M67=KWR(2,I67)
DO 675 J67=L67,M67
IF(KVAL(J67).EQ.IX)GO TO 676
675 CONTINUE
STOP '675'
C PUT KWD IN OUTPUT LIST
676 DO 677 K67=1,8
677 KWVEC(K67,N67)=KWLIST(K67,J67)
C
C PUT GENERIC VARIABLE NAME IN OUTPUT LIST
CALL RJUST(NVEC,N67,VLIST,GVNPTR(I67))
N67=N67+1
IF(N67.LE.3)GO TO 671
N67=1
WRITE(SINK,1605)((NVEC(K67,L67),K67=1,8),(KWVEC(M67,L67),
1 M67=1,8),L67=1,3)
671 CONTINUE
C
C FINISH OUTPUT LINE
IF(N67.LE.1)GO TO 678
N67=N67-1
WRITE(SINK,1605)((NVEC(K67,L67),K67=1,8),(KWVEC(M67,L67),
1 M67=1,8),L67=1,N67)
C
C NOW ALL NUMERIC-VALUED VARIABLES
678 N67=1
DO 680 I67=1,NVARS
IF(.NOT.VF(I67))GO TO 680
J67=TYPE(I67)
GO TO (682,682,680,682,682,680,680,680,680,680),J67
STOP '680'
C
682 CALL VALUE(VSPTR(I67),TYPE(I67),NC1,FVEC(N67),IX,&680)
IF(IX.NE.0)GO TO 680
NVPTD=NVPTD+1
C
C PUT NAME IN OUTPUT ARRAY
CALL RJUST(NVEC,N67,VLIST,GVNPTR(I67))
N67=N67+1
IF(N67.LE.3)GO TO 680
N67=1
WRITE(SINK,1606)((NVEC(J67,K67),J67=1,8),FVEC(K67),K67=1,3)
680 CONTINUE
N67=N67-1
IF(N67.LE.0)GO TO 681
WRITE(SINK,1606)((NVEC(J67,K67),J67=1,8),FVEC(K67),K67=1,N67)
C
C PRINT FLAG VARIABLES
681 N67=1
DO 683 I67=1,NVARS
IF((.NOT.VF(I67)) .OR. (TYPE(I67).NE.7))GO TO 683
J67=VSPTR(I67)
IF(.NOT.FLAGS(J67,NC1))GO TO 683
NVPTD=NVPTD+1
C
C FLAG IS UP--PUT VARIABLE NAME IN OUTPUT ARRAY
CALL RJUST(NVEC,N67,VLIST,GVNPTR(I67))
N67=N67+1
IF(N67.LE.3)GO TO 683
N67=1
WRITE(SINK,1616)NVEC
683 CONTINUE
N67=N67-1
IF(N67.GT.0)WRITE(SINK,1616)((NVEC(J67,K67),J67=1,8),K67=1,N67)
C
C IF NO VARIABLES WERE PRINTED, WRITE 'NONE'
IF(NVPTD.LE.0)WRITE(SINK,1611)
C RETURN
GO TO I670,(615,621)
C
C------------------------------
C
1600 FORMAT(1H0,'ENTER EXPERIMENT ID LINE'/)
1601 FORMAT(1H0,'ENTER NO. OF EXPERIMENTAL CONDITIONS'/)
1602 FORMAT(1H0,'DEFINE EXPERIMENTAL CONDITION(S)'/)
1603 FORMAT(1X,I5,' CONDITION(S) DEFINED')
1604 FORMAT(1H1/1H0,'THE FOLLOWING VARIABLE SETTINGS ARE CONSTANT',
1 ' ACROSS ALL CONDITIONS:')
1605 FORMAT(5X,3(8A1,'=',8A1,3X))
1606 FORMAT((5X,3(8A1,'=',G10.4,1X)))
1607 FORMAT(1H0,2X,'VARIABLE SETTINGS FOR CONDITION ',2A1)
1608 FORMAT(' THE VALUE FOR VARIABLE ',8A1,' IS ILLEGAL')
1609 FORMAT(' ILLEGAL COMBINATION OF VALUES INVOLVING VARIABLES:')
1610 FORMAT(1H0,'EXPERIMENT ABORTED DUE TO ERRORS IN INPUT')
1611 FORMAT(5X,'NONE')
1612 FORMAT(1H2)
1613 FORMAT(' CONDITION ',2A1)
1614 FORMAT(' PREVIOUS EXPERIMENT TERMINATED BY COMMAND')
1615 FORMAT(' FINISH DEFINING CONDITION(S)'/)
1616 FORMAT(5X,3(4X,8A1,8X))
C
C------------------------------
C
C ERROR HANDLING
C
C NO. OF EXPTL CONDITIONS WAS NOT GIVEN
699 WRITE(ODEV1,1620)
GO TO 694
C
C NAME WHERE THERE SHOULD HAVE BEEN SOMETHING ELSE
697 WRITE(ODEV1,1621)NAME
GO TO 694
C
C NO. OF CONDITIONS IS OUTSIDE THE RANGE (1,MAXC)
696 WRITE(ODEV1,1622)NUM,MAXC
GO TO 694
C
C TOO MANY CONDITIONS GENERATED
695 WRITE(ODEV1,1623)NC
C
C
C MOST FATAL ERRORS IN STUDENT INPUT EXIT THRU HERE
694 WRITE(ODEV1,1624)
EXPTON=.FALSE.
C
C TAKE CARE OF AUTODEFAULTING OF STATISTICS
IF(.NOT.AUTDEF)GO TO 490
DO 693 I=1,NSTATS
693 STTIND(I)=DSTIND(I)
WRITE(ODEV1,1706)
GO TO 490
C
C------------------------------
C
1620 FORMAT(1H0,'NO. OF EXPTL CONDITIONS WAS NOT SPECIFIED.')
1621 FORMAT(1H0,'''',8A1,''' APPEARS WHERE SOMETHING ELSE',
1 ' SHOULD BE.')
1622 FORMAT(1H0,'NUMBER OF CONDITIONS GIVEN,',I5,', IS OUTSIDE',
1 ' THE RANGE ( 1,',I3,').')
1623 FORMAT(1H0,'MORE THAN ',I3,' CONDITIONS GENERATED BY COND',
1 'ITION DEFINITION INFO.')
1624 FORMAT(1H0,'EXPERIMENT CANCELLED DUE TO ERRORS IN INPUT.'/1H1)
C
C------------------------------
C
C READ NO. OF SUBJECTS PER GROUP
700 WRITE(ODEV1,1700)
ASSIGN 700 TO CMDRTN
CALL INPUT(IDEV1,ECHOF,&492,&500)
LPTR=1
WDES=.FALSE.
NGP=0
C
701 CALL NEXT(LPTR,NAME,BC,NUM,FNUM,F,&702,&701,&705)
C
C NAME BETTER BE 'R*', 'W*', OR 'S*' TO INDICATE REPEATED MEASURES
C DESIGN
DO 703 I=1,3
CALL NMATCH(REPMES(1,I),NAME,&703)
C
C REPEATED MEASURES DESIGN IS INDICATED
WDES=.TRUE.
IF(MAXC1.GT.1)GO TO 701
C
C REPEATED MEASURES DESIGN NOT ALLOWED BY THIS MODEL
WDES=.FALSE.
WRITE(ODEV1,1713)
GO TO 700
C
703 CONTINUE
C UNIDENTIFIABLE NAME
GO TO 799
C
C HAVE A GRP SIZE--PROBABLY
702 IF(NGP.GE.NC)GO TO 797
NGP=NGP+1
IF(NUM.LE.0 .OR. NUM.GT.NGRP)GO TO 798
NPG(NGP)=NUM
GO TO 701
C
C END OF GROUP SIZES LINE
705 IF(NGP.EQ.0)NPG(1)=NDEF
IF(WDES)GO TO 755
C
C HAVE BETWEEN-SUBJECTS DESIGN
C FILL OUT GROUP SIZES TABLE
I=MAX0(NGP,1)
IF(I.GE.NC)GO TO 706
J=I+1
DO 707 K=J,NC
707 NPG(K)=NPG(I)
C
C MAKE SURE OVERALL N IS OK
706 N=0
DO 708 I=1,NC
708 N=N+NPG(I)
IF(N.GT.NOVER)GO TO 796
C
C------------------------------
C
C SIMULATE EACH CONDITION
NC1=1
712 DO 710 NGP=1,NC
CONDS(1)=NGP
C USE OF M99 NECESSITATED BY A BUG IN THE FORTRAN (G) COMPILER
M99=NGP
N=NPG(M99)
C
C PRINT HEADING
ASSIGN 711 TO I740
GO TO 740
711 NGPTMP=NGP
CALL CVALS(NGPTMP)
CALL MODEL(N,1,&694)
C
710 TNGRPS=TNGRPS+1
C
C THIS SECTION IMPLEMENTS THE REPEAT COMMAND FOR BETWEEN-SS DESIGNS
IF(.NOT.RPT)GO TO 725
WRITE(SINK,1708)
NRPT1=NRPT1+1
IF(NRPT1.LT.NRPT)GO TO 712
NRPT1=0
WRITE(ODEV1,1709)NRPT
C
C END OF EXPERIMENT
725 EXPTON=.FALSE.
WRITE(ODEV1,1705)
C
C FIX STATISTICS
IF(.NOT.AUTDEF)GO TO 490
C
C SET UP DEFAULT STATISTICS
DO 726 I=1,NSTATS
726 STTIND(I)=DSTIND(I)
WRITE(ODEV1,1706)
GO TO 490
C
C------------------------------
C
C WITHIN-SUBJECTS DESIGNS HANDLED HERE
755 ASSIGN 750 TO CMDRTN
NGP=0
C
C REQUEST LINE WITH CONDITION LABELS OR COMMAND
750 WRITE(ODEV1,1710)
CALL INPUT(IDEV1,ECHOF,&492,&500)
LPTR=1
NC1=0
N=NPG(1)
C PARSE LINE FOR CONDITION LABELS AND N (OPTIONAL)
751 CALL NEXT(LPTR,NAME,BC,NUM,FNUM,F,&752,&751,&753)
C
C FIND OUT WHAT CONDITION IS INDICATED
CALL CCNUM(NAME,I,NC,&750)
NC1=NC1+1
IF(NC1.GT.MAXC1)GO TO 756
CONDS(NC1)=I
GO TO 751
C
C NUMBER IS ASSUMED TO BE A GROUP SIZE
752 IF(NUM.LE.0 .OR. NUM.GT.NGRP)GO TO 757
N=NUM
GO TO 751
C
C------------------------------
C
C MAKE SURE THIS COMBINATION OF CONDITIONS IS OK
753 IF(NC1.LE.0)GO TO 750
IF(NVCWS.LE.0 .OR. NC1.EQ.1)GO TO 770
C
C TEST THOSE VARIABLES WHICH MUST BE HELD CONSTANT ACROSS CONDITIONS
DO 760 I=1,NVCWS
NUM=VCWS(I)
K=TYPE(NUM)
L=CONDS(1)
C BRANCH ON VARIABLE TYPE
GO TO (761,762,761,761,762,761,763,760,760,760),K
C
C INTEGER VARIABLES
761 K=VSPTR(NUM)
I751=IVARS(K,L)
I752=SPECI(K,L)
DO 764 J=2,NC1
L=CONDS(J)
IF(IVARS(K,L).NE.I751 .OR. SPECI(K,L).NE.I752)GO TO 795
764 CONTINUE
GO TO 760
C
C FLOATING POINT VARIABLES
762 K=VSPTR(NUM)
X1=FVARS(K,L)
I752=SPECF(K,L)
DO 765 J=2,NC1
L=CONDS(J)
IF(FVARS(K,L).NE.X1 .OR. SPECF(K,L).NE.I752)GO TO 795
765 CONTINUE
GO TO 760
C
C FLAG VARIABLES
763 K=VSPTR(NUM)
TV=FLAGS(K,L)
DO 766 J=2,NC1
L=CONDS(J)
IF(TV.AND.FLAGS(K,L))GO TO 766
IF(TV.OR.FLAGS(K,L))GO TO 795
766 CONTINUE
760 CONTINUE
C
C------------------------------
C
C SIMULATE THIS GROUP
770 NGP=NGP+1
C PRINT HEADING
771 ASSIGN 772 TO I740
GO TO 740
C
772 CALL MODEL(N,NC1,&750)
TNGRPS=TNGRPS+1
C
C THIS SECTION IMPLEMENTS THE REPEAT COMMAND FOR WITHIN-SS DESIGNS
IF(.NOT.RPT)GO TO 750
NRPT1=NRPT1+1
WRITE(SINK,1708)
IF(NRPT1.LT.NRPT)GO TO 771
NRPT1=0
WRITE(ODEV1,1709)NRPT
GO TO 750
C
C------------------------------
C
C THIS SECTION PRINTS HEADING BEFORE OUTPUT FOR EACH EXPTL GRP
740 WRITE(SINK,1744)
IF(SHORT.OR.VSHORT)GO TO 744
WRITE(SINK,1740)
JMAX=JMAXX(IDLINE,80)
WRITE(SINK,1102) (IDLINE(III),III=1,JMAX)
CALL TANDD
WRITE(SINK,1741)NGP
744 DO 741 I74=1,16
CCH(1,I74)=BLANK
741 CCH(2,I74)=BLANK
DO 742 I74=1,NC1
J74=CONDS(I74)
CALL CCHARS(J74,CC)
CCH(1,I74)=CC(1)
742 CCH(2,I74)=CC(2)
JMAX=INT(JMAXX(CCH,32)/2.0)+1
WRITE(SINK,1742) ((CCH(III,JJJ),III=1,2),JJJ=1,JMAX)
WRITE(SINK,1743)N
GO TO I740,(711,772)
C
C------------------------------
C
1740 FORMAT(1H2/' ')
1741 FORMAT(' GROUP NUMBER',I3)
1742 FORMAT(' CONDITION(S): ',16(2A1,1X))
1743 FORMAT(' NUMBER OF SUBJECTS:',I5)
1744 FORMAT(1H0)
C
C------------------------------
C
C ERROR HANDLING
C
C UNIDENTIFIABLE NAME IN GROUP SIZE LINE
799 WRITE(ODEV1,1701)NAME
GO TO 694
C
C ILLEGAL VALUE OF N FOR A SINGLE GROUP
798 WRITE(ODEV1,1702)NGP,NUM
GO TO 694
C
C NPG LIST OVERFLOW
797 WRITE(ODEV1,1703)NGP
GO TO 694
C
C OVERALL N TOO LARGE
796 WRITE(ODEV1,1704)N,NOVER
GO TO 694
C
C VARIABLE NOT CONSTANT ACROSS CONDITIONS WHEN IT SHOULD BE
795 L=GVNPTR(NUM)
WRITE(ODEV1,1707)(VLIST(J,L),J=1,8)
GO TO 750
C
C USER IS TRYING TO APPLY TOO MANY CONDITIONS TO THE SUBJECTS
756 WRITE(ODEV1,1711)MAXC1
GO TO 750
C
C INVALID GROUP SIZE IN WITHIN-SS DESIGN
757 N=NGP+1
WRITE(ODEV1,1702)N,NUM
GO TO 750
C
C------------------------------
C
1700 FORMAT(1H0,' ENTER NO. OF SUBJECTS IN EACH GROUP'/)
1701 FORMAT(1H0,'UNIDENTIFIABLE NAME IN GROUP SIZES LINE: ',8A1)
1702 FORMAT(1H0,'ILLEGAL VALUE OF N FOR GROUP',I3,' N=',I5)
1703 FORMAT(1H0,'MORE THAN',I3,' GROUP SIZES GIVEN')
1704 FORMAT(1H0,'OVERALL N=',I5,' LIMIT ON N=',I5)
1705 FORMAT(1H0,1X,'EXPERIMENT COMPLETED.'/1H1)
1706 FORMAT(1X,'DEFAULT STATISTICS IN EFFECT')
1707 FORMAT(1H0,8A1,' MUST BE CONSTANT ACROSS CONDITIONS')
1708 FORMAT('1 ')
1709 FORMAT(1X,I4,' GROUPS SIMULATED')
1710 FORMAT(1H1,'ENTER CONDITIONS FOR NEXT GROUP OR COMMAND'/)
1711 FORMAT(' NO MORE THAN',I3,' CONDITIONS MAY BE ENTERED'/)
1713 FORMAT(1X,'WITHIN-SS DESIGNS NOT ALLOWED BY THIS MODEL'/)
END