Trailing-Edge
-
PDP-10 Archives
-
decuslib20-03
-
decus/20-0093/csdm.for
There are no other files named csdm.for in the archive.
SUBROUTINE MODEL(NDATA,NCOND,*)
C
C SIMULATION OF CONDITIONED VERBAL DOMINANCE
C WRITEN BY RICHARD JOHNSON
C EXXON CORP.
C ADAPTED FOR USE WITH MESS BY ROY F TOUZEAU & JAMES R ULLRICH
C UNIVERSITY OF MONTANA
C MISSOULA, MONTANA 59801
C PHONE (406) 243-4662
C
C
C STUFF TO INTERFACE WITH SYSTEM
INTEGER*4 LINE,SI,SF,REINF
INTEGER*4 ODEV1,ODV
REAL*4 DMISS(6)
LOGICAL*4 FLGS
!! DATA FLGS/12*.FALSE./, DMISS/6*-1./
C
COMMON /IO/ IDEV(4),ODEV1,ODV(3),LINE(80)
COMMON /VARS1/ IV(12),FV(12),SI(12),SF(12),FLGS(12)
DIMENSION NCHOS(6), CONVR(2), RLIM(2,2)
EQUIVALENCE (IDEV3,IDEV(3)), (REINF,IV(1)), (NCHOS(1),IV(2)),
* (RLIM(1,1),FV(1)), (CONVR(1),FV(5))
C
C EFFECT MAGNITUDES TABLES READ BY MINIT
DIMENSION LIMV(6), CUMDS(6,10), VAR(6,10), IPTS(2,20)
DIMENSION VLIM(2,2)
C
DIMENSION VAL(6)
C
C---------------------------------
C
DOUBLE PRECISION MODNM1,MODNM2,MODNM3
COMMON /DATANM/ MODNM1,MODNM2,MODNM3
DATA MODNM1/'CSDM.DAT'/, MODNM2/'CSDM3.DAT'/,MODNM3/'CSDM.BIN'/
DATA FLGS/12*.FALSE./, DMISS/6*-1./
NCOND=NCOND!A DEC-10 FORTRAN-TEN BUG REQUIRES THIS
C
C************************************************************
C
C SET UP FOR OUTPUT
FLGS(1)=.TRUE.
DMISS(1)=0.0
CALL FPOUT1(FLGS,DMISS,&900)
C
C CHECK ORDER OF LIMITS ON IQ VARIABLE
DO 43 I=1,2
43 IF(RLIM(I,1)-RLIM(I,2).LE.0.0) GO TO 45
WRITE(ODEV1,44)
44 FORMAT('0ILLEGAL VALUES ON IQ VARIABLE'/)
RETURN 1
C
INM=0
INV=0
IDCST=0
C
45 PDIFF=0.0
IF(REINF.EQ.1) GO TO 56
C
C MAKE SURE LENGTH OF SESSION AND RATE OF REINF ARE WITHIN LIMITS
VALM = 4.0
IF(CONVR(2).LE.4.0) VALM= CONVR(2)
VALL = 120.0
IF(CONVR(1).LE.120.0) VALL = CONVR(1)
C
C PDIFF IS THE EFFECT DUE TO RATE OF REINF AND SESSION LENGTH
PDIFF=VALL*VALM/(VALL*VALM+200.)
C
C-----------------------------------
C
C SIMULATE NDATA SUBJECTS
56 DO 83 IT=1,NDATA
CALL NRAND(SAM,SER,DATA)
C
C GET EFFECTS OF VARIABLES
DO 61 I=1,6
IZ=NCHOS(I)
IF(NCHOS(I).NE.0) GO TO 60
CALL URAND(YFL)
DO 58 II=1,10
IF(CUMDS(I,II).GT.YFL) GO TO 59
58 CONTINUE
59 IZ=II
60 VAL(I)=VAR(I,IZ)
61 CONTINUE
C
C EFFECT OF IQ RANGES
SD =16.
AIQ=120.
IF((RLIM(2,2)-RLIM(2,1)-80.0).GE.0.0) GO TO 69
66 CALL NRAND(AIQ,SD,SIQ)
INM=INM+1
IF(SIQ.LT.RLIM(2,1)) GO TO 66
IF(SIQ.GT.RLIM(2,2)) GO TO 66
AIQ=SIQ
69 CALL NRAND(AIQ,SD,SIQ)
INV=INV+1
IF(SIQ.LT.RLIM(1,1)) GO TO 69
IF(SIQ.GT.RLIM(1,2)) GO TO 69
71 CALL NRAND(AIQ,SD,OIQ)
IF(OIQ.LT.RLIM(1,1)) GO TO 71
IF(OIQ.GT.RLIM(1,2)) GO TO 71
C
C PUT EFFECTS TOGETHER
VALT=(SIQ-OIQ)/85.
DATA=DATA+VAL(3)+VAL(2)*VAL(4)+(1.-DATA)*VALT
PROB = 1.0-DATA
IF(DATA-0.5.LT.0) PROB = DATA
PROB=PROB*PDIFF*VAL(6)*VAL(1)-VAL(5)
IF (PROB.LT.0) PROB = 0.0
DATA=DATA+PROB
IF(DATA.GE.0.0.AND.DATA.LE.1.0) GO TO 82
IF(DATA.LE.0.0) DATA=0.0
IF (DATA.GE.1.0) DATA=1.0
C
C TRANSFORMATION FROM PROB OF RESPONSE TO DOM SCORES
82 DATA=INT(DATA*20.0+.5)
ITTMP=IT
CALL FPOUT2(ITTMP,1,FLGS,DATA,&900)
83 CONTINUE
C
C--------------------------------
C
C CALCULATION OF THE EXPERIMENT COST
C
DO 97 I=1,6
IF(NCHOS(I).NE.0) IDCST=IDCST+1
97 CONTINUE
IF(.NOT.IDCST) GO TO 100
XDCST=IPTS(1,IDCST)
IF(CONVR(1).NE.1.0) GO TO 100
TCST=0.
GO TO 101
100 TCST=CONVR(1 )/120.*15.
101 IF(CONVR(2).NE.0.2) GO TO 103
RCST=0.0
103 RCST=CONVR(2)/4.*15.
INCST=NDATA
IF(RLIM(1,2).NE.(RLIM(1,1)+80.0).OR.RLIM(2,2).NE.(RLIM(2,1)
* +80.0)) INCST=NDATA+(INM-NDATA)/2+(INV-NDATA)/2
IR=INCST/5
JSCAL = IR/20
IF (IR.GT.20) IR = MOD(IR,20)
IPCST=IPTS (2,IR) + JSCAL*IPTS(2,20)
IPH=IPTS (2,IR+1) + JSCAL*IPTS(2,20)
XNTRP=NDATA-5*IR
XNCST=XNTRP/5.*(IPH-IPCST)+IPCST
COST=XNCST+TCST+RCST+XDCST
C
CALL FPOUT3(COST)
C
RETURN
C
900 STOP '900'
C
C----------------------------------
C
C MODEL INITIALIZATION
ENTRY MINIT
C
OPEN(UNIT=IDEV3,ACCESS='SEQIN',FILE=MODNM2,DIRECTORY='4030,11')
C
C
READ (IDEV3, 8 )((CUMDS(I,J),J=1,10),I=1,6)
READ(IDEV3, 8 )((VAR(I,J),J=1,10),I=1,6)
READ (IDEV3, 9) LIMV,((VLIM(I,J),J=1,2),I=1,2)
READ(IDEV3,10 )MDAT,SER,SAM
READ (IDEV3, 11 )((IPTS(I,J),J=1,20),I=1,2)
C
RETURN
C
C---------------------------
C
8 FORMAT (10F8.0)
9 FORMAT (6I1,8F3.0)
10 FORMAT (I3,2F10.0)
11 FORMAT (40I2)
C
END