Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-03 - decus/20-0093/demo2.for
There are no other files named demo2.for in the archive.
C     DEMO2
C
C     DEMONSTRATION MODEL FOR THE MICHIGAN EXPERIMENTAL SIMULATION
C     SUPERVISOR VERSION 3
C     ROBERT L. STOUT, SIMULATION DESIGNER AND PROGRAMMER
C     SEPTEMBER, 1973
C
      SUBROUTINE MODEL(N,NC1,*)
C
C
      LOGICAL*4 FLGS(12), VPT(6), XINC, XLAZY, MISS, INITLS
      LOGICAL*4 NOTIME, NOQUAL, TBLS
      INTEGER*4 SI(12), SF(12), CONDS(16), TMM, TMF, QM
      INTEGER*4 IV(12), TASK, WORKCD, HLDRS, ODEV1
      REAL*4 FV(12), DMISS(6), DV(6), INCOMP, INCTST, LTEST, INCME
      REAL*4 INC, LTDIST(4), LAZME, PMD(3), LCONST, QUALIN(5,2)
      REAL*4 FTIME(5,3), LAMBDA, FLOAF(2), FERR(2), TC(4), INCLEV(5,2)
      COMMON /VARS1/IV,FV,SI,SF,FLGS
      COMMON /CNDTNS/NCD,CONDS
      COMMON /IO/IDEV1,IDEV2, IDEV3, IDEV4, ODEV1
C
!!      DATA DMISS/6*-1./, VPT/6*.FALSE./
C
C     GIVE IDENTIFIABLE NAMES TO THE INDEPENDENT VARIABLES
      EQUIVALENCE (INCOMP, FV(1)), (LAZY, IV(1)), (WORKCD, IV(2)),
     1 (TASK, IV(3)), (XINC, FLGS(1)), (XLAZY, FLGS(2)), (NOTIME,
     2 FLGS(3)), (NOQUAL, FLGS(4))
C
C     DEPENDENT AND CONCOMITANT VARIABLES GO IN ARRAY DV
      EQUIVALENCE (INCTST, DV(1)), (LTEST, DV(2)), (TIME, DV(3)),
     1 (QUAL, DV(4))
C
C     THE FOLLOWING MODEL PARAMETERS ARE CONTROLLED BY FLOATING POINT
C     VARIABLES WHICH ARE USUALLY DECLARED INT
      EQUIVALENCE (INCME, FV(2)), (LAZME, FV(3)), (C1, FV(4)),
     1 (LCONST, FV(5)), (FSD, FV(6)), (QSD, FV(7)), (T1, FV(8)),
     2 (T2, FV(9)), (T3, FV(10)), (T4, FV(11)), (TBLS, FLGS(12))
C
C     TABLE PMD CONTROLS THE EFFECT OF WORKING CONDITIONS ON THE PROBA-
C     BILITY OF MISSING DATA
!!      DATA PMD/0.02, 0.08, 0.15/
C
C     PINIT = PROB. THAT A GIVEN NAPKIN HOLDER WILL HAVE TO HAVE
C     INITIALS STAMPED ON IT.  PREJ = PROB. THAT A GIVEN HOLDER WILL
C     BE FOUND DEFECTIVE ON FINAL INSPECTION.
!!      DATA PINIT/ .4/, PREJ/ .02/
C
C     COST PARAMETERS
      INTEGER COST5
!!      DATA COST1M/5./, COST1F/2./, COST2/2.5/, COST3/10./, COST4/.10/,
!!     1 COST5/2/, COST6/5./
C
C	MODEL NAME
	DOUBLE PRECISION MODNM1,MODNM2,MODNM3
	COMMON /DATANM/ MODNM1,MODNM2,MODNM3
	DATA MODNM1/'DEMO.DAT'/,MODNM2/'DEMO3.DAT'/,MODNM3/'DEMO.BIN'/
      DATA DMISS/6*-1./, VPT/6*.FALSE./
      DATA PMD/0.02, 0.08, 0.15/
      DATA PINIT/ .4/, PREJ/ .02/
      DATA COST1M/5./, COST1F/2./, COST2/2.5/, COST3/10./, COST4/.10/,
     1 COST5/2/, COST6/5./
C********************
C
C     SET UP OUTPUT FLAGS FOR FPOUT
      VPT(1)=.FALSE.
      VPT(2)=.FALSE.
      VPT(3)=.FALSE.
      VPT(4)=.FALSE.
      DO 1 I=1,NC1
      J=CONDS(I)
      CALL CVALS(J)
C
C     INCOMPETENCE TEST SCORES ARE PRINTED ONLY IF 'XINC' IS SPECIFIED
      VPT(1)=VPT(1) .OR. XINC
C     SAME FOR LAZINESS
      VPT(2)=VPT(2) .OR. XLAZY
C
C     TIME IS TO BE PRINTED UNLESS 'NOTIME' IS SPECIFIED
      VPT(3)=VPT(3) .OR. .NOT.NOTIME
C     SAME FOR QUALITY
 1    VPT(4)=VPT(4) .OR. .NOT.NOQUAL
      CALL FPOUT1(VPT, DMISS, &99)
C
      TMM=0
      TMF=0
      QM=0
C
C********************
C
C     SIMULATE THE REQUISITE NUMBER OF SUBJECTS
      DO 10 I=1,N
      K=CONDS(1)
      CALL CVALS(K)
C
C--------------------
C
C     SELECT INDIVIDUAL DIFFERENCES PARAMETERS AS NECESSARY
C
C     INCOMPETENCE:
      INCTST=INCOMP
C
C     EVEN IF INC IS CONTROLLED, IT IS NOT PERFECTLY CONTROLLED
      CALL URAND1( -.5, .5, X)
      INCTST=INCTST+X
      IF(INCTST .LT. 0.)INCTST=0.
      IF(INCTST .GT. 10.)INCTST=10.
C
C     IF INCOMPETENCE IS RANDOM, SELECT A TEST SCORE FROM AN UNIFORM
C     DISTRIBUTION
      IF(SF(1) .NE. 0)CALL URAND1(0., 10., INCTST)
C
C     ROUND INC SCORE TO TWO DECIMAL PLACES
      CALL ROUND(INCTST, .01)
C
C     ADD MEASUREMENT ERROR TO INCOMPETENCE TEST SCORE TO DETERMINE
C     'TRUE' INCOMPETENCE LEVEL
      CALL NRAND(INCTST, INCME, INC)
C
C     RESCALE AND TRUNCATE
      IF(INC .GT. 10.)INC=10.
      INC=.05*INC+.0025*INC*INC
      IF(INC .LT. 0.02)INC=0.02
C
C
C     LAZINESS:
C     TAKE CARE OF NUMBER-KEYWORD EQUIVALENCE
      LAZY=LAZY+SI(1)
      LTEST=LAZY
      IF(LAZY .LT. 5)GO TO 12
C
C     LAZINESS IS RANDOM--DECIDE TEST SCORE ACCORDING TO THE MULTINOMIAL
C     DISTRIBUTION SPECIFIED IN LTDIST.
      CALL MULNOM(LTDIST, 4, 1, 1, 1, K, J, J, J)
      LTEST=K
C
C     GENERATE REAL LAZINESS PARAMETER GIVEN TEST SCORE
C     MEAN UNDERLYING LAZINESS PARAMETER IS LINEAR WITH TEST SCORE
C     EXCEPT FOR THE HIGHEST LEVEL OF LAZINESS
 12   X=LTEST
      IF(X .GE. 3.99)X=8.
C
C     ADD RANDOM ERROR
      CALL NRAND(X, LAZME, QLAZ)
C
C     RESCALE AND TRUNCATE
      QLAZ=0.1*QLAZ
      IF(QLAZ.LT.0.1)QLAZ=0.1
      IF(QLAZ.GT.0.9)QLAZ=0.9
C
C
      MISS=.FALSE.
      FTLAST=0.
C
C********************
C
C     SIMULATE CONDITIONS WITHIN SUBJECTS
      DO 20 J=1,NC1
C
C     SET UP CURRENT VALUES FOR ALL IVS
      K=CONDS(J)
      CALL CVALS(K)
C
C     SET UP VARIABLE PRINT INDICATORS FOR FPOUT
      NOTIME=.NOT.NOTIME
      NOQUAL=.NOT.NOQUAL
C
C     DO NOTHING IF SUBJECT HAS QUIT OR BEEN FIRED ON A PREVIOUS
C     TRIAL
      TIME=-1.
      QUAL=-1.
      IF(MISS)GO TO 19
C
C     WHAT TO DO NEXT DEPENDS ON WHAT TASK IS TO BE DONE
      IF(TASK.EQ.2)GO TO 31
C
C--------------------
C
C     THE TASK IS MANUFACTURING NAPKIN HOLDERS
C     MUST FIRST DETERMINE WHETHER SUBJECT QUITS OR IS FIRED
C     ON THIS TRIAL
C
C     THE PROBABILITY OF HAVING MISSING DATA ON THIS TRIAL DEPENDS
C     ON WORKING CONDITIONS PLUS THE CHANCE THAT THE SUBJECT IS FIRED
C     FOR INCOMPETENCE AND/OR LAZINESS
C
      P=PMD(WORKCD)+C1*INC*QLAZ
      CALL BINOM(1,P,K)
      MISS=K .GE. 1
      IF(MISS)GO TO 19
C
C     KEEP TRACK OF NO. OF TIMES TIME AND QUALITY ARE MEASURED
C     FOR USE IN COST CALCULATIONS
C     NOTE:NOTIME AND NOQUAL WERE INVERTED ABOVE
      IF(NOTIME)TMM=TMM+1
      IF(NOQUAL)QM=QM+1
C
C--------------------
C
C     SIMULATE THE PRODUCTION OF 10 PORNOGRAPHIC NAPKIN HOLDERS
      HLDRS=0
      TIME=0.
C
C
C     DECIDE IF THE NEXT NAPKIN HOLDER MUST BE 'PERSONALIZED' BY
C     HAVING INITIALS STAMPED ON IT
 21   CALL BINOM(1, PINIT, K)
      INITLS=K.GT.0
C
C
C     INITIAL CUTTING AND STAMPING OF PARTS REQUIRES A CONSTANT MIN-
C     IMUM OF TIME PLUS A RANDOM PART DISTRIBUTED AS A GAMMA
C     RANDOM VARIABLE WITH SHAPE PARAMETER ALPHA=2, AND SCALE
C     PARAMETER BETA=TC(1), PLUS OPPORTUNITY FOR LOAFING
 22   TIME=TIME+T1
C
      CALL RGAMMA(2, TC(1), X)
      TIME=TIME+X
C
C     ADD TIME FOR LOAFING AS APPROPRIATE
      CALL LOAF(QLAZ, LCONST, TIME)
C
C     PROBABILITY OF HAVING TO REDO THIS STEP DEPENDS ON INCOMPETENCE
      CALL CHANCE(INC, &22)
C
C
C     DO INITIALS HAVE TO BE STAMPED ON THIS HOLDER?
      IF(.NOT.INITLS)GO TO 23
C
C     YES--TIME REQUIRED IS A CONSTANT MINIMUM PLUS A GAMMA RV
C     WITH ALPHA=1, BETA=TC(2), PLUS A SHORT OPPORTUNITY FOR LOAFING
      TIME=TIME+T2
      CALL RGAMMA(1, TC(2), X)
      TIME=TIME+X
      X=LCONST*0.5
      CALL LOAF( QLAZ, X, TIME )
C
C     A TRULY INCOMPETENT WORKER CAN RUIN THE PRODUCT AT THIS STEP
      X=.25*INC
      CALL CHANCE(X, &22)
C
C
C     ASSEMBLING PARTS REQUIRES A CONSTANT AMOUNT OF TIME PLUS A
C     GAMMA RV WITH ALPHA=1 AND BETA=TC(3), PLUS ALLOWANCE FOR
C     LOAFING
 23   TIME=TIME+T3
      CALL RGAMMA(1, TC(3), X)
      TIME=TIME+X
      CALL LOAF( QLAZ, LCONST, TIME)
C
C     THERE IS A SMALL CHANCE DEPENDING SLIGHTLY ON INCOMPETENCE THAT
C     THE ITEM DOES NOT PASS INSPECTION AT THIS POINT
      P=PREJ+.05*INC
      CALL CHANCE(P, &22)
C
C
C     TIME REQUIRED FOR PACKAGING IS A CONSTANT PLUS A GAMMA RV
C     WITH ALPHA=1 AND BETA=TC(4), PLUS OPPORTUNITY FOR LOAFING
      TIME=TIME+T4
      CALL RGAMMA(1, TC(4), X)
      TIME=TIME+X
      CALL LOAF(QLAZ, LCONST, TIME)
C
C
C     ONE MORE PORNOGRAPHIC NAPKIN HOLDER IS AVAILABLE TO THE WORLD
      HLDRS=HLDRS+1
      IF(HLDRS .LT. 10)GO TO 21
C
C--------------------
C
C     CALCULATE QUALITY INDEX:
C     AVERAGE QUALITY DEPENDS ONLY ON INCOMPETENCE--CALCULATE MEAN BY
C     INTERPOLATION
      CALL PLFN(QUALIN, 5, INC, X)
C
C     ADD RANDOM ERROR, CHOP, AND ROUND TO ONE DECIMAL PLACE
      CALL NRAND(X, QSD, QUAL)
      IF(QUAL .LT. 1.)QUAL=1.
      IF(QUAL .GT. 3.)QUAL=3.
C
C     TASK COMPLETE
      GO TO 50
C
C--------------------
C
C     FILLING-OUT-FORMS TASK
C     MEAN TIME TO FILL OUT FORMS INVOLVES AN INTERACTION OF INCOM-
C     PETENCE AND WORKING CONDITIONS AS DESCRIBED IN TABLE FTIME,
C     PLUS NUMEROUS OPPORTUNITIES FOR LOAFING, PLUS AN INCREASE IN
C     TIME ACROSS TRIALS.
C
C     RESCALE INC FOR INTPOL
 31   CALL PLFN(INCLEV, 5, INC, XI)
      XW=WORKCD
      CALL INTPOL(FTIME, 5, 3, 1, 1, XI, XW, 1., 1., X)
C
C     ADD NORMALLY DISTRIBUTED ERROR
      CALL NRAND(X, FSD, TIME)
      IF(TIME .LT. 5.)TIME=5.
C
C
C     FILLING OUT FORMS ALLOWS MANY OPPORTUNITIES FOR LOAFING--
C     NUMBER OF LOAFING INCIDENTS IS DETERMINED BY A POISSON PROCESS
C     WITH LAMBDA DEPENDENT ON LAZINESS
C
      LAMBDA=FLOAF(1)+FLOAF(2)*QLAZ
      CALL POISSN(LAMBDA, K)
C
C     SIMULATE THE REQUIRED NUMBER OF LOAFING EPISODES
      IF(K .LE. 0)GO TO 34
      DO 35 L=1,K
 35   CALL LOAF(1., LCONST, TIME)
C
C     TO SIMULATE CUMULATIVE EFFECT OF DISGUST, ADD 25% OF TIME ON LAST
C     TRIAL TO TIME FOR THIS TRIAL
      TIME=TIME+.25*FTLAST
      FTLAST=TIME
C
C
C     'QUALITY' IN THIS CASE MEANS THE NUMBER OF ERRORS MADE IN
C     FILLING OUT THE FORMS--ANOTHER POISSON RV, THIS ONE CON-
C     TROLLED BY INCOMPETENCE
 34   LAMBDA=FERR(1)+FERR(2)*INC
      CALL POISSN(LAMBDA, K)
      QUAL=K
C
C     KEEP TRACK OF NO. OF TIMES TIME AND QUALITY ARE MEASURED
C     FOR USE IN COST CALCULATIONS
C     NOTE:NOTIME AND NOQUAL WERE INVERTED ABOVE
      IF(NOTIME)TMF=TMF+1
      IF(NOQUAL)QM=QM+1
C
C--------------------
C
C     END OF CONDITIONS LOOP
C     ROUND TIME AND QUALITY AND PRINT
 50   CALL ROUND(TIME, .25)
      CALL ROUND(QUAL, .1)
19	ITMP=I
	JTMP=J
      CALL FPOUT2(ITMP, JTMP, FLGS, DV)
20	CONTINUE
C     END OF SUBJECTS LOOP
 10   CONTINUE
C
C********************
C
C     COST CALCULATION:
C     COST FOR MEASURING TIME IN THE MFG TASK IS COST1M DOLLARS
C     PER SUBJECT PER CONDITION, WITH ALLOWANCE FOR MISSING DATA.
C     IN THE FORMS TASK, THE COST IS COST1F DOLLARS PER SUBJECT
C     PER CONDITION.  QUALITY MEASUREMENT COSTS COST2 DOLLARS PER
C     SUBJECT PER CONDITION IN EACH TASK.  THE COST OF SETUP AND
C     DATA ANALYSIS IS COST3 + COST4*NO. OF SS.  MEASURING INCOM-
C     PETENCE AND LAZINESS COSTS NOTHING.  A LITTLE RANDOM VARIATION
C     IS ADDED TO THE FINAL COST IN THE FORM OF A GAMMA RV WITH
C     ALPHA=COST5 AND BETA=COST6 + .1*AMOUNT OF TIME MEASUREMENT.
      X=TMM
      COST=X*COST1M
      X=TMF
      COST=COST+X*COST1F
      X=QM
      COST=COST+X*COST2
      X=N
      COST=COST+COST3+X*COST4
      Y=TMM+TMF
      Y=.1*Y+COST6
      CALL RGAMMA(COST5,Y,X)
      COST=COST+X
C
C     ROUND OFF TO DOLLARS AND CENTS
      CALL ROUND(COST, .01)
      CALL FPOUT3(COST)
C
      IF(.NOT.TBLS)RETURN
C
C     PRINT TABLES FOR DEBUGGING PURPOSES
      WRITE(ODEV1,1002)LTDIST
      WRITE(ODEV1,1002)TC
      WRITE(ODEV1,1002)QUALIN
      WRITE(ODEV1,1002)INCLEV
      WRITE(ODEV1,1002)FTIME
      WRITE(ODEV1,1002)FLOAF
      WRITE(ODEV1,1002)FERR
      RETURN
C
C********************
C
C     MODEL INITIALIZATION:
      ENTRY MINIT
      OPEN(UNIT=IDEV3,ACCESS='SEQIN',FILE=MODNM2,DIRECTORY='4030,11')
C  
      READ(IDEV3,1001)LTDIST
      READ(IDEV3,1001)TC
      READ(IDEV3,1001)QUALIN
      READ(IDEV3,1001)INCLEV
      READ(IDEV3,1001)FTIME
      READ(IDEV3,1001)FLOAF
      READ(IDEV3,1001)FERR
      RETURN
C
C
 1001 FORMAT(6X,5G5.3)
 1002 FORMAT(1H0/(1X,5G11.3))
C
C     ERROR DETECTED BY FPOUT--PROBABLY NO VARIABLES
C     TO BE PRINTED (NOTIME AND NOQUAL SPECIFIED, BUT NOT XINC
C     OR XLAZY)
 99   RETURN 1
      END
      SUBROUTINE LOAF(QLAZ, LCONST, TIME)
      REAL*4 LCONST
C
C     THIS SUBROUTINE DECIDES IF A LOAFING INCIDENT IS TO OCCUR
C     AND, IF SO, SIMULATES THE TIME IT TAKES BY GENERATING
C     A GAMMA RANDOM VARIABLE WITH SHAPE PARAMETER ALPHA=2 AND
C     SCALE PARAMETER BETA=LCONST, AND ADDING IT TO TIME
C
C
      CALL CHANCE(QLAZ, &1)
      RETURN
C
C     A LOAFING INCIDENT IS TO OCCUR--CALCULATE TIME
 1    CALL RGAMMA(2, LCONST, X)
      TIME=TIME+X
      RETURN
      END