Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-06 - 43,50365/csdm.f10
There are no other files named csdm.f10 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