SUBROUTINE AD(CA,OB,KATJ,DAT,Z,NDSQ,NVAR,NOBS,ICND,NDIM,NOND, + NONV,RESMAT) DIMENSION CA(ICND),Z(NDSQ),OB(NOND),DAT(NOBS),RESMAT(NDIM) DOUBLE PRECISION CA,OB,RESMAT INTEGER DAT CCCC CCCC AUXILIARY ROUTINE J.V.RIJCKEVORSEL AUG. 1980 CCCC DO 9 K=1,NDSQ Z(K)=0. 9 CONTINUE H=0 L=1 LL=-NOBS 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).GT.KATJ) GOTO 6 REAL1=CA(DAT(KK)+IH1) REAL2=CA(DAT(KK)+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 IQ=1 DO 1 IP=1,NDIM RESMAT(IP)=RESMAT(IP) + Z(IQ) IQ=IQ+NDIM+1 1 CONTINUE RETURN END 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 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 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 EXTERNAL HOMAG4 DIMENSION IOUT(3) COMMON /VARBLS/ NOBS,NVAR,NDIM,MAXC,ISUC, + INPU,IDAT,IWRI,IPLO,IOUT,MAXI,NONV,NOND, + MASQ,NVNV,NDSQ,NDND,ISND,NAUX,NACC, + NDAT,NIPA,EPSI,IJOB,NJOB,NPLV,NAME(20),ISTAN, + IPARM,ICAT,ITUN,JDIM,METH COMMON /LINOUT/ ICAR,IPRI C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCCCCCCCCCC VERSION 7.00 HAS SOME FIXED CCCCCCCCCCCC CCCCCCCCCCCC PARAMETERS. THESE PARAMETERS HAVE CCCCCCCCCCCC CCCCCCCCCCCC FIXED VALUES FOR THE USER. CCCCCCCCCCCC CCCCCCCCCCCC THEY CAN BE CHANGED WITHIN THE CCCCCCCCCCCC CCCCCCCCCCCC PROGRAM BUT ONLY ON THE EXPLICIT CCCCCCCCCCCC CCCCCCCCCCCC INSTRUCTIONS OF THE DEPARTMENT OF CCCCCCCCCCCC CCCCCCCCCCCC DATATHEORY,UNIVERSITY OF LEIDEN, CCCCCCCCCCCC CCCCCCCCCCCC THE NETHERLANDS CCCCCCCCCCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCCCCCCCCCC THESE PARAMETERS ARE: CCCCCCCCCCCC CCCCCCCCCCCC CCCCCCCCCCCC CCCCCCCCCCCC -ISTAN-THE COMPUTATION AND OUTPUT OF CCCCCCCCCCCC CCCCCCCCCCCC STANDARDIZED CATEGORY SCORES CCCCCCCCCCCC CCCCCCCCCCCC (FIXED VALUE = 0: NO OUTPUT CCCCCCCCCCCC CCCCCCCCCCCC NO COMPUTATION CCCCCCCCCCCC CCCCCCCCCCCC -ITUN-THE NUMBER OF NON-ORTHOGONALIZING CCCCCCCCCCCC CCCCCCCCCCCC ITERATIONS (FIXED VALUE = 1) CCCCCCCCCCCC CCCCCCCCCCCC -JDIM-THE COMPUTATION OF A P+1 CCCCCCCCCCCC CCCCCCCCCCCC DIMENSIONAL SOLUTION WITH CCCCCCCCCCCC CCCCCCCCCCCC P DIMENSIONAL OUTPUT CCCCCCCCCCCC CCCCCCCCCCCC (FIXED VALUE = 0: NO) CCCCCCCCCCCC CCCCCCCCCCCC -METH-PARAMETER FOR WEIGHTING THE CCCCCCCCCCCC CCCCCCCCCCCC OBSERVATIONS WITH THE NUMBER OF CCCCCCCCCCCC CCCCCCCCCCCC NON MISSING ENTRIES / NVAR CCCCCCCCCCCC CCCCCCCCCCCC (FIXED VALUE: 0=WEIGHTING) CCCCCCCCCCCC CCCCCCCCCCCC (1= NO WEIGHTING) CCCCCCCCCCCC CCCCCCCCCCCC CCCCCCCCCCCC CCCCCCCCCCCC CCCCCCCCCCCC CCCCCCCCCCCC CCCCCCCCCCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ICAR=5 C>>>> ICAR = UNIT-NUMBER OF THE CARD-READER IPRI=6 C>>>> IPRI = UNIT-NUMBER OF THE PRINTER WRITE(IPRI,4050) READ (ICAR,1000) NJOB C LOOP OVER JOBS DO 200 IJOB=1,NJOB WRITE (IPRI,5000) JDIM=0 ISTAN=0 ITUN=0 C READ PARAMETER CARDS READ (ICAR,1100) NAME READ (ICAR,1000) NOBS,NVR1,NVR2,NDIM,MAXC,ISUC,ISTAN,ITUN,JDIM, +METH READ (ICAR,1200) MAXI,EPSIT READ (ICAR,1000) INPU,IDAT,IWRI,IPLO,IPARM,ICAT,IOUT CCC C ASSIGN DEFAULTS AND COMPUTE SEVERAL USEFUL VARIABLES CCC C COMPUTE A SOLUTION FOR NDIM=NDIM+1 AND USE THE FIRST NDIM DIMENSIONS C IN OUTPUT ONLY IF JDIM IS GREATER THAN 0 CCC IDIM=NDIM IF ((ISUC-NVR2).GT.NDIM) NDIM=NDIM+1 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC IF(JDIM.EQ.0) NDIM=IDIM CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCC CCC ADJUST THE NUMBER OF DIMENSIONS TO THE CCC MAXIMUM RANK OF THE PROBLEM CCC IF (MAXI.LE.0) MAXI = 75 E = .1E-20 IF (EPSIT.LT.E) EPSIT = .1E-4 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 MASQ = MAXC * MAXC NVNV = NVAR * (NVAR-1) / 2 NDSQ = NDIM * NDIM NDND = NDIM * (NDIM+1) / 2 ISND = ISUC * NDIM NDAT = 1+(NPLV * NOBS) MAND = MAXC * NDIM C NAUX = MAX0(6*NDSQ,(NDND*NOBS)*2,NVAR) IF (MAXC.GT.NAUX.AND.IPLO.GT.1) NAUX = MAXC IF (NAUX.LT.MAND.AND.ISTAN.GT.0) NAUX=MAND+ 2*MAXC IF (NAUX.LT.ISND.AND.IPLO.GT.0) NAUX= ISND NIPA = NVR1 IF (IPARM.LE.0) GOTO 100 NDAT=MAX0(NDAT,NVAR*NDIM) NAUX=MAX0(NAUX,NDAT,5*(NVAR+1)) 100 CONTINUE C C COMPUTE THE NECESSARY STORAGE FOR ALL PARAMETER-DEPENDING ARRAYS C ISUM = NONV + NVAR + ISUC*3 + NOND*2 + ISND*2 + NDIM*2 + NOND*2 + + NAUX + NDAT + NOBS*3 + NIPA CCCC CCCC THE NUMBER OF ITERATIONS WITHOUT ORTHOGONALIZATION CCCC IS SET TO 3, AND THE CONVERGENCE CRITERION IS CCCC ACCORDINGLY MULTIPLIED BY 3. THE PRECISION THUS CCCC REACHED IS IDENTICAL WITH THE PRECISION THE USER CCCC REQUESTED CCCC CCCC C C PRINT THE PARAMETERS C IOPT=ITUN+ISTAN+JDIM WRITE (IPRI,5050) IJOB,NAME WRITE (IPRI,5100) NOBS,NVR1,NVR2,IDIM,MAXC,ISUC, + MAXI,EPSIT WRITE (IPRI,5200) INPU,IDAT,IWRI WRITE (IPRI,5300) IPLO,IPARM WRITE (IPRI,5500) ICAT WRITE (IPRI,5400) (IOUT(I),I=1,2) IF(ITUN.LE.0) ITUN=1 EPSI=ITUN*EPSIT IF (IOPT.GT.0) WRITE(IPRI,5302) IF (ISTAN.EQ.1) WRITE (IPRI,5301) IF (ITUN.NE.1) WRITE (IPRI,5303) ITUN IF (JDIM.EQ.1) WRITE (IPRI,5304) IF (METH.EQ.1) WRITE (IPRI,5305) C C CALL A VARIABLE STORAGE ALLOCATOR, RETURN IN SUBROUTINE 'HOMAG4' C CALL DECLAR (HOMAG4,A,ISUM) IOU1=IOUT(1) IOU2=IOUT(2) IOU3=IOUT(3) IF (IOU1.GT.0.AND.IOU1.NE.IPRI) REWIND IOU1 IF (IOU2.GT.0.AND.IOU2.NE.IPRI) REWIND IOU2 IF (IOU3.GT.0.AND.IOU3.NE.IPRI) REWIND IOU3 200 CONTINUE C C FORMATS 1000 FORMAT (16I5) 1100 FORMAT (20A4) 1200 FORMAT (I5,E10.8) 4050 FORMAT (1H1,//////////, +30X,58H +++++++++++++++++++++++++++++++++++++++++++++++++++++++++/ +30X,58H + +/ +30X,58H + 21-12-1981 H O M A L S VERSION 7.0 +/ +30X,58H + +/ +30X,58H + THE HOMALS USER'S GUIDE CAN BE OBTAINED FROM THE +/ +30X,58H + DEPARTMENT OF DATATHEORY +/ +30X,58H + BREESTRAAT 70, 2311 CS LEIDEN. +/ +30X,58H + FOR MINOR PROBLEMS CALL +/ +30X,58H + DATATHEORY TEL 140945 OR +/ +30X,58H + THE REKENBURO TEL 148333 EXT 6559 +/ +30X,58H + +/ +30X,58H +++++++++++++++++++++++++++++++++++++++++++++++++++++++++) 5000 FORMAT(1H1/////, + 15H H O M A L S ,25X,23HVERSION 7.00 ,28X/ + 14H DECEMBER 1980/ + 1H ,100X,12H ALBERT GIFI/ + 1H ,100X,22H DEPARTMENT DATATHEORY/ + 1H ,100X,21H UNIVERSITY OF LEIDEN/ + 1H ,100X,16H BREESTRAAT 70 /1H ,100X,7H LEIDEN/ + 1H ,100X,16H THE NETHERLANDS) 5050 FORMAT (10H =========/8H JOB NR.,I2/10H =========/// + 27H INPUT-DATA SPECIFICATIONS:/ + 27H ------------------------- ///8H NAME - ,20A4///) 5100 FORMAT (1H ,22H* PROBLEM PARAMETERS */ + 1H ,22H----------------------/// + 33H NUMBER OF OBJECTS OR INDIVIDUALS,30X,I5// + 44H TOTAL NUMBER OF VARIABLES IN THE DATAMATRIX,19X,I5// + 29H NUMBER OF ANALYSIS-VARIABLES,34X,I5// + 23H NUMBER OF DIMENSIONS ,40X,I5// + 48H MAXIMUM NUMBER OF CATEGORIES OVER ALL VARIABLES,15X,I5// + 53H TOTAL NUMBER OF CATEGORIES OF THE ANALYSIS VARIABLES, + 10X,I5//// + 1H0,23H* ANALYSIS PARAMETERS */ + 1H ,23H-----------------------/// + 29H MAXIMUM NUMBER OF ITERATIONS,34X,I5// + 22H CONVERGENCE CRITERION,36X,E10.2) 5200 FORMAT (1H1/////28H * INPUT/OUTPUT PARAMETERS */ + 1H ,27H---------------------------/// + 30H UNIT NUMBER OF THE DATAMATRIX,33X,I5// + 52H PARAMETER INDICATING THE PRINT OF THE DATAMATRIX , + 11X,I5/1H ,5X,13H0: 10 OBJECTS/1H ,5X,14H1: ALL OBJECTS// + 45H PARAMETER INDICATING WHETHER OR NOT TO PRINT,18X,I5, + /1H ,42HOBJECT SCORES AND CATEGORY QUANTIFICATIONS/ + 1H ,4X,12H 0: NO PRINT/1H ,4X,18H 1: OBJECT SCORES / + 1H ,4X,46H 2: OBJECT SCORES AND CATEGORY QUANTIFICATIONS/ + 1H ,4X,42H 3: CATEGORY QUANTIFICATIONS PER VARIABLE /) 5300 FORMAT (47H PARAMETER INDICATING WHETHER OR NOT AND HOW TO, + 16X,I5/ 1H ,31HPLOT OBJECT SCORES AND CATEGORY, + 16H QUANTIFICATIONS/1H ,4X,11H 0: NO PLOT/1H ,4X, + 55H 1: UNLABELED PLOT OF OBJECT SCORES AND LABELED PLOT OF/ + 1H ,11X,28HALL CATEGORY QUANTIFICATIONS/ + 1H ,4X,51H 2: IN ADDITION, LABELED PLOTS OF OBJECT SCORES AND/ + 1H ,11X,46HCATEGORY QUANTIFICATIONS OF SELECTED VARIABLES/ + 1H ,4X,51H 3:LABELED PLOT OF ALL CATEGORY QUANTIFICATIONS AND/ + 1H ,10X,46H SEPARATE PLOTS OF CATEGORY QUANTIFICATIONS OF/ + 1H ,10X,19H SELECTED VARIABLES// + 56H PARAMETER TO PRINT AND PLOT THE DISCRIMINATION MEASURES, + 7X,I5/1H ,4X,6H 0: NO/1H ,4X,7H 1: YES/) 5500 FORMAT (39H NUMBER OF CATEGORIES FOR ALL VARIABLES,24X,I5/ + 1H ,4X,50H K: THE CATEGORY NUMBERS FOR ALL VARIABLES EQUAL K/ + 1H ,4X,47H 0: THE CATEGORY NUMBERS FOR ALL VARIABLES ARE , + 9HDIFFERENT/) 5400 FORMAT(47H THE UNIT NUMBER FOR OUTPUT OF OBJECT SCORES TO, +16X,I5/1H ,47HCARD, TAPE OR DISK (0: NO SUCH OUTPUT REQUIRED)// +58H THE UNIT NUMBER FOR OUTPUT OF CATEGORY QUANTIFICATIONS TO, + 5X,I5/1H ,47HCARD, TAPE OR DISK (0: NO SUCH OUTPUT REQUIRED)) 5301 FORMAT(49H COMPUTATION AND COMPLETE OUTPUT OF STANDARDIIZED , + 24HCATEGORY QUANTIFICATIONS/) 5302 FORMAT(//8H WARNING// + 59H YOU HAVE USED MORE THAN 30 COLUMNS OF THE SIZE OF PROBLEM , + 4HCARD/ + 58H THIS EVOKED SOME NON-STANDARD OPTIONS FOR TEST AND INSTAL, + 20HLATION PURPOSES ONLY/ + 56H EITHER CORRECT THE NUMBER OF PARAMETERS (MUST BE 6) OR , + 38HCORRECT THE USED FORMAT (MUST BE 6I5)//) 5303 FORMAT(17H THE PROGRAM USES,I3,1X,20HNON-ORTHOGONALIZING , +10HITERATIONS/) 5304 FORMAT(52H THE PROGRAM COMPUTES AN NDIM+1 DIMENSIONAL SOLUTION, +41H, NDIM DIMENSIONS ARE AVAILABLE ON OUTPUT/) 5305 FORMAT(52H YOU HAVE CHOSEN A NON STANDARD TREATMENT OF MISSING, + 5H DATA/) C RETURN END SUBROUTINE GRAM4M (DATAIN,DATAPV,ICATGO,MARFRE,MARFIN, + MAFRPV,MFPVIN,ACCUMU,OBSCOR, + CATSCO,STRESS,IPARTI,AUXILI, + NOBS,NVAR,NDIM,MAXC,ISUC, + INPU,IDAT,IWRI,IPLO,IOUT,MAXI,NONV,NOND, + MASQ,NVNV,NDSQ,NDND,ISND,NAUX,NACC, + NDAT,NIPA,EPSI,IJOB,NJOB,NPLV,NAME,ISTAN, + IPARM,ITUN,JDIM,METH) CCCC CCCC MISSING DATA ALLOWING MODIFIED CCCC GRAM-SCHMIDT ORTHOGONALIZATION DIMENSION NAME(20) DIMENSION IOUT(3) COMMON /LINOUT/ ICAR,IPRI DOUBLE PRECISION MARFIN,MFPVIN,ACCUMU,OBSCOR,CATSCO,STRESS DOUBLE PRECISION TOST, OLST, DIST ,STRM INTEGER DATAIN,DATAPV,PRODAT LOGICAL TUN DIMENSION DATAIN(NONV),DATAPV(NDAT),ICATGO(NVAR),MARFRE(ISUC), + MARFIN(ISUC),MAFRPV(NOBS),MFPVIN(NOBS), + ACCUMU(NOND),OBSCOR(NOND),CATSCO(ISND),STRESS(NDIM), + IPARTI(NIPA),AUXILI(NAUX) C CCCC C CCCC COMPUTATION OF MARGINAL FREQUENCIES ETC. CCCC QNVA=1./SQRT(FLOAT(NVAR)) NMAF=NOBS NORM=1 CALL PREPA4 (MARFRE,MARFIN,MAFRPV,MFPVIN,DATAIN, + ICATGO,AUXILI,FACT, + ISUC,NMAF,NONV,NVAR,NOBS,NORM,MAXC) SQVA= 1.0/ SQRT(FLOAT(NVAR)) CALL RANDMA (OBSCOR,NOND) N = 1 + 2 * NOBS CALL DIFMEA(OBSCOR,MAFRPV,NOBS,NDIM,NOND,FACT,METH) IF(METH.EQ.1)GOTO 10 KI=0 DO 9 IP=1,NDIM DO 9 K=1,NOBS KI=KI+1 9 OBSCOR(KI)=OBSCOR(KI)*MAFRPV(K) IF(METH.EQ.0)CALL MPR1(MFPVIN,OBSCOR,OBSCOR,NOBS,NDIM,NOND) 10 CALL MOGRAM(OBSCOR,NOBS,NDIM,NOND,NDSQ,NDND,ISND,ISUC,IPRI) IF(METH.EQ.0)CALL MPR1(MFPVIN,OBSCOR,OBSCOR,NOBS,NDIM,NOND) C READ(10,5010)(OBSCOR(L),L=1,NOND) C5010 FORMAT(5F15.12) C DO 959 I=1,NOND C OBSCOR(I)=OBSCOR(I)*SQVA C959 CONTINUE OLST = 0 NITR = 0 WRITE(IPRI,1300) CCCC CCCC START THE MAIN ITERATIVE PROCESS CCCC IF (ITUN.LT.1) ITUN=1 20 NITR = NITR + 1 CCCC CCCC START THE INNER ITERATIONS WITHOUT ORTHOGONALIZATION CCCC IF ITUN IS GREATER THAN 1 CCCC IK=0 IF(NITR.EQ.1)GOTO 102 100 IF(METH.EQ.0)CALL MPR1(MFPVIN,ACCUMU,ACCUMU,NOBS,NDIM,NOND) 102 IK=IK+1 TUN=.FALSE. IF (IK.GT.1) GOTO 31 TUN=.TRUE. DO 30 K=1,NDIM 30 STRESS(K) = 0.0D0 31 CONTINUE KNOB = -NOBS DO 40 IP=1,NDIM KNOB = KNOB +NOBS IF(METH.EQ.1) GOTO 45 DO 41 K=1,NOBS IF(NITR.GT.1)OBSCOR(K+KNOB)=ACCUMU(K+KNOB) 41 ACCUMU(K+KNOB)=0.0D0 GOTO 40 45 DO 42 K=1,NOBS IF(NITR.GT.1)OBSCOR(K+KNOB)=ACCUMU(K+KNOB) 42 ACCUMU(K+KNOB)=OBSCOR(K+KNOB)*DFLOAT(NVAR-MAFRPV(K)) 40 CONTINUE DO 50 K=1,ISND 50 CATSCO(K) = 0.0D0 CCCC CCCC START THE QUANTIFICATION OVER VARIABLES CCCC N = 1 L = 1 M = 1 DO 60 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) CALL PROING (DATAIN(N),CATSCO(L),ACCUMU,NOBS,NDIM, + KATJ,ICND,NOND,1,KATJ,3) IF(TUN.AND.METH.EQ.1) CALL AD(CATSCO(L),OBSCOR,KATJ,DATAIN(N), + AUXILI,NDSQ,NVAR,NOBS,ICND,NDIM,NOND,NONV,STRESS) IF(TUN.AND.METH.EQ.0)CALL ADDDIA(CATSCO(L),MARFRE(M),STRESS,KATJ + ,NDIM,ICND) L = L + ICND N = N + NOBS M = M + ICATGO(J) 60 CONTINUE C WRITE(6,5021)(ACCUMU(K)*SQRT(FLOAT(NVAR)),K=1,NOND) C5021 FORMAT(' Z ',5F15.10) CCCC CCCC TEST ON CONVERGENCE CCCC IF (IK.GT.1) GOTO 101 TOST = 0.0D0 DO 70 K=1,NDIM 70 TOST = TOST + STRESS(K)/DFLOAT(NVAR) DIST = DABS(TOST-OLST) OLST = TOST INITR=NITR-1 IF (DIST.LT.EPSI) GO TO 80 IF (NITR.EQ.MAXI) GO TO 90 101 CONTINUE CALL DIFMEA (ACCUMU,MAFRPV,NOBS,NDIM,NOND,FACT,METH) C WRITE(6,5022)(ACCUMU(K)*SQRT(FLOAT(NVAR)),K=1,NOND) C5022 FORMAT(' ZZ',5F15.10) IF(METH.EQ.0)CALL MPR1(MFPVIN,ACCUMU,ACCUMU,NOBS,NDIM,NOND) IF (IK.LT.ITUN) GOTO 100 WRITE (IPRI,1400) NITR,TOST,DIST CCCC CCCC START THE ORTHOGONALIZATION CCCC CALL MOGRAM (ACCUMU,NOBS,NDIM,NOND,NDSQ,NDND,ISND,ISUC,IPRI) GOTO 20 CCCC CCCC LEAVE THE ITERATION LOOP CCCC 80 WRITE (IPRI,1600) INITR GOTO 91 90 WRITE (IPRI,1500) DIST 91 CONTINUE CCCC CCCC ROTATION,SCALING AND DISCRIMINATION MEASURES CCCC NV1=NVAR+1 CALL ROTSCA(CATSCO,OBSCOR,MARFRE,AUXILI,ICATGO,STRESS, + DATAIN,MARFIN,ACCUMU,AUXILI(4*NVAR+5), + NDSQ,NDIM,ISND,ISUC,NVAR,NOND,NOBS,NONV,NAUX, + IPARM,NDAT,IPLO,JDIM,METH,NV1) CCCC I/O BLOCK CCCC CALL RES3 (DATAIN,DATAPV,ICATGO,MARFRE,OBSCOR,OBSCOR,CATSCO, + CATSCO,STRESS,AUXILI,IPARTI,NOBS,NVAR,NDIM, + NOND,ISUC,NPLV,NAME,NONV,NDAT,ISND,NIPA,NAUX,TOST, + IPRI,IWRI,IPLO,IOUT,2*NOND,2*ISND,ISTAN) 1300 FORMAT(1H1/////, + 1H ,15X,26H THE HISTORY OF ITERATIONS// + ,52H NUMBER OF TOTAL FIT DIFFERENCE BETWEEN TWO/ + 52H ITERATIONS CONSECUTIVE ITERATIONS//) 1400 FORMAT(1H ,I5,7X,2(F13.7)) 1500 FORMAT(//52H THE ITERATIVE PROCESS STOPS BECAUSE THE MAXIMUM NUM, + 48HBER OF ITERATIONS IS REACHED, THE TEST VALUE IS:,F10.7//) 1600 FORMAT(//53H THE ITERATIVE PROCESS STOPS BECAUSE THE CONVERGENCE , + 50HCRITERION IS REACHED, THE NUMBER OF ITERATIONS IS:,I4//) RETURN END SUBROUTINE HOMAG4 (MA,N) DIMENSION MA(N), FMT1(60) DIMENSION IOUT(3) COMMON /VARBLS/ NOBS,NVAR,NDIM,MAXC,ISUC, + INPU,IDAT,IWRI,IPLO,IOUT,MAXI,NONV,NOND, + MASQ,NVNV,NDSQ,NDND,ISND,NAUX,NACC, + NDAT,NIPA,EPSI,IJOB,NJOB,NPLV,NAME(20),ISTAN, + IPARM,ICAT,ITUN,JDIM,METH COMMON /LINOUT/ ICAR,IPRI DATA A,B /1H*,1H// C C COMPUTE POINTERS FOR ARRAY MA, INDICATING THE STARTING POINTS OF THE S 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 IK = 2*ISND + IJ IL = 2*NDIM + IK IM = NIPA + IL IN = NAUX + IM C NVR1 = NVAR + NPLV CCC C READ AND WRITE THE NUMBER OF CATEGORIES PER VARIABLE CCC 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 DO 67 I=1,NVR1 MA(IL-1+I) = 0 67 CONTINUE IF (IPLO.LE.1) GO TO 5 CCC CCC READ AND WRITE INFORMATION ABOUT WHAT TO PLOT, CCC AND CHECK WHETHER IT IS FEASIBLE CCC 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 CCC C READ AND WRITE INPUT FORMAT AND THE DATAMATRIX CCC READ (ICAR,1100) FMT1 WRITE (IPRI,1700) FMT1 NNNN = (NPLV+NVAR) * NOBS DO 16 I=1,NOBS 16 READ (INPU,FMT1) (MA(J),J=I,NNNN,NOBS) IF (INPU.NE.ICAR.AND.IJOB.LT.NJOB) REWIND INPU KNOB=MIN0(NOBS,10) IF (IDAT.EQ.1) KNOB=NOBS WRITE (IPRI,2300) KNOB 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,KNOB 25 WRITE (IPRI,3200) I,(MA(J),J=I,NONN,NOBS) 32 CONTINUE C C CHECK IF THE TOTAL NUMBER OF CATEGORIES IS NOT TOO SMALL C CHECK IF THE MAXIMUMNUMBER OF CATEGORIES IS NOT TOO SMALL 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 CALL MISTEL(MA(1),MA(IB),MA(IM),NOBS,NVAR,ISUC,METH,IMRANK) IF(NDIM.LE.IMRANK) GOTO 36 WRITE(IPRI,5100) IMRANK NOND=NOBS*IMRANK NDSQ=IMRANK*IMRANK NDND=(IMRANK*(IMRANK+1))/2 ISND=ISUC*IMRANK NDIM=MIN0(NDIM,IMRANK) 36 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 GRAM4M (MA(1),MA(IA),MA(IB),MA(IC),MA(ID),MA(IE),MA(IF), + MA(IH),MA(II),MA(IJ),MA(IK),MA(IL),MA(IM), + NOBS,NVAR,NDIM,MAXC,ISUC, + INPU,IDAT,IWRI,IPLO,IOUT,MAXI,NONV,NOND, + MASQ,NVNV,NDSQ,NDND,ISND,NAUX,NACC, + NDAT,NIPA,EPSI,IJOB,NJOB,NPLV,NAME,ISTAN, + IPARM,ITUN,JDIM,METH) C FORMATS 1000 FORMAT (16I5) 1100 FORMAT (20A4) 1200 FORMAT (80I1) 1300 FORMAT(1H1,/////, + 35H NUMBER OF CATEGORIES PER VARIABLE:/// + 1H ,12X,9HNUMBER OF,21X,9HNUMBER OF,21X,9HNUMBER OF,21X, + 9HNUMBER OF/31H VARIABLE CATEGORIES I , + 52HVARIABLE CATEGORIES I VARIABLE CATEGORIES, + 30H I VARIABLE CATEGORIES/1H ,115(1H-)/ + 1H ,25X,1HI,29X,1HI,29X,1HI) 1301 FORMAT (////47H THE NUMBER OF CATEGORIES FOR ALL VARIABLES IS:,I5) 1400 FORMAT (1H ,I5,5X,I8,7X,2HI ,I8,5X,I8,7X,2HI , + I8,5X,I8,7X,2HI ,I8,5X,I8) 1500 FORMAT (////47H THE FOLLOWING VARIABLES ARE VARIABLES TO LABLE, + 46H THE PLOT OF OBJECT SCORES, IF THEY ARE MARKED, + 13H WITH A STAR.,/25H IF MARKED WITH A SLASH, , + 48H THE CATEGORY QUANTIFICATIONS OF THOSE VARIABLES, + 13H ARE PLOTTED:/) 1600 FORMAT (1H ,I10,1X,2A1) 1700 FORMAT (////32H FORMAT TO READ THE DATAMATRIX: ,20A4/ + (1H ,40X,20A4)) 2300 FORMAT (8H0LIST OF ,I5,2X,23HROWS OF THE DATAMATRIX:/) 3000 FORMAT (1H ,5X,1H*/1H ,6X,13H* VARIABLES/1H ,7X,1H*/ + 1H ,8X,1H*/1H ,9X,2H* ,25I4) 3100 FORMAT (11H OBJECTS ,102A1) 3200 FORMAT (1H ,4X,I5,2H *,25I4/(1H ,10X,1H*,25I4)) 4000 FORMAT (46H0ERROR DETECTED: THE SPECIFIED TOTAL NUMBER OF, + 26H CATEGORIES IS NOT CORRECT/1H , + 12HIT SHOULD BE,I5,11H INSTEAD OF,I5) 4100 FORMAT (48H0ERROR DETECTED: THE SPECIFIED MAXIMUM NUMBER OF, + 26H CATEGORIES IS NOT CORRECT/1H , + 12HIT SHOULD BE,I5,11H INSTEAD OF,I5) 5000 FORMAT (45H0EXECUTION OF THE PROGRAM HAS BEEN TERMINATED) 5100 FORMAT(//51H0THE NUMBER OF DIMENSIONS IS DECREASED BECAUSE THE , + 41HMAXIMUM RANK OF THE DATAMATRIX IS SMALLER/ + 50H THAN THE NUMBER OF DIMENSIONS, THE NEW VALUE IS :,I4//) C 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 SUBROUTINE MOGRAM(A,N,NDIM,NOND,NDSQ,NDND,ISND,ISUC,IPRI) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C GRAM SCHMIDT ORTHOGONALIZATION OF MATRIX A C C IN CASE OF A SINGULAR MATRIX SEVERAL PARAMETERS C C ARE ADAPTED ACCORDING TO THE RANK IP OF A AND C C THE ORTHOGONAL SOLUTION IS STORED IN THE FIRST IP C C COLUMNS OF A. C C C C EEKE VAN DER BURG, NOVEMBER 1980 C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C DIMENSION A(N,NDIM) DOUBLE PRECISION A,SSQ,SSQDIN,CROSSP IP=NDIM DO 100 K=1,NDIM 10 SSQ=0.0D0 DO 20 I=1,N 20 SSQ=SSQ+A(I,K)*A(I,K) IF(SSQ.GT.1.0D-6) GOTO 30 C SSQ = APPROXIMATION OF THE EIGENVALUE IP=IP-1 IF(K.GT.IP) GOTO 120 C IF THE LAST COLUMN CORRESPONDS TO A ZERO EIGENVALUE JUMP DO 25 J=K,IP DO 25 I=1,N 25 A(I,J)=A(I,J+1) GOTO 10 30 SSQDIN=1.0D0/DSQRT(SSQ) DO 40 I=1,N 40 A(I,K)=A(I,K)*SSQDIN IF(K.EQ.IP) GOTO 120 K1=K+1 DO 70 L=K1,IP CROSSP=0.0D0 DO 50 I=1,N 50 CROSSP=CROSSP+A(I,K)*A(I,L) C UPDATE COLUMN K+1,..,IP DO 60 I=1,N 60 A(I,L)=A(I,L)-CROSSP*A(I,K) 70 CONTINUE IF(K.EQ.IP) GOTO 120 100 CONTINUE 120 IF(IP.EQ.NDIM) RETURN WRITE(IPRI,130) IP 130 FORMAT(1H+,50X,26HTHE RANK OF THE PROBLEM IS,I4) NOND=N*IP NDSQ=IP*IP NDND=(IP*(IP+1))/2 ISND=ISUC*IP NDIM=IP 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 MISTEL(DATAIN,ICATGO,IAUX,NOBS,NVAR,ISUC,METH,IMRANK) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C MISTEL COMPUTES THE MAXIMUM RANK OF THE PROBLEM C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC INTEGER DATAIN DIMENSION DATAIN(NOBS,NVAR),ICATGO(NVAR),IAUX(NVAR) C DO 10 J=1,NVAR IAUX(J)=0 DO 10 I=1,NOBS 10 IF(DATAIN(I,J).GT.ICATGO(J).OR.DATAIN(I,J).LE.0)IAUX(J)=IAUX(J)+1 MS=0 MO=0 DO 20 J=1,NVAR IF(IAUX(J).EQ.0) MO=MO+1 20 MS=MS+IAUX(J) C MS=TOTAL NUMBER OF MISSING OBJECTS C MO=NUMBER OF VARIABLES WITHOUT A MISSING SCORE C IF(METH.EQ.0)IMRANK=MIN0(NOBS-1,ISUC-MAX0(MO,1)) IF(METH.EQ.1)IMRANK=MIN0(NOBS-1,ISUC+MS-NVAR) C IMRANK=THE MAXIMUM RANK OF THE PROBLEM C NOND=NOBS*IMRANK NDSQ=IMRANK*IMRANK NDND=IMRANK*(IMRANK+1) ISND=ISUC*IMRANK 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 SUBROUTINE PRICAT(CATSCO,STANDA,MARFRE,IOUT,ICATGO, + ISND,MAND,ISUC,NVAR,NDIM,ISTAN,IWRI,NOBS) CCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCC CCC CCC THE ROUTINE COMPUTES STANDARDIZED CATEGORY QUANTIFICATIONS CCC CCC AND WRITES THEM AND THE OPTIMAL CATEGORY QUANTIFICATIONS CCC CCC TO ANY LOGICAL UNIT CCC CCC CCC CCC NO SUBROUTINES CALLED CCC CCC CCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCC DIMENSION CATSCO(ISND),STANDA(MAND),MARFRE(ISUC),IOUT(3), + ICATGO(NVAR) DOUBLE PRECISION CATSCO REAL STANDA INTEGER MARFRE,IOUT,ICATGO COMMON /LINOUT/ ICAR,IPRI CCC IOUB=IOUT(2) IOUC=IOUT(3) N=1 L=0 WRITE(IPRI,2501) DO 1 J=1,NVAR KATJ=ICATGO(J) ICND=KATJ*NDIM MISD=0 IF(IWRI.LT.2) GOTO 3 WRITE(IPRI,2500)J,(K,K=1,NDIM) WRITE(IPRI,2600) 3 CONTINUE DO 7 K=1,KATJ CCC CCC PRINT THE OPTIMAL CATEGORY QUANTIFICATIONS CCC IF (IWRI.GE.2) WRITE(IPRI,2700) K,MARFRE(N),(CATSCO(L+I), + I=K,ICND,KATJ) CCC CCC WRITE THE CATEGORY QUANTIFICATIONS TO UNIT IOUB CCC IF(IOUB.LE.0.OR.IOUB.EQ.IPRI) GOTO 5 WRITE(IOUB,3200) J,K,(CATSCO(L+I),I=K,ICND,KATJ) 5 CONTINUE MISD=MISD+MARFRE(N) N=N+1 7 CONTINUE CCC CCC COMPUTE THE STANDARDIZED CATEGORY QUANTIFICATIONS CCC IF(ISTAN.LE.0) GOTO 2 N=N-KATJ DO 8 K=1,KATJ IKJ=-KATJ DO 4 IP=1,NDIM IKJ=IKJ+KATJ STANDA(K+IKJ)=CATSCO(L+K+IKJ)* + SQRT(FLOAT(MARFRE(N))/FLOAT(NOBS-MARFRE(N))) 4 CONTINUE CCC CCC PRINT THE STANDARDIZED CATEGORY QUANTIFICATIONS CCC IF(K.EQ.1) WRITE(IPRI,2702) IF(IWRI.GE.2)WRITE(IPRI,2701)K,(STANDA(I),I=K,ICND,KATJ) CCC CCC WRITE THE STANDARDIZED CATEGORY QUANTIFICATIONS TO IOUC CCC IF(IOUC.LE.0.OR.IOUC.EQ.IPRI) GOTO 9 WRITE(IOUC,3200) J,K,(STANDA(I),I=K,ICND,KATJ) 9 CONTINUE N=N+1 8 CONTINUE 2 CONTINUE MISD=NOBS-MISD IF(IWRI.LT.2) GOTO 6 WRITE(IPRI,2800) MISD WRITE(IPRI,1000) 6 CONTINUE L=L+ICND 1 CONTINUE IF(IOUB.LE.0.OR.IOUB.EQ.IPRI) GOTO 100 WRITE(IPRI,3300) IOUB REWIND IOUB 100 CONTINUE IF(IOUC.LE.0.OR.IOUC.EQ.IPRI) GOTO 200 IF(ISTAN.NE.0)WRITE(IPRI,3301) IOUC REWIND IOUC 200 CONTINUE CCC CCC FORMAT LIST CCC 1000 FORMAT (1H ,130(1H-)) 2500 FORMAT (9H0VARIABLE,I4,3H ://1H ,11X,8HMARGINAL/ + 51H CATEGORY FREQUENCIES CATEGORY QUANTIFICATIONS/ + 51H -------- ----------- ------------------------// + 1H ,20X,10I10) 2501 FORMAT(///) 2600 FORMAT (1H ) 2700 FORMAT (1H ,I5,7X,I5,6X,10(F8.2,2X)) 2702 FORMAT(/1H ,26X,37HSTANDARDIZED CATEGORY QUANTIFICATIONS/ + 1H ,26X,37H------------ -------- ---------------/) 2701 FORMAT(1H ,I5,18X,10(F8.3,2X)) 2800 FORMAT (13H0 MISSING ,I5/) 3200 FORMAT (2I4,6F12.7/(8X,6F12.7)) 3300 FORMAT (49H0THE CATEGORY QUANTIFICATIONS WITH VARIABLE- AND , + 47HCATEGORY IDENTIFICATION ARE WRITTEN TO UNIT NR.,I2/ + 37H WITH FORMAT (2I4,6F12.7/(8X,6F12.7))) 3301 FORMAT (53H0THE STANDARDIZED CATEGORY QUANTIFICATIONS WITH VARIA, + 55HBLE AND CATEGORY IDENTIFICATION ARE WRITTEN TO UNIT NR.,I2/ + 37H WITH FORMAT (2I4,6F12.7/(8X,6F12.7)) C RETURN END 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) COMMON /LINOUT/ ICAR,IPRI DIMENSION CA(N1),MA(N2),Z(N4),D(N3),E(N3),IC(N5),OB(N6),DAT(NONV) 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 RETURN 400 WRITE(IPRI,500) 500 FORMAT(44H1NO CONVERGENCE OF EIGENVALUE ROUTINE IMTQL2, + /18H0NO ROTATION FOUND) STOP END SUBROUTINE ROTSCA(CATSCO,OBSCOR,MARFRE,AUXILI,ICATGO,DISMEA, + DATAIN,MARFIN,ACCUMU,INDEX, + NDSQ,NDIM,ISND,ISUC,NVAR,NOND,NOBS,NONV,NAUX, + IPARM,NDAT,IPLO,JDIM,METH,NV1) COMMON /LINOUT/ ICAR,IPRI C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCC C CCC THIS ROUTINE ROTATES THE FINAL SOLUTION TO ITS C CCC PRINCIPAL COMPONENTS,SCALES THE SOLUTION BY MUL- C CCC TIPLYING WITH SQRT (NOBS*NVAR) AND COMPUTES C CCC DISCRIMINATION MEASURES PER VARIABLE PER DIMENSION C CCC C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCC DIMENSION CATSCO(ISND),OBSCOR(NOND),MARFRE(ISUC),AUXILI(NAUX), + ICATGO(NVAR),DISMEA(NDIM),DATAIN(NONV),MARFIN(ISUC), + ACCUMU(NOND),INDEX(NV1) DOUBLE PRECISION CATSCO,OBSCOR,DISMEA,MARFIN,ACCUMU INTEGER DATAIN,ICATGO DATA A /1H*/ CCC NVND=NVAR*NDIM VVAR=NVAR VOBS=NOBS 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,METH) CCC CCCC CCCC PRINT THE EIGENVALUES CCCC NDSA=(NDIM)*(NDIM) IF ((ISUC-NVAR).GT.(NDIM-1)) IDIM=NDIM-1 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC IF(JDIM.EQ.0) IDIM=NDIM CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC DO 11 K=1,NDIM AUXILI(K+NDSA)=AUXILI(K+NDSA)/FLOAT(NVAR) 11 CONTINUE WRITE(IPRI,1004) (K,AUXILI(K+NDSA),K=1,NDIM) NDIM=IDIM ISND=ISUC*NDIM NOND=NDIM*NOBS DO 1 K=1,NDIM DISMEA(K)=0.0D0 1 CONTINUE DO 2 K=1,ISND CATSCO(K)=0.0D0 2 CONTINUE DO 3 K=1,NOND OBSCOR(K)=OBSCOR(K)*SQRT(FLOAT(NOBS)) 3 CONTINUE CCC IF (IPARM.LE.0) GOTO 4 CCC CCC PRINT THE DISCRIMINATION MEASURES CCC WRITE (IPRI,1000) WRITE (IPRI,1001) (L,L=1,NDIM) ND = 10 * NDIM + 1 WRITE (IPRI,1002) (A,I=1,ND) 4 CONTINUE CCC N=1 L=1 M=1 DO 5 J=1,NVAR KATJ=ICATGO(J) ICND=KATJ*NDIM 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) IF (IPARM.LE.0) GOTO 6 IF(METH.EQ.0) CALL ADDDIA(CATSCO(L),MARFRE(M),DISMEA,KATJ, + NDIM,ICND) IF(METH.EQ.1)CALL AD(CATSCO(L),OBSCOR,KATJ,DATAIN(N), + AUXILI(NVND+1),NDSQ,NVAR,NOBS,ICND,NDIM,NOND,NONV,DISMEA) DO 55 IP=1,NDIM DISMEA(IP)=DISMEA(IP)/FLOAT(NOBS) 55 CONTINUE WRITE(IPRI,1003) J,(DISMEA(K),K=1,NDIM) AUXILI(J)=DISMEA(1) IF(NDIM.GT.1)AUXILI(J+NVAR+1)=DISMEA(2) IF(NDIM.EQ.1)AUXILI(J+NVAR+1)=0.0 DO 7 IP=1,NDIM DISMEA(IP)=0.0D0 7 CONTINUE 6 CONTINUE L=L+ICND N=N+NOBS M=M+KATJ 5 CONTINUE C ORIGIN AUXILI(NVAR+1)=0.0 AUXILI(2*(NVAR+1))=0.0 CCC IF (IPARM.LE.0) RETURN CCCC PLOT THE FIRST TWO DIMENSIONS OF THE CCCC DISCRIMINATION MEASURES CCCC NN=NVAR+2 NNN=NN+NVAR+1 NNNN=NNN+NVAR+1 WRITE(IPRI,1005) DO 10 J=1,NV1 10 INDEX(J)=J CALL PLOTTO(AUXILI,AUXILI(NN),INDEX,AUXILI(NNN), + AUXILI(NNNN),NVAR+1,-1) CCC 1000 FORMAT(///51H DISCRIMINATION MEASURES PER VARIABLE PER DIMENSION/) 1001 FORMAT(1H ,8X,1H*/1H ,9X,13H* DIMENSION/1H ,10X,1H*/ + 1H ,11X,1H*/1H ,12X,1H*,I9,9I10) 1002 FORMAT(13H VARIABLES **,120A1) 1003 FORMAT(1H ,7X,I5,3H * ,10(F8.4,2X)) 1004 FORMAT (//27H0DIMENSION EIGENVALUE/ + 27H --------- ----------// + (1H ,I5,7X,F10.4)) 1005 FORMAT(1H1,40X,40H THE PLOT OF THE DISCRIMINATION MEASURES, + 16H ( * = ORIGIN )) CCC RETURN END SUBROUTINE RES3 (DATAIN,DATAPV,ICATGO,MARFRE,OBSCOR,ROCSBO, + CATSCO,OCSTAC,STRESS,AUXILI,IPARTI,NOBS,NVAR,NDIM, + NOND,ISUC,NPLV,NAME,NONV,NDAT,ISND,NIPA,NAUX,TOST, + IPRI,IWRI,IPLO,IOUT,NNNN,MMMM,ISTAN) DIMENSION DATAIN(NONV),DATAPV(NDAT),ICATGO(NVAR),MARFRE(ISUC), + OBSCOR(NOND),CATSCO(ISND),STRESS(NDIM),IPARTI(NIPA), + ROCSBO(NNNN),OCSTAC(MMMM),AUXILI(NAUX),NAME(20) DIMENSION IOUT(3) DOUBLE PRECISION OBSCOR,CATSCO,STRESS,TOST INTEGER DATAIN,DATAPV DATA A /1H*/ NPVS = NOBS NPND = NOND NDSA = (NDIM+1)*(NDIM+1) NDSQ = NDIM*NDIM CCC CCC CCC NVR1 = NVAR + NPLV IF (IWRI.EQ.0.OR.IWRI.GE.3) GOTO 119 CCC C PRINT OBJECT SCORES CCC WRITE (IPRI,1100) WRITE (IPRI,2000) (L,L=1,NDIM) ND = 10 * NDIM + 1 WRITE (IPRI,2200) (A,I=1,ND) DO 95 I=1,NPVS 95 WRITE (IPRI,2100) I,(OBSCOR(J),J=I,NPND,NPVS) CCC CCC PRINT OR/AND WRITE CATEGORY QUANTIFICATIONS CCC AND STANDARDIZED CATEGORY QUANTIFICATIONS CCC 119 CONTINUE IF (IWRI-2) 120,121,121 121 CONTINUE CALL PRICAT(CATSCO,AUXILI,MARFRE,IOUT,ICATGO,ISND,NAUX,ISUC,NVAR, + NDIM,ISTAN,IWRI,NOBS) 120 CONTINUE CCC C WRITE OBJECT SCORES TO UNIT IOUT(1) CCC IF (IOUT(1).LE.0.OR.IOUT(1).EQ.IPRI) GO TO 130 IOU = IOUT(1) DO 125 K=1,NPVS 125 WRITE (IOU ,3000) K,(OBSCOR(I),I=K,NPND,NPVS) WRITE (IPRI,3100) IOUT(1) REWIND IOU 130 CONTINUE IF (IPLO.EQ.0) RETURN CCC C REWRITE OBJECT SCORES AND CATEGORY QUANTIFICATIONS IN SINGLE PRECISION CCC DO 10 I=1,NPND 10 ROCSBO(I) = OBSCOR(I) DO 20 I=1,ISND 20 OCSTAC(I) = CATSCO(I) IF (NDIM.GT.1) GO TO 137 CCC C WHEN NUMBER OF DIMENSIONS EQUALS 1, DEFINE A SECOND DIMENSION TO BE 0 CCC 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 170 CCC C PLOT OBJECT SCORES, UNLABELED CCC WRITE (IPRI,1400) NAME CALL PLOTTO (ROCSBO,ROCSBO(N),AUXILI,AUXILI(N),AUXILI,NPVS,0) 132 CONTINUE CCC C PLOT OBJECT SCORES, LABELED BY THE VARIABLES WANTED CCC 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 IF (J.GT.NVAR) GOTO 141 CALL PLOTTO (ROCSBO,ROCSBO(N),DATAIN(M),AUXILI,AUXILI(N), + NOBS,1) GOTO 140 141 IP = 1 + (J-1-NVAR) * NOBS CALL PLOTTO (ROCSBO,ROCSBO(N),DATAPV(IP),AUXILI,AUXILI(N), + NOBS,1) 140 CONTINUE 170 CONTINUE N = 1 CCC C PLOT CATEGORY QUANTIFICATIONS OF THE VARIABLES WANTED CCC IN=0 IF(NDIM.EQ.1) GOTO 189 DO 200 J=1,NVAR KATJ = ICATGO(J) DO 185 I=1,KATJ 185 DATAIN(I) = I KK=2*KATJ IF (IPARTI(J).LE.1) GO TO 195 M = N + ICATGO(J) K = KATJ + 1 WRITE (IPRI,1700) J,NAME CALL PLOTTO (OCSTAC(N),OCSTAC(M),DATAIN,AUXILI,AUXILI(K), + KATJ,1) IF (ISTAN.NE.1) GOTO 195 DO 186 K=1,KATJ IK=K-1 NN=K+IN IKJ=-KATJ DO 187 IP=1,NDIM IKJ=IKJ+KATJ AUXILI(K+IKJ)=OCSTAC(N+IK+IKJ)*SQRT(FLOAT(MARFRE(NN) + )/FLOAT(NOBS-MARFRE(NN))) 187 CONTINUE 186 CONTINUE WRITE(IPRI,1701) J,NAME CALL PLOTTO(AUXILI,AUXILI(KATJ+1),DATAIN,AUXILI(KK+1), + AUXILI(KK+KATJ+1),KATJ,1) 195 N = N + ICATGO(J) * NDIM IN=IN+KATJ 200 CONTINUE 188 CONTINUE IJ = 0 IKAT = 0 DO 201 J=1,NVAR KATJ = ICATGO(J) IA = - ISUC DO 202 IP = 1,NDIM IA = IA + ISUC DO 203 IK = 1,KATJ IJ = IJ + 1 AUXILI(IA + IKAT +IK) = OCSTAC(IJ) MARFRE(IK + IKAT) = IK 203 CONTINUE 202 CONTINUE IKAT = IKAT + KATJ 201 CONTINUE DO 204 J = 1,ISND OCSTAC(J) = AUXILI(J) 204 CONTINUE WRITE(IPRI,1401) NAME ISUCI=ISUC+1 CALL PLOTTO(OCSTAC,OCSTAC(ISUCI),MARFRE,AUXILI,AUXILI(ISUCI), + ISUC,1) C 189 CONTINUE 1100 FORMAT (23H1THE OBJECT SCORES ARE://) 1400 FORMAT (25H1OBJECT SCORES, UNLABELED,22X,20A4) 1401 FORMAT (40H1CATEGORY QUANTIFICATIONS,LABELED BY ,9X,20A4/ + 30H THE ORIGINAL CATEGORY NUMBERS) 1450 FORMAT (26H1OBJECT SCORES, LABELED BY,20X,20A4/ + 9H VARIABLE,I5) 1700 FORMAT (30H1CATEGORY QUANTIFICATIONS VAR.,I5,14X,20A4) 1701 FORMAT (42H1STANDARDIZED CATEGORY QUANTIFICATIONS VAR,I5,14X,20A4) 2000 FORMAT (1H ,6X,1H*/1H ,7X,14H* DIMENSIONS/1H , 8X,1H*/ + 1H , 9X,1H*/1H ,10X,1H*,I9,9I10) 2100 FORMAT (1H ,5X,I5,3H * ,10F10.2) 2200 FORMAT (16H OBJECTS **,120A1) 3000 FORMAT (I5,6F12.7/(5X,6F12.7)) 3100 FORMAT (44H0THE OBJECT SCORES (WITH OBJECT-NUMBER) HAVE, + 25H BEEN WRITTEN TO UNIT NR.,I3,24H WITH FORMAT (I5,6F12.7/, + 12H(5X,6F12.7))) C RETURN END SUBROUTINE SSQ(OB,N,P,NP,IR) DIMENSION OB(NP) DOUBLE PRECISION OB,SQ INTEGER P,N,K,IR K=-N DO 1 IP=1,P K=K+N SQ=0.0D0 DO 2 I=1,N SQ=SQ+OB(I+K)*OB(I+K) 2 CONTINUE WRITE (6,1000) IP,SQ,IR 1 CONTINUE 1000 FORMAT (/1H ,28HTHE SSQ OF THETA FOR COLUMN ,I2,5H IS :,F12.6, + 5X,21HTHIS WAS CALL NUMBER ,I2/) 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