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