Trailing-Edge
-
PDP-10 Archives
-
decuslib10-06
-
43,50365/dope.f10
There are no other files named dope.f10 in the archive.
C THIS IS THE SUBROUTINE FOR DOPE
C WRITTEN BY HOWARD EICHENBAUM AND TRUDY VILLARS
C AND PROGRAMMED BY RICH NUSSLOCH ONE DREARY
C DAY IN N0VEMBER 1972
C
C
C VERSION 2--PROGRAMMED IN SUMMER 1973
C
C THIS INCLUDES REVISED DOSE RESOPONSE CURVES
C AND REVISIONS TO MAKE THE SIMULATION PERFORM
C IN A MANNER MORE AKIN TO THE EVERYDAY FIASCOS(??)
C OF RESEARCH
C
C VERSION 2 AUTHORS: HOWARD EICHENBAUM, TRUDY VILLARS, AND
C RICHARD NUSSLOCH--PROGRAMMED BY R. NUSSLOCH
C
C
SUBROUTINE MODEL(N,NCONDS,*)
C
C>>>>>>>>>> SECTION 1
C
C VARIABLE SET UP--SEE ALSO SECTION 13
C
C@@@@@@@@@@ SECTION 1.1
C VARIABLE TYPE DECLARATION
C
REAL*4 MK,I,STRDOS(3,3),DV(6),K,FV(12),DMISS(6),S(15,20)
REAL*4 DOSE,TR,R,A,B,SMALD,MK1,R1,TR1
REAL*4 Y,TOLV,LDH(4,3,2),VARI,FA1,REFAC,F1,F2,F3,F4
REAL*4 A1,B1,SCKFAC,T(6,10),Y3,PDEAD,DH,DL
REAL*4 Y1,B2,RETY,RETY9,Y9,COST,X2,X1,ERR,PRTI,STDE,STDE2,RND1,RND2
INTEGER*4 TASK,DRUG,TEST,STRAIN,TOL,RET,SINK,INACQ1(3,3,4)
INTEGER*4 IV(12),DRUG1,NDEAD,XDRUG,INRET1(4,2,4)
INTEGER*4 IIDX,ND,DRM(9),I1,I2,I3,M,M1
LOGICAL*4 FLGS(6),DEAD1,ODRET
C
C@@@@@@@@@@ SECTION 1.2
C INITIALIZATION FOR TIME-OF-DAY EFFECT
C
INTEGER*4 IHRS
REAL*4 TDAY
EQUIVALENCE (TDAY,FV(7))
C
C END OF SECTION 1.2
C
C@@@@@@@@@@ SECTION 1.3
C DATA, COMMON, AND EQUALVALENCE DECLARATIONS
C
!! DATA DMISS /6*0./
!! DATA FLGS /.TRUE.,5*.FALSE./
COMMON /VARS1/IV,FV
COMMON /IO1/NOV,SINK
COMMON /IO/IDEV1,IDEV2,IDEV3
EQUIVALENCE (TASK,IV(1)),(DRUG1,IV(2)),(TEST,IV(3)),
1(STRAIN,IV(4)),(MK,FV(1)),(TOL,IV(5)),(I,FV(2)),
2(TR,FV(3)),(R,FV(4)),(RET,IV(6)),(VARI,FV(6)),
3(XDRUG,IV(7))
C
DOUBLE PRECISION MODNM1,MODNM2,MODNM3
COMMON /DATANM/ MODNM1,MODNM2,MODNM3
DATA DMISS /6*0./
DATA FLGS /.TRUE.,5*.FALSE./
DATA MODNM1/'DOPE.DAT'/, MODNM2/'DOPE3.DAT'/,MODNM3/'DOPE.BIN'/
C
C---------------------
C
C
RND=RND!DEC-10 COMPILER BUG REQUIRES THIS
NCONDS=NCONDS!DITTO
C@@@@@@@@@@ SECTION 1.4
C IF TRIALS (TR) = 0 OR
C IF REINFORCEMENT < 1, SIMULATE ALL SUBJECTS WITH MISSING DATA
C
IF(R.LT.1 .OR. TR.EQ.0) GO TO 887
C
C@@@@@@@@@@ SECTION 1.5
C INITIALIZE VALUES FOR PROGRAM FOR EACH GROUP
C
DRUG=DRUG1
TOLV=TOL
MK1=MK
TR1=TR
FLGS(1)=.TRUE.
FLGS(2)=TEST.GE.2
IIDX=1
IF(I.GE.0) IIDX=2
C
C>>>>>>>>>> SECTION 2
C XDRUG ROUTINE
C
C@@@@@@@@@@ SECTION 2.1
C PASS IF XDRUG=0
C
IF(XDRUG.EQ.0) GO TO 727
C
C@@@@@@@@@@ SECTION 2.2
C PARSE THE VALUE OF XDRUG FOR THE THIRD DIGIT (I2)
C
I1=XDRUG/10
F1=I1
F2=F1/10.
I3=F2
F3=I3
F4=((F2-F3)*10.)+.1
I2=F4
IF(I2.LT.1) I2=1
IF(I2.GT.9) I2=9
C
C@@@@@@@@@@ SECTION 2.3
C SELECT DRUG VALUE AND DOSAGE ON BASIS OF I2
C
R1=.1
GO TO(991,992,991,992,991,992,991,992,993),I2
992 R1=10.
GO TO 991
993 R1=0.
991 MK1=R1*MK
DRUG=DRM(I2)
C
C>>>>>>>>>> SECTION 3
C ROUTINE TO DETERMINE IF THERE IS AN O.D.
C
C@@@@@@@@@@ SECTION 3.1
C FIRST SELECT END-POINTS OF LETHAL DOSE RANGE AND COMPUTE
C O.D.-IN-RETENTION-ONLY INDICATOR (ODRET)
C
727 DH=LDH(DRUG,STRAIN,2)
DL=LDH(DRUG,STRAIN,1)
ODRET=(RET.EQ.2).AND.(TEST.EQ.2)
C
C@@@@@@@@@@ SECTION 3.2
C COMPUTE PROBABILITY OF SUBJECT DYING (PEAD)
C NOTE THAT MINIMUM(PDEAD) = .02
C
PDEAD=.02
IF(MK1.GT.DL .AND. MK1.LT.DH) PDEAD=(MK1-DL)/(DH-DL)
IF(MK1.GE.DH) PDEAD=1.
C
C@@@@@@@@@@ SECTION 3.3
C IF ALL ANIMALS O.D., SIMULATE SUBJECTS WITHOUT FURTHER ADO AND
C COMPUTATION; OTHERWISE, PROCEDE
C
NDEAD=N
IF(PDEAD.EQ.1.) GO TO 887
NDEAD=0
C
C>>>>>>>>>> SECTION 4
C RESCALE DOSAGE
C
C@@@@@@@@@@ SECTION 4.1
C SELECT DRUG
C
715 GO TO(750,751,752,753),DRUG
C
C@@@@@@@@@@ SECTION 4.2
C UPS
C
750 IF(MK1.LE.3) DOSE=.667*MK1
IF(MK1.GT.3 .AND. MK1.LE.5) DOSE=MK1-1
IF(MK1.GT.5) DOSE=4.+.5*(MK1-5.)
GO TO 754
C
C@@@@@@@@@@ SECTION 4.3
C DOWNS
C
751 IF(MK1.LT.12) DOSE=MK1/12.
IF(MK1.GE.12 .AND. MK1.LT.25) DOSE=1.+.077*(MK1-12.)
IF(MK1.GE.25 .AND. MK1.LT.40) DOSE=2.+.067*(MK1-25.)
IF(MK1.GE.40 .AND.MK1.LT.50) DOSE=3.+.1*(MK1-40.)
IF(MK1.GE.50) DOSE=4.+.2*(MK1-50)
GO TO 754
C
C@@@@@@@@@@ SECTION 4.4
C NARC
C
752 IF(MK1.LT.60) DOSE=MK1/60.
IF(MK1.GE.60 .AND. MK1.LT.125) DOSE=1.+.015*(MK1-60)
IF(MK1.GE.125 .AND. MK1.LT.200) DOSE=2.+.013*(MK1-125)
IF(MK1.GE.200 .AND. MK1.LT.250) DOSE=3.+.02*(MK1-200)
IF(MK1.GE.250) DOSE=4.+.2*(MK1-250)
GO TO 754
C
C@@@@@@@@@@ SECTION 4.5
C ABIO
C
753 IF(MK1.LT.400) DOSE=MK1/400.
IF(MK1.GE.400 .AND. MK1.LT.800) DOSE=1.+.005*(MK1-400)
IF(MK1.GE.800) DOSE=3.+.01*(MK1-800.)
C
C>>>>>>>>>> SECTION 5
C SET UP RANDOM ERROR DISTRIBUTION
C
C@@@@@@@@@@ SECTION 5.1
C PARAMETERS OF ERROR DISTRIBUTION DEPEND ON STRAIN AND TOL
C
754 X2=0.
IF(STRAIN.EQ.1) X1=.1
IF(STRAIN.EQ.2) X1=.075
IF(STRAIN.EQ.3) X1=.05
IF(TOL.EQ.2) X2=.25
ERR=6.*(X1+X2)
C
C>>>>>>>>>> SECTION 6
C SECTION TO FIND TIME OF DAY IN HOURS--
C
CALL TIME (HRS)
DECODE(5,483,HRS) IHRS
483 FORMAT(I2,3X)
C
C
C>>>>>>>>>> SECTION 7
C SET UP THEORETICAL MEAN POINTS FOR ACQUISITION
C
C@@@@@@@@@@ SECTION 7.1
C SELECT MAIN EFFECT OF STRAIN BY SELECTING 3 PARAMETERS OF PARABOLIC
C FUNCTION (4TH IS REINFORCEMENT) AND COMPUTE APPROPRIATE ZERO DOSE
C THEORETICAL GROUP MEAN (Y1)
C
K=STRDOS(1,STRAIN)
A=STRDOS(2,STRAIN)
B=STRDOS(3,STRAIN)
Y1=K*(R-A)*(R-A)+B
Y=Y1
C
C@@@@@@@@@@ SECTION 7.2
C SELECT STRAIN X TASK X DRUG ACQUISITION-A1-B1-FUNCTION.
C
M=INACQ1(STRAIN,TASK,DRUG)
C
C@@@@@@@@@@ SECTION 7.3
C COMPUTE DOSE EFFECTIVENESS (SMALD) ON THE BASIS OF RESCALED DOSAGE, AND
C TIME OF INJECTION ( I IN THE PROGRAM), TEST, STATE (RET), AND DRUG
C
SMALD=0.
IF(((TEST.EQ.1).OR.(TEST.EQ.2.AND.RET.EQ.2)).AND.I.GT.0) GO TO 757
IF(I.LT.(-60.) .OR. I.GT.60) GO TO 757
IF(DRUG.EQ.4) TOLV=1.
IF(I.LT.0) PRTI=(ABS(ABS(I)-15.))/60.
IF(I.GE.0) PRTI=I/60.
IF(DRUG.EQ.4 .AND. I.GT.-15 .AND. I.LT.0) PRTI=0.
SMALD=DOSE*(1.-PRTI)/TOLV
C
C@@@@@@@@@@ SECTION 7.4
C IF DOWNS, PASSIVE AVOIDANCE IS SELECTED (M=21) GO TO
C NON-PARABOLIC ROUTINE
C
757 IF(M.EQ.21) GO TO 102
C
C@@@@@@@@@@ SECTION 7.5
C FILTER OUT POTENTIAL EXPONENTIAL OVERFLOW BOMB
C
C
IF(DRUG.EQ.3 .AND. SMALD.GE.100) SMALD=100.
IF(DRUG.NE.3 .AND. SMALD.GE.35) SMALD=35
C
C@@@@@@@@@@ SECTION 7.6
C RECOMPUTE A1 & B1 PARAMETERS OF PARABOLIC CURVE ON BASIS OF SMALD,
C DRUG, TASK, AND STRAIN MAIN AND/OR INTERACTION EFFECTS
C AND COMPUTE AND FILTER THEORETICAL GROUP MEAN WITH EFFECTIVE DRUG DOSE
C Y IS THE THEORETICAL GROUP MEAN
C
A1=A-((S(1,M)*SMALD)+S(2,M)*2**(SMALD/S(3,M))+S(4,M))
1+S(15,M)*(A-R)
B1=B/(S(5,M)*(SMALD/S(6,M))**S(7,M)+1.)+
1(S(8,M)*B**(SMALD/S(9,M))+S(10,M))+(SMALD*S(14,M))
B2=(S(11,M)-(S(12,M)*(S(13,M)-SMALD)*(S(13,M)-SMALD)))
IF(B2.LT.0) B2=0.
B1=B1-B2
Y=K*(R-A1)*(R-A1)+B1
IF(DRUG.LE.2.AND.TASK.NE.1.AND.A1.GT.0.AND.R.GT.A1) Y=B1
GO TO 103
C
C@@@@@@@@@@ SECTION 7.7
C ROUTINE FOR DOWNS-PASSIVE AVOIDANCE--NOT A PARABOLIC CURVE
C NOTE THAT TRAINING EFFECT IS DISABLED AS PART OF THE EFFECT
C
102 IF(TASK.NE.1 .AND. R.GT.A) Y=B
IF(Y.GE.70.) GO TO 485
Y=70.
IF(SMALD.GE.5) GO TO 485
Y=Y+.2*SMALD*(B-Y)
485 IF(TR.LE.70 .AND. SMALD.LT.5) TR1=.2*SMALD*(70.-TR)+TR
IF(TR.GT.70 .OR. SMALD.GE.5) TR1=TR
C
C>>>>>>>>>> SECTION 8
C SET UP THEORETICAL POINTS FOR RETENTION
C
C@@@@@@@@@@ SECTION 8.1
C FIRST SELECT EFFECTS OF DRUG, INTIME, AND STATE (RET) BY SELECTING
C PARAMETER OPTION (M OR M1)
C
103 IF(TEST.EQ.1) GO TO 761
M1=INRET1(DRUG,IIDX,RET)
M=M1
C
C@@@@@@@@@@ SECTION 8.2
C NARC FOR DN AND DD IS A SPECIAL OF CASE M=1 AS RETY MUST BE >=Y1
C
IF(M.EQ.11) M=1
C
C@@@@@@@@@@ SECTION 8.3
C COMPUTE FA1 FACTOR FOR ABIO'S EFFECT ON RETENTION ON BASIS OF
C SMALD AND TRAINING
C
IF(TR.LE.70.) Y3=Y1*(TR/70.)*(TR/70.)
IF(TR.GT.70.) Y3=Y1+(TR-70.)
IF(Y3.LT.0.) Y3=0.
IF(Y3.GT.TR) Y3=TR
FA1=1.5-((1.-Y3/TR)*SMALD)
IF(FA1.LT.1) FA1=1.
C
C@@@@@@@@@@ SECTION 8.4
C COMPUTE THEORETICAL RETENTION GROUP MEAN (RETY) AND SELECT
C APPROPRIATE ACQUISITION GROUP MEAN (Y OR Y1--SEE SECTION 7)
C ACCORDING TO STATE (CALLED RET IN PROGRAM)
C
RETY=(T(1,M)+T(2,M)*SMALD)*Y1+(T(3,M)*FA1+T(4,M))*Y
Y=T(5,M)*Y+T(6,M)*Y1
IF(M1.GE.7 .AND. RETY.LT.Y1) RETY=Y1
C
C>>>>>>>>>> SECTION 9
C COMPUTE AND ADD:
C
C@@@@@@@@@@ SECTION 9.1
C TRAINING EFFECT
C
761 IF(TR.LE.70.) Y=(TR1/70.)*(TR1/70.)*Y
IF(TR.GT.70.) Y=Y+(TR-70.)
IF(TR.LE.70. .AND. TEST.EQ.2) RETY=(TR1/70.)*(TR1/70.)*RETY
IF(TR.GT.70. .AND. TEST.EQ.2) RETY=RETY+(TR-70.)
C
C@@@@@@@@@@ SECTION 9.2
C EXCESSIVE REINFORCEMENT AND ABIO SICKNESS EFFECTS
C
REFAC=0.
SCKFAC=0.
IF((R.GT.5) .AND. (TASK.GE.2 .OR. STRAIN.EQ.3)) REFAC=(R-5.)*15.
IF(DRUG.EQ.4 .AND. MK1.GT.500) SCKFAC=Y*.002*(MK1-500)
RETY=RETY-REFAC
Y=Y-REFAC
IF(RET.GE.3 .OR. TEST.EQ.1) Y=Y-SCKFAC
IF(RET.EQ.2 .OR. RET.EQ.4) RETY=RETY-SCKFAC
C
C>>>>>>>>>> SECTION 10
C SIMULATE SUBJECTS
C
C@@@@@@@@@@ SECTION 10.1
C FIRST SET UP OUTPUT SEQUENCE AND BEGIN LOOP THROUGH N SUBJECTS
C
887 CALL FPOUT1(FLGS,DMISS,&999)
DO 555 M=1,N
C
C@@@@@@@@@@ SECTION 10.2
C STORE THEORETICAL GROUP MEANS SO THEY WONT BE LOST FOR NEXT SUBJECT
C
Y9=Y
RETY9=RETY
C
C@@@@@@@@@@ SECTION 10.3
C FUDGE BACK UNDER TOTAL TRIALS SPECIFIED IF THEORETICAL MEAN >= TRIALS
C INPUT
C
F1=.91*TR
F2=.06*F1
IF(Y9.GT.TR) CALL NRAND(F1,F2,Y9)
IF(RETY9.GT.TR) CALL NRAND(F1,F2,RETY9)
C
C@@@@@@@@@@ SECTION 10.4
C SET OUTPUT DV'S TO MISSING DATA VALUE (0.) AND DELIVER STUDENT
C MISSING DATA IF REINFOECEMENT=0 OR PDEAD=1.
C
DV(1)=0.
DV(2)=0.
IF(R.EQ.0 .OR. PDEAD.EQ.1) GO TO 716
C
C@@@@@@@@@@ SECTION 10.5
C DETERMINE IF THIS SUBJECT DIES
C
CALL BINOM(1,PDEAD,ND)
DEAD1=ND.GE.1
IF(DEAD1) NDEAD=NDEAD+1
IF(DEAD1.AND.(.NOT.ODRET)) GO TO 716
C
C@@@@@@@@@@ SECTION 10.6
C ADD IN RANDOM ERROR (SECTION 5) FACTOR. CAN BE LEFT OUT BY
C BY SPECIFYING VARI (VVVV)=.283
C
307 IF(VARI.GE.(.282) .AND. VARI.LE.(.284)) GO TO 711
STDE=ERR*Y9
STDE2=STDE/3.
CALL NRAND(0.,STDE,RND1)
CALL NRAND(0.,STDE2,RND2)
IF(TEST.EQ.2) RETY9=RND1*.75+RND2+RETY9
Y9=Y9+RND1
C
C@@@@@@@@@@ SECTION 10.7
C ADD IN TIME-OF-DAY EFFECT
C
711 IF(TDAY.GE.(.668).AND.TDAY.LE.(.670)) GO TO 851
Y9=Y9*(1-(ABS(12.-IHRS)/24.))
RETY9=RETY9*(1-(ABS(12.-IHRS)/24.))
C
C
C@@@@@@@@@@ SECTION 10.8
C TRUNCATE AND FILTER ACQ, IF APPROPRIATE DO LIKEWISE WITH RET SCORE
C SCORE
C
851 I1=Y9
Y9=I1
IF(Y9.GT.TR) Y9=TR-3.
IF(Y9.LT.0.) Y9=0
DV(1)=Y9
IF((.NOT.FLGS(2)) .OR. DEAD1) GO TO 716
I1=RETY9
RETY9=I1
IF(RETY9.GT.TR) RETY9=TR-3.
IF(RETY9.LT.0) RETY9=0.
DV(2)=RETY9
C
C@@@@@@@@@@SECTION 10.9
C PUT OUT DV VALUES AND END LOOP TO SIMULATE SUBJECTS
C
716 MTMP=M
CALL FPOUT2(MTMP,1,FLGS,DV,&999)
555 CONTINUE
C
C>>>>>>>>>> SECTION 11
C COST; DEAD ANIMALS OUTPUT
C
C@@@@@@@@@@ SECTION 11.1
C COMPUTE COST BASED ON TEST, STRAIN, STATE, DOSE, N
C
F1=3.
IF(STRAIN.EQ.1) F1=5.
F1=((.5)*TEST)*(.02)*TR+F1
F2=.1*DOSE
IF(RET.EQ.4) F2=2.*F2
F1=F1+F2
IF(TOL.EQ.2) F1=F1-2.
COST=F1*N
IF(COST.LT.0) COST=0.
C
C@@@@@@@@@@ SECTION 11.2
C PUT OUT COST AND NUMBER OF DEAD ANIMALS
C
CALL FPOUT3(COST)
IF(NDEAD.GT.0) WRITE(SINK,303) NDEAD
303 FORMAT(//2X,I5,1X,'ANIMALS DIED OR O.D.ED--WHY DO YOU THINK
1 THEY CALL IT DOPE???')
C
C>>>>>>>>>> SECTION 12
C RETURN FROM SIMULATING A GROUP
C
999 RETURN
C
C>>>>>>>>>> SECTION 13
C ENTRY TO SET UP ARRAYS FOR OPTION, MAPPING AND THE LIKE
C (SEE SECTION 1). INPUT FILE IS DOPEDAT2
C
ENTRY MINIT
C
OPEN(UNIT=IDEV3,ACCESS='SEQIN',FILE=MODNM2,DIRECTORY='4030,11')
C
READ(IDEV3,304) DRM,INACQ1,STRDOS,S,T,INRET1,LDH
304 FORMAT(9I2/2(18I2/),9F5.1,20(/15F5.1),5(/12F5.1),
1 2(/16I2),2(/12F5.1))
RETURN
END