1 1 FACTOR PATTERN STRUCTURE FOR THE ORTHOGONAL FACTOR ANALYSIS MODEL USING FSCORE HAMPARSUM BOZDOGAN AND DONALD E. RAMIREZ DEPARTMENT OF MATHEMATICS MATH-ASTRO BUILDING UNIVERSITY OF VIRGINIA CHARLOTTESVILLE, VIRGINIA 22903 TECHNICAL REPORT 17 (OCTOBER 18, 1986) 1 INTRODUCTION THIS TECHNICAL REPORT PRESENTS THE PROGRAM FSCORE WHICH IS DEVELOPED IN OUR PAPER: AN EXPERT MODEL SELECTION APPROACH TO DETERMINE THE BEST PATTERN STRUCTURE IN FACTOR ANALYSIS MODELS, MULTIVARIATE STATISTICAL MODELING AND DATA ANALYSIS, D. REIDEL PUBLISHING COMPANY, 1987, PP. 35-60. FSCORE IS A FORTRAN 77 PROGRAM WHICH FINDS THE BEST FACTOR PATTERN MATRIX FOR AN ORTHOGONAL FACTOR MODEL. THE CRITERION USED IS MALLOWS' C(P) WHICH IS FIRST ORDER EQUIVALENT TO AKAIKE'S INFORMATION CRITERION AIC. THE USER IS ASSUMED TO HAVE FOUND THE BEST NUMBER OF FACTORS FOR THE FACTOR MODEL. THE USER INPUTS TO THE SUBROUTINE FSCORE ARE N THE NUMBER OF CASES, P THE NUMBER OF VARIABLES, NF THE NUMBER OF FACTORS, CORR THE CORRELATION MATRIX IN SYMMETRIC STORAGE, AND LAMBDA THE MATRIX OF FACTOR LOADINGS. INDEX APPENDIX A CONTAINS THE RAW DATA SET WITH N=213 AND P=9 APPENDIX B CONTAINS THE TERMINAL OUTPUT FROM FSCORE APPENDIX C CONTAINS THE FULL OUTPUT FROM THE PROGRAM FSCORE APPENDIX D CONTAINS THE FORTRAN PROGRAM FSCORE APPENDIX E CONTAINS THE CALL STATEMENTS FROM FSCORE ************************************************************************ APPENDIX A: THE ORIGINAL DATA 1.00000 0.82800 1.00000 0.77600 0.77900 1.00000 0.43900 0.49300 0.46000 1.00000 0.43200 0.46400 0.42500 0.67400 1.00000 0.44700 0.48900 0.44300 0.59000 0.54100 1.00000 0.44700 0.43200 0.40100 0.38100 0.40200 0.28800 1.00000 0.54100 0.53700 0.53400 0.35000 0.36700 0.32000 0.55500 1.00000 0.38000 0.35800 0.35900 0.42400 0.44600 0.32500 0.59800 0.45200 1.00000 NOTE: P=9 N=213 ************************************************************************ APPENDIX B: TERMINAL OUTPUT FROM FSCORE OK, SEG FS_AUG10 ENTER THE NAME OF THE OUTPUT FILE THURSTONE.OUT THIS PROGRAM WILL COMPUTE FACTOR SCORE WEIGHTS COPYRIGHT @ AUGUST 9, 1986 ENTER THE NUMBER OF VARIABLES : <= 24 9 NUMBER OF VARIABLES = 9 ENTER THE NUMBER OF CASES 213 NUMBER OF CASES = 213 ENTER FILE WITH CORRELATION MATRIX IN SYMMETRIC STORAGE THURSTONE.CORR ENTER THE NUMBER OF FACTORS 3 ENTER THE FILE CONTAINING LAMBDA THURSTONE.LAM IS THE CORR FILE IN FREE FORMAT? ENTER Y OR N *****CAPS ONLY***** Y IS THE LAMBDA FILE IN FREE FORMAT? ENTER Y OR N *****CAPS ONLY***** Y PROGRAM ENDED NORMALLY **** STOP ************************************************************************ 1 APPENDIX C: FULL OUTPUT FROM FSCORE THIS PROGRAM WILL COMPUTE FACTOR SCORE WEIGHTS COPYRIGHT @ AUGUST 9, 1986 NUMBER OF VARIABLES = 9 NUMBER OF CASES = 213 DATA FILE = THURSTONE.CORR NUMBER OF FACTORS = 3 LAMBDA FILE = THURSTONE.LAM PSI FILE = THURSTONE.PSI CORRELATION MATRIX 1 2 3 4 5 6 7 8 9 1 1.00000 2 0.82800 1.00000 3 0.77600 0.77900 1.00000 4 0.43900 0.49300 0.46000 1.00000 5 0.43200 0.46400 0.42500 0.67400 1.00000 6 0.44700 0.48900 0.44300 0.59000 0.54100 1.00000 7 0.44700 0.43200 0.40100 0.38100 0.40200 0.28800 1.00000 8 0.54100 0.53700 0.53400 0.35000 0.36700 0.32000 0.55500 1.00000 9 0.38000 0.35800 0.35900 0.42400 0.44600 0.32500 0.59800 0.45200 1.00000 LAMBDA MATRIX 1 2 3 1 0.83417 0.24390 0.26408 2 0.82723 0.31826 0.22292 3 0.77467 0.28436 0.22660 4 0.22764 0.79211 0.22976 5 0.21285 0.70605 0.29047 6 0.31422 0.61587 0.13402 7 0.23215 0.17906 0.79517 8 0.44630 0.16642 0.52655 9 0.15384 0.31093 0.63782 PSI VECTOR 0.17493 0.16470 0.26767 0.26795 0.37182 0.50401 0.28174 0.49586 0.47284 ************************************************************************ ANALYSIS FOR FACTOR 1 * * * * SUMMARY * * * * MINIMUM CP IS 6.9602 NUMBER OF VARIABLES FOR FACTOR 1 IS 7 VARIABLE COEFFICIENT F-VALUE P-VALUES 1. 0.4529 80.65 0.0000 2. 0.4582 79.81 0.0000 3. 0.2672 35.36 0.0000 4. -0.1612 18.99 0.0000 5. -0.1140 9.62 0.0022 7. -0.1137 11.09 0.0010 9. -0.0910 7.15 0.0081 ************************************************************************ ANALYSIS FOR FACTOR 2 * * * * SUMMARY * * * * MINIMUM CP IS 4.5188 NUMBER OF VARIABLES FOR FACTOR 2 IS 6 VARIABLE COEFFICIENT F-VALUE P-VALUES 1. -0.1582 12.75 0.0004 4. 0.5709 129.53 0.0000 5. 0.3493 51.43 0.0000 6. 0.2223 24.87 0.0000 7. -0.1308 9.27 0.0026 8. -0.0745 2.78 0.0967 ************************************************************************ ANALYSIS FOR FACTOR 3 * * * * SUMMARY * * * * MINIMUM CP IS 5.3103 NUMBER OF VARIABLES FOR FACTOR 3 IS 5 VARIABLE COEFFICIENT F-VALUE P-VALUES 2. -0.2052 18.71 0.0000 6. -0.1002 5.59 0.0190 7. 0.6454 167.45 0.0000 8. 0.1871 15.17 0.0001 9. 0.2734 34.19 0.0000 ************************************************************************ FACTOR SCORE WEIGHTS: 1 2 3 1 : 0.453 -0.158 0.000 2 : 0.458 0.000 -0.205 3 : 0.267 0.000 0.000 4 : -0.161 0.571 0.000 5 : -0.114 0.349 0.000 6 : 0.000 0.222 -0.100 7 : -0.114 -0.131 0.645 8 : 0.000 -0.075 0.187 9 : -0.091 0.000 0.273 FACTOR SCORE WEIGHTS PATTERN 1 2 3 1 : ++++ - 2 : ++++ -- 3 : ++ 4 : - +++++ 5 : - +++ 6 : ++ - 7 : - - ++++++ 8 : + 9 : ++ PROGRAM ENDED NORMALLY ************************************************************************ APPENDIX D: THE FORTRAN PROGRAM FSCORE PROGRAM FSCORE C DEVELOPED BY HAMPARSUM BOZDOGAN AND DONALD E. RAMIREZ C PROGAMMING ASSISTANTS: LARRY BOBBITT AND JAMES SYTA C MATHEMATICS DEPARTMENT C MATHEMATICS-ASTRONOMY BUILDING C UNIVERSITY OF VIRGINIA C CHARLOTTESVILLE, VIRGINIA 22903 INTEGER MVP1,NSIZE1,NSIZE2,MAXVAR CHARACTER VERSON*72 C NOTE: THE MAX NUMBER OF VARIABLES IS MAXVAR PARAMETER(VERSON='COPYRIGHT @ AUGUST 9, 1986', + MAXVAR=24, + MVP1=MAXVAR+1, + NSIZE1=3*MVP1*MVP1+9*MVP1+12, + NSIZE2=(2*MVP1*MVP1*MVP1+4*MVP1)/3) INTEGER N,P,NF,IOUT,IWORK,IXS,IXV,NVAR,NV DOUBLE PRECISION CORR,FSWTS,LAMBDA,WORK4, + TABLE,WORK1,WORK3,WORK2,MINCP C FOLLOWING IS A LIST OF WORK STORAGE VECTORS AND WHERE THEY C ARE USED: C WORK1 IS DIMENSIONED AS NSIZE2=(2*MVP1*MVP1*MVP1+4*MVP1)/3 C SUBROUTINE MODEL C SUBROUTINE RLEAP (2*(P+1)**3+4*(P+1))/3 C WORK2 IS DIMENSIONED AS 10*MVP1 C SUBROUTINE MODEL C SUBROUTINE RLEAP 10*(P+1) C WORK3 IS DIMENSIONED AS 2*MAXVAR C SUBROUTINE MODEL C SUBROUTINE RLEAP 2*P C WORK4 IS DIMENSIONED AS 4*MAXVAR C SUBROUTINE MODEL C SUBROUTINE RLEAP (PX4) C IWORK IS DIMENSIONED AS NSIZE1=3*MVP1*MVP1+9*MVP1+12 C SUBROUTINE MODEL C SUBROUTINE RLEAP 3*(P+1)**2+9*(P+1)+12 C SUBROUTINE PATTRN P C IXS IS DIMENSIONED AS MVP1 C SUBROUTINE MODEL C SUBROUTINE RLEAP P+1 C IXV IS DIMENSIONED AS MVP1 C SUBROUTINE MODEL C SUBROUTINE RLEAP P+1 C NVAR IS DIMENSIONED AS MAXVAR*MVP1 C SUBROUTINE MODEL C SUBROUTINE RLEAP P*(P+1) COMMON /BLK1/CORR(MAXVAR*MVP1/2),WORK4(MAXVAR*4), + TABLE(MVP1,MVP1,4),WORK3(2*MVP1),LAMBDA(MVP1,MVP1), + IXS(3*MVP1),IXV(MVP1),NVAR(MAXVAR*MVP1), + FSWTS(MVP1,MVP1),WORK2(10*MVP1), + MINCP(MVP1),NV(MVP1),IWORK(NSIZE1) COMMON /BLK2/WORK1(NSIZE2) EXTERNAL START,GETCOR,COROUT, + MODEL,PATTRN,GETLAM,LAMOUT,PRTOUT C START OF PROGRAM C SETUP INPUT AND OUTPUT FILES UNITS 6 7 8 CALL START(N,P,NF,MAXVAR,IOUT,VERSON) C READ CORRELATION MATRIX IN SYMMETRIX STORAGE CALL GETCOR(P,CORR,IOUT) C PRINT CORR CALL COROUT(P,CORR,IOUT) C READ LAMBDA MATRIX CALL GETLAM(P,NF,LAMBDA,IOUT) C PRINT LAMBDA CALL LAMOUT(P,NF,LAMBDA,IOUT) C PERFORM MODEL SELECTION AND COMPUTE FACTOR SCORE WEIGHTS CALL MODEL(P,N,NF,CORR,LAMBDA, + FSWTS,MINCP,NV,TABLE, + WORK1,WORK2,WORK3,WORK4,IWORK,IXS,IXV,NVAR) CALL PRTOUT(P,NF,IOUT,MINCP,NV,TABLE) CALL PATTRN(P,NF,FSWTS,IWORK,IOUT) PRINT 700 WRITE(IOUT,700) 700 FORMAT(/1X,'PROGRAM ENDED NORMALLY') STOP END ************************************************************************ SUBROUTINE START(N,P,NF,MAXVAR,IOUT,VERSON) INTEGER N,P,MAXVAR,IOUT,NF CHARACTER VERSON*72 C LOCAL VARIABLES CHARACTER*60 FN CHARACTER*80 TITLE LOGICAL NEW,OLD INTEGER IOPT,NIN,UN EXTERNAL UGETIO,GTOPFN TITLE=' ENTER THE NAME OF THE OUTPUT FILE' UN=6 NEW=.TRUE. OLD=.FALSE. C SET OUTFILE UNIT TO BE 6 CALL GTOPFN(UN,FN,NEW,OLD,TITLE) IOUT=6 IOPT=3 NIN=5 C SET OUTPUT UNIT TO BE 6 FOR IMSL CALL UGETIO(IOPT,NIN,IOUT) WRITE(IOUT,710) 710 FORMAT('1') PRINT 720, VERSON WRITE(IOUT,720) VERSON 720 FORMAT(/1X,'THIS PROGRAM WILL COMPUTE FACTOR SCORE WEIGHTS', + /1X,A) 10 CONTINUE PRINT 730,MAXVAR 730 FORMAT(/,'ENTER THE NUMBER OF VARIABLES : <= ',I5) READ*,P IF (P.GT.MAXVAR) THEN PRINT*,'ERROR IN NUMBER OF VARIABLES' GOTO 10 ENDIF PRINT 740,P WRITE(IOUT,740) P 740 FORMAT(/1X,'NUMBER OF VARIABLES = ',I5) PRINT 750 750 FORMAT(/,'ENTER THE NUMBER OF CASES') READ*,N PRINT 760,N WRITE(IOUT,760) N 760 FORMAT(/1X,'NUMBER OF CASES = ',I5) UN=7 NEW=.FALSE. OLD=.TRUE. TITLE='ENTER FILE WITH CORRELATION MATRIX IN SYMMETRIC STORAGE' C SET CORRELATION FILE UNIT TO BE 7 CALL GTOPFN(UN,FN,NEW,OLD,TITLE) WRITE(IOUT,770) FN 770 FORMAT(/1X,'DATA FILE = ',A) PRINT 780 780 FORMAT(/,'ENTER THE NUMBER OF FACTORS') READ*,NF WRITE(IOUT,790) NF 790 FORMAT(/1X,'NUMBER OF FACTORS = ',I5) UN=8 NEW=.FALSE. OLD=.TRUE. TITLE='ENTER THE FILE CONTAINING LAMBDA' C SET LAMBDA FILE UNIT TO BE 8 CALL GTOPFN(UN,FN,NEW,OLD,TITLE) WRITE(IOUT,800) FN 800 FORMAT(/1X,'LAMBDA FILE = ',A) RETURN END ************************************************************************ SUBROUTINE GTOPFN(UN,FN,NEW,OLD,TITLE) C GET AND OPEN FILENAME INTEGER UN CHARACTER*60 FN CHARACTER*80 TITLE LOGICAL NEW,OLD C UN (INPUT) UNIT TO OPEN FILE ON C FN (OUTPUT) NAME OF FILE THAT HAS BEEN OPENED C NEW (INPUT) C .TRUE. IF THE FILE IS REQUIRED TO BE A NEW FILE C .FALSE. OTHERWISE C OLD (INPUT) C .TRUE. IF THE FILE IS REQUIRED TO BE A OLD FILE C .FALSE. OTHERWISE C TITLE (INPUT) PROMPT TO BE PRINTED WHEN ASKING FOR FN C LOCAL VARIABLES LOGICAL EX 10 CONTINUE PRINT* PRINT 710,TITLE 710 FORMAT(A) READ 710,FN INQUIRE(FILE=FN,EXIST=EX) IF(NEW.AND.EX) THEN PRINT*,'FILE = ' PRINT*,' ',FN PRINT*,'EXISTS. PLEASE TRY AGAIN.' GOTO 10 ENDIF IF(OLD.AND.(.NOT.EX)) THEN PRINT*,'FILE = ' PRINT*,' ',FN PRINT*,'DOES NOT EXIST. PLEASE TRY AGAIN.' GOTO 10 ENDIF OPEN(UNIT=UN,FILE=FN,ERR=20) REWIND UN RETURN 20 CONTINUE PRINT*,'ERROR IN OPENING FILE =' PRINT*,FN PRINT*,'PLEASE TRY AGAIN.' GOTO 10 END ************************************************************************ SUBROUTINE QUERY(TITLE,RESPON) CHARACTER*50 TITLE LOGICAL RESPON C LOCAL VARIABLES CHARACTER*1 ANS PRINT 710,TITLE 710 FORMAT(/,A) 10 CONTINUE PRINT 720 720 FORMAT('ENTER Y OR N *****CAPS ONLY*****') READ 730,ANS 730 FORMAT(A) IF((ANS.NE.'Y').AND.(ANS.NE.'N')) THEN GOTO 10 ENDIF RESPON=(ANS.EQ.'Y') RETURN END ************************************************************************ C SUBROUTINE UGETIO(IOPT,NIN,NOUT) C IMSL ROUTINE FOR SETTING AND RETRIVING INPUT OUTPUT UNITS C END ************************************************************************ SUBROUTINE GETCOR(P,CORR,IOUT) INTEGER P,IOUT DOUBLE PRECISION CORR(P*(P+1)/2) C LOCAL VARIABLES INTEGER INUNIT,I LOGICAL FREE CHARACTER TITLE*50,FMT*80 EXTERNAL QUERY TITLE='IS THE CORR FILE IN FREE FORMAT?' CALL QUERY(TITLE,FREE) INUNIT=7 IF (.NOT.FREE) THEN PRINT 710 710 FORMAT(/,'ENTER THE FORTRAN FORMAT FOR CORR') READ 720, FMT 720 FORMAT(A) READ(INUNIT,FMT,ERR=10) (CORR(I),I=1,P*(P+1)/2) ELSE READ(INUNIT,*,ERR=10) (CORR(I),I=1,P*(P+1)/2) ENDIF RETURN 10 CONTINUE PRINT 730,I WRITE(IOUT,730) I 730 FORMAT(/1X,'ERROR IN READING CORR MATRIX', + /1X,'ERROR OCCURRED WHILE READING ROW ',I5) STOP END ************************************************************************ SUBROUTINE COROUT(P,CORR,IOUT) INTEGER P,IOUT DOUBLE PRECISION CORR(P*(P+1)/2) C LOCAL VARIABLES INTEGER NC,IOPT CHARACTER*20 ITITLE EXTERNAL USWSM WRITE(IOUT,710) 710 FORMAT(1X) ITITLE='CORRELATION MATRIX' NC=20 IOPT=2 CALL USWSM(ITITLE,NC,CORR,P,IOPT) RETURN END ************************************************************************ C SUBROUTINE USWSM(ITITLE,NC,A,M,IOPT) C IMSL ROUTINE FOR PRINTING A SYMMETRIC MATRIX C END ************************************************************************ SUBROUTINE GETLAM(P,NF,LAMBDA,IOUT) INTEGER P,IOUT,NF DOUBLE PRECISION LAMBDA(P,NF) C LOCAL VARIABLES INTEGER INUNIT,I,J LOGICAL FREE CHARACTER TITLE*50,FMT*80 EXTERNAL QUERY TITLE='IS THE LAMBDA FILE IN FREE FORMAT?' CALL QUERY(TITLE,FREE) INUNIT=8 IF (.NOT.FREE) THEN PRINT 710 710 FORMAT(/,'ENTER THE FORTRAN FORMAT FOR LAMBDA') READ 720, FMT 720 FORMAT(A) DO 10,I=1,P READ(INUNIT,FMT,ERR=30) (LAMBDA(I,J),J=1,NF) 10 CONTINUE ELSE DO 20,I=1,P READ(INUNIT,*,ERR=30) (LAMBDA(I,J),J=1,NF) 20 CONTINUE ENDIF RETURN 30 CONTINUE PRINT 730,I WRITE(IOUT,730) I 730 FORMAT(/1X,'ERROR IN READING LAMBDA MATRIX', + /1X,'ERROR OCCURRED WHILE READING ROW ',I5) STOP END ************************************************************************ SUBROUTINE LAMOUT(P,NF,LAMBDA,IOUT) INTEGER P,NF,IOUT DOUBLE PRECISION LAMBDA(P,NF) C LOCAL VARIABLES INTEGER NC,IOPT CHARACTER*20 ITITLE EXTERNAL USWFM WRITE(IOUT,710) 710 FORMAT(1X) ITITLE='LAMBDA MATRIX' NC=20 IOPT=2 CALL USWFM(ITITLE,NC,LAMBDA,P,P,NF,IOPT) RETURN END ************************************************************************ C SUBROUTINE USWFM(ITITLE,NC,A,IA,N,M,IOPT) C IMSL ROUTINE FOR PRINTING A FULL STORAGE MODE MATRIX C END ************************************************************************ SUBROUTINE PRTOUT(P,NF,IOUT,MINCP,NV,TABLE) INTEGER IOUT,NF,NV(NF),P DOUBLE PRECISION MINCP(NF),TABLE(NF,P,4) C LOCAL VARIABLES INTEGER F,I,J DO 20,F=1,NF WRITE(IOUT,710) F 710 FORMAT(//,1X,72('*'),//,1X,'ANALYSIS FOR FACTOR ',I4,//) WRITE(IOUT,720) MINCP(F),F,NV(F) 720 FORMAT(/1X,25X,'* * * * SUMMARY * * * *',/1X, + /1X,'MINIMUM CP IS ',G16.5, + /1X,'NUMBER OF VARIABLES FOR FACTOR ',I5,' IS ',I5,/) WRITE(IOUT,730) 730 FORMAT(/,1X,'VARIABLE',4X,'COEFFICIENT',4X,'F-VALUE', + 4X,'P-VALUES') DO 10,I=1,NV(F) WRITE(IOUT,740) (TABLE(F,I,J),J=1,4) 740 FORMAT(/,1X,F8.0,4X,F11.4,4X,F7.2,4X,F8.4) 10 CONTINUE 20 CONTINUE RETURN END ************************************************************************ SUBROUTINE PATTRN(P,NF,FSWTS,IWORK,IOUT) INTEGER P,NF,IOUT,IWORK(NF) DOUBLE PRECISION FSWTS(P,NF) C LOCAL VARIABLES INTEGER I,J,LEFT,RIGHT,JLEFT CHARACTER STRING*68 LOGICAL FIRST INTRINSIC MIN EXTERNAL FILSTR DO 10,I=1,NF IWORK(I)=I 10 CONTINUE WRITE(IOUT,710) 710 FORMAT(//,1X,72('*'),//,1X,'FACTOR SCORE WEIGHTS:',/) WRITE(IOUT,720) (IWORK(I),I=1,NF) 720 FORMAT(1X,6X,8(I8)/(7X,8(I8))) DO 20,I=1,P WRITE(IOUT,730) I,' : ',(FSWTS(I,J),J=1,NF) 730 FORMAT (1X,I3,A3,8(F8.3)/(7X,8(F8.3))) 20 CONTINUE WRITE(IOUT,740) 740 FORMAT(//,1X,'FACTOR SCORE WEIGHTS PATTERN',/) WRITE(IOUT,720) (IWORK(I),I=1,NF) DO 50,I=1,P FIRST=.TRUE. JLEFT=NF 30 CONTINUE STRING=' ' DO 40,J=1,MIN(JLEFT,8) RIGHT=8*J LEFT=RIGHT+1-8 CALL FILSTR(STRING,LEFT,RIGHT,FSWTS(I,J)) 40 CONTINUE IF(FIRST) THEN WRITE(IOUT,750) I,' : ',STRING 750 FORMAT(1X,I3,A3,A) ELSE WRITE(IOUT,760) STRING 760 FORMAT(1X,3X,3X,A) ENDIF JLEFT=JLEFT-8 FIRST=.FALSE. IF(JLEFT.GT.0) GOTO 30 50 CONTINUE RETURN END ************************************************************************ SUBROUTINE FILSTR(STRING,LEFT,RIGHT,FSWT) CHARACTER STRING*68 INTEGER LEFT,RIGHT DOUBLE PRECISION FSWT C LOCAL VARIABLES DOUBLE PRECISION CUTPT(7),ZERO INTRINSIC ABS PARAMETER(ZERO=0.0D0) CUTPT(1)=0.1D0 CUTPT(2)=0.2D0 CUTPT(3)=0.3D0 CUTPT(4)=0.4D0 CUTPT(5)=0.5D0 CUTPT(6)=0.6D0 CUTPT(7)=0.7D0 IF (FSWT.GT.ZERO) THEN IF (FSWT.LE.CUTPT(1)) THEN STRING(LEFT:RIGHT)=' ' ELSE IF (FSWT.LE.CUTPT(2)) THEN STRING(LEFT:RIGHT)=' +' ELSE IF (FSWT.LE.CUTPT(3)) THEN STRING(LEFT:RIGHT)=' ++' ELSE IF (FSWT.LE.CUTPT(4)) THEN STRING(LEFT:RIGHT)=' +++' ELSE IF (FSWT.LE.CUTPT(5)) THEN STRING(LEFT:RIGHT)=' ++++' ELSE IF (FSWT.LE.CUTPT(6)) THEN STRING(LEFT:RIGHT)=' +++++' ELSE IF (FSWT.LE.CUTPT(7)) THEN STRING(LEFT:RIGHT)=' ++++++' ELSE STRING(LEFT:RIGHT)=' +++++++' ENDIF ELSE IF (ABS(FSWT).LE.CUTPT(1)) THEN STRING(LEFT:RIGHT)=' ' ELSE IF (ABS(FSWT).LE.CUTPT(2)) THEN STRING(LEFT:RIGHT)=' -' ELSE IF (ABS(FSWT).LE.CUTPT(3)) THEN STRING(LEFT:RIGHT)=' --' ELSE IF (ABS(FSWT).LE.CUTPT(4)) THEN STRING(LEFT:RIGHT)=' ---' ELSE IF (ABS(FSWT).LE.CUTPT(5)) THEN STRING(LEFT:RIGHT)=' ----' ELSE IF (ABS(FSWT).LE.CUTPT(6)) THEN STRING(LEFT:RIGHT)=' -----' ELSE IF (ABS(FSWT).LE.CUTPT(7)) THEN STRING(LEFT:RIGHT)=' ------' ELSE STRING(LEFT:RIGHT)=' -------' ENDIF ENDIF END ************************************************************************ SUBROUTINE MODEL(P,N,NF,CORR,LAMBDA, + FSWTS,MINCP,NV,TABLE, + WORK1,WORK2,WORK3,WORK4,IWORK,IXS,IXV,NVAR) C P INPUT : INTEGER C NUMBER OF VARIABLES C N INPUT : INTEGER C NUMBER OF CASES C NF INPUT : INTEGER C NUMBER OF FACTORS C CORR INPUT : DOUBLE PRECISION C DIMENSION P*(P+1)/2 C CORRELATION MATRIX IN SYMMETRIC STORAGE C LAMBDA INPUT : DOUBLE PRECISION C DIMENSION (P,NF) C LAMBDA MATRIX OF FACTOR LOADINGS C FSWTS OUTPUT : DOUBLE PRECISION C DIMENSION (P,NF) C MATRIX OF FACTOR SCORE WEIGHTS C MINCP OUTPUT : DOUBLE PRECISION C DIMENSION NF C VECTOR OF MINIMUN CP VALUES C NV OUTPUT : INTEGER C DIMENSION NF C VECTOR GIVING NUMBER OF VARIABLES C ASSOCIATED WITH FACTOR C TABLE OUTPUT : DOUBLE PRECISION C DIMENSION (NF,P,4) C SUMMARY TABLE FROM MODEL C COLUMN 1 CONTAINS BEST VARIABLES C COLUMN 2 CONTAINS FACTOR SCORE WEIGHTS C COLUMN 3 CONTAINS F-VALUES C COLUMN 4 CONTAINS P-VALUES C WORK1 WORK : DOUBLE PRECISION C DIMENSION (2*(P+1)**3+4*(P+1))/3 C SUBROUTINE RLEAP (2*(P+1)**3+4*(P+1))/3 C WORK2 WORK : DOUBLE PRECISION C DIMENSION 10*(P+1) C SUBROUTINE RLEAP 10*(P+1) C WORK3 WORK : DOUBLE PRICISION C DIMENSION 2*P C SUBROUTINE RLEAP 2*P C WORK4 WORK : DOUBLE PRECISION C DIMENSION (P,4) C SUBROUTINE RLEAP (PX4) C IWORK WORK : INTEGER C DIMENSION 3*(P+1)*(P+1)+9*(P+1)+12 C SUBROUTINE RLEAP 3*(P+1)**2+9*(P+1)+12 C SUBROUTINE PATTRN P C IXS WORK : INTEGER C DIMENSION P+1 C SUBROUTINE RLEAP P+1 C IXV WORK : INTEGER C DIMENSION P+1 C SUBROUTINE RLEAP P+1 C NVAR WORK INTEGER C DIMENSION P*(P+1) C SUBROUTINE RLEAP P*(P+1) INTEGER N,P,NF,NV(NF), + IXV(P+1),IXS(3*(P+1)), + NVAR(P*(P+1)),IWORK(3*(P+1)*(P+1)+9*(P+1)+12) DOUBLE PRECISION WORK1((2*(P+1)*(P+1)*(P+1)+4*(P+1))/3), + WORK3(2*P),TABLE(NF,P,4), + WORK2((P+1),10),FSWTS(P,NF), + CORR(P*(P+1)/2),WORK4(P,4), + LAMBDA(P,NF),MINCP(NF) C LOCAL VARIABLES INTEGER F,I,IER,PP1,IJOB(4),IXB(2),INDX,J,JJ,INDSYM DOUBLE PRECISION ONE,ZERO EXTERNAL RLEAP,INDSYM INTRINSIC NINT PARAMETER(ONE=1.0D0, + ZERO=0.0D0) PP1=P+1 DO 70,F=1,NF C WORK1 CONTAINS THE CORRELATION MATRIX FOR RLEAP DO 10, I=1,P*PP1/2 WORK1(I)=CORR(I) 10 CONTINUE C ESTIMATE CORR(X,F) BY VARIMAX FACTOR LOADINGS DO 20, J=1,P JJ=INDSYM(PP1,J) WORK1(JJ)=LAMBDA(J,F) IF (WORK1(JJ).GT.0.9999D0) WORK1(JJ)=0.9999D0 IF (WORK1(JJ).LT.-0.9999D0) WORK1(JJ)=-0.9999D0 20 CONTINUE WORK1(INDSYM(PP1,PP1))=ONE C IJOB(1) CONTAINS N-1 C IJOB(2) = 3 MEANS USE MALLOWS' CP STATISTIC C IJOB(3) = 1 IS NUMBER OF BEST SUBSETS C IJOB(4) = 2 ALLOWS 2 SUBSETS TO BE STORED IJOB(1)=N-1 IJOB(2)=3 IJOB(3)=1 IJOB(4)=2 CALL RLEAP(WORK1,PP1,IJOB,IXS,WORK3,IXV,NVAR,IXB,WORK4,P, + WORK2,IWORK,IER) C WORK3 CONTAINS MALLOWS' CP STATISTICS C IXS CONTAINS INDEX FOR WORK3 C NVAR CONTAINS VARIABLES USED IN THE MODEL C IXV CONTAINS INDEX FOR NVAR C E.G. IF MINIMUM CP OCCURS AT WORK3(11) WHERE C IXS = (1,3,5,7,9,11,13,...) THEN THE NUMBER OF VARIABLES C USED IS 6 SINCE IXS(6) = 11. ALSO, IXV(6) = 31 SINCE C 31 = 1 + ((1+1) + (2+2) + (3+3) + (4+4) + (5+5)), SO C THE BEST VARIABLES ARE LOCATED IN NVAR(31) TO NVAR(31+6). MINCP(F)=1.0D38 DO 30,I=1,P INDX=IXS(I) IF (WORK3(INDX).LT.MINCP(F)) THEN NV(F)=I MINCP(F)=WORK3(INDX) ENDIF 30 CONTINUE C BEST MODEL CONTAINS NV(F) VARIABLES FOR FACTOR F C MINIMUM CP IS IN MINCP(F) FOR FACTOR F C COLUMN 1 OF TABLE CONTAINS BEST VARIABLES C COLUMN 2 OF TABLE CONTAINS FACTOR SCORE WEIGHTS C COLUMN 3 OF TABLE CONTAINS F-VALUES C COLUMN 4 OF TABLE CONTAINS P-VALUES DO 40,I=1,NV(F) TABLE(F,I,1)=WORK4(I,1) TABLE(F,I,2)=WORK4(I,2) TABLE(F,I,3)=WORK4(I,3) TABLE(F,I,4)=WORK4(I,4) 40 CONTINUE C FSWTS CONTAINS THE FACTOR SCORE WEIGHTS DO 50, I=1,P FSWTS(I,F)=ZERO 50 CONTINUE DO 60,I=1,NV(F) FSWTS(NINT(TABLE(F,I,1)),F)=TABLE(F,I,2) 60 CONTINUE 70 CONTINUE RETURN END ************************************************************************ FUNCTION INDSYM(I,J) INTEGER INDSYM,I,J INDSYM=I*(I-1)/2 + J RETURN C END ************************************************************************ C SUBROUTINE RLEAP(RR,KZ,IJOB,IXS,STAT,IXV,NVAR,IXB,BEST,IB,WK,IW, C + IER) C IMSL ROUTINE FOR FINDING THE BEST REGRESSION SUBSET C END ************************************************************************ END ************************************************************************ APPENDIX E: THE CALL STATEMENTS FROM FSCORE 1: PROGRAM FSCORE 56: CALL START(N,P,NF,MAXVAR,IOUT,VERSON) 58: CALL GETCOR(P,CORR,IOUT) 60: CALL COROUT(P,CORR,IOUT) 62: CALL GETLAM(P,NF,LAMBDA,IOUT) 64: CALL LAMOUT(P,NF,LAMBDA,IOUT) 66: CALL MODEL(P,N,NF,CORR,LAMBDA, 67: + FSWTS,MINCP,NV,TABLE, 68: + WORK1,WORK2,WORK3,WORK4,IWORK,IXS,IXV,NVAR) 69: CALL PRTOUT(P,NF,IOUT,MINCP,NV,TABLE) 70: CALL PATTRN(P,NF,FSWTS,IWORK,IOUT) 77: SUBROUTINE START(N,P,NF,MAXVAR,IOUT,VERSON) 91: CALL GTOPFN(UN,FN,NEW,OLD,TITLE) 96: CALL UGETIO(IOPT,NIN,IOUT) 125: CALL GTOPFN(UN,FN,NEW,OLD,TITLE) 138: CALL GTOPFN(UN,FN,NEW,OLD,TITLE) 144: SUBROUTINE GTOPFN(UN,FN,NEW,OLD,TITLE) 189: SUBROUTINE QUERY(TITLE,RESPON) 212: SUBROUTINE GETCOR(P,CORR,IOUT) 221: CALL QUERY(TITLE,FREE) 241: SUBROUTINE COROUT(P,CORR,IOUT) 253: CALL USWSM(ITITLE,NC,CORR,P,IOPT) 261: SUBROUTINE GETLAM(P,NF,LAMBDA,IOUT) 270: CALL QUERY(TITLE,FREE) 294: SUBROUTINE LAMOUT(P,NF,LAMBDA,IOUT) 306: CALL USWFM(ITITLE,NC,LAMBDA,P,P,NF,IOPT) 314: SUBROUTINE PRTOUT(P,NF,IOUT,MINCP,NV,TABLE) 337: SUBROUTINE PATTRN(P,NF,FSWTS,IWORK,IOUT) 368: CALL FILSTR(STRING,LEFT,RIGHT,FSWTS(I,J)) 384: SUBROUTINE FILSTR(STRING,LEFT,RIGHT,FSWT) 438: SUBROUTINE MODEL(P,N,NF,CORR,LAMBDA, 439: + FSWTS,MINCP,NV,TABLE, 440: + WORK1,WORK2,WORK3,WORK4,IWORK,IXS,IXV,NVAR) 532: CALL RLEAP(WORK1,PP1,IJOB,IXS,WORK3,IXV,NVAR,IXB,WORK4,P, 533: + WORK2,IWORK,IER) The following subroutines are from IMSL: UGETIO USWSM USWFM RLEAP ************************************************************************