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