EXTERNAL PRIINM CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C THIS EXTERNAL PART OF THE SUBROUTINE PRIINM C C READS SOME ESSENTIAL PARAMETERS FOR STORAGE C C ALLOCATION AND COMPUTES THE TOTAL AMOUNT OF C C NECESSARY STORAGE. C C C C THE RETURN IS IN THE SUBROUTINE PRIINM C C C C SUBROUTINES CALLED : DECLAR C C C C ALBERT GIFI FEB. 1981 C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC COMMON /VARBLS/ NOBS,NVAR,NDIM,MAXC,ISUC, + INPU,IDAT,IWR1,IPLO,IOUT1,MAXI,NONV,NOND, + NVNV,NDSQ,NDND,ISND,NAUX,NVND, + NDAT,NIPA,EPSI,IJOB,NJOB,NPLV,NAME(20),NAID, + ILEV,EPSIN,NITIN,IWR2,IOUT2,IOUT3,IOUT4,IPRIN, + LABEL(35),ICAT COMMON /LINOUT/ ICAR,IPRI CCCC ICAR=5 C>>>> ICAR = UNIT-NUMBER OF THE CARD-READER IPRI=6 C>>>> IPRI = UNIT-NUMBER OF THE PRINTER READ (ICAR,1000) NJOB WRITE(IPRI,5700) WRITE(IPRI,5800) WRITE(IPRI,5900) CCCC CCCC START THE DO LOOP OVER THE NUMBER OF JOBS CCCC DO 200 IJOB=1,NJOB WRITE (IPRI,5000) CCCC CCCC READ PARAMETER CARDS CCCC READ (ICAR,1100) NAME READ (ICAR,1000) NOBS,NVR1,NVR2,NDIM,MAXC,ISUC READ (ICAR,1200) MAXI,EPSI,NITIN,EPSIN READ (ICAR,1000) INPU,IDAT,IWR1,IWR2,IPLO,IOUT1,IOUT2,IOUT3,ILEV, + IPRIN,ICAT,IOUT4 CCCC CCCC ADJUST THE NUMBER OF DIMENSIONS IF THE RANK OF THE CCCC DATAMATRIX IS SMALLER THAN THE NUMBER OF DIMENSIONS CCCC THIS APPLIES ONLY TO THE CASES WHERE ALL VARIABLES CCCC HAVE THE SAME MEASUREMENT LEVEL. CCCC THE SAME SITUATION FOR MIXED VARIABLES IS TESTED IN CCCC THE ROUTINE PRIINM. CCCC ISRANK = MIN0(NVR2,NOBS) IMRANK = MIN0((ISUC-NVR2),NOBS) IF(ILEV-1) 3,1,2 1 IF(NDIM.LE.IMRANK) GOTO 3 NDIM = IMRANK WRITE(IPRI,4000) IMRANK GOTO 3 2 IF(NDIM.LE.ISRANK) GOTO 3 NDIM = ISRANK WRITE(IPRI,4000) ISRANK 3 CONTINUE CCCC CCCC ASSIGN SOME DEFAULT VALUES AND COMPUTE SOME USEFUL CCCC COMBINATIONS OF PARAMETERS CCCC IF (MAXI.LE.0) MAXI = 75 IF (NITIN.LE.0) NITIN= 20 E = .1E-20 IF (EPSI.LT.E) EPSI = .5E-4 IF (EPSIN.LT.E) EPSIN = .5E-1/FLOAT(NOBS) IF (INPU.EQ.0) INPU = ICAR IF (NVR1.LT.NVR2) NVR1 = NVR2 NVAR = NVR2 NPLV = NVR1 - NVR2 NVR1 = NVR2 + NPLV NONV = NOBS * NVAR NOND = NOBS * NDIM NVNV = NVAR * (NVAR-1) / 2 NDSQ = NDIM * NDIM NDND = NDIM * (NDIM+1) / 2 ISND = ISUC * NDIM NDAT = NPLV * NOBS + MAX0(NVAR,2*MAXC) NVND = NVAR * NDIM CCCC NAID = ISND IIII = (NDND+NOBS) * 2 III = ISUC+((NVAR*(NVAR-1))/2)+1 NAUX = MAX0(6*NDSQ,IIII,(MAXC*(6+MAXC)+2*NDIM+NDSQ+III), + 2*NVAR,2*MAXC*NDIM,3*NOBS,8*MAXC,NVND) NIPA = 1 JPLO=IPLO/10 KPLO=IPLO-JPLO*10 IF (JPLO.EQ.2.OR.KPLO.EQ.2) NIPA = NVR1 CCCC CCCC COMPUTE THE NECESSARY STORAGE FOR ALL PARAMETER-DEPENDING ARRAYS CCCC ISUM = NONV + NVAR + ISUC*3 + NOND*2 + ISND*2 + NVND + NOND*2 + + NAUX + NDAT + NOBS*3 + NIPA + NVAR + NVAR*5 + NVND*2 + + NVAR*3 + NAID + NDIM CCCC CCCC WRITE PARAMETERS CCCC WRITE (IPRI,5050) IJOB,NAME WRITE (IPRI,5100) NOBS,NVR1,NVR2,NDIM,MAXC,ISUC, + MAXI,EPSI,NITIN,EPSIN WRITE (IPRI,5200) INPU,IDAT,IWR1,IWR2 WRITE (IPRI,5300) IPLO,IOUT1,IOUT2,IOUT3 WRITE (IPRI,5400) ILEV,IPRIN WRITE (IPRI,5500) ICAT WRITE (IPRI,5600) IOUT4 CCCC CCCC CALL VARIABLE STORAGE ALLOCATOR, RETURN IN SUBROUTINE 'PRIINM' CCCC CALL DECLAR (PRIINM,A,ISUM) IF (IOUT1.GT.0) REWIND IOUT1 IF (IOUT2.GT.0) REWIND IOUT2 IF (IOUT3.GT.0) REWIND IOUT3 IF (IOUT4.GT.0) REWIND IOUT4 200 CONTINUE CCCC CCCC FORMAT-LIST CCCC 1000 FORMAT (16I5) 1100 FORMAT (20A4) 1200 FORMAT (I5,E10.8,I5,E10.8) 4000 FORMAT(50H0THE NUMBER OF DIMENSIONS IS ADJUSTED BECAUSE THE / + 50H RANK OF THE DATAMATRIX IS SMALLER THAN THE NUMBER, + 40H OF DIMENSIONS. THE NEW VALUE IS : NDIM=,I4/ + 51H THIS APPLIES ONLY TO THE CASE WHERE ALL VARIABLES , + 32HHAVE THE SAME MEASUREMENT LEVEL.//) 5000 FORMAT (1H1/// + 20H P R I N C A L S,16X,26HA PROGRAM FOR PRINCIPAL CO, + 17HMPONENTS ANALYSIS,21X,12H ALBERT GIFI/ + 1H ,35X,46HOF DISCRETE DATA WITH MIXED MEASUREMENT LEVELS, + 18X,25H DEPARTMENT OF DATATHEORY/ + 20H VERSION 6.00,78X,27H THE UNIVERSITY OF LEYDEN/ + 1H ,99X,14H BREESTRAAT 70/ + 16H MARCH 1981,84X,7H LEYDEN/ + 1H ,99X,16H THE NETHERLANDS////) 5050 FORMAT (1H ,8X,10H =========/1H ,8X,8H JOB NR.,I2/ 0 + 1H ,8X,10H =========//// + 1H ,8X,27H INPUT-DATA SPECIFICATIONS:/ + 1H ,8X,27H ------------------------- ///1H ,8X,8H NAME : , + 20A4///) 5100 FORMAT (1H ,8X,23H * PROBLEM PARAMETERS */ + 1H ,8X,21H ------------------/// + 1H ,8X,23H NUMBER OF OBJECTS ,50X,I5// + 1H ,8X,44H TOTAL NUMBER OF VARIABLES IN THE DATAMATRIX,29X,I5// + 1H ,8X,29H NUMBER OF ANALYSIS-VARIABLES,44X,I5// + 1H ,8X,23H NUMBER OF DIMENSIONS ,50X,I5// + 1H ,8X,48H MAXIMUM NUMBER OF CATEGORIES OVER ALL VARIABLES,25X,I5 +//1H ,8X,53H TOTAL NUMBER OF CATEGORIES OF THE ANALYSIS VARIABLES, + 20X,I5///// + 1H ,8X,24H * ANALYSIS PARAMETERS */ + 1H ,8X,22H -------------------/// + 1H ,8X,50H MAXIMUM NUMBER OF ITERATIONS TO COMPUTE THE FINAL, + 14H CONFIGURATION,9X,I5// + 1H ,8X,50H CONVERGENCE CRITERION FOR THE FINAL CONFIGURATION, + 18X,E10.2// + 1H ,8X,52H MAXIMUM NUMBER OF ITERATIONS TO COMPUTE THE INITIAL, + 14H CONFIGURATION,7X,I5// + 1H ,8X,52H CONVERGENCE CRITERION FOR THE INITIAL CONFIGURATION, + 16X,E10.2/) 5200 FORMAT (1H1///1H ,8X,28H * INPUT/OUTPUT PARAMETERS */ + 1H ,8X,26H -----------------------/// + 1H ,8X,30H UNIT NUMBER OF THE DATAMATRIX,43X,I5// + 1H ,8X,52H PARAMETER INDICATING WHETHER OR NOT (1 AND 0 RESP.), + 21X,I5/1H ,8X,24H TO PRINT THE DATAMATRIX// + 1H ,8X,45H PARAMETER INDICATING WHETHER OR NOT TO PRINT,28X,I5, + /1H ,8X,34H OBJECT- AND CATEGORY INFORMATION / + 1H ,11X,12H=0: NO PRINT/1H ,11X,22H=1: OBJECT SCORES ONLY/ + 1H ,11X,49H=2: OBJECT SCORES AND OPTIMALLY SCALED CATEGORIES/ + 1H ,11X,36H=3: OPTIMALLY SCALED CATEGORIES ONLY// + 1H ,8X,52H PARAMETER INDICATING WHETHER OR NOT (1 AND 0 RESP.), + 21X,I5/1H ,8X,31H TO PRINT THE ITERATION HISTORY/) 5300 FORMAT (1H ,8X,47H PARAMETER INDICATING WHETHER OR NOT AND HOW TO, + 5H PLOT,21X,I5/ + 1H ,11X,11H=0: NO PLOT/1H ,11X,10H=1: OBJECT, + 46H SCORES, UNLABELED, AND COMPONENT LOADINGS / + 1H ,11X,51H=2: IN ADDITION, PLOT OF OBJECT SCORES AND/OR / + 1H ,11X,51H SEPARATE PLOTS OF THE CATEGORY QUANTIFICATIONS / + 1H ,11X,51H LABELED BY SELECTED VARIABLES // + 1H ,8X,47H UNIT-NUMBER FOR OUTPUT OF THE OBJECT SCORES TO, + 26X,I5/1H ,8X,27H CARD, TAPE OR DISK (=0: NO, + 21H OUTPUT OF THIS KIND)// + 1H ,8X,38H LIKEWISE FOR THE CATEGORY COORDINATES,35X,I5// + 1H ,8X,42H LIKEWISE FOR THE CATEGORY QUANTIFICATIONS,31X,I5/) 5400 FORMAT (1H ,8X,36H MEASUREMENT LEVEL FOR ALL VARIABLES,37X,I5/ + 1H ,11X,38H=0: MIXED MEASUREMENT LEVELS / + 1H ,11X,35H=1: ONLY MULTIPLE NOMINAL VARIABLES/ + 1H ,11X,33H=2: ONLY SINGLE NOMINAL VARIABLES/ + 1H ,11X,33H=3: ONLY SINGLE ORDINAL VARIABLES/ + 1H ,11X,35H=4: ONLY SINGLE NUMERICAL VARIABLES// + 1H ,8X,29H OUTPUT SUPPRESSING PARAMETER,44X,I5/ + 1H ,11X,52H=0: NO OUTPUT OF THE INITIAL CONFIGURATION / + 1H ,11X,50H=1: IDENTICAL OUTPUT OPTIONS FOR BOTH THE INITIAL / + 1H ,15X,23HAND FINAL CONFIGURATION/ + 1H ,11X,47H=2: OUTPUT OPTIONS FOR BOTH CONFIGURATIONS ARE / + 1H ,15X,27HFULLY SPECIFIED BY THE USER/) 5500 FORMAT (1H ,8X,39H NUMBER OF CATEGORIES FOR ALL VARIABLES,34X,I5/ + 1H ,11X,49H=K: THE CATEGORY NUMBERS FOR ALL VARIABLES EQUAL , + 1HK/ + 1H ,11X,47H=0: THE CATEGORY NUMBERS FOR ALL VARIABLES ARE , + 9HDIFFERENT/) 5600 FORMAT(1H ,8X,46H UNIT NUMBER FOR OUTPUT OF THE COMPONENT LOADI, + 6HNGS TO,21X,I5/1H ,8X,27H CARD, TAPE OR DISK (=0: NO, + 21H OUTPUT OF THIS KIND)//) 5700 FORMAT(1H1//////// + 40X,56H =======================================================/ + 40X,56H X X/ + 40X,56H X MARCH 1981 P R I N C A L S VERSION 6.00 X/ + 40X,56H X X/ + 40X,56H X FOR INFORMATION CALL: DATATHEORY OR THE REKEN- X/ + 40X,56H X BURO TEL 148333 EXT 2257,2252 OR 6559 X/ + 40X,56H X X/ + 40X,56H X THE FOLLOWING REMARKS MAY BE HELPFUL FOR X/ + 40X,56H X STUDYING THE OUTPUT X/ + 40X,56H X TOTAL LOSS = MULTIPLE LOSS + SINGLE LOSS X/ + 40X,56H X TOTAL FIT = NUMBER OF DIMENSIONS - TOTAL LOSS X/ + 40X,56H X MULTIPLE FIT = MULTIPLE COMPONENT OF TOTAL FIT X/ + 40X,56H X (FOR MULTIPLE VARIABLES THIS IS THE X/ + 40X,56H X HOMALS DISCRIMINATION-MEASURE) X) 5800 FORMAT(40X, + 56H X SINGLE FIT = SQUARED COMPONENT LOADINGS X/ + 40X,56H X (THE 'DISCRIMINATION MEASURE' FOR X/ + 40X,56H X SINGLE VARIABLES) X/ + 40X,56H X X/ + 40X,56H X NO CORRELATIONS BETWEEN OPTIMALLY SCALED VARIABLES X/ + 40X,56H X ARE COMPUTED IN CASE OF MISSING ENTRIES IN THE DATA X/ + 40X,56H X FOR MULTIPLE VARIABLES THE CORRELATIONS ARE BASED X/ + 40X,56H X ON THE QUANTIFICATIONS OF THE FIRST DIMENSION X/ + 40X,56H X X/ + 40X,56H =======================================================) 5900 FORMAT(////,40X, + 56H ON FEBRUARY 3RD 1982 AN ERROR IN THE COMPUTATION OF / + 40X,56H THE CORRELATION MATRICES HAS BEEN ELIMINATED. THIS / + 40X,56H ERROR APPEARED WHEN VARIABLES FOR WHICH A DIFFERENT / + 40X,56H NUMBER OF CATEGORIES WAS SPECIFIED, WERE ANALYZED. /// + 40X,56H *******************************************************/ + 40X,56H * ON 12 MARCH 1984 AN ERROR IN THE COMPUTATION OF THE */ + 40X,56H * COMPONENT-LAODINGS HAS BEEN ELIMINATED. BECAUSE OF */ + 40X,56H * THIS ERROR ALSO CATEGORY QUANTIFICATIONS AND SINGLE */ + 40X,56H * LOSS GIVE THE WRONG RESULTS. THIS ERROR OCCURS IN */ + 40X,56H * FEW SOLUTIONS ONLY. */ + 40X,56H * FOR INFORMATION CALL: RENEE VERDEGAAL OR EEKE VAN */ + 40X,56H * DER BURG. TEL 148333 EXT. 2252, 2257 */ + 40X,56H *******************************************************) C STOP END SUBROUTINE DECLAR (HOMSUB,B,ISUM) DEC00010 DIMENSION A(15000) DEC00020 C>>>> DIMENSION A(ISUM) DEC00030 COMMON /LINOUT/ ICAR,IPRI DEC00040 IDIM = 15000 DEC00050 C>>>> IDIM = ISUM DEC00060 IF (ISUM.LE.IDIM) GO TO 10 DEC00070 WRITE (IPRI,1000) ISUM DEC00080 RETURN DEC00090 10 CONTINUE DEC00100 CALL HOMSUB(A,ISUM) DEC00110 1000 FORMAT (50H0ARRAY 'A' IN SUBROUTINE 'DECLAR' IS TOO SMALL FOR, DEC00120 + 9H THIS JOB/21H 'A' MUST BE AT LEAST,I8,5H LONG// DEC00130 + 45H EXECUTION OF THE PROGRAM HAS BEEN TERMINATED) DEC00140 RETURN DEC00150 END DEC00160 SUBROUTINE ADDDIA (GENMAT,DIAMAT,RESMAT,N,M,NM) INTEGER DIAMAT DOUBLE PRECISION GENMAT, RESMAT DIMENSION GENMAT(NM), DIAMAT(N), RESMAT(M) II = 0 DO 10 J=1,M DO 10 I=1,N II = II + 1 10 RESMAT(J) = RESMAT(J)+GENMAT(II)*GENMAT(II)*DIAMAT(I) RETURN END CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C*** C C*** THIS ROUTINE PRINTS CATEGORY SCORES FOR MULTIPLE C C*** AND SINGLE VARIABLES. C C*** SOME VALUES ARE RECOMPUTED AND RESCALED C C*** STRESSES ARE ALSO RECOMPUTED AND PRINTED C C*** C C*** SUBROUTINES CALLED : C C*** C C*** ADDDIA C C*** MEALEV C C*** CORREL C C*** SILOSS C C*** ALBERT GIFI FEB. 1981 C C*** C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C*** SUBROUTINE CATPRI(ICATGO,MARFRE,DATAIN,ITYP,MARFIN,YBLANK, + DIRCOS,AIDH,HULP,STRES1,CATSCO,STRES3, + OBSCOR,TEXT,STRESC,IPARTI,AUXILI,CROSSP, + NVAR,ISUC,NONV,MAXC,ISND,NDIM,NVND,NOND,IWR1, + ID,NAID,NITR,IOUT3,NIPA,IPLO,NAUX,NDSQ,INFIN) DIMENSION ICATGO(NVAR),MARFRE(ISUC),DATAIN(NONV),ITYP(NVAR), + MARFIN(ISUC),YBLANK(MAXC), AIDH(NAID),HULP(ID) , + STRES1(NVND),CATSCO(ISND),STRES3(NVAR),IPARTI(NIPA), + OBSCOR(NOND),TEXT(NVAR,5),STRESC(NDIM),DIRCOS(NVND), + AUXILI(NAUX),CROSSP(NDSQ) COMMON /LINOUT/ ICAR,IPRI INTEGER ICATGO,MARFRE,DATAIN,ITYP REAL YBLANK,HULP,AIDH,DIRCOS DOUBLE PRECISION STRES1,CATSCO,OBSCOR,MARFIN,STRES3,CONST3,CONST4, + TLOSS,SLOSS,TMLOSS,TFIT,T2,T3,T4 C*** NOBS=NOND/NDIM QNVA=1.0/NVAR+0. QNDI=1.0/NDIM+0. CONST=1./FLOAT(NOBS*NVAR) CONST2=1./SQRT(FLOAT(NOBS)) CONST3=1./DFLOAT(NOBS) CONST4=1./DFLOAT(NVAR) STRESA=0. STRESB=0. DO 123 IP=1,NDIM STRESC(IP)=0. 123 CONTINUE L=1 M=1 K=1 N=1 LL=1 LI=0 NN=1 IN=1 IM=0 MM=MAXC*(5+MAXC)+2*NDIM+NDSQ MISTO=0 WRITE(IPRI,2401) C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C ******** START THE LOOP OVER VARIABLES *********************** C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C DO 1 J=1,NVAR TSTRES=0. STRES3(J)=0.0D0 KATJ=ICATGO(J) ICND=NDIM*KATJ MISD=0 C*** IK=K-1 DO 2 IP=1,NDIM STRES1(IK+IP)=0.0D0 2 CONTINUE CALL ADDDIA(CATSCO(L),MARFRE(M),STRES1(K),KATJ,NDIM,ICND) C*** C*** CCCCCCCCCCC FOR SINGLE VARIABLES ONLY CCCCCCCCCCCCCCCCCCCCCC C*** IF(ITYP(J).EQ.0) GOTO 126 DO 11 I=1,ICND AIDH(LI+I)=CATSCO(LI+I) 11 CONTINUE MKJ=ID-NDIM CALL MEALEV(CATSCO(L),YBLANK,DIRCOS(K),HULP(1), + ITYP(J),MARFRE(M),STRES3(J), + KATJ,NDIM,ICND,MKJ,NOBS) CCCC CCCC RESCALE THE CORRELATIONS, CATEGORY SCORES AND CCCC THE OPTIMALLY SCALED DATAVECTORS CCCC 126 CONTINUE DO 124 KI=1,KATJ AUXILI(MM+KI+M-1)= YBLANK(KI) IF(ITYP(J).EQ.0) AUXILI(MM+KI+M-1)=CATSCO(LI+KI)*CONST2 124 CONTINUE IF(ITYP(J).EQ.0) GOTO 12 LCAT=-KATJ DO 7 IP=1,NDIM IQ=IP-1 DIRCOS(K+IQ)=DIRCOS(K+IQ)*1./SQRT(FLOAT(NOBS)) LCAT=LCAT+KATJ DO 8 IK=1,KATJ IL=IK-1 IF(IP.EQ.1) YBLANK(IK)=YBLANK(IK)*SQRT(FLOAT(NOBS)) CATSCO(L+IL+LCAT)=YBLANK(IK)*DIRCOS(K+IQ) 8 CONTINUE 7 CONTINUE CCCC CCCC CCCCCCC WRITE THE OPTIMALLY SCALED DATAVECTOR TO UNIT IOUT3 CCCC CCCCCCC AND REWIND IOUT3 CCCC IF(IOUT3.LE.0.OR.IOUT3.EQ.IPRI) GOTO 12 IOU=IOUT3 DO 13 IK=1,KATJ WRITE(IOU,3002) J,IK,YBLANK(IK) 13 CONTINUE CCCC 12 CONTINUE DO 20 IK=1,KATJ MISD=MISD+MARFRE(IN) IN=IN+1 20 CONTINUE MISD=NOBS-MISD MISTO=MISTO+MISD IF(IWR1.LE.1) GOTO 120 WRITE(IPRI,2400) (TEXT(J,I),I=1,5),MISD WRITE(IPRI,2403)(IP,IP=1,NDIM) C*** C*** CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C*** * PRINT THE CATEGORY QUANTIFICATIONS AND COORDINATES * C*** CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C*** C*** CCCC FOR MULTIPLE VARIABLES ONLY CCCCCCCCCCCCCCCCCCCCCCCC C*** IF(ITYP(J).NE.0) GOTO 119 IM=IM+1 WRITE(IPRI,2500) IK=K-1 DO 44 IP=1,NDIM DIRCOS(IK+IP)=0. 44 CONTINUE DO 4 IK=1,KATJ WRITE(IPRI,2700) IK,MARFRE(NN),(CATSCO(LI+I),I=IK,ICND,KATJ) NN=NN+1 4 CONTINUE WRITE(IPRI,2704) GOTO 120 119 CONTINUE C*** C*** CCCCCCC FOR SINGLE VARIABLES ONLY CCCCCCCCCCCCCCCCCCCCCCCCCC C*** WRITE(IPRI,2501) DO 5 IK=1,KATJ WRITE(IPRI,2701) IK,MARFRE(NN),YBLANK(IK),(CATSCO(LI+I), + I=IK,ICND,KATJ) NN=NN+1 5 CONTINUE WRITE(IPRI,2702) DO 6 IP=1,KATJ WRITE(IPRI,2703) (AIDH(LI+I),I=IP,ICND,KATJ) 6 CONTINUE WRITE(IPRI,2704) LL=LL+ICND 120 CONTINUE STRES3(J) = STRES3(J)*CONST3 IK = K-1 DO 3 IP=1,NDIM STRES1(IK+IP) = STRES1(IK+IP)*CONST3 3 CONTINUE DO 121 IP=1,NDIM I=IP-1 STRESC(IP)=STRESC(IP)+STRES1(K+I) CCCCC (STRESC = COLUMNSUM MULTIPLE FIT) 121 CONTINUE L=L+ICND LI=L-1 N=N+NOBS M=M+KATJ K=K+NDIM 1 CONTINUE IF(INFIN.EQ.1) WRITE (IPRI,2406) (IP,IP=1,NDIM) IF(INFIN.EQ.0) WRITE (IPRI,2402) (IP,IP=1,NDIM) WRITE (IPRI,2404) C CCCCC CCCCCCCC COMPUTE AND WRITE MULTIPLE FIT (AND SUMS) CCCCCCCCCCCC C IL = 1 IMULT=0 STRESA = 0. DO 222 I = 1,NVAR ILDIM = IL + NDIM - 1 IMULT=IMULT+ITYP(I) SUM=0. DO 225 IK=IL,ILDIM SUM = SUM + STRES1(IK) CCCCC (SUM = ROWSUM MULTIPLE FIT) 225 CONTINUE STRESA = STRESA + SUM CCCCC (STRESA = TOTAL SUM MULTIPLE FIT) WRITE(IPRI,2405)I,SUM,(STRES1(IK),IK=IL,ILDIM) 227 IL = IL + NDIM 222 CONTINUE STRESA = STRESA / FLOAT(NVAR) DO 223 I=1,NDIM STRESC(I) = STRESC(I) / FLOAT(NVAR) 223 CONTINUE WRITE (IPRI,2407) STRESA,(STRESC(JK),JK=1,NDIM) C CCCCC CCCCCCC COMPUTE FINAL LOSSES AND FIT CCCCCCCCCCCCCCCCCCCCCCC C T2 = 0.0D0 T3 = 0.0D0 T4 = 0.0D0 SLOSS = 0.0D0 TMLOSS = 0.0D0 TLOSS = 0.0D0 TFIT = 0.0D0 K = 1 DO 112 J=1,NVAR IK = K-1 DO 111 IP=1,NDIM T2 = T2 + STRES1(IK+IP)*CONST4 IF(ITYP(J).NE.0) T4 = T4 + STRES1(IK+IP)*CONST4 111 CONTINUE IF(ITYP(J).NE.0) T3 = T3 +STRES3(J)*CONST4 K = K+NDIM 112 CONTINUE SLOSS = T4 - T3 TMLOSS = NDIM - T2 TLOSS = TMLOSS + SLOSS TFIT = T2 - SLOSS IF(IMULT.NE.0) CALL SILOSS (STRES1,STRES3,DIRCOS,ITYP,NDIM, + NVAR,IPRI,STRESA,STRESC) WRITE(IPRI,3000) WRITE(IPRI,3001) NITR,TFIT,TLOSS,TMLOSS,SLOSS N=((NVAR*(NVAR-1))/2)+1 II=MM+1 III=II+ISUC IF (MISTO.EQ.0) CALL CORREL(DATAIN,AUXILI(II),NONV,ISUC,NOBS,NVAR, + AUXILI(III),N,ICATGO,OBSCOR,NOND,MARFRE,INFIN) 122 CONTINUE C*** C*** FORMAT LIST C*** 2401 FORMAT(1H1////) 2400 FORMAT(1H0//5X,12H------------/5X,8HVARIABLE,F4.0,20X,5HTYPE:, + 4A4,10X,8HMISSING:,I4/5X,12H------------) 2403 FORMAT(1H //5X,11HDIMENSION :,22X,(I4,9I9)//) 2402 FORMAT(1H1//5X,32H--------------------------------/ + 5X,32HSUMMARY OF INITIAL CONFIGURATION/5X,32(1H-)/ + //5X,11HDIMENSION :,6X,(I4,9I9)) 2406 FORMAT(1H1//5X,19H-------------------/ + 5X,19HSUMMARY OF ANALYSIS/5X,19H-------------------/ + //5X,11HDIMENSION :,6X,(I4,9I9)) 2404 FORMAT(1H ,//8X,11H ROW SUMS ,3X,12HMULTIPLE FIT/ + 8X,11H ,3X,12H------------/) 2405 FORMAT(1H ,I7,3X,F7.3,1X,(10F9.3)) 2407 FORMAT(1H0,10H MEAN ,F7.3,1X,(10F9.3)) 2500 FORMAT(1H0/4X,19H MARGINAL/ + 24H CATEGORY FREQUENCY,13X,24HCATEGORY QUANTIFICATIONS/ + 24H -------- ---------,13X,24H------------------------) 2501 FORMAT(//38H MARGINAL CATEGORY / +56H CATEGORY FREQUENCY QUANTIF. SINGLE CATEGORY COO, + 8HRDINATES/ +56H -------- --------- -------- -------------------, + 8H--------) 2700 FORMAT( 1H ,4X,I5,5X,I5,15X,(10F9.3)) 2701 FORMAT( 1H ,4X,I5,5X,I5,4X,F10.3,1X,(10F9.3)) 2702 FORMAT(//1H ,36X,29HMULTIPLE CATEGORY COORDINATES/ + 37X,29H-----------------------------) 2703 FORMAT( 1H ,34X,(10F9.3)) 2704 FORMAT(//1H0,130(1H-)) 3000 FORMAT(1H0// + 51H ITERATION TOTAL TOTAL MULTIP, + 51HLE SINGLE / + 51H NUMBER FIT LOSS LOSS , + 51H LOSS / + 51H --------- ----- ----- ------, + 51H-- ------ ) 3001 FORMAT(1H0,3X,I5,4F14.4) 3002 FORMAT(I3,1X,I3,1X,F8.3) RETURN END SUBROUTINE CORREL(DATAIN,Y,NM,ISUC,NOBS,NVAR,COR,N,ICATGO,OBSCOR, + NOND,MARFRE,INFIN) DIMENSION DATAIN(NM),Y(ISUC),COR(N),ICATGO(NVAR),OBSCOR(NOND), + MARFRE(ISUC) DOUBLE PRECISION OBSCOR INTEGER DATAIN COMMON /LINOUT/ICAR,IPRI CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCC CCCC ORIGINAL DATA ARE REPLACED BY CATEGORY QUANTIFICATIONS CCCC (OF THE FIRST DIMENSION FOR MULTIPLE VARIABLES), CCCC AND STANDARDIZED. CORRELATIONS ARE COMPUTED AND PRINTED. CCCC THIS ROUTINE IS ONLY CALLED IF THERE ARE NO MISSING ENTRIES CCCC CCCC SUBROUTINES CALLED: WEDEV CCCC WESTAN CCCC PRITRI CCCC ALBERT GIFI FEB. 1981 CCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCC DO 9 IK=1,N COR(IK)=0. 9 CONTINUE K=1 DO 10 J=1,NVAR CALL WEDEV(Y(K),MARFRE(K),ICATGO(J),NOBS) CALL WESTAN(Y(K),MARFRE(K),ICATGO(J),1) K=K+ICATGO(J) 10 CONTINUE IL=0 IK=0 JK=0 JNOBS=-NOBS NVA=NVAR-1 DO 1 K=1,NVA IK=IK+K JNOBS=JNOBS+NOBS JJNOBS=JNOBS IA=IK JK=IL+ICATGO(K) DO 2 J=K,NVA JJNOBS=JJNOBS+NOBS DO 3 I=1,NOBS REALJ=Y(JK+DATAIN(I+JJNOBS)) REALK=Y(IL+DATAIN(I+JNOBS)) COR(IA)=COR(IA)+REALJ*REALK 3 CONTINUE IA=IA+J JK=JK+ICATGO(J+1) 2 CONTINUE IL=IL+ICATGO(K) 1 CONTINUE CCCC CCCC PRINT THE UNDER TRIANGULAR MATRIX CCCC IF(INFIN.EQ.1) WRITE(IPRI,100) IF(INFIN.EQ.0) WRITE(IPRI,200) CCCC CALL PRITRI(COR,NVAR,N,IPRI) CCCC 100 FORMAT(1H1//5X,44H* CORRELATIONS BETWEEN OPTIMALLY SCALED VARI, + 7HABLES */7X,47(1H-)) 200 FORMAT(1H1///5X,37H* CORRELATIONS AFTER INITIALIZATION */ + 5X,37H --------------------------------- /) CCCC RETURN END SUBROUTINE DIFMEA (MATRIX,DIAGON,NROW,NCOL,NRNC,FACT,IOPT) DOUBLE PRECISION MATRIX, AUXI, INDI INTEGER DIAGON DIMENSION MATRIX (NRNC), DIAGON(NROW) L = 0 M = 0 IF (IOPT.NE.0) GO TO 30 DO 20 K=1,NCOL AUXI = 0.0D0 DO 10 I=1,NROW L = L + 1 10 AUXI = AUXI + MATRIX(L) AUXI = FACT * AUXI DO 20 I=1,NROW M = M + 1 20 MATRIX(M) = MATRIX(M) - AUXI * DIAGON(I) RETURN 30 INDI = 1.0D0 / (NROW+0.0D0) DO 50 K=1,NCOL AUXI = 0.0D0 DO 40 I=1,NROW L = L + 1 40 AUXI = AUXI + MATRIX(L) AUXI = INDI * AUXI DO 50 I=1,NROW M = M + 1 50 MATRIX(M) = MATRIX(M) - AUXI RETURN END SUBROUTINE GENPRO(DIRCOS,DATAIN,OBSCOR,RSUM,NVAR,NOBS,NDIM,NVND, + NONV,NOND) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C THIS ROUTINE COMPUTES A MATRIX PRODUCT OF TWO GENERAL C C MATRICES : A = B'C C C C C NO SUBROUTINES CALLED C C C C J.V.RIJCKEVORSEL OCT. 1978 C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C DIMENSION DIRCOS(NVND),OBSCOR(NOND),DATAIN(NONV),RSUM(NVAR) INTEGER DATAIN,PP REAL DIRCOS DOUBLE PRECISION OBSCOR C DO 4 L=1,NVND DIRCOS(L)=0. 4 CONTINUE DO 5 IP=1,NVAR RSUM(IP)=0. 5 CONTINUE C JJ=-NOBS II=-NDIM DO 3 J=1,NVAR JJ=JJ+NOBS II=II+NDIM PP=-NOBS DO 2 IP=1,NDIM PP=PP+NOBS DO 1 I=1,NOBS DIRCOS(IP+II)=DIRCOS(IP+II)+DATAIN(I+JJ)*OBSCOR(I+PP) 1 CONTINUE RSUM(J)=RSUM(J)+DIRCOS(IP+II)*DIRCOS(IP+II) 2 CONTINUE 3 CONTINUE CCCC DO 6 IJ=1,NVAR RSUM(IJ)=1./SQRT(RSUM(IJ)) 6 CONTINUE CCCC II=-NDIM DO 7 J=1,NVAR II=II+NDIM DO 8 IP=1,NDIM DIRCOS(IP+II)=DIRCOS(IP+II)*RSUM(J) 8 CONTINUE 7 CONTINUE RETURN END SUBROUTINE IMTQL2(IERR,N, 1 Z,D,E,NP) C ****************************************************************** C * * C * I M T Q L 2 * C * * C * PURPOSE: DETERMINES THE EIGENVALUES AND EIGENVECTORS OF A * C * SYMMETRIC TRIDIAGONAL MATRIX USING THE IMPLICIT * C * QL METHOD. * C * * C * SUBROUTINES CALLED: NONE * C * * C * ADAPTED FROM EISPACK * C * * C ****************************************************************** DIMENSION Z(NP,NP),D(NP),E(NP) REAL B,C,F,G,P,R,S,MACHEP REAL SQRT,ABS,SIGN C C ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPCIFYING C THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC. C C ********** C MACHEP = 2.0**(-20) C IERR = 0 IF (N .EQ. 1) GO TO 1001 C DO 100 I = 2, N 100 E(I-1) = E(I) C E(N) = 0.0 C DO 240 L = 1, N J = 0 C ********** LOOK FOR SMALL SUB-DIAGONAL ELEMENT ********** 105 DO 110 M = L, N IF (M .EQ. N) GO TO 120 IF (ABS(E(M)) .LE. MACHEP* (ABS(D(M)) + ABS(D(M+1)))) X GO TO 120 110 CONTINUE C 120 P = D(L) IF (M .EQ. L) GO TO 240 IF (J .EQ.30) GO TO 1000 J = J + 1 C ********** FORM SHIFT ********** G = (D(L+1) - P) / (2.0 * E(L)) R = SQRT(G*G+1.0) G = D(M) - P + E(L) / (G + SIGN(R,G)) S = 1.0 C = 1.0 P = 0.0 NML = M - L C ********** FOR I=M-1 STEP -1 UNTIL L DO -- ********** DO 200 II = 1, NML I = M - II F = S * E(I) B = C * E(I) IF (ABS(F) .LT. ABS(G)) GO TO 150 C = G / F R = SQRT(C*C+1.0) E(I+1) = F * R S = 1.0 / R C = C * S GO TO 160 150 S = F / G R = SQRT(S*S+1.0) E(I+1) = G* R C = 1.0 / R S = S * C 160 G = D(I+1) - P R = (D(I) - G) * S + 2.0 * C * B P = S * R D(I+1) = G + P G = C * R - B C ********** FORM VECTOR ********** DO 180 K = 1, N F = Z(K,I+1) Z(K,I+1) = S * Z(K,I) + C * F Z(K,I) = C * Z(K,I) - S * F 180 CONTINUE C 200 CONTINUE C D(L) = D(L) - P E(L) = G E(M) = 0.0 GO TO 105 240 CONTINUE C ********** ORDER EIGENVALUES AND EIGENVECTORS ********** DO 300 II = 2, N I = II - 1 K = I P = D(I) C DO 260 J = II, N IF (D(J) .LE. P ) GO TO 260 K = J P = D(J) 260 CONTINUE C IF (K .EQ. I) GO TO 300 D(K) = D(I) D(I) = P C DO 280 J = 1, N P = Z(J,I) Z(J,I) = Z(J,K) Z(J,K) = P 280 CONTINUE C 300 CONTINUE C GO TO 1001 C ********** SET ERROR -- NO CONVERGENCE TO AN C EIGENVALUE AFTER 30 ITERATIONS ********** 1000 IERR = L 1001 RETURN END CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C INIFIG REGULATES A COMPUTATIONAL FLOW C C TO COMPUTE A METRIC INITIAL CONFIGURATION C C WITH AN ITERATIVE A L S ALGORITHM C C THE METHOD IS EQUIVALENT TO THE SINGULAR C C VALUE DECOMPOSITION OF THE STANDARDIZED C C DATA MATRIX. C C C C PHASE SUBROUTINES C C CALLED C C C C INITIALIZATION RANDMA C C DIFMEA C C MPR1 C C MOGRAM C C GENPRO C C C C ! THE NEXT THREE PHASES ARE ITERATIVELY COMPUTED ! C C !----------------------------------------------- ! C C ! QUANTIFICATION PROING ! C C ! MPR1 ! C C ! MEALEV ! C C ! AD C ! ! C C ! ORTHOGONALIZATION DIFMEA ! C C ! MOGRAM ! C C ! ! C C ! CONVERGENCE-TEST NO SUBROUTINES CALLED ! C C !----------------------------------------------- ! C C C C ROTATION ROT1 C C PROING C C MPR1 C C ADDDIA C C MEALEV C C C C I/O BLOCK OUTPUT C C C C ALBERT GIFI FEB. 1981 C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC SUBROUTINE INIFIG (DATAIN,ICATGO,MARFRE,MARFIN,MAFRPV,ACCUMU, + OBSCOR,CATSCO,AUXILI,ITYP,STRES1,STRES3,JTYP, + DIRCOS,MFPVIN,DATAPV,IPARTI,TEXT,AIDH,STRESC, + NAME,LABEL, + NOBS,NVAR,NDIM,MAXC,ISUC,IWR1,IPLO,NONV,NOND,NDSQ, + ISND,NAUX,NVND,NPLV,EPSIN,NITIN,IWR2,NDND,FACT,OLFIT, + SUPER,NIPA,NDAT,IOUT1,IOUT2,IOUT3,IOUT4,NAID,NITR, + ILEV) CCCC CCCC CCCC CCCC CCCC COMMON /LINOUT/ ICAR,IPRI DOUBLE PRECISION MARFIN,ACCUMU,OBSCOR,CATSCO,STRES1,MFPVIN,T2, + T3,T4,OLFIT,STRES3,TFIT,TLOSS,TMLOSS,SLOSS INTEGER DATAIN,DATAPV DIMENSION DATAIN(NONV),ICATGO(NVAR),MARFRE(ISUC),DATAPV(NDAT), + MARFIN(ISUC),MAFRPV(NOBS),MFPVIN(NOBS),IPARTI(NIPA), + ACCUMU(NOND),OBSCOR(NOND),CATSCO(ISND),AIDH(NAID), + AUXILI(NAUX),ITYP(NVAR) ,JTYP(NVAR) ,TEXT(NVAR,5), + STRES1(NVND),STRES3(NVAR),DIRCOS(NVND),STRESC(NDIM), + NAME(20) ,LABEL(35) LOGICAL LOGOUT,NOINIT INTEGER SUPER C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C SOME TEMPORARILY CHANGES IN PARAMETER VALUES VALID ONLY C C DURING COMPUTATION OF THE INITIAL CONFIGURATION C C C C CONST1 SCALES THE SSQ OF THE SOLUTION FROM 1/NVAR TO NOBS C C CONST2 SCALES THE SSQ OF THE SOLUTION FROM NOBS TO 1 C C C C NOINIT INDICATES WHETHER AN INITIAL SVD IS NEEDED ( = .FALSE.) C C OR NOT ( = .TRUE.) C C C C LOGOUT INDICATES WHETHER THE RESULTS OF THE INITIAL C C CONFIGURATION ARE TO BE PRINTED (= .TRUE.) OR NOT (= .FALSE.) C C C C SUPER GOVERNS THE VALUES OF LOGOUT C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C NOINIT=.FALSE. IF(ILEV.EQ.1.OR.ILEV.EQ.4) NOINIT=.TRUE. LOGOUT=.TRUE. IF (SUPER.LE.0) LOGOUT=.FALSE. JWR1=IWR1 JWR2=IWR2 JPLO=IPLO JOUT1=IOUT1 JOUT2=IOUT2 JOUT3=IOUT3 JOUT4=IOUT4 IF(SUPER.LE.0) GOTO 19 JWR1=IWR1/10 JWR2=IWR2/10 JPLO=IPLO/10 JOUT1=IOUT1/10 JOUT2=IOUT2/10 JOUT3=IOUT3/10 JOUT4=IOUT4/10 IWR1=IWR1-JWR1*10 IWR2=IWR2-JWR2*10 IPLO=IPLO-JPLO*10 IOUT1=IOUT1-JOUT1*10 IOUT2=IOUT2-JOUT2*10 IOUT3=IOUT3-JOUT3*10 IOUT4=IOUT4-JOUT4*10 IF (SUPER.EQ.2) GOTO 19 JWR1=IWR1 JWR2=IWR2 JPLO=IPLO JOUT1=IOUT1 JOUT2=IOUT2 JOUT3=IOUT3 JOUT4=IOUT4 19 CONTINUE IF(NOINIT) GOTO 44 DO 1 J=1,NVAR JTYP(J)=ITYP(J) IF(ITYP(J).NE.0)ITYP(J)=3 1 CONTINUE 44 CONTINUE C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C CALL RANDMA (OBSCOR,NOND) N = 1 + NOBS * NOBS CALL DIFMEA (OBSCOR,MAFRPV,NOBS,NDIM,NOND,FACT,0) DO 24 K=1,NOBS ACCUMU(K)=MAFRPV(K) 24 CONTINUE CALL MPR1 (ACCUMU,OBSCOR,OBSCOR,NOBS,NDIM,NOND) CALL MPR1 (MFPVIN,OBSCOR,OBSCOR,NOBS,NDIM,NOND) CALL MOGRAM (OBSCOR,NOBS,NDIM,NOND) CALL MPR1 (MFPVIN,OBSCOR,OBSCOR,NOBS,NDIM,NOND) SQVA=1.0 / SQRT(FLOAT(NVAR)) C DO 959 I=1,NOND C OBSCOR(I)=OBSCOR(I)*SQVA C 959 CONTINUE CALL GENPRO (DIRCOS,DATAIN,OBSCOR,AUXILI,NVAR,NOBS,NDIM,NVND,NONV, + NOND) CCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCC CCCC CCCC COMPUTE THE SINGULAR VALUE DECOMPOSITION CCCC CCCC FOR SINGLE NON-NUMERICAL VARIABLES CCCC CCCC CCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCC OLFIT = 0.0D0 IF((NOINIT).AND.(LOGOUT)) WRITE(IPRI,1700) IF(NOINIT) RETURN CCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCC NITR = 0 IF (LOGOUT) GOTO 26 GOTO 27 26 IF(JWR2.NE.0)WRITE (IPRI,1403) 27 CONTINUE CCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCC CCCC CCCC START OF THE MAIN ITERATIVE PROCESS CCCC CCCC CCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCC 2 NITR = NITR + 1 KNOB=-NOBS DO 3 IP=1,NDIM KNOB=KNOB+NOBS DO 333 K=1,NOBS IF (NITR.GT.1) OBSCOR(K+KNOB)=ACCUMU(K+KNOB) ACCUMU(K+KNOB)=0.0D0 333 CONTINUE 3 CONTINUE DO 4 K=1,ISND CATSCO(K) = 0.0D0 AIDH(K)=0.0 4 CONTINUE IPDIM=-NDIM DO 5 K=1,NVAR IPDIM=IPDIM+NDIM DO 55 IP=1,NDIM IF(ITYP(K).EQ.0) DIRCOS(IP+IPDIM)=0. 55 CONTINUE 5 CONTINUE CCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCC CCC CCCC THE QUANTIFICATION OVER VARIABLES CCC CCCC CCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCC K = 1 N = 1 L = 1 M = 1 DO 6 J=1,NVAR IK=K-1 STRES3(J) = 0.0D0 DO 7 IP=1,NDIM STRES1 (IK+IP)=0.0D0 7 CONTINUE ICND = ICATGO(J) * NDIM KATJ = ICATGO(J) CALL PROING (DATAIN(N),OBSCOR,CATSCO(L),NOBS,NDIM, + KATJ,NOND,ICND,1,KATJ,4) CALL MPR1 (MARFIN(M),CATSCO(L),CATSCO(L),KATJ,NDIM,ICND) IAA=1+KATJ MKJ=5*KATJ+4 CALL ADDDIA(CATSCO(L),MARFRE(M),STRES1(K),KATJ,NDIM,ICND) IF(ITYP(J).NE.0)CALL MEALEV(CATSCO(L),AUXILI(1),DIRCOS(K), + AUXILI(IAA),ITYP(J),MARFRE(M), + STRES3(J),KATJ,NDIM,ICND,MKJ,NOBS) CALL PROING (DATAIN(N),CATSCO(L),ACCUMU,NOBS,NDIM, + KATJ,ICND,NOND,1,KATJ,3) K = K + NDIM L = L + ICND N = N + NOBS 6 M = M + ICATGO(J) CCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCC CCC CCCC TEST ON CONVERGENCE AND END OF THE MAIN ITERATIVE LOOP CCC CCCC CCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCC T2 = 0.0D0 T3 = 0.0D0 T4 = 0.0D0 TFIT = 0.0D0 TMLOSS = 0.0D0 SLOSS = 0.0D0 TLOSS = 0.0D0 K=1 DO 8 J=1,NVAR IK=K-1 DO 9 IP=1,NDIM T2 = T2 + STRES1(IK+IP)/DFLOAT(NVAR) IF(ITYP(J).NE.0)T4 = T4 + STRES1(IK+IP)/DFLOAT(NVAR) 9 CONTINUE IF(ITYP(J).NE.0) T3 = T3 + STRES3(J)/DFLOAT(NVAR) K=K+NDIM 8 CONTINUE SLOSS = T4 - T3 TMLOSS = NDIM - T2 TLOSS = TMLOSS + SLOSS TFIT = T2 - SLOSS DIST = DABS(TFIT-OLFIT) IF (LOGOUT) GOTO 20 GOTO 18 20 IF(JWR2.NE.0) WRITE(IPRI,1404) NITR,TFIT,TLOSS,TMLOSS,SLOSS,DIST 18 CONTINUE OLFIT = TFIT IX = 1 IF (DIST.LT.EPSIN) IX = -1 IF (NITR.GT.NITIN) IX = 0 IF (IX) 21,22,23 21 IF(.NOT.LOGOUT) GOTO 11 IF(JWR2.NE.0) WRITE (IPRI,1600) GOTO 11 22 IF(.NOT.LOGOUT) GOTO 11 IF(JWR2.NE.0) WRITE (IPRI,1500) GOTO 11 23 CONTINUE CCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCC CCC CCCC THE ORTHOGONALIZATION CCC CCCC CCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCC CALL DIFMEA (ACCUMU,MAFRPV,NOBS,NDIM,NOND,FACT,0) CALL MPR1 (MFPVIN,ACCUMU,ACCUMU,NOBS,NDIM,NOND) CALL MOGRAM (ACCUMU,NOBS,NDIM,NOND) CALL MPR1 (MFPVIN,ACCUMU,ACCUMU,NOBS,NDIM,NOND) CCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCC CCC CCCC RETURN TO THE START OF THE ITERATION LOOP CCC CCCC CCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCC GOTO 2 CCCC 11 CONTINUE CCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCC CCC CCCC ROTATION OF THE FINAL CONFIGURATION TO ITS CCC CCCC PRINCIPAL COMPONENTS , WITH THE SSQ CCC CCCC PER COLUMN EQUAL TO THE NUMBER OF OBSERVATIONS CCC CCCC AND COMPUTATION OF THE ACCORDING CATEGORY SCORES CCC CCCC CCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCC N = 1 + NDSQ L = N + NDIM CALL ROT1 (CATSCO,OBSCOR,MARFRE,AUXILI,AUXILI(N),AUXILI(L), + ICATGO,ISND,ISUC,NDIM,NDSQ,NVAR,NOND,NOBS,NONV, + DATAIN,0,DIRCOS,NVND,NVAR) CONST1=SQRT(FLOAT(NOBS)) DO 31 JI=1,NOND 31 OBSCOR(JI)=OBSCOR(JI)*CONST1 DO 12 K=1,ISND 12 CATSCO(K) = 0.0D0 N = 1 L = 1 M = 1 K = 1 DO 14 J=1,NVAR IK=K-1 STRES3(J) = 0. DO 15 IP=1,NDIM STRES1 (IK+IP)=0.0D0 15 CONTINUE ICND = ICATGO(J) * NDIM KATJ = ICATGO(J) CALL PROING (DATAIN(N),OBSCOR,CATSCO(L),NOBS,NDIM, + KATJ,NOND,ICND,1,KATJ,4) CALL MPR1 (MARFIN(M),CATSCO(L),CATSCO(L),KATJ,NDIM,ICND) CCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCC C CCC COMPUTE THE CORRELATION FOR THE ROTATED C CCC CONFIGURATION IN THOSE CASES WHERE NO OUTPUT C CCC FROM THE INITIAL CONFIGURATION IS REQUIRED C CCC C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC IF(LOGOUT) GOTO 28 STRES3(J)=0. IAA=1+KATJ MKJ=5*KATJ+4 IF(ITYP(J).NE.0)CALL MEALEV(CATSCO(L),AUXILI(1),DIRCOS(K), + AUXILI(IAA),ITYP(J),MARFRE(M), + STRES3(J),KATJ,NDIM,ICND,MKJ,NOBS) 28 K = K + NDIM L = L + ICND N = N + NOBS 14 M = M + ICATGO(J) CCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCC CCCC THE SECOND I/O BLOCK CCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCC IF (LOGOUT) +CALL OUTPUT (DATAIN,DATAPV,ICATGO,MARFRE,OBSCOR,ACCUMU,CATSCO, + CATSCO,STRES1,AUXILI,IPARTI,ITYP,MARFIN,STRES3,TEXT,AIDH, + STRESC,DIRCOS,STRES1,LABEL, + NOBS,NVAR,NDIM,JOUT1,JOUT2,JOUT3,JOUT4, + NOND,ISUC,NPLV,NAME,NONV,NDAT,ISND,NIPA,NAUX, + JWR1,JPLO,2*NOND,2*ISND,MAXC,NVND,NAID,NITR,0) CONST2=1.0/SQRT(FLOAT(NOBS)) DO 32 I=1,NOND OBSCOR(I)=OBSCOR(I)*CONST2 32 CONTINUE DO 16 J=1,NVAR ITYP(J)=JTYP(J) 16 CONTINUE CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C THE FORMAT LIST C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 1403 FORMAT (1H1////5X,42H* THE HISTORY OF ITERATIONS TO COMPUTE THE, + 31H INITIAL METRIC CONFIGURATION */7X,69(1H-)// +1H ,52H ITERATION TOTAL TOTAL MULTIPLE, + 42H SINGLE DIFFERENCE BETWEEN THE/ +1H ,52H NUMBER FIT LOSS LOSS , + 42H LOSS LAST TWO ITERATIONS //) 1404 FORMAT (1H ,I8,3X,4(F14.7),F14.7) 1500 FORMAT(/52H THE ITERATIVE PROCESS STOPS BECAUSE THE MAXIMUM, + 32H NUMBER OF ITERATIONS IS REACHED) 1600 FORMAT(/53H THE ITERATIVE PROCESS STOPS BECAUSE THE CONVERGE, + 25HNCE TEST VALUE IS REACHED) 1700 FORMAT(1H1//4X,45H ALL VARIABLES ARE EITHER MULTIPLE NOMINAL OR, + 53H SINGLE NUMERICAL, SO INITIAL AND FINAL CONFIGURATION, + 14H ARE IDENTICAL) RETURN END SUBROUTINE LIDICA(MARFRE,YBLANK,EPLUS,DPLUS,KJ,E) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C*** C C*** THIS ROUTINE COMPUTES A WEIGTHED LINEAR REGRESSION OF THE C C*** MODEL VECTOR YBLANK ON CATEGORICAL DISCRETE DATA C C*** C C*** NO SUBROUTINES CALLED J.VAN RIJCKEVORSEL MAY 78 C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC DIMENSION MARFRE(KJ),YBLANK(KJ),EPLUS(KJ),DPLUS(KJ) REAL CONST,DELTA,GAMMA,HULP1,HULP2,ALPHA,BETA,DPLUS,EPLUS INTEGER MARFRE C*** CONST=0. DELTA=0. GAMMA=0. ALPHA=0. BETA =0. C*** DO 1 K=1,KJ CONST=CONST+MARFRE(K) DELTA=DELTA+MARFRE(K)*K GAMMA=GAMMA+MARFRE(K)*YBLANK(K) 1 CONTINUE C*** IF (CONST.GT.E)CONST=1./CONST DELTA=DELTA*CONST GAMMA=GAMMA*CONST HULP1=0. HULP2=0. C*** DO 2 K=1,KJ EPLUS(K)=YBLANK(K)-GAMMA DPLUS(K)=K-DELTA HULP1=HULP1+EPLUS(K)*MARFRE(K)*DPLUS(K) HULP2=HULP2+DPLUS(K)*MARFRE(K)*DPLUS(K) 2 CONTINUE C*** IF (HULP2.GT.E) ALPHA=HULP1/HULP2 IF(ALPHA.LT.0.) ALPHA=-ALPHA BETA=GAMMA-ALPHA*DELTA C*** DO 3 K=1,KJ IF(MARFRE(K).EQ.0) YBLANK(K)=0.0 IF(MARFRE(K).EQ.0) GOTO 3 YBLANK(K)=ALPHA*K+BETA 3 CONTINUE RETURN END SUBROUTINE MEALEV(CATSCO,YBLANK,A,HULP,ITYP,MARFRE, + STRES3,KJ,NDIM,ICND,MKJ,NOBS) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C*** C C*** THIS ROUTINE MINIMIZES THE LOSS COMPONENTS CAUSED BY C C*** THE SINGLE VECTOR APPROACH OF NOMINAL,NUMERICAL C C*** OR ORDINAL VARIABLES C C*** THE SCALED DATA VECTOR HAS STANDARD LENGTH C C*** THE MINIMIZATION IS LEAST-SQUARES C C*** C C*** C C*** SUBROUTINES CALLED: C C*** C C*** FOR ORDINAL VARIABLES : ORDICA C C*** FOR NUMERICAL VARIABLES : LIDICA C C*** C C*** ALBERT GIFI DECEMBER 1980 C C*** C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C*** DIMENSION CATSCO(ICND),MARFRE(KJ),YBLANK(KJ),A(NDIM), + HULP(MKJ) DOUBLE PRECISION CATSCO,STRES3,ST INTEGER MARFRE REAL HULP,A,INPD,TRAC C*** C*** INITIALIZE SOME VECTORS AND VARIABLES C*** NDSQ=NDIM*NDIM E=.1E-20 INPD=1./NDIM DO 15 K=1,KJ YBLANK(K)=0. 15 CONTINUE C*** C*** COMPUTE THE SINGLE DATA VECTOR FROM C*** THE MULTIPLE CATEGORY SCORES C*** DO 4 K=1,KJ LCAT=-KJ DO 5 IP=1,NDIM LCAT=LCAT+KJ YBLANK(K)=YBLANK(K)+CATSCO(K+LCAT)*A(IP) 5 CONTINUE 4 CONTINUE C*** C*** SCALE THE DATAVECTOR ACCORDING TO THE RESTRICTIONS C*** IMPOSED BY THE MEASUREMENT LEVEL C*** C*** CODE MEANING C*** C*** 1 SINGLE NOMINAL C*** C*** 2 SINGLE ORDINAL C*** C*** 3 SINGLE NUMERICAL C*** LA=1+KJ LB=LA+KJ LC=LB+KJ LD=(2*KJ)+4 IF(ITYP.EQ.2) CALL ORDICA(YBLANK,MARFRE,KJ,HULP(1),HULP(LA), + HULP(LB),HULP(LC),LD,E) IF(ITYP.EQ.3) CALL LIDICA(MARFRE,YBLANK,HULP(1),HULP(LA),KJ,E) C*** C*** STANDARDIZE YBLANK AND UPDATE THE CORRELATIONS C*** TRAC=0. DO 9 IP=1,KJ TRAC=TRAC+YBLANK(IP)*YBLANK(IP)*MARFRE(IP) 9 CONTINUE IF(TRAC.GT.E) TRAC=1./SQRT(TRAC) DO 10 IP=1,KJ YBLANK(IP)=TRAC*YBLANK(IP) 10 CONTINUE C*** STRES3=0.0D0 LCAT=-KJ DO 7 IP=1,NDIM ST=0.0D0 LCAT=LCAT+KJ DO 8 K=1,KJ ST=ST+CATSCO(K+LCAT)*DFLOAT(MARFRE(K))*YBLANK(K) 8 CONTINUE A(IP)=ST STRES3=STRES3+ST*ST 7 CONTINUE LCAT=-KJ DO 12 IP=1,NDIM LCAT=LCAT+KJ DO 13 K=1,KJ IF (MARFRE(K).EQ.0) GOTO 14 IF(AMIN1(ABS(YBLANK(K)),ABS(A(IP))) .LE. E) GOTO 14 CATSCO(K+LCAT)=YBLANK(K)*A(IP) GOTO 13 14 CATSCO(K+LCAT)=0.0D0 13 CONTINUE 12 CONTINUE RETURN END SUBROUTINE MOGRAM(ORTHOG,NOBS,NDIM,NPND) CCCCCCC C C THIS ROUTINE COMPUTES A MODIFIED C GRAM SCHMIDT ORTHOGONALIZATION C C C J. VAN RIJCKEVORSEL FEBR 1978 C CCCCCCCCC DIMENSION ORTHOG(NPND) DOUBLE PRECISION ORTHOG,SSQ,CROSSP,SSQDIN C ICOL=-NOBS DO 1 IP=1,NDIM ICOL=ICOL+NOBS CCCC C COMPUTE THE SUM OF SQUARES OF COLUMN IP CCCC SSQ=0.0D0 DO 2 I=1,NOBS SSQ=SSQ+ORTHOG(I+ICOL)*ORTHOG(I+ICOL) 2 CONTINUE CCCC C NORMALIZE COLUMN IP CCCC SSQDIN=1.0D0/DSQRT(SSQ) DO 3 I=1,NOBS ORTHOG(I+ICOL)=ORTHOG(I+ICOL)*SSQDIN 3 CONTINUE CCCC C COMPUTE CROSSPRODUCT BETWEEN COLUMN IP AND COLUMN IP+1 CCCC DO 4 JP=IP,NDIM JCOL=JP*NOBS IF(JCOL.EQ.NPND) GOTO 4 CROSSP=0.0D0 DO 5 I=1,NOBS CROSSP=CROSSP+ORTHOG(I+ICOL)*ORTHOG(I+JCOL) 5 CONTINUE CCCCC C UPDATE COLUMN IP+1 CCCCC DO 6 I=1,NOBS ORTHOG(I+JCOL)=ORTHOG(I+JCOL)-CROSSP*ORTHOG(I+ICOL) 6 CONTINUE 4 CONTINUE 1 CONTINUE RETURN END SUBROUTINE MPR1 (A,B,R,N,M,NM) DOUBLE PRECISION A, B, R DIMENSION A(N), B(NM), R(NM) C L = 0 DO 10 J=1,M DO 10 I=1,N L = L + 1 10 R(L) = A(I) * B(L) RETURN END SUBROUTINE ORDICA(YBLANK,MARFRE,KJ,MARHUL,YHULP,HULPY,HULP,KJSQ,E) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCC CCCC ORDICA SCALES ORDINAL DISCRETE VARIABLES CCCC IN TERMS OF OPTIMAL SCALING CCCC MONOTONE REGRESSION IS DONE ON THE NON- CCCC MISSING CATEGORIES ONLY. CCCC IF THE QUANTIFICATIONS OF THE FIRST AND CCCC THE LAST CATEGORY ARE IDENTICAL, WHICH CCCC MEANS THAT THERE IS ONLY ONE TIEBLOCK, CCCC THE SIGN OF NON-SCALED DATA VECTOR IS CCCC CHANGED; THIS HAPPENS ONLY ONCE. CCCC CCCC SUBROUTINES CALLED : WMRMXI CCCC CCCC JAN VAN RIJCKEVORSEL OCT. 1978 CCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCC DIMENSION MARFRE(KJ),MARHUL(KJ),YHULP(KJ),HULPY(KJ),YBLANK(KJ), 1 HULP(KJSQ) INTEGER MARFRE,MARHUL REAL YHULP,HULPY,YBLANK,HULP,ZERO,E LOGICAL LOG,TEST LOG=.FALSE. TEST=.FALSE. C*** IT=0 4 CONTINUE I=0 IT=IT+1 DO 1 K=1,KJ IF (MARFRE(K).EQ.0) GOTO 1 IF(LOG)YBLANK(K)=(-1.0)*YBLANK(K) I=I+1 MARHUL(I)=MARFRE(K) YHULP(I)=YBLANK(K) 1 CONTINUE IF(I.LE.1) GOTO 6 C*** II=(I/2)+1 CALL WMRMXI(YHULP,HULPY,MARHUL,HULP(1),HULP(II+1),HULP(2*II+1), 1 HULP(3*II+1),I,II) C*** LOG=.FALSE. IF (TEST) GOTO 5 IF (HULPY(1).EQ.HULPY(I)) LOG=.TRUE. IF (LOG) TEST=.TRUE. IF (LOG) GOTO 4 5 CONTINUE I=0 DO 2 K=1,KJ IF(MARFRE(K).EQ.0) GOTO 3 I=I+1 YBLANK(K)=HULPY(I) GOTO 2 3 CONTINUE YBLANK(K)=0. 2 CONTINUE 6 CONTINUE RETURN END CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C OUTPUT IS AN I/O ROUTINE FOR C C PRINTING,PUNCHING AND PLOTTING C C FINAL RESULTS C C C C SUBROUTINES CALLED : CATPRI C C PLOTTO C C C C ALBERT GIFI FEB. 1981 C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C SUBROUTINE OUTPUT (DATAIN,DATAPV,ICATGO,MARFRE,OBSCOR,ROCSBO, + CATSCO,OCSTAC,STRES1,AUXILI,IPARTI,ITYP,MARFIN,STRES3, + TEXT,AIDH,STRESC,DIRCOS,SOCRID,LABEL, + NOBS,NVAR,NDIM,IOUT1,IOUT2,IOUT3,IOUT4, + NOND,ISUC,NPLV,NAME,NONV,NDAT,ISND,NIPA,NAUX, + IWR1,IPLO,NNNN,MMMM,MAXC,NVND,NAID,NITR,INFIN) DIMENSION DATAIN(NONV),DATAPV(NDAT),ICATGO(NVAR),MARFRE(ISUC), + OBSCOR(NOND),CATSCO(ISND),STRES1(NVND),IPARTI(NIPA), + ROCSBO(NNNN),OCSTAC(MMMM),AUXILI(NAUX),NAME(20), + ITYP(NVAR),MARFIN(ISUC),STRES3(NVAR),TEXT(NVAR,5), + AIDH(NAID),STRESC(NDIM),DIRCOS(NVND),SOCRID(NVND) DIMENSION LABEL(35) LOGICAL TYP COMMON /LINOUT/ ICAR,IPRI DOUBLE PRECISION OBSCOR,CATSCO,STRES1,MARFIN,STRES3 INTEGER DATAIN,DATAPV,P,PP,PPP,PPPP DATA B /1H*/ NPVS = NOBS NPND = NOND INDEX= NPLV*NOBS CCCC CCCC PRINT THE EIGENVALUES CCCC NDSA=NDIM*NDIM DO 15 I=1,NDIM AUXILI(I+NDSA) = AUXILI(I+NDSA)/FLOAT(NVAR) 15 CONTINUE WRITE(IPRI,1200) (IP,AUXILI(IP+NDSA),IP=1,NDIM) IRT=1 NVR1 = NVAR + NPLV IA=1+MAXC IB=1+MAXC+NDIM ID=4*MAXC+MAXC*MAXC+NDIM IC=IB+ID IE=ID+MAXC+NDIM+1 NDSQ=NDIM*NDIM CCCC CCCC PRINT AND RECOMPUTE THE PARAMETERS CCCC CALL CATPRI(ICATGO,MARFRE,DATAIN,ITYP,MARFIN,AUXILI(1),DIRCOS, + AIDH,AUXILI(IB),STRES1,CATSCO,STRES3,OBSCOR,TEXT,STRESC, + IPARTI,AUXILI,AUXILI(IE), + NVAR,ISUC,NONV,MAXC,ISND,NDIM,NVND,NOND,IWR1,ID,NAID,NITR, + IOUT3,NIPA,IPLO,NAUX,NDSQ,INFIN) C IF (IRT.EQ.1) GOTO 1001 IF(IWR1.EQ.0) GOTO 120 IF(IWR1.EQ.3) GOTO 120 CCCC CCCC PRINT OBJECT SCORES CCCC WRITE (IPRI,1100) WRITE (IPRI,2000) (L,L=1,NDIM) ND = 10 * NDIM + 1 WRITE (IPRI,2200) (B,I=1,ND) DO 95 I=1,NPVS 95 WRITE (IPRI,2100) I,(OBSCOR(J),J=I,NPND,NPVS) 120 CONTINUE IF(IOUT3.GT.0.AND.IOUT3.NE.IPRI) WRITE(IPRI,3400) IOUT3 CCCC CCCC WRITE OBJECT SCORES TO UNIT IOUT1 C*** IF (IOUT1.LE.0.OR.IOUT1.EQ.IPRI) GO TO 130 IOU=IOUT1 DO 125 K=1,NPVS 125 WRITE (IOU,3000) K,(OBSCOR(I),I=K,NPND,NPVS) WRITE (IPRI,3100) IOUT1 130 CONTINUE CCCC CCCC WRITE CATEGORY COORDINATES TO UNIT IOUT2 CCCC IF (IOUT2.LE.0.OR.IOUT2.EQ.IPRI) GO TO 330 IOU=IOUT2 L = 0 DO 210 J=1,NVAR KATJ = ICATGO(J) ICND = ICATGO(J) * NDIM DO 215 K=1,KATJ 215 WRITE (IOU,3200) J,K,(CATSCO(L+I),I=K,ICND,KATJ) 210 L = L + ICND WRITE (IPRI,3300) IOUT2 330 CONTINUE CCCC CCCC REWRITE OBJECT SCORES AND CATEGORY COORDINATES IN SINGLE CCCC PRECISION AND REARRANGE THE COMPONENT LOADINGS CCCC DO 10 I=1,NPND 10 ROCSBO(I) = OBSCOR(I) DO 20 I=1,ISND 20 OCSTAC(I) = CATSCO(I) IJ=-NVAR DO 21 J=1,NDIM IJ=IJ+NVAR IP=-NDIM IMUL=NVAR DO 22 I=1,NVAR IF(ITYP(I).EQ.0) IMUL=IMUL-1 IP=IP+NDIM AUXILI(I+IJ)=DIRCOS(J+IP) IF(ITYP(I).EQ.0) AUXILI(I+IJ)=0. 22 CONTINUE 21 CONTINUE DO 23 IP=1,NVND SOCRID(IP)=AUXILI(IP) 23 CONTINUE CCCC CCCC WRITE COMPONENT LOADINGS TO UNIT IOUT4 C*** IF (IMUL.EQ.0) GOTO 230 IF (IOUT4.LE.0.OR.IOUT4.EQ.IPRI) GO TO 230 IOU=IOUT4 DO 225 K=1,NVAR 225 WRITE (IOU,3000) K,(SOCRID(I),I=K,NVND,NVAR) WRITE (IPRI,3500) IOUT4 230 CONTINUE IF (IPLO.EQ.0) RETURN IF (NDIM.GT.1) GO TO 137 CCCC CCCC DEFINE A SECOND DIMENSION WITH ZERO QUANTIFICATIONS IF CCCC THE REQUIRED NUMBE OF DIMENSIONS IS ONE. CCCC NP = NPND + 1 DO 30 I=NP,NNNN 30 ROCSBO(I) = 0. NP = ISND + 1 DO 40 I=NP,MMMM 40 OCSTAC(I) = 0. 137 N = 1 + NPVS IF (IPLO.GE.3) GO TO 132 CCCC CCCC PLOT OBJECT SCORES, UNLABELED CCCC WRITE (IPRI,1400) NAME CALL PLOTTO (ROCSBO,ROCSBO(N),AUXILI,AUXILI(N),AUXILI,NPVS,0) CCCC CCCC IF THE NUMBER OF DIMENSIONS EQUALS 1 CCCC RETURN TO THE MAIN PROGRAM IF (NDIM.EQ.1) RETURN CCCC CCCC PLOT COMPONENT LOADINGS, LABELED WITH VARIABLE NUMBER CCCC IF(IMUL.LE.0) GOTO 132 DO 24 I=1,NVAR DATAPV(I+INDEX)=I 24 CONTINUE IV=INDEX+1 NV=NVAR+1 WRITE(IPRI,1300) NAME CALL PLOTTO(SOCRID,SOCRID(NV),DATAPV(IV),AUXILI(NV),AUXILI,NVAR,1) 132 CONTINUE IF (IPLO.EQ.1) RETURN CCCC CCCC PLOT OBJECT SCORES, LABELED BY THE VARIABLES WANTED CCCC DO 140 J=1,NVR1 IF (IPARTI(J).LE.0.OR.IPARTI(J).GT.2) GO TO 140 N = 1 + NOBS M = 1 + (J-1) * NOBS WRITE (IPRI,1450) NAME,J CALL PLOTTO (ROCSBO,ROCSBO(N),DATAIN(M),AUXILI,AUXILI(N), + NOBS,1) 140 CONTINUE N = 1 170 CONTINUE CCCC CCCC PLOT CATEGORY QUANTIFICATIONS OF THE VARIABLES WANTED CCCC L=1 N=1 CCCC DO 200 J=1,NVAR TYP=.TRUE. KATJ=ICATGO(J) IF(IPARTI(J).LE.1) GOTO 203 IF(ITYP(J).EQ.0) TYP=.FALSE. DO 2 I=1,KATJ DATAPV(INDEX+I)=I IF(TYP) DATAPV(INDEX+I+KATJ)=I 2 CONTINUE CCCC IF(.NOT.TYP) GOTO 201 IKK=-2*KATJ IK =-KATJ DO 186 IP=1,NDIM IKK=IKK+2*KATJ IK=IK+KATJ DO 185 I=1,KATJ II=I-1 AUXILI(IKK+I)=OCSTAC(N+II+IK) AUXILI(KATJ+I+IKK)=AIDH(L+II+IK) 185 CONTINUE 186 CONTINUE ICND=2*KATJ*NDIM 201 CONTINUE CCCC M=N+KATJ P=2*KATJ K=KATJ+1 PP=P+1 PPP=PP+P PPPP=PPP+P WRITE(IPRI,1700) J,NAME IF(TYP) GOTO 202 CALL PLOTTO(OCSTAC(N),OCSTAC(M),DATAPV(INDEX+1),AUXILI(1), + AUXILI(K),KATJ,1) GOTO 203 202 CALL PLOTTO(AUXILI(1),AUXILI(PP),DATAPV(INDEX+1),AUXILI(PPP), + AUXILI(PPPP),P,1) 203 L=L+KATJ*NDIM N=N+KATJ*NDIM 200 CONTINUE 1001 CONTINUE CCCC CCCC FORMAT-LIST CCCC 1100 FORMAT (1H1,4X,19H* OBJECT SCORES * :/7X,13(1H-)//) 1200 FORMAT(/////29H0 DIMENSION EIGENVALUE/ + 29H --------- ----------/ + (1H ,5X,I5,3X,F10.3)) 1300 FORMAT (30H1 COMPONENT LOADINGS LABELED,15X,20A4/ + 30H BY THEIR VARIABLE NUMBER ) 1400 FORMAT (28H1 OBJECT SCORES, UNLABELED,17X,20A4/) 1450 FORMAT (29H1 OBJECT SCORES, LABELED BY,15X,20A4/ + 12H VARIABLE,I5) 1700 FORMAT (36H1 RESCALED CATEGORIES FOR VARIABLE,I5,10X,20A4/ + 36H LABELED BY THEIR CATEGORY NUMBER) 2000 FORMAT (1H ,8X,1H*/1H ,9X,12H* DIMENSIONS/1H ,10X,1H*/ + 1H ,11X,1H*/1H ,12X,1H*,I9,9I10) 2100 FORMAT (1H ,7X,I5,3H * ,(10F10.4)) 2200 FORMAT (16H OBJECTS **,120A1) 3000 FORMAT (I5,9F8.3/(5X,9F8.3)) 3100 FORMAT(/49H0THE OBJECT SCORES (WITH OBSERVATION-NUMBER) HAVE, + 21H BEEN WRITTEN TO UNIT,I3,12H WITH FORMAT, + 22H (I5,9F8.3/(5X,9F8.3))) 3200 FORMAT (2I4,9F8.3/(8X,9F8.3)) 3300 FORMAT(/53H0THE RESCALED CATEGORIES (WITH VARIABLE- AND CATEGORY, + 34H NUMBER) HAVE BEEN WRITTEN TO UNIT,I3,12H WITH FORMAT, + 23H (2I4,9F8.3/(8X,9F8.3))) 3400 FORMAT(/54H0THE CATEGORY QUANTIFICATIONS (WITH VARIABLE- AND CATE, + 38HGORY NUMBER) HAVE BEEN WRITTEN TO UNIT,I3, + 31H WITH FORMAT (I3,1X,I3,1X,F8.3)) 3500 FORMAT(/53H0THE COMPONENT LOADINGS (WITH VARIABLE - NUMBER) HAVE, + 21H BEEN WRITTEN TO UNIT,I3,12H WITH FORMAT, + 22H (I5,9F8.3/(5X,9F8.3))) C RETURN END SUBROUTINE PLOTTO (X,Y,IND,INDEX,IHULP,NITEM,IDENT) COMMON /LINOUT/ ICAR,IPRI DIMENSION X(NITEM),Y(NITEM),IND(NITEM),INDEX(NITEM),IHULP(NITEM), + LABEL(37) DIMENSION LINE(71), IMRE(71), IPLUS(56), XPR(11) C>>>> DIMENSION LINE(NC), IMRE(NC), IPLUS(NL), XPR(NN+1) LOGICAL IHULP,IMRE LOGICAL LABEL, BOOL, BOEL,STAR DATA STAR /1H*/ DATA LABEL (1),LABEL (2),LABEL (3),LABEL (4),LABEL (5),LABEL (6), + LABEL (7),LABEL (8),LABEL (9),LABEL(10),LABEL(11),LABEL(12), + LABEL(13),LABEL(14),LABEL(15),LABEL(16),LABEL(17),LABEL(18), + LABEL(19),LABEL(20),LABEL(21),LABEL(22),LABEL(23),LABEL(24), + LABEL(25),LABEL(26),LABEL(27),LABEL(28),LABEL(29),LABEL(30), + LABEL(31),LABEL(32),LABEL(33),LABEL(34),LABEL(35),LABEL(36), + LABEL(37)/1H ,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9, + 1HA,1HB,1HC,1HD,1HE,1HF,1HG,1HH,1HI,1HJ, + 1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,1HS,1HT, + 1HU,1HV,1HW,1HX,1HY,1HZ,1H+/ C NL = 56 C>>>> NL = NUMBER OF LINES NN = 10 NC = 7 * NN + 1 C>>>> NC = NUMBER OF COLUMNS (DO NOT EXCEED THE PAGEWIDTH ]]) C 1 FORMAT (32X,3H.--,10(7H+------),5H+---.) C>>>> ## = NN C 2 FORMAT(24X,F7.3,1X,1H!,2X,71A1,3X,1H!) C>>>> ## = NC C 3 FORMAT(24X,F7.3,1X,1H!,76X,1H!) C>>>> ## = NC+5 C 4 FORMAT (31X,11F7.3) C>>>> ## = NN+1 C 5 FORMAT(1H1,4X, +53H SUMMARY OF ALL CELLS (X,Y), MARKED : + IN THE PLOT, , + 43HCONTAINING MORE THAN 1 POINT IDENTIFICATION// + 5X,27H NUMBER OF/ + 5X,49H X Y POINTS POINT-IDENTIFICATION//) 6 FORMAT(1H1,4X, + 53H SUMMARY OF ALL CELLS (X,Y), MARKED : + IN THE PLOT, , + 30HCONTAINING MORE THAN 35 POINTS/ + 5X,27H NUMBER OF/ + 5X,24H X Y POINTS//) 7 FORMAT(1H ,5X,2F7.3,2X,I5) 8 FORMAT(1H ,5X,2F7.3,2X,I5,7X,90A1/(1H ,33X,90A1)) C C IF IDENT=0 : THE POINTS ARE COUNTED FROM 1,2,...,9,A,...Z; C IF A CELL CONTAINS MORE THAN 35 POINTS, C THE SYMBOL '+' WILL BE USED IN THE PLOT AND C A LISTING WILL SHOW, HOW MANY POINTS ARE COUNTED C C IF IDENT=1 : THE POINTS ARE IDENTIFIED WITH THE CONTENT OF IND; C OR =-1 IF A CELL CONTAINS MORE THAN 2 POINTS, C THE SYMBOL '+' WILL BE USED IN THE PLOT AND C A LISTING WILL SHOW THE NUMBER OF POINTS C AND THEIR IDENTIFICATION C C IF IDENT=-1 THE LAST POINT TO BE PLOTTED IS EXPECTED TO BE (0,0) C THE VALUES OF Y ARE SORTED IN DESCENDING ORDER; C THE VALUES OF X AND IND ARE PERMUTED ACCORDINGLY C INDEX(1)=1 XMAX=X(1) XMIN=X(1) DO 10 I=2,NITEM INDEX(I)=I IF (X(I).LE.XMAX) GO TO 11 XMAX=X(I) GO TO 10 11 IF (X(I).LT.XMIN) XMIN=X(I) 10 CONTINUE 15 M=NITEM 20 M=M/2 IF (M) 30,40,30 30 K=NITEM-M J=1 41 I=J 49 L=I+M KL = INDEX(L) KI = INDEX(I) IF (Y(KI).GE.Y(KL)) GO TO 60 INDEX(I)=INDEX(L) INDEX(L) = KI I=I-M IF (I.GE.1) GO TO 49 60 J=J+1 IF (J-K) 41,41,20 40 CONTINUE C C THE PLOT IS ADJUSTED TO THE RANGE OF THE 'LONGEST' AXIS C SPANX=XMAX-XMIN KI = INDEX(1) KL = INDEX(NITEM) SPANY = Y(KI) - Y(KL) IF (SPANY.LE.SPANX) GO TO 75 XMIN=XMIN-(SPANY-SPANX)/2.0 SPANX=SPANY 75 STEPX=SPANX/(7.0*NN) STEPY = (STEPX * NC) / (NL + 0.) HSTEP=STEPY/2.0 TOP = (Y(KI) + Y(KL) + SPANX) / 2.0 DO 76 I=1,NL 76 IPLUS(I)=0 C C THE POINTS ARE PLOTTED LINE AFTER LINE C BOEL=.FALSE. BOOL=.FALSE. WRITE (IPRI,1) L=1 I=1 YPR=TOP+STEPY 80 YPR=YPR-STEPY IF (I.GT.NITEM) GO TO 110 KI = INDEX(I) IF (Y(KI)-YPR+HSTEP) 110,90,90 90 DO 95 J=1,NC 95 LINE(J)=1 BOEL=.FALSE. 100 JP = (X(KI)-XMIN) / STEPX + 1.0 IPLUS(L)=IPLUS(L)+1 IF (IDENT.EQ.0) GO TO 102 IF (LINE(JP).NE.1) GO TO 101 LINE(JP) = MOD(IND(KI)-1,35) + 2 GO TO 105 101 LINE(JP)=37 BOEL=.TRUE. BOOL=.TRUE. GO TO 105 102 LINE(JP)=LINE(JP)+1 IF (LINE(JP).GE.37) GO TO 103 GO TO 105 103 BOOL=.TRUE. BOEL=.TRUE. LINE(JP)=37 105 I=I+1 IF (I.GT.NITEM) GO TO 106 KI = INDEX(I) IF (Y(KI) - YPR + HSTEP) 106,106,100 106 DO 107 JP=1,NC KI = LINE(JP) 107 IMRE (JP) = LABEL(KI) IF(IDENT.NE.-1.OR.I.LT.NITEM) GOTO 109 DO 108 JP=1,NC IF(LINE(JP).NE.(MOD(NITEM-1,35)+2)) GOTO 108 IMRE(JP)=STAR GOTO 109 108 CONTINUE 109 WRITE (IPRI,2) YPR,(IMRE (JP),JP=1,NC) GO TO 115 110 WRITE (IPRI,3) YPR 115 CONTINUE IF (L.NE.1) IPLUS(L)=IPLUS(L)+IABS(0+IPLUS(L-1)) IF (.NOT.BOEL) IPLUS(L)=-IPLUS(L) L=L+1 IF (L-NL) 80,80,120 120 WRITE (IPRI,1) C C VALUES OF X-AXIS ARE PRINTED C XPR(1)=XMIN DO 130 J=1,NN 130 XPR(J+1)=XPR(J)+STEPX*7.0 WRITE (IPRI,4) XPR C C CHECK TO SEE IF A LISTING IS REQUIRED C IF (.NOT.BOOL) GO TO 1000 IF (IDENT.EQ.0) GO TO 140 WRITE (IPRI,5) GO TO 150 140 WRITE (IPRI,6) 150 CONTINUE DO 900 L=1,NL IF (IPLUS(L).LE.0) GO TO 900 DO 200 J=1,NC 200 LINE(J)=0 IF (L.EQ.1) GO TO 210 IA=IABS(0+IPLUS(L-1))+1 IF (IA.GT.NITEM) GO TO 1000 GO TO 220 210 IA=1 220 IB=IPLUS(L) DO 300 I=IA,IB KI = INDEX(I) JP = (X(KI) - XMIN) / STEPX + 1.0 300 LINE(JP)=LINE(JP)+1 YPR=TOP-STEPY*(L-1) IF (IDENT.NE.0) GO TO 500 DO 400 J=1,NC IF (LINE(J).LT.36) GO TO 400 XP1=XMIN+(J-1)*STEPX WRITE (IPRI,7) XP1,YPR,LINE(J) 400 CONTINUE GO TO 900 500 DO 600 J=1,NC IF (LINE(J).LT.2) GO TO 600 XP1=XMIN+(J-1)*STEPX IT=0 DO 550 I=IA,IB KI = INDEX(I) JP = (X(KI) - XMIN) / STEPX + 1.0 IF (JP.NE.J) GO TO 550 IT=IT+1 KK = MOD(IND(KI)-1,35) + 2 IHULP(IT) = LABEL(KK) IF (IT.EQ.LINE(J)) GO TO 575 550 CONTINUE 575 WRITE (IPRI,8) XP1,YPR,IT,(IHULP(I),I=1,IT) 600 CONTINUE 900 CONTINUE 1000 CONTINUE RETURN END SUBROUTINE PREPA4 (MARFRE,MARFIN,MAFRPV,MFPVIN,DATAIN, + ICATGO,IMISSI,FACT, + ISUC,NMAF,NONV,NVAR,NOBS,NORM,MAXC) DOUBLE PRECISION MARFIN, MFPVIN INTEGER DATAIN COMMON /LINOUT/ ICAR,IPRI DIMENSION MARFRE(ISUC),MARFIN(ISUC),MAFRPV(NMAF),MFPVIN(NMAF), + DATAIN(NONV),ICATGO(NVAR),IMISSI(NVAR) DATA A /1H*/ C DO 10 J=1,ISUC 10 MARFRE(J) = 0 DO 20 K=1,NOBS 20 MAFRPV(K) = 0 NN = 0 NC = 0 C DO 40 J=1,NVAR IMISSI(J) = 0 DO 30 I=1,NOBS NN = NN + 1 IF (DATAIN(NN).LE.ICATGO(J).AND.DATAIN(NN).GT.0) GO TO 25 DATAIN(NN) = ICATGO(J) + 1 IMISSI(J) = IMISSI(J) + 1 GO TO 30 25 L = NC + DATAIN(NN) MARFRE(L) = MARFRE(L) + 1 MAFRPV(I) = MAFRPV(I) + 1 30 CONTINUE 40 NC = NC + ICATGO(J) C IF (NORM.EQ.2) GO TO 52 C DO 45 J=1,ISUC MARFIN(J) = 0.0D0 45 IF (MARFRE(J).NE.0) MARFIN(J) = 1.0D0 / MARFRE(J) C DO 50 J=1,NOBS MFPVIN(J) = 0.0D0 50 IF (MAFRPV(J).NE.0) MFPVIN(J)=DSQRT (DFLOAT(NVAR) / MAFRPV(J)) C GO TO 58 C 52 DO 54 J=1,ISUC MARFIN(J) = 0.0D0 54 IF (MARFRE(J).NE.0) MARFIN(J) = DSQRT (1.0D0 / MARFRE(J)) DO 56 J=1,NOBS MFPVIN(J) = 0.0D0 56 IF (MAFRPV(J).NE.0) MFPVIN(J) = 1.0D0 / MAFRPV(J) 58 CONTINUE C NSUM = 0 IF (NORM.EQ.2) GO TO 70 DO 60 L=1,NOBS 60 NSUM = NSUM + MAFRPV(L) GO TO 90 C 70 DO 80 J=1,NVAR 80 NSUM = NSUM + NOBS - IMISSI(J) 90 FACT = 1.0D0 / NSUM C WRITE (IPRI,1000) KM = MAXC IF (MAXC.GT.10) KM = 10 WRITE (IPRI,1100) (I,I=1,KM) KK = KM * 6 + 14 WRITE (IPRI,1200) (A,J=1,KK) K = 0 DO 100 J=1,NVAR KATJ = ICATGO(J) WRITE (IPRI,1300) J,IMISSI(J),(MARFRE(K+I),I=1,KATJ) 100 K = K + KATJ C 1000 FORMAT (4X,26H * MARGINAL FREQUENCIES *:/7X,20(1H-)/) 1100 FORMAT (1H ,9X,1H*/1H ,10X,14H* CATEGORIES/1H ,11X,1H*/ + 1H ,12X,1H*/1H ,13X,14H* MISSING ,10I6) 1200 FORMAT (15H VARIABLES ,74A1) 1300 FORMAT (1H ,8X,I5,3H * ,I6,5X,10I6/(1H ,14X,1H*,12X,10I6)) RETURN END CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C PRIINI REGULATES THE FLOW OF THE FOLLOWING C C ALGORITHMIC STRUCTURE: C C C C C C I/O BLOCK NO SUBROUTINES CALLED C C C C C C INITIALIZATION PREPA4 C C INIFIG C C C C ! THE NEXT THREE PHASES ARE ITERATIVELY COMPUTED ! C C !----------------------------------------------- ! C C ! QUANTIFICATION PROING ! C C ! MPR1 ! C C ! MEALEV ! C C ! ADC C ! ! C C ! ORTHOGONALIZATION DIFMEA ! C C ! MOGRAM ! C C ! ! C C ! CONVERGENCE-TEST NO SUBROUTINES CALLED ! C C !----------------------------------------------- ! C C C C ROTATION ROT1 C C PROING C C MPR1 C C MEALEV C C C C I/O BLOCK OUTPUT C C C C ALBERT GIFI FEB. 1981 C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC SUBROUTINE PRIINI (DATAIN,DATAPV,ICATGO,MARFRE,MARFIN,MAFRPV, + MFPVIN,ACCUMU,OBSCOR,CATSCO,IPARTI, + AUXILI,ITYP,TEXT,STRES1,STRES3,AIDH,STRESC, + DIRCOS,JTYP,LABEL, + NOBS,NVAR,NDIM,MAXC,ISUC, + INPU,IDAT,IWR1,IPLO,IOUT1,MAXI,NONV,NOND, + NVNV,NDSQ,NDND,ISND,NAUX,NVND, + NDAT,NIPA,EPSI,IJOB,NJOB,NPLV,NAME,NAID,EPSIN, + NITIN,IWR2,IOUT2,IOUT3,IOUT4,IPRIN,ILEV) CCCC CCCC CCCC CCCC CCCC DIMENSION NAME(20),TEXT0(4),TEXT1(4),TEXT2(4),TEXT3(4) COMMON /LINOUT/ ICAR,IPRI DOUBLE PRECISION MARFIN,MFPVIN,ACCUMU,OBSCOR,CATSCO,STRES1,T2,T3, + T4,STRES3,TFIT,DIST,OLFIT,TLOSS,TMLOSS,SLOSS INTEGER DATAIN,DATAPV,PRODAT,MUL,SIN DIMENSION DATAIN(NONV),DATAPV(NDAT),ICATGO(NVAR),MARFRE(ISUC), + MARFIN(ISUC),MAFRPV(NOBS),MFPVIN(NOBS), + ACCUMU(NOND),OBSCOR(NOND),CATSCO(ISND), + IPARTI(NIPA),AUXILI(NAUX),TEXT(NVAR,5),ITYP(NVAR), + STRES1(NVND),STRES3(NVAR),AIDH(NAID),STRESC(NDIM), + DIRCOS(NVND),JTYP(NVAR) ,LABEL(35) DATA TEXT0 /4HMULT,4HIPLE,4H NOM,4HINAL/ DATA TEXT1 /4H SIN,4HGLE ,4HNOMI,4HNAL / DATA TEXT2 /4H SIN,4HGLE ,4HORDI,4HNAL / DATA TEXT3 /4HSING,4HLE N,4HUMER,4HICAL/ CCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCC C CCCC THE FIRST I/O BLOCK C CCCC C CCCC C CCCC WRITE THE MEASUREMENT LEVELS OF THE VARIABLES C CCCC IF THE USER'S INSTRUCTIONS ARE INCOMPATIBLE C CCCC WITH THE PROGRAM OPTIONS THE EXECUTION IS C CCCC TERMINATED C CCCC C CCCC C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCC IL=0 IJ=0 IN=0 IM=0 DO 1 J=1,NVAR IF(ITYP(J)-3) 14,14,13 13 WRITE(IPRI,1303) J RETURN 14 CONTINUE IF (ITYP(J).EQ.0) GOTO 2 GOTO 3 2 IL=IL+1 DO 4 I=1,4 II=I+1 TEXT(J,1)=J 4 TEXT(J,II)=TEXT0(I) GOTO 111 3 IF (ITYP(J).EQ.1) GOTO 5 GOTO 6 5 DO 7 I=1,4 II=I+1 TEXT(J,1)=J 7 TEXT(J,II)=TEXT1(I) GOTO 111 6 IF (ITYP(J).EQ.2) GOTO 8 GOTO 9 8 DO 10 I=1,4 II=I+1 TEXT(J,1)=J 10 TEXT(J,II)=TEXT2(I) GOTO 111 9 DO 11 I=1,4 II=I+1 TEXT(J,1)=J 11 TEXT(J,II)=TEXT3(I) 111 CONTINUE IF(ITYP(J).EQ.3) IJ=IJ+1 IF(ITYP(J).EQ.2) IM=IM+1 IF(ITYP(J).EQ.1) IN=IN+1 1 CONTINUE IF (IL.EQ.NVAR) ILEV=1 IF (IM.EQ.NVAR) ILEV=3 IF (IN.EQ.NVAR) ILEV=2 IF (IJ.EQ.NVAR) ILEV=4 IF(ILEV.EQ.0) GOTO 16 WRITE(IPRI,1302) (TEXT(1,I),I=2,5) GOTO 17 16 WRITE(IPRI,1301) KK=(NVAR+3)/4 DO 12 K=1,KK WRITE(IPRI,1401)((TEXT(J,I),I=1,5),J=K,NVAR,KK) 12 CONTINUE 17 CONTINUE WRITE(IPRI,1402) CCCC CCCC COMPUTATION OF MARGINAL FREQUENCIES ETC. CCCC OLFIT=0.0D0 NORM=1 NMAF=NOBS CALL PREPA4 (MARFRE,MARFIN,MAFRPV,MFPVIN,DATAIN, + ICATGO,AUXILI,FACT, + ISUC,NMAF,NONV,NVAR,NOBS,NORM,MAXC) 881 CONTINUE DO 15 I=1,NVAR KMIS=AUXILI(I) IF(KMIS.EQ.NOBS) WRITE (IPRI,1700) I 15 CONTINUE CALL INIFIG (DATAIN,ICATGO,MARFRE,MARFIN,MAFRPV,ACCUMU,OBSCOR, + CATSCO,AUXILI,ITYP,STRES1,STRES3,JTYP,DIRCOS,MFPVIN, + DATAPV,IPARTI,TEXT,AIDH,STRESC,NAME,LABEL, + NOBS,NVAR,NDIM,MAXC,ISUC,IWR1,IPLO,NONV,NOND,NDSQ,ISND + ,NAUX,NVND,NPLV,EPSIN,NITIN,IWR2,NDND,FACT,OLFIT,IPRIN, + NIPA,NDAT,IOUT1,IOUT2,IOUT3,IOUT4,NAID,NITR,ILEV) NITR = 0 CCC IF (IWR2.NE.0) WRITE (IPRI,1403) CCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCC CCCC CCCC START OF THE MAIN ITERATIVE PROCESS CCCC CCCC CCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCC 20 NITR = NITR + 1 KNOB = -NOBS DO 40 IP=1,NDIM KNOB = KNOB +NOBS DO 41 K=1,NOBS IF (NITR.GT.1) OBSCOR(K+KNOB)=ACCUMU(K+KNOB) ACCUMU(K+KNOB)=0.0D0 41 CONTINUE 40 CONTINUE DO 50 K=1,ISND CATSCO(K) = 0.0D0 50 AIDH(K) = 0. CCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCC CCC CCCC THE QUANTIFICATION OVER VARIABLES CCC CCCC CCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCC K = 1 N = 1 L = 1 M = 1 DO 60 J=1,NVAR IK=K-1 STRES3(J) = 0.0D0 DO 61 IP=1,NDIM STRES1 (IK+IP)=0.0D0 61 CONTINUE ICND = ICATGO(J) * NDIM KATJ = ICATGO(J) CALL PROING (DATAIN(N),OBSCOR,CATSCO(L),NOBS,NDIM, + KATJ,NOND,ICND,1,KATJ,4) CALL MPR1 (MARFIN(M),CATSCO(L),CATSCO(L),KATJ,NDIM,ICND) IAA=1+KATJ MKJ=5*KATJ+4 ICC=MKJ+KATJ+1 CALL ADDDIA(CATSCO(L),MARFRE(M),STRES1(K),KATJ,NDIM,ICND) IF (ITYP(J).NE.0) CALL MEALEV(CATSCO(L),AUXILI(1),DIRCOS(K), + AUXILI(IAA),ITYP(J),MARFRE(M),STRES3(J), + KATJ,NDIM,ICND,MKJ,NOBS) CALL PROING (DATAIN(N),CATSCO(L),ACCUMU,NOBS,NDIM, + KATJ,ICND,NOND,1,KATJ,3) K = K + NDIM L = L + ICND N = N + NOBS 60 M = M + ICATGO(J) CCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCC CCC CCCC TEST ON CONVERGENCE AND END OF THE MAIN ITERATIVE LOOP CCC CCCC CCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCC T2 = 0.0D0 T3 = 0.0D0 T4 = 0.0D0 TFIT = 0.0D0 TMLOSS = 0.0D0 SLOSS = 0.0D0 TLOSS = 0.0D0 K=1 DO 70 J=1,NVAR IK=K-1 DO 71 IP=1,NDIM T2 = T2 + STRES1(IK+IP)/DFLOAT(NVAR) IF(ITYP(J).NE.0) T4 = T4 + STRES1(IK+IP)/DFLOAT(NVAR) 71 CONTINUE IF(ITYP(J).NE.0) T3 = T3 + STRES3(J)/DFLOAT(NVAR) K=K+NDIM 70 CONTINUE SLOSS = T4 - T3 TMLOSS = NDIM - T2 TLOSS = TMLOSS + SLOSS TFIT = T2-SLOSS DIST = DABS(TFIT-OLFIT) IF(IWR2.NE.0) WRITE(IPRI,1404) NITR,TFIT,TLOSS,TMLOSS,SLOSS,DIST OLFIT = TFIT IX = 1 IF (DIST.LT.EPSI) IX = -1 IF (NITR.GT.MAXI) IX = 0 IF (IX) 21,22,23 21 WRITE (IPRI,1600) GO TO 90 22 WRITE (IPRI,1500) GO TO 90 23 CONTINUE CCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCC CCC CCCC THE ORTHOGONALIZATION CCC CCCC CCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCC CALL DIFMEA (ACCUMU,MAFRPV,NOBS,NDIM,NOND,FACT,0) CALL MPR1 (MFPVIN,ACCUMU,ACCUMU,NOBS,NDIM,NOND) CALL MOGRAM (ACCUMU,NOBS,NDIM,NOND) CALL MPR1 (MFPVIN,ACCUMU,ACCUMU,NOBS,NDIM,NOND) CCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCC CCC CCCC RETURN TO THE START OF THE ITERATION LOOP CCC CCCC CCC GOTO 20 CCCC CCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCC 90 CONTINUE CCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCC CCC CCCC ROTATION OF THE FINAL CONFIGURATION TO ITS CCC CCCC PRINCIPAL COMPONENTS , SCALING THAT THE SSQ CCC CCCC PER COLUMN EQUALS THE NUMBER OF OBSERVATIONS CCC CCCC AND COMPUTATION OF THE ACCORDING CATEGORY SCORES CCC CCCC CCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCC N = 1 + NDSQ L = N + NDIM CALL ROT1 (CATSCO,OBSCOR,MARFRE,AUXILI,AUXILI(N),AUXILI(L), + ICATGO,ISND,ISUC,NDIM,NDSQ,NVAR,NOND,NOBS,NONV,DATAIN,0, + DIRCOS,NVND,NVAR) CONST=SQRT(FLOAT(NOBS)) DO 75 JI=1,NOND 75 OBSCOR(JI)=OBSCOR(JI)*CONST DO 74 K=1,ISND 74 CATSCO(K) = 0.0D0 N = 1 L = 1 M = 1 DO 76 J=1,NVAR ICND = ICATGO(J) * NDIM KATJ = ICATGO(J) CALL PROING (DATAIN(N),OBSCOR,CATSCO(L),NOBS,NDIM, + KATJ,NOND,ICND,1,KATJ,4) CALL MPR1 (MARFIN(M),CATSCO(L),CATSCO(L),KATJ,NDIM,ICND) L = L + ICND N = N + NOBS 76 M = M + ICATGO(J) CCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCC CCCC THE SECOND I/O BLOCK CCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCC CALL OUTPUT (DATAIN,DATAPV,ICATGO,MARFRE,OBSCOR,ACCUMU,CATSCO, + CATSCO,STRES1,AUXILI,IPARTI,ITYP,MARFIN,STRES3,TEXT,AIDH, + STRESC,DIRCOS,STRES1,LABEL, + NOBS,NVAR,NDIM,IOUT1,IOUT2,IOUT3,IOUT4, + NOND,ISUC,NPLV,NAME,NONV,NDAT,ISND,NIPA,NAUX, + IWR1,IPLO,2*NOND,2*ISND,MAXC,NVND,NAID,NITR,1) CCCC CCCC FORMAT LIST CCCC 1301 FORMAT (////39H MEASUREMENT LEVEL PER VARIABLE:// + 1H ,15X,11HMEASUREMENT,3(20X,11HMEASUREMENT)/ + 31H VARIABLE LEVEL !, + 31H VARIABLE LEVEL !, + 31H VARIABLE LEVEL !, + 31H VARIABLE LEVEL !/ + 4H ,120(1H-)/ + 1H ,29X,1H!,3(30X,1H!)) 1302 FORMAT(///1H0,4X,45H * MEASUREMENT LEVEL FOR ALL VARIABLES IS * :, + 2H ,4A4/1H ,4X,42H -------------------------------------- ) 1303 FORMAT(1H1,41H THE MEASUREMENT LEVEL CODE FOR VARIABLE ,I3, + 51H IS NOT PERMITTED, THE PROGRAM EXECUTION HAS ABNOR, + 11HMALLY ENDED) 1401 FORMAT (1H ,4X,F4.0,4X,4A4,1X,1H!,3(4X,F4.0,5X,4A4,1X,1H!)) 1402 FORMAT (1H1/) 1403 FORMAT(1H1//5X,42H* THE HISTORY OF ITERATIONS TO COMPUTE THE, + 22H FINAL CONFIGURATION */ + 1H ,6X,60(1H-)// +1H ,52H ITERATION TOTAL TOTAL MULTIPLE, + 52H SINGLE DIFFERENCE BETWEEN THE / +1H ,52H NUMBER FIT LOSS LOSS , + 52H LOSS LAST TWO ITERATIONS //) 1404 FORMAT (1H ,I8,3X,4(F14.7),F14.7) 1500 FORMAT(/52H THE ITERATIVE PROCESS STOPS BECAUSE THE MAXIMUM, + 32H NUMBER OF ITERATIONS IS REACHED) 1600 FORMAT(/53H THE ITERATIVE PROCESS STOPS BECAUSE THE CONVERGE, + 25HNCE TEST VALUE IS REACHED) 1700 FORMAT (1H ,40X,22HWARNING : VARIABLE NR.,I5, + 25HHAS NO VALID OBSERVATIONS/ + 1H ,40X,49H EXECUTION IS CONTINUED WITH ZERO QUANTIFICATIONS, + 18H FOR THIS VARIABLE) RETURN END SUBROUTINE PRIINM (MA,N) DIMENSION MA(N), FMT1(60) COMMON /VARBLS/ NOBS,NVAR,NDIM,MAXC,ISUC,INPU,IDAT,IWR1, + IPLO,IOUT1,MAXI,NONV,NOND,NVNV,NDSQ, + NDND,ISND,NAUX,NVND,NDAT,NIPA,EPSI, + IJOB,NJOB,NPLV,NAME(20),NAID,ILEV,EPSIN,NITIN, + IWR2,IOUT2,IOUT3,IOUT4,IPRIN,LABEL(35),ICAT COMMON /LINOUT/ ICAR,IPRI DATA A,B /1H*,1H// CCCC CCCC COMPUTE POINTERS FOR ARRAY MA, INDICATING THE STARTING POINTS CCCC OF THE SUB-ARRAYS CCCC IA = NONV + 1 IB = NDAT + IA IC = NVAR + IB ID = ISUC + IC IE = 2*ISUC + ID IF = NOBS + IE IH = 2*NOBS + IF II = 2*NOND + IH IJ = 2*NOND + II IL = 2*ISND + IJ IM = NIPA + IL IN = NAUX + IM IP = NVAR + IN IQ = 5*NVAR + IP IR = 2*NVND + IQ IS = 2*NVAR + IR IT = NAID + IS IU = NDIM + IT IV = NVND + IU C NVR1 = NVAR + NPLV CCCC CCCC READ AND WRITE THE NUMBER OF CATEGORIES PER VARIABLE CCCC IF (ICAT.NE.0) GOTO 55 READ(ICAR,1000)(MA(IB-1+I),I=1,NVR1) WRITE (IPRI,1300) KK = (NVR1 + 3) / 4 DO 2 K=1,KK 2 WRITE (IPRI,1400) (I,MA(IB-1+I),I=K,NVR1,KK) GOTO 66 55 CONTINUE DO 56 I=1,NVR1 MA(IB-1+I)=ICAT 56 CONTINUE WRITE (IPRI,1301) MA(IB) 66 CONTINUE JPLO=IPLO/10 KPLO=IPLO-JPLO*10 IF (JPLO.LE.1.AND.KPLO.LE.1) GO TO 5 CCCC CCCC READ AND WRITE THE REQUESTED PLOT OPTIONS CCCC AND CHECK WETHER THEY ARE FEASIBLE CCCC READ (ICAR,1200) (MA(IL-1+I),I=1,NVR1) IF (NPLV.EQ.0) GO TO 250 NNNN = NVAR + 1 DO 200 I=NNNN,NVR1 IF (MA(IL-1+I).GT.2) MA(IL-1+I) = 0 200 IF (MA(IL-1+I).EQ.2) MA(IL-1+I) = 1 250 CONTINUE WRITE (IPRI,1500) DO 6 I=1,NVR1 IF (MA(IL-1+I).EQ.1) WRITE (IPRI,1600) I,A IF (MA(IL-1+I).EQ.2) WRITE (IPRI,1600) I,A,B 6 IF (MA(IL-1+I).EQ.3) WRITE (IPRI,1600) I,B 5 CONTINUE CCCC CCCC READ THE MEASUREMENT LEVELS OF THE VARIABLES CCCC IF (ILEV.EQ.0) GOTO 1 DO 3 I=1,NVR1 MA(IN-1+I)=ILEV-1 3 CONTINUE GOTO 4 1 READ (ICAR,1000) (MA(IN-1+I),I=1,NVAR) 4 CONTINUE CCCC CCCC ONLY FOR MIXED VARIABLES: CCCC COMPUTE THE MAXIMUM RANK OF THE DATAMATRIX CCCC AND ADJUST THE REQUESTED NUMBER OF DIMENSIONS CCCC IF NECESSARY. CCCC IF(ILEV.GT.0) GOTO 41 IRANK=0 DO 40 J=1,NVAR C1010 FORMAT(1H ,4I10) IF(MA(IN-1+J).EQ.0) IRANK=IRANK+MA(IB-1+J)-1 IF(MA(IN-1+J).GT.0) IRANK=IRANK+1 C WRITE(IPRI,1010) IRANK,MA(IB-1+J),ILEV,MA(IN-1+J) 40 CONTINUE IF(NDIM.LE.IRANK) GOTO 41 WRITE(IPRI,5100) IRANK RETURN 41 CONTINUE CCCC CCCC READ AND WRITE INPUT FORMAT AND THE DATAMATRIX CCCC READ (ICAR,1100) FMT1 WRITE (IPRI,1700) FMT1 NNNN = (NPLV+NVAR) * NOBS DO 16 I=1,NOBS READ (INPU,FMT1) (MA(J),J=I,NNNN,NOBS) 16 CONTINUE IF (INPU.NE.ICAR.AND.IJOB.LT.NJOB) REWIND INPU KPAR=MIN0(NOBS,10) IF (IDAT.EQ.1) KPAR=NOBS WRITE (IPRI,2300) KPAR NN = NVR1 NNNN = NN IF (NN.GT.25) NN = 25 N4 = NN * 4 + 2 WRITE (IPRI,3000) (I,I=1,NN) WRITE (IPRI,3100) (A,J=1,N4) NONN = NOBS * NNNN DO 25 I=1,KPAR 25 WRITE (IPRI,3200) I,(MA(J),J=I,NONN,NOBS) 32 CONTINUE CCCC CCCC CHECK IF THE TOTAL NUMBER OF CATEGORIES IS NOT TOO SMALL CCCC CCCC CHECK IF THE MAXIMUMNUMBER OF CATEGORIES IS NOT TOO SMALL CCCC CCCC THE NON-ANALYSIS PLOT PARTITIONING VARIABLES ARE ONLY CCCC CHECKED FOR THE MAXIMUM NUMBER OF CATEGORIES CCCC IRET = 0 NMAX = 0 NSUM = 0 DO 35 J=1,NVAR IF (NMAX.LT.MA(IB-1+J)) NMAX = MA(IB-1+J) 35 NSUM = NSUM + MA(IB-1+J) MMAX = NMAX CCCC CCCC CHECK THE MAXIMUM NUMBER OF CATEGORIES OF CCCC THE PARTITIONING VARIABLES CCCC IF (NPLV.EQ.0) GOTO 39 DO 37 J=1,NPLV IF(NMAX.LT.MA(IC-1+J)) NMAX=MA(IC-1+J) 37 CONTINUE 39 CONTINUE IF (NSUM.LE.ISUC) GO TO 38 WRITE (IPRI,4000) NSUM, ISUC IRET = 1 38 IF (NMAX.LE.MAXC) GO TO 500 WRITE (IPRI,4100) NMAX,MAXC IRET = 1 500 CONTINUE ISUC = NSUM MAXC = MMAX IF (IRET.EQ.0) GO TO 600 WRITE (IPRI,5000) RETURN 600 CONTINUE C CALL PRIINI (MA(1),MA(IA),MA(IB),MA(IC),MA(ID),MA(IE),MA(IF), + MA(IH),MA(II),MA(IJ),MA(IL),MA(IM),MA(IN), + MA(IP),MA(IQ),MA(IR),MA(IS),MA(IT),MA(IU),MA(IV), + LABEL, + NOBS,NVAR,NDIM,MAXC,ISUC, + INPU,IDAT,IWR1,IPLO,IOUT1,MAXI,NONV,NOND, + NVNV,NDSQ,NDND,ISND,NAUX,NVND, + NDAT,NIPA,EPSI,IJOB,NJOB,NPLV,NAME,NAID,EPSIN, + NITIN,IWR2,IOUT2,IOUT3,IOUT4,IPRIN,ILEV) RETURN C CCCCCCCCCCCCC FORMATS CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 1000 FORMAT (16I5) 1100 FORMAT (20A4) 1200 FORMAT (80I1) 1300 FORMAT (////45H * NUMBER OF CATEGORIES PER VARIABLE * :/ + 45H --------------------------------- // + 1H ,17X,9HNUMBER OF,21X,9HNUMBER OF,21X,9HNUMBER OF,21X, + 9HNUMBER OF/36H VARIABLE CATEGORIES ! , + 52HVARIABLE CATEGORIES ! VARIABLE CATEGORIES, + 30H ! VARIABLE CATEGORIES/6H ,115(1H-)/ + 3H ,28X,1H!,29X,1H!,29X,1H!) 1301 FORMAT (////49H * THE NUMBER OF CATEGORIES FOR ALL VARIABLES, + 7H IS * :,I5/7X,45(1H-)) 1400 FORMAT (1H ,2X,I8,5X,I8,7X,2H! ,I8,5X,I8,7X,2H! , + I8,5X,I8,7X,2H! ,I8,5X,I8) 1500 FORMAT (////44H THE FOLLOWING VARIABLES ACT AS LABELING, + 40H-VARIABLES IN THE OBJECT SCORES PLOT, IF, + 26H LABELED WITH A STAR, AND,/4X,18H IF LABELED WITH A, + 58H SLASH, THE OPTIMALLY SCALED CATEGORIES OF THOSE VARIABLES, + 13H ARE PLOTTED:/) 1600 FORMAT (1H ,I10,1X,2A1) 1700 FORMAT(//////1H ,4X,36H* FORMAT TO READ THE DATAMATRIX * : ,20A4/ + 1H ,5X,30H -----------------------------,(1H ,5X,20A4)) 2300 FORMAT (//1H0,I8,1X,24HROWS OF THE DATAMATRIX :/7X,25(1H-)/) 3000 FORMAT (1H ,8X,1H*/1H ,9X,11H* VARIABLES/1H ,10X,1H*/1H ,11X,1H*/ + 1H ,12X,2H* ,25I4) 3100 FORMAT (14H OBJECTS ,102A1) 3200 FORMAT (1H ,7X,I5,2H *,25I4/(1H ,13X,1H*,25I4)) 4000 FORMAT (46H0ERROR DETECTED: THE SPECIFIED TOTAL NUMBER OF, + 33H CATEGORIES (ISUC) IS NOT CORRECT/1H , + 16X,12HIT SHOULD BE,I5,11H INSTEAD OF,I5) 4100 FORMAT (48H0ERROR DETECTED: THE SPECIFIED MAXIMUM NUMBER OF, + 33H CATEGORIES (MAXC) IS NOT CORRECT/1H , + 16X,12HIT SHOULD BE,I5,11H INSTEAD OF,I5) 5000 FORMAT (45H0EXECUTION OF THE PROGRAM HAS BEEN TERMINATED) 5100 FORMAT (46H0THE NUMBER OF DIMENSIONS IS GREATER THAN THE , + 36HMAXIMUM RANK OF THE MIXED DATAMATRIX/, + 1H ,21HTHE MAXIMUM RANK IS :,I5/, + 35HTHE EXECUTION HAS ABNORMALLY ENDED:/ + 52HADJUST THE NUMBER OF DIMENSIONS AND RESUBMIT THE JOB//) END SUBROUTINE PRITRI(T,N,NT,IWRITE) TRI00010 C ******************************************************************TRI00020 C * *TRI00030 C * P R I T R I *TRI00040 C * *TRI00050 C * PURPOSE: PRINTS THE LOWER TRIANGULAR PART OF A SQUARE SYMME- *TRI00060 C * TRIC N*N MATRIX, STORED IN THE ONE-DIMENSIONAL ARRAY *TRI00070 C * T OF LENGTH NT. DIAGONAL ENTRIES ARE PRINTED AS STARS*TRI00080 C * *TRI00090 C * SUBROUTINES CALLED: NONE *TRI00100 C * *TRI00110 C * AUTHOR: WILLEM HEISER RELEASED: APRIL 1977 *TRI00120 C * *TRI00130 C ******************************************************************TRI00140 DIMENSION T(NT),FORM(6),FREP(12) TRI00150 DATA FORM/4H(1H ,4H, I5,4H,2X,,4H ,4HF9.3,4H,A9)/ TRI00160 DATA FREP/4H 1,4H 2,4H 3,4H 4,4H 5,4H 6, TRI00170 X 4H 7,4H 8,4H 9,4H 10,4H 11,4H 12/ TRI00180 DATA STAR/4H* / TRI00190 C CTRI00200 C CHECK HOW MANY TIMES THE NUMBER OF COLUMNS EXCEEDS 12 CTRI00210 C CTRI00220 NTRU=N/12 TRI00230 NREM=N-NTRU*12 TRI00240 IF (NREM.GT.0) GO TO 1 TRI00250 NREM=12 TRI00260 NTRU=NTRU-1 TRI00270 1 NREP=NTRU+1 TRI00280 C CTRI00290 C PRINT NREP TIMES A BLOCK OF ELEMENTS CTRI00300 C CTRI00310 LB=1 TRI00320 NK=12 TRI00330 DO 2 I=1,NREP TRI00340 IF (I.EQ.NREP) NK=NREM TRI00350 KB=LB TRI00360 KE=KB+NK-1 TRI00370 WRITE(IWRITE,60) (K,K=KB,KE) TRI00380 WRITE(IWRITE,61) TRI00390 WRITE(IWRITE,62) KB,STAR TRI00400 LB=KB+1 TRI00410 LE=KE TRI00420 IF (LB.GT.LE) RETURN TRI00430 C CTRI00440 C PRINT TRIANGULAR PART CTRI00450 C CTRI00460 ME=(KB*KB-KB)/2 TRI00470 INCR=0 TRI00480 DO 4 L=LB,LE TRI00490 MB=ME+KB TRI00500 ME=MB+INCR TRI00510 INCR=INCR+1 TRI00520 FORM(4)=FREP(INCR) TRI00530 4 WRITE(IWRITE,FORM) L,(T(M),M=MB,ME),STAR TRI00540 LB=LE+1 TRI00550 IF (LB.GT.N) RETURN TRI00560 C CTRI00570 C PRINT RECTANGULAR PART CTRI00580 C CTRI00590 FORM(4)=FREP(12) TRI00600 INCR=KE-1 TRI00610 DO 7 L=LB,N TRI00620 MB=MB+INCR TRI00630 ME=MB+11 TRI00640 INCR=INCR+1 TRI00650 7 WRITE(IWRITE,FORM) L,(T(M),M=MB,ME) TRI00660 2 CONTINUE TRI00670 RETURN TRI00680 60 FORMAT(1H0,4X,12I9) TRI00690 61 FORMAT(1H ) TRI00700 62 FORMAT(1H ,I5,2X,A9) TRI00710 END TRI00720 SUBROUTINE PROING (INDMAT,GENMAT,RESMAT,N,M,L,NG,NR,L1,LC,MSA) INTEGER INDMAT DOUBLE PRECISION GENMAT, RESMAT DIMENSION INDMAT(N), GENMAT(NG), RESMAT(NR) II = 0 JJ = L1 - 1 GO TO (10,40,70,100), MSA 10 DO 30 J=1,M DO 20 I=1,N II = II + 1 KK = JJ + INDMAT(I) 20 RESMAT(II) = RESMAT(II) + GENMAT(KK) 30 JJ = JJ + LC RETURN 40 DO 60 J=1,M DO 50 I=1,N KK = JJ + INDMAT(I) II = II + 1 50 RESMAT(KK) = RESMAT(KK) + GENMAT(II) 60 JJ = JJ + LC RETURN 70 DO 90 J=1,M DO 80 I=1,N II = II + 1 KK = JJ + INDMAT(I) 80 IF (INDMAT(I).LE.L) + RESMAT(II) = RESMAT(II) + GENMAT(KK) 90 JJ = JJ + LC RETURN 100 DO 120 J=1,M DO 110 I=1,N II = II + 1 KK = JJ + INDMAT(I) 110 IF (INDMAT(I).LE.L) + RESMAT(KK) = RESMAT(KK) + GENMAT(II) 120 JJ = JJ + LC RETURN END SUBROUTINE RANDMA (A,N) C>>>> WARNING: THE NECESSARY AVAILABLE INTEGER ARITHMETIC IS C>>>> 125 * 2796203 = 348525375 (<2**29) DIMENSION A(N) DOUBLE PRECISION A,Z IY = 315747 M = 2796203 Z = 2.0D0 / M DO 10 I=1,N IY = IY * 125 IY = IY - (IY/M) * M 10 A(I) = -1.0D0 + IY * Z RETURN END SUBROUTINE ROT1 (CA,OB,MA,Z,D,E,IC,N1,N2,N3,N4,N5,N6,N7,NONV,DAT, + METH,DIRCOS,NVND,NVAR) COMMON /LINOUT/ ICAR,IPRI DIMENSION CA(N1),MA(N2),Z(N4),D(N3),E(N3),IC(N5),OB(N6),DAT(NONV), + DIRCOS(NVND) DOUBLE PRECISION CA,OB INTEGER DAT IF (METH.EQ.1)CALL SUMSQU(CA,OB,IC,DAT,Z,N4,N5,N7,N1,N3,N6,NONV) IF(METH.EQ.1) GOTO 150 C DO 101 K=1,N4 101 Z(K) = 0. M = 1 L = 1 DO 141 J=1,N5 KATJ = IC(J) LL = - KATJ I4 = 0 DO 131 II = 1,N3 LL = LL + KATJ I1 = L DO 121 JJ = 1,N3 I3 = L + LL I2 = M I4 = I4 + 1 DO 111 KK = 1,KATJ Z(I4) = Z(I4) + CA(I1) * MA(I2) * CA(I3) I1 = I1 + 1 I2 = I2 + 1 111 I3 = I3 + 1 121 CONTINUE 131 CONTINUE M = M + IC(J) 141 L = L + IC(J) * N3 C 150 CALL TRED2 (N3,Z,D,E,N3) CALL IMTQL2(IERR,N3,Z,D,E,N3) IF(IERR.GT.0) GOTO 400 C DO 341 I=1,N7 I2 = 1 DO 321 II=1,N3 I1 = I E(II) = 0. DO 311 JJ = 1,N3 E(II) = E(II) + OB(I1) * Z(I2) I1 = I1 + N7 311 I2 = I2 + 1 321 CONTINUE I1 = I DO 331 II = 1,N3 OB(I1) = E(II) 331 I1 = I1 + N7 341 CONTINUE NDIM=N3 DO 441 J=1,NVAR I2 = 1 DO 421 L=1,N3 I1=(J-1)*NDIM+1 E(L) = 0. DO 411 K = 1,N3 E(L) = E(L) + DIRCOS(I1) * Z(I2) I1 = I1 + 1 411 I2 = I2 + 1 421 CONTINUE I1=(J-1)*NDIM+1 DO 431 L = 1,N3 DIRCOS(I1) = E(L) 431 I1 = I1 + 1 441 CONTINUE RETURN 400 WRITE(IPRI,500) 500 FORMAT(44H1NO CONVERGENCE OF EIGENVALUE ROUTINE IMTQL2, + /18H0NO ROTATION FOUND) STOP END SUBROUTINE SILOSS (STRES1,STRES3,DIRCOS,ITYP,NDIM,NVAR,IPRI, + STRESA,STRESC) DIMENSION STRES1(NDIM,NVAR),STRESC(NDIM),ITYP(NVAR), + DIRCOS(NDIM,NVAR),STRES3(NVAR) REAL DIRCOS,STRESC INTEGER ITYP DOUBLE PRECISION STRES1,STRES3 DATA A/3H /,B/3H - / CCCCC WRITE (IPRI,70) KDIM = NDIM+1 ISING = 0 DO 10 I=1,NVAR IF(ITYP(I).EQ.0) WRITE(IPRI,85) I,(A,B,A,K=1,KDIM) IF(ITYP(I).EQ.0) GOTO 10 RSUM = 0.0D0 DO 5 K=1,NDIM STRES1(K,I) = DIRCOS(K,I) * DIRCOS(K,I) RSUM = RSUM + STRES1(K,I) 5 CONTINUE WRITE (IPRI,95) I,RSUM,(STRES1(K,I),K=1,NDIM) IF(ITYP(I).NE.0) ISING = ISING + 1 10 CONTINUE STRESA = 0. DO 20 K=1,NDIM STRESC(K) = 0. DO 15 I=1,NVAR IF(ITYP(I).NE.0) STRESC(K) = STRESC(K)+STRES1(K,I) 15 CONTINUE STRESA = STRESA + STRESC(K) 20 CONTINUE STRESA = STRESA / FLOAT(ISING) DO 21 I=1,NDIM STRESC(I) = STRESC(I) / FLOAT(ISING) 21 CONTINUE WRITE (IPRI,101) STRESA,(STRESC(K),K=1,NDIM) WRITE (IPRI,80) DO 4 I=1,NVAR IF(ITYP(I).EQ.0) WRITE(IPRI,90) I,(A,B,A,K=1,NDIM) IF(ITYP(I).EQ.0) GOTO 4 WRITE (IPRI,100) I,(DIRCOS(K,I),K=1,NDIM) 4 CONTINUE CCCCCCCCCCCCCCCC C FORMATS C CCCCCCCCCCCCCCCC 70 FORMAT (1H0/21X,11H SINGLE FIT/21X,11H ----------/) 80 FORMAT(1H0/21X,19H COMPONENT LOADINGS/21X,19H ------------------/) 85 FORMAT (1H ,I7,4X,30A3/(1H ,10X,30A3)) 90 FORMAT (1H ,I7,3X,6H ,4X,30A3/(1H ,10X,30A3)) 95 FORMAT (1H ,I7,3X,F7.3,1X,(10F9.3)/(1H ,10X,10F9.3)) 100 FORMAT (1H ,I7,11X,(10F9.3)/(1H ,10X,10F9.3)) 101 FORMAT (1H0,10H MEAN ,F7.3,1X,(10F9.3)/(1H ,10X,10F9.3)) RETURN END SUBROUTINE SUMSQU(CA,OB,ICA,DAT,Z,NDSQ,NVAR,NOBS,ISND,NDIM,NOND, + NONV) CCCC CCCC THIS ROUTINE COMPUTES CROSSPRODUCTS OF CATEGORY CCCC SCORES. MISSING VALUES ARE SUBSTITUTED BY THE CCCC CORRESPONDING OBSERVATION SCORES. CCCC DIMENSION CA(ISND),OB(NOND),ICA(NVAR),DAT(NONV),Z(NDSQ) DOUBLE PRECISION CA,OB INTEGER DAT CCCC DO 1 K=1,NDSQ Z(K)=0. 1 CONTINUE INOB=-NOBS H=0 L=1 DO 2 J=1,NVAR INOB=INOB+NOBS LL=-NOBS KATJ=ICA(J) HH=-KATJ I4=0 DO 3 II=1,NDIM LL=LL+NOBS HH=HH+KATJ I1=L IH1=H DO 4 JJ=1,NDIM IH3=H+HH I3=L+LL I4=I4+1 DO 5 KK=1,NOBS IF(DAT(KK+INOB).GT.KATJ) GOTO 6 REAL1=CA(DAT(KK+INOB)+IH1) REAL2=CA(DAT(KK+INOB)+IH3) GOTO 7 6 REAL1=OB(I1) REAL2=OB(I3) 7 CONTINUE Z(I4)=Z(I4)+REAL1*REAL2 I1=I1+1 I3=I3+1 5 CONTINUE IH1=IH1+KATJ IH3=IH3+KATJ 4 CONTINUE 3 CONTINUE L=1 H=H+ICA(J)*NDIM 2 CONTINUE RETURN END SUBROUTINE TRED2(N, 1 Z,D,E,NP) C ****************************************************************** C * * C * T R E D 2 * C * * C * PURPOSE: REDUCES A REAL SYMMETRIC MATRIX TO A SYMMETRIC TRI- * C * DIAGONAL MATRIX USING ORTHOGONAL SIMILARITY TRANS- * C * FORMATIONS; THE ACCUMULATED ORTHOGONAL TRANSFORMA- * C * TIONS ARE RETAINED IN Z. * C * * C * SUBROUTINES CALLED: NONE * C * * C * ADAPTED FROM EISPACK * C * * C ****************************************************************** DIMENSION Z(NP,NP),D(NP),E(NP) C IF (N .EQ. 1) GO TO 320 C ********** FOR I=N STEP -1 UNTIL 2 DO -- ********** DO 300 II =2, N I = N + 2 - II L = I - 1 H = 0.0 SCALE = 0.0 IF (L .LT.2) GO TO 130 C ********** SCALE ROW (ALGOL TOL THEN NOT NEEDED) ********** DO 120 K =1, L 120 SCALE = SCALE + ABS(Z(I,K)) C IF (SCALE .NE. 0.0) GO TO 140 130 E(I) = Z(I,L) GO TO 290 C 140 DO 150 K = 1, L Z(I,K) = Z(I,K) / SCALE H = H + Z(I,K) * Z(I,K) 150 CONTINUE C F = Z(I,L) G = -SIGN(SQRT(H),F) E(I) = SCALE * G H = H - F * G Z(I,L) = F - G F = 0.0 C DO 240 J = 1, L Z(J,I) = Z(I,J) / (SCALE * H) G = 0.0 C ********** FORM ELEMENT OF A*U ********** DO 180 K = 1, J 180 G = G + Z(J,K) * Z(I,K) C JP1 = J + 1 IF (L .LT. JP1) GO TO 220 C DO 200 K = JP1, L 200 G = G + Z(K,J) * Z(I,K) C ********** FORM ELEMENT OF P ********** 220 E(J) = G / H F = F + E(J) * Z(I,J) 240 CONTINUE C HH = F / (H + H) C ********** FORM REDUCED A ********** DO 260 J =1, L F = Z(I,J) G = E(J) - HH * F E(J) = G C DO 260 K = 1, J Z(J,K) = Z(J,K) - F * E(K) -G * Z(I,K) 260 CONTINUE C DO 280 K = 1, L 280 Z(I,K) = SCALE * Z(I,K) C 290 D(I) = H 300 CONTINUE C 320 D(1) = 0.0 E(1) = 0.0 C ********** ACCUMULATION OF TRANSFORMATION MATRICES ********** DO 500 I = 1, N L = I - 1 IF (D(I) .EQ. 0.0) GO TO 380 C C DO 360 J = 1, L G = 0.0 DO 340 K =1, L 340 G = G + Z(I,K) * Z(K,J) C DO 360 K = 1, L Z(K,J) = Z(K,J) - G * Z(K,I) 360 CONTINUE C 380 D(I) = Z(I,I) Z(I,I) = 1.0 IF (L .LT. 1) GO TO 500 C DO 400 J =1, L Z(I,J) = 0.0 Z(J,I) = 0.0 400 CONTINUE C 500 CONTINUE C RETURN END SUBROUTINE WEDEV(Z,ID,N1,N) C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C C C VECTOR Z IS REPLACED BY THE DEVIATIONS OF THE WEIGHTED MEAN C C C ID= MARGINAL FREQUENCIES C C C N1= NUMBER OF DIFFERENT VALUES (DIMENSION OF Z) C C C N = NUMBER OF OBSERVATIONS C C C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC REAL Z INTEGER ID DIMENSION Z(N1),ID(N1) XS=0. DO 10 L=1,N1 XS=XS+Z(L)*FLOAT(ID(L)) 10 CONTINUE S=XS/FLOAT(N) DO 20 L=1,N1 IF(ID(L).EQ.0) Z(L)=0.0 IF(ID(L).NE.0) Z(L)=Z(L)-S 20 CONTINUE RETURN END SUBROUTINE WESTAN(A,IW,N1,N2) C************************************************* C*** * C*** WIEGHTED STANDARDIZATON OF VECTOR A ON N2 * C*** * C************************************************* REAL A,S INTEGER IW DIMENSION A(N1),IW(N1) S=0.0 DO 10 I=1,N1 10 S=S+A(I)*A(I)*IW(I) S=SQRT(FLOAT(N2)/S) DO 20 I=1,N1 20 A(I)=A(I)*S RETURN END SUBROUTINE WMRMXI (DIST,DISP,IW,TRIALV,LOVBK,LUP,IWOVBK,N,IN) C ****************************************************************** C * * C * W M R M X I * C * * C * PURPOSE: WEIGHTED MONOTONE REGRESSION. * C * * C * SUBROUTINES CALLED: NONE. * C * * C * SEE ACCOMPANYING PAPER SECTIONS: 1.2, 2.7.1, 2.7.2.0, * C * 2.7.2.2.1.1, 2.7.2.2.2.1, * C * 2.7.2.2.3.1. & 2.7.2.2.4.1. * C * * C * AUTHOR: ERNST VAN WANING. RELEASED: OCT. 1977 * C * * C ****************************************************************** C C DIMENSION DIST(N), DISP(N), IW(N) DIMENSION TRIALV(IN),LOVBK(IN),LUP(IN),IWOVBK(IN) REAL DIST,DISP,TRIALV,SDS,SW,TRV INTEGER IW LOGICAL NEWBL/.TRUE./ INTEGER LOVBK, LUP, IWOVBK C IXSTK = 0 DISP(1) = DIST(1) DO 10 IUP = 2, N DISP(IUP) = DIST(IUP) IF ( IXSTK .EQ. 0) GOTO 11 IF ((LUP(IXSTK) + 1) .LT. IUP ) GOTO 11 IF (DISP(IUP) .LT. TRIALV(IXSTK)) GOTO 12 GOTO 10 11 IF (DISP(IUP) .GE. DISP(IUP - 1)) GOTO 10 12 SDS = DISP(IUP)* IW(IUP) SW = IW(IUP) IDOWN = IUP 4 IDOWN = IDOWN - 1 IF ( IXSTK .EQ. 0) GOTO 2 IF (LUP(IXSTK) .EQ. IDOWN) GOTO 1 IF ( IXSTK .EQ. 1) GOTO 2 IF (LUP(IXSTK - 1) .NE. IDOWN) GOTO 2 IXSTK = IXSTK - 1 1 SDS = SDS + IWOVBK(IXSTK) * TRIALV(IXSTK) SW = SW + IWOVBK(IXSTK) IDOWN = IDOWN - LOVBK (IXSTK) + 1 NEWBL = .FALSE. GOTO 3 2 SDS = SDS + IW(IDOWN) * DISP(IDOWN) SW = SW + IW(IDOWN) 3 TRV = SDS / SW IF (IDOWN .EQ. 1) GOTO 5 IF ( IXSTK .EQ. 0) GOTO 40 IF ( (IDOWN - 1) .GT. LUP(IXSTK)) GOTO 40 IF ( IXSTK .EQ. 1) GOTO 41 IF (TRIALV(IXSTK - 1) .GT. TRV ) GOTO 4 41 IF ( (IDOWN - 1) .LT. LUP(IXSTK)) GOTO 40 IF (TRIALV(IXSTK) .GT. TRV ) GOTO 4 GOTO 5 40 IF (DISP (IDOWN - 1) .GT. TRV ) GOTO 4 5 IF (NEWBL) IXSTK = IXSTK + 1 NEWBL = .TRUE. LUP(IXSTK) = IUP LOVBK(IXSTK) = IUP - IDOWN + 1 TRIALV(IXSTK) = TRV IWOVBK(IXSTK) = SW 10 CONTINUE IF (IXSTK .EQ. 0) RETURN DO 20 IUP = 1, IXSTK LUPIUP = LUP(IUP) IDOWN = LUPIUP - LOVBK(IUP) + 1 DO 20 J = IDOWN, LUPIUP 20 DISP(J) = TRIALV(IUP) RETURN END