C You must add STEPIT to the end of this file to complete this program
C *********************************************************************
C **** RECIPE - RELATIVE WEIGHT AVERAGING MODEL ***********************
C This program solves for least-squares weights and scale values
C in the constant, relative weight averaging model
C It requires the recipe design of 3 factors: This means
C all combinations of 3 sources of information, including
C all cases in which information is not presented:
C ABC (all three), AB(C is excluded), AC, BC, A, B, C.
C This program is based on method described in the following reference:
C Birnbaum (1975). Intuitive Numerical prediction.
C American Journal of Psychology, 89, 417-429.
C
C This version by Birnbaum & Stegner. See:
C Birnbaum, M. H., & Stegner, S. E. (1979).
C Source credibility in social judgment: Bias, expertise,
C and the judge's point of view. Journal of Personality and
C Social Psychology, 37, 48-74.
C**********************************************************************
C MODIFIED BY BIRNBAUM JAN 9,1998
C INPUT TO PROGRAM
C CARD 1 NC NB NA NO. OF LEVELS IN 3I3
C CARD 2 WC, WB, WA, S0 = ESTS. OF WTS, S0 4F5.0
C CARD 3 ESTS OF S.VALS in format = 16F5.0
C (CARD 4) ESTS OF S. VALS (CONTINUES AS NEEDED)
C CARD 4 OR 5 F-TYPE FORMAT IN PARENS (27F1.0)
C CARD 5--? DATA IN PROPER FORMAT
C DATA ORDER ABC, BC, AC, AB, C, B, A
C
C**********************************************************************
C **** RECIPE - RELATIVE WEIGHT AVERAGING MODEL ****
PROGRAM RECIPE
IMPLICIT DOUBLE PRECISION(A-H,O-Z)
REAL FORM
COMMON/STPIT/CHISQ,X(50),XMAX(50),XMIN(50),DELTAX(50),ERR(50,50),D
1ELMIN(50),MASK(50),NV,NTRACE,MATRIX
COMMON/TOFUNK/ABC(9,9,9),AB(9,9),AC(9,9),BC(9,9),A(9),B(9),C(9),PA
1BC(9,9,9),PAB(9,9),PAC(9,9),PBC(9,9),PA(9),PB(9),PC(9),RABC(9,9,9)
2,RAB(9,9),RAC(9,9),RBC(9,9),RA(9),RB(9),RC(9),PCHISQ(7),OBSERV(7),
3FORM(80),SINIT(27),ROOTMS(7),TROOT,CELLS,WO,SO,W(3),SC(9),SA(9),SB
4(9),WINIT(3),NA,NB,NC,NSV
COMMON/FASTER/JVARY
COMMON/ICALL/ICALLS,IMAX
OPEN (5, FILE='RECIPE.DAT', STATUS='OLD')
OPEN (6, FILE='RECIPE.OUT', STATUS='NEW')
C EXTERNAL FUNK <---in some compilers you may need this.
ICALLS=0
IMAX=9999
CELLS=0.0
C READ PROBLEM PARAMETERS
C NC,NB,NA=NO. LEVELS OF C,B,A RESPECTIVELY (CARD 1) USINF 3I3
C INITIAL ESTIMATES OF WEIGHTS AND SO (CARD 2)
READ(5,1000)NC,NB,NA,(WINIT(I),I=1,3),SO
1000 FORMAT(3I3/4F7.3)
WRITE(6,999)
999 FORMAT(1H1,5X,'RECIPE FOR WEIGHTS AND SCALE VALUES'/
1 ,1H0,5X,'RELATIVE WEIGHT AVERAGING MODEL',/1H0,5X,
2 'PARAMETER CARDS')
WRITE(6,1005)NC,NB,NA,(WINIT(I),I=1,3),SO
1005 FORMAT(1H ,3I3,/1H ,4F7.3)
NSV=NA+NB+NC
NV=NSV+5
C READ INITIAL ESTIMATES OF SCALE VALUES(2 CARDS)
READ(5,1001)(SINIT(I),I=1,NSV)
1001 FORMAT(16F5.2)
WRITE(6,1006)(SINIT(I),I=1,NSV)
1006 FORMAT(1H ,15F6.2,/1H ,13F6.2)
C READ FORMAT FOR DATA
READ(5,1002)(FORM(I),I=1,80)
1002 FORMAT(80A1)
WRITE(6,1007)(FORM(I),I=1,80)
1007 FORMAT(1H ,80A1)
C READ IN DATA--ABC,BC,AC,C,B,A,RESPECTIVELY
C DATA ONE ROW AT A TIME
DO 10 I=1,NA
DO 10 J=1,NB
10 READ(5,FORM)(ABC(I,J,K),K=1,NC)
DO 15 J=1,NB
15 READ(5,FORM)(BC(J,K),K=1,NC)
DO 20 I=1,NA
20 READ(5,FORM)(AC(I,K),K=1,NC)
DO 25 I=1,NA
25 READ(5,FORM)(AB(I,J),J=1,NB)
READ(5,FORM)(C(K),K=1,NC)
READ(5,FORM)(B(J),J=1,NB)
READ(5,FORM)(A(I),I=1,NA)
C SET UP INITIAL ESTIMATES
DO 30 I=1,NSV
30 X(I)=SINIT(I)
II=NSV+1
III=NSV+3
L=4
DO 35 I=II,III
L=L-1
35 X(I)=WINIT(L)
C SET WEIGHT OF INITIAL ESTIMATE TO 1.0
WO=1
I=III+1
X(I)=WO
I=I+1
X(I)=SO
C THESE VARIABLES MAKE STEPIT HAPPY
NTRACE=0
MATRIX=105
C SEE STEPIT DOCUMENTATION
DO 40 I=1,NV
XMAX(I)=0.0
XMIN(I)=0.0
DELMIN(I)=0.0
DELTAX(I)=X(I)*(.01)
C NOTHING IS FIXED
40 MASK(I)=0
MM=NV-1
MASK(MM)=1
C NOW, CALL STEPIT TO WORK
CALL STEPIT
C CALCULATE NO. OF CELLS IN EACH DESIGN
OBSERV(1)=NA*NB*NC
OBSERV(2)=NB*NC
OBSERV(3)=NA*NC
OBSERV(4)=NA*NB
OBSERV(5)=NC
OBSERV(6)=NB
OBSERV(7)=NA
DO 45 I=1,7
C CALCULATE TOTAL NO. OF CELLS
45 CELLS=CELLS+OBSERV(I)
C CALCULATE INDICES OF FIT PER DESIGN
DO 50 I=1,7
ROOTMS(I)=PCHISQ(I)/OBSERV(I)
50 ROOTMS(I)=DSQRT(ROOTMS(I))
TROOT=CHISQ/CELLS
TROOT=DSQRT(TROOT)
C NOW, CALL WRITER TO PRINT RESULTS
CALL WRITER
WRITE(6,2001)
2001 FORMAT(//'1 NORMAL END OF PROGRAM')
STOP
END
C**********************************************************************
C Here is subroutine FUNK
C**********************************************************************
C FUNK IS SET-UP TO FIT A CONSTANT-WEIGHT AVERAGING MODEL
SUBROUTINE FUNK
IMPLICIT DOUBLE PRECISION(A-H,O-Z)
REAL FORM
COMMON/STPIT/CHISQ,X(50),XMAX(50),XMIN(50),DELTAX(50),ERR(50,50),D
1ELMIN(50),MASK(50),NV,NTRACE,MATRIX
COMMON/TOFUNK/ABC(9,9,9),AB(9,9),AC(9,9),BC(9,9),A(9),B(9),C(9),PA
1BC(9,9,9),PAB(9,9),PAC(9,9),PBC(9,9),PA(9),PB(9),PC(9),RABC(9,9,9)
2,RAB(9,9),RAC(9,9),RBC(9,9),RA(9),RB(9),RC(9),PCHISQ(7),OBSERV(7),
3FORM(80),SINIT(27),ROOTMS(7),TROOT,CELLS,WO,SO,W(3),SC(9),SA(9),SB
4(9),WINIT(3),NA,NB,NC,NSV
COMMON/ICALL/ICALLS,IMAX
COMMON/FASTER/JVARY
C FIND SCALE VALUES AND WEIGHTS
DO 10 K=1,NC
10 SC(K)=X(K)
J=0
JJJJ=NC+NB
JJJ=NC+1
DO 15 JJ=JJJ,JJJJ
J=J+1
15 SB(J)=X(JJ)
I=0
III=NC+NB+1
DO 20 II=III,NSV
I=I+1
20 SA(I)=X(II)
I=0
III=NSV+1
IIII=NSV+3
DO 25 II=III,IIII
I=I+1
25 W(I)=X(II)
I=NSV+4
WO=X(I)
I=I+1
SO=X(I)
C START WITH ZERO DEVIATIONS, CHISQ=0.0
DO 30 IDES=1,7
30 PCHISQ(IDES)=0.0
CHISQ=0.0
C FIT ABC DESIGN
DO 35 I=1,NA
DO 35 J=1,NB
DO 35 K=1,NC
PABC(I,J,K)=WO*SO+W(1)*SA(I)+W(2)*SB(J)+W(3)*SC(K)
PABC(I,J,K)=PABC(I,J,K)/(WO+W(1)+W(2)+W(3))
RABC(I,J,K)=ABC(I,J,K)-PABC(I,J,K)
35 PCHISQ(1)=PCHISQ(1)+(RABC(I,J,K)**2)
C FIT BC DESIGN
DO 40 J=1,NB
DO 40 K=1,NC
PBC(J,K)=WO*SO+W(2)*SB(J)+W(3)*SC(K)
PBC(J,K)=PBC(J,K)/(WO+W(2)+W(3))
RBC(J,K)=BC(J,K)-PBC(J,K)
40 PCHISQ(2)=PCHISQ(2)+(RBC(J,K)**2)
C FIT AC DESIGN
DO 45 I=1,NA
DO 45 K=1,NC
PAC(I,K)=WO*SO+W(1)*SA(I)+W(3)*SC(K)
PAC(I,K)=PAC(I,K)/(WO+W(1)+W(3))
RAC(I,K)=AC(I,K)-PAC(I,K)
45 PCHISQ(3)=PCHISQ(3)+(RAC(I,K)**2)
C FIT AB DESIGN
DO 50 I=1,NA
DO 50 J=1,NB
PAB(I,J)=WO*SO+W(1)*SA(I)+W(2)*SB(J)
PAB(I,J)=PAB(I,J)/(WO+W(1)+W(2))
RAB(I,J)=AB(I,J)-PAB(I,J)
50 PCHISQ(4)=PCHISQ(4)+(RAB(I,J)**2)
C FIT C DESIGN
DO 55 K=1,NC
PC(K)=(WO*SO+W(3)*SC(K))/(WO+W(3))
RC(K)=C(K)-PC(K)
55 PCHISQ(5)=PCHISQ(5)+(RC(K)**2)
C FIT B DESIGN
DO 60 J=1,NB
PB(J)=(WO*SO+W(2)*SB(J))/(WO+W(2))
RB(J)=B(J)-PB(J)
60 PCHISQ(6)=PCHISQ(6)+(RB(J)**2)
C FIT A DESIGN
DO 65 I=1,NA
PA(I)=(WO*SO+W(1)*SA(I))/(WO+W(1))
RA(I)=A(I)-PA(I)
65 PCHISQ(7)=PCHISQ(7)+(RA(I)**2)
DO 70 IDES=1,7
70 CHISQ=CHISQ+PCHISQ(IDES)
C COUNT UP NO. OF VISITS TO FUNK
ICALLS=ICALLS+1
RETURN
END
C *********************************************************************
C THIS SUBROUTINE PRINTS OUT RESULTS
SUBROUTINE WRITER
IMPLICIT DOUBLE PRECISION(A-H,O-Z)
REAL FORM
COMMON/STPIT/CHISQ,X(50),XMAX(50),XMIN(50),DELTAX(50),ERR(50,50),D
1ELMIN(50),MASK(50),NV,NTRACE,MATRIX
COMMON/TOFUNK/ABC(9,9,9),AB(9,9),AC(9,9),BC(9,9),A(9),B(9),C(9),PA
1BC(9,9,9),PAB(9,9),PAC(9,9),PBC(9,9),PA(9),PB(9),PC(9),RABC(9,9,9)
2,RAB(9,9),RAC(9,9),RBC(9,9),RA(9),RB(9),RC(9),PCHISQ(7),OBSERV(7),
3FORM(80),SINIT(27),ROOTMS(7),TROOT,CELLS,WO,SO,W(3),SC(9),SA(9),SB
4(9),WINIT(3),NA,NB,NC,NSV
COMMON/ICALL/ICALLS,IMAX
DIMENSION AWBC(9),BWAC(9),CWAB(9),AWB(9),BWA(9),AWC(9),
*CWA(9), BWC(9), CWB(9), PAWBC(9), PBWAC(9),PCWAB(9),PAWB(9),
*PBWA(9),PAWC(9),PCWA(9),PBWC(9), PCWB(9)
WRITE(6,1)
1 FORMAT(1H1)
WRITE(6,2)
2 FORMAT(1H0,13X,'DESIGN A X B X C')
DO 100 I=1,NA
WRITE(6,883) I
883 FORMAT(1H/,10X,' A=',I3)
DO 100 J=1,NB
WRITE(6,3)(ABC(I,J,K),K=1,NC)
WRITE(6,4)(PABC(I,J,K),K=1,NC)
100 WRITE(6,5)(RABC(I,J,K),K=1,NC)
WRITE(6,6)
6 FORMAT(1H0,13X,'DESIGN B X C')
DO 105 J=1,NB
WRITE(6,3)(BC(J,K),K=1,NC)
WRITE(6,4)(PBC(J,K),K=1,NC)
105 WRITE(6,5)(RBC(J,K),K=1,NC)
WRITE(6,7)
7 FORMAT(1H0,13X,'DESIGN A X C')
DO 110 I=1,NA
WRITE(6,3)(AC(I,K),K=1,NC)
WRITE(6,4)(PAC(I,K),K=1,NC)
110 WRITE(6,5)(RAC(I,K),K=1,NC)
WRITE(6,8)
8 FORMAT(1H0,13X,'DESIGN A X B')
DO 115 I=1,NA
WRITE(6,3)(AB(I,J),J=1,NB)
WRITE(6,4)(PAB(I,J),J=1,NB)
115 WRITE(6,5)(RAB(I,J),J=1,NB)
WRITE(6,9)
9 FORMAT(1H0,13X,'DESIGN C')
WRITE(6,3)(C(K),K=1,NC)
WRITE(6,4)(PC(K),K=1,NC)
WRITE(6,5)(RC(K),K=1,NC)
WRITE(6,10)
10 FORMAT(1H0,13X,'DESIGN B')
WRITE(6,3)(B(J),J=1,NB)
WRITE(6,4)(PB(J),J=1,NB)
WRITE(6,5)(RB(J),J=1,NB)
WRITE(6,15)
15 FORMAT(1H0,13X,'DESIGN A')
WRITE(6,3)(A(I),I=1,NA)
WRITE(6,4)(PA(I),I=1,NA)
WRITE(6,5)(RA(I),I=1,NA)
3 FORMAT(1H0,13X,'DATA',9F10.3)
4 FORMAT(1H ,13X,'PRED',9F10.3)
5 FORMAT(1H ,13X,'RESD',9F10.3)
WRITE(6,20)(PCHISQ(I),OBSERV(I),ROOTMS(I),I=1,7),CHISQ,CELLS,TROOT
20 FORMAT(1H0,18X,'SUMMARY STATISTICS',/1H ,18X,' CHISQ',' OBS
1ERV',' ROOTMS',/1H ,6X,'DESIGN ABC',1X,3F10.3,/1H ,6X,'DESIGN B
2C',2X,3F10.3,/1H ,6X,'DESIGN AC',2X,3F10.3,/1H ,6X,'DESIGN AB',2X,
33F10.3,/1H ,6X,'DESIGN C',2X,3F10.3,/1H ,6X,'DESIGN B',2X,3F10.3
4,/1H ,6X,'DESIGN A',2X,3F10.3,/1H ,6X,'OVERALL',4X,3F10.3)
WRITE(6,11)NC,NB,NA
11 FORMAT(1H0,6X,'NO. OF LEVELS OF C=',I2,/1H ,6X,'NO. OF LEVELS OF B
1=',I2,/1H ,6X,'NO. OF LEVELS OF A=',I2,/1H ,6X,'SCALE VALUES')
WRITE(6,12)(SC(K),K=1,NC)
12 FORMAT(1H ,11X,'C',9F10.3)
WRITE(6,13)(SB(J),J=1,NB)
13 FORMAT(1H ,11X,'B',9F10.3)
WRITE(6,14)(SA(I),I=1,NA)
14 FORMAT(1H ,11X,'A',9F10.3)
WRITE(6,24)(W(I),I=1,3)
24 FORMAT(1H0,6X,'WEIGHTS',/1H ,6X,'WA=',F7.3,3X,'WB=',F7.3,3X,'WC=',
1F7.3)
WRITE(6,25)WO,SO
25 FORMAT(1H0,6X,'INITIAL IMPRESSION',/1H ,6X,'WO=',F7.3,3X,'SO=',F7.
13)
WRITE(6,75)ICALLS
75 FORMAT(1H0,'NO. OF FUNCTION CALLS=',I4)
C FINDS MARGINAL MEANS FOR A WITH B AND C
R=NB*NC
DO 231 I=1,NA
TOT1=0.0
TOT2=0.0
DO 230 J=1,NB
DO 230 K=1,NC
TOT2=TOT2+PABC(I,J,K)
230 TOT1=TOT1+ABC(I,J,K)
AWBC(I)=TOT1/R
PAWBC(I)=TOT2/R
231 CONTINUE
C FINDS MARGINAL MEANS FOR B WITH A AND C
R=NA*NC
DO 241 J=1,NB
TOT1=0.0
TOT2=0.0
DO 240 I=1,NA
DO 240 K=1,NC
TOT1=TOT1+ABC(I,J,K)
240 TOT2=TOT2+PABC(I,J,K)
BWAC(J)=TOT1/R
PBWAC(J)=TOT2/R
241 CONTINUE
C FINDS MARGINAL MEANS FOR C WITH A AND B
R=NA*NB
DO 251 K=1,NC
TOT1=0.0
TOT2=0.0
DO 250 I=1,NA
DO 250 J=1,NB
TOT1=TOT1+ABC(I,J,K)
250 TOT2=TOT2+PABC(I,J,K)
CWAB(K)=TOT1/R
PCWAB(K)=TOT2/R
251 CONTINUE
C FINDS MARGINAL MEANS FOR A WITH B AND A WITH C
R1=NA
R2=NB
R3=NC
DO 331 I=1,NA
TOT1=0.0
TOT2=0.0
TOT3=0.0
TOT4=0.0
DO 330 J=1,NB
TOT3=TOT3+PAB(I,J)
330 TOT1=TOT1+AB(I,J)
AWB(I)=TOT1/R2
PAWB(I)=TOT3/R2
DO 329 K=1,NC
TOT4=TOT4+PAC(I,K)
329 TOT2=TOT2 +AC(I,K)
PAWC(I)=TOT4/R3
AWC(I)=TOT2/R3
331 CONTINUE
C FINDS MARGINAL MEANS FOR B WITH A AND B WITH C
DO 341 J=1,NB
TOT1=0.0
TOT2=0.0
TOT3=0.0
TOT4=0.0
DO 340 I=1,NA
TOT3=TOT3+PAB(I,J)
340 TOT1=TOT1+AB(I,J)
PBWA(J)=TOT3/R1
BWA(J)=TOT1/R1
DO 339 K=1,NC
TOT4=TOT4+PBC(J,K)
339 TOT2=TOT2+BC(J,K)
PBWC(J)=TOT4/R3
BWC(J)=TOT2/R3
341 CONTINUE
C FINDS MARGINAL MEANS FOR C WITH A AND C WITH B
DO 351 K=1,NC
TOT1=0.0
TOT2=0.0
TOT3=0.0
TOT4=0.0
DO 350 I=1,NA
TOT3=TOT3+PAC(I,K)
350 TOT1=TOT1+AC(I,K)
PCWA(K)=TOT3/R1
CWA(K)=TOT1/R1
DO 349 J=1,NB
TOT4=TOT4+PBC(J,K)
349 TOT2=TOT2+BC(J,K)
PCWB(K)=TOT4/R2
CWB(K)=TOT2/R2
351 CONTINUE
502 FORMAT(1H0,13X,'DATA',9F10.3)
503 FORMAT(1H ,13X,'PRED',9F10.3)
WRITE(6,501)
501 FORMAT(1H0,18X,'MARGINAL MEANS FOR A X B X C DESIGN')
WRITE(6,521)
521 FORMAT(1H0,13X,'C(BA)')
WRITE(6,502) (CWAB(K),K=1,NC)
WRITE(6,503)(PCWAB(K),K=1,NC)
WRITE(6,522)
522 FORMAT(1H0,13X,'B(CA)')
WRITE(6,502) (BWAC(J),J=1,NB)
WRITE(6,503) (PBWAC(J),J=1,NB)
WRITE(6,523)
523 FORMAT(1H0,13X,'A(BC)')
WRITE(6,502)(AWBC(I),I=1,NA)
WRITE(6,503) (PAWBC(I),I=1,NA)
WRITE(6,600)
600 FORMAT(1H0,18X,'MARGINAL MEANS FOR B X C DESIGN')
WRITE(6,582)
582 FORMAT(1H0,13X,'C(B)')
WRITE(6,502)(CWB(K),K=1,NC)
WRITE(6,503)(PCWB(K),K=1,NC)
WRITE(6,533)
533 FORMAT(1H0,13X,'B(C)')
WRITE(6,502) (BWC(J),J=1,NB)
WRITE(6,503) (PBWC(J),J=1,NB)
WRITE(6,603)
603 FORMAT(1H0,18X,'MARGINAL MEANS FOR A X C DESIGN')
WRITE(6,561)
561 FORMAT(1H0,13X,'A(C)')
WRITE(6,502) (AWC(I),I=1,NA)
WRITE(6,503) (PAWC(I),I=1,NA)
WRITE(6,562)
562 FORMAT(1H0,13X,'C(A)')
WRITE(6,502) (CWA(K),K=1,NC)
WRITE(6,503) (PCWA(K),K=1,NC)
WRITE(6,701)
701 FORMAT(1H0,18X,' MARGINAL MEANS FOR A X B DESIGN')
WRITE(6,671)
671 FORMAT(1H0,13X,'B(A)')
WRITE(6,502) (BWA(J),J=1,NB)
WRITE(6,503) (PBWA(J),J=1,NB)
WRITE(6,762)
762 FORMAT(1H0,13X,'A(B)')
WRITE(6,502)(AWB(I),I=1,NA)
WRITE(6,503) (PAWB(I),I=1,NA)
RETURN
END
C*********************************************************************
C Attach STEPIT here to make a complete program
C ********************************************************************