Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-03 - decus/20-0093/socf.for
There are no other files named socf.for in the archive.
C	SOCIAL FACILITATION SIMULATION
C	D. W. RAJECKI, SUMMER 1972
C	R. NUSSLOCH, SUMMER 1972
C	COMPLETED SUMMER 1973
C
      SUBROUTINE MODEL(N,NCOND,*)
C
C>>>>>>>>>> SECTION 1
C	VARIABLE DEFINITION--SEE ALSO SECTION 8
C
      REAL*4 C1(4,2,2),CRR1(2,2,2),CRL1(2,2,2)
      REAL*4 PERC1,S1(3,2,2),SRA1(2,2,2)
      LOGICAL*4 FLGS(12)
      REAL*4 DV(6),FV(12),RSTAGE
      REAL*4 DMISS(6),BMLS2(2,2,2),BHSD2(2,2),BHDD2(2,2)
      REAL*4 BMLD2(2,2,2),SVER2(2,5)
      REAL*4 STGE3(10),STGP3(6),PER3(4),ELPHA(14)
      REAL*4 EBETA(14),HABN(14),PLPHA(14),PBETA(14)
      LOGICAL*4 ACOR,ALPHA,BETA,SOC1D
      INTEGER*4 IV(12),SUBS,STAGE,SOCON,TASK
      INTEGER*4 DRISIT,MTLRN,HABIT,SOC1,SINK
      INTEGER*4 ETASK,PTASK,TYPE,OUT,PERS,INTE
      REAL*4 SMA2(2,2),SMT2(2,2,2),SRP1(2,2,2)
C
C@@@@@@@@@@  SECTION 1.2
C	DATA, COMMON, AND EQUIVALENCE DECLARATIONS
C
      COMMON /VARS1/IV,FV
      COMMON /IO1/NOV,SINK
      COMMON /IO/IDEV1,IDEV2,IDEV3
!!      DATA FLGS /12*.FALSE./
!!      DATA DMISS /6*-1./
      EQUIVALENCE (SUBS,IV(1)), (RSTAGE,FV(1)), (SOC1,IV(2)),
     1(TASK,IV(3)),(DRISIT,IV(4)),(MTLRN,IV(5)),(HABIT,IV(6)),
     2(ETASK,IV(7)),(PTASK,IV(8)),(TYPE,IV(9)),
     3(OUT,IV(10)),(PERS,IV(11)),(INTE,IV(12))
C 
C------------------
C 
      DOUBLE PRECISION MODNM1,MODNM2,MODNM3
      COMMON /DATANM/ MODNM1,MODNM2,MODNM3
      DATA FLGS /12*.FALSE./
      DATA DMISS /6*-1./
      DATA MODNM1/'SOCF.DAT'/, MODNM2/'SOCF3.DAT'/,MODNM3/'SOCF.BIN'/
C
	NCOND=NCOND!DEC-TEN BUG REQUIRES THIS
C@@@@@@@@@@  SECTION 1.3
C	INITIALIZE OR CONVERT VALUES FOR PROGRAM USE PER EACH
C	GROUP SIMULATED
C
      STAGE=RSTAGE+.1
      SOC1D=(STAGE.EQ.1) .AND. (SOC1.EQ.4)
      SOCON=SOC1
      IF(SOC1.EQ.5) SOCON=2
      IF(SOC1D) SOCON=1
      COST=1.
C
C@@@@@@@@@@  SECTION 1.4
C	SELECT STAGE
  400 GO TO(401,402,403),STAGE
C
C>>>>>>>>>> SECTION 2
C	STAGE 1 FOR SOPHS
C
C@@@@@@@@@@  SECTION 2.1
C	IF SUBJECTS ARE SOPHS, PROCEED THROUGH SECTION 2,
C	IF BUGS GO TO SECTION 3.
C
  401 GO TO(200,101),SUBS
C
C@@@@@@@@@@@  SECTION 2.2
C	SET FLGS ARRAY & BEGIN OUTPUT SEQUENCE
C
  101 FLGS(1)=.TRUE.
      FLGS(2)=.TRUE.
      FLGS(3)=.FALSE.
      FLGS(4)=.FALSE.
      IF(SOC1D) WRITE(SINK,1505)
      CALL FPOUT1(FLGS,DMISS,&999)
 1505 FORMAT(/' SOCON WAS DEFAULTED TO ALONE FOR THIS GROUP'/)
C
C@@@@@@@@@@  SECTION 2.3
C	SELECT MEANS AND STANDARD DEVIATIONS FOR NUMBER OF
C	ATTEMPTS AND PERCENT CORRECT THEORETICAL DISTRIBUTIONS.
C	ALSO SELECT END POINTS OF RANGES OF SCORES.
C
      AMEAN=S1(2,TASK,SOCON)
      ASD=S1(3,TASK,SOCON)
      PERC=S1(1,TASK,SOCON)
      UP=SRA1(1,TASK,SOCON)
      DOWN=SRA1(2,TASK,SOCON)
      UPP=SRP1(1,TASK,SOCON)
      DOWNP=SRP1(2,TASK,SOCON)
C
C@@@@@@@@@@  SECTION 2.4
C	SIMULATE SUBJECTS FOR STAGE 1 SOPHS
C
      DO 220 K=1,N
      ATEMPT=RANDG(AMEAN,ASD,DOWN,UP)
      PERC1=RANDG(PERC,.04,DOWNP,UPP)
      I1=ATEMPT
      DV(1)=I1
      I1=DV(1)*PERC1+.4999
      DV(2)=I1
	KTMP=K
      CALL FPOUT2(KTMP,1,FLGS,DV,&999)
  220 CONTINUE
C
C@@@@@@@@@@  SECTION 2.5
C	COMPLETE SIMULATION OF THIS GROUP AND RETURN
C
      CALL FPOUT3(1.)
      RETURN
C
C>>>>>>>>>>> SECTION 3
C	STAGE 1 FOR BUGS
C
C@@@@@@@@@@@  SECTION 3.1
C	ENTER FROM SECTION 2.1 AND SET UP FLGS ARRAY & BEGIN
C	OUTPUT SEQUENCE.
C
  200 FLGS(3)=.TRUE.
      FLGS(4)=.TRUE.
      FLGS(1)=.FALSE.
      FLGS(2)=.FALSE.
      IF(SOC1D) WRITE(SINK,1505)
      CALL FPOUT1(FLGS,DMISS,&999)
C
C@@@@@@@@@@  SECTION 3.2
C	SELECT DISTRIBUTION MEANS AND STANDARD DEVIATIONS
C	FOR RUN TIME AND LATENCY THEORETICAL DISTRIBUTIONS.
C
      RMEAN=C1(1,TASK,SOCON)
      RSD=C1(3,TASK,SOCON)
      RLSD=C1(4,TASK,SOCON)
      RLAT=C1(2,TASK,SOCON)
      UPL=CRL1(1,TASK,SOCON)
      DOWNL=CRL1(2,TASK,SOCON)
      UPR=CRR1(1,TASK,SOCON)
      DOWNR=CRR1(2,TASK,SOCON)
C
C@@@@@@@@@@@  SECTION 3.3
C	SIMULATE SUBJECTS FOR STAGE 1 BUGS
C
      DO 120 I=1,N
      DV(3)=RANDG(RMEAN,RSD,DOWNR,UPR)
      DV(4)=RANDG(RLAT,RLSD,DOWNL,UPL)
	ITMP=I
      CALL FPOUT2(ITMP,1,FLGS,DV,&999)
  120 CONTINUE
C
C@@@@@@@@@@@  SECTION 3.4
C	COMPLETE SIMULATION OF THIS GROUP AND RETURN
C
      CALL FPOUT3(1.)
      RETURN
C
C>>>>>>>>>> SECTION 4
C	INITIALIZE FOR STAGE 2
C
C@@@@@@@@@@  SECTION 4.1
C	SELECT SUBJECTS:  IF BUGS, GO TO SECTION 5; IF SOPHS,
C	GO TO SECTION 6
C
  402 IF(SUBS.NE.1) GO TO 708
C
C>>>>>>>>>>> SECTION 5
C	STAGE 2 FOR BUGS
C
C@@@@@@@@@@  SECTION 5.1
C	INITIALIZE FLGS ARRAY FOR OUTPUT AND BEGIN
C	OUTPUT SEQUENCE
C
      DO 881 KK=1,4
  881 FLGS(KK)=.FALSE.
      FLGS(5)=.TRUE.
      FLGS(6)=.FALSE.
      CALL FPOUT1(FLGS,DMISS,&999)
C
C@@@@@@@@@@  SECTION 5.2
C	CHOOSE THEORETICAL SCORE DISTRIBUTION PARAMETERS
C	ON THE BASIS OF DRISIT OR SOCON, AND MTLRN (IF DEFINED).
C	SET UP OUTPUT, THEN GO TO SECTION 5.4.	IF MTRLN IS NOT
C	DEFINED, GO TO SECTION 5.3.
C
      IF(MTLRN.EQ.3) GO TO 871
      WRITE(SINK,1503)
      GO TO(872,872,873),DRISIT
  872 XTIME=BMLD2(1,MTLRN,DRISIT)
      TSE=BMLD2(2,MTLRN,DRISIT)
      GO TO 874
  873 XTIME=BMLS2(1,MTLRN,SOCON)
      TSE=BMLS2(2,MTLRN,SOCON)
      GO TO 874
C
C@@@@@@@@@@  SECTION 5.3
C	ENTER FROM SECTION 5.2.  IF HABIT IS NOT SPECIFIED,
C	RETURN.  IF HABIT IS SPECIFIED, SELECT THEORETICAL
C	SCORE DISTRIBUTION PARAMETERS ON THE BASIS OF DRISIT
C	OR SOCON, AND HABIT.  SET UP OUTPUT.
C
  871 WRITE(SINK,1504)
      GO TO(875,876,999),HABIT
  875 XTIME=10.
      TSE=1.
      GO TO 874
  876 GO TO (878,878,879),DRISIT
  878 XTIME=BHDD2(1,DRISIT)
      TSE=BHDD2(2,DRISIT)
      GO TO 874
  879 XTIME=BHSD2(1,SOCON)
      TSE=BHSD2(2,SOCON)
 1503 FORMAT(/5X,'TIME IN MAZE'/)
 1504 FORMAT(/5X,'TURN CHOICES'/)
C
C@@@@@@@@@@  SECTION 5.4
C	SIMULATE SUBJECTS FOR STAGE 2 BUGS
C
  874 DO 880 K=1,N
      CALL NRAND(XTIME,TSE,DV(5))
      DV(5)=ABS(DV(5))
      IF(HABIT.EQ.3) GO TO 997
      I1=DV(5)+.49999
      DV(5)=I1
997	KTMP=K
      CALL FPOUT2(KTMP,1,FLGS,DV,&999)
  880 CONTINUE
C
C@@@@@@@@@@  SECTION 5.5
C	COMPLETE SIMULATION OF THIS GROUP AND RETURN
C
      CALL FPOUT3(COST)
      RETURN
C
C>>>>>>>>>> SECTION 6
C	STAGE 2 FOR SOPHS
C
C@@@@@@@@@@  SECTION 6.1
C	SELECT COMMON VALUE (ICON) FOR SOCON OR DRISIT,
C	WHICHEVER IS DEFINED.
C
  708 IF(DRISIT.EQ.3) ICON=SOCON
      IF(SOCON.EQ.4) ICON=DRISIT
C
C@@@@@@@@@@  SECTION 6.2
C	SET UP FOR SOPHS MOTOR LEARNING TASK AND OUTPUT.
C	IF TASK IS NOT MOTOR LEARNING, GO TO SECTION 6.5,
C	OTHERWISE SELECT PRARMETERS OF SCORE DISTRIBUTIONS
C	ON THE BASIS OF ICON, MTLRN, & SOCON.
C
      IF(MTLRN.EQ.3) GO TO 710
      FLGS(5)=.TRUE.
      FLGS(6)=.FALSE.
      DO 726 KK=1,4
  726 FLGS(KK)=.FALSE.
      CALL FPOUT1(FLGS,DMISS,&999)
      WRITE(SINK,1506)
 1506 FORMAT(/5X,'MINUTES STYLUS CONTACT'/)
      IF(ICON.EQ.2) GO TO 711
      XBAR=SMA2(1,MTLRN)
      SD=SMA2(2,MTLRN)
      GO TO 712
  711 KON=1
      IF(SOCON.EQ.3) KON=2
      XBAR=SMT2(1,KON,MTLRN)
      SD=SMT2(2,KON,MTLRN)
C
C@@@@@@@@@@  SECTION 6.3
C	SIMULATE STAGE 2 SOPHS IN MOTOR LEARNING TASK.
C
  712 DO 713 M=1,N
      CALL NRAND(XBAR,SD,DV(5))
      IF(HABIT.EQ.3) GO TO 714
      I1=DV(5)
      DV(5)=I1
  714 DV(5)=ABS(DV(5))
	MTMP=M
      CALL FPOUT2(MTMP,1,FLGS,DV,&999)
  713 CONTINUE
C
C@@@@@@@@@@  SECTION 6.4
C	FINISH GROUP SIMULATION OUTPUT & RETURN.

C
      CALL FPOUT3(COST)
      RETURN
C
C@@@@@@@@@@  SECTION 6.5
C	SET UP FOR SOPHS VERBAL LEARNING AND OUTPUT.
C	ENTRY IS FROM SECTION 6.2.  SELECT OR COMPUTE
C	SCORE DISTRIBUTION PARAMETERS ON BASIS OF HABIT,
C	ICON, AND SOCON.
C
  710 FLGS(6)=.TRUE.
      DO 725 KK=1,5
  725 FLGS(KK)=.FALSE.
      CALL FPOUT1(FLGS,DMISS,&999)
      I2=ICON
      IF(DRISIT.EQ.2) I2=4
      IF(HABIT.EQ.1) I2=5
      XBAR=SVER2(1,I2)
      SD=SVER2(2,I2)
C
C@@@@@@@@@@  SECTION 6.6
C      SIMULATE STAGE 2 SOPHS FOR VERBAL LEARNING
C
  715 DO 717 M=1,N
      CALL NRAND(XBAR,SD,DV(6))
      I1=DV(6)
      DV(6)=I1
      DV(6)=ABS(DV(6))
      IF(DV(6).GT.20) DV(6)=20.
	MTMP=M
      CALL FPOUT2(MTMP,1,FLGS,DV,&999)
  717 CONTINUE
C
C@@@@@@@@@@  SECTION 6.7
C	FINISH GROUP SIMULATION OUTPUT AND RETURN.
C

      CALL FPOUT3(COST)
      RETURN
C
C>>>>>>>>>> SECTION 7
C	STAGE 3
C
C@@@@@@@@@@  SECTION 7.1
C	SET UP FOR STAGE AND PASS TO SECTION 7.3 UNLESS
C	ETASK IS SPECIFIED
C
  403 ALPHA=.FALSE.
      BETA=.FALSE.
      ACOR=.FALSE.
      IF(PTASK.NE.1) GO TO 415
C
C@@@@@@@@@@  SECTION 7.2
C	DETERMINE IF ONE (ACOR=F), OR TWO (ACOR=T) DEPENDENT
C	VARIABLES WILL BE PUT OUT.  SELECT APPROPRIATE
C	THEORETICAL GROUP MEANS FOR E TASKS  (ATEMPT, CORCT).
C
      ACOR=ETASK.EQ.2 .OR. ETASK.EQ.3 .OR. ETASK.EQ.6 .OR. ETASK.EQ.7
      IE=ETASK-1
      ATEMPT=STGE3(IE)
      IC=IE
      IF(IE.GT.2) IC=IE-2
      IF(ACOR) CORCT=PER3(IC)
C
C@@@@@@@@@@  SECTION 7.3
C	MODIFY ATEMPT, CORCT ON BASIS OF AVAILABLE INDEPENDENT
C	VARIALBES AND PASS TO SECTION 7.5
C
  415 INOW=SOCON
      IF(DRISIT.NE.3) INOW=3+DRISIT
      IF(TYPE.NE.1) INOW=4+TYPE
      IF(OUT.NE.1) INOW=6+OUT
      IF(PERS.NE.1) INOW=8+PERS
      IF(INTE.NE.1) INOW=10+INTE
      ITASK=ETASK
      IF(ETASK.EQ.1) ITASK=PTASK
      GO TO(999,12,11,12,11,12,11,12,11,413,602),ITASK
   12 ALPHA=.TRUE.
      GO TO 416
   11 BETA=.TRUE.
  416 IF(PTASK.NE.1) GO TO 601
      IF(ALPHA) ATEMPT=ATEMPT*ELPHA(INOW)
      IF(BETA) ATEMPT=ATEMPT*EBETA(INOW)
      GO TO 413
  602 ATEMPT=HABN(INOW)+ATEMPT
      GO TO 413
C
C@@@@@@@@@@  SECTION 7.4
C	ENTER FROM SECTION 7.1.  SELECT APPROPRIATE THEORETICAL
C	GROUP MEAN FOR P TASK (ATEMPT) AND MODIFY ACCORDING TO
C	INDEPENDENT VARIABLES.	PASS TO SECTION 7.5.
C
  601 IP=PTASK-1
      ATEMPT=STGP3(IP)
      IF(PTASK.EQ.6 .OR. PTASK.EQ.7) GO TO 413
      IF(ALPHA) ATEMPT=ATEMPT+PLPHA(INOW)
      IF(BETA) ATEMPT=ATEMPT+PBETA(INOW)
C
C@@@@@@@@@@  SECTION 7.5
C	SET UP FOR OUTPUT BY SETTING UP FLGS ARRAY,
C	CALLING FPOUT1, AND PRINTING APPROPRIATE DEPENDENT
C	VARIABLE IDENTIFICATION.
C
  413 FLGS(1)=ACOR
      FLGS(2)=.TRUE.
      DO 421 KKK=3,6
  421 FLGS(KKK)=.FALSE.
      CALL FPOUT1(FLGS,DMISS,&999)
      GO TO (31,35,35,32,32,35,35,33,33,34,34),ETASK
   31 GO TO(999,42,42,42,42,43,43),PTASK
   32 WRITE(SINK,301)
  301 FORMAT(/5X,'REVOLUTIONS OF STYLUS--DISC CONTACT'/)
      GO TO 35
   33 WRITE(SINK,302)
  302 FORMAT(/5X,'NUMBER OF ERRORS'/)
      GOTO 35
   34 WRITE(SINK,303)
  303 FORMAT(/5X,'CHOICE OF FREQUENT WORD'/)
      GO TO 35
   42 WRITE(SINK,305)
      GO TO 35
  305 FORMAT(/5X,'PICKS FAVORITE(PERCENT CHOICE)'/)
   43 WRITE(SINK,306)
  306 FORMAT(/5X,'PALMER SWEAT INDEX'/)
C
C@@@@@@@@@@  SECTION 7.6
C	COMPUTE STANDARD ARROR FOR DEPENDENT VARIABLE SCORE
C	DISTRIBUTION
C
   35 CALL NRAND(.05,.01,XC1)
      CALL NRAND(5.,1.,XA1)
      XC1=ABS(XC1)
      XA1=ABS(XA1)
      IF(XC1.EQ.0.) XC1=1.
      IF(XA1.EQ.0.) XA1=1.
C
C@@@@@@@@@@  SECTION 7.7
C	SIMULATE SUBJECT IN STAGE 3
C
      DO 310 K=1,N
      CALL NRAND(ATEMPT,XA1,DV(2))
      DV(2)=ABS(DV(2))
      I1=DV(2)
      IF((ETASK.LT.4 .OR. ETASK.GT.5) .AND. ETASK.GT.1) DV(2)=I1
      IF(PTASK.GT.1 .AND. PTASK.LE.5) DV(2)=I1
      IF(ETASK.GE.10 .AND. DV(2).GT.20) DV(2)=20.
      IF(PTASK.GT.1 .AND. PTASK.LE.5 .AND. DV(2).GT.100) DV(2)=99.
      IF(.NOT. ACOR) GO TO 311
      DV(1)=DV(2)
      DV(2)=RANDG(CORCT,XC1,0.,1.)
      I1=DV(2)*DV(1)
      DV(2)=I1
      DV(2)=ABS(DV(2))
311	KTMP=K
      CALL FPOUT2(KTMP,1,FLGS,DV,&999)
  310 CONTINUE
C
C@@@@@@@@@@  SECTION 7.8
C	FINISH GROUP OUTPUT AND RETURN
C
      CALL FPOUT3(1.)
  999 RETURN
C
C>>>>>>>>>> SECTION 8
C	INITIALIZE DATA ARRAYS FROM CALL OF MINIT
C
      ENTRY MINIT
C 
      OPEN(UNIT=IDEV3,ACCESS='SEQIN',FILE=MODNM2,DIRECTORY='4030,11')
      READ(IDEV3,998) C1,S1,SRA1,CRR1,CRL1,SMA2,SMT2,ELPHA,EBETA,
     1PLPHA,PBETA,HABN,PER3,STGE3,STGP3,BMLS2,BMLD2,BHSD2,BHDD2,SRP1,
     2SVER2
  998 FORMAT(16F5.2/12F5.2/3(8F5.2/),4F5.2/8F5.2/5(14F5.2/),4F5.2/
     110F5.2/6F5.2/2(8F5.2/),2(4F5.2/),8F5.2/10F5.2)
      RETURN
      END
C
C>>>>>>>>>> SECTION 9
C	MODIFICATION OF NRAND FOR RANGEING
C
      FUNCTION RANDG(XMN,SD,DEND,REND)
      CALL NRAND(XMN,SD,X1)
      RANDG=X1
      IF(X1.LT.DEND) RANDG=DEND
      IF(X1.GT.REND) RANDG=REND
      RETURN
      END