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 ********************************************************************