Trailing-Edge
-
PDP-10 Archives
-
decuslib20-03
-
decus/20-0093/impt.for
There are no other files named impt.for in the archive.
C IMPRINTING SIMULATION SUBROUTINE
C OCT. 14, 1971
C BOB STOUT, PROGRAMMER
C DON RAJECKI, SIMULATION DESIGNER (FALL, 1970)
C MODIFIED DRASTICALLY BY BOB STOUT, AUGUST, 1972
C
C
SUBROUTINE MODEL(N,NCOND,*)
IMPLICIT INTEGER*4 (O)
INTEGER*4 LINE
COMMON /IO/IDEV(4),ODEV1,ODV(3),LINE(80)
C
INTEGER*4 SI(12), SF(12)
INTEGER*4 IV(12)
REAL*4 FV(12)
LOGICAL*4 FLGS(12)
COMMON /VARS1/IV, FV, SI, SF, FLGS
C
INTEGER*4 REAR,TARG,TEST,AROUS,INDUCT,WALK,AGE
EQUIVALENCE (REAR,IV(1)), (TARG,IV(2)), (TEST,IV(3)),
1 (AROUS,IV(4)), (INDUCT,IV(4)), (WALK,IV(6)), (AGE,IV(7))
C
C TABLE OF AGE CATEGORIES
INTEGER*4 AGETBL(6)
!! DATA AGETBL/8,12,16,20,30,48/
C
C AROLRN CONTROLS THE EFFECT OF AROUSAL ON LEARNING RATE.
C (1-AROLRN(AROUS)) IS THE PROPORTION OF THE DISTANCE TOWARD ASYMP-
C TOTE THAT THE ANIMAL WILL GO IN A GIVEN TRIAL IN WHICH IMPRINT-
C ING IS TAKING PLACE.
REAL LRNPAR, AROLRN(5)
!! DATA AROLRN/.75, .65, .60, .55, .40/
C
C AROUSAL-AGE INTERACTION TABLE
C THE AROAGE TABLE CONTROLS THE EFFECT OF AROUSAL AND AGE ON PIMP,
C THE PROBABILITY OF BEGINNING IMPRINTING ON A GIVEN TRIAL. IT
C IS ALSO USED TO HELP DETERMINE THE ASYMPTOTE OF THE LEARNING
C CURVE (A SEPARATE TABLE REALLY SHOULD BE USED, BUT THIS WAY IS
C EASIER).
REAL*4 AROAGE(5,6)
!! DATA AROAGE/ .30, .55, .85, .92, .95,
!! 1 .24, .48, .80, .88, .92,
!! 2 .18, .40, .60, .70, .88,
!! 3 .12, .30, .50, .65, .85,
!! 4 .09, .20, .30, .45, .55,
!! 5 .07, .10, .15, .30, .45/
C
C IF WALK=MATCHED, THE STANDARD ERRORS FOR GENERAL NOISE AND
C LEARNING ASYMPTOTE INDIVIDUAL DIFFERENCES ARE REDUCED
REAL*4 WALKEF(2)
!! DATA WALKEF/1.0, .70/
C
C ISOLATED REARING INCREASES IMPRINTING OVERALL
REAL*4 REAREF(2)
!! DATA REAREF/1.0, 0.5/
C
C ASSORTED OTHER STUFF
REAL*4 NOISE,DMISS(6),DATA(6),LRNSE
C BASE IS THE MEAN IMPRINTING SCORE FOR ANIMALS WHICH HAVE NOT YET
C BEGUN TO IMPRINT
C GNSD IS THE STANDARD DEVIATION OF THE GENERAL MEASUREMENT ERROR
C ASIGMA IS THE UPPER BOUND OF THE STANDARD DEVIATION OF LEARNING
C ASYMPTOTES
C DMISS IS PURELY FOR THE BENEFIT OF FPOUT
C LRNSE CONTROLS THE STANDARD ERROR DUE TO VARIATIONS IN STRENGTH
C OF LEARNING
!! DATA BASE/1./, GNSD/1./, ASIGMA/4./, DMISS/6*-1./, LRNSE/4./
C
DOUBLE PRECISION MODNM1,MODNM2,MODNM3
COMMON /DATANM/ MODNM1,MODNM2,MODNM3
DATA MODNM1/'IMPT.DAT'/ ,MODNM2/'IMPT3.DAT'/,MODNM3/'IMPT.BIN'/
C
DATA AGETBL/8,12,16,20,30,48/
DATA AROLRN/.75, .65, .60, .55, .40/
DATA AROAGE/ .30, .55, .85, .92, .95,
1 .24, .48, .80, .88, .92,
2 .18, .40, .60, .70, .88,
3 .12, .30, .50, .65, .85,
4 .09, .20, .30, .45, .55,
5 .07, .10, .15, .30, .45/
DATA WALKEF/1.0, .70/
DATA REAREF/1.0, 0.5/
DATA BASE/1./, GNSD/1./, ASIGMA/4./, DMISS/6*-1./, LRNSE/4./
NCOND=NCOND!DEC-10 FORTRAN COMPILER BUG REQUIRES THIS
C
C------------------------------
C
C SET UP OUTPUT SUBROUTINE
DO 10 I=1,6
10 FLGS(I)=I.LE.TEST
CALL FPOUT1(FLGS,DMISS,&999)
C
C SIMULATE THE SUBJECTS
LRNPAR=AROLRN(AROUS)
DO 1 I=1,N
IMP=0
LTRIAL=0
C
C IF AGE IS RANDOM, SELECT AN AGE
IF(SI(7).NE.0)CALL URAND2(16,30,AGE)
C
C COMPUTE AGE CATEGORY
DO 2 IAGE=1,6
IF(AGE.LE.AGETBL(IAGE))GO TO 3
2 CONTINUE
C
C PROBABILITY OF BEGINNING IMPRINTING IS A FUNCTION OF AROUSAL
C AND AGE
3 PIMP=AROAGE(AROUS,IAGE)
C
C LEARNING ASYMPTOTE IS A FUNCTION OF AROUSAL, AGE, REARING, AND
C INDIVIDUAL DIFFERENCES
RAA=REAREF(REAR)*AROAGE(AROUS,IAGE)
ASYMP=40.*RAA
C INDIVIDUAL DIFFERENCES HAVE STD. ERROR PROPORTIONAL TO ASYMPTOTE
SE=ASIGMA*WALKEF(WALK)*RAA
CALL NRAND(0.,SE,NOISE)
ASYMP=ASYMP+NOISE
IF(ASYMP.LT.0.)ASYMP=0.
C
C
C SIMULATE EACH TEST
DO 4 J=1,TEST
DV=0.
C
C IF S HAS NOT STARTED IMPRINTING YET, IT HAS A CHANCE NOW
IF(IMP.EQ.0)CALL BINOM(1,PIMP,IMP)
C IF ANIMAL HAS NOT STARTED TO IMPRINT, SKIP NEXT SECTION
IF(IMP.EQ.0)GO TO 5
C
C LEARNING MODEL IS SIMPLE LINEAR OPERATOR
LTRIAL=LTRIAL+1
DV=ASYMP*LRNPAR**LTRIAL
C GENERATE NOISE PROPORTIONAL TO HEIGHT OF ASYMPTOTE AND INVERSELY
C PROPORTIONAL TO STRENGTH OF LEARNING
SE=LRNSE*RAA*(DV/ASYMP)
CALL NRAND(0.,SE,NOISE)
DV=ASYMP-DV+NOISE
C
C ADD BASE RATE AND GENERAL NOISE
C GENERAL NOISE DEPENDS ON WALK
5 SE=WALKEF(WALK)*GNSD
CALL NRAND(0.,SE,NOISE)
DV=DV+BASE+NOISE
C ROUND ALL FIGURES TO NEAREST TENTH AND CUT OFF BELOW 0
DV=10.*DV+.5
IX=AINT(DV)
DV=IX
DV=0.1*DV
IF(DV.LT.0.)DV=0.
4 DATA(J)=DV
ITMP=I
CALL FPOUT2(ITMP,1,FLGS,DATA,&999)
1 CONTINUE
C
C FINISH OUTPUT
CALL FPOUT3(0.)
RETURN
C
C OUTPUT ERROR
999 STOP '999'
C
C
ENTRY MINIT
RETURN
C
END