####################################################################### CC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCC readme : CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CC CC This file contains the complete code of six stand-alone Fortran CC programs for cluster analysis, described and illustrated in CC CC L. Kaufman and P.J. Rousseeuw (1990), FINDING GROUPS IN DATA: CC AN INTRODUCTION TO CLUSTER ANALYSIS, New York: John Wiley. CC CC The book contains data sets, included at the end of this file, CC and gives complete outputs for them which allow you to check the CC proper functioning of the programs. The chapters are largely CC self-contained. Each chapter of the book describes one specific CC clustering method and the corresponding program: CC CC Chapter 1 : DAISY.FOR (computes dissimilarities) CC Chapter 2 : PAM.FOR (partitions the data set into CC clusters with a new method using medoids) CC Chapter 3 : CLARA.FOR (for clustering large applications) CC Chapter 4 : FANNY.FOR (a new method for fuzzy clustering) CC Chapter 5+6 : TWINS.FOR (hierarchical clustering; you can CC choose between agglomerative and divisive) CC Chapter 7 : MONA.FOR (divisive hierachical clustering CC of binary data sets). CC CC The above clustering methods were selected/developed to have CC good robustness properties (they are based on sums of distances CC instead of sums of squared distances). The programs PAM, FANNY, CC and TWINS can be used on data which consists of measurements CC OR dissimilarities. CC CC This software may be used and copied freely, provided suitable CC reference is made to the corresponding book FINDING GROUPS IN CC DATA by L. Kaufman and P.J. Rousseeuw. CC CC For questions, problems or comments contact: CC CC Leonard Kaufman CC Dienst Medische Informatica CC Faculty of Medicine, V.U.B. CC Laarbeeklaan 103 CC B-1090 Brussels CC Belgium CC CC Peter J. Rousseeuw CC Department of Mathematics and Computing CC Universitaire Instelling Antwerpen CC Universiteitsplein 1 CC B-2610 Wilrijk (Antwerp) CC Belgium CC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCC file DAISY.FOR (Chapter 1) 42k CCCCCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC PROGRAM DAISY CC CC PROGRAM FOR CALCULATING DISSIMILARITIES BETWEEN OBJECTS CC OR VARIABLES CC CC LIST OF FUNCTIONS AND SUBROUTINES: CC SUBROUTINE QYN CC SUBROUTINE RANK CC SUBROUTINE TTWO CC SUBROUTINE ENTR CC CC THE FOLLOWING VECTORS AND MATRICES MUST BE DIMENSIONED IN THE CC MAIN PROGRAM : CC X(MAXNN,MAXPP),D(MAXNN),DVEC(MAXNN) CC JTMD(MAXPP),VALMD(MAXPP),NBLAV(MAXPP),JPLACE(MAXPP),HULP(MAXTT) CC CHARACTER VTYPE(MAXPP),JLAB(10,MAXPP) CC WHERE : CC MAXNN = MAXIMAL NUMBER OF OBJECTS CC MAXTT = MAXIMAL NUMBER OF VARIABLES IN THE DATA SET CC MAXPP = MAXIMAL NUMBER OF VARIABLES USED FOR THE CC CALCULATIONS CC DIMENSION X(100,50),D(100),DVEC(100) DIMENSION JTMD(50),VALMD(50),NBLAV(50),JPLACE(50),HULP(80) CHARACTER YNSAVE,JDAT,JCRL,VTYPE(50),JLAB(10,50) CHARACTER*30 FNAMEA,FNAMEB,FNAMEC,FNAMED CHARACTER*60 JFMT,NAME MAXNN=100 MAXTT=80 MAXPP=50 CC CC LOGICAL INPUT AND OUTPUT UNITS: CC LUA = LOGICAL UNIT A (INPUT) CC LUB = LOGICAL UNIT B (OUTPUT) CC LUC = LOGICAL UNIT C (OUTPUT OF DATA MATRIX) CC LUD = LOGICAL UNIT D (OUTPUT OF DISSIMILARITY MATRIX) CC THE USER SHOULD ASSIGN TO THESE UNITS THE NUMBERS USED BY HIS CC OWN COMPUTER: ONLY THE NEXT 4 STATEMENTS MUST BE CHANGED: CC LUA=1 LUB=2 LUC=3 LUD=4 CC CC VTYPE(J) IS THE TYPE OF VARIABLE J: CC = A FOR AN ASYMMETRIC BINARY VARIABLE CC = S FOR A SYMMETRIC BINARY VARIABLE CC = N FOR A NOMINAL VARIABLE CC = O FOR AN ORDINAL VARIABLE CC = I FOR AN INTERVAL VARIABLE (ADDITIVE) CC = T FOR A RATIO VARIABLE CC CC VECTOR JTMD IS ONLY READ IF THERE ARE MISSING VALUES CC JTMD(J) = 0 IF VARIABLE J IS BINARY CC =-1 IF VARIABLE J IS NOT BINARY AND HAS MISSING VALUES CC =+1 IF VARIABLE J IS NOT BINARY AND HAS NO MISSING VALUES CC CALL ENTR(NN,JPP,MAXNN,MAXTT,MAXPP,X,DVEC,VALMD,JTMD, F JPLACE,HULP,LUA,LUB,LUC,LUD,FNAMEA,FNAMEB,FNAMEC,FNAMED, F JLAB,NAME,YNSAVE,NFF,JFMT,MDATA,JDAT,JCRL,VTYPE,JTELB) IF(JDAT.EQ.'3'.OR.JDAT.EQ.'4')GO TO 500 CC CC ANALYSIS OF MISSING DATA CC IF(JTELB.EQ.0.AND.MDATA.EQ.0)GO TO 200 WRITE(LUB,9070) CC CC INSPECTION OF OBJECTS CC JHALT=0 DO 108 L=1,NN NBE=0 DO 106 J=1,JPP IF(JTMD(J).EQ.0)GO TO 104 IF(MDATA.EQ.0.OR.JTMD(J).GE.1)GO TO 106 IF(X(L,J).EQ.VALMD(J))NBE=NBE+1 GO TO 106 104 IF(X(L,J).NE.0..AND.X(L,J).NE.1.)NBE=NBE+1 106 CONTINUE IF(NBE.LT.JPP)GO TO 108 JHALT=1 WRITE(LUB,9080)L 108 CONTINUE IF(JHALT.EQ.1)STOP CC CC INSPECTION OF VARIABLES CC NBLAT=0 JHALT=0 DO 160 J=1,JPP NBLAV(J)=0 IF(JTMD(J).EQ.0)GO TO 130 IF(MDATA.EQ.0.OR.JTMD(J).GE.1)GO TO 160 DO 110 L=1,NN IF(X(L,J).EQ.VALMD(J))NBLAV(J)=NBLAV(J)+1 110 CONTINUE GO TO 150 130 DO 140 L=1,NN IF(X(L,J).NE.0..AND.X(L,J).NE.1.)NBLAV(J)=NBLAV(J)+1 140 CONTINUE 150 NBLAT=NBLAT+NBLAV(J) IF(NBLAV(J).EQ.0)WRITE(LUB,9090)(JLAB(K,J),K=1,10) IF(NBLAV(J).EQ.1)WRITE(LUB,9095)(JLAB(K,J),K=1,10) IF(NBLAV(J).GT.1)WRITE(LUB,9100)(JLAB(K,J),K=1,10),NBLAV(J) IF(NBLAV(J).LT.(NN-2))GO TO 160 WRITE(LUB,9110)(JLAB(K,J),K=1,10) IF(NFF.EQ.0)WRITE(LUB,9115) JHALT=1 160 CONTINUE WRITE(LUB,9120)NBLAT IF(JHALT.EQ.1)STOP CC CC THE VALUES TAKEN BY ORDINAL VARIABLES ARE REPLACED BY THEIR RANKS. CC FOR NOMINAL VARIABLES, SUBROUTINE 'RANK' IS USED TO DETERMINE HOW CC MANY VALUES THEY TAKE. CC 200 IF(JDAT.EQ.'2')CALL TTWO(NN,JPP,MAXNN,MAXPP,MDATA,JCRL,HULP, F X,VALMD,JTMD,LUB,LUD,FNAMEB,FNAMED,JLAB) WRITE(LUB,9130) JHALT=0 DO 320 J=1,JPP IF(VTYPE(J).EQ.'A'.OR.VTYPE(J).EQ.'S')GO TO 310 IF(VTYPE(J).EQ.'I'.OR.VTYPE(J).EQ.'T')GO TO 210 PRNN=NN IF(JTMD(J).LT.0)PRNN=NN-NBLAV(J) CALL RANK(NN,J,MAXNN,MAXPP,X,JTMD,VALMD,PRNN,ALMR) DADA=1. DADZ=ALMR NLMR=ALMR IF(VTYPE(J).EQ.'N')WRITE(LUB,9140)(JLAB(K,J),K=1,10),NLMR IF(VTYPE(J).EQ.'O')WRITE(LUB,9150)(JLAB(K,J),K=1,10),NLMR GO TO 270 210 IF(VTYPE(J).EQ.'I')WRITE(LUB,9160)(JLAB(K,J),K=1,10) IF(VTYPE(J).EQ.'T')WRITE(LUB,9170)(JLAB(K,J),K=1,10) DADA=X(1,J) DADZ=X(1,J) IF(JTMD(J).GE.0)GO TO 250 DO 220 L=1,NN IF(X(L,J).EQ.VALMD(J))GO TO 220 DADA=X(L,J) DADZ=X(L,J) GO TO 230 220 CONTINUE 230 DO 240 L=2,NN IF(X(L,J).EQ.VALMD(J))GO TO 240 IF(X(L,J).LT.DADA)DADA=X(L,J) IF(X(L,J).GT.DADZ)DADZ=X(L,J) 240 CONTINUE GO TO 270 250 DO 260 L=2,NN IF(X(L,J).LT.DADA)DADA=X(L,J) IF(X(L,J).GT.DADZ)DADZ=X(L,J) 260 CONTINUE 270 STAM=DADZ-DADA IF(STAM.LE.0.)GO TO 300 DO 290 L=1,NN IF(JTMD(J).GT.0)GO TO 280 IF(X(L,J).NE.VALMD(J))GO TO 280 X(L,J)=99.99 GO TO 290 280 X(L,J)=(X(L,J)-DADA)/STAM 290 CONTINUE IF(JTMD(J).LT.0)VALMD(J)=99.99 GO TO 320 300 JHALT=1 WRITE(LUB,9180)(JLAB(K,J),K=1,10) WRITE(LUB,9190) WRITE(LUB,9115) GO TO 320 310 IF(VTYPE(J).EQ.'S')WRITE(LUB,9172)(JLAB(K,J),K=1,10) IF(VTYPE(J).EQ.'A')WRITE(LUB,9174)(JLAB(K,J),K=1,10) 320 CONTINUE IF(JHALT.EQ.1)STOP IF(JDAT.EQ.'2')GO TO 500 CC CC CALCULATION OF THE DISSIMILARITIES CC 400 JHALT=0 NBAD=0 DO 450 L=2,NN LA=L-1 DO 440 K=1,LA PPA=0. DLK=0. DO 420 J=1,JPP IF(VTYPE(J).EQ.'A'.OR.VTYPE(J).EQ.'S')GO TO 410 IF(JTMD(J).GE.0)GO TO 405 IF(X(L,J).EQ.VALMD(J))GO TO 420 IF(X(K,J).EQ.VALMD(J))GO TO 420 405 PPA=PPA+1. IF(VTYPE(J).EQ.'N'.AND.X(L,J).NE.X(K,J))DLK=DLK+1. IF(VTYPE(J).EQ.'A'.OR.VTYPE(J).EQ.'S'.OR.VTYPE(J).EQ.'N') F GO TO 420 DLK=DLK+ABS(X(L,J)-X(K,J)) GO TO 420 410 IF(X(L,J).NE.0..AND.X(L,J).NE.1.)GO TO 420 IF(X(K,J).NE.0..AND.X(K,J).NE.1.)GO TO 420 IF(VTYPE(J).EQ.'S'.OR.X(L,J).NE.0.OR.X(K,J).NE.0)PPA=PPA+1. IF(X(L,J).NE.X(K,J))DLK=DLK+1. 420 CONTINUE IF(PPA.GT.0.5)GO TO 430 NBAD=NBAD+1 WRITE(LUB,9200)K,L D(K)=1/2. GO TO 440 430 D(K)=DLK/PPA 440 CONTINUE WRITE(LUD,9210)(D(K),K=1,LA) 450 CONTINUE IF(NBAD.LE.0)GO TO 500 WRITE(LUB,9220)NBAD WRITE(LUB,9230) 500 WRITE(*,9300) IF(YNSAVE.EQ.'Y'.AND.FNAMEB.EQ.'CON')WRITE(*,9310)FNAMEC WRITE(*,9320)FNAMED IF(FNAMEB.NE.'CON')WRITE(LUB,9320)FNAMED IF(FNAMEB.NE.'CON'.AND.FNAMEB.NE.'PRN')WRITE(*,9330)FNAMEB IF(FNAMEB.EQ.'PRN')WRITE(*,9325) IF(FNAMEB.NE.'CON'.AND.FNAMEB.NE.'PRN')WRITE(LUB,9330)FNAMEB 8000 FORMAT(60A1) 8010 FORMAT(3I4) 8020 FORMAT(30I2) 9070 FORMAT(//1X,25H ANALYSIS OF MISSING DATA/1X,1X,24(1H-)) 9080 FORMAT(1X,21H PLEASE DELETE OBJECT,I5, F30H , ALL ITS VALUES ARE MISSING.) 9090 FORMAT(2X,'VARIABLE ',10A1,' HAS NO MISSING VALUES') 9095 FORMAT(2X,'VARIABLE ',10A1,' HAS ONE MISSING VALUE') 9100 FORMAT(2X,'VARIABLE ',10A1,' HAS ',I3,' MISSING VALUES') 9110 FORMAT(2X,'VARIABLE ',10A1,' HAS LESS THAN THREE MEASURED VAL' F'UES.'/2X,'PLEASE REMOVE IT BEFORE RESTARTING THE PROGRAM.') 9115 FORMAT(1X,44H (THIS CAN BE DONE BY CHANGING THE NUMBER OF, F33H VARIABLES AND THE INPUT FORMAT.)/) 9120 FORMAT(//1X,39H THE TOTAL NUMBER OF MISSING VALUES IS ,I6//) 9130 FORMAT(//2X,'SUMMARY OF THE VARIABLES'/ F2X,24('-')) 9140 FORMAT(2X,'Variable ',10A1,' is nominal. It takes',I4, F ' different values.') 9150 FORMAT(2X,'Variable ',10A1,' is ordinal. Its maximal' F ' rank is ',I5,'.') 9160 FORMAT(2X,'Variable ',10A1,' is interval.') 9170 FORMAT(2X,'Variable ',10A1,' is ratio.') 9172 FORMAT(2X,'Variable ',10A1,' is symmetric binary.') 9174 FORMAT(2X,'Variable ',10A1,' is asymmetric binary.') 9180 FORMAT(/1X,' ALL NONMISSING VALUES OF VARIABLE ',10A1, F ' ARE THE SAME.') 9190 FORMAT(1X,48H PLEASE REMOVE THIS VARIABLE AND USE THE PROGRAM, F7H AGAIN.) 9200 FORMAT(1X,'No dissimilarity can be computed between objects' F ,I4,' and',I4) 9210 FORMAT(1X,8F9.3) 9220 FORMAT(1X,' This has occured',I5,' times.'//) 9230 FORMAT(1X,'In each case the dissimilarity was set equal' F ' to 1/2.') 9300 FORMAT(//1X,'This run has been successfully completed') 9310 FORMAT(/1X,'Your data is on file : ',A30) 9320 FORMAT(/1X,'The dissimilarity matrix is on file : ',A30) 9325 FORMAT(/1X,'The remaining output was sent to the printer') 9330 FORMAT(/1X,'The remaining output is on file : ',A30) END CC CC SUBROUTINE QYN(YN,NYN) CHARACTER*1 YN 10 READ(*,8000)YN IF(YN.EQ.'y')YN='Y' IF(YN.EQ.'n')YN='N' IF(YN.EQ.'Y')NYN=1 IF(YN.EQ.'N')NYN=0 IF(YN.EQ.'Y'.OR.YN.EQ.'N')GO TO 20 WRITE(*,9000) GO TO 10 20 RETURN 8000 FORMAT(A1) 9000 FORMAT(2X,'NOT ALLOWED ! PLEASE ENTER YOUR CHOICE AGAIN: '$) END CC CC SUBROUTINE RANK(NN,J,MAXNN,MAXPP,X,JTMD,VALMD,PRNN,ALMR) CC CC THE DATA ARE REPLACED BY THEIR RANKS USING A SEARCH OF THE CC SMALLEST, SECOND SMALLEST, THIRD SMALLEST ..... VALUES. CC IN THIS WAY IT IS NOT NECESSARY TO STORE A VECTOR CONTAINING CC THE SORTED VALUES. CC MISSING DATA ARE GIVEN A VALUE OF -1. CC DIMENSION X(MAXNN,MAXPP),JTMD(MAXPP),VALMD(MAXPP) RNN=NN DADA=X(1,J) DADZ=X(1,J) IF(JTMD(J).GE.0)GO TO 20 DO 10 L=1,NN IF(X(L,J).EQ.VALMD(J))GO TO 10 DADA=X(L,J) DADZ=X(L,J) GO TO 20 10 CONTINUE 20 IF(JTMD(J).GE.0)GO TO 40 DO 30 L=2,NN IF(X(L,J).EQ.VALMD(J))GO TO 30 IF(X(L,J).LT.DADA)DADA=X(L,J) IF(X(L,J).GT.DADZ)DADZ=X(L,J) 30 CONTINUE GO TO 60 40 DO 50 L=2,NN IF(X(L,J).LT.DADA)DADA=X(L,J) IF(X(L,J).GT.DADZ)DADZ=X(L,J) 50 CONTINUE 60 GREAT=RNN+5. IF(DADA.LT.0.)GREAT=RNN-DADA+5. IF(JTMD(J).GE.0)GO TO 90 DO 80 L=1,NN IF(X(L,J).EQ.VALMD(J))GO TO 70 X(L,J)=X(L,J)+GREAT GO TO 80 70 X(L,J)=-1. 80 CONTINUE GO TO 110 90 DO 100 L=1,NN X(L,J)=X(L,J)+GREAT 100 CONTINUE 110 DADZ=DADZ+GREAT VALMD(J)=-1. ALMR=0. NTEL=0 120 DADB=DADZ DO 130 L=1,NN IF(X(L,J).LT.(ALMR+0.5))GO TO 130 IF(X(L,J).LT.DADB)DADB=X(L,J) 130 CONTINUE DO 150 L=1,NN IF(X(L,J).NE.DADB)GO TO 150 NTEL=NTEL+1 X(L,J)=ALMR 150 CONTINUE ALMR=ALMR+1. IF(NTEL.LT.PRNN)GO TO 120 RETURN END CC CC SUBROUTINE TTWO(NN,JPP,MAXNN,MAXPP,MDATA,JCRL,HULP, F X,VALMD,JTMD,LUB,LUD,FNAMEB,FNAMED,JLAB) CC CC CALCULATION OF CORRELATION COEFFICIENTS BETWEEN VARIABLES, CC AND CONVERSION INTO DISSIMILARITIES. CC DIMENSION X(MAXNN,MAXPP),VALMD(MAXPP),JTMD(MAXPP),HULP(MAXPP) CHARACTER*1 JLAB(10,MAXPP),JCRL CHARACTER*30 FNAMEB,FNAMED JHALT=0 JPPM=JPP-1 WRITE(LUB,9050) DO 230 J=2,JPP JM=J-1 IF(MDATA.EQ.1)GO TO 100 DO 80 JJ=1,JM CC CC CORRELATION BETWEEN VARIABLES J EN JJ CC NMES=0 GJ=0. GJJ=0. GJK=0. GJJK=0. GJJJ=0. DO 50 L=1,NN GJ=GJ+X(L,J) GJJ=GJJ+X(L,JJ) 50 CONTINUE GJ=GJ/NN GJJ=GJJ/NN DO 60 L=1,NN GJK=GJK+(X(L,J)-GJ)*(X(L,J)-GJ) GJJK=GJJK+(X(L,JJ)-GJJ)*(X(L,JJ)-GJJ) GJJJ=GJJJ+(X(L,J)-GJ)*(X(L,JJ)-GJJ) 60 CONTINUE IF(GJK.NE.0..AND.GJJK.NE.0.)GO TO 70 HULP(JJ)=0. IF(GJK.EQ.0.)NMES=1 GO TO 80 70 GJK=SQRT(GJK) GJJK=SQRT(GJJK) HULP(JJ)=GJJJ/GJK/GJJK 80 CONTINUE IF(NMES.EQ.1)WRITE(LUB,9000)(JLAB(K,J),K=1,10) GO TO 200 100 DO 160 JJ=1,JM GJ=0. GJJ=0. GJK=0. GJJK=0. GJJJ=0. GKV=0. DO 110 L=1,NN IF(JTMD(J).GT.0.AND.X(L,J).EQ.VALMD(J))GO TO 110 IF(JTMD(JJ).GT.0.AND.X(L,JJ).EQ.VALMD(JJ))GO TO 110 GKV=GKV+1. GJ=GJ+X(L,J) GJJ=GJJ+X(L,JJ) 110 CONTINUE IF(GKV.GT.1.5)GO TO 120 HULP(JJ)=0. IF(GKV.EQ.0.)WRITE(LUB,9010)(JLAB(K,J),K=1,10), F (JLAB(K,JJ),K=1,10) IF(GKV.EQ.1.)WRITE(LUB,9020)(JLAB(K,J),K=1,10), F (JLAB(K,JJ),K=1,10) GO TO 160 120 GJ=GJ/GKV GJJ=GJJ/GKV DO 140 L=1,NN IF(JTMD(J).GT.0..AND.X(L,J).EQ.VALMD(J))GO TO 140 IF(JTMD(JJ).GT.0..AND.X(L,JJ).EQ.VALMD(JJ))GO TO 140 GJK=GJK+(X(L,J)-GJ)*(X(L,J)-GJ) GJJK=GJJK+(X(L,JJ)-GJJ)*(X(L,JJ)-GJJ) GJJJ=GJJJ+(X(L,J)-GJ)*(X(L,JJ)-GJJ) 140 CONTINUE IF(GJK.NE.0..AND.GJJK.NE.0.)GO TO 150 HULP(JJ)=0. IF(GJK.EQ.0..AND.GJJK.NE.0.)WRITE(LUB,9030)(JLAB(K,J),K=1,10), F (JLAB(K,JJ),K=1,10) IF(GJK.NE.0..AND.GJJK.EQ.0.)WRITE(LUB,9030)(JLAB(K,JJ),K=1,10) F ,(JLAB(K,J),K=1,10) IF(GJK.EQ.0..AND.GJJK.EQ.0.)WRITE(LUB,9040)(JLAB(K,J),K=1,10), F (JLAB(K,JJ),K=1,10) GO TO 160 150 GJK=SQRT(GJK) GJJK=SQRT(GJJK) HULP(JJ)=GJJJ/GJK/GJJK 160 CONTINUE 200 WRITE(LUB,9060)(HULP(JJ),JJ=1,JM) DO 220 JJ=1,JM IF(HULP(JJ).GT.1.)HULP(JJ)=1. IF(HULP(JJ).LT.-1.)HULP(JJ)=-1. IF(JCRL.EQ.'1')HULP(JJ)=(1.-HULP(JJ))/2. IF(JCRL.EQ.'2'.AND.HULP(JJ).GE.0.)HULP(JJ)=1.-HULP(JJ) IF(JCRL.EQ.'2'.AND.HULP(JJ).LT.0.)HULP(JJ)=1.+HULP(JJ) 220 CONTINUE WRITE(LUD,9060)(HULP(JJ),JJ=1,JM) 230 CONTINUE RETURN 9000 FORMAT(' Variable ',10A1,' has zero variance. Its correlation' F /' with all other variables has been set equal to 0.') 9010 FORMAT(' Variables ',10A1,' and ',10A1,' have no common' F ' measurements.'/' Their correlation coefficient has been' F ' set equal to 0.') 9020 FORMAT(' Variables ',10A1,' and ',10A1,' have one common' F ' measurement.'/' Their correlation coefficient has been' F ' set equal to 0.') 9030 FORMAT(' The measurements of variable ',10A1,' which are' F ' common with'/' variable ',10A1,' have zero variance.' F ' For this reason their'/' correlation has been set equal' F ' to 0.') 9040 FORMAT(' The common measurements of variables ',10A1,' and ', F 10A1/' have zero variance for both variables. Their' F ' correlation has been set'/' equal to 0.') 9050 FORMAT(' CORRELATION MATRIX'/1X,18('*')/) 9060 FORMAT(1X,8F9.3) END CC CC SUBROUTINE ENTR(NN,JPP,MAXNN,MAXTT,MAXPP,X,DVEC,VALMD,JTMD, F JPLACE,HULP,LUA,LUB,LUC,LUD,FNAMEA,FNAMEB,FNAMEC,FNAMED, F JLAB,NAME,YNSAVE,NFF,JFMT,MDATA,JDAT,JCRL,VTYPE,JTELB) DIMENSION X(MAXNN,MAXPP),DVEC(MAXNN) DIMENSION VALMD(MAXPP),JTMD(MAXPP),JPLACE(MAXPP),HULP(MAXTT) CHARACTER CYNFF,YNSAVE,CMDT,CDATA,CYNK,CEX,JLAB(10,MAXPP) CHARACTER JDAT,JCRL,VTYPE(MAXPP) CHARACTER*30 FNAMEA,FNAMEB,FNAMEC,FNAMED CHARACTER*60 JFMT,NAME JTELB=0 WRITE(*,9500) WRITE(*,9505) WRITE(*,8350) 100 WRITE(*,9510) WRITE(*,9515) 110 READ(*,8500)JDAT IF(JDAT.EQ.'1'.OR.JDAT.EQ.'2'.OR.JDAT.EQ.'3'.OR.JDAT.EQ.'4') F GO TO 120 WRITE(*,9520) GO TO 100 120 IF(JDAT.EQ.'1')GO TO 160 IF(JDAT.EQ.'4')WRITE(*,9521) IF(JDAT.EQ.'2'.OR.JDAT.EQ.'3')WRITE(*,9522) WRITE(*,9515) 130 READ(*,8500)JCRL IF(JCRL.EQ.'1'.OR.JCRL.EQ.'2')GO TO 140 WRITE(*,9520) GO TO 130 140 IF(JDAT.NE.'3')GO TO 160 150 WRITE(*,9523)MAXPP WRITE(*,9524)MAXPP READ(*,*)JPP IF(JPP.GE.3.AND.JPP.LE.MAXPP)GO TO 500 WRITE(*,9520) GO TO 150 160 WRITE (*,9525)MAXNN 170 WRITE (*,9530)MAXNN READ (*,*) NN IF(NN.LE.MAXNN)GO TO 180 WRITE(*,9520) GO TO 170 180 IF(NN.GE.3)GO TO 190 WRITE(*,9540) GO TO 170 190 IF(JDAT.EQ.'4')GO TO 500 CC CC IN THIS SECTION SPECIFIC INFORMATION RELATED TO THE INPUT CC OF MEASUREMENTS IS ENTERED : CC TOTAL NUMBER OF VARIABLES (JPPT) CC NUMBER OF VARIABLES TO BE USED IN THE ANALYSIS (JPP) CC VARIABLES TO BE USED IN THE ANALYSIS, AND THEIR LABELS. CC WRITE(*,9620)MAXTT,MAXPP 300 WRITE(*,9630)MAXTT READ(*,*)JPPT IF(JPPT.NE.1)GO TO 310 JPP=1 GO TO 340 310 IF(JPPT.GE.1.AND.JPPT.LE.MAXTT)GO TO 320 WRITE(*,9520) GO TO 300 320 JPPA=MAXPP IF(JPPA.GT.JPPT)JPPA=JPPT 330 WRITE(*,9640)JPPA READ(*,*)JPP IF(JPP.GE.1.AND.JPP.LE.JPPA)GO TO 340 WRITE(*,9520) GO TO 330 340 IF(JDAT.EQ.'1')WRITE(*,9645) IF(JDAT.EQ.'2')WRITE(*,9646) IF(JPPT.GT.JPP)GO TO 370 350 WRITE(*,9650) DO 360 J=1,JPP JPLACE(J)=J 352 WRITE(*,9660)J READ(*,8510)(JLAB(K,J),K=1,10),VTYPE(J) IF(VTYPE(J).EQ.'i'.OR.VTYPE(J).EQ.'1')VTYPE(J)='I' IF(VTYPE(J).EQ.'t')VTYPE(J)='T' IF(JDAT.EQ.'1')GO TO 354 IF(VTYPE(J).EQ.'I'.OR.VTYPE(J).EQ.'T')GO TO 360 GO TO 358 354 IF(VTYPE(J).EQ.'a')VTYPE(J)='A' IF(VTYPE(J).EQ.'s')VTYPE(J)='S' IF(VTYPE(J).EQ.'n')VTYPE(J)='N' IF(VTYPE(J).EQ.'o'.OR.VTYPE(J).EQ.'0')VTYPE(J)='O' IF(VTYPE(J).EQ.'A'.OR.VTYPE(J).EQ.'S'.OR.VTYPE(J).EQ.'N'. F OR.VTYPE(J).EQ.'O'.OR.VTYPE(J).EQ.'I'.OR.VTYPE(J).EQ.'T') F GO TO 360 358 WRITE(*,9665) GO TO 352 360 CONTINUE GO TO 430 370 WRITE(*,9670) DO 400 J=1,JPP 380 WRITE(*,9680)J READ(*,8520)JPLACE(J),(JLAB(K,J),K=1,10),VTYPE(J) IF(JPLACE(J).GE.1.AND.JPLACE(J).LE.JPPT)GO TO 385 WRITE(*,9685) GO TO 380 385 IF(J.EQ.1)GO TO 392 JPPL=J-1 DO 390 JK=1,JPPL IF(JPLACE(JK).NE.JPLACE(J))GO TO 390 WRITE(*,9690) GO TO 380 390 CONTINUE 392 IF(VTYPE(J).EQ.'i'.OR.VTYPE(J).EQ.'1')VTYPE(J)='I' IF(VTYPE(J).EQ.'t')VTYPE(J)='T' IF(JDAT.EQ.'1')GO TO 394 IF(VTYPE(J).EQ.'I'.OR.VTYPE(J).EQ.'T')GO TO 400 GO TO 398 394 IF(VTYPE(J).EQ.'a')VTYPE(J)='A' IF(VTYPE(J).EQ.'s')VTYPE(J)='S' IF(VTYPE(J).EQ.'n')VTYPE(J)='N' IF(VTYPE(J).EQ.'o'.OR.VTYPE(J).EQ.'0')VTYPE(J)='O' IF(VTYPE(J).EQ.'A'.OR.VTYPE(J).EQ.'S'.OR.VTYPE(J).EQ.'N'. F OR.VTYPE(J).EQ.'O'.OR.VTYPE(J).EQ.'I'.OR.VTYPE(J).EQ.'T') F GO TO 400 398 WRITE(*,9665) GO TO 380 400 CONTINUE 430 DO 440 J=1,JPP IF(VTYPE(J).EQ.'A')JTELB=JTELB+1 IF(VTYPE(J).EQ.'S')JTELB=JTELB+1 440 CONTINUE CC CC OUTPUT SECTION : CC TITLE CC 500 WRITE (*,9720) READ (*,8530)NAME CC CC FORMATS CC 550 WRITE (*,9780) CALL QYN(CYNFF,NFF) IF (CYNFF.EQ.'Y') GOTO 600 WRITE(*,9790) READ (*,8530)JFMT CC CC STATUS OF INPUT AND OUTPUT: KEYBOARD, SCREEN, PRINTER, FILE CC 600 WRITE(*,9800) READ(*,8550)FNAMEA IF(FNAMEA.EQ.'KEY'.OR.FNAMEA.EQ.'key'.OR.FNAMEA.EQ.'Key') F GO TO 610 YNSAVE='N' NSAVE=0 GO TO 620 610 FNAMEA='CON' WRITE(*,9810) CALL QYN(YNSAVE,NSAVE) IF (YNSAVE.EQ.'N')GO TO 620 614 WRITE(*,9820) READ(*,8550)FNAMEC OPEN(LUC,FILE=FNAMEC,STATUS='NEW',IOSTAT=NEG,ERR=615) GO TO 620 615 IF(NEG.NE.1027.AND.NEG.NE.1030.AND.NEG.NE.1032. F AND.NEG.NE.1033.AND.NEG.NE.1045)GO TO 616 WRITE(*,9833) GO TO 614 616 WRITE(*,9834)NEG STOP 620 OPEN(LUA,FILE=FNAMEA,IOSTAT=NER,ERR=630) GOTO 640 630 IF(FNAMEA.NE.'CON'.AND.(NER.EQ.1027.OR.NER.EQ.1030. F OR.NER.EQ.1032.OR.NER.EQ.1033))THEN WRITE(*,9832) GOTO 600 ENDIF WRITE(*,9834)NER STOP 640 WRITE(*,9825) READ(*,8550)FNAMED OPEN(LUD,FILE=FNAMED,STATUS='NEW',IOSTAT=NES,ERR=642) GO TO 645 642 IF(NES.NE.1027.AND.NES.NE.1030.AND.NES.NE.1032. F AND.NES.NE.1033.AND.NES.NE.1045)GO TO 644 WRITE(*,9833) GO TO 640 644 WRITE(*,9834)NES STOP 645 WRITE(*,9830) READ(*,8550)FNAMEB IF(FNAMEB.EQ.'con'.OR.FNAMEB.EQ.'Con')FNAMEB='CON' IF(FNAMEB.EQ.'prn'.OR.FNAMEB.EQ.'Prn')FNAMEB='PRN' IF (FNAMEB.EQ.'CON'.OR.FNAMEB.EQ.'PRN')OPEN(LUB,FILE=FNAMEB) IF (.NOT.(FNAMEB.EQ.'CON'.OR.FNAMEB.EQ.'PRN'))OPEN(LUB, F FILE=FNAMEB,STATUS='NEW',IOSTAT=NET,ERR=650) GO TO 670 650 IF(NET.NE.1027.AND.NET.NE.1030.AND.NET.NE.1032. F AND.NET.NE.1033.AND.NET.NE.1045)GO TO 660 WRITE(*,9833) GO TO 645 660 WRITE(*,9834)NET STOP 670 IF(JDAT.EQ.'3'.OR.JDAT.EQ.'4')GO TO 800 CC CC SECTION ON MISSING DATA CC IF(JTELB.NE.JPP)GO TO 690 WRITE(*,9835) DO 680 J=1,JPP JTMD(J)=0 VALMD(J)=-99.99 680 CONTINUE GO TO 800 690 IF(JTELB.EQ.0)WRITE (*,9840) IF(JTELB.NE.0)WRITE (*,9845) CALL QYN(CDATA,MDATA) IF(MDATA.EQ.0) GO TO 740 WRITE(*,9850) CALL QYN(CMDT,MDT) IF(MDT.EQ.0)GO TO 710 WRITE(*,9860) READ(*,*)VVAL DO 700 J=1,JPP JTMD(J)=-1 IF(VTYPE(J).EQ.'A'.OR.VTYPE(J).EQ.'S')JTMD(J)=0 VALMD(J)=VVAL 700 CONTINUE GO TO 800 710 DO 730 J=1,JPP IF(VTYPE(J).NE.'A'.AND.VTYPE(J).NE.'S')GO TO 715 VALMD(J)=-99.99 JTMD(J)=0 GO TO 730 715 WRITE (*,9870)(JLAB(K,J),K=1,10) CALL QYN(CYNK,NYNK) IF (CYNK.EQ.'Y')GO TO 720 JTMD(J)=1 VALMD(J)=-99.99 GO TO 730 720 JTMD(J)=-1 WRITE(*,9880) READ (*,*) VALMD(J) 730 CONTINUE GO TO 800 740 DO 750 J=1,JPP JTMD(J)=1 IF(VTYPE(J).EQ.'A'.OR.VTYPE(J).EQ.'S')JTMD(J)=0 VALMD(J)=-99.99 750 CONTINUE CC CC RECAPITULATION OF OPTIONS. CC 800 WRITE (*,9890) WRITE (*,9900) WRITE (*,9905)NAME IF(JDAT.NE.'3')WRITE(*,9910)NN IF(JDAT.EQ.'3')WRITE(*,9915)JPP IF(JDAT.NE.'1')GO TO 802 WRITE(*,8080) GO TO 806 802 IF(JDAT.NE.'4')GO TO 804 WRITE(*,8083) IF(JCRL.EQ.'1')WRITE(*,8087) IF(JCRL.EQ.'2')WRITE(*,8088) GO TO 806 804 IF(JDAT.EQ.'2')WRITE(*,8081) IF(JDAT.EQ.'3')WRITE(*,8082) IF(JCRL.EQ.'1')WRITE(*,8085) IF(JCRL.EQ.'2')WRITE(*,8086) 806 IF(JDAT.EQ.'3'.OR.JDAT.EQ.'4')GO TO 830 IF(JPPT.GT.1)GO TO 810 WRITE(*,8118) GO TO 820 810 WRITE(*,8115)JPPT IF(JPP.GT.1)WRITE(*,8116)JPP IF(JPP.EQ.1)WRITE(*,8119)(JLAB(K,1),K=1,10),JPLACE(1) 820 IF(CDATA.EQ.'N')WRITE(*,8145) IF(CDATA.EQ.'N')GO TO 825 WRITE(*,8140) IF(CMDT.EQ.'Y')WRITE(*,8142) IF(CMDT.EQ.'Y')WRITE(*,*)VVAL 825 IF (CYNFF.EQ.'Y') WRITE(*,8160) IF (CYNFF.EQ.'N') WRITE(*,8165) JFMT GO TO 842 830 IF(JDAT.EQ.'3')GO TO 840 IF (CYNFF.EQ.'Y') WRITE(*,8170) IF (CYNFF.EQ.'N') WRITE(*,8175) JFMT GO TO 842 840 IF (CYNFF.EQ.'Y') WRITE(*,8180) IF (CYNFF.EQ.'N') WRITE(*,8185) JFMT 842 IF (FNAMEA.NE.'CON') WRITE(*,8039) FNAMEA IF (FNAMEA.EQ.'CON') WRITE(*,8034) IF (YNSAVE.EQ.'Y') WRITE(*,8038) FNAMEC WRITE(*,8040) FNAMED WRITE(*,8050) FNAMEB WRITE (*,8030) CALL QYN(CEX,NEX) IF (CEX.NE.'Y') GOTO 100 IF(FNAMEB.EQ.'CON')GO TO 900 WRITE(LUB,9500) WRITE(LUB,9505) WRITE(LUB,8350) WRITE(LUB,9905)NAME WRITE(LUB,9900) IF(JDAT.NE.'3')WRITE(LUB,9910)NN IF(JDAT.EQ.'3')WRITE(LUB,9915)JPP IF(JDAT.NE.'1')GO TO 844 WRITE(LUB,8080) GO TO 850 844 IF(JDAT.NE.'4')GO TO 846 WRITE(LUB,8083) IF(JCRL.EQ.'1')WRITE(LUB,8087) IF(JCRL.EQ.'2')WRITE(LUB,8088) GO TO 850 846 IF(JDAT.EQ.'2')WRITE(LUB,8081) IF(JDAT.EQ.'3')WRITE(LUB,8082) IF(JCRL.EQ.'1')WRITE(LUB,8085) IF(JCRL.EQ.'2')WRITE(LUB,8086) 850 IF(JDAT.EQ.'3'.OR.JDAT.EQ.'4')GO TO 870 IF(JPPT.GT.1)GO TO 852 WRITE(LUB,8118) GO TO 865 852 WRITE(LUB,8115)JPPT IF(JPP.GT.1)GO TO 854 WRITE(LUB,8119)(JLAB(K,1),K=1,10),JPLACE(1) GO TO 865 854 WRITE(LUB,8116)JPP WRITE(LUB,8114) DO 860 J=1,JPP WRITE(LUB,8117)(JLAB(K,J),K=1,10),JPLACE(J),VTYPE(J) 860 CONTINUE 865 IF(CDATA.EQ.'N')WRITE(LUB,8145) IF(CDATA.EQ.'N')GO TO 868 WRITE(LUB,8140) IF(CMDT.EQ.'Y')WRITE(LUB,8142) IF(CMDT.EQ.'Y')WRITE(LUB,*)VVAL 868 IF (CYNFF.EQ.'Y') WRITE(LUB,8160) IF (CYNFF.EQ.'N') WRITE(LUB,8165) JFMT GO TO 890 870 IF(JDAT.EQ.'3')GO TO 880 IF (CYNFF.EQ.'Y') WRITE(LUB,8170) IF (CYNFF.EQ.'N') WRITE(LUB,8175) JFMT GO TO 890 880 IF (CYNFF.EQ.'Y') WRITE(LUB,8180) IF (CYNFF.EQ.'N') WRITE(LUB,8185) JFMT 890 IF (FNAMEB.EQ.'CON') PAUSE ' ' IF(FNAMEB.NE.'CON')WRITE(LUB,*) IF (YNSAVE.EQ.'Y') WRITE(LUB,8038) FNAMEC IF (FNAMEA.NE.'CON') WRITE(LUB,8039) FNAMEA CC CC INPUT OF DATA CC 900 IF(JDAT.EQ.'3'.OR.JDAT.EQ.'4')GO TO 940 IF (FNAMEA.EQ.'CON') WRITE(*,8355) JHALT=0 DO 930 L=1,NN IF (FNAMEA.NE.'CON')GO TO 910 905 WRITE(*,8356)JPPT,L 910 IF (CYNFF.EQ.'N') READ(LUA,JFMT)(HULP(J),J=1,JPPT) IF (CYNFF.EQ.'Y') READ(LUA,*)(HULP(J),J=1,JPPT) DO 920 J=1,JPP JH=JPLACE(J) IF(VTYPE(J).EQ.'T')GO TO 912 X(L,J)=HULP(JH) GO TO 920 912 IF(JTMD(J).GT.0.OR.HULP(JH).NE.VALMD(J))GO TO 915 X(L,J)=1000. GO TO 920 915 IF(HULP(JH).GT.0.)GO TO 918 WRITE(*,8358)L IF(FNAMEA.EQ.'CON')GO TO 916 JHALT=1 GO TO 920 916 WRITE(*,8360) GO TO 905 918 X(L,J)=ALOG10(HULP(JH)) 920 CONTINUE IF (YNSAVE.EQ.'N')GO TO 930 IF (CYNFF.EQ.'N') WRITE(LUC,JFMT)(HULP(J),J=1,JPPT) IF (CYNFF.EQ.'Y') WRITE(LUC,*)(HULP(J),J=1,JPPT) 930 CONTINUE 933 DO 935 J=1,JPP IF(VTYPE(J).EQ.'T')VALMD(J)=1000. 935 CONTINUE IF (YNSAVE.EQ.'Y') CLOSE(LUC,STATUS='KEEP') IF (YNSAVE.EQ.'Y') WRITE(*,8038) FNAMEC IF(JHALT.EQ.1)STOP RETURN 940 IF(FNAMEA.EQ.'CON'.AND.JDAT.EQ.'4')WRITE(*,8363) IF(FNAMEA.EQ.'CON'.AND.JDAT.EQ.'3')WRITE(*,8364) IF(JDAT.EQ.'4')NNK=NN IF(JDAT.EQ.'3')NNK=JPP DO 990 L=2,NNK LSUBT=L-1 IF (FNAMEA.NE.'CON')GO TO 950 IF(JDAT.EQ.'4'.AND.L.EQ.2) WRITE(*,8361) L,LSUBT IF(JDAT.EQ.'4'.AND.L.NE.2) WRITE(*,8362)LSUBT,L IF(JDAT.EQ.'3'.AND.L.EQ.2) WRITE(*,8367) L,LSUBT IF(JDAT.EQ.'3'.AND.L.NE.2) WRITE(*,8368)LSUBT,L 950 IF (CYNFF.EQ.'Y') READ(LUA,*)(DVEC(J),J=1,LSUBT) IF (CYNFF.EQ.'N') READ(LUA,JFMT)(DVEC(J),J=1,LSUBT) IF(JDAT.EQ.'3')GO TO 970 DO 964 J=1,LSUBT IF(DVEC(J).GE.0..AND.DVEC(J).LE.1.)GO TO 964 IF(FNAMEA.EQ.'CON')GO TO 960 WRITE(*,8365)L,J STOP 960 WRITE(*,8370)L,J,L GO TO 950 964 CONTINUE GO TO 985 970 DO 974 J=1,LSUBT IF(DVEC(J).LE.1..AND.DVEC(J).GE.-1.)GO TO 974 IF(FNAMEA.EQ.'CON')GO TO 972 WRITE(*,8372)L,J STOP 972 WRITE(*,8374)L,J,L GO TO 950 974 CONTINUE 985 IF (YNSAVE.EQ.'N')GO TO 986 IF (CYNFF.EQ.'Y') WRITE(LUC,*)(DVEC(J),J=1,LSUBT) IF (CYNFF.EQ.'N') WRITE(LUC,JFMT)(DVEC(J),J=1,LSUBT) 986 DO 988 J=1,LSUBT IF(JDAT.EQ.'4'.AND.JCRL.EQ.'1')DVEC(J)=1.-DVEC(J) IF(JDAT.EQ.'4'.AND.JCRL.EQ.'2')DVEC(J)=SQRT(1.-DVEC(J)) IF(JDAT.EQ.'3'.AND.JCRL.EQ.'1')DVEC(J)=(1.-DVEC(J))/2. IF(JDAT.EQ.'3'.AND.JCRL.EQ.'2'.AND.DVEC(J).GE.0.)DVEC(J)= F 1.-DVEC(J) IF(JDAT.EQ.'3'.AND.JCRL.EQ.'2'.AND.DVEC(J).LT.0.)DVEC(J)= F 1.+DVEC(J) 988 CONTINUE WRITE(LUD,8380)(DVEC(J),J=1,LSUBT) 990 CONTINUE IF (YNSAVE.EQ.'Y') CLOSE(LUC,STATUS='KEEP') IF (YNSAVE.EQ.'Y') WRITE(*,8038) FNAMEC RETURN 8030 FORMAT(/1X,' ARE ALL THESE OPTIONS OK? YES OR NO : '$) 8034 FORMAT(1X,' THE DATA WILL BE READ FROM THE KEYBOARD') 8038 FORMAT(1X,' THE DATA WILL BE SAVED ON FILE: ',A30) 8039 FORMAT(1X,' YOUR DATA RESIDE ON FILE: ',A30/) 8040 FORMAT(1X,' THE DISSIMILARITIES' F ' WILL BE WRITTEN ON: ',A30) 8050 FORMAT(1X,' THE OTHER OUTPUT WILL BE WRITTEN ON: ',A30) 8080 FORMAT(2X,'INPUT OF A MATRIX OF MEASUREMENTS FOR THE ' F 'CALCULATION'/4X,'OF DISSIMILARITIES BETWEEN OBJECTS') 8081 FORMAT(2X,'INPUT OF A MATRIX OF INTERVAL OR RATIO' F ' MEASUREMENTS,'/4X,'FOR THE CALCULATION OF DISSIMILARITIES' F ' BETWEEN VARIABLES') 8082 FORMAT(2X,'INPUT OF CORRELATION COEFFICIENTS BETWEEN' F ' VARIABLES') 8083 FORMAT(2X,'INPUT OF SIMILARITIES BETWEEN OBJECTS') 8085 FORMAT(/2X,'THE CORRELATIONS ARE CONVERTED TO DISSIMILARITIES' F ' BY THE FORMULA :'/5X,'d = ( 1 - r ) / 2') 8086 FORMAT(/2X,'THE CORRELATIONS ARE CONVERTED TO DISSIMILARITIES' F ' BY THE FORMULA :'/5X,'d = 1 - absolute value of r') 8087 FORMAT(/2X,'THE SIMILARITIES ARE CONVERTED TO DISSIMILARITIES' F ' BY THE FORMULA :'/5X,'d = 1 - s') 8088 FORMAT(/2X,'THE SIMILARITIES ARE CONVERTED TO DISSIMILARITIES' F ' BY THE FORMULA :'/5X,'d = square root of ( 1 - s )') 8114 FORMAT(1X,' THESE VARIABLES ARE :') 8115 FORMAT(/1X,' THERE ARE ',I4,' VARIABLES IN THE DATA SET,') 8116 FORMAT(1X,' AND 'I4,' OF THEM WILL BE USED IN THE ANALYSIS') 8117 FORMAT(10X,10A1,' (POSITION :',I3,', TYPE : ',A1,')') 8118 FORMAT(/1X,' THERE IS ONE VARIABLE IN THE DATA SET') 8119 FORMAT(1X,' AND ONLY VARIABLE ',10A1,' WILL BE USED IN THE' F ' ANALYSIS (POSITION :',I3,')') 8140 FORMAT(1X,' MISSING VALUES CAN OCCUR') 8142 FORMAT(1X,' THE UNIQUE VALUE WHICH REPRESENTS MISSING' F' MEASUREMENTS IS :'/6X$) 8145 FORMAT(1X,' THERE ARE NO MISSING VALUES') 8160 FORMAT(1X,' THE MEASUREMENTS WILL BE READ IN FREE FORMAT') 8165 FORMAT(1X,' THE INPUT FORMAT FOR THE MEASUREMENTS IS'/2X,A60) 8170 FORMAT(1X,' THE SIMILARITIES WILL BE READ IN FREE FORMAT') 8175 FORMAT(' THE INPUT FORMAT FOR THE SIMILARITIES IS'/2X,A60) 8180 FORMAT(1X,' THE CORRELATIONS WILL BE READ IN FREE FORMAT') 8185 FORMAT(' THE INPUT FORMAT FOR THE CORRELATIONS IS'/2X,A60) 8350 FORMAT(/1X,'This program constructs a dissimilarity' F ' matrix between objects or variables.', F /1X,'Further information can be found in Chapter 1 of:' F //5X,'L. Kaufman and P.J. Rousseeuw (1990),' F /5X,'Finding Groups in Data: An Introduction to' F ' Cluster Analysis,' F /5X,'Wiley, New York.'//) 8355 FORMAT(//1X,'PLEASE ENTER YOUR DATA FOR EACH OBJECT'//) 8356 FORMAT(1X,' THE',I3,' MEASUREMENTS FOR OBJECT ',I5,' : '/) 8358 FORMAT(/1X,'You have entered a negative or zero ratio' F ' variable for object',I5,'.') 8360 FORMAT(1X,'This is not allowed. Please enter the' F ' measurements for'/1X,'this object once again.') 8361 FORMAT(1X,' SIMILARITY BETWEEN OBJECTS ',I5, F' AND ',I5,' : '/) 8362 FORMAT(1X,' THE ',I4,' SIMILARITIES FOR OBJECT ',I5, F' : '/) 8363 FORMAT(1X,' FOR OBJECT J, ENTER SIMILARITIES TO OBJECTS', F' 1,2,... ,(J-1) '/3X,'(CAREFUL : THE SIMILARITIES MAY NOT' F' BE NEGATIVE NOR EXCEED ONE)') 8364 FORMAT(1X,' FOR VARIABLE J, ENTER CORRELATIONS WITH' F' VARIABLES 1,2,... ,(J-1) '/3X,'(CAREFUL : THE CORRELATIONS' F' MUST BE BETWEEN -1 AND +1)') 8365 FORMAT(/1X,'THE SIMILARITY BETWEEN OBJECTS',I5,' AND ',I5, F' IS NEGATIVE OR EXCEEDS ONE,'/ F' UNFORTUNATELY THE PROGRAM MUST BE STOPPED.') 8367 FORMAT(1X,' CORRELATION BETWEEN VARIABLES ',I5, F' AND ',I5,' : '/) 8368 FORMAT(1X,' THE ',I4,' CORRELATIONS WITH VARIABLE ',I5, F' : '/) 8370 FORMAT(/' THE SIMILARITY BETWEEN OBJECTS ',I5,' AND ',I5, F' IS NEGATIVE OR EXCEEDS ONE.'/ F 1X,'PLEASE ENTER THE DISSIMILARITIES FOR', F' OBJECT ',I5,' ONCE AGAIN :'/) 8372 FORMAT(/1X,'THE CORRELATION BETWEEN VARIABLES',I5,' AND ',I5, F' IS NOT BETWEEN -1 AND +1,'/ F' UNFORTUNATELY THE PROGRAM MUST BE STOPPED.') 8374 FORMAT(/' THE CORRELATION BETWEEN VARIABLES ',I5,' AND ',I5, F' IS NOT BETWEEN -1 AND +1.'/ F 1X,'PLEASE ENTER THE CORRELATIONS FOR', F' VARIABLE ',I5,' ONCE AGAIN :'/) 8380 FORMAT(1X,8F9.3) 8500 FORMAT(A1) 8510 FORMAT(10A1,21X,A1) 8520 FORMAT(BNI4,7X,10A1,21X,A1) 8530 FORMAT(A60) 8550 FORMAT(A30) 9500 FORMAT(23X,33('*') /23X,'*',31X,'*'/23X,'* COMPUTING ' F 'DISSIMILARITIES *'/23X,'*',31X,'*'/23X,33('*')///) 9505 FORMAT(//' Copyright (C) Leonard Kaufman and Peter' F ' Rousseeuw 1990. All rights reserved.') 9510 FORMAT(1X,'This program has four options :'/3X, F'1. Your data consists of a rectangular matrix of objects'/, F 6X,'by variables, in which the variables may be of different' F /,6X,'types. You wish to cluster the objects. ',12X, F '(Please type 1)' F /,3X,'2. Your data consists of a rectangular matrix of'/6X, F'objects by variables, but all variables are interval or' F ' ratio.'/6X,'You wish to calculate the Pearson correlation' F' coefficients'/6X,'for clustering the variables.',22X, F' (Please type 2)'/3X,'3. Maybe you already have correlation' F /6X,'coefficients between variables (either parametric' F /6X,'or nonparametric). Your input data consist of a lower' F /6X,'triangular matrix of pairwise correlations. You wish' F /6X,'to calculate dissimilarities between the variables.' F ' (Please type 3)'/,3X,'4. Your data consists of a lower' F ' triangular matrix of'/6X,'similarities between objects ' F '(with values between 0 and 1),'/6X,'which you would like' F ' to convert to dissimilarities. (Please type 4)') 9515 FORMAT(1X,'Please enter your choice : ',$) 9520 FORMAT(1X,'NOT ALLOWED ! PLEASE ENTER YOUR CHOICE AGAIN : '$) 9521 FORMAT(/1X,'The similarities can be converted to' F ' dissimilarities in two ways :'//' 1. d = 1 - s',21X, F ' (Please type 1)'/' 2. d = square root of ( 1 - s )' F ' (Please type 2)'/) 9522 FORMAT(/1X,'The correlations can be converted to' F ' dissimilarities in two ways :'//' 1. d = ( 1 - r ) / 2' F ,11X,' (Please type 1)'//,5X,'With this formula, variables' F ' with a high positive correlation receive'/5X,'a' F ' dissimilarity close to zero, whereas variables with a ' F 'strongly negative'/5X,'correlation will be considered' F ' very dissimilar.'/5X,'In other applications one might' F ' prefer to use :'//2X,' 2. d = 1 - absolute value of r ' F ' (Please type 2)'//5X,'in which case also variables' F ' with a strongly negative correlation'/5X,'will be' F ' assigned a small dissimilarity.'/) 9523 FORMAT(//1X,'THE PRESENT VERSION OF THE PROGRAM CAN HANDLE' F ' UP TO',I6,' VARIABLES.'/1X,'(IF MORE ARE TO BE CONSIDERED' F ', THE ARRAYS INSIDE THE PROGRAM MUST BE ADAPTED)') 9524 FORMAT(/1X,'HOW MANY VARIABLES DOES YOUR DATA SET CONTAIN ?' F/1X,47(1H-)/' PLEASE GIVE A NUMBER BETWEEN 3 AND ',I6,' : '$) 9525 FORMAT(//1X,'THE PRESENT VERSION OF THE PROGRAM CAN HANDLE' F ' UP TO',I6,' OBJECTS.'/1X,'(IF MORE ARE TO BE CONSIDERED' F ', THE ARRAYS INSIDE THE PROGRAM MUST BE ADAPTED)') 9530 FORMAT(/' HOW MANY OBJECTS DOES YOUR DATA SET CONTAIN ?' F/1X,45(1H-)/' PLEASE GIVE A NUMBER BETWEEN 3 AND ',I6,' : '$) 9540 FORMAT(/' AT LEAST 3 OBJECTS ARE NEEDED FOR CLUSTER ANALYSIS' F','/1X,' PLEASE FORESEE MORE OBJECTS ') 9620 FORMAT(//1X,'THE PRESENT VERSION OF THE PROGRAM ALLOWS TO' F ' ENTER UP TO',I5,' VARIABLES,'/1X,'OF WHICH AT MOST',I5, F ' CAN BE USED IN THE ACTUAL COMPUTATIONS.'/1X,'(IF MORE ARE' F ' NEEDED, THE ARRAYS INSIDE THE PROGRAM MUST BE ADAPTED)') 9630 FORMAT(/1X,'WHAT IS THE TOTAL NUMBER OF VARIABLES IN YOUR' F' DATA SET ?'/1X,56(1H-)/ F' PLEASE GIVE A NUMBER BETWEEN 1 AND ',I6,' : '$) 9640 FORMAT(/38H HOW MANY VARIABLES DO YOU WANT TO USE, F' IN THE ANALYSIS ?'/1X,55('-')/1X,' (AT MOST ',I4,' ) : '$) 9645 FORMAT(/' This option can handle variables of the following' F ' types :'/5X,' SYMMETRIC BINARY (please type S)' F /5X,' ASYMMETRIC BINARY (please type A)' F /5X,' NOMINAL (please type N)' F /5X,' ORDINAL (please type O)' F /5X,' INTERVAL (please type I)' F /5X,' RATIO to be treated as ORDINAL (please type O)' F /5X,' RATIO to be treated as INTERVAL (please type I)' F /5X,' RATIO to be logarithmically transformed (please' F ' type T)'/10X,'CAREFUL : A VARIABLE FOR WHICH A ' F 'LOGARITHMIC'/22X,'TRANSFORMATION IS REQUESTED MAY ONLY' F /22X,'CONTAIN POSITIVE NON-ZERO VALUES') 9646 FORMAT(/' This option can handle variables of the following' F ' types :'/5X,' INTERVAL (please type I)' F /5X,' RATIO to be treated as INTERVAL (please type I)' F /5X,' RATIO to be logarithmically transformed (please' F ' type T)'/10X,'CAREFUL : A VARIABLE FOR WHICH A ' F 'LOGARITHMIC'/22X,'TRANSFORMATION IS REQUESTED MAY ONLY' F /22X,'CONTAIN POSITIVE NON-ZERO VALUES') 9650 FORMAT(//1X,'VARIABLES TO BE USED ', F' LABEL (AT MOST 10 CHARACTERS) TYPE'/ F 1X,17(1H-),4(1H),6(1H-),10(1H),19(1H-),'-----') 9660 FORMAT(1X,'NUMBER : ',I4,6X$) 9665 FORMAT(/' A WRONG CODE WAS ENTERED FOR THIS VARIABLE.' F ' PLEASE ENTER THIS WHOLE LINE AGAIN.') 9670 FORMAT(//1X,'VARIABLES TO BE USED : POSITION', F ' LABEL (AT MOST 10 CHARACTERS) TYPE'/ F 1X,31('-'),4(1H),7('-'),10(1H),21('-'),'---') 9680 FORMAT(1X,'NUMBER ',I4,15X,': '$) 9685 FORMAT(/' THIS POSITION IS NOT ALLOWED.' F ' PLEASE ENTER THIS WHOLE LINE AGAIN.') 9690 FORMAT(/' THIS POSITION HAS ALREADY BEEN CHOSEN FOR ANOTHER', F' VARIABLE.'/' PLEASE ENTER THIS WHOLE LINE AGAIN.') 9720 FORMAT(/1X,'PLEASE ENTER A TITLE FOR THE OUTPUT (AT MOST 60' F ' CHARACTERS)'/1X,59(1H-)/1X$) 9780 FORMAT(/' DO YOU WANT TO READ THE DATA IN FREE FORMAT ?'/1X, F 45(1H-)/' THIS MEANS THAT YOU ONLY HAVE TO INSERT BLANK(S)', F 17H BETWEEN NUMBERS./31H (NOTE: WE ADVISE USERS WITHOUT, F 45H KNOWLEDGE OF FORTRAN FORMATS TO ANSWER YES.)/ F ' MAKE YOUR CHOICE (YES/NO) : '$) 9790 FORMAT(/1X,'YOUR DESIRED FORTRAN FORMAT IS :'/ F1X'(BETWEEN BRACKETS AND', F ' AT MOST 60 CHARACTERS, e.g. (2F3.0,F1.0) )') 9800 FORMAT(/1X,'PLEASE GIVE THE NAME OF THE FILE CONTAINING', F' THE DATA (e.g. TYPE A:EXAMPLE.DAT)',/1X,'OR TYPE', F' KEY IF YOU PREFER TO ENTER THE DATA BY KEYBOARD.'/ F1X,'WHAT DO YOU CHOOSE ? '$) 9810 FORMAT(/1X,'DO YOU WANT TO SAVE YOUR DATA ON A FILE ?'/ F 1X,'PLEASE ANSWER YES OR NO : ',$) 9820 FORMAT(/1X,'IN WHICH FILE DO YOU WANT TO SAVE YOUR DATA ?'/ 1 56H (WARNING : IF THERE ALREADY EXISTS A FILE WITH THE SAME, F' NAME'/12X,'THEN THE OLD FILE WILL BE OVERWRITTEN.)'/ F ' TYPE e.g. B:SAVE.DAT ..................... : '$) 9825 FORMAT(/' OUTPUT SECTION'/1X,14('-')/' A. On which file' F ' do you want to output the dissimilarity matrix ?'/5X, F 62('-')/ 1 56H (WARNING : IF THERE ALREADY EXISTS A FILE WITH THE SAME, F ' NAME'/12X,'THEN THE OLD FILE WILL BE OVERWRITTEN.)'/ F ' TYPE e.g. B:EXAMPLE.DIS .................. : '$) 9830 FORMAT(/' B. Where do you want the rest of the output ?' F /5X,42('-')/ F ' TYPE CON IF YOU WANT IT ON THE SCREEN'/ F ' OR TYPE PRN IF YOU WANT IT ON THE PRINTER'/ F ' OR TYPE THE NAME OF A FILE (e.g. B:EXAMPLE.OUT)'/ F ' (WARNING : IF THERE ALREADY EXISTS A FILE WITH THE SAME', F ' NAME'/12X,'THEN THE OLD FILE WILL BE OVERWRITTEN.)'/ F ' WHAT DO YOU CHOOSE ? ...................... : '$) 9832 FORMAT(/' THIS FILE WAS NOT FOUND, PLEASE ENTER ANOTHER ONE') 9833 FORMAT(/' FILE NAME INCORRECT, PLEASE ENTER ANOTHER') 9834 FORMAT(/' FORTRAN ERROR CODE : ',I8) 9835 FORMAT(/' All variables are binary. Only the values 0 and 1 ' F'are allowed ;'/' all other values will be treated as missing' F ' measurements.') 9840 FORMAT(/' CAN MISSING DATA OCCUR IN THE MEASUREMENTS ?' F/1X,'PLEASE ANSWER YES OR NO : '$) 9845 FORMAT(/' For the binary variables only the values 0 and 1 ' F'are allowed ;'/' all other values will be treated as missing' F ' measurements.'/' CAN MISSING DATA OCCUR FOR THE OTHER' F ' VARIABLES ?'/' PLEASE ANSWER YES OR NO : '$) 9850 FORMAT(/' IS THERE A UNIQUE VALUE WHICH IS TO BE INTERPRETED'/ F ' AS A MISSING MEASUREMENT VALUE FOR ANY VARIABLE ? '/ F ' PLEASE ANSWER YES OR NO : '$) 9860 FORMAT(/' PLEASE ENTER THIS VALUE NOW : '$) 9870 FORMAT(/' SHOULD MISSING VALUES BE FORESEEN FOR VARIABLE', F1X,10A1,' ?'/' PLEASE ANSWER YES OR NO : '$) 9880 FORMAT(' ENTER THE VALUE OF THIS VARIABLE WHICH HAS TO BE' F' INTERPRETED AS'/' THE MISSING VALUE CODE : '$) 9890 FORMAT(//////////) 9900 FORMAT(///' DATA SPECIFICATIONS AND CHOSEN OPTIONS'/1X, F 38('-')) 9905 FORMAT(' TITLE : ',A60) 9910 FORMAT(' THERE ARE ',I4,' OBJECTS') 9915 FORMAT(' THERE ARE ',I4,' VARIABLES') END CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCCCC file PAM.FOR (Chapter 2) 42k CCCCCCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC PROGRAM PAM CC CC PARTITIONING AROUND MEDOIDS CC CC CARRIES OUT A CLUSTERING USING THE K-MEDOID APPROACH. CC CC dimension NSEND,NREPR,NELEM,NCLUV is MAXNN: DIMENSION NSEND(100),NREPR(100),NELEM(100),NCLUV(100) CC dimension of RADUS,DAMER,TTD,SEPAR,DVEC is MAXNN: DIMENSION RADUS(100),DAMER(100),TTD(100),SEPAR(100),DVEC(100) CC dimension X(MAXNN,MAXPP),DYS(MAXHH): DIMENSION X(100,20),DYS(4951) CC dimension VALMD,JTMD,JPLACE(MAXPP) and HULP(MAXTT): DIMENSION VALMD(20),JTMD(20),JPLACE(20),HULP(80) CC dimension LAB(3,MAXNN) and JLAB(10,MAXPP): CHARACTER LAB(3,100),JLAB(10,20),NUM(13),YNSAVE CHARACTER*30 FNAMEA,FNAMEB,FNAMEC CHARACTER*60 JFMT,NAME CC MAXNN=100 MAXTT=80 MAXPP=20 MAXHH=4951 CC CC LOGICAL INPUT AND OUTPUT UNITS: CC LUA = LOGICAL UNIT A (INPUT) CC LUB = LOGICAL UNIT B (OUTPUT) CC LUC = LOGICAL UNIT C (OUTPUT OF DATA MATRIX) CC THE USER SHOULD ASSIGN TO LUA, LUB, AND LUC, THE NUMBERS USED BY CC HIS OWN COMPUTER: ONLY THE NEXT 3 STATEMENTS MUST BE CHANGED: CC LUA=1 LUB=2 LUC=3 CC CALL ENTR(NN,JPP,KBEG,KEND,MAXNN,MAXTT,MAXPP,MAXHH,X,DVEC,DYS, F VALMD,JTMD,JPLACE,HULP,NUM,LUA,LUB,LUC,FNAMEA,FNAMEB,FNAMEC, F LAB,JLAB,NAME,YNSAVE,JDYSS,NSTAN,NDYST,LARGE,LGRAP,JLABS, F NFF,JFMT,MDATA) IF(JDYSS.EQ.1)GO TO 100 IF(MDATA.EQ.0)GOTO 48 CC CC INSPECTION OF OBJECTS FOR MISSING VALUES CC WRITE(LUB,*) JHALT=0 DO 20 L=1,NN DO 10 J=1,JPP IF(JTMD(J).GE.0)GOTO 20 IF(X(L,J).NE.VALMD(J))GOTO 20 10 CONTINUE WRITE(LUB,9041)LAB(1,L),LAB(2,L),LAB(3,L) JHALT=1 20 CONTINUE CC CC INSPECTION OF VARIABLES FOR MISSING VALUES CC MYST=0 DO 45 J=1,JPP MYSJ=0 IF(JTMD(J).GE.0)GOTO 45 DO 46 L=1,NN IF(X(L,J).EQ.VALMD(J))MYSJ=MYSJ+1 46 CONTINUE MYST=MYST+MYSJ IF(MYSJ.EQ.0)GOTO 45 WRITE(LUB,9045)(JLAB(K,J),K=1,10),MYSJ IF(MYSJ.LT.NN)GOTO 45 WRITE(LUB,9047)(JLAB(K,J),K=1,10) IF(NFF.EQ.0)WRITE(LUB,9048) JHALT=1 45 CONTINUE WRITE(LUB,9049)MYST IF(JHALT.EQ.1)STOP CC CC STANDARDIZATION AND DISTANCES CC 48 IF(NSTAN.EQ.0)GO TO 70 CALL STAND(NN,JPP,MAXNN,MAXPP,X,JTMD,VALMD,JHALT,JLAB,LUB,FNAMEB) IF(JHALT.EQ.1)STOP IF(LARGE.EQ.0)GO TO 70 WRITE(LUB,9031) IF(MDATA.NE.0)WRITE(LUB,9032) JPEND=JPP IF(JPP.GT.8)JPEND=8 DO 60 L=1,NN WRITE(LUB,9033)LAB(1,L),LAB(2,L),LAB(3,L),(X(L,J),J=1,JPEND) IF(JPP.GT.8)WRITE(LUB,9040)(X(L,J),J=9,JPP) 60 CONTINUE 70 CALL DYSTA(NN,JPP,MAXNN,MAXPP,MAXHH,X,DYS,NDYST,JTMD, F VALMD,LAB,JHALT,LUB,FNAMEB) IF(JHALT.EQ.1)STOP 100 IF(LARGE.EQ.0)GO TO 125 WRITE(LUB,9060) WRITE(LUB,9033)LAB(1,1),LAB(2,1),LAB(3,1) DO 120 L=2,NN LSUBT=L-1 JPEND=LSUBT IF(LSUBT.GT.8)JPEND=8 DO 110 J=1,LSUBT NLJ=MEET(L,J) DVEC(J)=DYS(NLJ) 110 CONTINUE WRITE(LUB,9033)LAB(1,L),LAB(2,L),LAB(3,L),(DVEC(J),J=1,JPEND) IF(LSUBT.GT.8)WRITE(LUB,9040)(DVEC(J),J=9,LSUBT) 120 CONTINUE 125 S=0.0 NHALF=NN*(NN-1)/2+1 L=1 130 L=L+1 IF(DYS(L).GT.S)S=DYS(L) IF(L.LT.NHALF)GO TO 130 DO 140 KK=KBEG,KEND IF(KK.EQ.KBEG)GO TO 135 KMP=KK-1 IF(FNAMEB.NE.'CON')WRITE(*,9068)KMP,KK 135 IF(FNAMEB.EQ.'CON') PAUSE ' ' WRITE(LUB,9070)KK CALL BSWAP(KK,NN,MAXNN,NREPR,RADUS,DAMER,TTD,MAXHH,DYS F,SKY,S,LUB) WRITE(LUB,9075) RNN=NN ASKY=SKY/RNN WRITE(LUB,9080)ASKY CALL CSTAT(KK,NN,NSEND,NREPR,RADUS,DAMER,TTD,SEPAR,SKY,S, FMAXHH,DYS,NCLUV,NELEM,JPP,MAXNN,MAXPP,X,LAB,LUB,JDYSS,NSTAN) IF(LGRAP.EQ.0)GO TO 140 IF(KK.LE.1)GO TO 140 IF(KK.GE.NN)GO TO 140 IF(FNAMEB.EQ.'CON') PAUSE ' ' CALL DARK(KK,NN,MAXNN,MAXHH,NCLUV,NSEND,NELEM,NREPR F,RADUS,DAMER,TTD,DYS,LAB,LUB,S,NUM) 140 CONTINUE WRITE(*,9085) IF(YNSAVE.EQ.'Y'.AND.FNAMEB.EQ.'CON')WRITE(*,9090)FNAMEC IF(FNAMEB.NE.'PRN'.AND.FNAMEB.NE.'CON')WRITE(*,9095)FNAMEB IF(FNAMEB.EQ.'PRN')WRITE(*,9096) IF(FNAMEB.NE.'PRN'.AND.FNAMEB.NE.'CON')WRITE(LUB,9095)FNAMEB STOP 9031 FORMAT(//' STANDARDIZED MEASUREMENTS'/1X,25(1H-)/) 9032 FORMAT(' ( 99.99 DENOTES A MISSING VALUE)'//) 9033 FORMAT(1X,3A1,2X,8F9.2) 9040 FORMAT(6X,8F9.2) 9041 FORMAT(/' OBJECT ',3A1,' CONTAINS ONLY MISSING VALUES', F ' AND MUST BE REMOVED.'/) 9045 FORMAT(' VARIABLE ',10A1,' CONTAINS',I5,' MISSING VALUES') 9047 FORMAT(/' VARIABLE',10A1,' CONTAINS ONLY MISSING VALUES', F ' AND MUST BE REMOVED.') 9048 FORMAT(' (THIS CAN BE DONE BY CHANGING THE NUMBER OF', F ' VARIABLES AND THE INPUT FORMAT.)'/) 9049 FORMAT(/' THE TOTAL NUMBER OF MISSING VALUES IS',I7//) 9060 FORMAT(//' DISSIMILARITY MATRIX'/1X,20(1H-)/) 9068 FORMAT(' I am finished with',I3,' clusters, working on',I3) 9070 FORMAT(//1X,46(1H*)/1X,1H*,44X,1H*/' * NUMBER OF', F' REPRESENTATIVE OBJECTS',I6,4X,1H*/1X,1H*,44X,1H*/1X,46(1H*)) 9075 FORMAT(1X/14H FINAL RESULTS) 9080 FORMAT(1X,26H AVERAGE DISSIMILARITY = ,F12.3/) 9085 FORMAT(/' This run has been successfully completed.'/) 9090 FORMAT(/1X,'Your data is in file: ',A30) 9095 FORMAT(/1X,'The output is in file: ',A30) 9096 FORMAT(/1X,'The output was sent to the printer.') END CC CC SUBROUTINE QYN(YN,NYN) CHARACTER YN 10 READ(*,8000)YN IF(YN.EQ.'y')YN='Y' IF(YN.EQ.'n')YN='N' IF(YN.EQ.'Y')NYN=1 IF(YN.EQ.'N')NYN=0 IF(YN.EQ.'Y'.OR.YN.EQ.'N')GO TO 20 WRITE(*,9000) GO TO 10 20 RETURN 8000 FORMAT(A1) 9000 FORMAT(' NOT ALLOWED! PLEASE ENTER YOUR CHOICE AGAIN: '$) END CC CC SUBROUTINE NWLAB(NN,MAXNN,NUM,LAB) CHARACTER LAB(3,MAXNN),NUM(13) LLA=1 LLB=1 LLC=1 DO 50 J=1,NN IF(LLC.LT.10)GOTO 10 LLC=0 IF(LLB.LT.10)GOTO 20 LLB=0 LLA=LLA+1 20 LLB=LLB+1 10 LLC=LLC+1 LAB(1,J)=NUM(LLA) LAB(2,J)=NUM(LLB) LAB(3,J)=NUM(LLC) 50 CONTINUE RETURN END CC CC FUNCTION MEET(L,J) IF(L.EQ.J)GO TO 20 IF(L.GT.J)GO TO 10 CC CC L IS LESS THAN J CC MEET=(J-2)*(J-1)/2+L+1 RETURN CC CC J IS LESS THAN L CC 10 MEET=(L-2)*(L-1)/2+J+1 RETURN CC CC J EQUALS L CC 20 MEET=1 RETURN END CC CC SUBROUTINE STAND(NN,JPP,MAXNN,MAXPP,X,JTMD,VALMD,JHALT,JLAB, F LUB,FNAMEB) DIMENSION X(MAXNN,MAXPP),JTMD(MAXPP),VALMD(MAXPP) CHARACTER JLAB(10,MAXPP) CHARACTER*30 FNAMEB DO 200 J=1,JPP AVERA=0.0 STAM=0.0 IF(JTMD(J).GE.0)GOTO 100 NPRES=0 DO 20 L=1,NN IF(X(L,J).EQ.VALMD(J))GOTO 20 NPRES=NPRES+1 AVERA=AVERA+X(L,J) 20 CONTINUE IF(NPRES.LE.1)GOTO 300 RPRES=NPRES AVERA=AVERA/RPRES DO 50 L=1,NN IF(X(L,J).EQ.VALMD(J))GOTO 50 STAM=STAM+ABS(X(L,J)-AVERA) 50 CONTINUE STAM=STAM/RPRES WRITE(LUB,9305)(JLAB(K,J),K=1,10),AVERA,STAM IF(STAM.LE.0.0)GOTO 300 DO 60 L=1,NN IF(X(L,J).EQ.VALMD(J))GOTO 70 X(L,J)=(X(L,J)-AVERA)/STAM IF(X(L,J).GT.49.0)X(L,J)=49.0 IF(X(L,J).LT.(-49.0))X(L,J)=-49.0 GOTO 60 70 X(L,J)=99.99 60 CONTINUE VALMD(J)=99.99 GOTO 200 100 DO 120 L=1,NN AVERA=AVERA+X(L,J) 120 CONTINUE RNN=NN AVERA=AVERA/RNN DO 150 L=1,NN STAM=STAM+ABS(X(L,J)-AVERA) 150 CONTINUE STAM=STAM/RNN WRITE(LUB,9305)(JLAB(K,J),K=1,10),AVERA,STAM IF(STAM.LE.0.0)GOTO 300 DO 160 L=1,NN X(L,J)=(X(L,J)-AVERA)/STAM IF(X(L,J).GT.49.0)X(L,J)=49.0 IF(X(L,J).LT.(-49.0))X(L,J)=-49.0 160 CONTINUE GOTO 200 300 JHALT=1 WRITE(LUB,9300)(JLAB(K,J),K=1,10) WRITE(LUB,9301) IF(FNAMEB.NE.'CON')WRITE(*,9300)(JLAB(K,J),K=1,10) IF(FNAMEB.NE.'CON')WRITE(*,9301) 200 CONTINUE RETURN 9300 FORMAT(/' THE MEAN DEVIATION OF VARIABLE ',10A1, F /' IS ZERO (UP TO COMPUTER PRECISION).') 9301 FORMAT(' PLEASE RUN THE PROGRAM AGAIN WITHOUT THIS' F ' VARIABLE. '/) 9305 FORMAT(' VARIABLE ',10A1,' HAS AVERAGE ',F10.3, F ', AND MEAN DEVIATION',F10.3) END CC CC SUBROUTINE DYSTA(NN,JPP,MAXNN,MAXPP,MAXHH,X,DYS,NDYST,JTMD, F VALMD,LAB,JHALT,LUB,FNAMEB) DIMENSION X(MAXNN,MAXPP),DYS(MAXHH),JTMD(MAXPP),VALMD(MAXPP) CHARACTER LAB(3,MAXNN) CHARACTER*30 FNAMEB PP=JPP NLK=1 DYS(1)=0.0 DO 100 L=2,NN LSUBT=L-1 DO 20 K=1,LSUBT CLK=0.0 NLK=NLK+1 NPRES=0 DO 30 J=1,JPP IF(JTMD(J).GE.0)GOTO 40 IF(X(L,J).EQ.VALMD(J))GOTO 30 IF(X(K,J).EQ.VALMD(J))GOTO 30 40 NPRES=NPRES+1 IF(NDYST.NE.1)GOTO 50 CLK=CLK+(X(L,J)-X(K,J))*(X(L,J)-X(K,J)) GOTO 30 50 CLK=CLK+ABS(X(L,J)-X(K,J)) 30 CONTINUE RPRES=NPRES IF(NPRES.NE.0)GOTO 60 JHALT=1 WRITE(LUB,9400)LAB(1,L),LAB(2,L),LAB(3,L),LAB(1,K),LAB(2,K) F,LAB(3,K) IF(FNAMEB.NE.'CON')WRITE(*,9400)LAB(1,L),LAB(2,L),LAB(3,L), F LAB(1,K),LAB(2,K),LAB(3,K) DYS(NLK)=0.0 GOTO 20 60 IF(NDYST.NE.1)GOTO 70 DYS(NLK)=SQRT(CLK*(PP/RPRES)) GOTO 20 70 DYS(NLK)=CLK*(PP/RPRES) 20 CONTINUE 100 CONTINUE RETURN 9400 FORMAT(' OBJECTS ',3A1,' AND ',3A1, F ' HAVE NO COMMON MEASUREMENTS.') END CC CC SUBROUTINE BSWAP(KK,NN,MAXNN,NREPR,DYSMA,DYSMB,BETER,MAXHH,DYS F,SKY,S,LUB) DIMENSION NREPR(MAXNN),DYSMA(MAXNN),DYSMB(MAXNN),BETER(MAXNN) DIMENSION DYS(MAXHH) CC CC FIRST ALGORITHM: BUILD. CC NNY=0 DO 17 J=1,NN NREPR(J)=0 DYSMA(J)=1.1*S+1.0 17 CONTINUE 20 DO 22 JA=1,NN IF(NREPR(JA).NE.0)GO TO 22 BETER(JA)=0. DO 21 J=1,NN NJAJ=MEET(JA,J) CMD=DYSMA(J)-DYS(NJAJ) IF(CMD.GT.0.0)BETER(JA)=BETER(JA)+CMD 21 CONTINUE 22 CONTINUE AMMAX=0. DO 31 JA=1,NN IF(NREPR(JA).NE.0)GO TO 31 IF(BETER(JA).LT.AMMAX)GO TO 31 AMMAX=BETER(JA) NMAX=JA 31 CONTINUE NREPR(NMAX)=1 NNY=NNY+1 DO 41 J=1,NN NJN=MEET(NMAX,J) IF(DYS(NJN).LT.DYSMA(J))DYSMA(J)=DYS(NJN) 41 CONTINUE IF(NNY.NE.KK)GO TO 20 SKY=0. DO 51 J=1,NN SKY=SKY+DYSMA(J) 51 CONTINUE IF(KK.EQ.1)RETURN RNN=NN ASKY=SKY/RNN WRITE(LUB,9100)ASKY CC CC SECOND ALGORITHM: SWAP. CC 60 DO 63 J=1,NN DYSMA(J)=1.1*S+1.0 DYSMB(J)=1.1*S+1.0 DO 62 JA=1,NN IF(NREPR(JA).EQ.0)GO TO 62 NJAJ=MEET(JA,J) IF(DYS(NJAJ).GE.DYSMA(J))GO TO 61 DYSMB(J)=DYSMA(J) DYSMA(J)=DYS(NJAJ) GO TO 62 61 IF(DYS(NJAJ).GE.DYSMB(J))GO TO 62 DYSMB(J)=DYS(NJAJ) 62 CONTINUE 63 CONTINUE DZSKY=1.0 DO 73 K=1,NN IF(NREPR(K).EQ.1)GO TO 73 DO 72 JA=1,NN IF(NREPR(JA).EQ.0)GO TO 72 DZ=0. DO 71 J=1,NN NJAJ=MEET(JA,J) NKJ=MEET(K,J) IF(DYS(NJAJ).NE.DYSMA(J))GO TO 70 SMALL=DYSMB(J) IF(DYS(NKJ).LT.SMALL)SMALL=DYS(NKJ) DZ=DZ-DYSMA(J)+SMALL GO TO 71 70 IF(DYS(NKJ).LT.DYSMA(J))DZ=DZ-DYSMA(J)+DYS(NKJ) 71 CONTINUE IF(DZ.GE.DZSKY)GO TO 72 DZSKY=DZ KBEST=K NBEST=JA 72 CONTINUE 73 CONTINUE IF(DZSKY.GE.0.)RETURN NREPR(KBEST)=1 NREPR(NBEST)=0 SKY=SKY+DZSKY GO TO 60 9100 FORMAT(1X//16H RESULT OF BUILD/2X, F25H AVERAGE DISSIMILARITY = ,F12.3) END CC CC SUBROUTINE CSTAT(KK,NN,NSEND,NREPR,RADUS,DAMER,TTD,SEPAR,Z,S, FMAXHH,DYS,NCLUV,NELEM,JPP,MAXNN,MAXPP,X,LAB,LUB,JDYSS,NSTAN) DIMENSION NCLUV(MAXNN),NSEND(MAXNN),NREPR(MAXNN),NELEM(MAXNN) DIMENSION SEPAR(MAXNN),DAMER(MAXNN),RADUS(MAXNN),TTD(MAXNN) DIMENSION X(MAXNN,MAXPP),DYS(MAXHH) CHARACTER LAB(3,MAXNN),JDRAW(30) DO 130 J=1,NN IF(NREPR(J).EQ.1)GO TO 120 DSMAL=1.1*S+1.0 DO 110 K=1,NN IF(NREPR(K).EQ.0)GO TO 110 NJAJ=MEET(K,J) IF(DYS(NJAJ).GE.DSMAL)GO TO 110 DSMAL=DYS(NJAJ) KSMAL=K 110 CONTINUE NSEND(J)=KSMAL GO TO 130 120 NSEND(J)=J 130 CONTINUE JK=1 NPLAC=NSEND(1) DO 135 J=1,NN NCLUV(J)=0 IF(NSEND(J).EQ.NPLAC)NCLUV(J)=1 135 CONTINUE DO 145 JA=2,NN NPLAC=NSEND(JA) IF(NCLUV(NPLAC).NE.0)GO TO 145 JK=JK+1 DO 140 J=2,NN IF(NSEND(J).EQ.NPLAC)NCLUV(J)=JK 140 CONTINUE IF(JK.EQ.KK)GO TO 148 145 CONTINUE CC CC ANALYSIS OF THE CLUSTERING. CC 148 WRITE(LUB,9200) DO 160 NUMCL=1,KK NTT=0 RADUS(NUMCL)=-1.0 TTT=0.0 DO 150 J=1,NN IF(NCLUV(J).NE.NUMCL)GO TO 150 NTT=NTT+1 M=NSEND(J) NELEM(NTT)=J NJM=MEET(J,M) TTT=TTT+DYS(NJM) IF(DYS(NJM).GT.RADUS(NUMCL))RADUS(NUMCL)=DYS(NJM) 150 CONTINUE RTT=NTT TTD(NUMCL)=TTT/RTT NSS=NTT IF(NSS.GT.10)NSS=10 DO 152 L=1,NSS LEEN=3*(L-1)+1 LTWE=3*(L-1)+2 LDRE=3*L NCASE=NELEM(L) JDRAW(LEEN)=LAB(1,NCASE) JDRAW(LTWE)=LAB(2,NCASE) JDRAW(LDRE)=LAB(3,NCASE) 152 CONTINUE NSSDR=NSS*3 WRITE(LUB,9210)NUMCL,LAB(1,M),LAB(2,M),LAB(3,M),NTT, F(JDRAW(K),K=1,NSSDR) IF(NTT.LE.10)GO TO 160 KAUNT=0 DO 154 L=11,NTT KAUNT=KAUNT+1 LEEN=3*(KAUNT-1)+1 LTWE=3*(KAUNT-1)+2 LDRE=3*KAUNT NCASE=NELEM(L) JDRAW(LEEN)=LAB(1,NCASE) JDRAW(LTWE)=LAB(2,NCASE) JDRAW(LDRE)=LAB(3,NCASE) IF(KAUNT.EQ.10)GO TO 156 GO TO 154 156 WRITE(LUB,9215)(JDRAW(K),K=1,30) KAUNT=0 154 CONTINUE IF(KAUNT.GE.1)WRITE(LUB,9215)(JDRAW(K),K=1,LDRE) 160 CONTINUE IF(JDYSS.EQ.1)GO TO 230 IF(NSTAN.EQ.0)WRITE(LUB,9220) IF(NSTAN.EQ.1)WRITE(LUB,9230) DO 210 NUMCL=1,KK DO 220 L=1,NN IF(NCLUV(L).EQ.NUMCL)GO TO 225 220 CONTINUE 225 M=NSEND(L) WRITE(LUB,9240)LAB(1,M),LAB(2,M),LAB(3,M),(X(M,J),J=1,JPP) 210 CONTINUE 230 RNN=NN IF(KK.NE.1)GO TO 240 DAMER(1)=S GO TO 300 240 WRITE(LUB,9270) WRITE(LUB,9280)(NCLUV(J),J=1,NN) WRITE(LUB,9290) CC CC NUML = NUMBER OF L-CLUSTERS. CC NUML=0 DO 40 K=1,KK CC CC IDENTIFICATION OF CLUSTER K: CC NEL=NUMBER OF OBJECTS CC NELEM=VECTOR OF OBJECTS CC NEL=0 DO 23 J=1,NN IF(NCLUV(J).NE.K)GO TO 23 NEL=NEL+1 NELEM(NEL)=J 23 CONTINUE IF(NEL.NE.1)GO TO 24 NVN=NELEM(1) DAMER(K)=0. SEPAR(K)=1.1*S+1.0 DO 250 J=1,NN IF(J.EQ.NVN)GO TO 250 MEVJ=MEET(NVN,J) IF(SEPAR(K).GT.DYS(MEVJ))SEPAR(K)=DYS(MEVJ) 250 CONTINUE CC CC IS CLUSTER K 1) AN L-CLUSTER ? CC 2) AN L*-CLUSTER ? CC IF(SEPAR(K).EQ.0.)GO TO 400 NUML=NUML+1 WRITE(LUB,9310)K WRITE(LUB,9320)LAB(1,NVN),LAB(2,NVN),LAB(3,NVN),SEPAR(K) GO TO 40 400 WRITE(LUB,9324)K,LAB(1,NVN),LAB(2,NVN),LAB(3,NVN) WRITE(LUB,9326) GO TO 40 24 DAM=-1. SEP=1.1*S+1.0 KAND=1 DO 26 JA=1,NEL NVNA=NELEM(JA) AJA=-1. AJB=1.1*S+1.0 DO 25 JB=1,NN JNDZ=MEET(NVNA,JB) IF(NCLUV(JB).EQ.K)GO TO 30 IF(DYS(JNDZ).LT.AJB)AJB=DYS(JNDZ) GO TO 25 30 IF(DYS(JNDZ).GT.AJA)AJA=DYS(JNDZ) 25 CONTINUE IF(AJA.GE.AJB)KAND=0 IF(DAM.LT.AJA)DAM=AJA IF(SEP.GT.AJB)SEP=AJB 26 CONTINUE SEPAR(K)=SEP DAMER(K)=DAM IF(KAND.EQ.0)GO TO 40 CC CC DIAMETER AND SEPARATION OF ISOLATED CLUSTERS CC WRITE(LUB,9310)K WRITE(LUB,9330)DAM,SEP NUML=NUML+1 IF(DAM.LT.SEP)GO TO 27 WRITE(LUB,9340) GO TO 40 27 WRITE(LUB,9350) 40 CONTINUE IF(NUML.EQ.0)WRITE(LUB,9360) IF(NUML.GE.1)WRITE(LUB,9365)NUML 300 WRITE(LUB,9370)(DAMER(J),J=1,KK) IF(KK.NE.1)WRITE(LUB,9380)(SEPAR(J),J=1,KK) WRITE(LUB,9390)(TTD(J),J=1,KK) WRITE(LUB,9400)(RADUS(J),J=1,KK) RETURN 9200 FORMAT(1X,11H CLUSTERS /2X,22H NUMBER MEDOID SIZE, F13H OBJECTS) 9210 FORMAT(/1X,I5,6X,3A1,2X,I6,5X,10(3A1,1X)) 9215 FORMAT(28X,10(3A1,1X)) 9220 FORMAT(//1X,22HCOORDINATES OF MEDOIDS/1X,22(1H*)/) 9230 FORMAT(//1X,42HCOORDINATES OF MEDOIDS (USING STANDARDIZED, F14H MEASUREMENTS)/1X,56(1H*)/) 9240 FORMAT(1X,3A1,2X,125(8F9.2/6X)) 9270 FORMAT(//18H CLUSTERING VECTOR/1X,17(1H*)/) 9280 FORMAT(11X,50(20I3/11X)) 9290 FORMAT(//27H CLUSTERING CHARACTERISTICS/1X,26(1H*)/) 9310 FORMAT(1X,9H CLUSTER ,I4,13H IS ISOLATED,) 9320 FORMAT(8X,41H IT IS A SINGLETON CONSISTING OF OBJECT ,3A1/ F8X,17H ITS SEPARATION =,F11.2/) 9324 FORMAT(1X,9H CLUSTER ,I4,29H IS A SINGLETON CONSISTING OF, F8H OBJECT ,3A1,21H. IT IS NOT ISOLATED.) 9326 FORMAT(1X,47H ** IT IS NOT ADVISABLE TO DIVIDE THE DATA INTO, F18H SO MANY CLUSTERS./) 9330 FORMAT(8X,' WITH DIAMETER =',F11.2,' AND SEPARATION =',F11.2) 9340 FORMAT(8X,20H IT IS AN L-CLUSTER./) 9350 FORMAT(8X,31H THEREFORE IT IS AN L*-CLUSTER./) 9360 FORMAT(1X,31H THERE ARE NO ISOLATED CLUSTERS) 9365 FORMAT(1X,35H THE NUMBER OF ISOLATED CLUSTERS = ,I4) 9370 FORMAT(//26H DIAMETER OF EACH CLUSTER,125(/2X,8F9.2)) 9380 FORMAT(/28H SEPARATION OF EACH CLUSTER,125(/2X,8F9.2)) 9390 FORMAT(/38H AVERAGE DISSIMILARITY TO EACH MEDOID, F125(/2X,8F9.2)) 9400 FORMAT(/38H MAXIMUM DISSIMILARITY TO EACH MEDOID, F125(/2X,8F9.2)) END CC CC SUBROUTINE DARK(KK,NN,MAXNN,MAXHH,NCLUV,NSEND,NELEM,NEGBR F,SYL,SRANK,AVSYL,DYS,LAB,LUB,S,NUM) DIMENSION NCLUV(MAXNN),NSEND(MAXNN),NELEM(MAXNN),NEGBR(MAXNN) DIMENSION SYL(MAXNN),SRANK(MAXNN),AVSYL(MAXNN),DYS(MAXHH) CHARACTER LAB(3,MAXNN),JDRAW(51),NUM(13),JBLAN,JSTAR,JSEPA JBLAN=NUM(11) JSTAR=NUM(12) JSEPA=NUM(13) WRITE(LUB,9500) WRITE(LUB,9510) DO 10 LL=1,51 JDRAW(LL)=JSEPA 10 CONTINUE WRITE(LUB,9515)(JDRAW(LL),LL=1,51),JSEPA,JSEPA,JSEPA TTSYL=0.0 DO 100 NUMCL=1,KK NTT=0 DO 30 J=1,NN IF(NCLUV(J).NE.NUMCL)GO TO 30 NTT=NTT+1 NELEM(NTT)=J 30 CONTINUE DO 40 J=1,NTT NJ=NELEM(J) DYSB=1.1*S+1.0 NEGBR(J)=-1 DO 41 NCLU=1,KK IF(NCLU.EQ.NUMCL)GO TO 41 NBB=0 DB=0.0 DO 43 L=1,NN IF(NCLUV(L).NE.NCLU)GO TO 43 NBB=NBB+1 MJL=MEET(NJ,L) DB=DB+DYS(MJL) 43 CONTINUE BTT=NBB DB=DB/BTT IF(DB.GE.DYSB)GO TO 41 DYSB=DB NEGBR(J)=NCLU 41 CONTINUE IF(NTT.EQ.1)GO TO 50 DYSA=0.0 DO 45 L=1,NTT NL=NELEM(L) NJL=MEET(NJ,NL) DYSA=DYSA+DYS(NJL) 45 CONTINUE ATT=NTT-1 DYSA=DYSA/ATT IF(DYSA.GT.0.0)GO TO 51 IF(DYSB.GT.0.0)GO TO 52 50 SYL(J)=0.0 GO TO 40 52 SYL(J)=1.0 GO TO 40 51 IF(DYSB.LE.0.0)GO TO 53 IF(DYSB.GT.DYSA)SYL(J)=1.0-DYSA/DYSB IF(DYSB.LT.DYSA)SYL(J)=DYSB/DYSA-1.0 IF(DYSB.EQ.DYSA)SYL(J)=0.0 GO TO 54 53 SYL(J)=-1.0 54 IF(SYL(J).LE.(-1.0))SYL(J)=-1.0 IF(SYL(J).GE.1.0)SYL(J)=1.0 40 CONTINUE AVSYL(NUMCL)=0.0 DO 60 J=1,NTT SYMAX=-2.0 DO 70 L=1,NTT IF(SYL(L).LE.SYMAX)GO TO 70 SYMAX=SYL(L) LANG=L 70 CONTINUE NSEND(J)=LANG SRANK(J)=SYL(LANG) AVSYL(NUMCL)=AVSYL(NUMCL)+SRANK(J) SYL(LANG)=-3.0 60 CONTINUE TTSYL=TTSYL+AVSYL(NUMCL) RTT=NTT AVSYL(NUMCL)=AVSYL(NUMCL)/RTT IF(NTT.GE.2)GOTO 75 NCASE=NELEM(1) DO 65 LL=2,50 JDRAW(LL)=JBLAN 65 CONTINUE WRITE(LUB,9525)NUMCL,NEGBR(1),LAB(1,NCASE),LAB(2,NCASE), FLAB(3,NCASE),JSEPA,(JDRAW(LL),LL=2,50),JSEPA GOTO 96 75 DO 80 L=1,NTT LPLAC=NSEND(L) NCASE=NELEM(LPLAC) NEG=NEGBR(LPLAC) TRUN=SRANK(L) IF(SRANK(L).LE.0.0)TRUN=0.0 LENGT=TRUN*50.0+1.1 DO 90 LL=2,51 JDRAW(LL)=JBLAN 90 CONTINUE IF(LENGT.LE.1)GOTO 95 DO 91 LL=2,LENGT JDRAW(LL)=JSTAR 91 CONTINUE 95 WRITE(LUB,9520)NUMCL,NEG,SRANK(L),LAB(1,NCASE),LAB(2,NCASE), FLAB(3,NCASE),(JDRAW(J),J=1,51),JSEPA 80 CONTINUE 96 IF(NUMCL.LT.KK)WRITE(LUB,9530)JSEPA,JSEPA 100 CONTINUE DO 105 LL=1,51 JDRAW(LL)=JSEPA 105 CONTINUE WRITE(LUB,9516)JSEPA,JSEPA,(JDRAW(LL),LL=1,51),JSEPA WRITE(LUB,9510) WRITE(LUB,9517) DO 110 NUMCL=1,KK WRITE(LUB,9540)NUMCL,AVSYL(NUMCL) 110 CONTINUE RNN=NN TTSYL=TTSYL/RNN WRITE(LUB,9550)TTSYL RETURN 9500 FORMAT(//31X,17(1H*)/31X,1H*,15X,1H*/31X, F17H* SILHOUETTES */31X,1H*,15X,1H*/31X,17(1H*)/) 9510 FORMAT(/22X,25(2H0 ),1H1/22X,26(2H. )/22X,6H0 0 0 , F46H1 1 2 2 2 3 3 4 4 4 5 5 6 6 6 7 7 8 8 8 9 9 0 ) 9515 FORMAT(22X,5(10H0 4 8 2 6 ),1H0//1X,21H CLU NEIG S(I) I , F52A1/22X,A1,50X,A1) 9516 FORMAT(22X,A1,50X,A1/22X,52A1) 9517 FORMAT(22X,5(10H0 4 8 2 6 ),1H0//) 9520 FORMAT(1X,I4,1X,I4,1X,F5.2,3X,55A1) 9525 FORMAT(1X,I4,1X,I4,2X,4H .00,3X,53A1,1H1,A1) 9530 FORMAT(22X,A1,50X,A1) 9540 FORMAT(8X,'CLUSTER ',I4,' HAS AVERAGE SILHOUETTE WIDTH ',F5.2) 9550 FORMAT(/7X,37H FOR THE ENTIRE DATA SET, THE AVERAGE, F21H SILHOUETTE WIDTH IS ,F5.2//) END CC CC SUBROUTINE ENTR(NN,JPP,KBEG,KEND,MAXNN,MAXTT,MAXPP,MAXHH,X, F DVEC,DYS,VALMD,JTMD,JPLACE,HULP,NUM,LUA,LUB,LUC,FNAMEA, F FNAMEB,FNAMEC,LAB,JLAB,NAME,YNSAVE,JDYSS,NSTAN,NDYST,LARGE, F LGRAP,JLABS,NFF,JFMT,MDATA) DIMENSION X(MAXNN,MAXPP),DVEC(MAXNN),DYS(MAXHH) DIMENSION VALMD(MAXPP),JTMD(MAXPP),JPLACE(MAXPP),HULP(MAXTT) CHARACTER STAN,DYSS,DYST,CYNFF,YNSAVE,CARGE,CGRAP,CLABS,CMDT CHARACTER CDATA,CYNK,CEX,LAB(3,MAXNN),JLAB(10,MAXPP) CHARACTER NUM(13) CHARACTER*30 FNAMEA,FNAMEB,FNAMEC CHARACTER*60 JFMT,NAME NUM(1)='0' NUM(2)='1' NUM(3)='2' NUM(4)='3' NUM(5)='4' NUM(6)='5' NUM(7)='6' NUM(8)='7' NUM(9)='8' NUM(10)='9' NUM(11)=' ' NUM(12)='*' NUM(13)='+' YNSAVE=' ' NSTAN=0 WRITE (*,9500) WRITE(*,9505) WRITE(*,9507) 100 WRITE(*,9510) 110 READ(*,8500)DYSS JDYSS=2 IF(DYSS.EQ.'D'.OR.DYSS.EQ.'d')JDYSS=1 IF(DYSS.EQ.'M'.OR.DYSS.EQ.'m')JDYSS=0 IF(JDYSS.NE.2)GO TO 120 WRITE(*,9520) GO TO 110 120 WRITE (*,9525)MAXNN 130 WRITE (*,9530)MAXNN READ (*,*) NN IF(NN.LE.MAXNN) GOTO 140 WRITE(*,9520) GOTO 130 140 IF(NN.GE.3)GO TO 150 WRITE(*,9540) GOTO 130 150 WRITE(*,9550) 160 WRITE(*,9560) READ(*,*)KBEG IF(KBEG.GE.1)GO TO 170 WRITE(*,9570)KBEG GO TO 160 170 IF(KBEG.LE.NN)GO TO 180 WRITE(*,9580)KBEG,NN GO TO 160 180 WRITE(*,9590) READ(*,*)KEND IF(KEND.GE.KBEG)GO TO 190 WRITE(*,9600) GO TO 160 190 IF(KEND.LE.NN)GO TO 200 WRITE(*,9610)KEND,NN GO TO 180 200 IF(JDYSS.EQ.1)GO TO 500 CC CC IN THIS SECTION SPECIFIC INFORMATION RELATED TO THE INPUT CC OF MEASUREMENTS IS ENTERED : CC TOTAL NUMBER OF VARIABLES (JPPT) CC NUMBER OF VARIABLES TO BE USED IN THE ANALYSIS (JPP) CC VARIABLES TO BE USED IN THE ANALYSIS AND THEIR LABELS CC CHOICE OF STANDARDIZATION CC CHOICE OF EUCLIDEAN OR MANHATTAN DISTANCE CC WRITE(*,9620)MAXTT,MAXPP 300 WRITE(*,9630)MAXTT READ(*,*)JPPT IF(JPPT.NE.1)GO TO 310 JPP=1 GO TO 350 310 IF(JPPT.GE.1.AND.JPPT.LE.MAXTT)GO TO 320 WRITE(*,9520) GO TO 300 320 JPPA=MAXPP IF(JPPA.GT.JPPT)JPPA=JPPT 330 WRITE(*,9640)JPPA READ(*,*)JPP IF(JPP.GE.1.AND.JPP.LE.JPPA)GO TO 340 WRITE(*,9520) GO TO 330 340 IF(JPPT.GT.JPP)GO TO 370 350 WRITE(*,9650) DO 360 J=1,JPP JPLACE(J)=J WRITE(*,9660)J READ(*,8500)(JLAB(K,J),K=1,10) 360 CONTINUE GO TO 410 370 WRITE(*,9670) DO 400 J=1,JPP 380 WRITE(*,9680)J READ(*,8510)JPLACE(J),(JLAB(K,J),K=1,10) IF(JPLACE(J).LT.1.OR.JPLACE(J).GT.JPPT)GO TO 380 IF(J.EQ.1)GO TO 400 JPPL=J-1 DO 390 JK=1,JPPL IF(JPLACE(JK).NE.JPLACE(J))GO TO 390 WRITE(*,9690) GO TO 380 390 CONTINUE 400 CONTINUE 410 WRITE(*,9700) CALL QYN(STAN,NSTAN) WRITE(*,9710) 420 READ(*,8500)DYST NDYST=0 IF(DYST.EQ.'E'.OR.DYST.EQ.'e')NDYST=1 IF(DYST.EQ.'M'.OR.DYST.EQ.'m')NDYST=2 IF(NDYST.NE.0)GO TO 500 WRITE(*,9520) GO TO 420 CC CC OUTPUT SECTION : CC TITLE CC SMALL OR LARGE OUTPUT CC GRAPHICAL OUTPUT (SILHOUETTES) CC LABELS OF OBJECTS CC 500 WRITE (*,9720) READ (*,8520)NAME WRITE(*,9730) IF(NSTAN.EQ.1)WRITE(*,9732) IF(NSTAN.EQ.0)WRITE(*,9734) CALL QYN(CARGE,LARGE) WRITE(*,9740) CALL QYN(CGRAP,LGRAP) WRITE(*,9750) CALL QYN(CLABS,JLABS) IF(JLABS.EQ.0)GO TO 520 WRITE(*,9760) DO 510 J=1,NN WRITE(*,9770)J READ(*,8500)LAB(1,J),LAB(2,J),LAB(3,J) 510 CONTINUE GO TO 550 520 CALL NWLAB(NN,MAXNN,NUM,LAB) CC CC FORMATS CC 550 WRITE (*,9780) CALL QYN(CYNFF,NFF) IF (CYNFF.EQ.'Y') GOTO 600 WRITE(*,9790) READ (*,8520)JFMT CC CC STATUS OF INPUT AND OUTPUT : KEYBOARD, SCREEN, PRINTER, FILE CC 600 WRITE(*,9800) READ(*,8530)FNAMEA IF(FNAMEA.EQ.'KEY'.OR.FNAMEA.EQ.'key'.OR.FNAMEA.EQ.'Key') F GO TO 610 YNSAVE='N' NSAVE=0 GO TO 650 610 FNAMEA='CON' WRITE(*,9810) CALL QYN(YNSAVE,NSAVE) IF (YNSAVE.EQ.'N')GO TO 650 620 WRITE(*,9820) READ(*,8530)FNAMEC OPEN(LUC,FILE=FNAMEC,STATUS='NEW',IOSTAT=NEG,ERR=630) GO TO 650 630 IF(NEG.NE.1027.AND.NEG.NE.1030.AND.NEG.NE.1032. F AND.NEG.NE.1033.AND.NEG.NE.1045)GO TO 640 WRITE(*,9832) GO TO 620 640 WRITE(*,9834)NEG STOP 650 OPEN(LUA,FILE=FNAMEA,IOSTAT=NER,ERR=660) GO TO 670 660 IF(FNAMEA.NE.'CON'.AND.(NER.EQ.1027.OR.NER.EQ.1030.OR. F NER.EQ.1032.OR.NER.EQ.1033))THEN WRITE(*,9836) GO TO 600 ENDIF WRITE(*,9834)NER STOP 670 WRITE(*,9830) READ(*,8530)FNAMEB IF(FNAMEB.EQ.'con'.OR.FNAMEB.EQ.'Con')FNAMEB='CON' IF(FNAMEB.EQ.'prn'.OR.FNAMEB.EQ.'Prn')FNAMEB='PRN' IF (FNAMEB.EQ.'CON'.OR.FNAMEB.EQ.'PRN')OPEN(LUB,FILE=FNAMEB) IF (.NOT.(FNAMEB.EQ.'CON'.OR.FNAMEB.EQ.'PRN'))OPEN(LUB, F FILE=FNAMEB,STATUS='NEW',IOSTAT=NET,ERR=680) GO TO 695 680 IF(NET.NE.1027.AND.NET.NE.1030.AND.NET.NE.1032. F AND.NET.NE.1033.AND.NET.NE.1045)GO TO 690 WRITE(*,9832) GO TO 670 690 WRITE(*,9834)NET STOP 695 IF(JDYSS.EQ.1)GO TO 800 CC CC SECTION ON MISSING DATA CC WRITE (*,9840) CALL QYN(CDATA,MDATA) IF(MDATA.EQ.0) GO TO 740 WRITE(*,9850) CALL QYN(CMDT,MDT) IF(MDT.EQ.0)GO TO 710 WRITE(*,9860) READ(*,*)VVAL DO 700 J=1,JPP JTMD(J)=-1 VALMD(J)=VVAL 700 CONTINUE GO TO 800 710 DO 730 J=1,JPP WRITE (*,9870)(JLAB(K,J),K=1,10) CALL QYN(CYNK,NYNK) IF (CYNK.EQ.'Y')GO TO 720 JTMD(J)=1 VALMD(J)=-99.99 GO TO 730 720 JTMD(J)=-1 WRITE(*,9880) READ (*,*) VALMD(J) 730 CONTINUE GO TO 800 740 DO 750 J=1,JPP JTMD(J)=1 VALMD(J)=-99.99 750 CONTINUE CC CC RECAPITULATION OF OPTIONS CC 800 WRITE(*,9890) WRITE (*,9900) WRITE (*,9905)NAME WRITE(*,9910)NN IF(CLABS.EQ.'Y')WRITE(*,8070) IF(CLABS.EQ.'N')WRITE(*,8075) IF(JDYSS.EQ.1)WRITE(*,8080) IF(JDYSS.EQ.0)WRITE(*,8085) IF(CARGE.EQ.'Y')WRITE(*,8090) IF(CARGE.EQ.'N')WRITE(*,8095) IF(CGRAP.EQ.'Y')WRITE(*,8100) IF(CGRAP.EQ.'N')WRITE(*,8105) WRITE(*,8110)KBEG,KEND IF(JDYSS.EQ.1)GO TO 840 IF(JPPT.GT.1)GO TO 810 WRITE(*,8118) GO TO 820 810 WRITE(*,8115)JPPT IF(JPP.GT.1)WRITE(*,8116)JPP IF(JPP.EQ.1)WRITE(*,8119)(JLAB(K,1),K=1,10),JPLACE(1) 820 IF(STAN.EQ.'Y')WRITE(*,8120) IF(STAN.EQ.'N')WRITE(*,8125) IF(NDYST.EQ.1)WRITE(*,8130) IF(NDYST.EQ.2)WRITE(*,8135) IF(CDATA.EQ.'N')WRITE(*,8145) IF(CDATA.EQ.'N')GO TO 830 IF(CMDT.EQ.'N')WRITE(*,8140) IF(CMDT.EQ.'Y')WRITE(*,8142) IF(CMDT.EQ.'Y')WRITE(*,*)VVAL 830 IF (CYNFF.EQ.'Y') WRITE(*,8160) IF (CYNFF.EQ.'N') WRITE(*,8165) JFMT GO TO 850 840 IF (CYNFF.EQ.'Y') WRITE(*,8170) IF (CYNFF.EQ.'N') WRITE(*,8175) JFMT 850 IF (FNAMEA.NE.'CON') WRITE(*,8039) FNAMEA IF (FNAMEA.EQ.'CON') WRITE(*,8034) IF (YNSAVE.EQ.'Y') WRITE(*,8038) FNAMEC WRITE(*,8040) FNAMEB WRITE (*,8030) CALL QYN(CEX,NEX) IF (CEX.NE.'Y') GOTO 100 IF(FNAMEB.EQ.'CON')GO TO 900 WRITE(LUB,9500) WRITE(LUB,9505) WRITE(LUB,9507) WRITE(LUB,9905)NAME WRITE(LUB,9900) WRITE(LUB,9910)NN IF(JLABS.NE.0)WRITE(LUB,8070) IF(JLABS.EQ.0)WRITE(LUB,8075) IF(JDYSS.NE.0)WRITE(LUB,8080) IF(JDYSS.EQ.0)WRITE(LUB,8085) IF(LARGE.NE.0)WRITE(LUB,8090) IF(LARGE.EQ.0)WRITE(LUB,8095) IF(LGRAP.NE.0)WRITE(LUB,8100) IF(LGRAP.EQ.0)WRITE(LUB,8105) WRITE(LUB,8110)KBEG,KEND IF(JDYSS.EQ.1)GO TO 880 IF(JPPT.GT.1)GO TO 852 WRITE(LUB,8118) GO TO 865 852 WRITE(LUB,8115)JPPT IF(JPP.GT.1)GO TO 854 WRITE(LUB,8119)(JLAB(K,1),K=1,10),JPLACE(1) GO TO 865 854 WRITE(LUB,8116)JPP WRITE(LUB,8114) DO 860 J=1,JPP WRITE(LUB,8117)(JLAB(K,J),K=1,10),JPLACE(J) 860 CONTINUE 865 IF(NSTAN.EQ.0)WRITE(LUB,8125) IF(NSTAN.EQ.1)WRITE(LUB,8120) IF(NDYST.EQ.1)WRITE(LUB,8130) IF(NDYST.EQ.2)WRITE(LUB,8135) IF(CDATA.EQ.'N')WRITE(LUB,8145) IF(CDATA.EQ.'N')GO TO 870 WRITE(LUB,8140) IF(CMDT.EQ.'Y')WRITE(LUB,8142) IF(CMDT.EQ.'Y')WRITE(LUB,*)VVAL 870 IF (CYNFF.EQ.'Y') WRITE(LUB,8160) IF (CYNFF.EQ.'N') WRITE(LUB,8165) JFMT GO TO 890 880 IF (CYNFF.EQ.'Y') WRITE(LUB,8170) IF (CYNFF.EQ.'N') WRITE(LUB,8175) JFMT 890 IF (FNAMEB.EQ.'CON') PAUSE ' ' IF(FNAMEB.NE.'CON')WRITE(LUB,*) IF (YNSAVE.EQ.'Y') WRITE(LUB,8038) FNAMEC IF (FNAMEA.NE.'CON') WRITE(LUB,8039) FNAMEA CC CC INPUT OF DATA CC 900 IF (FNAMEA.EQ.'CON') WRITE(*,8355) IF(JDYSS.EQ.1)GO TO 940 DO 930 L=1,NN IF (FNAMEA.NE.'CON')GO TO 910 WRITE(*,8359)JPPT,LAB(1,L),LAB(2,L),LAB(3,L) 910 IF (CYNFF.EQ.'N') READ(LUA,JFMT)(HULP(J),J=1,JPPT) IF (CYNFF.EQ.'Y') READ(LUA,*)(HULP(J),J=1,JPPT) DO 920 J=1,JPP JH=JPLACE(J) X(L,J)=HULP(JH) 920 CONTINUE IF (YNSAVE.EQ.'N')GO TO 930 IF (CYNFF.EQ.'N') WRITE(LUC,JFMT)(HULP(J),J=1,JPPT) IF (CYNFF.EQ.'Y') WRITE(LUC,*)(HULP(J),J=1,JPPT) 930 CONTINUE IF (YNSAVE.EQ.'Y') CLOSE(LUC,STATUS='KEEP') IF (YNSAVE.EQ.'Y') WRITE(*,8038) FNAMEC RETURN 940 DYS(1)=0.0 IF(FNAMEA.EQ.'CON')WRITE(*,8363) DO 990 L=2,NN LSUBT=L-1 IF (FNAMEA.NE.'CON')GO TO 950 IF (L.EQ.2) WRITE(*,8361) LAB(1,2),LAB(2,2),LAB(3,2), F LAB(1,1),LAB(2,1),LAB(3,1) IF (L.NE.2) WRITE(*,8362)LSUBT,LAB(1,L),LAB(2,L),LAB(3,L) 950 IF (CYNFF.EQ.'Y') READ(LUA,*)(DVEC(J),J=1,LSUBT) IF (CYNFF.EQ.'N') READ(LUA,JFMT)(DVEC(J),J=1,LSUBT) DO 980 J=1,LSUBT IF(DVEC(J).GE.0.)GO TO 970 IF(FNAMEA.EQ.'CON')GO TO 960 WRITE(*,8365)LAB(1,L),LAB(2,L),LAB(3,L),LAB(1,J),LAB(2,J), F LAB(3,J) STOP 960 WRITE(*,8370)LAB(1,L),LAB(2,L),LAB(3,L),LAB(1,J),LAB(2,J), F LAB(3,J),LAB(1,L),LAB(2,L),LAB(3,L) GO TO 950 970 NLJ=MEET(L,J) DYS(NLJ)=DVEC(J) 980 CONTINUE IF (YNSAVE.EQ.'N')GO TO 990 IF (CYNFF.EQ.'Y') WRITE(LUC,*)(DVEC(J),J=1,LSUBT) IF (CYNFF.EQ.'N') WRITE(LUC,JFMT)(DVEC(J),J=1,LSUBT) 990 CONTINUE IF (YNSAVE.EQ.'Y') CLOSE(LUC,STATUS='KEEP') IF (YNSAVE.EQ.'Y') WRITE(*,8038) FNAMEC 8030 FORMAT(/1X,' ARE ALL THESE OPTIONS OK? YES OR NO: '$) 8034 FORMAT(1X,' THE DATA WILL BE READ FROM THE KEYBOARD') 8038 FORMAT(1X,' THE DATA WILL BE SAVED IN FILE: ',A30) 8039 FORMAT(1X,' YOUR DATA RESIDE IN FILE: ',A30/) 8040 FORMAT(1X,' YOUR OUTPUT WILL BE WRITTEN IN: ',A30) 8070 FORMAT(1X,' LABELS OF OBJECTS ARE READ') 8075 FORMAT(1X,' LABELS OF OBJECTS ARE NOT READ') 8080 FORMAT(1X,' INPUT OF DISSIMILARITIES') 8085 FORMAT(1X,' INPUT OF MEASUREMENTS') 8090 FORMAT(1X,' LARGE OUTPUT IS WANTED') 8095 FORMAT(1X,' SMALL OUTPUT') 8100 FORMAT(1X,' GRAPHICAL OUTPUT IS WANTED (SILHOUETTES)') 8105 FORMAT(1X,' NO GRAPHICAL OUTPUT IS WANTED') 8110 FORMAT(1X,' CLUSTERINGS ARE CARRIED OUT IN ',I4, F' TO ',I4,' CLUSTERS') 8114 FORMAT(' THESE VARIABLES ARE :') 8115 FORMAT(/1X,' THERE ARE ',I4,' VARIABLES IN THE DATA SET,') 8116 FORMAT(1X,' AND 'I4,' OF THEM WILL BE USED IN THE ANALYSIS') 8117 FORMAT(10X,10A1,' (POSITION :',I3,')') 8118 FORMAT(/1X,' THERE IS ONE VARIABLE IN THE DATA SET') 8119 FORMAT(1X,' AND ONLY VARIABLE ',10A1,' WILL BE USED IN THE' F ' ANALYSIS (POSITION :',I3,')') 8120 FORMAT(1X,' THE MEASUREMENTS WILL BE STANDARDIZED') 8125 FORMAT(1X,' THE MEASUREMENTS WILL NOT BE STANDARDIZED') 8130 FORMAT(1X,' EUCLIDEAN DISTANCE WILL BE USED') 8135 FORMAT(1X,' MANHATTAN DISTANCE WILL BE USED') 8140 FORMAT(1X,' MISSING VALUES CAN OCCUR') 8142 FORMAT(1X,' THE UNIQUE VALUE WHICH REPRESENTS MISSING' F' MEASUREMENTS IS :'/6X$) 8145 FORMAT(1X,' THERE ARE NO MISSING VALUES') 8160 FORMAT(1X,' THE MEASUREMENTS WILL BE READ IN FREE FORMAT') 8165 FORMAT(1X,' THE INPUT FORMAT FOR THE MEASUREMENTS IS'/2X,A60) 8170 FORMAT(1X,' THE DISSIMILARITIES WILL BE READ IN FREE FORMAT') 8175 FORMAT(' THE INPUT FORMAT FOR THE DISSIMILARITIES IS'/2X,A60) 8355 FORMAT(//1X,'PLEASE ENTER YOUR DATA FOR EACH OBJECT'//) 8359 FORMAT(1X,'THE ',I3,' MEASUREMENTS FOR OBJECT ',3A1,' : '/) 8361 FORMAT(1X,' DISSIMILARITY BETWEEN OBJECTS ',3A1, F' AND ',3A1,' : '/) 8362 FORMAT(1X,' THE ',I4,' DISSIMILARITIES FOR OBJECT ',3A1, F' : '/) 8363 FORMAT(1X,' FOR OBJECT J, ENTER DISSIMILARITIES TO OBJECTS', F' 1,2,... ,(J-1) '//) 8365 FORMAT(/' THE DISSIMILARITY BETWEEN OBJECTS',3A1,' AND ',3A1, F' IS NEGATIVE,'/' UNFORTUNATELY THE PROGRAM MUST BE STOPPED.') 8370 FORMAT(/' THE DISSIMILARITY BETWEEN OBJECTS ',3A1,' AND ',3A1, F' IS NEGATIVE.'/1X,'PLEASE ENTER THE DISSIMILARITIES FOR', F' OBJECT ',3A1,' ONCE AGAIN :'/) 8500 FORMAT(10A1) 8510 FORMAT(BNI4,6X,10A1) 8520 FORMAT(A60) 8530 FORMAT(A30) 9500 FORMAT(////23X,33('*')/23X,'*',31X,'*'/23X, F '* PARTITIONING AROUND MEDOIDS *'/ F 23X,'*',31X,'*'/23X,33('*')//) 9505 FORMAT(/' Copyright (C) Leonard Kaufman and Peter' F ' Rousseeuw 1990. All rights reserved.'//) 9507 FORMAT(/5X,' This clustering algorithm', F ' is based on the k-medoid approach.', F /5X,' More information can be found in chapter 2 of:' F //5X,' L. Kaufman and P.J. Rousseeuw (1990),' F /5X,' Finding Groups in Data : An Introduction to' F ' Cluster Analysis,' F /5X,' Wiley, New York.'//) 9510 FORMAT(/' DO YOU WANT TO ENTER MEASUREMENTS ? (PLEASE' F' ANSWER M)'/' OR DO YOU PREFER TO GIVE' F' DISSIMILARITIES ? (THEN ANSWER D): '$) 9520 FORMAT(' NOT ALLOWED! PLEASE ENTER YOUR CHOICE AGAIN: '$) 9525 FORMAT(//' THE PRESENT VERSION OF THE PROGRAM CAN HANDLE' F ' UP TO',I6,' OBJECTS.'/' (IF MORE ARE TO BE CLUSTERED' F ', THE ARRAYS INSIDE THE PROGRAM MUST BE ADAPTED.)') 9530 FORMAT(/' HOW MANY OBJECTS ARE TO BE CLUSTERED? ', F /1X,38(1H-)/' PLEASE GIVE A NUMBER BETWEEN 3 AND ',I6,' : '$) 9540 FORMAT(/' AT LEAST 3 OBJECTS ARE NEEDED FOR CLUSTER ANALYSIS,' F','/' PLEASE FORESEE MORE OBJECTS.') 9550 FORMAT(/' CLUSTERINGS WILL BE CARRIED OUT IN K1 TO K2' F ' CLUSTERS.') 9560 FORMAT(' PLEASE ENTER K1 : '$) 9570 FORMAT(/' THE BEGINNING NUMBER OF CLUSTERS WAS GIVEN AS ',I6, F' ,'/' IT SHOULD BE AT LEAST ONE,') 9580 FORMAT(/' THE BEGINNING NUMBER OF CLUSTERS WAS GIVEN AS ',I6, F' ,'/' IT SHOULD NOT EXCEED THE NUMBER OF OBJECTS :',I6,' ,') 9590 FORMAT(' PLEASE ENTER K2 : '$) 9600 FORMAT(/' THE FINAL NUMBER OF CLUSTERS MAY NOT BE SMALLER' F' THAN THE BEGINNING'/' NUMBER OF CLUSTERS. PLEASE ENTER' F' BOTH NUMBERS AGAIN.') 9610 FORMAT(/' THE FINAL NUMBER OF CLUSTERS WAS GIVEN AS ',I7, F' ,'/' IT SHOULD NOT EXCEED THE NUMBER OF OBJECTS :',I5,' ,') 9620 FORMAT(//' THE PRESENT VERSION OF THE PROGRAM ALLOWS TO' F ' ENTER UP TO',I5,' VARIABLES,'/' OF WHICH AT MOST',I5, F ' CAN BE USED IN THE ACTUAL COMPUTATIONS.'/' (IF MORE ARE' F ' NEEDED, THE ARRAYS INSIDE THE PROGRAM MUST BE ADAPTED)') 9630 FORMAT(/' WHAT IS THE TOTAL NUMBER OF VARIABLES IN YOUR' F' DATA SET?'/1X,55(1H-)/ F' PLEASE GIVE A NUMBER BETWEEN 1 AND ',I6,' : '$) 9640 FORMAT(/' HOW MANY VARIABLES DO YOU WANT TO USE', F ' IN THE ANALYSIS?'/1X,54('-')/' (AT MOST ',I4,' ) : '$) 9650 FORMAT(//' VARIABLE TO BE USED ', F' LABEL (AT MOST 10 CHARACTERS)'/ F 1X,17(1H-),4(1H),6(1H-),10(1H),19(1H-)) 9660 FORMAT(' NUMBER : ',I4,6X$) 9670 FORMAT(//' VARIABLE TO BE USED : POSITION', F ' LABEL (AT MOST 10 CHARACTERS)'/ F 1X,32('-'),4(1H),6('-'),10(1H),19('-')) 9680 FORMAT(' NUMBER ',I4,15X,': '$) 9690 FORMAT(/' THIS POSITION HAS ALREADY BEEN CHOSEN FOR ANOTHER', F' VARIABLE.'/' ENTER THE RIGHT POSITION PLEASE : ') 9700 FORMAT(/' DO YOU WANT THE MEASUREMENTS TO BE STANDARDIZED' F '? (YES OR NO)....: '$) 9710 FORMAT(/' DO YOU WANT TO USE EUCLIDEAN DISTANCE ? (PLEASE' F' ANSWER E)'/' OR DO YOU PREFER MANHATTAN DISTANCE ?' F' (THEN ANSWER M)..............: '$) 9720 FORMAT(/' PLEASE ENTER A TITLE FOR THE OUTPUT (AT MOST 60' F ' CHARACTERS)'/1X,60(1H-)/1X$) 9730 FORMAT(/' DO YOU WANT LARGE OUTPUT ? (PLEASE ANSWER YES)'/ F' OR IS SMALL OUTPUT SUFFICIENT ? (THEN ANSWER NO)') 9732 FORMAT(' (IN THE LATTER CASE NO STANDARDIZED MEASUREMENTS OR' F/1X,' DISSIMILARITIES ARE GIVEN)',1X,40('.'),' : '$) 9734 FORMAT(' (IN THE LATTER CASE NO DISSIMILARITIES ARE GIVEN)' F,1X,18('.'),' : '$) 9740 FORMAT(/' DO YOU WANT GRAPHICAL OUTPUT (SILHOUETTES) ?' F' PLEASE ANSWER YES OR NO: '$) 9750 FORMAT(/' DO YOU WANT TO ENTER LABELS OF OBJECTS?' F' PLEASE ANSWER YES OR NO.....: '$) 9760 FORMAT(/' EACH LABEL MAY CONSIST OF AT MOST 3 CHARACTERS'/ F /' OBJECT LABEL'/ F 1X,12(1H-),4(1H),6(1H-),3(1H),5(1H-)) 9770 FORMAT(' NUMBER ',4X,I4,' : '$) 9780 FORMAT(/' DO YOU WANT TO READ THE DATA IN FREE FORMAT ?'/1X, F 45(1H-)/' THIS MEANS THAT YOU ONLY HAVE TO INSERT BLANK(S)', F ' BETWEEN NUMBERS.'/' (NOTE: WE ADVISE USERS WITHOUT', F ' KNOWLEDGE OF FORTRAN FORMATS TO ANSWER YES.)'/ F ' MAKE YOUR CHOICE (YES/NO): '$) 9790 FORMAT(/' YOUR DESIRED FORTRAN FORMAT IS :'/ F ' (BETWEEN BRACKETS AND', F ' AT MOST 60 CHARACTERS, e.g. (2F3.0,F1.0) )') 9800 FORMAT(/' PLEASE GIVE THE NAME OF THE FILE CONTAINING', F ' THE DATA (e.g. TYPE A:EXAMPLE.DAT)',/' OR TYPE', F ' KEY IF YOU PREFER TO ENTER THE DATA BY KEYBOARD.'/ F ' WHAT DO YOU CHOOSE? '$) 9810 FORMAT(/' DO YOU WANT TO SAVE YOUR DATA IN A FILE ?'/ F ' PLEASE ANSWER YES OR NO: ',$) 9820 FORMAT(/' IN WHICH FILE DO YOU WANT TO SAVE YOUR DATA ?'/ F ' (WARNING : IF THERE ALREADY EXISTS A FILE WITH THE SAME', F ' NAME'/12X,'THEN THE OLD FILE WILL BE OVERWRITTEN.)'/ F ' TYPE e.g. B:SAVE.DAT .................: '$) 9830 FORMAT(/' WHERE DO YOU WANT YOUR OUTPUT ?'/1X,32('-')/ F ' TYPE CON IF YOU WANT IT ON THE SCREEN'/ F ' OR TYPE PRN IF YOU WANT IT ON THE PRINTER'/ F ' OR TYPE THE NAME OF A FILE (e.g. B:EXAMPLE.OUT)'/ F ' (WARNING : IF THERE ALREADY EXISTS A FILE WITH THE SAME', F ' NAME'/12X,'THEN THE OLD FILE WILL BE OVERWRITTEN.)'/ F ' WHAT DO YOU CHOOSE ? ....................: '$) 9832 FORMAT(/' FILE NAME IS INCORRECT, PLEASE ENTER ANOTHER') 9834 FORMAT(/' FORTRAN ERROR CODE : ',I8) 9836 FORMAT(/' THIS FILE WAS NOT FOUND, PLEASE ENTER ANOTHER ONE') 9840 FORMAT(/' CAN MISSING DATA OCCUR IN THE MEASUREMENTS ?' F /' PLEASE ANSWER YES OR NO: '$) 9850 FORMAT(/' IS THERE A UNIQUE VALUE WHICH IS TO BE INTERPRETED'/ F ' AS A MISSING MEASUREMENT VALUE FOR ANY VARIABLE? '/ F ' PLEASE ANSWER YES OR NO: '$) 9860 FORMAT(/' PLEASE ENTER THIS VALUE NOW: '$) 9870 FORMAT(/' SHOULD MISSING VALUES BE FORESEEN FOR VARIABLE', F 1X,10A1,' ?'/' PLEASE ANSWER YES OR NO: '$) 9880 FORMAT(' ENTER THE VALUE OF THIS VARIABLE WHICH HAS TO BE' F ' INTERPRETED AS'/' THE MISSING VALUE CODE: '$) 9890 FORMAT(//////////) 9900 FORMAT(/' DATA SPECIFICATIONS AND CHOSEN OPTIONS'/1X,38('-')) 9905 FORMAT(' TITLE: ',A60/) 9910 FORMAT(' THERE ARE ',I4,' OBJECTS') RETURN END CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCCC file CLARA.FOR (Chapter 3) 44k CCCCCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC PROGRAM CLARA CC CLUSTERING LARGE APPLICATIONS CC CC CLUSTERING PROGRAM BASED UPON THE K-MEDOID APPROACH, CC AND SUITABLE FOR DATA SETS OF AT LEAST 100 OBJECTS. CC (FOR SMALLER DATA SETS, PLEASE USE PROGRAM PAM.) CC CC THE FOLLOWING VECTORS AND MATRICES MUST BE DIMENSIONED IN CC THE MAIN PROGRAM: CC X(MAXXX) CC HULP(MAXTT),JPLACE(MAXTT),JTMD(MAXTT),VALMD(MAXTT) CC NREPR(100),NSEL(100),NBEST(100),DYS(4951) CC NR(30),NRX(30),TTD(30),RADUS(30),RATT(30) CC TTBES(30),RDBES(30),RABES(30) CC CHARACTER NUM(13),JLAB(10,100) CC WHERE: CC MAXXX = MAXIMAL NUMBER OF MEASUREMENTS (OBJECTS*VARIABLES) CC MAXTT = MAXIMAL NUMBER OF VARIABLES CC 100 = MAXIMAL NUMBER OF OBJECTS DRAWN FROM DATA SET CC 4951 = 100*(100-1)/2 + 1 CC 30 = MAXIMAL NUMBER OF CLUSTERS CC DIMENSION X(3500) DIMENSION HULP(150),JPLACE(150),JTMD(150),VALMD(150) DIMENSION NREPR(100),NSEL(100),NBEST(100),DYS(4951) DIMENSION NR(30),NRX(30),TTD(30),RADUS(30),RATT(30) DIMENSION TTBES(30),RDBES(30),RABES(30) CHARACTER NUM(13),JLAB(10,100) CHARACTER*30 FNAMEA,FNAMEB CHARACTER*60 JFMT,NAME INTEGER*4 NRUN MAXXX=3500 MAXTT=150 CC CC LOGICAL INPUT AND OUTPUT UNITS : CC LUA = LOGICAL UNIT A (INPUT) CC LUB = LOGICAL UNIT B (OUTPUT) CC THE USER SHOULD ASSIGN TO LUA AND LUB THE NUMBERS USED BY HIS CC OWN COMPUTER : ONLY THE NEXT TWO STATEMENTS MUST BE CHANGED. CC LUA=1 LUB=2 CC CC NRAN = NUMBER OF RANDOM SAMPLES, MAY BE CHANGED BY THE USER CC NRAN=5 CC CALL ENTR(NN,JPP,MAXXX,MAXTT,HULP,JPLACE,X,VALMD,JTMD,NUM, F LUA,LUB,FNAMEA,FNAMEB,JLAB,NAME,KK,NSTAN,NDYST,LARGE,LGRAP, F NFF,JFMT,MDATA) RNN=NN NSAM=40+2*KK NNEQ=0 IF(NN.EQ.NSAM) NNEQ=1 NHALF=NSAM*(NSAM-1)/2+1 NSAMB=2*NSAM NNPP=NN*JPP CC CC INSPECTION OF OBJECTS FOR MISSING VALUES CC IF(MDATA.EQ.0)GO TO 100 JHALT=0 L=0 45 L=L+1 KAUNT=(L-1)*JPP DO 60 J=1,JPP IF(JTMD(J).GE.0)GO TO 50 NLJ=KAUNT+J IF(X(NLJ).NE.VALMD(J))GO TO 50 60 CONTINUE WRITE(LUB,9200)L JHALT=1 50 IF(L.LT.NN)GO TO 45 CC CC INSPECTION OF VARIABLES FOR MISSING VALUES CC MYST=0 NMAT=0 DO 90 J=1,JPP IF(JTMD(J).GE.0)GO TO 80 MYSJ=0 NDEX=J 70 IF(X(NDEX).EQ.VALMD(J))MYSJ=MYSJ+1 NDEX=NDEX+JPP IF(NDEX.LE.NNPP)GO TO 70 IF(MYSJ.GT.0)GO TO 85 80 WRITE(LUB,9210)(JLAB(K,J),K=1,10) NMAT=1 GO TO 90 85 MYST=MYST+MYSJ IF(MYSJ.EQ.NN)GO TO 87 WRITE(LUB,9211)(JLAB(K,J),K=1,10),MYSJ GO TO 90 87 WRITE(LUB,9212)(JLAB(K,J),K=1,10) IF(NFF.EQ.0)WRITE(LUB,9214) JHALT=1 90 CONTINUE WRITE(LUB,9215)MYST IF(JHALT.EQ.1)GO TO 510 IF(NMAT.EQ.0)WRITE(LUB,9220) CC CC STANDARDIZATION OF MEASUREMENTS CC 100 IF(NSTAN.EQ.0)GO TO 120 CALL STAND(NN,JPP,X,MAXXX,MAXTT,JTMD,VALMD,JHALT,JLAB,LUB,FNAMEB) IF(JHALT.EQ.1)GO TO 510 IF(LARGE.LE.1)GO TO 120 WRITE(LUB,9235) IF(MDATA.NE.0)WRITE(LUB,9236) NDEX=0 NEXB=0 110 NDEX=NDEX+1 NEXA=NEXB+1 NEXB=NEXB+JPP WRITE(LUB,9240)NDEX,(X(NEXAB),NEXAB=NEXA,NEXB) IF(NDEX.LT.NN)GO TO 110 CC CC IN DO 400, RANDOM SUBSAMPLES ARE DRAWN AND PARTITIONED CC INTO KK CLUSTERS CC 120 WRITE(LUB,9250)KK WRITE(LUB,9245)NRAN,NSAM NUNFS=0 LESS=NSAM IF(NN.LT.NSAMB)LESS=NN-NSAM KALL=0 NRUN=0 DO 400 JRAN=1,NRAN JHALT=0 IF(NNEQ.EQ.0)GO TO 140 IF(NNEQ.EQ.2)GO TO 400 NNEQ=2 DO 130 J=1,NSAM NSEL(J)=J 130 CONTINUE WRITE(LUB,9255) GO TO 330 140 IF(FNAMEB.EQ.'CON')PAUSE' ' WRITE(LUB,9260)JRAN IF(FNAMEB.NE.'CON')WRITE(*,9265)JRAN NTT=0 IF(JRAN.EQ.1.OR.NUNFS.EQ.JRAN.OR.NN.LT.NSAMB)GO TO 180 DO 150 JK=1,KK NSEL(JK)=NRX(JK) 150 CONTINUE KKM=KK-1 DO 170 JK=1,KKM NSM=NSEL(JK) KKP=JK+1 JSM=JK DO 160 JKK=KKP,KK IF(NSEL(JKK).GE.NSM)GO TO 160 NSM=NSEL(JKK) JSM=JKK 160 CONTINUE NSEL(JSM)=NSEL(JK) NSEL(JK)=NSM 170 CONTINUE NTT=KK GO TO 210 180 CALL RANDM(NRUN,RAN) KRAN=RNN*RAN+1. IF(KRAN.GT.NN)KRAN=NN IF(JRAN.EQ.1)GO TO 200 DO 190 JK=1,KK IF(KRAN.EQ.NRX(JK))GO TO 180 190 CONTINUE 200 NTT=NTT+1 NSEL(NTT)=KRAN 210 CALL RANDM(NRUN,RAN) KRAN=RNN*RAN+1. IF(KRAN.GT.NN)KRAN=NN IF(JRAN.EQ.1)GO TO 230 IF(NN.GE.NSAMB)GO TO 230 DO 220 JK=1,KK IF(KRAN.EQ.NRX(JK))GO TO 210 220 CONTINUE 230 DO 260 KANS=1,NTT IF(NSEL(KANS).LT.KRAN)GO TO 260 IF(NSEL(KANS).EQ.KRAN)GO TO 210 GO TO 270 260 CONTINUE NTT=NTT+1 NSEL(NTT)=KRAN GO TO 290 270 DO 280 NAD=KANS,NTT NADV=NTT-NAD+KANS NADVP=NADV+1 NSEL(NADVP)=NSEL(NADV) 280 CONTINUE NTT=NTT+1 NSEL(KANS)=KRAN 290 IF(NTT.LT.LESS)GO TO 210 IF(NN.GE.NSAMB)GO TO 320 NEXAP=1 NEXBP=1 JN=0 300 JN=JN+1 IF(NSEL(NEXAP).EQ.JN)THEN NEXAP=NEXAP+1 ELSE NREPR(NEXBP)=JN NEXBP=NEXBP+1 ENDIF IF(JN.LT.NN)GO TO 300 DO 310 NSUB=1,NSAM NSEL(NSUB)=NREPR(NSUB) 310 CONTINUE 320 WRITE(LUB,9270) WRITE(LUB,9280)(NSEL(JJ),JJ=1,NSAM) 330 CALL DYSTA(NSAM,JPP,NSEL,X,MAXXX,MAXTT,DYS,NDYST,JTMD,VALMD, F JHALT,LUB,FNAMEB) IF(JHALT.EQ.1)GO TO 400 KALL=1 S=0.0 L=1 340 L=L+1 IF(DYS(L).GT.S)S=DYS(L) IF(L.LT.NHALF)GO TO 340 CALL BSWAP(KK,NSAM,NREPR,DYS,Z,S,LUB) RSAM=NSAM AZ=Z/RSAM IF(NNEQ.EQ.0)WRITE(LUB,9320) IF(NNEQ.GE.1)WRITE(LUB,9325) WRITE(LUB,9330)AZ CALL SELEC(KK,NN,JPP,NSTAN,NDYST,ZB,NSAM,LUB,MDATA, F JTMD,VALMD,NREPR,NSEL,DYS,X,MAXXX,MAXTT,NR,NAFS, F TTD,RADUS,RATT) NUNFS=NUNFS+NAFS IF(NAFS.EQ.1)GO TO 400 IF(JRAN.EQ.1)GO TO 350 IF(ZB.GE.ZBA)GO TO 400 350 ZBA=ZB DO 345 JJB=1,30 TTBES(JJB)=TTD(JJB) RDBES(JJB)=RADUS(JJB) RABES(JJB)=RATT(JJB) 345 CONTINUE DO 360 JK=1,KK NRX(JK)=NR(JK) 360 CONTINUE DO 370 JS=1,NSAM NBEST(JS)=NSEL(JS) 370 CONTINUE JRSKY=JRAN SX=S 400 CONTINUE IF(NUNFS.LT.NRAN) GOTO 450 WRITE(LUB,9335) IF(FNAMEB.NE.'CON') WRITE(*,9335) STOP CC CC FOR THE BEST SUBSAMPLE, THE OBJECTS OF THE ENTIRE DATA SET CC ARE ASSIGNED TO THEIR CLUSTERS CC 450 IF(KALL.EQ.1)GO TO 460 WRITE(LUB,9340)NRAN GO TO 510 460 AZBA=ZBA/RNN IF(KK.NE.1)GO TO 470 IF(NNEQ.EQ.0)WRITE(LUB,9350)JRSKY,NRX(1) IF(NNEQ.GE.1)WRITE(LUB,9355)NRX(1) WRITE(LUB,9360)AZBA GO TO 500 470 IF(NNEQ.GE.1)GO TO 480 WRITE(LUB,9370)JRSKY WRITE(LUB,9280)(NBEST(JJ),JJ=1,NSAM) WRITE(LUB,9360)AZBA CALL DYSTA(NSAM,JPP,NBEST,X,MAXXX,MAXTT,DYS,NDYST,JTMD,VALMD, F JHALT,LUB,FNAMEB) CALL RESUL(KK,NN,JPP,LARGE,NDYST,LUB,MDATA,JTMD,VALMD, F X,MAXXX,MAXTT,NRX) WRITE(LUB,9400)(ttbes(J),J=1,KK) WRITE(LUB,9410)(rdbes(J),J=1,KK) WRITE(LUB,9420)(rabes(J),J=1,KK) 480 IF(LGRAP.EQ.0)GO TO 500 CALL BLACK(KK,JPP,NSAM,NBEST,DYS,SX,X,MAXXX,LUB,NUM) 500 WRITE(*,9450) 510 IF(FNAMEB.NE.'CON'.AND.FNAMEB.NE.'PRN')WRITE(*,9460)FNAMEB IF(FNAMEB.EQ.'PRN')WRITE(*,9470) IF(FNAMEB.NE.'CON'.AND.FNAMEB.NE.'PRN')WRITE(LUB,9460)FNAMEB STOP 9200 FORMAT(1X,' FOR OBJECT',I7,' ALL VALUES ARE MISSING'/ F55H SO IT SHOULD BE REMOVED BEFORE RESTARTING THE PROGRAM) 9210 FORMAT(' Variable ',10A1,' is defined for all objects.') 9211 FORMAT(' Variable ',10A1,' contains',I7,' missing values.') 9212 FORMAT(/' VARIABLE ',10A1,' CONTAINS ONLY MISSING VALUES'/ F53H SO IT MUST BE REMOVED BEFORE RESTARTING THE PROGRAM) 9214 FORMAT(1X,' (THIS CAN BE DONE BY CHANGING THE NUMBER OF ', F 'VARIABLES AND THE INPUT FORMAT.)'/) 9215 FORMAT(//' The total number of missing values is',I9,'.'//) 9220 FORMAT(/' CAREFUL, NO VARIABLES ARE DEFINED FOR ALL OBJECTS') 9235 FORMAT(//26H STANDARDIZED MEASUREMENTS/1X,25(1H-)/) 9236 FORMAT(1X,33H ( 99.99 DENOTES A MISSING VALUE)//) 9240 FORMAT(1X,I6,2X,125(8F8.2/6X)) 9245 FORMAT(/,I4,' SAMPLES OF ',I5,' OBJECTS WILL NOW BE DRAWN.'/) 9250 FORMAT(//1X,46(1H*)/1X,1H*,44X,1H*/1X,12H* NUMBER OF, F' REPRESENTATIVE OBJECTS',I6,4X,'*'/' *',44X,'*'/1X,46('*')) 9255 FORMAT(/1X,' The size of the sample equals the number of', F ' objects in the data set.'/1X,' In this case the entire', F ' data set is clustered.') 9260 FORMAT(1X///14H SAMPLE NUMBER,I5/1X,18(1H*)) 9265 FORMAT(1X,' Working on sample number ',I4) 9270 FORMAT(/17H RANDOM SAMPLE =) 9280 FORMAT(5X,10I7) 9320 FORMAT(/30H FINAL RESULT FOR THIS SAMPLE) 9325 FORMAT(/1X,' FINAL RESULT') 9330 FORMAT(' AVERAGE DISTANCE = ',F12.3/) 9335 FORMAT(' FOR EACH SAMPLE AT LEAST ONE OBJECT WAS FOUND', F ' WHICH COULD NOT'/' BE ASSIGNED TO A CLUSTER (BECAUSE OF', F ' MISSING VALUES).'/' THE PROGRAM THEREFORE STOPS HERE.') 9340 FORMAT(///1X,13H EACH OF THE ,I5,24H RANDOM SAMPLES CONTAINS/ F1X,51H OBJECTS BETWEEN WHICH NO DISTANCE CAN BE COMPUTED.) 9350 FORMAT(//////2X,15H SAMPLE NUMBER,I4,14H WAS SELECTED, F,21H ITS MEDOID IS OBJECT,I7,2H .) 9355 FORMAT(//////3X,'THE MEDOID IS OBJECT NUMBER ',I7,'.') 9360 FORMAT(//' AVERAGE DISTANCE FOR THE ENTIRE DATA SET =', F F12.3) 9370 FORMAT(//////' FINAL RESULTS'/3X,13('*')//3X,'SAMPLE', F ' NUMBER',I3,' WAS SELECTED, WITH OBJECTS =') 9400 FORMAT(//35H AVERAGE DISTANCE TO EACH MEDOID,6(/2X,5F12.3)) 9410 FORMAT(/35H MAXIMUM DISTANCE TO EACH MEDOID,6(/2X,5F12.3)) 9420 FORMAT(/' MAXIMUM DISTANCE TO A MEDOID DIVIDED BY MINIMUM'/ F ' DISTANCE OF THE MEDOID TO ANOTHER MEDOID',6(/2X,5F12.3)) 9450 FORMAT(/1X,' This run has been successfully completed'/) 9460 FORMAT(/1X,' Your output is written on file : ',A30) 9470 FORMAT(/1X,' The output was sent to the printer') END CC CC SUBROUTINE QYN(YN,NYN) CHARACTER YN 10 READ(*,8000)YN IF(YN.EQ.'y')YN='Y' IF(YN.EQ.'n')YN='N' IF(YN.EQ.'Y')NYN=1 IF(YN.EQ.'N')NYN=0 IF(YN.EQ.'Y'.OR.YN.EQ.'N')GO TO 20 WRITE(*,9000) GO TO 10 20 RETURN 8000 FORMAT(A1) 9000 FORMAT(1X,'NOT ALLOWED ! PLEASE ENTER YOUR CHOICE AGAIN : '$) END CC CC FUNCTION MEET(L,J) IF(L.GT.J)GO TO 10 IF(L.EQ.J)GO TO 20 CC CC L LESS THAN J CC MEET=(J-2)*(J-1)/2+L+1 RETURN CC CC J LESS THAN L CC 10 MEET=(L-2)*(L-1)/2+J+1 RETURN CC CC J EQUALS L CC 20 MEET=1 RETURN END CC CC SUBROUTINE STAND(NN,JPP,X,MAXXX,MAXTT,JTMD,VALMD,JHALT,JLAB, F LUB,FNAMEB) DIMENSION X(MAXXX),JTMD(MAXTT),VALMD(MAXTT) CHARACTER*1 JLAB(10,MAXTT) CHARACTER*30 FNAMEB DO 200 J=1,JPP AVERA=0.0 STAM=0.0 IF(JTMD(J).GE.0)GO TO 100 NPRES=0 L=0 20 L=L+1 NLJ=(L-1)*JPP+J IF(X(NLJ).EQ.VALMD(J))GOTO 21 NPRES=NPRES+1 AVERA=AVERA+X(NLJ) 21 IF(L.LT.NN)GO TO 20 IF(NPRES.LE.1)GO TO 300 RPRES=NPRES AVERA=AVERA/RPRES L=0 50 L=L+1 NLJ=(L-1)*JPP+J IF(X(NLJ).EQ.VALMD(J))GO TO 51 STAM=STAM+ABS(X(NLJ)-AVERA) 51 IF(L.LT.NN)GO TO 50 STAM=STAM/RPRES WRITE(LUB,9300)(JLAB(K,J),K=1,10),AVERA,STAM IF(STAM.LE.0.0)GO TO 300 L=0 60 L=L+1 NLJ=(L-1)*JPP+J IF(X(NLJ).EQ.VALMD(J))GO TO 70 X(NLJ)=(X(NLJ)-AVERA)/STAM IF(X(NLJ).GT.49.0)X(NLJ)=49.0 IF(X(NLJ).LT.(-49.0))X(NLJ)=-49.0 GO TO 61 70 X(NLJ)=99.99 61 IF(L.LT.NN)GO TO 60 VALMD(J)=99.99 GO TO 200 100 L=0 120 L=L+1 NLJ=(L-1)*JPP+J AVERA=AVERA+X(NLJ) IF(L.LT.NN)GO TO 120 RNN=NN AVERA=AVERA/RNN L=0 150 L=L+1 NLJ=(L-1)*JPP+J STAM=STAM+ABS(X(NLJ)-AVERA) IF(L.LT.NN)GO TO 150 STAM=STAM/RNN WRITE(LUB,9300)(JLAB(K,J),K=1,10),AVERA,STAM IF(STAM.LE.0.0)GO TO 300 L=0 160 L=L+1 NLJ=(L-1)*JPP+J X(NLJ)=(X(NLJ)-AVERA)/STAM IF(X(NLJ).GT.49.0)X(NLJ)=49.0 IF(X(NLJ).LT.(-49.0))X(NLJ)=-49.0 IF(L.LT.NN)GO TO 160 GO TO 200 300 JHALT=1 WRITE(LUB,9310)(JLAB(J,K),K=1,10) IF(FNAMEB.NE.'CON') WRITE(*,9310)(JLAB(J,K),K=1,10) WRITE(LUB,9320) IF(FNAMEB.NE.'CON')WRITE(*,9320) 200 CONTINUE RETURN 9300 FORMAT(1X,' VARIABLE ',10A1,13H HAS AVERAGE ,F10.3, F ' MEAN DEVIATION ',F10.3) 9310 FORMAT(/1X,' THE MEAN DEVIATION OF VARIABLE ',10A1, F/1X,36H IS ZERO (UP TO COMPUTER PRECISION).) 9320 FORMAT(1X,' PLEASE RUN THE PROGRAM AGAIN WITHOUT THIS', F 'VARIABLE') END CC CC SUBROUTINE DYSTA(NSAM,JPP,NSEL,X,MAXXX,MAXTT,DYS,NDYST,JTMD, F VALMD,JHALT,LUB,FNAMEB) DIMENSION X(MAXXX),DYS(4951) DIMENSION NSEL(100),JTMD(MAXTT),VALMD(MAXTT) CHARACTER*30 FNAMEB PP=JPP NLK=1 DYS(1)=0.0 DO 100 L=2,NSAM LSUBT=L-1 LSEL=NSEL(L) DO 20 K=1,LSUBT KSEL=NSEL(K) CLK=0.0 NLK=NLK+1 NPRES=0 DO 30 J=1,JPP NUMLJ=(LSEL-1)*JPP+J NUMKJ=(KSEL-1)*JPP+J IF(JTMD(J).GE.0)GO TO 40 IF(X(NUMLJ).EQ.VALMD(J))GO TO 30 IF(X(NUMKJ).EQ.VALMD(J))GO TO 30 40 NPRES=NPRES+1 IF(NDYST.NE.1)GO TO 50 CLK=CLK+(X(NUMLJ)-X(NUMKJ))*(X(NUMLJ)-X(NUMKJ)) GO TO 30 50 CLK=CLK+ABS(X(NUMLJ)-X(NUMKJ)) 30 CONTINUE RPRES=NPRES IF(NPRES.NE.0)GO TO 60 JHALT=1 WRITE(LUB,9400)LSEL,KSEL IF(FNAMEB.NE.'CON')WRITE(*,9400)LSEL,KSEL DYS(NLK)=0.0 GO TO 20 60 IF(NDYST.NE.1)GO TO 70 DYS(NLK)=SQRT(CLK*(PP/RPRES)) GO TO 20 70 DYS(NLK)=CLK*(PP/RPRES) 20 CONTINUE 100 CONTINUE RETURN 9400 FORMAT(1X,8H OBJECTS,I8,4H AND,I8,23H HAVE NO COMMON MEASURE, F6HMENTS,/49H SO THE DISTANCE BETWEEN THEM CANNOT BE COMPUTED) END CC CC SUBROUTINE RANDM(NRUN,RAN) CC WE PROGRAMMED THIS GENERATOR OURSELVES BECAUSE WE WANTED IT CC TO BE MACHINE INDEPENDENT. IT SHOULD RUN ON MOST COMPUTERS CC BECAUSE THE LARGEST INTEGER USED IS LESS THAN 2**30 . THE PERIOD CC IS 2**16=65536, WHICH IS GOOD ENOUGH FOR OUR PURPOSES. INTEGER*4 NRUN,K NRUN=NRUN*5761+999 K=NRUN/65536 NRUN=NRUN-K*65536 RY=NRUN RAN=RY/65536.0 RETURN END CC CC SUBROUTINE BSWAP(KK,NSAM,NREPR,DYS,SKY,S,LUB) DIMENSION DYSMA(100),DYSMB(100),BETER(100),NREPR(100),DYS(4951) CC CC FIRST ALGORITHM: BUILD. CC NNY=0 DO 17 J=1,NSAM NREPR(J)=0 DYSMA(J)=1.1*S+1.0 17 CONTINUE 20 DO 22 JA=1,NSAM IF(NREPR(JA).NE.0)GO TO 22 BETER(JA)=0. DO 21 J=1,NSAM NJAJ=MEET(JA,J) CMD=DYSMA(J)-DYS(NJAJ) IF(CMD.GT.0.0)BETER(JA)=BETER(JA)+CMD 21 CONTINUE 22 CONTINUE AMMAX=0. DO 31 JA=1,NSAM IF(NREPR(JA).NE.0)GO TO 31 IF(BETER(JA).LT.AMMAX)GO TO 31 AMMAX=BETER(JA) NMAX=JA 31 CONTINUE NREPR(NMAX)=1 NNY=NNY+1 DO 41 J=1,NSAM NJN=MEET(NMAX,J) IF(DYS(NJN).LT.DYSMA(J))DYSMA(J)=DYS(NJN) 41 CONTINUE IF(NNY.NE.KK)GO TO 20 SKY=0. DO 51 J=1,NSAM SKY=SKY+DYSMA(J) 51 CONTINUE IF(KK.EQ.1)RETURN RSAM=NSAM ASKY=SKY/RSAM WRITE(LUB,9100)ASKY CC CC SECOND ALGORITHM: SWAP. CC 60 DO 63 J=1,NSAM DYSMA(J)=1.1*S+1.0 DYSMB(J)=1.1*S+1.0 DO 62 JA=1,NSAM IF(NREPR(JA).EQ.0)GO TO 62 NJAJ=MEET(JA,J) IF(DYS(NJAJ).GE.DYSMA(J))GO TO 61 DYSMB(J)=DYSMA(J) DYSMA(J)=DYS(NJAJ) GO TO 62 61 IF(DYS(NJAJ).GE.DYSMB(J))GO TO 62 DYSMB(J)=DYS(NJAJ) 62 CONTINUE 63 CONTINUE DZSKY=1.0 DO 73 K=1,NSAM IF(NREPR(K).EQ.1)GO TO 73 DO 72 JA=1,NSAM IF(NREPR(JA).EQ.0)GO TO 72 DZ=0. DO 71 J=1,NSAM NJAJ=MEET(JA,J) NKJ=MEET(K,J) IF(DYS(NJAJ).NE.DYSMA(J))GO TO 70 SMALL=DYSMB(J) IF(DYS(NJAJ).LT.SMALL)SMALL=DYS(NKJ) DZ=DZ-DYSMA(J)+SMALL GO TO 71 70 IF(DYS(NKJ).LT.DYSMA(J))DZ=DZ-DYSMA(J)+DYS(NKJ) 71 CONTINUE IF(DZ.GE.DZSKY)GO TO 72 DZSKY=DZ KBEST=K NBEST=JA 72 CONTINUE 73 CONTINUE IF(DZSKY.GE.0.0)RETURN NREPR(KBEST)=1 NREPR(NBEST)=0 SKY=SKY+DZSKY GO TO 60 9100 FORMAT(1X/33H RESULT OF BUILD FOR THIS SAMPLE/2X, F ' AVERAGE DISTANCE = ',F12.3) END CC CC SUBROUTINE SELEC(KK,NN,JPP,NSTAN,NDYST,ZB,NSAM,LUB,MDATA, F JTMD,VALMD,NREPR,NSEL,DYS,X,MAXXX,MAXTT,NR,NAFS, F TTD,RADUS,RATT) DIMENSION NREPR(100),NSEL(100),DYS(4951),X(MAXXX),NEW(30) DIMENSION NRNEW(30),NSNEW(30),NPNEW(30),TTNEW(30),RDNEW(30) DIMENSION NS(30),NR(30),NP(30),TTD(30),RADUS(30),RATT(30) DIMENSION JTMD(MAXTT),VALMD(MAXTT) CC CC NAFS = 1 IF A DISTANCE CANNOT BE CALCULATED CC NAFS=0 CC CC IDENTIFICATION OF REPRESENTATIVE OBJECTS, AND INITIALIZATIONS CC JK=0 DO 10 J=1,NSAM IF(NREPR(J).EQ.0)GO TO 10 JK=JK+1 NR(JK)=NSEL(J) NS(JK)=0 TTD(JK)=0. RADUS(JK)=-1. NP(JK)=J 10 CONTINUE CC CC ASSIGNMENT OF THE OBJECTS OF THE ENTIRE DATA SET TO A CLUSTER, CC COMPUTATION OF SOME STATISTICS, DETERMINATION OF THE CC NEW ORDERING OF THE CLUSTERS CC ZB=0. PP=JPP NEWF=0 JN=0 15 JN=JN+1 IF(MDATA.NE.0)GO TO 40 DO 30 JK=1,KK DSUM=0. NRJK=NR(JK) DO 20 JP=1,JPP NA=(NRJK-1)*JPP+JP NB=(JN-1)*JPP+JP TRA=ABS(X(NA)-X(NB)) IF(NDYST.EQ.1)TRA=TRA*TRA DSUM=DSUM+TRA 20 CONTINUE IF(JK.EQ.1)GO TO 25 IF(DSUM.GE.DNULL)GO TO 30 25 DNULL=DSUM JKABC=JK 30 CONTINUE GO TO 80 40 PRES=0. DO 70 JK=1,KK DSUM=0. NRJK=NR(JK) ABC=0. DO 50 JP=1,JPP NA=(NRJK-1)*JPP+JP NB=(JN-1)*JPP+JP IF(JTMD(JP).GE.0)GO TO 45 IF(X(NA).EQ.VALMD(JP))GO TO 50 IF(X(NB).EQ.VALMD(JP))GO TO 50 45 ABC=ABC+1. TRA=ABS(X(NA)-X(NB)) IF(NDYST.EQ.1)TRA=TRA*TRA DSUM=DSUM+TRA 50 CONTINUE IF(ABC.LT.0.5)GO TO 70 DSUM=DSUM*ABC/PP IF(PRES.GT.0.5)GO TO 60 PRES=1. GO TO 65 60 IF(DSUM.GE.DNULL)GO TO 70 65 DNULL=DSUM JKABC=JK 70 CONTINUE IF(PRES.GT.0.5)GO TO 80 WRITE(LUB,9000)JN WRITE(LUB,9002) NAFS=1 RETURN 80 IF(NDYST.EQ.1)DNULL=SQRT(DNULL) ZB=ZB+DNULL TTD(JKABC)=TTD(JKABC)+DNULL IF(DNULL.GT.RADUS(JKABC))RADUS(JKABC)=DNULL NS(JKABC)=NS(JKABC)+1 IF(NEWF.GE.KK)GO TO 90 IF(NEWF.EQ.0)GO TO 84 DO 82 JNEW=1,NEWF IF(JKABC.EQ.NEW(JNEW))GO TO 90 82 CONTINUE 84 NEWF=NEWF+1 NEW(NEWF)=JKABC 90 IF(JN.LT.NN)GO TO 15 CC CC A PERMUTATION IS CARRIED OUT ON VECTORS NR,NS,NP,TTD,RADUS CC USING THE INFORMATION IN VECTOR NEW. CC DO 92 JK=1,KK NJK=NEW(JK) NRNEW(JK)=NR(NJK) NSNEW(JK)=NS(NJK) NPNEW(JK)=NP(NJK) TTNEW(JK)=TTD(NJK) RDNEW(JK)=RADUS(NJK) 92 CONTINUE DO 94 JK=1,KK NR(JK)=NRNEW(JK) NS(JK)=NSNEW(JK) NP(JK)=NPNEW(JK) TTD(JK)=TTNEW(JK) RADUS(JK)=RDNEW(JK) 94 CONTINUE CC CC PRINTING OF RESULTS FOR ENTIRE DATA SET CC RNN=NN ZM=ZB/RNN WRITE(LUB,9010)ZB,ZM IF(NSTAN.EQ.0)WRITE(LUB,9020) IF(NSTAN.NE.0)WRITE(LUB,9025) DO 100 JK=1,KK JKA=(NR(JK)-1)*JPP+1 JKB=JKA-1+JPP WRITE(LUB,9030)JK,NS(JK),NR(JK),(X(J),J=JKA,JKB) 100 CONTINUE DO 101 J=1,KK RNS=NS(J) TTD(J)=TTD(J)/RNS 101 CONTINUE WRITE(LUB,9040)(TTD(J),J=1,KK) WRITE(LUB,9050)(RADUS(J),J=1,KK) IF(KK.EQ.1)GO TO 150 CC CC COMPUTATION OF MINIMAL DISTANCE OF MEDOID KA TO ANY CC OTHER MEDOID FOR COMPARISON WITH THE RADIUS OF CLUSTER KA. CC DO 120 KA=1,KK NSTRT=0 NPA=NP(KA) DO 110 KB=1,KK IF(KB.EQ.KA)GO TO 110 NPB=NP(KB) NPAB=MEET(NPA,NPB) IF(NSTRT.EQ.0)THEN NSTRT=1 ELSE IF(DYS(NPAB).GE.RATT(KA))GO TO 110 ENDIF 104 RATT(KA)=DYS(NPAB) IF(RATT(KA).NE.0.)GO TO 110 WRITE(LUB,9054)KA,KB WRITE(LUB,9056) RATT(KA)=-1. 110 CONTINUE IF(RATT(KA).GT.(-0.5))RATT(KA)=RADUS(KA)/RATT(KA) 120 CONTINUE WRITE(LUB,9060)(RATT(J),J=1,KK) 150 RETURN 9000 FORMAT(' OBJECT',I5,37H DOESNT HAVE COMMON MEASUREMENTS WITH, F53H ANY OF THE MEDOIDS AND THEREFORE CANNOT BE ASSIGNED.) 9002 FORMAT(1X,' THIS SAMPLE IS NOT CONSIDERED ANY FURTHER') 9010 FORMAT(33H RESULTS FOR THE ENTIRE DATA SET/3X, F20H TOTAL DISTANCE =,F15.3/3X,20H AVERAGE DISTANCE =,F15.3) 9020 FORMAT(/46H CLUSTER SIZE MEDOID COORDINATES OF MEDOID) 9025 FORMAT(/46H CLUSTER SIZE MEDOID COORDINATES OF MEDOID, F28H (STANDARDIZED MEASUREMENTS)) 9030 FORMAT(/1X,I8,I5,I7,2X,5F11.2,20(/23X,5F11.2)) 9040 FORMAT(/33H AVERAGE DISTANCE TO EACH MEDOID,6(/2X,5F12.3)) 9050 FORMAT(/33H MAXIMUM DISTANCE TO EACH MEDOID,6(/2X,5F12.3)) 9054 FORMAT(/51H THE DISSIMILARITY BETWEEN THE MEDOIDS OF CLUSTERS, FI3,5H AND ,I3,9H IS ZERO.) 9056 FORMAT(' IN THE FOLLOWING VECTOR A VALUE OF -1 IS GIVEN TO', F ' BOTH CLUSTERS.') 9060 FORMAT(/49H MAXIMUM DISTANCE TO A MEDOID DIVIDED BY MINIMUM/ F42H DISTANCE OF THE MEDOID TO ANOTHER MEDOID,6(/2X,5F12.3)) END CC CC SUBROUTINE RESUL(KK,NN,JPP,LARGE,NDYST,LUB,MDATA,JTMD, F VALMD,X,MAXXX,MAXTT,NRX) DIMENSION X(MAXXX),NRX(30),LYNE(25),JTMD(MAXTT),VALMD(MAXTT) LYNF=25 PP=JPP CC CC CLUSTERING VECTOR IS INCORPORATED INTO X, AND PRINTED. CC JN=0 100 JN=JN+1 NJNB=(JN-1)*JPP DO 145 JK=1,KK IF(NRX(JK).EQ.JN)GO TO 220 145 CONTINUE JNA=(JN-1)*JPP+1 IF(MDATA.NE.0)GO TO 170 DO 160 JK=1,KK DSUM=0. NRJK=(NRX(JK)-1)*JPP DO 150 J=1,JPP NA=NRJK+J NB=NJNB+J TRA=ABS(X(NA)-X(NB)) IF(NDYST.EQ.1)TRA=TRA*TRA DSUM=DSUM+TRA 150 CONTINUE IF(NDYST.EQ.1)DSUM=SQRT(DSUM) IF(JK.EQ.1)DNULL=DSUM+0.1 IF(DSUM.GE.DNULL)GO TO 160 DNULL=DSUM JKSKY=JK 160 CONTINUE GO TO 200 170 DO 190 JK=1,KK DSUM=0. NRJK=(NRX(JK)-1)*JPP ABC=0. DO 180 J=1,JPP NA=NRJK+J NB=NJNB+J IF(JTMD(J).GE.0)GO TO 185 IF(X(NA).EQ.VALMD(J))GO TO 180 IF(X(NB).EQ.VALMD(J))GO TO 180 185 ABC=ABC+1. TRA=ABS(X(NA)-X(NB)) IF(NDYST.EQ.1)TRA=TRA*TRA DSUM=DSUM+TRA 180 CONTINUE IF(NDYST.EQ.1)DSUM=SQRT(DSUM) DSUM=DSUM*ABC/PP IF(JK.EQ.1)DNULL=DSUM+0.1 IF(DSUM.GE.DNULL)GO TO 190 DNULL=DSUM JKSKY=JK 190 CONTINUE 200 X(JNA)=JKSKY 220 IF(JN.LT.NN)GO TO 100 DO 230 JK=1,KK NRJK=NRX(JK) NRJKA=(NRJK-1)*JPP+1 X(NRJKA)=JK 230 CONTINUE WRITE(LUB,9110) MTEL=0 MTELP=LYNF 240 DO 250 J=1,MTELP MTEL=MTEL+1 MTELA=(MTEL-1)*JPP+1 LYNE(J)=X(MTELA) 250 CONTINUE WRITE(LUB,9120)(LYNE(J),J=1,MTELP) IF(MTEL.GE.NN)GO TO 300 NNTEL=NN-MTEL IF(NNTEL.GE.LYNF)GO TO 240 MTELP=NN-MTEL GO TO 240 CC CC WHEN LARGE IS NOT ZERO, LIST OF ALL CLUSTER ELEMENTS IN ENTIRE CC DATA SET IS GIVEN. CC 300 IF(LARGE.LE.0)GO TO 330 WRITE(LUB,9130) DO 320 KA=1,KK MTT=0 J=0 325 J=J+1 JA=(J-1)*JPP+1 NXJA=INT(X(JA)+0.1) IF(NXJA.EQ.KA)MTT=MTT+1 IF(J.LT.NN)GO TO 325 WRITE(LUB,9140)KA,MTT,NRX(KA) MTT=0 J=0 315 J=J+1 JA=(J-1)*JPP+1 NXJA=INT(X(JA)+0.1) IF(NXJA.NE.KA)GO TO 310 MTT=MTT+1 LYNE(MTT)=J IF(MTT.NE.10)GO TO 310 MTT=0 WRITE(LUB,9150)(LYNE(JJ),JJ=1,10) 310 IF(J.LT.NN)GO TO 315 IF(MTT.NE.0)WRITE(LUB,9150)(LYNE(JJ),JJ=1,MTT) 320 CONTINUE 330 RETURN 9110 FORMAT(//2X,18H CLUSTERING VECTOR/3X,17(1H*)/) 9120 FORMAT(4X,25I3) 9130 FORMAT(//4X,27HCLUSTER SIZE MEDOID OBJECTS) 9140 FORMAT(/3X,I8,I5,I7) 9150 FORMAT(24X,10I5) END CC CC SUBROUTINE BLACK(KK,JPP,NSAM,NBEST,DYS,SX,X,MAXXX,LUB,NUM) DIMENSION NCLUV(100),NSEND(100),NELEM(100),NEGBR(100) DIMENSION SYL(100),SRANK(100),AVSYL(100),NBEST(100) DIMENSION X(MAXXX),DYS(4951) CHARACTER JDRAW(51),NUM(13),JBLAN,JSTAR,JSEPA JBLAN=NUM(11) JSTAR=NUM(12) JSEPA=NUM(13) WRITE(LUB,9500) WRITE(LUB,9510) DO 10 LL=1,51 JDRAW(LL)=JSEPA 10 CONTINUE WRITE(LUB,9515)(JDRAW(LL),LL=1,51),JSEPA,JSEPA,JSEPA CC CC CONSTRUCTION OF CLUSTERING VECTOR (NCLUV) CC OF SELECTED SAMPLE (NBEST). CC DO 12 L=1,NSAM NCASE=NBEST(L) JNA=(NCASE-1)*JPP+1 NCLUV(L)=INT(X(JNA)+0.1) 12 CONTINUE CC CC DRAWING OF THE SILHOUETTES CC TTSYL=0.0 DO 100 NUMCL=1,KK NTT=0 DO 30 J=1,NSAM IF(NCLUV(J).NE.NUMCL)GO TO 30 NTT=NTT+1 NELEM(NTT)=J 30 CONTINUE DO 40 J=1,NTT NJ=NELEM(J) DYSB=1.1*SX+1.0 NEGBR(J)=-1 DO 41 NCLU=1,KK IF(NCLU.EQ.NUMCL)GO TO 41 NBB=0 DB=0.0 DO 43 L=1,NSAM IF(NCLUV(L).NE.NCLU)GO TO 43 NBB=NBB+1 MJL=MEET(NJ,L) DB=DB+DYS(MJL) 43 CONTINUE BTT=NBB DB=DB/BTT IF(DB.GE.DYSB)GO TO 41 DYSB=DB NEGBR(J)=NCLU 41 CONTINUE IF(NTT.EQ.1)GO TO 50 DYSA=0.0 DO 45 L=1,NTT NL=NELEM(L) NJL=MEET(NJ,NL) DYSA=DYSA+DYS(NJL) 45 CONTINUE ATT=NTT-1 DYSA=DYSA/ATT IF(DYSA.GT.0.0)GO TO 51 IF(DYSB.GT.0.0)GO TO 52 50 SYL(J)=0.0 GO TO 40 52 SYL(J)=1.0 GO TO 40 51 IF(DYSB.LE.0.0)GO TO 53 IF(DYSB.GT.DYSA)SYL(J)=1.0-DYSA/DYSB IF(DYSB.LT.DYSA)SYL(J)=DYSB/DYSA-1.0 IF(DYSB.EQ.DYSA)SYL(J)=0.0 GO TO 54 53 SYL(J)=-1.0 54 IF(SYL(J).LE.(-1.0))SYL(J)=-1.0 IF(SYL(J).GE.1.0)SYL(J)=1.0 40 CONTINUE AVSYL(NUMCL)=0.0 DO 60 J=1,NTT SYMAX=-2.0 DO 70 L=1,NTT IF(SYL(L).LE.SYMAX)GO TO 70 SYMAX=SYL(L) LANG=L 70 CONTINUE NSEND(J)=LANG SRANK(J)=SYL(LANG) AVSYL(NUMCL)=AVSYL(NUMCL)+SRANK(J) SYL(LANG)=-3.0 60 CONTINUE TTSYL=TTSYL+AVSYL(NUMCL) RTT=NTT AVSYL(NUMCL)=AVSYL(NUMCL)/RTT IF(NTT.GE.2)GOTO 75 NCASE=NELEM(1) DO 65 LL=2,50 JDRAW(LL)=JBLAN 65 CONTINUE WRITE(LUB,9525)NUMCL,NEGBR(1),NBEST(NCASE),JSEPA, F(JDRAW(LL),LL=2,50),JSEPA GOTO 96 75 DO 80 L=1,NTT LPLAC=NSEND(L) NCASE=NELEM(LPLAC) NEG=NEGBR(LPLAC) TRUNC=SRANK(L) IF(SRANK(L).LE.0.0)TRUNC=0.0 LENGT=TRUNC*50.0+1.1 DO 90 LL=2,51 JDRAW(LL)=JBLAN 90 CONTINUE IF(LENGT.LE.1)GOTO 95 DO 91 LL=2,LENGT JDRAW(LL)=JSTAR 91 CONTINUE 95 WRITE(LUB,9520)NUMCL,NEG,SRANK(L),NBEST(NCASE), F(JDRAW(LL),LL=1,51),JSEPA 80 CONTINUE 96 IF(NUMCL.LT.KK)WRITE(LUB,9530)JSEPA,JSEPA 100 CONTINUE DO 105 LL=1,51 JDRAW(LL)=JSEPA 105 CONTINUE WRITE(LUB,9516)JSEPA,JSEPA,(JDRAW(LL),LL=1,51),JSEPA WRITE(LUB,9510) WRITE(LUB,9517) DO 110 NUMCL=1,KK WRITE(LUB,9540)NUMCL,AVSYL(NUMCL) 110 CONTINUE RSAM=NSAM TTSYL=TTSYL/RSAM WRITE(LUB,9550)TTSYL RETURN 9500 FORMAT(////22X,36('*')/22X,'*',34X,'*'/22X,'* SILHOUETTES', F' OF SELECTED SAMPLE *'/22X,'*',34X,'*'/22X,36('*')/) 9510 FORMAT(/24X,25('0 '),'1'/24X,26('. ')/24X,'0 0 0 ', F46H1 1 2 2 2 3 3 4 4 4 5 5 6 6 6 7 7 8 8 8 9 9 0 ) 9515 FORMAT(24X,5('0 4 8 2 6 '),'0'//1X,' CLU NEIG S(I) I ', F52A1/24X,A1,50X,A1) 9516 FORMAT(24X,A1,50X,A1/24X,52A1) 9517 FORMAT(24X,5(10H0 4 8 2 6 ),1H0//) 9520 FORMAT(1X,I4,1X,I4,1X,F5.2,1X,I7,52A1) 9525 FORMAT(1X,I4,1X,I4,2X,4H .00,1X,I7,50A1,1H1,A1) 9530 FORMAT(24X,A1,50X,A1) 9540 FORMAT(7X,' CLUSTER ',I4,' HAS AVERAGE SILHOUETTE WIDTH',F6.2) 9550 FORMAT(/7X,37H FOR THE SELECTED SAMPLE, THE AVERAGE, F21H SILHOUETTE WIDTH IS ,F5.2//) END CC CC SUBROUTINE ENTR(NN,JPP,MAXXX,MAXTT,HULP,JPLACE,X,VALMD,JTMD, F NUM,LUA,LUB,FNAMEA,FNAMEB,JLAB,NAME,KK,NSTAN,NDYST,LARGE, F LGRAP,NFF,JFMT,MDATA) DIMENSION X(MAXXX) DIMENSION VALMD(MAXTT),JTMD(MAXTT),HULP(MAXTT),JPLACE(MAXTT) CHARACTER STAN,DYST,CYNFF,CGRAP,CMDT CHARACTER CDATA,CYNK,CEX,JLAB(10,MAXTT) CHARACTER NUM(13) CHARACTER*30 FNAMEA,FNAMEB CHARACTER*60 JFMT,NAME NUM(1)='0' NUM(2)='1' NUM(3)='2' NUM(4)='3' NUM(5)='4' NUM(6)='5' NUM(7)='6' NUM(8)='7' NUM(9)='8' NUM(10)='9' NUM(11)=' ' NUM(12)='*' NUM(13)='+' NSTAN=0 WRITE (*,9500) WRITE (*,9505) WRITE (*,9510) 120 WRITE (*,9525)MAXXX 130 WRITE (*,9530) MAXXX READ (*,*) NN IF(NN.GE.100.AND.NN.LE.MAXXX)GO TO 140 WRITE (*,9520) GOTO 130 140 WRITE(*,9550) 160 WRITE(*,9560) READ(*,*)KK IF(KK.GE.1)GO TO 170 WRITE(*,9570)KK GO TO 160 170 IF(KK.LE.30)GO TO 200 WRITE(*,9580)KK GO TO 160 CC CC IN THIS SECTION SPECIFIC INFORMATION RELATED TO THE INPUT CC IS ENTERED : CC NUMBER OF VARIABLES (JPP) CC LABELS OF VARIABLES CC CHOICE OF STANDARDIZATION CC CHOICE OF EUCLIDEAN OR MANHATTAN DISTANCE CC 200 WRITE(*,9620)MAXTT 210 WRITE(*,9630)MAXTT READ(*,*)JPPT IF(JPPT.GE.1.AND.JPPT.LE.MAXTT)GO TO 220 WRITE(*,9520) GO TO 210 220 IF(JPPT.NE.1)GO TO 230 JPP=1 JPLACE(1)=1 GO TO 240 230 MAXV=MAXXX/NN WRITE(*,9640) IF(MAXV.LT.JPPT)WRITE(*,9645)MAXV,MAXXX,MAXV IF(MAXV.GE.JPPT)WRITE(*,9646)JPPT READ(*,*)JPP IF(JPP.GE.1.AND.JPP.LE.JPPT)GO TO 240 WRITE(*,9520) GO TO 230 240 NNPP=NN*JPP IF(NNPP.LE.MAXXX)GO TO 250 WRITE(*,9540)NNPP GO TO 230 250 IF(JPPT.GT.JPP)GO TO 280 DO 260 J=1,JPP JPLACE(J)=J 260 CONTINUE WRITE(*,9650) DO 270 J=1,JPP WRITE(*,9660)J READ(*,8500)(JLAB(K,J),K=1,10) 270 CONTINUE GO TO 320 280 WRITE(*,9670) DO 310 J=1,JPP 290 WRITE(*,9680)J READ(*,8520)JPLACE(J),(JLAB(K,J),K=1,10) IF(JPLACE(J).LT.1.OR.JPLACE(J).GT.JPPT)GO TO 290 IF(J.EQ.1)GO TO 310 JPPL=J-1 DO 300 JK=1,JPPL IF(JPLACE(JK).NE.JPLACE(J))GO TO 300 WRITE(*,9690) GO TO 290 300 CONTINUE 310 CONTINUE 320 WRITE(*,9700) CALL QYN(STAN,NSTAN) WRITE(*,9710) 330 READ(*,8500)DYST NDYST=0 IF(DYST.EQ.'E'.OR.DYST.EQ.'e')NDYST=1 IF(DYST.EQ.'M'.OR.DYST.EQ.'m')NDYST=2 IF(NDYST.NE.0)GO TO 400 WRITE(*,9520) GO TO 330 CC CC OUTPUT SECTION : CC TITLE CC SMALL, MEDIUM SIZED OR LARGE OUTPUT CC GRAPHICAL OUTPUT (SILHOUETTES) CC 400 WRITE (*,9720) READ (*,8530)NAME 410 WRITE(*,9730) READ(*,8560)LARGE IF(LARGE.GE.0.AND.LARGE.LE.2)GO TO 420 WRITE(*,9520) GO TO 410 420 IF(KK.GT.1)GO TO 430 CGRAP='N' LGRAP=0 GO TO 500 430 WRITE(*,9740) CALL QYN(CGRAP,LGRAP) CC CC FORMATS CC 500 WRITE (*,9780) CALL QYN(CYNFF,NFF) IF (CYNFF.EQ.'Y') GOTO 600 WRITE(*,9790) READ (*,8530)JFMT CC CC STATUS OF INPUT AND OUTPUT : KEYBOARD, SCREEN, PRINTER, FILE CC 600 WRITE(*,9800) READ(*,8550)FNAMEA OPEN(LUA,FILE=FNAMEA,IOSTAT=NER,ERR=610) GO TO 620 610 IF(NER.EQ.1027.OR.NER.EQ.1030.OR.NER.EQ.1032.OR.NER.EQ.1033) F THEN WRITE(*,9810) GO TO 600 ENDIF WRITE(*,9820)NER STOP 620 WRITE(*,9830) READ(*,8550)FNAMEB IF(FNAMEB.EQ.'con'.OR.FNAMEB.EQ.'Con')FNAMEB='CON' IF(FNAMEB.EQ.'prn'.OR.FNAMEB.EQ.'Prn')FNAMEB='PRN' IF (FNAMEB.EQ.'CON'.OR.FNAMEB.EQ.'PRN')OPEN(LUB,FILE=FNAMEB) IF (.NOT.(FNAMEB.EQ.'CON'.OR.FNAMEB.EQ.'PRN'))OPEN(LUB, F FILE=FNAMEB,STATUS='NEW',IOSTAT=NET,ERR=630) GO TO 650 630 IF(NET.NE.1027.AND.NET.NE.1030.AND.NET.NE.1032. F AND.NET.NE.1033.AND.NET.NE.1045)GO TO 640 WRITE(*,9810) GO TO 620 640 WRITE(*,9820)NET STOP CC CC SECTION ON MISSING DATA CC 650 WRITE (*,9840) CALL QYN(CDATA,MDATA) IF(MDATA.EQ.0) GO TO 740 WRITE(*,9850) CALL QYN(CMDT,MDT) IF(MDT.EQ.0)GO TO 710 WRITE(*,9860) READ(*,*)VVAL DO 700 J=1,JPP JTMD(J)=-1 VALMD(J)=VVAL 700 CONTINUE GO TO 800 710 DO 730 J=1,JPP WRITE (*,9870)(JLAB(K,J),K=1,10) CALL QYN(CYNK,NYNK) IF (CYNK.EQ.'Y') GOTO 720 JTMD(J)=1 VALMD(J)=-99.99 GO TO 730 720 JTMD(J)=-1 WRITE(*,9880) READ (*,*) VALMD(J) 730 CONTINUE GO TO 800 740 DO 750 J=1,JPP JTMD(J)=1 VALMD(J)=-99.99 750 CONTINUE CC CC RECAPITULATION OF OPTIONS AND PARAMETERS CC 800 WRITE(*,9890) WRITE (*,9900) WRITE (*,9905)NAME WRITE(*,9910)NN WRITE(*,8110)KK IF(LARGE.EQ.0)WRITE(*,8090) IF(LARGE.EQ.1)WRITE(*,8092) IF(LARGE.EQ.2)WRITE(*,8095) IF(CGRAP.EQ.'Y')WRITE(*,8100) IF(CGRAP.EQ.'N')WRITE(*,8105) IF(JPPT.GT.1) GO TO 810 WRITE(*,8118) GO TO 820 810 WRITE(*,8115)JPPT IF(JPP.GT.1) WRITE(*,8116)JPP IF(JPP.EQ.1) WRITE(*,8119)(JLAB(K,1),K=1,10),JPLACE(1) 820 IF(STAN.EQ.'Y')WRITE(*,8120) IF(STAN.EQ.'N')WRITE(*,8125) IF(NDYST.EQ.1)WRITE(*,8130) IF(NDYST.EQ.2)WRITE(*,8135) IF(MDATA.EQ.0)WRITE(*,8145) IF(MDATA.EQ.0)GO TO 830 IF(CMDT.EQ.'N')WRITE(*,8140) IF(CMDT.EQ.'Y')WRITE(*,8142) IF(CMDT.EQ.'Y')WRITE(*,*)VVAL 830 IF (CYNFF.EQ.'Y') WRITE(*,8160) IF (CYNFF.EQ.'N') WRITE(*,8165) JFMT WRITE(*,8039) FNAMEA WRITE(*,8040) FNAMEB WRITE (*,8030) CALL QYN(CEX,NEX) IF (CEX.NE.'Y') GOTO 120 IF(FNAMEB.EQ.'CON')GO TO 900 WRITE(LUB,9500) WRITE(LUB,9505) WRITE(LUB,9510) WRITE(LUB,9905)NAME WRITE(LUB,9900) WRITE(LUB,9910)NN WRITE(LUB,8110)KK IF(LARGE.EQ.0)WRITE(LUB,8090) IF(LARGE.EQ.1)WRITE(LUB,8092) IF(LARGE.EQ.2)WRITE(LUB,8095) IF(LGRAP.NE.0)WRITE(LUB,8100) IF(LGRAP.EQ.0)WRITE(LUB,8105) IF(JPPT.GT.1) GO TO 852 WRITE(LUB,8118) GO TO 865 852 WRITE(LUB,8115)JPPT IF(JPP.GT.1) GO TO 854 WRITE(LUB,8119)(JLAB(K,1),K=1,10),JPLACE(1) GO TO 865 854 WRITE(LUB,8116)JPP WRITE(LUB,8114) DO 860 J=1,JPP WRITE(LUB,8117)(JLAB(K,J),K=1,10),JPLACE(J) 860 CONTINUE 865 IF(NSTAN.EQ.0)WRITE(LUB,8125) IF(NSTAN.EQ.1)WRITE(LUB,8120) IF(NDYST.EQ.1)WRITE(LUB,8130) IF(NDYST.EQ.2)WRITE(LUB,8135) IF(MDATA.EQ.0)WRITE(LUB,8145) IF(MDATA.EQ.0)GO TO 870 WRITE(LUB,8140) IF(CMDT.EQ.'Y')WRITE(LUB,8142) IF(CMDT.EQ.'Y')WRITE(LUB,*)VVAL 870 IF (CYNFF.EQ.'Y') WRITE(LUB,8160) IF (CYNFF.EQ.'N') WRITE(LUB,8165) JFMT IF (FNAMEB.EQ.'CON') PAUSE ' ' IF(FNAMEB.NE.'CON')WRITE(LUB,*) WRITE(LUB,8039) FNAMEA CC CC INPUT OF DATA CC 900 NDEX=0 DO 920 JC=1,NN IF(CYNFF.EQ.'N') READ(LUA,JFMT)(HULP(J),J=1,JPPT) IF(CYNFF.EQ.'Y') READ(LUA,*)(HULP(J),J=1,JPPT) DO 910 J=1,JPP NDEX=NDEX+1 JH=JPLACE(J) X(NDEX)=HULP(JH) 910 CONTINUE 920 CONTINUE RETURN 8030 FORMAT(/1X,' ARE ALL THESE OPTIONS OK ? YES OR NO : '$) 8039 FORMAT(1X,' YOUR DATA RESIDE ON FILE : ',A30/) 8040 FORMAT(1X,' YOUR OUTPUT WILL BE WRITTEN ON : ',A30) 8090 FORMAT(' SMALL OUTPUT IS WANTED') 8092 FORMAT(' MEDIUM SIZED OUTPUT IS WANTED') 8095 FORMAT(' LARGE OUTPUT IS WANTED') 8100 FORMAT(1X,' GRAPHICAL OUTPUT IS WANTED (SILHOUETTES)') 8105 FORMAT(1X,' THERE WILL BE NO GRAPHICAL OUTPUT') 8110 FORMAT(' THE OBJECTS WILL BE CLUSTERED INTO ',I4,' CLUSTERS') 8114 FORMAT(' These variables are :') 8115 FORMAT(/1X,' THERE ARE ',I4,' VARIABLES IN THE DATA SET,') 8116 FORMAT(1X,' AND ',I4,' OF THEM WILL BE USED IN THE ANALYSIS') 8117 FORMAT(10X,10A1,' (POSITION :',I3,')') 8118 FORMAT(/1X,' THERE IS ONE VARIABLE IN THE DATA SET ') 8119 FORMAT(1X,' AND ONLY VARIABLE ',10A1,' WILL BE USED IN THE', F ' ANALYSIS (POSITION :',I3,')') 8120 FORMAT(1X,' THE MEASUREMENTS WILL BE STANDARDIZED') 8125 FORMAT(1X,' THE MEASUREMENTS WILL NOT BE STANDARDIZED') 8130 FORMAT(1X,' EUCLIDEAN DISTANCE WILL BE USED') 8135 FORMAT(1X,' MANHATTAN DISTANCE WILL BE USED') 8140 FORMAT(1X,' MISSING VALUES CAN OCCUR') 8142 FORMAT(1X,' THE UNIQUE VALUE WHICH REPRESENTS MISSING', F' MEASUREMENTS IS :'/6X$) 8145 FORMAT(1X,' THERE ARE NO MISSING VALUES') 8160 FORMAT(1X,' THE MEASUREMENTS WILL BE READ IN FREE FORMAT') 8165 FORMAT(1X,' THE INPUT FORMAT FOR THE MEASUREMENTS IS'/2X,A60) 8500 FORMAT(10A1) 8520 FORMAT(BNI4,6X,10A1) 8530 FORMAT(A60) 8550 FORMAT(A30) 8560 FORMAT(I1) 9500 FORMAT(/22X,35('*')/22X,'*',33X,'*'/22X,'* CLUSTE', F'RING LARGE APPLICATIONS *'/22X,'*',33X,'*'/22X,35('*')/) 9505 FORMAT(/' Copyright (C) Leonard Kaufman and Peter Rousseeuw', F ' 1990. All rights reserved.') 9510 FORMAT(/5X,' This clustering algorithm', F ' is based on the k-medoid approach.', F /5X,' More information can be found in Chapter 3 of:' F //5X,' L. Kaufman and P.J. Rousseeuw (1990),' F /5X,' Finding Groups in Data : An Introduction to Cluster', F ' Analysis,' F /5X,' Wiley, New York.'/) 9520 FORMAT(1X,'NOT ALLOWED ! PLEASE ENTER YOUR CHOICE AGAIN : '$) 9525 FORMAT(//1X,'THE PRESENT VERSION OF CLARA CAN HANDLE', F ' DATA SETS WITH AT LEAST 100 OBJECTS,'/1X,'AND AT MOST', F I7,/1X'(IF FEWER THAN 100 OBJECTS ARE TO BE CLUSTERED', F ' PLEASE USE THE PROGRAM PAM)') 9530 FORMAT(/1X,'HOW MANY OBJECTS ARE TO BE CLUSTERED ? '/1X, F38('-')/1X,'PLEASE GIVE A NUMBER OF AT LEAST 100', F ', AND AT MOST ',I7,' : '$) 9540 FORMAT(/1X,' THE NUMBER OF MEASUREMENTS WAS GIVEN AS',I7,'.' F/1X,' THIS EXCEEDS THE TOTAL NUMBER ALLOWED.') 9550 FORMAT(//1X,'CLARA CAN HANDLE UP TO 30 CLUSTERS.') 9560 FORMAT(/1X,'HOW MANY CLUSTERS ARE WANTED ? '/1X,30('-')/ F 1X,'PLEASE ENTER A NUMBER BETWEEN 1 AND 30 : '$) 9570 FORMAT(/1X,'THE NUMBER OF CLUSTERS WAS GIVEN AS ',I6, F' ,'/1X,'IT SHOULD BE AT LEAST ONE,') 9580 FORMAT(/1X,'THE NUMBER OF CLUSTERS WAS GIVEN AS ',I6, F' ,'/' IT SHOULD NOT EXCEED THE MAXIMAL NUMBER ALLOWED : 30') 9620 FORMAT(//1X,'IN THE PRESENT VERSION OF THE PROGRAM UP TO' F ,I5,' VARIABLES CAN BE ENTERED.'/1X,'(IF MORE ARE', F ' NEEDED, THE ARRAYS INSIDE THE PROGRAM MUST BE ADAPTED)') 9630 FORMAT(/1X,'WHAT IS THE TOTAL NUMBER OF VARIABLES IN YOUR', F' DATA SET ?'/1X,56('-')/ F' PLEASE GIVE A NUMBER BETWEEN 1 AND ',I6,' : '$) 9640 FORMAT(/' HOW MANY VARIABLES DO YOU WANT TO USE IN THE ', F 'ANALYSIS ?'/1X,55('-')) 9645 FORMAT(' (Note that the number of variables may not exceed', F I3,/' because the program can store at most ',I5, F ' measurements',/' PLEASE ENTER A NUMBER BETWEEN 1 AND ',I3, F ' : '$) 9646 FORMAT(' PLEASE ENTER A NUMBER BETWEEN 1 AND ',I3,' : '$) 9650 FORMAT(//1X,'VARIABLE TO BE USED ', F' LABEL (AT MOST 10 CHARACTERS)'/ F 1X,17('-'),4(1H),6('-'),10(1H),19('-')) 9660 FORMAT(1X,'NUMBER : ',I4,6X,$) 9670 FORMAT(//1X,'VARIABLE TO BE USED : POSITION', F ' LABEL (AT MOST 10 CHARACTERS)'/ F 1X,32('-'),4(1H),6('-'),10(1H),19('-')) 9680 FORMAT(1X,'NUMBER ',I4,15X,': '$) 9690 FORMAT(/' THIS POSITION HAS ALREADY BEEN CHOSEN FOR ANOTHER', F' VARIABLE.'/1X,'ENTER THE RIGHT POSITION PLEASE :') 9700 FORMAT(/' DO YOU WANT THE MEASUREMENTS TO BE STANDARDIZED', F ' ? (YES OR NO) ',6('.'),' : '$) 9710 FORMAT(/1X,'DO YOU WANT TO USE EUCLIDEAN DISTANCE ? (PLEASE', F' ANSWER E)'/1X,'OR DO YOU PREFER MANHATTAN DISTANCE ?', F' (THEN ANSWER M) .............. : '$) 9720 FORMAT(/1X,'PLEASE ENTER A TITLE FOR THE OUTPUT (AT MOST 60', F ' CHARACTERS)'/1X,60('-')/1X$) 9730 FORMAT(/1X,'HOW MUCH OUTPUT DO YOU WANT ?'/3X,'SMALL OUTPUT', F' (PLEASE ANSWER 0)'/3X,'MEDIUM SIZED OUTPUT (PLEASE', F' ANSWER 1) : INCLUDES DETAILS ON CLUSTERING'/3X,'OR LARGE', F' OUTPUT (PLEASE ANSWER 2) : ALSO INCLUDES DETAILS ON', F' THE DATA'/1X,67('.'),' : ',$) 9740 FORMAT(/' DO YOU WANT GRAPHICAL OUTPUT (SILHOUETTES) ?', F' PLEASE ANSWER YES OR NO : '$) 9780 FORMAT(/' DO YOU WANT TO READ THE DATA IN FREE FORMAT ?'/1X, F 45('-')/' THIS MEANS THAT YOU ONLY HAVE TO INSERT BLANK(S)', F ' BETWEEN NUMBERS.'/' (NOTE: WE ADVISE USERS WITHOUT', F ' KNOWLEDGE OF FORTRAN FORMATS TO ANSWER YES.)'/ F ' MAKE YOUR CHOICE (YES/NO) ',18('.'),' : '$) 9790 FORMAT(/1X,'YOUR DESIRED FORTRAN FORMAT IS :'/ F1X'(BETWEEN BRACKETS AND', F ' AT MOST 60 CHARACTERS, e.g. (2F3.0,F1.0) )') 9800 FORMAT(/1X,'PLEASE GIVE THE NAME OF THE FILE CONTAINING', F' THE DATA (e.g. TYPE A:TEST.DAT) '/1X,44('.'),' : ',$) 9810 FORMAT(/' THIS FILE WAS NOT FOUND, PLEASE ENTER ANOTHER ONE') 9820 FORMAT(/' FORTRAN ERROR CODE : ',I8) 9830 FORMAT(/1X,'WHERE DO YOU WANT YOUR OUTPUT ?'/1X,32('-')/ 1 43H TYPE CON IF YOU WANT IT ON THE SCREEN/ 1 44H OR TYPE PRN IF YOU WANT IT ON THE PRINTER/ 1 48H OR TYPE THE NAME OF A FILE (e.g. B:EXAMPLE.OUT)/ 1 56H (WARNING : IF THERE ALREADY EXISTS A FILE WITH THE SAME, F' NAME'/12X,'THEN THE OLD FILE WILL BE OVERWRITTEN.)'/ 1 ' WHAT DO YOU CHOOSE ? ....................... : '$) 9840 FORMAT(/1X,'CAN MISSING DATA OCCUR IN THE MEASUREMENTS ?' F/1X,'PLEASE ANSWER YES OR NO ',20('.'),' : '$) 9850 FORMAT(/' IS THERE A UNIQUE VALUE WHICH IS TO BE INTERPRETED'/ F ' AS A MISSING MEASUREMENT VALUE FOR ANY VARIABLE ? '/ F ' PLEASE ANSWER YES OR NO : '$) 9860 FORMAT(/' PLEASE ENTER THIS VALUE NOW : '$) 9870 FORMAT(/' SHOULD MISSING VALUES BE FORESEEN FOR VARIABLE ', F 10A1,' ?'/' PLEASE ANSWER YES OR NO : '$) 9880 FORMAT(1X,'ENTER THE VALUE OF THIS VARIABLE WHICH HAS TO BE', F' INTERPRETED AS'/1X,'THE MISSING VALUE CODE : '$) 9890 FORMAT(//////////) 9900 FORMAT(/' DATA SPECIFICATIONS AND CHOSEN OPTIONS'/1X,38('-')) 9905 FORMAT(1X,' TITLE : ',A60/) 9910 FORMAT(1X,' THERE ARE ',I4,' OBJECTS') END CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCCC file FANNY.FOR (Chapter 4) 41k CCCCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC PROGRAM FANNY CC CC PROGRAM FOR FUZZY CLUSTER ANALYSIS CC CC dimension of NSEND,NEGBR,NELEM,NCLUV,DVEC,SYL is MAXNN: DIMENSION NSEND(100),NEGBR(100),NELEM(100),NCLUV(100) DIMENSION DVEC(100),SYL(100) CC dim. X(MAXNN,MAXPP),P(MAXNN,MAXKK),DP(MAXNN,MAXKK),DSS(MAXHH): DIMENSION X(100,20),P(100,10),DP(100,10),DSS(4951) CC dim. VALMD,JTMD,JPLACE(MAXPP),HULP(MAXTT),ESP,EF,PT,NFUZZ(MAXKK): DIMENSION VALMD(20),JTMD(20),JPLACE(20),HULP(80) DIMENSION PT(10),NFUZZ(10),ESP(10),EF(10) CC dim. LAB(3,MAXNN),JLAB(10,MAXPP): CHARACTER LAB(3,100),JLAB(10,20),NUM(13),YNSAVE CHARACTER*30 FNAMEA,FNAMEB,FNAMEC CHARACTER*60 JFMT,NAME CC MAXNN=100 MAXTT=80 MAXPP=20 MAXKK=10 MAXHH=4951 CC CC WHERE: CC MAXNN = MAXIMAL NUMBER OF OBJECTS CC MAXTT = MAXIMAL NUMBER OF VARIABLES IN DATA SET CC MAXPP = MAXIMAL NUMBER OF VARIABLES FOR CLUSTERING CC MAXKK = MAXIMAL NUMBER OF CLUSTERS CC MAXHH = (MAXNN*(MAXNN-1))/2 + 1 CC CC------------------------------------------------------------------- CC CC LOGICAL INPUT AND OUTPUT UNITS : CC LUA = LOGICAL UNIT A (INPUT) CC LUB = LOGICAL UNIT B (OUTPUT) CC LUC = LOGICAL UNIT C (OUTPUT OF DATA MATRIX) CC THE USER SHOULD ASSIGN TO LUA, LUB, AND LUC, THE NUMBERS USED BY CC HIS OWN COMPUTER : ONLY THE NEXT 3 STATEMENTS MUST BE CHANGED: CC LUA=1 LUB=2 LUC=3 CC CALL ENTR(NN,JPP,KBEG,KEND,MAXNN,MAXTT,MAXPP,MAXKK, F MAXHH,X,DVEC,DSS,VALMD,JTMD,JPLACE,HULP,NUM,LUA,LUB,LUC, F FNAMEA,FNAMEB,FNAMEC,LAB,JLAB,NAME,YNSAVE,JDYSS,NSTAN, F NDYST,LARGE,LGRAP,JLABS,NFF,JFMT,MDATA) IF(JDYSS.EQ.1)GO TO 100 IF(MDATA.EQ.0)GOTO 48 CC CC INSPECTION OF OBJECTS FOR MISSING VALUES CC WRITE(LUB,*) JHALT=0 DO 20 L=1,NN DO 10 J=1,JPP IF(JTMD(J).GE.0)GOTO 20 IF(X(L,J).NE.VALMD(J))GOTO 20 10 CONTINUE WRITE(LUB,9041)LAB(1,L),LAB(2,L),LAB(3,L) JHALT=1 20 CONTINUE CC CC INSPECTION OF VARIABLES FOR MISSING VALUES CC MYST=0 DO 45 J=1,JPP MYSJ=0 IF(JTMD(J).GE.0)GOTO 45 DO 46 L=1,NN IF(X(L,J).EQ.VALMD(J))MYSJ=MYSJ+1 46 CONTINUE MYST=MYST+MYSJ IF(MYSJ.EQ.0)GOTO 45 WRITE(LUB,9045)(JLAB(K,J),K=1,10),MYSJ IF(MYSJ.LT.NN)GOTO 45 WRITE(LUB,9047)(JLAB(K,J),K=1,10) IF(NFF.EQ.0)WRITE(LUB,9048) JHALT=1 45 CONTINUE WRITE(LUB,9049)MYST IF(JHALT.EQ.1)STOP CC CC STANDARDIZATION AND DISTANCES CC 48 IF(NSTAN.EQ.0)GO TO 70 CALL STAND(NN,JPP,MAXNN,MAXPP,X,JTMD,VALMD,JHALT,JLAB, F LUB,FNAMEB) IF(JHALT.EQ.1)STOP IF(LARGE.EQ.0)GO TO 70 WRITE(LUB,9031) IF(MDATA.NE.0)WRITE(LUB,9032) JPEND=JPP IF(JPP.GT.8)JPEND=8 DO 60 L=1,NN WRITE(LUB,9033)LAB(1,L),LAB(2,L),LAB(3,L),(X(L,J),J=1,JPEND) IF(JPP.GT.8)WRITE(LUB,9040)(X(L,J),J=9,JPP) 60 CONTINUE 70 CALL DYSTA(NN,JPP,MAXNN,MAXPP,MAXHH,X,DSS,NDYST,JTMD, F VALMD,LAB,JHALT,LUB,FNAMEB) IF(JHALT.EQ.1)STOP 100 IF(LARGE.EQ.0)GO TO 125 WRITE(LUB,9060) WRITE(LUB,9033)LAB(1,1),LAB(2,1),LAB(3,1) DO 120 L=2,NN LSUBT=L-1 JPEND=LSUBT IF(LSUBT.GT.8)JPEND=8 DO 110 J=1,LSUBT NLJ=NN*(J-1)+L-(J*(J+1))/2 DVEC(J)=DSS(NLJ) 110 CONTINUE WRITE(LUB,9033)LAB(1,L),LAB(2,L),LAB(3,L),(DVEC(J),J=1,JPEND) IF(LSUBT.GT.8)WRITE(LUB,9040)(DVEC(J),J=9,LSUBT) 120 CONTINUE 125 S=0.0 NHALF=NN*(NN-1)/2+1 L=1 130 L=L+1 IF(DSS(L).GT.S)S=DSS(L) IF(L.LT.NHALF)GO TO 130 DO 140 KK=KBEG,KEND IF(KK.EQ.KBEG)GO TO 135 KMP=KK-1 IF(FNAMEB.NE.'CON')WRITE(*,9068)KMP,KK 135 IF(FNAMEB.EQ.'CON') PAUSE ' ' WRITE(LUB,9070)KK CALL FUZZY(NN,MAXNN,MAXKK,MAXHH,P,DP,PT,LAB,DSS,ESP,EF, F EDA,EDB,KK,LUB) CALL CADDY(NN,MAXNN,MAXKK,P,LAB,KK,KTRUE,LUB, F NFUZZ,NCLUV,PT,NELEM,EDA,EDB) IF(LGRAP.EQ.0)GO TO 140 IF(KTRUE.LE.1)GO TO 140 IF(KTRUE.GE.NN)GO TO 140 CALL FYGUR(KTRUE,NN,MAXNN,MAXKK,MAXHH,NCLUV,NSEND,NELEM F,NEGBR,SYL,DVEC,PT,DSS,LAB,LUB,S,NUM(11),NUM(12),NUM(13)) IF(FNAMEB.EQ.'CON') PAUSE ' ' 140 CONTINUE WRITE(*,9085) IF(YNSAVE.EQ.'Y'.AND.FNAMEB.EQ.'CON')WRITE(*,9090)FNAMEC IF(FNAMEB.NE.'PRN'.AND.FNAMEB.NE.'CON')WRITE(*,9095)FNAMEB IF(FNAMEB.EQ.'PRN')WRITE(*,9096) IF(FNAMEB.NE.'PRN'.AND.FNAMEB.NE.'CON')WRITE(LUB,9095)FNAMEB STOP 9031 FORMAT(//' STANDARDIZED MEASUREMENTS'/1X,25(1H-)/) 9032 FORMAT(' ( 99.99 DENOTES A MISSING VALUE)'//) 9033 FORMAT(1X,3A1,2X,8F9.2) 9040 FORMAT(6X,8F9.2) 9041 FORMAT(/' OBJECT ',3A1,' CONTAINS ONLY MISSING VALUES', F ' AND MUST BE REMOVED.'/) 9045 FORMAT(' VARIABLE ',10A1,' CONTAINS',I5,' MISSING VALUES') 9047 FORMAT(/' VARIABLE',10A1,' CONTAINS ONLY MISSING VALUES', F ' AND MUST BE REMOVED.') 9048 FORMAT(' (THIS CAN BE DONE BY CHANGING THE NUMBER OF', F ' VARIABLES AND THE INPUT FORMAT.)'/) 9049 FORMAT(/' THE TOTAL NUMBER OF MISSING VALUES IS',I7//) 9060 FORMAT(//' DISSIMILARITY MATRIX'/1X,20(1H-)/) 9068 FORMAT(' I am finished with',I3,' clusters, working on',I3) 9070 FORMAT(//1X,32(1H*)/1X,1H*,30X,1H*/' * NUMBER OF', F' CLUSTERS',I6,4X,1H*/1X,1H*,30X,1H*/1X,32(1H*)) 9085 FORMAT(/' This run has been successfully completed'/) 9090 FORMAT(/1X,'Your data is on file : ',A30) 9095 FORMAT(/1X,'The output is on file : ',A30) 9096 FORMAT(/1X,'The output was sent to the printer') END CC CC SUBROUTINE NWLAB(NN,MAXNN,NUM,LAB) CHARACTER LAB(3,MAXNN),NUM(13) LLA=1 LLB=1 LLC=1 DO 50 J=1,NN IF(LLC.LT.10)GOTO 10 LLC=0 IF(LLB.LT.10)GOTO 20 LLB=0 LLA=LLA+1 20 LLB=LLB+1 10 LLC=LLC+1 LAB(1,J)=NUM(LLA) LAB(2,J)=NUM(LLB) LAB(3,J)=NUM(LLC) 50 CONTINUE RETURN END CC CC SUBROUTINE QYN(YN,NYN) CHARACTER YN 10 READ(*,8000)YN IF(YN.EQ.'y')YN='Y' IF(YN.EQ.'n')YN='N' IF(YN.EQ.'Y')NYN=1 IF(YN.EQ.'N')NYN=0 IF(YN.EQ.'Y'.OR.YN.EQ.'N')GO TO 20 WRITE(*,9000) GO TO 10 20 RETURN 8000 FORMAT(A1) 9000 FORMAT(' NOT ALLOWED! PLEASE ENTER YOUR CHOICE AGAIN: '$) END CC CC SUBROUTINE STAND(NN,JPP,MAXNN,MAXPP,X,JTMD,VALMD,JHALT, F JLAB,LUB,FNAMEB) DIMENSION X(MAXNN,MAXPP),JTMD(MAXPP),VALMD(MAXPP) CHARACTER JLAB(10,MAXPP) CHARACTER*30 FNAMEB RNN=NN DO 200 J=1,JPP AVERA=0.0 STAM=0.0 IF(JTMD(J).GE.0)GOTO 100 NPRES=0 DO 20 L=1,NN IF(X(L,J).EQ.VALMD(J))GOTO 20 NPRES=NPRES+1 AVERA=AVERA+X(L,J) 20 CONTINUE IF(NPRES.LE.1)GOTO 300 RPRES=NPRES AVERA=AVERA/RPRES DO 50 L=1,NN IF(X(L,J).EQ.VALMD(J))GOTO 50 STAM=STAM+ABS(X(L,J)-AVERA) 50 CONTINUE STAM=STAM/RPRES WRITE(LUB,9320)(JLAB(K,J),K=1,10),AVERA,STAM IF(STAM.LE.0.0)GOTO 300 DO 60 L=1,NN IF(X(L,J).EQ.VALMD(J))GOTO 70 X(L,J)=(X(L,J)-AVERA)/STAM IF(X(L,J).GT.49.0)X(L,J)=49.0 IF(X(L,J).LT.(-49.0))X(L,J)=-49.0 GOTO 60 70 X(L,J)=99.99 60 CONTINUE VALMD(J)=99.99 GOTO 200 100 DO 120 L=1,NN AVERA=AVERA+X(L,J) 120 CONTINUE AVERA=AVERA/RNN DO 150 L=1,NN STAM=STAM+ABS(X(L,J)-AVERA) 150 CONTINUE STAM=STAM/RNN WRITE(LUB,9320)(JLAB(K,J),K=1,10),AVERA,STAM IF(STAM.LE.0.0)GOTO 300 DO 160 L=1,NN X(L,J)=(X(L,J)-AVERA)/STAM IF(X(L,J).GT.49.0)X(L,J)=49.0 IF(X(L,J).LT.(-49.0))X(L,J)=-49.0 160 CONTINUE GOTO 200 300 JHALT=1 WRITE(LUB,9300)(JLAB(K,J),K=1,10) WRITE(LUB,9310) IF(FNAMEB.NE.'CON')WRITE(*,9300)(JLAB(K,J),K=1,10) IF(FNAMEB.NE.'CON')WRITE(*,9310) 200 CONTINUE RETURN 9300 FORMAT(/' THE MEAN ABSOLUTE DEVIATION OF VARIABLE ',10A1, F /' IS ZERO (UP TO COMPUTER PRECISION).') 9310 FORMAT(' PLEASE REMOVE THIS VARIABLE AND USE THE PROGRAM AG', F'AIN.'/' (THIS CAN BE DONE BY CHANGING THE INPUT FORMAT.)'/) 9320 FORMAT(' VARIABLE',10A1,' HAS AVERAGE ',F10.3, F ', MEAN DEVIATION',F10.3) END CC CC SUBROUTINE DYSTA(NN,JPP,MAXNN,MAXPP,MAXHH,X,DSS,NDYST, F JTMD,VALMD,LAB,JHALT,LUB,FNAMEB) DIMENSION X(MAXNN,MAXPP),DSS(MAXHH),JTMD(MAXPP),VALMD(MAXPP) CHARACTER LAB(3,MAXNN) CHARACTER*30 FNAMEB PP=JPP NNSUB=NN-1 NLK=0 DO 100 L=1,NNSUB LPLUS=L+1 DO 20 K=LPLUS,NN CLK=0.0 NLK=NLK+1 NPRES=0 DO 30 J=1,JPP IF(JTMD(J).GE.0)GOTO 40 IF(X(L,J).EQ.VALMD(J))GOTO 30 IF(X(K,J).EQ.VALMD(J))GOTO 30 40 NPRES=NPRES+1 IF(NDYST.NE.1)GOTO 50 CLK=CLK+(X(L,J)-X(K,J))*(X(L,J)-X(K,J)) GOTO 30 50 CLK=CLK+ABS(X(L,J)-X(K,J)) 30 CONTINUE RPRES=NPRES IF(NPRES.NE.0)GOTO 60 JHALT=1 WRITE(LUB,9400)LAB(1,L),LAB(2,L),LAB(3,L), F LAB(1,K),LAB(2,K),LAB(3,K) IF(FNAMEB.NE.'CON')WRITE(*,9400)LAB(1,L),LAB(2,L),LAB(3,L), F LAB(1,K),LAB(2,K),LAB(3,K) DSS(NLK)=0.0 GOTO 20 60 IF(NDYST.NE.1)GOTO 70 DSS(NLK)=SQRT(CLK*(PP/RPRES)) GOTO 20 70 DSS(NLK)=CLK*(PP/RPRES) 20 CONTINUE 100 CONTINUE RETURN 9400 FORMAT(' OBJECTS ',3A1,' AND ',3A1) F ' HAVE NO COMMON MEASUREMENTS') END CC CC SUBROUTINE FUZZY(NN,MAXNN,MAXKK,MAXHH,P,DP,PT,LAB,DSS,ESP,EF, F EDA,EDB,K,LUB) DIMENSION P(MAXNN,MAXKK),DP(MAXNN,MAXKK),DSS(MAXHH) DIMENSION PT(MAXKK),ESP(MAXKK),EF(MAXKK) CHARACTER LAB(3,MAXNN) CC CC R IS THE EXPONENT, STRICTLY LARGER THAN 1.0 CC EPS IS THE PRECISION FOR THE ITERATIONS CC NYT IS THE MAXIMAL NUMBER OF ITERATIONS CC R=2.0 EPS=0.000001 NYT=500 CC CC INITIAL FUZZY CLUSTERING CC NNSUB=NN-1 RVERS=1./R RKME=K-1 DO 30 M=1,NN DO 20 L=1,K DP(M,L)=0. P(M,L)=0.1/RKME 20 CONTINUE 30 CONTINUE NDK=NN/K ND=NDK L=1 DO 50 M=1,NN P(M,L)=0.9 IF(M.LT.ND)GO TO 35 ND=ND+NDK L=L+1 IF(L.EQ.K)ND=NN 35 DO 40 LX=1,K P(M,LX)=P(M,LX)**R 40 CONTINUE 50 CONTINUE WRITE(LUB,9110) CC CC INITIAL CRITERION VALUE CC CRYT=0. DO 100 L=1,K ESP(L)=0. EF(L)=0. DO 90 M=1,NN ESP(L)=ESP(L)+P(M,L) DO 80 J=1,NN IF(J.EQ.M)GO TO 80 J2=MIN0(M,J) J1=(J2-1)*NN-(J2*(J2+1))/2+MAX0(M,J) DP(M,L)=DP(M,L)+P(J,L)*DSS(J1) EF(L)=EF(L)+P(J,L)*P(M,L)*DSS(J1) 80 CONTINUE 90 CONTINUE CRYT=CRYT+EF(L)/(ESP(L)*2.) 100 CONTINUE CRT=CRYT REEN=1./(R-1.) CC CC START OF ITERATIONS CC KAUNT=1 M=0 CC CC THE NEW MEMBERSHIP COEFFICIENTS OF THE OBJECTS ARE CALCULATED, CC AND THE RESULTING VALUE OF THE CRITERION IS COMPUTED. CC 200 M=M+1 DT=0. DO 210 L=1,K PT(L)=((2.*ESP(L)*ESP(L))/(2.*ESP(L)*DP(M,L)-EF(L)))**REEN DT=DT+PT(L) 210 CONTINUE XX=0. DO 220 L=1,K PT(L)=PT(L)/DT IF(PT(L).LE.0.)XX=XX+PT(L) 220 CONTINUE DO 240 L=1,K IF(PT(L).LE.0.)PT(L)=0. PT(L)=(PT(L)/(1-XX))**R ESP(L)=ESP(L)+PT(L)-P(M,L) DO 230 J=1,NN IF(J.EQ.M)GO TO 230 J2=MIN0(M,J) J1=(J2-1)*NN-(J2*(J2+1))/2+MAX0(M,J) DDD=(PT(L)-P(M,L))*DSS(J1) DP(J,L)=DP(J,L)+DDD EF(L)=EF(L)+2.*P(J,L)*DDD 230 CONTINUE P(M,L)=PT(L) 240 CONTINUE IF(M.LT.NN)GO TO 200 CRYT=0. EDA=0. DO 250 L=1,K ANN=NN EDA=EDA+ESP(L)/ANN CRYT=CRYT+EF(L)/(ESP(L)*2.) 250 CONTINUE CC CC CRITERION IS PRINTED AND TESTED FOR CONVERGENCE CC WRITE(LUB,9120)KAUNT,CRYT IF((CRT/CRYT-1.).LE.EPS)GO TO 500 IF(KAUNT.LT.NYT)GO TO 300 WRITE(LUB,9130)NYT GO TO 500 300 M=0 KAUNT=KAUNT+1 CRT=CRYT GO TO 200 CC CC NON-FUZZYNESS INDEX OF LIBERT IS COMPUTED CC 500 SMALL=1. FL=0. DO 410 MM=1,NN BBB=P(MM,1)**RVERS DO 400 J=2,K AAA=P(MM,J)**RVERS IF(AAA.GT.BBB)BBB=AAA 400 CONTINUE IF(BBB.LT.SMALL)SMALL=BBB FL=FL+BBB 410 CONTINUE RNN=NN FL=(FL/RNN+SMALL)/2. RK=K FL=(RK*FL-1.)/(RK-1.) CC WRITE(LUB,9135)FL ZK=K EDB=(ZK*EDA-1.)/(ZK-1.) DO 520 M=1,NN DO 510 L=1,K P(M,L)=P(M,L)**RVERS 510 CONTINUE 520 CONTINUE RETURN 9110 FORMAT(1X//' ITERATION',4X,' OBJECTIVE FUNCTION'/) 9120 FORMAT(1X,I5,11X,F11.4) 9130 FORMAT(/,' The maximum number of iterations (',I3, F ') has been reached.'/' The iterative procedure is' F ' therefore interrupted.') 9135 FORMAT(/33H NON-FUZZYNESS INDEX OF LIBERT = ,F5.2/) END CC CC SUBROUTINE CADDY(NN,MAXNN,MAXKK,P,LAB,K,KTRUE,LUB, F NFUZZ,NCLUV,RDRAW,NELEM,EDA,EDB) DIMENSION NCLUV(MAXNN),NELEM(MAXNN),P(MAXNN,MAXKK) DIMENSION NFUZZ(MAXKK),RDRAW(MAXKK) CHARACTER LAB(3,MAXNN),JDRAW(30) PBEST=P(1,1) NBEST=1 DO 10 L=2,K IF(P(1,L).LE.PBEST)GO TO 10 PBEST=P(1,L) NBEST=L 10 CONTINUE NFUZZ(1)=NBEST NCLUV(1)=1 KTRUE=1 DO 20 M=2,NN PBEST=P(M,1) NBEST=1 DO 30 L=2,K IF(P(M,L).LE.PBEST)GO TO 30 PBEST=P(M,L) NBEST=L 30 CONTINUE JSTAY=0 DO 40 KTRY=1,KTRUE IF(NFUZZ(KTRY).NE.NBEST)GO TO 40 NCLUV(M)=KTRY JSTAY=1 40 CONTINUE IF(JSTAY.EQ.1)GO TO 20 KTRUE=KTRUE+1 NFUZZ(KTRUE)=NBEST NCLUV(M)=KTRUE 20 CONTINUE IF(KTRUE.GE.K)GO TO 100 KNEXT=KTRUE+1 DO 60 KWALK=KNEXT,K DO 70 KLEFT=1,K JSTAY=0 KSUP=KWALK-1 DO 80 KTRY=1,KSUP IF(NFUZZ(KTRY).NE.KLEFT)GO TO 80 JSTAY=1 80 CONTINUE IF(JSTAY.EQ.1)GO TO 70 NFUZZ(KWALK)=KLEFT GO TO 60 70 CONTINUE 60 CONTINUE 100 WRITE(LUB,9200)(L,L=1,K) WRITE(LUB,9210) DO 110 M=1,NN DO 120 L=1,K LFUZZ=NFUZZ(L) RDRAW(L)=P(M,LFUZZ) 120 CONTINUE WRITE(LUB,9220)LAB(1,M),LAB(2,M),LAB(3,M),(RDRAW(L),L=1,K) 110 CONTINUE WRITE(LUB,9300)EDA,EDB WRITE(LUB,9230) IF(KTRUE.LT.K)WRITE(LUB,9240)KTRUE WRITE(LUB,9250) DO 160 NUMCL=1,KTRUE NTT=0 DO 150 J=1,NN IF(NCLUV(J).NE.NUMCL)GO TO 150 NTT=NTT+1 NELEM(NTT)=J 150 CONTINUE NSS=NTT IF(NSS.GT.10)NSS=10 DO 152 L=1,NSS LEEN=3*(L-1)+1 LTWE=3*(L-1)+2 LDRE=3*L NCASE=NELEM(L) JDRAW(LEEN)=LAB(1,NCASE) JDRAW(LTWE)=LAB(2,NCASE) JDRAW(LDRE)=LAB(3,NCASE) 152 CONTINUE NSSDR=NSS*3 WRITE(LUB,9260)NUMCL,NTT,(JDRAW(LL),LL=1,NSSDR) IF(NTT.LE.10)GO TO 160 KAUNT=0 DO 154 L=11,NTT KAUNT=KAUNT+1 LEEN=3*(KAUNT-1)+1 LTWE=3*(KAUNT-1)+2 LDRE=3*KAUNT NCASE=NELEM(L) JDRAW(LEEN)=LAB(1,NCASE) JDRAW(LTWE)=LAB(2,NCASE) JDRAW(LDRE)=LAB(3,NCASE) IF(KAUNT.EQ.10)GO TO 156 GO TO 154 156 WRITE(LUB,9270)(JDRAW(LL),LL=1,30) KAUNT=0 154 CONTINUE IF(KAUNT.GE.1)WRITE(LUB,9270)(JDRAW(LL),LL=1,LDRE) 160 CONTINUE WRITE(LUB,9280) WRITE(LUB,9290)(NCLUV(J),J=1,NN) RETURN 9200 FORMAT(1X//1X,16HFUZZY CLUSTERING/1X,16(1H*)/ F88(/3X,10I7)) 9210 FORMAT(1X) 9220 FORMAT(1X,3A1,10F7.4,87(/4X,10F7.4)) 9230 FORMAT(1X//24H CLOSEST HARD CLUSTERING/1X,23(1H*)/) 9240 FORMAT(/1X,44H FOR THIS HARD CLUSTERING, IT TURNS OUT THAT/ F1X,16H ONLY THE FIRST ,I4,23H CLUSTERS ARE NONEMPTY.//) 9250 FORMAT(34H CLUSTER NUMBER SIZE OBJECTS) 9260 FORMAT(/6X,I5,5X,I6,5X,10(3A1,1X)) 9270 FORMAT(27X,10(3A1,1X)) 9280 FORMAT(1X//18H CLUSTERING VECTOR/1X,17(1H*)/) 9290 FORMAT(11X,50(20I3/11X)) 9300 FORMAT(/33H PARTITION COEFFICIENT OF DUNN = ,F5.2/ F ' ITS NORMALIZED VERSION = ',F5.2) END CC CC SUBROUTINE FYGUR(KTRUE,NN,MAXNN,MAXKK,MAXHH,NCLUV,NSEND,NELEM F,NEGBR,SYL,SRANK,AVSYL,DSS,LAB,LUB,S,JBLAN,JSTAR,JSEPA) DIMENSION NCLUV(MAXNN),NSEND(MAXNN),NELEM(MAXNN),NEGBR(MAXNN) DIMENSION SYL(MAXNN),SRANK(MAXNN),AVSYL(MAXKK),DSS(MAXHH) CHARACTER LAB(3,MAXNN),JDRAW(51),JSEPA,JBLAN,JSTAR WRITE(LUB,9500) WRITE(LUB,9510) DO 10 LL=1,51 JDRAW(LL)=JSEPA 10 CONTINUE WRITE(LUB,9515)(JDRAW(LL),LL=1,51),JSEPA,JSEPA,JSEPA TTSYL=0.0 DO 100 NUMCL=1,KTRUE NTT=0 DO 30 J=1,NN IF(NCLUV(J).NE.NUMCL)GO TO 30 NTT=NTT+1 NELEM(NTT)=J 30 CONTINUE DO 40 J=1,NTT NJ=NELEM(J) DYSB=1.1*S+1.0 NEGBR(J)=-1 DO 41 NCLU=1,KTRUE IF(NCLU.EQ.NUMCL)GO TO 41 NBB=0 DB=0.0 DO 43 L=1,NN IF(NCLUV(L).NE.NCLU)GO TO 43 NBB=NBB+1 IF(L.LT.NJ)GO TO 42 IF(L.GT.NJ)GO TO 44 GO TO 43 42 MJL=NN*(L-1)+NJ-L*(L+1)/2 DB=DB+DSS(MJL) GO TO 43 44 MJL=NN*(NJ-1)+L-NJ*(NJ+1)/2 DB=DB+DSS(MJL) 43 CONTINUE BTT=NBB DB=DB/BTT IF(DB.GE.DYSB)GO TO 41 DYSB=DB NEGBR(J)=NCLU 41 CONTINUE IF(NTT.EQ.1)GO TO 50 DYSA=0.0 DO 45 L=1,NTT NL=NELEM(L) IF(NJ.LT.NL)GO TO 46 IF(NJ.GT.NL)GO TO 47 GO TO 45 46 NJL=NN*(NJ-1)+NL-NJ*(NJ+1)/2 DYSA=DYSA+DSS(NJL) GO TO 45 47 NJL=NN*(NL-1)+NJ-NL*(NL+1)/2 DYSA=DYSA+DSS(NJL) 45 CONTINUE ATT=NTT-1 DYSA=DYSA/ATT IF(DYSA.GT.0.0)GO TO 51 IF(DYSB.GT.0.0)GO TO 52 50 SYL(J)=0.0 GO TO 40 52 SYL(J)=1.0 GO TO 40 51 IF(DYSB.LE.0.0)GO TO 53 IF(DYSB.GT.DYSA)SYL(J)=1.0-DYSA/DYSB IF(DYSB.LT.DYSA)SYL(J)=DYSB/DYSA-1.0 IF(DYSB.EQ.DYSA)SYL(J)=0.0 GO TO 54 53 SYL(J)=-1.0 54 IF(SYL(J).LE.(-1.0))SYL(J)=-1.0 IF(SYL(J).GE.1.0)SYL(J)=1.0 40 CONTINUE AVSYL(NUMCL)=0.0 DO 60 J=1,NTT SYMAX=-2.0 DO 70 L=1,NTT IF(SYL(L).LE.SYMAX)GO TO 70 SYMAX=SYL(L) LANG=L 70 CONTINUE NSEND(J)=LANG SRANK(J)=SYL(LANG) AVSYL(NUMCL)=AVSYL(NUMCL)+SRANK(J) SYL(LANG)=-3.0 60 CONTINUE TTSYL=TTSYL+AVSYL(NUMCL) RTT=NTT AVSYL(NUMCL)=AVSYL(NUMCL)/RTT IF(NTT.GE.2)GOTO 75 NCASE=NELEM(1) DO 65 LL=2,50 JDRAW(LL)=JBLAN 65 CONTINUE WRITE(LUB,9525)NUMCL,NEGBR(1),LAB(1,NCASE),LAB(2,NCASE), FLAB(3,NCASE),JSEPA,(JDRAW(LL),LL=2,50),JSEPA GOTO 96 75 DO 80 L=1,NTT LPLAC=NSEND(L) NCASE=NELEM(LPLAC) NEG=NEGBR(LPLAC) TRUNC=SRANK(L) IF(SRANK(L).LE.0.0)TRUNC=0.0 LENGT=TRUNC*50.0+1.1 DO 90 LL=2,51 JDRAW(LL)=JBLAN 90 CONTINUE IF(LENGT.LE.1)GOTO 95 DO 91 LL=2,LENGT JDRAW(LL)=JSTAR 91 CONTINUE 95 WRITE(LUB,9520)NUMCL,NEG,SRANK(L),LAB(1,NCASE),LAB(2,NCASE), FLAB(3,NCASE),(JDRAW(J),J=1,51),JSEPA 80 CONTINUE 96 IF(NUMCL.LT.KTRUE)WRITE(LUB,9530)JSEPA,JSEPA 100 CONTINUE DO 105 LL=1,51 JDRAW(LL)=JSEPA 105 CONTINUE WRITE(LUB,9516)JSEPA,JSEPA,(JDRAW(LL),LL=1,51),JSEPA WRITE(LUB,9510) WRITE(LUB,9517) DO 110 NUMCL=1,KTRUE WRITE(LUB,9540)NUMCL,AVSYL(NUMCL) 110 CONTINUE RNN=NN TTSYL=TTSYL/RNN WRITE(LUB,9550)TTSYL RETURN 9500 FORMAT(//31X,17(1H*)/31X,1H*,15X,1H*/31X, F17H* SILHOUETTES */31X,1H*,15X,1H*/31X,17(1H*)/) 9510 FORMAT(/22X,25(2H0 ),1H1/22X,26(2H. )/22X,6H0 0 0 , F46H1 1 2 2 2 3 3 4 4 4 5 5 6 6 6 7 7 8 8 8 9 9 0 ) 9515 FORMAT(22X,5(10H0 4 8 2 6 ),1H0//1X,21H CLU NEIG S(I) I , F52A1/22X,A1,50X,A1) 9516 FORMAT(22X,A1,50X,A1/22X,52A1) 9517 FORMAT(22X,5(10H0 4 8 2 6 ),1H0//) 9520 FORMAT(1X,I4,1X,I4,1X,F5.2,3X,55A1) 9525 FORMAT(1X,I4,1X,I4,2X,4H .00,3X,53A1,1H1,A1) 9530 FORMAT(22X,A1,50X,A1) 9540 FORMAT(7X,' CLUSTER',I5,' HAS AVERAGE SILHOUETTE WIDTH ',F5.2) 9550 FORMAT(/7X,37H FOR THE ENTIRE DATA SET, THE AVERAGE, F21H SILHOUETTE WIDTH IS ,F5.2//) END CC CC SUBROUTINE ENTR(NN,JPP,KBEG,KEND,MAXNN,MAXTT,MAXPP, F MAXKK,MAXHH,X,DVEC,DSS,VALMD,JTMD,JPLACE,HULP,NUM, F LUA,LUB,LUC,FNAMEA,FNAMEB,FNAMEC,LAB,JLAB,NAME,YNSAVE, F JDYSS,NSTAN,NDYST,LARGE,LGRAP,JLABS,NFF,JFMT,MDATA) DIMENSION X(MAXNN,MAXPP),DVEC(MAXNN),DSS(MAXHH) DIMENSION VALMD(MAXPP),JTMD(MAXPP),JPLACE(MAXPP),HULP(MAXTT) CHARACTER STAN,DYSS,DYST,CYNFF,YNSAVE,CARGE,CGRAP,CLABS,CMDT CHARACTER CDATA,CYNK,CEX,LAB(3,MAXNN),JLAB(10,MAXPP) CHARACTER NUM(13) CHARACTER*30 FNAMEA,FNAMEB,FNAMEC CHARACTER*60 JFMT,NAME NUM(1)='0' NUM(2)='1' NUM(3)='2' NUM(4)='3' NUM(5)='4' NUM(6)='5' NUM(7)='6' NUM(8)='7' NUM(9)='8' NUM(10)='9' NUM(11)=' ' NUM(12)='*' NUM(13)='+' YNSAVE=' ' NSTAN=0 WRITE (*,9500) WRITE(*,9505) WRITE(*,9507) 100 WRITE(*,9510) 110 READ(*,8500)DYSS JDYSS=2 IF(DYSS.EQ.'D'.OR.DYSS.EQ.'d')JDYSS=1 IF(DYSS.EQ.'M'.OR.DYSS.EQ.'m')JDYSS=0 IF(JDYSS.NE.2)GO TO 120 WRITE(*,9520) GO TO 110 120 WRITE (*,9525)MAXNN 130 WRITE (*,9530)MAXNN READ (*,*) NN IF(NN.LE.MAXNN) GOTO 140 WRITE(*,9520) GOTO 130 140 IF(NN.GE.3)GO TO 150 WRITE(*,9540) GOTO 130 150 NSEMY=NN/2 IF(MAXKK.LT.NSEMY)NSEMY=MAXKK WRITE(*,9550)NSEMY 160 WRITE(*,9560) READ(*,*)KBEG IF(KBEG.GE.2)GO TO 170 WRITE(*,9570)KBEG GO TO 160 170 IF(KBEG.LE.NSEMY)GO TO 180 WRITE(*,9580)KBEG,NN GO TO 160 180 WRITE(*,9590) READ(*,*)KEND IF(KEND.GE.KBEG)GO TO 190 WRITE(*,9600) GO TO 160 190 IF(KEND.LE.NSEMY)GO TO 200 WRITE(*,9610)KEND,NN GO TO 180 200 IF(JDYSS.EQ.1)GO TO 500 CC CC IN THIS SECTION SPECIFIC INFORMATION RELATED TO THE INPUT CC OF MEASUREMENTS IS ENTERED : CC TOTAL NUMBER OF VARIABLES (JPPT) CC NUMBER OF VARIABLES TO BE USED IN THE ANALYSIS (JPP) CC VARIABLES TO BE USED IN THE ANALYSIS AND THEIR LABELS CC CHOICE OF STANDARDIZATION CC CHOICE OF EUCLIDEAN OR MANHATTAN DISTANCE CC WRITE(*,9620)MAXTT,MAXPP 300 WRITE(*,9630)MAXTT READ(*,*)JPPT IF(JPPT.NE.1)GO TO 310 JPP=1 GO TO 350 310 IF(JPPT.GE.1.AND.JPPT.LE.MAXTT)GO TO 320 WRITE(*,9520) GO TO 300 320 JPPA=MAXPP IF(JPPA.GT.JPPT)JPPA=JPPT 330 WRITE(*,9640)JPPA READ(*,*)JPP IF(JPP.GE.1.AND.JPP.LE.JPPA)GO TO 340 WRITE(*,9520) GO TO 330 340 IF(JPPT.GT.JPP)GO TO 370 350 WRITE(*,9650) DO 360 J=1,JPP JPLACE(J)=J WRITE(*,9660)J READ(*,8500)(JLAB(K,J),K=1,10) 360 CONTINUE GO TO 410 370 WRITE(*,9670) DO 400 J=1,JPP 380 WRITE(*,9680)J READ(*,8510)JPLACE(J),(JLAB(K,J),K=1,10) IF(JPLACE(J).LT.1.OR.JPLACE(J).GT.JPPT)GO TO 380 IF(J.EQ.1)GO TO 400 JPPL=J-1 DO 390 JK=1,JPPL IF(JPLACE(JK).NE.JPLACE(J))GO TO 390 WRITE(*,9690) GO TO 380 390 CONTINUE 400 CONTINUE 410 WRITE(*,9700) CALL QYN(STAN,NSTAN) WRITE(*,9710) 420 READ(*,8500)DYST NDYST=0 IF(DYST.EQ.'E'.OR.DYST.EQ.'e')NDYST=1 IF(DYST.EQ.'M'.OR.DYST.EQ.'m')NDYST=2 IF(NDYST.NE.0)GO TO 500 WRITE(*,9520) GO TO 420 CC CC OUTPUT SECTION : CC TITLE CC SMALL OR LARGE OUTPUT CC GRAPHICAL OUTPUT (SILHOUETTES) CC LABELS OF OBJECTS CC 500 WRITE (*,9720) READ (*,8520)NAME WRITE(*,9730) IF(NSTAN.EQ.1)WRITE(*,9732) IF(NSTAN.EQ.0)WRITE(*,9734) CALL QYN(CARGE,LARGE) WRITE(*,9740) CALL QYN(CGRAP,LGRAP) WRITE(*,9750) CALL QYN(CLABS,JLABS) IF(JLABS.EQ.0)GO TO 520 WRITE(*,9760) DO 510 J=1,NN WRITE(*,9770)J READ(*,8500)LAB(1,J),LAB(2,J),LAB(3,J) 510 CONTINUE GO TO 550 520 CALL NWLAB(NN,MAXNN,NUM,LAB) CC CC FORMATS CC 550 WRITE (*,9780) CALL QYN(CYNFF,NFF) IF (CYNFF.EQ.'Y') GOTO 600 WRITE(*,9790) READ (*,8520)JFMT CC CC STATUS OF INPUT AND OUTPUT : KEYBOARD, SCREEN, PRINTER, FILE CC 600 WRITE(*,9800) READ(*,8530)FNAMEA IF(FNAMEA.EQ.'KEY'.OR.FNAMEA.EQ.'key'.OR.FNAMEA.EQ.'Key') F GO TO 610 YNSAVE='N' NSAVE=0 GO TO 650 610 FNAMEA='CON' WRITE(*,9810) CALL QYN(YNSAVE,NSAVE) IF (YNSAVE.EQ.'N')GO TO 650 620 WRITE(*,9820) READ(*,8530)FNAMEC OPEN(LUC,FILE=FNAMEC,STATUS='NEW',IOSTAT=NEG,ERR=630) GO TO 650 630 IF(NEG.NE.1027.AND.NEG.NE.1030.AND.NEG.NE.1032. F AND.NEG.NE.1033.AND.NEG.NE.1045)GO TO 640 WRITE(*,9832) GO TO 620 640 WRITE(*,9834)NEG STOP 650 OPEN(LUA,FILE=FNAMEA,IOSTAT=NER,ERR=660) GO TO 670 660 IF(FNAMEA.NE.'CON'.AND.(NER.EQ.1027.OR.NER.EQ.1030.OR. F NER.EQ.1032.OR.NER.EQ.1033))THEN WRITE(*,9836) GO TO 600 ENDIF WRITE(*,9834)NER STOP 670 WRITE(*,9830) READ(*,8530)FNAMEB IF(FNAMEB.EQ.'con'.OR.FNAMEB.EQ.'Con')FNAMEB='CON' IF(FNAMEB.EQ.'prn'.OR.FNAMEB.EQ.'Prn')FNAMEB='PRN' IF (FNAMEB.EQ.'CON'.OR.FNAMEB.EQ.'PRN')OPEN(LUB,FILE=FNAMEB) IF (.NOT.(FNAMEB.EQ.'CON'.OR.FNAMEB.EQ.'PRN'))OPEN(LUB, F FILE=FNAMEB,STATUS='NEW',IOSTAT=NET,ERR=680) GO TO 695 680 IF(NET.NE.1027.AND.NET.NE.1030.AND.NET.NE.1032. F AND.NET.NE.1033.AND.NET.NE.1045)GO TO 690 WRITE(*,9832) GO TO 670 690 WRITE(*,9834)NET STOP 695 IF(JDYSS.EQ.1)GO TO 800 CC CC SECTION ON MISSING DATA CC WRITE (*,9840) CALL QYN(CDATA,MDATA) IF(MDATA.EQ.0) GO TO 740 WRITE(*,9850) CALL QYN(CMDT,MDT) IF(MDT.EQ.0)GO TO 710 WRITE(*,9860) READ(*,*)VVAL DO 700 J=1,JPP JTMD(J)=-1 VALMD(J)=VVAL 700 CONTINUE GO TO 800 710 DO 730 J=1,JPP WRITE (*,9870)(JLAB(K,J),K=1,10) CALL QYN(CYNK,NYNK) IF (CYNK.EQ.'Y')GO TO 720 JTMD(J)=1 VALMD(J)=-99.99 GO TO 730 720 JTMD(J)=-1 WRITE(*,9880) READ (*,*) VALMD(J) 730 CONTINUE GO TO 800 740 DO 750 J=1,JPP JTMD(J)=1 VALMD(J)=-99.99 750 CONTINUE CC CC RECAPITULATION OF OPTIONS CC 800 WRITE(*,9890) WRITE (*,9900) WRITE (*,9905)NAME WRITE(*,9910)NN IF(CLABS.EQ.'Y')WRITE(*,8070) IF(CLABS.EQ.'N')WRITE(*,8075) IF(JDYSS.EQ.1)WRITE(*,8080) IF(JDYSS.EQ.0)WRITE(*,8085) IF(CARGE.EQ.'Y')WRITE(*,8090) IF(CARGE.EQ.'N')WRITE(*,8095) IF(CGRAP.EQ.'Y')WRITE(*,8100) IF(CGRAP.EQ.'N')WRITE(*,8105) WRITE(*,8110)KBEG,KEND IF(JDYSS.EQ.1)GO TO 840 IF(JPPT.GT.1)GO TO 810 WRITE(*,8118) GO TO 820 810 WRITE(*,8115)JPPT IF(JPP.GT.1)WRITE(*,8116)JPP IF(JPP.EQ.1)WRITE(*,8119)(JLAB(K,1),K=1,10),JPLACE(1) 820 IF(STAN.EQ.'Y')WRITE(*,8120) IF(STAN.EQ.'N')WRITE(*,8125) IF(NDYST.EQ.1)WRITE(*,8130) IF(NDYST.EQ.2)WRITE(*,8135) IF(CDATA.EQ.'N')WRITE(*,8145) IF(CDATA.EQ.'N')GO TO 830 IF(CMDT.EQ.'N')WRITE(*,8140) IF(CMDT.EQ.'Y')WRITE(*,8142) IF(CMDT.EQ.'Y')WRITE(*,*)VVAL 830 IF (CYNFF.EQ.'Y') WRITE(*,8160) IF (CYNFF.EQ.'N') WRITE(*,8165) JFMT GO TO 850 840 IF (CYNFF.EQ.'Y') WRITE(*,8170) IF (CYNFF.EQ.'N') WRITE(*,8175) JFMT 850 IF (FNAMEA.NE.'CON') WRITE(*,8039) FNAMEA IF (FNAMEA.EQ.'CON') WRITE(*,8034) IF (YNSAVE.EQ.'Y') WRITE(*,8038) FNAMEC WRITE(*,8040) FNAMEB WRITE (*,8030) CALL QYN(CEX,NEX) IF (CEX.NE.'Y') GOTO 100 IF(FNAMEB.EQ.'CON')GO TO 900 WRITE(LUB,9500) WRITE(LUB,9505) WRITE(LUB,9507) WRITE(LUB,9905)NAME WRITE(LUB,9900) WRITE(LUB,9910)NN IF(JLABS.NE.0)WRITE(LUB,8070) IF(JLABS.EQ.0)WRITE(LUB,8075) IF(JDYSS.NE.0)WRITE(LUB,8080) IF(JDYSS.EQ.0)WRITE(LUB,8085) IF(LARGE.NE.0)WRITE(LUB,8090) IF(LARGE.EQ.0)WRITE(LUB,8095) IF(LGRAP.NE.0)WRITE(LUB,8100) IF(LGRAP.EQ.0)WRITE(LUB,8105) WRITE(LUB,8110)KBEG,KEND IF(JDYSS.EQ.1)GO TO 880 IF(JPPT.GT.1)GO TO 852 WRITE(LUB,8118) GO TO 865 852 WRITE(LUB,8115)JPPT IF(JPP.GT.1)GO TO 854 WRITE(LUB,8119)(JLAB(K,1),K=1,10),JPLACE(1) GO TO 865 854 WRITE(LUB,8116)JPP WRITE(LUB,8114) DO 860 J=1,JPP WRITE(LUB,8117)(JLAB(K,J),K=1,10),JPLACE(J) 860 CONTINUE 865 IF(NSTAN.EQ.0)WRITE(LUB,8125) IF(NSTAN.EQ.1)WRITE(LUB,8120) IF(NDYST.EQ.1)WRITE(LUB,8130) IF(NDYST.EQ.2)WRITE(LUB,8135) IF(CDATA.EQ.'N')WRITE(LUB,8145) IF(CDATA.EQ.'N')GO TO 870 WRITE(LUB,8140) IF(CMDT.EQ.'Y')WRITE(LUB,8142) IF(CMDT.EQ.'Y')WRITE(LUB,*)VVAL 870 IF (CYNFF.EQ.'Y') WRITE(LUB,8160) IF (CYNFF.EQ.'N') WRITE(LUB,8165) JFMT GO TO 890 880 IF (CYNFF.EQ.'Y') WRITE(LUB,8170) IF (CYNFF.EQ.'N') WRITE(LUB,8175) JFMT 890 IF (FNAMEB.EQ.'CON') PAUSE ' ' IF(FNAMEB.NE.'CON')WRITE(LUB,*) IF (YNSAVE.EQ.'Y') WRITE(LUB,8038) FNAMEC IF (FNAMEA.NE.'CON') WRITE(LUB,8039) FNAMEA CC CC INPUT OF DATA CC 900 IF (FNAMEA.EQ.'CON') WRITE(*,8355) IF(JDYSS.EQ.1)GO TO 940 DO 930 L=1,NN IF (FNAMEA.NE.'CON')GO TO 910 WRITE(*,8359)JPPT,LAB(1,L),LAB(2,L),LAB(3,L) 910 IF (CYNFF.EQ.'N') READ(LUA,JFMT)(HULP(J),J=1,JPPT) IF (CYNFF.EQ.'Y') READ(LUA,*)(HULP(J),J=1,JPPT) DO 920 J=1,JPP JH=JPLACE(J) X(L,J)=HULP(JH) 920 CONTINUE IF (YNSAVE.EQ.'N')GO TO 930 IF (CYNFF.EQ.'N') WRITE(LUC,JFMT)(HULP(J),J=1,JPPT) IF (CYNFF.EQ.'Y') WRITE(LUC,*)(HULP(J),J=1,JPPT) 930 CONTINUE IF (YNSAVE.EQ.'Y') CLOSE(LUC,STATUS='KEEP') IF (YNSAVE.EQ.'Y') WRITE(*,8038) FNAMEC RETURN 940 NNSUB=NN-1 IF(FNAMEA.EQ.'CON')WRITE(*,8363) DO 990 L=1,NNSUB LMR=L+1 IF (FNAMEA.NE.'CON')GO TO 950 IF (L.EQ.1) WRITE(*,8361) LAB(1,2),LAB(2,2),LAB(3,2), F LAB(1,1),LAB(2,1),LAB(3,1) IF (L.NE.1) WRITE(*,8362)L,LAB(1,LMR),LAB(2,LMR),LAB(3,LMR) 950 IF (CYNFF.EQ.'Y') READ(LUA,*)(DVEC(J),J=1,L) IF (CYNFF.EQ.'N') READ(LUA,JFMT)(DVEC(J),J=1,L) DO 970 J=1,L IF(DVEC(J).GE.0.)GO TO 970 IF(FNAMEA.EQ.'CON')GO TO 960 WRITE(*,8365)LAB(1,LMR),LAB(2,LMR),LAB(3,LMR),LAB(1,J), F LAB(2,J),LAB(3,J) STOP 960 WRITE(*,8370)LAB(1,LMR),LAB(2,LMR),LAB(3,LMR),LAB(1,J), F LAB(2,J),LAB(3,J),LAB(1,LMR),LAB(2,LMR),LAB(3,LMR) GO TO 950 970 CONTINUE MUSE=L DSS(MUSE)=DVEC(1) IF(L.EQ.1)GO TO 985 DO 980 J=2,L MUSE=MUSE+NN-J DSS(MUSE)=DVEC(J) 980 CONTINUE 985 IF (YNSAVE.EQ.'N')GO TO 990 IF (CYNFF.EQ.'Y') WRITE(LUC,*)(DVEC(J),J=1,L) IF (CYNFF.EQ.'N') WRITE(LUC,JFMT)(DVEC(J),J=1,L) 990 CONTINUE IF (YNSAVE.EQ.'Y') CLOSE(LUC,STATUS='KEEP') IF (YNSAVE.EQ.'Y') WRITE(*,8038) FNAMEC 8030 FORMAT(/1X,' ARE ALL THESE OPTIONS OK? YES OR NO: '$) 8034 FORMAT(1X,' THE DATA WILL BE READ FROM THE KEYBOARD') 8038 FORMAT(1X,' THE DATA WILL BE SAVED ON FILE: ',A30) 8039 FORMAT(1X,' YOUR DATA RESIDE ON FILE: ',A30/) 8040 FORMAT(1X,' YOUR OUTPUT WILL BE WRITTEN ON: ',A30) 8070 FORMAT(1X,' LABELS OF OBJECTS ARE READ') 8075 FORMAT(1X,' LABELS OF OBJECTS ARE NOT READ') 8080 FORMAT(1X,' INPUT OF DISSIMILARITIES') 8085 FORMAT(1X,' INPUT OF MEASUREMENTS') 8090 FORMAT(1X,' LARGE OUTPUT IS WANTED') 8095 FORMAT(1X,' SMALL OUTPUT') 8100 FORMAT(1X,' GRAPHICAL OUTPUT IS WANTED (SILHOUETTES)') 8105 FORMAT(1X,' NO GRAPHICAL OUTPUT IS WANTED') 8110 FORMAT(1X,' CLUSTERINGS ARE CARRIED OUT IN ',I4, F' TO ',I4,' CLUSTERS') 8114 FORMAT(1X,' THESE VARIABLES ARE :') 8115 FORMAT(/1X,' THERE ARE ',I4,' VARIABLES IN THE DATA SET,') 8116 FORMAT(1X,' AND 'I4,' OF THEM WILL BE USED IN THE ANALYSIS') 8117 FORMAT(10X,10A1,' (POSITION :',I3,')') 8118 FORMAT(/1X,' THERE IS ONE VARIABLE IN THE DATA SET') 8119 FORMAT(1X,' AND ONLY VARIABLE ',10A1,' WILL BE USED IN THE' F ' ANALYSIS (POSITION :',I3,')') 8120 FORMAT(1X,' THE MEASUREMENTS WILL BE STANDARDIZED') 8125 FORMAT(1X,' THE MEASUREMENTS WILL NOT BE STANDARDIZED') 8130 FORMAT(1X,' EUCLIDEAN DISTANCE WILL BE USED') 8135 FORMAT(1X,' MANHATTAN DISTANCE WILL BE USED') 8140 FORMAT(1X,' MISSING VALUES CAN OCCUR') 8142 FORMAT(1X,' THE UNIQUE VALUE WHICH REPRESENTS MISSING' F' MEASUREMENTS IS :'/6X$) 8145 FORMAT(1X,' THERE ARE NO MISSING VALUES') 8160 FORMAT(1X,' THE MEASUREMENTS WILL BE READ IN FREE FORMAT') 8165 FORMAT(1X,' THE INPUT FORMAT FOR THE MEASUREMENTS IS'/2X,A60) 8170 FORMAT(1X,' THE DISSIMILARITIES WILL BE READ IN FREE FORMAT') 8175 FORMAT(' THE INPUT FORMAT FOR THE DISSIMILARITIES IS'/2X,A60) 8355 FORMAT(//1X,'PLEASE ENTER YOUR DATA FOR EACH OBJECT'//) 8359 FORMAT(1X,'THE ',I3,' MEASUREMENTS FOR OBJECT ',3A1,' : '/) 8361 FORMAT(1X,' DISSIMILARITY BETWEEN OBJECTS ',3A1, F' AND ',3A1,' : '/) 8362 FORMAT(1X,' THE ',I4,' DISSIMILARITIES FOR OBJECT ',3A1, F' : '/) 8363 FORMAT(1X,' FOR OBJECT J, ENTER DISSIMILARITIES TO OBJECTS', F' 1,2,... ,(J-1) '//) 8365 FORMAT(/' THE DISSIMILARITY BETWEEN OBJECTS',3A1,' AND ',3A1, F' IS NEGATIVE,'/' UNFORTUNATELY THE PROGRAM MUST BE STOPPED.') 8370 FORMAT(/' THE DISSIMILARITY BETWEEN OBJECTS ',3A1,' AND ',3A1, F' IS NEGATIVE.'/1X,'PLEASE ENTER THE DISSIMILARITIES FOR', F' OBJECT ',3A1,' ONCE AGAIN :'/) 8500 FORMAT(10A1) 8510 FORMAT(BNI4,6X,10A1) 8520 FORMAT(A60) 8530 FORMAT(A30) 9500 FORMAT(////29X,21('*')/29X,'*',19X,'*'/29X, F '* FUZZY ANALYSIS *'/ F 29X,'*',19X,'*'/29X,21('*')/) 9505 FORMAT(//' Copyright (C) Leonard Kaufman and Peter' F ' Rousseeuw 1990. All rights reserved.') 9507 FORMAT(/5X,' This program performs fuzzy clustering on a' F ' data set'/5X,' of measurements or dissimilarities.' F /5X,' More information can be found in chapter 4 of:' F //5X,' L. Kaufman and P.J. Rousseeuw (1990),' F /5X,' Finding Groups in Data:' F ' An Introduction to Cluster Analysis,' F /5X,' Wiley, New York.'//) 9510 FORMAT(/1X,'DO YOU WANT TO ENTER MEASUREMENTS ? (PLEASE' F' ANSWER M)'/1X,'OR DO YOU PREFER TO GIVE' F' DISSIMILARITIES ? (THEN ANSWER D) : '$) 9520 FORMAT(1X,'NOT ALLOWED ! PLEASE ENTER YOUR CHOICE AGAIN: '$) 9525 FORMAT(//1X,'THE PRESENT VERSION OF THE PROGRAM CAN HANDLE' F ' UP TO',I6,' OBJECTS.'/1X,'(IF MORE ARE TO BE CLUSTERED' F ', THE ARRAYS INSIDE THE PROGRAM MUST BE ADAPTED)') 9530 FORMAT(/1X,'HOW MANY OBJECTS ARE TO BE CLUSTERED ? '/1X, F38(1H-)/1X,'PLEASE GIVE A NUMBER BETWEEN 3 AND ',I6,' : '$) 9540 FORMAT(/' AT LEAST 3 OBJECTS ARE NEEDED FOR CLUSTER ANALYSIS' F','/1X,' PLEASE FORESEE MORE OBJECTS ') 9550 FORMAT(/' CLUSTERINGS WILL BE CARRIED OUT IN K1 TO K2' F ' CLUSTERS.'/' K1 SHOULD BE AT LEAST 2, AND K2 AT MOST',I4) 9560 FORMAT(1X,' PLEASE ENTER K1 : '$) 9570 FORMAT(/1X,'THE BEGINNING NUMBER OF CLUSTERS WAS GIVEN AS ', F I6,' ,'/1X,'IT SHOULD BE AT LEAST TWO,') 9580 FORMAT(/' THE BEGINNING NUMBER OF CLUSTERS WAS GIVEN AS ',I6, F ' ,'/' IT SHOULD NOT EXCEED',I5,' ,') 9590 FORMAT(1X,' PLEASE ENTER K2 : '$) 9600 FORMAT(/1X,'THE FINAL NUMBER OF CLUSTERS MAY NOT BE SMALLER' F 'THAN THE BEGINNING'/1X,'NUMBER OF CLUSTERS. PLEASE ENTER' F ' THESE NUMBERS AGAIN') 9610 FORMAT(/1X,'THE FINAL NUMBER OF CLUSTERS WAS GIVEN AS ',I7, F ' ,'/' IT SHOULD NOT EXCEED',I5,' ,') 9620 FORMAT(//1X,'THE PRESENT VERSION OF THE PROGRAM ALLOWS TO' F ' ENTER UP TO',I5,' VARIABLES,'/1X,'OF WHICH AT MOST',I5, F ' CAN BE USED IN THE ACTUAL COMPUTATIONS.'/1X,'(IF MORE ARE' F ' NEEDED, THE ARRAYS INSIDE THE PROGRAM MUST BE ADAPTED)') 9630 FORMAT(/1X,'WHAT IS THE TOTAL NUMBER OF VARIABLES IN YOUR' F' DATA SET ?'/1X,56(1H-)/ F' PLEASE GIVE A NUMBER BETWEEN 1 AND ',I6,' : '$) 9640 FORMAT(/38H HOW MANY VARIABLES DO YOU WANT TO USE, F' IN THE ANALYSIS ?'/1X,55('-')/' (AT MOST ',I4,' ) : '$) 9650 FORMAT(//1X,'VARIABLE TO BE USED ', F' LABEL (AT MOST 10 CHARACTERS)'/ F 1X,17(1H-),4(1H),6(1H-),10(1H),19(1H-)) 9660 FORMAT(1X,'NUMBER : ',I4,6X$) 9670 FORMAT(//1X,'VARIABLE TO BE USED : POSITION', F ' LABEL (AT MOST 10 CHARACTERS)'/ F 1X,32('-'),4(1H),6('-'),10(1H),19('-')) 9680 FORMAT(1X,'NUMBER ',I4,15X,': '$) 9690 FORMAT(/' THIS POSITION HAS ALREADY BEEN CHOSEN FOR ANOTHER', F' VARIABLE.'/1X,'ENTER THE RIGHT POSITION PLEASE : ') 9700 FORMAT(/1X,'DO YOU WANT THE MEASUREMENTS TO BE STANDARDIZED' F' ? (YES OR NO) ',6('.'),' : '$) 9710 FORMAT(/1X,'DO YOU WANT TO USE EUCLIDEAN DISTANCE? (PLEASE' F' ANSWER E)'/1X,'OR DO YOU PREFER MANHATTAN DISTANCE?' F' (THEN ANSWER M) .............. : '$) 9720 FORMAT(/1X,'PLEASE ENTER A TITLE FOR THE OUTPUT (AT MOST 60' F ' CHARACTERS)'/1X,60(1H-)/1X$) 9730 FORMAT(/1X,'DO YOU WANT LARGE OUTPUT ? (PLEASE ANSWER YES)'/ F' OR IS SMALL OUTPUT SUFFICIENT ? (THEN ANSWER NO)') 9732 FORMAT(' (IN THE LATTER CASE NO STANDARDIZED MEASUREMENTS OR' F/1X,' DISSIMILARITIES ARE GIVEN)',1X,40('.'),' : '$) 9734 FORMAT(' (IN THE LATTER CASE NO DISSIMILARITIES ARE GIVEN)' F,1X,18('.'),' : '$) 9740 FORMAT(/1X,'DO YOU WANT GRAPHICAL OUTPUT (SILHOUETTES)?' F' PLEASE ANSWER YES OR NO : '$) 9750 FORMAT(/1X,'DO YOU WANT TO ENTER LABELS OF OBJECTS?' F' PLEASE ANSWER YES OR NO ... : '$) 9760 FORMAT(/1X,'EACH LABEL MAY CONSIST OF AT MOST 3 CHARACTERS'/ F/1X,' OBJECT LABEL'/ 1 1X,12(1H-),4(1H),6(1H-),3(1H),5(1H-)) 9770 FORMAT(' NUMBER ',4X,I4,' : '$) 9780 FORMAT(/' DO YOU WANT TO READ THE DATA IN FREE FORMAT?'/1X, F 45(1H-)/' THIS MEANS THAT YOU ONLY HAVE TO INSERT BLANK(S)', F ' BETWEEN NUMBERS.'/' (NOTE: WE ADVISE USERS WITHOUT', F ' KNOWLEDGE OF FORTRAN FORMATS TO ANSWER YES.)'/ F ' MAKE YOUR CHOICE (YES/NO): '$) 9790 FORMAT(/' YOUR DESIRED FORTRAN FORMAT IS:'/ F ' (BETWEEN BRACKETS AND', F ' AT MOST 60 CHARACTERS, e.g. (2F3.0,F1.0) )') 9800 FORMAT(/1X,'PLEASE GIVE THE NAME OF THE FILE CONTAINING', F ' THE DATA (e.g. TYPE A:EXAMPLE.DAT)',/1X,'OR TYPE', F ' KEY IF YOU PREFER TO ENTER THE DATA BY KEYBOARD.'/ F ' WHAT DO YOU CHOOSE? '$) 9810 FORMAT(/1X,'DO YOU WANT TO SAVE YOUR DATA IN A FILE ?'/ F ' PLEASE ANSWER YES OR NO: ',$) 9820 FORMAT(/' IN WHICH FILE DO YOU WANT TO SAVE YOUR DATA?'/ F ' (WARNING : IF THERE ALREADY EXISTS A FILE WITH THE SAME', F ' NAME'/12X,'THEN THE OLD FILE WILL BE OVERWRITTEN.)'/ F ' TYPE e.g. B:SAVE.DAT ..................... : '$) 9830 FORMAT(/' WHERE DO YOU WANT YOUR OUTPUT ?'/1X,32('-')/ F ' TYPE CON IF YOU WANT IT ON THE SCREEN'/ F ' OR TYPE PRN IF YOU WANT IT ON THE PRINTER'/ F ' OR TYPE THE NAME OF A FILE (e.g. B:EXAMPLE.OUT)'/ F ' (WARNING : IF THERE ALREADY EXISTS A FILE WITH THE SAME', F ' NAME'/12X,'THEN THE OLD FILE WILL BE OVERWRITTEN.)'/ F ' WHAT DO YOU CHOOSE ? ...................... : '$) 9832 FORMAT(/' FILE NAME INCORRECT, PLEASE ENTER ANOTHER') 9834 FORMAT(/' FORTRAN ERROR CODE: ',I8) 9836 FORMAT(/' THIS FILE WAS NOT FOUND, PLEASE ENTER ANOTHER ONE') 9840 FORMAT(/' CAN MISSING DATA OCCUR IN THE MEASUREMENTS?' F/' PLEASE ANSWER YES OR NO: '$) 9850 FORMAT(/' IS THERE A UNIQUE VALUE WHICH IS TO BE INTERPRETED'/ F ' AS A MISSING MEASUREMENT VALUE FOR ANY VARIABLE? '/ F ' PLEASE ANSWER YES OR NO: '$) 9860 FORMAT(/' PLEASE ENTER THIS VALUE NOW: '$) 9870 FORMAT(/' SHOULD MISSING VALUES BE FORESEEN FOR VARIABLE', F 1X,10A1,' ?'/1X,'PLEASE ANSWER YES OR NO: '$) 9880 FORMAT(' ENTER THE VALUE OF THIS VARIABLE WHICH HAS TO BE' F ' INTERPRETED AS'/' THE MISSING VALUE CODE: '$) 9890 FORMAT(//////////) 9900 FORMAT(//' DATA SPECIFICATIONS AND CHOSEN OPTIONS'/1X,38('-')) 9905 FORMAT(' TITLE: ',A60) 9910 FORMAT(' THERE ARE ',I4,' OBJECTS') RETURN END CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCCCCCCCCCCC file TWINS.FOR (Chapters 5 and 6) 41k CCCCCCCCCCCCCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC PROGRAM TWINS CC CC THIS PROGRAM PERFORMS AGGLOMERATIVE NESTING (AGNES) USING THE CC GROUP AVERAGE METHOD OF SOKAL AND MICHENER (1958), AS WELL AS CC DIVISIVE ANALYSIS (DIANA) USING THE METHOD OF MCNAUGHTON-SMITH, CC WILLIAMS, DALE, AND MOCKETT (1964). CC CC LIST OF FUNCTIONS AND SUBROUTINES: CC MAIN UNIT CC SUBROUTINE ENTR CC SUBROUTINE QYN CC FUNCTION MEET CC SUBROUTINE NWLAB CC SUBROUTINE STAND CC SUBROUTINE DYSTA CC SUBROUTINE AVERL CC SUBROUTINE BANAG CC SUBROUTINE SPLYT CC SUBROUTINE SUPCL CC SUBROUTINE BANDY CC CC THE FOLLOWING VECTORS AND MATRICES MUST BE DIMENSIONED IN THE CC MAIN PROGRAM ONLY: CC KWAN(MAXNN),NER(MAXNN),BAN(MAXNN),DVEC(MAXNN),JPLACE(MAXPP) CC X(MAXNN,MAXPP),JTMD(MAXPP),VALMD(MAXPP),DYS(MAXHH),HULP(MAXTT) CC LAB(3,MAXNN),JLAB(10,MAXPP),NUM(13) CC WHERE: CC MAXNN = MAXIMAL NUMBER OF OBJECTS CC MAXTT = MAXIMAL TOTAL NUMBER OF VARIABLES CC MAXPP = MAXIMAL NUMBER OF VARIABLES USED IN THE ANALYSIS CC MAXHH = (MAXNN*(MAXNN-1))/2 + 1 CC CC DIMENSION KWAN(100),NER(100),BAN(100),DVEC(100),JPLACE(20) DIMENSION X(100,20),JTMD(20),VALMD(20),DYS(4951),HULP(80) CHARACTER LAB(3,100),JLAB(10,20),NUM(13),YNSAVE CHARACTER*30 FNAMEA,FNAMEB,FNAMEC CHARACTER*60 JFMT,NAME MAXNN=100 MAXTT=80 MAXPP=20 MAXHH=4951 CC CC LOGICAL INPUT AND OUTPUT UNITS : CC LUA = LOGICAL UNIT A (INPUT) CC LUB = LOGICAL UNIT B (OUTPUT) CC LUC = LOGICAL UNIT C (OUTPUT OF DATA MATRIX) CC THE USER SHOULD ASSIGN TO LUA, LUB AND LUC THE NUMBERS USED BY CC HIS OWN COMPUTER: ONLY THE NEXT 3 STATEMENTS MUST BE CHANGED: CC LUA=1 LUB=2 LUC=3 CC 10 CALL ENTR(MAXNN,MAXTT,MAXPP,MAXHH,X,DVEC,DYS,VALMD,JTMD, F JPLACE,HULP,LAB,JLAB,NUM,LUA,LUB,LUC,FNAMEA,FNAMEB,FNAMEC, F NAME,JFMT,NN,JPP,JDYSS,NSTAN,NDYST,LARGE,LGRAP,JLABS,NFF, F MDATA,YNSAVE,JALG) CC CC INSPECTION OF OBJECTS FOR MISSING VALUES CC IF(JDYSS.EQ.0)GO TO 20 JPP=1 GO TO 100 20 IF(MDATA.EQ.0)GOTO 48 JHALT=0 DO 41 L=1,NN DO 42 J=1,JPP IF(JTMD(J).GE.0)GOTO 41 IF(X(L,J).NE.VALMD(J))GOTO 41 42 CONTINUE WRITE(LUB,9041)LAB(1,L),LAB(2,L),LAB(3,L) IF(FNAMEB.NE.'CON')WRITE(*,9041)LAB(1,L),LAB(2,L),LAB(3,L) JHALT=1 41 CONTINUE CC CC INSPECTION OF VARIABLES FOR MISSING VALUES CC MYST=0 DO 45 J=1,JPP MYSJ=0 IF(JTMD(J).GE.0)GOTO 45 DO 46 L=1,NN IF(X(L,J).EQ.VALMD(J))MYSJ=MYSJ+1 46 CONTINUE MYST=MYST+MYSJ IF(MYSJ.EQ.0)GOTO 45 WRITE(LUB,9045)(JLAB(K,J),K=1,10),MYSJ IF(MYSJ.LT.NN)GOTO 45 WRITE(LUB,9047)(JLAB(J,K),K=1,10) IF(NFF.EQ.0)WRITE(LUB,9048) IF(FNAMEB.NE.'CON')WRITE(*,9047)(JLAB(J,K),K=1,10) IF(NFF.EQ.0.AND.FNAMEB.NE.'CON')WRITE(*,9048) JHALT=1 45 CONTINUE WRITE(LUB,9049)MYST IF(JHALT.EQ.1)STOP CC CC STANDARDIZATION AND DISTANCES CC 48 IF(NSTAN.EQ.0)GO TO 70 CALL STAND(NN,JPP,MAXNN,MAXPP,X,JTMD,VALMD,JHALT,JLAB,LUB, F FNAMEB) IF(JHALT.EQ.1)STOP IF(LARGE.EQ.0)GO TO 70 WRITE(LUB,9031) IF(MDATA.NE.0)WRITE(LUB,9032) JPEND=JPP IF(JPP.GT.8)JPEND=8 DO 60 L=1,NN WRITE(LUB,9033)LAB(1,L),LAB(2,L),LAB(3,L),(X(L,J),J=1,JPEND) IF(JPP.GT.8)WRITE(LUB,9040)(X(L,J),J=9,JPP) 60 CONTINUE 70 CALL DYSTA(NN,JPP,MAXNN,MAXPP,MAXHH,X,DYS,NDYST,JTMD,VALMD, F LAB,JHALT,LUB,FNAMEB) IF(JHALT.EQ.1)STOP 100 IF(LARGE.EQ.0)GO TO 130 WRITE(LUB,9060) WRITE(LUB,9033)LAB(1,1),LAB(2,1),LAB(3,1) DO 120 L=2,NN LSUBT=L-1 JPEND=LSUBT IF(LSUBT.GT.8)JPEND=8 DO 110 J=1,LSUBT NLJ=MEET(L,J) DVEC(J)=DYS(NLJ) 110 CONTINUE WRITE(LUB,9033)LAB(1,L),LAB(2,L),LAB(3,L),(DVEC(J),J=1,JPEND) IF(LSUBT.GT.8)WRITE(LUB,9040)(DVEC(J),J=9,LSUBT) 120 CONTINUE 130 WRITE(LUB,9070) 150 IF(JALG.EQ.2)GO TO 200 CALL AVERL(NN,MAXNN,KWAN,NER,BAN,MAXHH,DYS,LUB) IF(LGRAP.NE.0)CALL BANAG(NN,MAXNN,BAN,NER,LAB,NUM,LUB) GO TO 300 200 CALL SPLYT(NN,MAXNN,KWAN,NER,BAN,MAXHH,DYS,LUB) IF(LGRAP.NE.0)CALL BANDY(NN,MAXNN,BAN,NER,LAB,NUM,LUB) 300 WRITE(*,9085) IF(YNSAVE.EQ.'Y'.AND.FNAMEB.EQ.'CON')WRITE(*,9090)FNAMEC IF(FNAMEB.NE.'PRN'.AND.FNAMEB.NE.'CON')WRITE(LUB,9095)FNAMEB IF(FNAMEB.EQ.'PRN')WRITE(*,9096) IF(FNAMEB.NE.'PRN'.AND.FNAMEB.NE.'CON')WRITE(*,9095)FNAMEB STOP 9031 FORMAT(//26H STANDARDIZED MEASUREMENTS/1X,25(1H-)/) 9032 FORMAT(1X,33H ( 99.99 DENOTES A MISSING VALUE)//) 9033 FORMAT(1X,3A1,2X,8F9.2) 9040 FORMAT(6X,8F9.2) 9041 FORMAT(/1X,7H OBJECT,3A1,29H CONTAINS ONLY MISSING VALUES, F21H AND MUST BE REMOVED./) 9045 FORMAT(1X,9H VARIABLE,10A1,9H CONTAINS,I5,15H MISSING VALUES) 9047 FORMAT(/1X,9H VARIABLE,10A1,29H CONTAINS ONLY MISSING VALUES, F21H AND MUST BE REMOVED.) 9048 FORMAT(1X,' (THIS CAN BE DONE BY CHANGING THE NUMBER OF' F' VARIABLES AND THE INPUT FORMAT.)'/) 9049 FORMAT(//1X,38H THE TOTAL NUMBER OF MISSING VALUES IS,I7//) 9060 FORMAT(//21H DISSIMILARITY MATRIX/1X,20(1H-)/) 9070 FORMAT(1X,5(/),16H CLUSTER RESULTS/1X,15(1H-)) 9085 FORMAT(/1X,'THIS RUN HAS BEEN SUCCESSFULLY COMPLETED') 9090 FORMAT(/' Your data is written in file : ',A30) 9095 FORMAT(/' The output is written in file : ',A30) 9096 FORMAT(/' The output was sent to the printer') END CC CC FUNCTION MEET(L,J) IF(L.GT.J)GO TO 10 IF(L.EQ.J)GO TO 20 CC CC L IS LESS THAN J CC MEET=(J-2)*(J-1)/2+L+1 RETURN CC CC J IS LESS THAN L CC 10 MEET=(L-2)*(L-1)/2+J+1 RETURN CC CC J EQUALS L CC 20 MEET=1 RETURN END CC CC SUBROUTINE NWLAB(NN,MAXNN,NUM,LAB) CHARACTER LAB(3,MAXNN),NUM(13) LLA=1 LLB=1 LLC=1 DO 50 J=1,NN IF(LLC.LT.10)GOTO 10 LLC=0 IF(LLB.LT.10)GOTO 20 LLB=0 LLA=LLA+1 20 LLB=LLB+1 10 LLC=LLC+1 LAB(1,J)=NUM(LLA) LAB(2,J)=NUM(LLB) LAB(3,J)=NUM(LLC) 50 CONTINUE RETURN END CC CC SUBROUTINE QYN(YN,NYN) CHARACTER*1 YN 10 READ(*,8000)YN IF(YN.EQ.'y')YN='Y' IF(YN.EQ.'n')YN='N' IF(YN.EQ.'Y')NYN=1 IF(YN.EQ.'N')NYN=0 IF(YN.EQ.'Y'.OR.YN.EQ.'N')GO TO 20 WRITE(*,9000) GO TO 10 20 RETURN 8000 FORMAT(A1) 9000 FORMAT(' NOT ALLOWED! PLEASE ENTER YOUR CHOICE AGAIN: '$) END CC CC SUBROUTINE STAND(NN,JPP,MAXNN,MAXPP,X,JTMD,VALMD,JHALT,JLAB, F LUB,FNAMEB) DIMENSION X(MAXNN,MAXPP),JTMD(MAXPP),VALMD(MAXPP) CHARACTER JLAB(10,MAXPP) CHARACTER*30 FNAMEB DO 200 J=1,JPP AVERA=0.0 STAM=0.0 IF(JTMD(J).GE.0)GOTO 100 NPRES=0 DO 20 L=1,NN IF(X(L,J).EQ.VALMD(J))GOTO 20 NPRES=NPRES+1 AVERA=AVERA+X(L,J) 20 CONTINUE IF(NPRES.LE.1)GOTO 300 RPRES=NPRES AVERA=AVERA/RPRES DO 50 L=1,NN IF(X(L,J).EQ.VALMD(J))GOTO 50 STAM=STAM+ABS(X(L,J)-AVERA) 50 CONTINUE STAM=STAM/RPRES WRITE(LUB,9305)(JLAB(K,J),K=1,10),AVERA,STAM IF(STAM.LE.0.0)GOTO 300 DO 60 L=1,NN IF(X(L,J).EQ.VALMD(J))GOTO 70 X(L,J)=(X(L,J)-AVERA)/STAM IF(X(L,J).GT.49.0)X(L,J)=49.0 IF(X(L,J).LT.(-49.0))X(L,J)=-49.0 GOTO 60 70 X(L,J)=99.99 60 CONTINUE VALMD(J)=99.99 GOTO 200 100 DO 120 L=1,NN AVERA=AVERA+X(L,J) 120 CONTINUE RNN=NN AVERA=AVERA/RNN DO 150 L=1,NN STAM=STAM+ABS(X(L,J)-AVERA) 150 CONTINUE STAM=STAM/RNN WRITE(LUB,9305)(JLAB(K,J),K=1,10),AVERA,STAM IF(STAM.LE.0.0)GOTO 300 DO 160 L=1,NN X(L,J)=(X(L,J)-AVERA)/STAM IF(X(L,J).GT.49.0)X(L,J)=49.0 IF(X(L,J).LT.(-49.0))X(L,J)=-49.0 160 CONTINUE GOTO 200 300 JHALT=1 WRITE(LUB,9300)(JLAB(K,J),K=1,10) IF(FNAMEB.NE.'CON')WRITE(*,9300)(JLAB(K,J),K=1,10) 200 CONTINUE RETURN 9300 FORMAT(/' THE MEAN DEVIATION OF VARIABLE ',10A1/ F ' IS ZERO (UP TO COMPUTER PRECISION).'/' PLEASE RUN' F ' THE PROGRAM AGAIN WITHOUT THIS VARIABLE.'/) 9305 FORMAT(' VARIABLE ',10A1,' HAS AVERAGE ',F10.3, F ', MEAN DEVIATION ',F10.3) END CC CC SUBROUTINE DYSTA(NN,JPP,MAXNN,MAXPP,MAXHH,X,DYS,NDYST,JTMD, F VALMD,LAB,JHALT,LUB,FNAMEB) DIMENSION X(MAXNN,MAXPP),DYS(MAXHH),JTMD(MAXPP),VALMD(MAXPP) CHARACTER LAB(3,MAXNN) CHARACTER*30 FNAMEB PP=JPP NLK=1 DYS(1)=0.0 DO 100 L=2,NN LSUBT=L-1 DO 20 K=1,LSUBT CLK=0.0 NLK=NLK+1 NPRES=0 DO 30 J=1,JPP IF(JTMD(J).GE.0)GOTO 40 IF(X(L,J).EQ.VALMD(J))GOTO 30 IF(X(K,J).EQ.VALMD(J))GOTO 30 40 NPRES=NPRES+1 IF(NDYST.NE.1)GOTO 50 CLK=CLK+(X(L,J)-X(K,J))*(X(L,J)-X(K,J)) GOTO 30 50 CLK=CLK+ABS(X(L,J)-X(K,J)) 30 CONTINUE RPRES=NPRES IF(NPRES.NE.0)GOTO 60 JHALT=1 WRITE(LUB,9400)LAB(1,L),LAB(2,L),LAB(3,L), F LAB(1,K),LAB(2,K),LAB(3,K) IF(FNAMEB.NE.'CON')WRITE(*,9400)LAB(1,L),LAB(2,L),LAB(3,L), F LAB(1,K),LAB(2,K),LAB(3,K) DYS(NLK)=0.0 GOTO 20 60 IF(NDYST.NE.1)GOTO 70 DYS(NLK)=SQRT(CLK*(PP/RPRES)) GOTO 20 70 DYS(NLK)=CLK*(PP/RPRES) 20 CONTINUE 100 CONTINUE RETURN 9400 FORMAT(2X,'OBJECTS ',3A1,' AND ',3A1, F28H HAVE NO COMMON MEASUREMENTS) END CC CC SUBROUTINE AVERL(NN,MAXNN,KWAN,NER,BAN,MAXHH,DYS,LUB) DIMENSION KWAN(MAXNN),DYS(MAXHH),NER(MAXNN),BAN(MAXNN) NCLU=NN-1 CC INITIALIZATION DO 10 L=1,NN KWAN(L)=1 NER(L)=L 10 CONTINUE CC CC FIND CLOSEST CLUSTERS CC 100 J=1 80 J=J+1 IF(KWAN(J).EQ.0)GOTO 80 NEJ=MEET(1,J) SMALD=DYS(NEJ)*1.1+1.0 NNS=NN-1 DO 120 L=1,NNS IF(KWAN(L).EQ.0)GO TO 120 LMUCH=L+1 DO 110 J=LMUCH,NN IF(KWAN(J).EQ.0)GO TO 110 NLJ=MEET(L,J) IF(DYS(NLJ).GT.SMALD)GO TO 110 SMALD=DYS(NLJ) LA=L LB=J 110 CONTINUE 120 CONTINUE CC CC DETERMINE LFYRS AND LLAST CC DO 200 L=1,NN IF(NER(L).EQ.LA)LFYRS=L IF(NER(L).EQ.LB)LLAST=L 200 CONTINUE BAN(LLAST)=SMALD CC CC IF THE TWO CLUSTERS ARE NEXT TO EACH OTHER, CC NER MUST NOT BE CHANGED CC LNEXT=LFYRS+KWAN(LA) IF(LNEXT.EQ.LLAST)GOTO 230 CC CC UPDATING NER AND BAN CC LPUT=LFYRS+KWAN(LA) LNUM=LLAST-LPUT DO 220 L=1,LNUM LKA=NER(LPUT) AKB=BAN(LPUT) LENDA=LLAST+KWAN(LB)-2 LENDB=LENDA+1 DO 210 J=LPUT,LENDA NER(J)=NER(J+1) BAN(J)=BAN(J+1) 210 CONTINUE NER(LENDB)=LKA BAN(LENDB)=AKB 220 CONTINUE CC CC CALCULATE NEW DISSIMILARITIES CC 230 DO 240 LQ=1,NN IF(LQ.EQ.LA.OR.LQ.EQ.LB)GO TO 240 IF(KWAN(LQ).EQ.0)GO TO 240 TA=KWAN(LA) TB=KWAN(LB) FA=TA/(TA+TB) FB=TB/(TA+TB) NAQ=MEET(LA,LQ) NBQ=MEET(LB,LQ) DYS(NAQ)=FA*DYS(NAQ)+FB*DYS(NBQ) 240 CONTINUE IF(NCLU.NE.1)GOTO 250 WRITE(LUB,9100) WRITE(LUB,9110)(NER(L),L=1,NN) WRITE(LUB,9120) WRITE(LUB,9130)(BAN(L),L=2,NN) 250 KWAN(LA)=KWAN(LA)+KWAN(LB) KWAN(LB)=0 NCLU=NCLU-1 IF(NCLU.GT.0)GOTO 100 RETURN 9100 FORMAT(//37H THE FINAL ORDERING OF THE OBJECTS IS/) 9110 FORMAT(5(I9,6X)) 9120 FORMAT(//41H THE DISSIMILARITIES BETWEEN CLUSTERS ARE/) 9130 FORMAT(3X,5F15.3) END CC CC SUBROUTINE BANAG(NN,MAXNN,BAN,NER,LAB,NUM,LUB) DIMENSION BAN(MAXNN),NER(MAXNN) CHARACTER*1 LAB(3,MAXNN),JDRAW(78),NUM(13),JBLAN,JSTAR,JSEPA JBLAN=NUM(11) JSTAR=NUM(12) JSEPA=NUM(13) WRITE(LUB,9000) WRITE(LUB,9200) WRITE(LUB,9210) WRITE(LUB,9220) SUP=0.0 DO 70 K=2,NN IF(BAN(K).GT.SUP)SUP=BAN(K) 70 CONTINUE AC=0.0 DO 80 K=1,NN KEARL=K IF(K.EQ.1)KEARL=2 KAFTE=K+1 IF(K.EQ.NN)KAFTE=NN SYZE=BAN(KEARL) IF(BAN(KAFTE).LT.SYZE)SYZE=BAN(KAFTE) AC=AC+1.0-(SYZE/SUP) LEMPT=INT((SYZE/SUP)*75.0+0.01) IF(LEMPT.EQ.0)GOTO 82 DO 81 L=1,LEMPT JDRAW(L)=JBLAN 81 CONTINUE 82 LADD=LEMPT+1 KAUNT=0 NCASE=NER(K) DO 83 L=LADD,78 KAUNT=KAUNT+1 IF(KAUNT.EQ.5)KAUNT=1 IF(KAUNT.EQ.1)JDRAW(L)=LAB(1,NCASE) IF(KAUNT.EQ.2)JDRAW(L)=LAB(2,NCASE) IF(KAUNT.EQ.3)JDRAW(L)=LAB(3,NCASE) IF(KAUNT.EQ.4)JDRAW(L)=JSEPA 83 CONTINUE WRITE(LUB,9100)(JDRAW(J),J=1,78) IF(K.EQ.NN)GO TO 90 SYZE=BAN(KAFTE) LEMPT=INT((SYZE/SUP)*75.0+0.01) IF(LEMPT.EQ.0)GOTO 86 DO 85 L=1,LEMPT JDRAW(L)=JBLAN 85 CONTINUE 86 LADD=LEMPT+1 DO 87 L=LADD,78 JDRAW(L)=JSTAR 87 CONTINUE WRITE(LUB,9100)(JDRAW(J),J=1,78) 80 CONTINUE 90 WRITE(LUB,9200) WRITE(LUB,9210) WRITE(LUB,9220) WRITE(LUB,9300)SUP RNN=NN AC=AC/RNN WRITE(LUB,9310)AC RETURN 9000 FORMAT(///34X,12(1H*)/34X,1H*,10X,1H*/34X,1H*,8H BANNER, F2X,1H*/34X,1H*,10X,1H*/34X,12(1H*)/) 9100 FORMAT(1X,78A1) 9200 FORMAT(//1X,25(3H0 ),1H1/1X,26(3H. )) 9210 FORMAT(1X,45H0 0 0 1 1 2 2 2 3 3 4 4 4 5 5 , F31H6 6 6 7 7 8 8 8 9 9 0) 9220 FORMAT(1X,5(15H0 4 8 2 6 ),1H0//) 9300 FORMAT(//28H THE ACTUAL HIGHEST LEVEL IS,3X,F25.10) 9310 FORMAT(//38H THE AGGLOMERATIVE COEFFICIENT OF THIS, F12H DATA SET IS,2X,F5.2) END CC CC SUBROUTINE SPLYT(NN,MAXNN,KWAN,NER,BAN,MAXHH,DYS,LUB) DIMENSION KWAN(MAXNN),DYS(MAXHH),NER(MAXNN),BAN(MAXNN) CC CC INITIALIZATION CC NCLU=1 NHALF=NN*(NN-1)/2+1 DO 10 L=1,NN KWAN(L)=0 BAN(L)=0. NER(L)=L 10 CONTINUE KWAN(1)=NN JA=1 CC CC COMPUTATION OF DIAMETER OF DATA SET CC CS=0.0 K=0 20 K=K+1 IF(DYS(K).GT.CS)CS=DYS(K) IF(K.LT.NHALF)GO TO 20 CC CC PREPARE FOR SPLITTING CC 30 JB=JA+KWAN(JA)-1 JMA=JB CC CC SPECIAL CASE OF A PAIR OF OBJECTS CC IF(KWAN(JA).NE.2)GO TO 50 KWAN(JA)=1 KWAN(JB)=1 JAN=NER(JA) JBN=NER(JB) JAB=MEET(JAN,JBN) BAN(JB)=DYS(JAB) GO TO 400 CC CC FINDING FIRST OBJECT TO BE SHIFTED CC 50 BYGSD=-1. DO 110 L=JA,JB LNER=NER(L) SD=0. DO 100 J=JA,JB JNER=NER(J) NLJ=MEET(LNER,JNER) SD=SD+DYS(NLJ) 100 CONTINUE IF(SD.LE.BYGSD)GO TO 110 BYGSD=SD LNDSD=L 110 CONTINUE CC CC SHIFTING THE FIRST OBJECT CC KWAN(JA)=KWAN(JA)-1 KWAN(JB)=1 IF(JB.EQ.LNDSD)GO TO 115 LCHAN=NER(LNDSD) LMM=JB-1 DO 112 LMMA=LNDSD,LMM LMMB=LMMA+1 NER(LMMA)=NER(LMMB) 112 CONTINUE NER(JB)=LCHAN 115 SPLYN=0. JMA=JB-1 CC CC FINDING THE NEXT OBJECT TO BE SHIFTED CC 120 SPLYN=SPLYN+1. REST=JMA-JA BDYFF=-1. DO 150 L=JA,JMA LNER=NER(L) DA=0. DO 130 J=JA,JMA JNER=NER(J) NLJ=MEET(LNER,JNER) DA=DA+DYS(NLJ) 130 CONTINUE DA=DA/REST DB=0. JMB=JMA+1 DO 140 J=JMB,JB JNER=NER(J) NLJ=MEET(LNER,JNER) DB=DB+DYS(NLJ) 140 CONTINUE DB=DB/SPLYN DYFF=DA-DB IF(DYFF.LE.BDYFF)GO TO 150 BDYFF=DYFF JAWAY=L 150 CONTINUE JMB=JMA+1 CC CC SHIFTING THE NEXT OBJECT WHEN NECESSARY CC IF(BDYFF.LE.0.)GO TO 200 IF(JMA.EQ.JAWAY)GO TO 165 LCHAN=NER(JAWAY) LMZ=JMA-1 DO 160 LXX=JAWAY,LMZ LXXP=LXX+1 NER(LXX)=NER(LXXP) 160 CONTINUE NER(JMA)=LCHAN 165 DO 170 LXX=JMB,JB LXY=LXX-1 IF(NER(LXY).LT.NER(LXX))GO TO 180 LCHAN=NER(LXY) NER(LXY)=NER(LXX) NER(LXX)=LCHAN 170 CONTINUE 180 KWAN(JA)=KWAN(JA)-1 KWAN(JMA)=KWAN(JMB)+1 KWAN(JMB)=0 JMA=JMA-1 JMB=JMA+1 IF(JMA.NE.JA)GO TO 120 CC CC SWITCH THE TWO PARTS WHEN NECESSARY CC 200 IF(NER(JA).LT.NER(JMB))GO TO 300 LXXA=JA DO 220 LGRB=JMB,JB LXXA=LXXA+1 LCHAN=NER(LGRB) DO 210 LXY=LXXA,LGRB LXF=LGRB-LXY+LXXA LXG=LXF-1 NER(LXF)=NER(LXG) 210 CONTINUE NER(LXG)=LCHAN 220 CONTINUE LLQ=KWAN(JMB) KWAN(JMB)=0 JMA=JA+JB-JMA-1 JMB=JMA+1 KWAN(JMB)=KWAN(JA) KWAN(JA)=LLQ CC CC COMPUTE LEVEL FOR BANNER CC 300 IF(NCLU.EQ.1)BAN(JMB)=CS IF(NCLU.EQ.1)GO TO 400 CALL SUPCL(MAXHH,DYS,JA,JB,AREST,MAXNN,NER) BAN(JMB)=AREST 400 NCLU=NCLU+1 IF(NCLU.EQ.2)WRITE(LUB,9000)NN,JMA,KWAN(JMB) IF(NCLU.EQ.NN)GOTO 500 CC CC CONTINUE SPLITTING UNTIL ALL OBJECTS ARE SEPARATED CC IF(JB.EQ.NN)GO TO 430 420 JA=JA+KWAN(JA) IF(JA.GT.NN)GO TO 430 IF(KWAN(JA).LE.1)GO TO 420 GO TO 30 430 JA=1 IF(KWAN(JA).EQ.1)GO TO 420 GO TO 30 500 WRITE(LUB,9100) WRITE(LUB,9110)(NER(L),L=1,NN) WRITE(LUB,9120) WRITE(LUB,9130)(BAN(L),L=2,NN) RETURN 9000 FORMAT(//22H AT THE FIRST STEP THE,I4,20H OBJECTS ARE DIVIDED, F5H INTO/3X,I4,12H OBJECTS AND,I4,8H OBJECTS) 9100 FORMAT(//37H THE FINAL ORDERING OF THE OBJECTS IS/) 9110 FORMAT(5(I9,6X)) 9120 FORMAT(//34H THE DIAMETERS OF THE CLUSTERS ARE/) 9130 FORMAT(3X,5F15.3) END CC CC SUBROUTINE SUPCL(MAXHH,DYS,KKA,KKB,AREST,MAXNN,NER) DIMENSION DYS(MAXHH),NER(MAXNN) KKC=KKB-1 AREST=0. DO 20 L=KKA,KKC LNER=NER(L) KKD=L+1 DO 10 J=KKD,KKB JNER=NER(J) MLJ=MEET(LNER,JNER) IF(DYS(MLJ).GT.AREST)AREST=DYS(MLJ) 10 CONTINUE 20 CONTINUE RETURN END CC CC SUBROUTINE BANDY(NN,MAXNN,BAN,NER,LAB,NUM,LUB) DIMENSION BAN(MAXNN),NER(MAXNN) CHARACTER*1 LAB(3,MAXNN),JDRAW(78),NUM(13),JSTAR,JSEPA JSTAR=NUM(12) JSEPA=NUM(13) WRITE(LUB,9000) WRITE(LUB,9200) WRITE(LUB,9210) WRITE(LUB,9220) SUP=0.0 DO 70 K=2,NN IF(BAN(K).GT.SUP)SUP=BAN(K) 70 CONTINUE DO 71 K=2,NN BAN(K)=BAN(K)/SUP 71 CONTINUE DC=0.0 DO 80 K=1,NN NCASE=NER(K) DO 81 L=1,19 LALFA=(L-1)*4+1 LBETA=(L-1)*4+2 LGAMA=(L-1)*4+3 LDELT=L*4 JDRAW(LALFA)=LAB(1,NCASE) JDRAW(LBETA)=LAB(2,NCASE) JDRAW(LGAMA)=LAB(3,NCASE) JDRAW(LDELT)=JSEPA 81 CONTINUE JDRAW(77)=LAB(1,NCASE) JDRAW(78)=LAB(2,NCASE) KEARL=K IF(K.EQ.1)KEARL=2 KAFTE=K+1 IF(K.EQ.NN)KAFTE=NN SYZE=BAN(KEARL) IF(BAN(KAFTE).LT.SYZE)SYZE=BAN(KAFTE) DC=DC+1.0-SYZE LENGT=INT((1.0-SYZE)*75.0+0.01)+3 WRITE(LUB,9100)(JDRAW(J),J=1,LENGT) IF(K.EQ.NN)GO TO 90 SYZE=BAN(KAFTE) LENGT=INT((1.0-SYZE)*75.0+0.01)+3 DO 82 L=1,LENGT JDRAW(L)=JSTAR 82 CONTINUE WRITE(LUB,9100)(JDRAW(J),J=1,LENGT) 80 CONTINUE 90 WRITE(LUB,9200) WRITE(LUB,9210) WRITE(LUB,9220) WRITE(LUB,9300)SUP RNN=NN DC=DC/RNN WRITE(LUB,9310)DC RETURN 9000 FORMAT(///34X,12(1H*)/34X,1H*,10X,1H*/34X,1H*,8H BANNER, F2X,1H*/34X,1H*,10X,1H*/34X,12(1H*)/) 9100 FORMAT(1X,78A1) 9200 FORMAT(//3X,1H1,25(3H 0)/3X,26(3H. )) 9210 FORMAT(3X,45H0 9 9 8 8 8 7 7 6 6 6 5 5 4 4 , F31H4 3 3 2 2 2 1 1 0 0 0) 9220 FORMAT(3X,5(15H0 6 2 8 4 ),1H0//) 9300 FORMAT(//40H THE ACTUAL DIAMETER OF THIS DATA SET IS,3X,F25.10) 9310 FORMAT(//33H THE DIVISIVE COEFFICIENT OF THIS, F12H DATA SET IS,2X,F5.2) END CC CC SUBROUTINE ENTR(MAXNN,MAXTT,MAXPP,MAXHH,X,DVEC,DYS,VALMD,JTMD, F JPLACE,HULP,LAB,JLAB,NUM,LUA,LUB,LUC,FNAMEA,FNAMEB,FNAMEC, F NAME,JFMT,NN,JPP,JDYSS,NSTAN,NDYST,LARGE,LGRAP,JLABS, F NFF,MDATA,YNSAVE,JALG) DIMENSION X(MAXNN,MAXPP),DVEC(MAXNN),DYS(MAXHH) DIMENSION VALMD(MAXPP),JTMD(MAXPP),JPLACE(MAXPP),HULP(MAXTT) CHARACTER NUM(13) CHARACTER STAN,DYSS,DYST,CYNFF,YNSAVE,CARGE,CGRAP,CLABS,CMDT CHARACTER CALG,CDATA,CYNK,CEX,LAB(3,MAXNN),JLAB(10,MAXPP) CHARACTER*30 FNAMEA,FNAMEB,FNAMEC CHARACTER*60 JFMT,NAME NUM(1)='0' NUM(2)='1' NUM(3)='2' NUM(4)='3' NUM(5)='4' NUM(6)='5' NUM(7)='6' NUM(8)='7' NUM(9)='8' NUM(10)='9' NUM(11)=' ' NUM(12)='*' NUM(13)='+' YNSAVE=' ' NSTAN=0 WRITE(*,9000) 50 WRITE(*,9010) 60 READ(*,8500)CALG JALG=0 IF(CALG.EQ.'A'.OR.CALG.EQ.'a')JALG=1 IF(CALG.EQ.'D'.OR.CALG.EQ.'d')JALG=2 IF(JALG.NE.0)GO TO 70 WRITE(*,9520) GO TO 60 70 IF(JALG.EQ.1)WRITE(*,9500) IF(JALG.EQ.2)WRITE(*,9501) WRITE(*,9505) IF(JALG.EQ.1)WRITE(*,9506) IF(JALG.EQ.2)WRITE(*,9507) WRITE(*,9508) 100 WRITE(*,9510) 110 READ(*,8500)DYSS JDYSS=2 IF(DYSS.EQ.'D'.OR.DYSS.EQ.'d')JDYSS=1 IF(DYSS.EQ.'M'.OR.DYSS.EQ.'m')JDYSS=0 IF(JDYSS.NE.2)GO TO 120 WRITE(*,9520) GO TO 110 120 WRITE (*,9525)MAXNN 130 WRITE (*,9530)MAXNN READ (*,*) NN IF(NN.LE.MAXNN) GOTO 140 WRITE(*,9520) GOTO 130 140 IF(NN.GE.3)GO TO 200 WRITE(*,9540) GOTO 130 200 IF(JDYSS.EQ.1)GO TO 500 CC CC IN THIS SECTION SPECIFIC INFORMATION RELATED TO THE INPUT CC OF MEASUREMENTS IS ENTERED : CC TOTAL NUMBER OF VARIABLES (JPPT) CC NUMBER OF VARIABLES TO BE USED IN THE ANALYSIS (JPP) CC VARIABLES TO BE USED IN THE ANALYSIS, AND THEIR LABELS CC CHOICE OF STANDARDIZATION CC CHOICE OF EUCLIDEAN OR MANHATTAN DISTANCE. CC WRITE(*,9620)MAXTT,MAXPP 300 WRITE(*,9630)MAXTT READ(*,*)JPPT IF(JPPT.NE.1)GO TO 310 JPP=1 GO TO 350 310 IF(JPPT.GE.1.AND.JPPT.LE.MAXTT)GO TO 320 WRITE(*,9520) GO TO 300 320 JPPA=MAXPP IF(JPPA.GT.JPPT)JPPA=JPPT 330 WRITE(*,9640)JPPA READ(*,*)JPP IF(JPP.GE.1.AND.JPP.LE.JPPA)GO TO 340 WRITE(*,9520) GO TO 330 340 IF(JPPT.GT.JPP)GO TO 370 350 WRITE(*,9650) DO 360 J=1,JPP JPLACE(J)=J WRITE(*,9660)J READ(*,8510)(JLAB(K,J),K=1,10) 360 CONTINUE GO TO 410 370 WRITE(*,9670) DO 400 J=1,JPP 380 WRITE(*,9680)J READ(*,8520)JPLACE(J),(JLAB(K,J),K=1,10) IF(JPLACE(J).LT.1.OR.JPLACE(J).GT.JPPT)GO TO 380 IF(J.EQ.1)GO TO 400 JPPL=J-1 DO 390 JK=1,JPPL IF(JPLACE(JK).NE.JPLACE(J))GO TO 390 WRITE(*,9690) GO TO 380 390 CONTINUE 400 CONTINUE 410 WRITE(*,9700) CALL QYN(STAN,NSTAN) WRITE(*,9710) 420 READ(*,8500)DYST NDYST=0 IF(DYST.EQ.'E'.OR.DYST.EQ.'e')NDYST=1 IF(DYST.EQ.'M'.OR.DYST.EQ.'m')NDYST=2 IF(NDYST.NE.0)GO TO 500 WRITE(*,9520) GO TO 420 CC CC OUTPUT SECTION : CC TITLE CC SMALL OR LARGE OUTPUT CC GRAPHICAL OUTPUT (BANNER) CC LABELS OF OBJECTS CC 500 WRITE (*,9720) READ (*,8530)NAME WRITE(*,9730) IF(NSTAN.EQ.1)WRITE(*,9732) IF(NSTAN.EQ.0)WRITE(*,9734) CALL QYN(CARGE,LARGE) WRITE(*,9740) CALL QYN(CGRAP,LGRAP) WRITE(*,9750) CALL QYN(CLABS,JLABS) IF(JLABS.EQ.0)GO TO 520 WRITE(*,9760) DO 510 J=1,NN WRITE(*,9770)J READ(*,8540)LAB(1,J),LAB(2,J),LAB(3,J) 510 CONTINUE GO TO 550 520 CALL NWLAB(NN,MAXNN,NUM,LAB) CC CC FORMATS CC 550 WRITE (*,9780) CALL QYN(CYNFF,NFF) IF (CYNFF.EQ.'Y') GOTO 600 WRITE(*,9790) READ (*,8530)JFMT CC CC STATUS OF INPUT AND OUTPUT: KEYBOARD, SCREEN, PRINTER, FILES. CC 600 WRITE(*,9800) READ(*,8550)FNAMEA IF(FNAMEA.EQ.'KEY'.OR.FNAMEA.EQ.'key'.OR.FNAMEA.EQ.'Key')GOTO 610 YNSAVE='N' NSAVE=0 GO TO 620 610 FNAMEA='CON' WRITE(*,9810) CALL QYN(YNSAVE,NSAVE) IF (YNSAVE.EQ.'N')GO TO 620 612 WRITE(*,9820) READ(*,8550)FNAMEC OPEN(LUC,FILE=FNAMEC,STATUS='NEW',IOSTAT=NEG,ERR=615) GO TO 620 615 IF(NEG.NE.1027.AND.NEG.NE.1030.AND.NEG.NE.1032. F AND.NEG.NE.1033.AND.NEG.NE.1045)GO TO 616 WRITE(*,9831) GO TO 612 616 WRITE(*,9834)NEG STOP 620 OPEN(LUA,FILE=FNAMEA,IOSTAT=NER,ERR=630) GO TO 640 630 IF(FNAMEA.NE.'CON'.AND.(NER.EQ.1027.OR.NER.EQ.1030.OR. F NER.EQ.1032.OR.NER.EQ.1033))THEN WRITE(*,9832) GO TO 600 ENDIF WRITE(*,9834)NER STOP 640 WRITE(*,9830) READ(*,8550)FNAMEB IF(FNAMEB.EQ.'con'.OR.FNAMEB.EQ.'Con')FNAMEB='CON' IF(FNAMEB.EQ.'prn'.OR.FNAMEB.EQ.'Prn')FNAMEB='PRN' IF (FNAMEB.EQ.'CON'.OR.FNAMEB.EQ.'PRN')OPEN(LUB,FILE=FNAMEB) IF (.NOT.(FNAMEB.EQ.'CON'.OR.FNAMEB.EQ.'PRN'))OPEN(LUB, F FILE=FNAMEB,STATUS='NEW',IOSTAT=NET,ERR=650) GO TO 690 650 IF(NET.NE.1027.AND.NET.NE.1030.AND.NET.NE.1032. F AND.NET.NE.1033.AND.NET.NE.1045)GO TO 660 WRITE(*,9831) GO TO 640 660 WRITE(*,9834)NET STOP 690 IF(JDYSS.EQ.1)GO TO 800 CC CC SECTION ON MISSING DATA CC WRITE (*,9840) CALL QYN(CDATA,MDATA) IF(MDATA.EQ.0) GO TO 740 WRITE(*,9850) CALL QYN(CMDT,MDT) IF(MDT.EQ.0)GO TO 710 WRITE(*,9860) READ(*,*)VVAL DO 700 J=1,JPP JTMD(J)=-1 VALMD(J)=VVAL 700 CONTINUE GO TO 800 710 DO 730 J=1,JPP WRITE (*,9870)(JLAB(K,J),K=1,10) CALL QYN(CYNK,NYNK) IF (CYNK.EQ.'Y')GO TO 720 JTMD(J)=1 VALMD(J)=-99.99 GO TO 730 720 JTMD(J)=-1 WRITE(*,9880) READ (*,*) VALMD(J) 730 CONTINUE GO TO 800 740 DO 750 J=1,JPP JTMD(J)=1 VALMD(J)=-99.99 750 CONTINUE CC CC RECAPITULATION OF OPTIONS CC 800 WRITE(*,9890) WRITE(*,9900) WRITE(*,9905)NAME WRITE(*,9910)NN IF(CLABS.EQ.'Y')WRITE(*,8070) IF(CLABS.EQ.'N')WRITE(*,8075) IF(JDYSS.EQ.1)WRITE(*,8080) IF(JDYSS.EQ.0)WRITE(*,8085) IF(CARGE.EQ.'Y')WRITE(*,8090) IF(CARGE.EQ.'N')WRITE(*,8095) IF(CGRAP.EQ.'Y')WRITE(*,8100) IF(CGRAP.EQ.'N')WRITE(*,8105) IF(JDYSS.EQ.1)GO TO 840 IF(JPPT.GT.1)GO TO 810 WRITE(*,8118) GO TO 820 810 WRITE(*,8115)JPPT IF(JPP.GT.1)WRITE(*,8116)JPP IF(JPP.EQ.1)WRITE(*,8119)(JLAB(K,1),K=1,10),JPLACE(1) 820 IF(STAN.EQ.'Y')WRITE(*,8120) IF(STAN.EQ.'N')WRITE(*,8125) IF(NDYST.EQ.1)WRITE(*,8130) IF(NDYST.EQ.2)WRITE(*,8135) IF(CDATA.EQ.'N')WRITE(*,8145) IF(CDATA.EQ.'N')GO TO 830 IF(CMDT.EQ.'N')WRITE(*,8140) IF(CMDT.EQ.'Y')WRITE(*,8142) IF(CMDT.EQ.'Y')WRITE(*,*)VVAL 830 IF (CYNFF.EQ.'Y') WRITE(*,8160) IF (CYNFF.EQ.'N') WRITE(*,8165) JFMT GO TO 850 840 IF (CYNFF.EQ.'Y') WRITE(*,8170) IF (CYNFF.EQ.'N') WRITE(*,8175) JFMT 850 IF (FNAMEA.NE.'CON') WRITE(*,8039) FNAMEA IF (FNAMEA.EQ.'CON') WRITE(*,8034) IF (YNSAVE.EQ.'Y') WRITE(*,8038) FNAMEC WRITE(*,8040) FNAMEB WRITE (*,8030) CALL QYN(CEX,NEX) IF (CEX.NE.'Y')GO TO 50 IF(FNAMEB.EQ.'CON')GO TO 900 IF(JALG.EQ.1)WRITE(LUB,9500) IF(JALG.EQ.2)WRITE(LUB,9501) WRITE(LUB,9505) IF(JALG.EQ.1)WRITE(LUB,9506) IF(JALG.EQ.2)WRITE(LUB,9507) WRITE(LUB,9508) WRITE(LUB,9906)NAME WRITE(LUB,9900) WRITE(LUB,9910)NN IF(JLABS.NE.0)WRITE(LUB,8070) IF(JLABS.EQ.0)WRITE(LUB,8075) IF(JDYSS.NE.0)WRITE(LUB,8080) IF(JDYSS.EQ.0)WRITE(LUB,8085) IF(LARGE.NE.0)WRITE(LUB,8090) IF(LARGE.EQ.0)WRITE(LUB,8095) IF(LGRAP.NE.0)WRITE(LUB,8100) IF(LGRAP.EQ.0)WRITE(LUB,8105) IF(JDYSS.EQ.1)GO TO 880 IF(JPPT.GT.1)GO TO 852 WRITE(LUB,8118) GO TO 865 852 WRITE(LUB,8115)JPPT IF(JPP.GT.1)GO TO 854 WRITE(LUB,8119)(JLAB(K,1),K=1,10),JPLACE(1) GO TO 865 854 WRITE(LUB,8116)JPP WRITE(LUB,8114) DO 860 J=1,JPP WRITE(LUB,8117)(JLAB(K,J),K=1,10),JPLACE(J) 860 CONTINUE 865 IF(NSTAN.EQ.0)WRITE(LUB,8125) IF(NSTAN.EQ.1)WRITE(LUB,8120) IF(NDYST.EQ.1)WRITE(LUB,8130) IF(NDYST.EQ.2)WRITE(LUB,8135) IF(CDATA.EQ.'N')WRITE(LUB,8145) IF(CDATA.EQ.'N')GO TO 870 WRITE(LUB,8140) IF(CMDT.EQ.'Y')WRITE(LUB,8142) IF(CMDT.EQ.'Y')WRITE(LUB,*)VVAL 870 IF (CYNFF.EQ.'Y') WRITE(LUB,8160) IF (CYNFF.EQ.'N') WRITE(LUB,8165) JFMT GO TO 890 880 IF (CYNFF.EQ.'Y') WRITE(LUB,8170) IF (CYNFF.EQ.'N') WRITE(LUB,8175) JFMT 890 IF (FNAMEB.EQ.'CON') PAUSE ' ' IF(FNAMEB.NE.'CON')WRITE(LUB,*) IF (YNSAVE.EQ.'Y') WRITE(LUB,8038) FNAMEC IF (FNAMEA.NE.'CON') WRITE(LUB,8039) FNAMEA CC CC INPUT OF DATA CC 900 IF (FNAMEA.EQ.'CON') WRITE(*,8355) IF(JDYSS.EQ.1)GO TO 940 DO 930 L=1,NN IF (FNAMEA.NE.'CON')GO TO 910 WRITE(*,8359)JPPT,LAB(1,L),LAB(2,L),LAB(3,L) 910 IF (CYNFF.EQ.'N') READ(LUA,JFMT)(HULP(J),J=1,JPPT) IF (CYNFF.EQ.'Y') READ(LUA,*)(HULP(J),J=1,JPPT) DO 920 J=1,JPP JH=JPLACE(J) X(L,J)=HULP(JH) 920 CONTINUE IF (YNSAVE.EQ.'N')GO TO 930 IF (CYNFF.EQ.'N') WRITE(LUC,JFMT)(HULP(J),J=1,JPPT) IF (CYNFF.EQ.'Y') WRITE(LUC,*)(HULP(J),J=1,JPPT) 930 CONTINUE IF (YNSAVE.EQ.'Y') CLOSE(LUC,STATUS='KEEP') IF (YNSAVE.EQ.'Y') WRITE(*,8038) FNAMEC RETURN 940 DYS(1)=0.0 IF(FNAMEA.EQ.'CON')WRITE(*,8363) DO 990 L=2,NN LSUBT=L-1 IF (FNAMEA.NE.'CON')GO TO 950 IF (L.EQ.2) WRITE(*,8361) LAB(1,2),LAB(2,2),LAB(3,2), F LAB(1,1),LAB(2,1),LAB(3,1) IF (L.NE.2) WRITE(*,8362)LSUBT,LAB(1,L),LAB(2,L),LAB(3,L) 950 IF (CYNFF.EQ.'Y') READ(LUA,*)(DVEC(J),J=1,LSUBT) IF (CYNFF.EQ.'N') READ(LUA,JFMT)(DVEC(J),J=1,LSUBT) DO 980 J=1,LSUBT IF(DVEC(J).GE.0.)GO TO 970 IF(FNAMEA.EQ.'CON')GO TO 960 WRITE(*,8365)L,J STOP 960 WRITE(*,8370)LAB(1,L),LAB(2,L),LAB(3,L),LAB(1,J),LAB(2,J), F LAB(3,J),LAB(1,L),LAB(2,L),LAB(3,L) GO TO 950 970 NLJ=MEET(L,J) DYS(NLJ)=DVEC(J) 980 CONTINUE IF (YNSAVE.EQ.'N')GO TO 990 IF (CYNFF.EQ.'Y') WRITE(LUC,*)(DVEC(J),J=1,LSUBT) IF (CYNFF.EQ.'N') WRITE(LUC,JFMT)(DVEC(J),J=1,LSUBT) 990 CONTINUE IF (YNSAVE.EQ.'Y') CLOSE(LUC,STATUS='KEEP') IF (YNSAVE.EQ.'Y') WRITE(*,8038) FNAMEC RETURN 8030 FORMAT(/1X,' ARE ALL THESE OPTIONS OK? YES OR NO: '$) 8034 FORMAT(1X,' THE DATA WILL BE READ FROM THE KEYBOARD') 8038 FORMAT(1X,' THE DATA WILL BE SAVED IN THE FILE: ',A30) 8039 FORMAT(1X,' YOUR DATA RESIDE IN THE FILE: ',A30/) 8040 FORMAT(1X,' YOUR OUTPUT WILL BE WRITTEN IN: ',A30) 8070 FORMAT(1X,' LABELS OF OBJECTS ARE READ') 8075 FORMAT(1X,' LABELS OF OBJECTS ARE NOT READ') 8080 FORMAT(1X,' INPUT OF DISSIMILARITIES') 8085 FORMAT(1X,' INPUT OF MEASUREMENTS') 8090 FORMAT(1X,' LARGE OUTPUT IS WANTED') 8095 FORMAT(1X,' SMALL OUTPUT') 8100 FORMAT(1X,' GRAPHICAL OUTPUT IS WANTED (BANNER)') 8105 FORMAT(1X,' NO GRAPHICAL OUTPUT IS WANTED') 8114 FORMAT(' THESE VARIABLES ARE :') 8115 FORMAT(/1X,' THERE ARE ',I4,' VARIABLES IN THE DATA SET,') 8116 FORMAT(1X,' AND 'I4,' OF THEM WILL BE USED IN THE ANALYSIS') 8117 FORMAT(10X,10A1,' (POSITION :',I3,')') 8118 FORMAT(/1X,' THERE IS ONE VARIABLE IN THE DATA SET') 8119 FORMAT(1X,' AND ONLY VARIABLE ',10A1,' WILL BE USED IN THE' F ' ANALYSIS (POSITION :',I3,')') 8120 FORMAT(1X,' THE MEASUREMENTS WILL BE STANDARDIZED') 8125 FORMAT(1X,' THE MEASUREMENTS WILL NOT BE STANDARDIZED') 8130 FORMAT(1X,' EUCLIDEAN DISTANCE IS USED') 8135 FORMAT(1X,' MANHATTAN DISTANCE IS USED') 8140 FORMAT(1X,' MISSING VALUES CAN OCCUR') 8142 FORMAT(1X,' THE UNIQUE VALUE WHICH REPRESENTS MISSING' F' MEASUREMENTS IS :'/6X$) 8145 FORMAT(1X,' THERE ARE NO MISSING VALUES') 8160 FORMAT(1X,' THE MEASUREMENTS WILL BE READ IN FREE FORMAT') 8165 FORMAT(1X,' THE INPUT FORMAT FOR THE MEASUREMENTS IS'/2X,A60) 8170 FORMAT(1X,' THE DISSIMILARITIES WILL BE READ IN FREE FORMAT') 8175 FORMAT(' THE INPUT FORMAT FOR THE DISSIMILARITIES IS'/2X,A60) 8355 FORMAT(//1X,'PLEASE ENTER YOUR DATA FOR EACH OBJECT'//) 8359 FORMAT(1X,' THE',I3,' MEASUREMENTS FOR OBJECT ',3A1,' : '/) 8360 FORMAT(1X,'THE',I3,' MEASUREMENTS FOR OBJECT ',3A1,' : '/) 8361 FORMAT(1X,' DISSIMILARITY BETWEEN OBJECTS ',3A1, F' AND ',3A1,' : '/) 8362 FORMAT(1X,' THE ',I4,' DISSIMILARITIES FOR OBJECT ',3A1, F' : '/) 8363 FORMAT(1X,' FOR OBJECT J, ENTER DISSIMILARITIES TO OBJECTS', F' 1,2,... ,(J-1) '//) 8365 FORMAT(/1X,'THE DISSIMILARITY BETWEEN OBJECTS',I5,' AND ',I5, F' IS NEGATIVE,'/' UNFORTUNATELY THE PROGRAM MUST BE STOPPED.') 8370 FORMAT(/' THE DISSIMILARITY BETWEEN OBJECTS ',3A1,' AND ',3A1, F' IS NEGATIVE.'/1X,'PLEASE ENTER THE DISSIMILARITIES FOR', F' OBJECT ',3A1,' ONCE AGAIN :'/) 8500 FORMAT(A1) 8510 FORMAT(10A1) 8520 FORMAT(BNI4,6X,10A1) 8530 FORMAT(A60) 8540 FORMAT(3A1) 8550 FORMAT(A30) 9000 FORMAT(///////////////26X,29('*')/26X,'*',27X,'*'/26X,'* HI', F'ERARCHICAL CLUSTERING *'/26X,'*',27X,'*'/26X,29('*')////) 9010 FORMAT(/1X,'DO YOU WANT AGGLOMERATIVE NESTING (AGNES)' F /1X,'OR DIVISIVE ANALYSIS (DIANA)?'/1X,'PLEASE' F ' ENTER YOUR CHOICE (A OR D): '$) 9500 FORMAT(///////////////27X,27('*')/27X,'*',25X,'*'/27X,'* AG', F'GLOMERATIVE NESTING *'/27X,'*',25X,'*'/27X,27('*')//) 9501 FORMAT(///////////////29X,23('*')/29X,'*',21X,'*'/29X,'* DI', F'VISIVE ANALYSIS *'/29X,'*',21X,'*'/29X,23('*')//) 9505 FORMAT(/' Copyright (C) Leonard Kaufman and Peter' F ' Rousseeuw 1990. All rights reserved.'//) 9506 FORMAT(/6X,'This agglomerative hierarchical clustering' F' algorithm is based on'/6X,'the group average method of' F' Sokal and Michener.') 9507 FORMAT(/6X,'This divisive hierarchical clustering' F ' algorithm uses the method of'/6X,'McNaughton-Smith,' F ' Williams, Dale, and Mockett.') 9508 FORMAT(6X,'More information is given in:' F //6X,'L. Kaufman and P.J. Rousseeuw (1990),' F /6X,'Finding Groups in Data: An Introduction to' F ' Cluster Analysis,' F /6X,'Wiley, New York.'//) 9510 FORMAT(/1X,'DO YOU WANT TO ENTER MEASUREMENTS? (PLEASE' F' ANSWER M)'/1X,'OR DO YOU PREFER TO GIVE' F' DISSIMILARITIES? (THEN ANSWER D): '$) 9520 FORMAT(1X,'NOT ALLOWED! PLEASE ENTER YOUR CHOICE AGAIN: '$) 9525 FORMAT(//1X,'THE PRESENT VERSION OF THE PROGRAM CAN HANDLE' F ' UP TO',I6,' OBJECTS.'/1X,'(IF MORE ARE TO BE CLUSTERED,' F ' THE ARRAYS INSIDE THE PROGRAM MUST BE ADAPTED)') 9530 FORMAT(/1X,'HOW MANY OBJECTS ARE TO BE CLUSTERED? '/1X, F37(1H-)/1X,'PLEASE GIVE A NUMBER BETWEEN 3 AND ',I6,' : '$) 9540 FORMAT(/' AT LEAST 3 OBJECTS ARE NEEDED FOR CLUSTER ANALYSIS.' F','/1X,' PLEASE FORESEE MORE OBJECTS.') 9620 FORMAT(//1X,'THE PRESENT VERSION OF THE PROGRAM ALLOWS TO' F ' ENTER UP TO',I5,' VARIABLES,'/1X,'OF WHICH AT MOST',I5, F ' CAN BE USED IN THE ACTUAL COMPUTATIONS.'/1X,'(IF MORE ARE' F ' NEEDED, THE ARRAYS INSIDE THE PROGRAM MUST BE ADAPTED)') 9630 FORMAT(/1X,'WHAT IS THE TOTAL NUMBER OF VARIABLES IN YOUR' F' DATA SET ?'/1X,56(1H-)/ F' PLEASE GIVE A NUMBER BETWEEN 1 AND ',I6,' : '$) 9640 FORMAT(/38H HOW MANY VARIABLES DO YOU WANT TO USE, F' IN THE ANALYSIS?'/1X,54('-')/1X,' (AT MOST ',I4,' ) : '$) 9650 FORMAT(//1X,'VARIABLE TO BE USED ', F' LABEL (AT MOST 10 CHARACTERS)'/ F 1X,17(1H-),4(1H),6(1H-),10(1H),19(1H-)) 9660 FORMAT(1X,'NUMBER : ',I4,6X$) 9670 FORMAT(//1X,'VARIABLE TO BE USED : POSITION', F ' LABEL (AT MOST 10 CHARACTERS)'/ F 1X,32('-'),4(1H),6('-'),10(1H),19('-')) 9680 FORMAT(1X,'NUMBER ',I4,15X,': '$) 9690 FORMAT(/' THIS POSITION HAS ALREADY BEEN CHOSEN FOR ANOTHER', F' VARIABLE.'/1X,'ENTER THE RIGHT POSITION PLEASE: ') 9700 FORMAT(/' DO YOU WANT THE MEASUREMENTS TO BE STANDARDIZED?' F ' (YES OR NO)......:'$) 9710 FORMAT(/1X,'DO YOU WANT TO USE EUCLIDEAN DISTANCE? (PLEASE' F' ANSWER E)'/1X,'OR DO YOU PREFER MANHATTAN DISTANCE?' F' (THEN ANSWER M) ..............: '$) 9720 FORMAT(/1X,'PLEASE ENTER A TITLE FOR THE OUTPUT (AT MOST 60' F ' CHARACTERS)'/1X,59(1H-)/1X$) 9730 FORMAT(/1X,'DO YOU WANT LARGE OUTPUT? (PLEASE ANSWER YES)'/ F' OR IS SMALL OUTPUT SUFFICIENT? (THEN ANSWER NO)') 9732 FORMAT(' (IN THE LATTER CASE NO STANDARDIZED MEASUREMENTS OR' F/1X,' DISSIMILARITIES ARE GIVEN)',1X,40('.'),' : '$) 9734 FORMAT(1X,'(IN THE LATTER CASE NO DISSIMILARITIES ARE GIVEN)' F,1X,18('.'),' : '$) 9740 FORMAT(/1X,'DO YOU WANT GRAPHICAL OUTPUT (BANNER)?' F' PLEASE ANSWER YES OR NO ....: '$) 9750 FORMAT(/1X,'DO YOU WANT TO ENTER LABELS OF OBJECTS?' F' PLEASE ANSWER YES OR NO ....: '$) 9760 FORMAT(/1X,'EACH LABEL MAY CONSIST OF AT MOST 3 CHARACTERS'/ F/1X,' OBJECT LABEL'/ F 1X,12(1H-),4(1H),6(1H-),3(1H),5(1H-)) 9770 FORMAT(1X,'NUMBER ',4X,I4,' : '$) 9780 FORMAT(/' DO YOU WANT TO READ THE DATA IN FREE FORMAT ?'/1X, F 45(1H-)/' THIS MEANS THAT YOU ONLY HAVE TO INSERT BLANK(S)', F 17H BETWEEN NUMBERS./31H (NOTE: WE ADVISE USERS WITHOUT, F 45H KNOWLEDGE OF FORTRAN FORMATS TO ANSWER YES.)/ F ' MAKE YOUR CHOICE (YES/NO): '$) 9790 FORMAT(/1X,'YOUR DESIRED FORTRAN FORMAT IS:'/ F1X'(BETWEEN BRACKETS AND', F ' AT MOST 60 CHARACTERS, e.g. (2F3.0,F1.0) )') 9800 FORMAT(/1X,'PLEASE GIVE THE NAME OF THE FILE CONTAINING', F' THE DATA (e.g. TYPE A:EXAMPLE.DAT)',/1X,'OR TYPE', F' KEY IF YOU PREFER TO ENTER THE DATA BY KEYBOARD.'/ F1X,'WHAT DO YOU CHOOSE? '$) 9810 FORMAT(/1X,'DO YOU WANT TO SAVE YOUR DATA IN A FILE?'/ F 1X,'PLEASE ANSWER YES OR NO: ',$) 9820 FORMAT(/1X,'IN WHICH FILE DO YOU WANT TO SAVE YOUR DATA?'/ 1 ' (WARNING: IF THERE ALREADY EXISTS A FILE WITH THE SAME', 1 ' NAME'/12X,'THEN THE OLD FILE WILL BE OVERWRITTEN.)'/ 1 ' TYPE e.g. B:SAVE.DAT .....................: '$) 9830 FORMAT(/1X,'WHERE DO YOU WANT YOUR OUTPUT?'/1X,30('-')/ 1 ' TYPE CON IF YOU WANT IT ON THE SCREEN'/ 1 ' OR TYPE PRN IF YOU WANT IT ON THE PRINTER'/ 1 ' OR TYPE THE NAME OF A FILE (e.g. B:EXAMPLE.OUT)'/ 1 ' (WARNING: IF THERE ALREADY EXISTS A FILE WITH THE SAME', 1 ' NAME'/12X,'THEN THE OLD FILE WILL BE OVERWRITTEN.)'/ 1 ' WHAT DO YOU CHOOSE? ......................: '$) 9831 FORMAT(/' FILE NAME IS INCORRECT, PLEASE ENTER ANOTHER') 9832 FORMAT(/' THIS FILE WAS NOT FOUND, PLEASE ENTER ANOTHER ONE') 9834 FORMAT(/' FORTRAN ERROR CODE: ',I8) 9840 FORMAT(/1X,'CAN MISSING DATA OCCUR IN THE MEASUREMENTS?' F/1X,'PLEASE ANSWER YES OR NO: '$) 9850 FORMAT(/' IS THERE A UNIQUE VALUE WHICH IS TO BE INTERPRETED'/ F1X,'AS A MISSING MEASUREMENT VALUE FOR ANY VARIABLE? '/ F1X,'PLEASE ANSWER YES OR NO: '$) 9860 FORMAT(/' PLEASE ENTER THIS VALUE NOW: '$) 9870 FORMAT(/' SHOULD MISSING VALUES BE FORESEEN FOR VARIABLE ', F 10A1,' ?'/' PLEASE ANSWER YES OR NO: '$) 9880 FORMAT(' ENTER THE VALUE OF THIS VARIABLE WHICH HAS TO BE' F' INTERPRETED AS'/' THE MISSING VALUE CODE: '$) 9890 FORMAT(//////////) 9900 FORMAT(/' DATA SPECIFICATIONS AND CHOSEN OPTIONS'/1X,38('-')) 9905 FORMAT(1X,' TITLE: ',A60) 9906 FORMAT(1X,'TITLE: ',A60) 9910 FORMAT(1X,' THERE ARE ',I4,' OBJECTS') RETURN END CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCCC file MONA.FOR (Chapter 7) 29k CCCCCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC PROGRAM MONA CC CC MONOTHETIC ANALYSIS CC CC PROGRAM FOR DIVISIVE HIERARCHICAL CLUSTERING OF BINARY DATA, CC USING ASSOCIATION ANALYSIS. CC CC LIST OF FUNCTIONS AND SUBROUTINES: CC FUNCTION KAB CC SUBROUTINE BANMT CC SUBROUTINE FRAME CC SUBROUTINE ENTR CC SUBROUTINE QYN CC SUBROUTINE NWLAB CC SUBROUTINE DATMT CC CC THE FOLLOWING VECTORS AND MATRICES MUST BE DIMENSIONED IN THE CC MAIN PROGRAM: CC NBAN(MAXNN),NER(MAXNN),KWAN(MAXNN),LAVA(MAXNN) CC KX(MAXNN,MAXPP),LABNN(3,MAXNN),LABPP(3,MAXPP) CC HULP(MAXTT),JPLACE(MAXPP),JLACK(MAXPP) CC NUM(13),VUL(30) CC WHERE: CC MAXNN = MAXIMAL NUMBER OF OBJECTS CC MAXTT = MAXIMAL NUMBER OF VARIABLES IN DATA SET CC MAXPP = MAXIMAL NUMBER OF VARIABLES USED IN THE ANALYSIS CC DIMENSION NBAN(200),NER(200),KWAN(200),LAVA(200) DIMENSION JPLACE(100),JLACK(100),HULP(300) CHARACTER KX(200,100),LABNN(3,200),LABPP(3,100),NUM(13) CHARACTER VUL(30),YNSAVE,NZF CHARACTER*30 FNAMEA,FNAMEB,FNAMEC CHARACTER*60 NAME,JFMT MAXNN=200 MAXTT=200 MAXPP=100 CC CC LOGICAL INPUT AND OUTPUT UNITS : CC LUA = LOGICAL UNIT A (INPUT) CC LUB = LOGICAL UNIT B (OUTPUT) CC LUC = LOGICAL UNIT C (OUTPUT OF DATA MATRIX) CC THE USER SHOULD ASSIGN TO LUA, LUB AND LUC THE NUMBERS USED BY CC HIS OWN COMPUTER: ONLY THE NEXT 3 STATEMENTS MUST BE CHANGED: CC LUA=1 LUB=2 LUC=3 CC CC The real variables ABSL, ABSH, PRSL, and PRSH define CC the assignment of values '0' and '1' to the measurement CC variables : CC a. if ABSL <= measurement <= ABSH then measur. = '0' CC b. if PRSL <= measurement <= PRSH then measur. = '1' CC All other values will be treated as missing. CC The user can adapt these values by changing the following CC four statements. CC If he wants to use character variables he must change CC array HULP to CHARACTER and adapt the statements in which CC the measurement matrix is filled (see subroutine ENTR). CC ABSL=-0.001 ABSH=0.001 PRSL=0.999 PRSH=1.001 CC CALL ENTR(NN,JPP,MAXNN,MAXTT,MAXPP,KX,JPLACE,HULP, F LUA,LUB,LUC,FNAMEA,FNAMEB,FNAMEC,LABNN,LABPP,NAME,NUM, F YNSAVE,LARGE,LGRAP,NFF,JFMT,ABSL,ABSH,PRSL,PRSH) IF(LARGE.EQ.0)GO TO 50 WRITE(LUB,9000) CALL DATMT(NN,JPP,MAXNN,MAXPP,LUB,LABNN,LABPP,KX) 50 LACK=0 JHALT=0 NNHAL=(NN+1)/2 JPTWE=(JPP+4)/5 MYST=0 DO 70 L=1,NN MYSCA=0 DO 60 J=1,JPP IF(KX(L,J).EQ.'0')GO TO 60 IF(KX(L,J).EQ.'1')GO TO 60 MYSCA=MYSCA+1 60 CONTINUE MYST=MYST+MYSCA IF(MYSCA.NE.JPP)GO TO 70 JHALT=1 WRITE(LUB,9010)LABNN(1,L),LABNN(2,L),LABNN(3,L) 70 CONTINUE IF(JHALT.EQ.1)STOP IF(MYST.EQ.0)WRITE(LUB,9065) IF(MYST.EQ.0)GO TO 290 DO 100 J=1,JPP JNUL=0 JEEN=0 DO 80 L=1,NN IF(KX(L,J).EQ.'0')JNUL=JNUL+1 IF(KX(L,J).EQ.'1')JEEN=JEEN+1 80 CONTINUE JLACK(J)=NN-JNUL-JEEN IF(JLACK(J).NE.0)LACK=LACK+1 IF(JLACK(J).LT.NNHAL)GO TO 90 WRITE(LUB,9020)LABPP(1,J),LABPP(2,J),LABPP(3,J),JLACK(J) JHALT=1 90 IF(JNUL.EQ.0)GO TO 95 IF(JEEN.EQ.0)GO TO 95 GO TO 100 95 WRITE(LUB,9030)LABPP(1,J),LABPP(2,J),LABPP(3,J) WRITE(LUB,9040) JHALT=1 100 CONTINUE IF(JHALT.EQ.0)GO TO 110 WRITE(LUB,9055) IF(NFF.EQ.0)WRITE(LUB,9050) STOP 110 JPRES=JPP-LACK IF(JPRES.NE.0)GO TO 120 WRITE(LUB,9060) STOP 120 IF(LACK.EQ.1)WRITE(LUB,9070) IF(LACK.LE.1)GO TO 200 WRITE(LUB,9075)LACK IF(JPRES.GE.JPTWE)GO TO 200 WRITE(LUB,9080) CC CC FILLING IN MISSING VALUES CC 200 DO 260 J=1,JPP IF(JLACK(J).EQ.0)GO TO 260 IF(JLACK(J).EQ.1)WRITE(LUB,9082)LABPP(1,J),LABPP(2,J), F LABPP(3,J) IF(JLACK(J).GT.1)WRITE(LUB,9084)LABPP(1,J),LABPP(2,J), F LABPP(3,J),JLACK(J) LAMA=-1 NSYN=1 DO 240 JA=1,JPP IF(JLACK(JA).NE.0)GO TO 240 JVA=0 JVB=0 JVC=0 JVD=0 DO 230 K=1,NN IF(KX(K,J).EQ.'1')GO TO 220 IF(KX(K,JA).EQ.'0')JVA=JVA+1 IF(KX(K,JA).EQ.'1')JVB=JVB+1 GO TO 230 220 IF(KX(K,JA).EQ.'0')JVC=JVC+1 IF(KX(K,JA).EQ.'1')JVD=JVD+1 230 CONTINUE KAL=JVA*JVD-JVB*JVC KALF=KAB(KAL) IF(KALF.LT.LAMA)GO TO 240 LAMA=KALF JMA=JA IF(KAL.LT.0)NSYN=-1 240 CONTINUE DO 250 L=1,NN IF(KX(L,J).EQ.'0')GO TO 250 IF(KX(L,J).EQ.'1')GO TO 250 IF(NSYN.EQ.1)THEN KX(L,J)=KX(L,JMA) ELSE IF(KX(L,JMA).EQ.'1')KX(L,J)='0' IF(KX(L,JMA).EQ.'0')KX(L,J)='1' ENDIF 250 CONTINUE 260 CONTINUE IF(MYST.EQ.1)WRITE(LUB,9086) IF(MYST.GT.1)WRITE(LUB,9088)MYST IF(LARGE.EQ.0)GO TO 290 WRITE(LUB,9170) CALL DATMT(NN,JPP,MAXNN,MAXPP,LUB,LABNN,LABPP,KX) CC CC INITIALIZATION CC 290 DO 300 K=1,NN KWAN(K)=0 NER(K)=K LAVA(K)=0 300 CONTINUE NPASS=1 KWAN(1)=NN CC CC ALGORITHM CC NCLU=1 KA=1 305 IF(LARGE.EQ.0)GO TO 310 WRITE(LUB,9090)NPASS 310 KB=KA+KWAN(KA)-1 LAMA=-1 JNAT=JPP DO 370 J=1,JPP IF(NCLU.EQ.1)GO TO 330 JNUL=0 JEEN=0 DO 325 L=KA,KB NEL=NER(L) IF(KX(NEL,J).EQ.'0')JNUL=JNUL+1 IF(KX(NEL,J).EQ.'1')JEEN=JEEN+1 325 CONTINUE IF(JEEN.EQ.0)GO TO 370 IF(JNUL.EQ.0)GO TO 370 330 JNAT=JNAT-1 LAMS=0 DO 360 JB=1,JPP IF(JB.EQ.J)GO TO 360 KVA=0 KVB=0 KVC=0 KVD=0 DO 350 L=KA,KB NEL=NER(L) IF(KX(NEL,J).EQ.'1')GO TO 340 IF(KX(NEL,JB).EQ.'0')KVA=KVA+1 IF(KX(NEL,JB).EQ.'1')KVB=KVB+1 GO TO 350 340 IF(KX(NEL,JB).EQ.'0')KVC=KVC+1 IF(KX(NEL,JB).EQ.'1')KVD=KVD+1 350 CONTINUE LAMS=LAMS+KAB(KVA*KVD-KVB*KVC) 360 CONTINUE IF(LAMS.LE.LAMA)GO TO 370 JTEL=KVC+KVD JTELZ=KVA+KVB LAMA=LAMS JMA=J 370 CONTINUE IF(JNAT.LT.JPP)GO TO 375 IF(LARGE.EQ.0)GO TO 373 WRITE(LUB,9095)((LABNN(KL,NER(K)),KL=1,3),K=KA,KB) WRITE(LUB,9150) 373 KWAN(KA)=-KWAN(KA) GO TO 400 CC CC SPLITTING CC 375 NEL=NER(KA) IF(KX(NEL,JMA).EQ.'1')THEN NZF='0' JTEL2=JTEL ELSE NZF='1' JTEL2=JTELZ ENDIF JRES=KB-KA+1-JTEL2 KM=KA+JTEL2 L=KA 378 NEL=NER(L) IF(KX(NEL,JMA).EQ.NZF)GO TO 380 L=L+1 IF(L.LT.KM)GO TO 378 GO TO 390 380 DO 381 LBB=L,KB NELBB=NER(LBB) IF(KX(NELBB,JMA).EQ.NZF)GO TO 381 LCC=LBB-1 GO TO 382 381 CONTINUE 382 DO 383 LAA=L,LCC LDD=LCC+L-LAA LEE=LDD+1 NER(LEE)=NER(LDD) 383 CONTINUE NER(L)=NELBB GO TO 378 390 NCLU=NCLU+1 IF(LARGE.EQ.0)GO TO 395 WRITE(LUB,9095)((LABNN(KL,NER(K)),KL=1,3),K=KA,KB) WRITE(LUB,9098)JTEL2,JRES,LABPP(1,JMA),LABPP(2,JMA), F LABPP(3,JMA) 395 NBAN(KM)=NPASS KWAN(KA)=JTEL2 KWAN(KM)=JRES LAVA(KM)=JMA KA=KA+KWAN(KA) 400 IF(KB.EQ.NN)GO TO 500 410 KA=KA+KAB(KWAN(KA)) IF(KA.GT.NN)GO TO 500 IF(KWAN(KA).LT.2)GO TO 410 GO TO 310 500 NPASS=NPASS+1 DO 510 KA=1,NN IF(KWAN(KA).GE.2)GO TO 305 510 CONTINUE WRITE(LUB,9180) WRITE(LUB,9110) WRITE(LUB,9100)((LABNN(KL,NER(L)),KL=1,3),L=1,NN) WRITE(LUB,9120) WRITE(LUB,9140)(NBAN(L),L=2,NN) WRITE(LUB,9130) NST=0 NNA=2 520 NNB=NNA+9 IF(NNB.LT.NN)GO TO 530 NNB=NN NST=1 530 NK=0 DO 560 LA=NNA,NNB IF(LAVA(LA).EQ.0)THEN DO 540 LB=1,3 NK=NK+1 VUL(NK)=' ' 540 CONTINUE ELSE DO 550 LB=1,3 NK=NK+1 VUL(NK)=LABPP(LB,LAVA(LA)) 550 CONTINUE ENDIF 560 CONTINUE WRITE(LUB,9160)(VUL(NT),NT=1,NK) NNA=NNB+1 IF(NST.EQ.0)GO TO 520 IF(LGRAP.EQ.0)GO TO 600 CALL BANMT(NN,NBAN,NER,LAVA,LABNN,LABPP,NUM,LUB,MAXNN, F MAXPP) 600 WRITE(*,9200) IF(YNSAVE.EQ.'Y'.AND.FNAMEB.EQ.'CON')WRITE(*,9210)FNAMEC IF(FNAMEB.NE.'PRN'.AND.FNAMEB.NE.'CON')WRITE(LUB,9220)FNAMEB IF(FNAMEB.NE.'PRN'.AND.FNAMEB.NE.'CON')WRITE(*,9220)FNAMEB IF(FNAMEB.EQ.'PRN')WRITE(*,9230) 9000 FORMAT(/' INPUT DATA'/1X,10(1H*)/) 9010 FORMAT(' PLEASE DELETE OBJECT ',3A1, F ' , ALL ITS VALUES ARE MISSING.') 9020 FORMAT(' VARIABLE ',3A1,' HAS',I3,' MISSING VALUES, WHICH', F' IS AT LEAST 50 PERCENT'/' OF THE NUMBER OF OBJECTS.') 9030 FORMAT(' ALL NONMISSING VALUES OF VARIABLE ',3A1, F ' ARE IDENTICAL.') 9040 FORMAT(' THIS VARIABLE SHOULD BE REMOVED', F ' BEFORE RESTARTING THE PROGRAM.') 9050 FORMAT(/' (THIS CAN BE DONE BY CHANGING THE NUMBER OF' F ' VARIABLES AND THE INPUT FORMAT.)'/) 9055 FORMAT(/' IN ORDER TO USE THIS PROGRAM SOME OBJECTS', F ' OR VARIABLES SHOULD BE REMOVED.') 9060 FORMAT(/' ALL VARIABLES HAVE MISSING VALUES, THE ALGORITHM' F' CANNOT BE CARRIED OUT.'/' PLEASE SELECT AN IMPORTANT' F' VARIABLE WITH RELATIVELY FEW MISSING VALUES'/' AND' F' REMOVE ALL OBJECTS FOR WHICH THIS VARIABLE WAS NOT GIVEN.') 9065 FORMAT(/' THERE ARE NO MISSING VALUES') 9070 FORMAT(//' ONE VARIABLE HAS MISSING VALUES'/) 9075 FORMAT(//1X,I5,' VARIABLES HAVE MISSING VALUES'/) 9080 FORMAT(' FEWER THAN 20 PERCENT OF THE VARIABLES ARE WITHOUT' F' MISSING'/' VALUES. THE ALGORITHM WILL BE CARRIED OUT' F' BECAUSE'/' THERE IS AT LEAST ONE VARIABLE WITHOUT MISSING' F' VALUES.'/' IT WOULD BE PREFERABLE TO DROP SOME VARIABLES' F' OR OBJECTS.'//) 9082 FORMAT(' VARIABLE ',3A1,' HAS ONE MISSING VALUE') 9084 FORMAT(' VARIABLE ',3A1,' HAS ',I5,' MISSING VALUES') 9086 FORMAT(/' ONE MISSING VALUE HAS BEEN ESTIMATED') 9088 FORMAT(/1X,I5,' MISSING VALUES HAVE BEEN ESTIMATED'/) 9090 FORMAT(//' STEP NUMBER ',I5/2X,17(1H*)) 9095 FORMAT(//' THE CLUSTER ',15(1X,3A1),100(/15X,15(1X,3A1))) 9098 FORMAT(' IS DIVIDED INTO ',I5,' AND ',I5, F ' OBJECTS, USING VARIABLE ',4X,3A1) 9100 FORMAT(100(5X,10(4X,3A1),/)) 9110 FORMAT(/' THE FINAL ORDERING OF THE OBJECTS IS'/) 9120 FORMAT(/' THE SEPARATION STEP IS'/) 9130 FORMAT(/' THE VARIABLE USED IS'/) 9140 FORMAT(8X,10I7) 9150 FORMAT(' CANNOT BE SEPARATED BY THE REMAINING VARIABLES') 9160 FORMAT(8X,10(4X,3A1)) 9170 FORMAT(/' REVISED DATA'/1X,12(1H*)/) 9180 FORMAT(//' FINAL RESULTS'/1X,13(1H*)) 9200 FORMAT(/' This run was successfully completed') 9210 FORMAT(/' Your data is in file : ',A30) 9220 FORMAT(/' The output is in file : ',A30) 9230 FORMAT(/' The output was sent to the printer') END CC CC FUNCTION KAB(J) KAB=J IF(J.LT.0)KAB=-J RETURN END CC CC SUBROUTINE QYN(YN,NYN) CHARACTER YN 10 READ(*,8000)YN IF(YN.EQ.'y')YN='Y' IF(YN.EQ.'n')YN='N' IF(YN.EQ.'Y')NYN=1 IF(YN.EQ.'N')NYN=0 IF(YN.EQ.'Y'.OR.YN.EQ.'N')GO TO 20 WRITE(*,9000) GO TO 10 20 RETURN 8000 FORMAT(A1) 9000 FORMAT(' NOT ALLOWED! PLEASE ENTER YOUR CHOICE AGAIN: '$) END CC CC SUBROUTINE NWLAB(MAXJJ,JJ,NUM,LAB) CHARACTER LAB(3,MAXJJ),NUM(13) LLA=1 LLB=1 LLC=1 DO 30 K=1,JJ IF(LLC.LT.10)GOTO 20 LLC=0 IF(LLB.LT.10)GOTO 10 LLB=0 LLA=LLA+1 10 LLB=LLB+1 20 LLC=LLC+1 LAB(1,K)=NUM(LLA) LAB(2,K)=NUM(LLB) LAB(3,K)=NUM(LLC) 30 CONTINUE RETURN END CC CC SUBROUTINE DATMT(NN,JPP,MAXNN,MAXPP,LUB,LABNN,LABPP,KX) CHARACTER KX(MAXNN,MAXPP),LABNN(3,MAXNN),LABPP(3,MAXPP) JPPA=JPP NDXB=0 10 NFN=0 JPL=30 IF(JPPA.LE.30)NFN=1 IF(JPPA.LE.30)JPL=JPPA NDXA=NDXB+1 NDXB=NDXA+JPL-1 WRITE(LUB,9000)(LABPP(1,J),J=NDXA,NDXB) WRITE(LUB,9010)(LABPP(2,J),J=NDXA,NDXB) WRITE(LUB,9010)(LABPP(3,J),J=NDXA,NDXB) JPPA=JPPA-30 DO 20 L=1,NN IF(L.EQ.1)WRITE(LUB,9010) WRITE(LUB,9020)(LABNN(KK,L),KK=1,3),(KX(L,J),J=NDXA,NDXB) 20 CONTINUE IF(NFN.EQ.0)GO TO 10 9000 FORMAT(/7X,30(A1,1X)) 9010 FORMAT(7X,30(A1,1X)) 9020 FORMAT(1X,3A1,2X,30(1X,A1)) RETURN END CC CC SUBROUTINE BANMT(NN,NBAN,NER,LAVA,LABNN,LABPP,NUM,LUB, F MAXNN,MAXPP) DIMENSION NBAN(MAXNN),NER(MAXNN),LAVA(MAXNN) CHARACTER*1 LABNN(3,MAXNN),LABPP(3,MAXPP) CHARACTER JDRAW(72),LABFF(3,69),NUM(13) WRITE(LUB,9200) MAKS=0 DO 70 KK=2,NN IF(NBAN(KK).GT.MAKS)MAKS=NBAN(KK) 70 CONTINUE MWDTH=69 CALL NWLAB(MWDTH,MAKS,NUM,LABFF) CALL FRAME(MAKS,LABFF,LUB) DO 80 KK=1,NN NCASE=NER(KK) DO 81 L=1,18 LALFA=(L-1)*4+1 LBETA=(L-1)*4+2 LGAMA=(L-1)*4+3 LDELT=L*4 JDRAW(LALFA)=LABNN(1,NCASE) JDRAW(LBETA)=LABNN(2,NCASE) JDRAW(LGAMA)=LABNN(3,NCASE) JDRAW(LDELT)=NUM(13) 81 CONTINUE KLEFT=KK IF(KK.EQ.1)KLEFT=2 60 IF(NBAN(KLEFT).NE.0)GOTO 61 IF(KLEFT.EQ.2)GOTO 61 KLEFT=KLEFT-1 GOTO 60 61 NBBEF=NBAN(KLEFT) KRYGT=KK+1 IF(KK.EQ.NN)KRYGT=NN 65 IF(NBAN(KRYGT).NE.0)GOTO 66 IF(KRYGT.EQ.NN)GOTO 66 KRYGT=KRYGT+1 GOTO 65 66 NBMAX=NBAN(KRYGT) IF(NBMAX.LT.NBBEF)NBMAX=NBBEF LENGT=(NBMAX*69)/MAKS+3 WRITE(LUB,9210)(JDRAW(J),J=1,LENGT) IF(KK.EQ.NN)GOTO 90 KAFTE=KK+1 NBNEX=NBAN(KAFTE) IF(NBNEX.EQ.0)GOTO 80 LENGT=(NBNEX*69)/MAKS+3 DO 82 L=1,LENGT JDRAW(L)=NUM(12) 82 CONTINUE LV=LAVA(KAFTE) WRITE(LUB,9220)LABPP(1,LV),LABPP(2,LV),LABPP(3,LV), F (JDRAW(J),J=1,LENGT) 80 CONTINUE 90 CALL FRAME(MAKS,LABFF,LUB) RETURN 9200 FORMAT(///34X,12(1H*)/34X,1H*,10X,1H*/34X,9H* BANNER, F 2X,1H*/34X,1H*,10X,1H*/34X,12(1H*)//) 9210 FORMAT(6X,72A1) 9220 FORMAT(2X,3A1,1X,72A1) END CC CC SUBROUTINE FRAME(MAKS,LABFF,LUB) CHARACTER LABFF(3,69),LAT(2,69) IF(MAKS.GT.68)RETURN DO 10 K=1,69 LAT(1,K)=' ' LAT(2,K)=' ' 10 CONTINUE DO 20 J=1,MAKS L=(J*69)/MAKS LAT(1,L)=LABFF(2,J) LAT(2,L)=LABFF(3,J) 20 CONTINUE IF(MAKS.GT.9)GOTO 30 WRITE(LUB,9300)(LAT(2,K),K=1,69) RETURN 30 WRITE(LUB,9310)(LAT(1,K),K=1,69) WRITE(LUB,9320)(LAT(2,K),K=1,69) RETURN 9300 FORMAT(//8X,1H0,69A1//) 9310 FORMAT(//8X,1H0,69A1) 9320 FORMAT(8X,1H0,69A1//) END CC CC SUBROUTINE ENTR(NN,JPP,MAXNN,MAXTT,MAXPP,KX,JPLACE,HULP, F LUA,LUB,LUC,FNAMEA,FNAMEB,FNAMEC,LABNN,LABPP,NAME,NUM, F YNSAVE,LARGE,LGRAP,NFF,JFMT,ABSL,ABSH,PRSL,PRSH) DIMENSION JPLACE(MAXPP),HULP(MAXTT) CHARACTER CYNFF,YNSAVE,CARGE,CGRAP,CLABN,CLABP,CEX CHARACTER LABNN(3,MAXNN),LABPP(3,MAXPP),KX(MAXNN,MAXPP) CHARACTER NUM(13) CHARACTER*30 FNAMEA,FNAMEB,FNAMEC CHARACTER*60 JFMT,NAME NUM(1)='0' NUM(2)='1' NUM(3)='2' NUM(4)='3' NUM(5)='4' NUM(6)='5' NUM(7)='6' NUM(8)='7' NUM(9)='8' NUM(10)='9' NUM(11)=' ' NUM(12)='*' NUM(13)='+' WRITE(*,9500) WRITE(*,9505) WRITE(*,9510) 100 WRITE (*,9525)MAXNN 130 WRITE (*,9530)MAXNN READ (*,*) NN IF(NN.LE.MAXNN) GOTO 140 WRITE(*,9520) GOTO 130 140 IF(NN.GE.3)GO TO 150 WRITE(*,9540) GOTO 130 150 WRITE(*,9750) CALL QYN(CLABN,JLABN) IF(CLABN.EQ.'N')GO TO 170 WRITE(*,9760) DO 160 J=1,NN WRITE(*,9770)J READ(*,8500)LABNN(1,J),LABNN(2,J),LABNN(3,J) 160 CONTINUE GO TO 200 170 CALL NWLAB(MAXNN,NN,NUM,LABNN) CC CC IN THIS SECTION SPECIFIC INFORMATION RELATED TO THE INPUT CC OF MEASUREMENTS IS ENTERED : CC TOTAL NUMBER OF VARIABLES (JPPT) CC NUMBER OF VARIABLES TO BE USED IN THE ANALYSIS (JPP) CC VARIABLES TO BE USED IN THE ANALYSIS, AND THEIR LABELS. CC 200 WRITE(*,9620)MAXTT,MAXPP WRITE(*,9625) 300 WRITE(*,9630)MAXTT READ(*,*)JPPT IF(JPPT.NE.3)GO TO 310 JPP=3 GO TO 340 310 IF(JPPT.GE.3.AND.JPPT.LE.MAXTT)GO TO 320 WRITE(*,9520) GO TO 300 320 JPPA=MAXPP IF(JPPA.GT.JPPT)JPPA=JPPT 330 WRITE(*,9640)JPPA READ(*,*)JPP IF(JPP.GE.3.AND.JPP.LE.JPPA)GO TO 340 WRITE(*,9520) GO TO 330 340 WRITE(*,9645) CALL QYN(CLABP,JLABP) IF(JPPT.GT.JPP)GO TO 370 350 IF(CLABP.EQ.'Y')WRITE(*,9650) DO 360 J=1,JPP JPLACE(J)=J IF(CLABP.EQ.'N')GO TO 360 WRITE(*,9660)J READ(*,8500)(LABPP(K,J),K=1,3) 360 CONTINUE GO TO 410 370 IF(CLABP.EQ.'Y')WRITE(*,9670) IF(CLABP.EQ.'N')WRITE(*,9675) DO 400 J=1,JPP 380 WRITE(*,9680)J IF(CLABP.EQ.'Y')READ(*,8520)JPLACE(J),(LABPP(K,J),K=1,3) IF(CLABP.EQ.'N')READ(*,8520)JPLACE(J) IF(JPLACE(J).LT.1.OR.JPLACE(J).GT.JPPT)GO TO 380 IF(J.EQ.1)GO TO 400 JPPL=J-1 DO 390 JK=1,JPPL IF(JPLACE(JK).NE.JPLACE(J))GO TO 390 WRITE(*,9690) GO TO 380 390 CONTINUE 400 CONTINUE 410 IF(CLABP.EQ.'N')CALL NWLAB(MAXPP,JPP,NUM,LABPP) CC CC OUTPUT SECTION : CC TITLE CC SMALL OR LARGE OUTPUT CC GRAPHICAL OUTPUT (BANNER) CC LABELS OF OBJECTS CC WRITE (*,9720) READ (*,8530)NAME WRITE(*,9730) CALL QYN(CARGE,LARGE) WRITE(*,9740) CALL QYN(CGRAP,LGRAP) CC CC FORMATS CC WRITE (*,9780) CALL QYN(CYNFF,NFF) IF (CYNFF.EQ.'Y') GOTO 600 WRITE(*,9790) READ (*,8530)JFMT CC CC STATUS OF INPUT AND OUTPUT: KEYBOARD, SCREEN, PRINTER, FILES. CC 600 WRITE(*,9800) READ(*,8550)FNAMEA IF(FNAMEA.EQ.'KEY'.OR.FNAMEA.EQ.'key'.OR.FNAMEA.EQ.'Key') F GO TO 610 YNSAVE='N' NSAVE=0 GO TO 620 610 FNAMEA='CON' WRITE(*,9810) CALL QYN(YNSAVE,NSAVE) IF (YNSAVE.EQ.'N')GO TO 620 612 WRITE(*,9820) READ(*,8550)FNAMEC OPEN(LUC,FILE=FNAMEC,STATUS='NEW',IOSTAT=NEG,ERR=614) GO TO 620 614 IF(NEG.NE.1027.AND.NEG.NE.1030.AND.NEG.NE.1032.AND.NEG.NE. F 1033.AND.NEG.NE.1045)GO TO 616 WRITE(*,9832) GO TO 612 616 WRITE(*,9834)NEG STOP 620 OPEN(LUA,FILE=FNAMEA,IOSTAT=NEF,ERR=630) GOTO 640 630 IF(FNAMEA.NE.'CON'.AND.(NEF.EQ.1027.OR.NEF.EQ.1030. F OR.NEF.EQ.1032.OR.NEF.EQ.1033))THEN WRITE(*,9836) GOTO 600 ENDIF WRITE(*,9834)NEF STOP 640 WRITE(*,9830) READ(*,8550)FNAMEB IF(FNAMEB.EQ.'con'.OR.FNAMEB.EQ.'Con')FNAMEB='CON' IF(FNAMEB.EQ.'prn'.OR.FNAMEB.EQ.'Prn')FNAMEB='PRN' IF (FNAMEB.EQ.'CON'.OR.FNAMEB.EQ.'PRN')OPEN(LUB,FILE=FNAMEB) IF (.NOT.(FNAMEB.EQ.'CON'.OR.FNAMEB.EQ.'PRN'))OPEN(LUB, F FILE=FNAMEB,STATUS='NEW',IOSTAT=NET,ERR=680) GO TO 700 680 IF(NET.NE.1027.AND.NET.NE.1030.AND.NET.NE.1032.AND.NET.NE. F 1033.AND.NET.NE.1045)GO TO 690 WRITE(*,9832) GO TO 640 690 WRITE(*,9834)NET STOP CC CC RECAPITULATION OF OPTIONS. CC 700 WRITE(*,9900) WRITE(*,9910) WRITE(*,9920)NAME WRITE(*,9930)NN IF(CLABN.EQ.'Y')WRITE(*,8070) IF(CLABN.EQ.'N')WRITE(*,8075) IF(CARGE.EQ.'Y')WRITE(*,8090) IF(CARGE.EQ.'N')WRITE(*,8095) IF(CGRAP.EQ.'Y')WRITE(*,8100) IF(CGRAP.EQ.'N')WRITE(*,8105) WRITE(*,8115)JPPT IF(JPPT.GT.JPP)WRITE(*,8116)JPP IF(JPPT.EQ.JPP)WRITE(*,8113) IF(CLABP.EQ.'Y')WRITE(*,8080) IF(CLABP.EQ.'N')WRITE(*,8085) IF (CYNFF.EQ.'Y') WRITE(*,8160) IF (CYNFF.EQ.'N') WRITE(*,8165) JFMT IF (FNAMEA.NE.'CON') WRITE(*,8039) FNAMEA IF (FNAMEA.EQ.'CON') WRITE(*,8034) IF (YNSAVE.EQ.'Y') WRITE(*,8038) FNAMEC WRITE(*,8040) FNAMEB WRITE (*,8030) CALL QYN(CEX,NEX) IF (CEX.NE.'Y') GOTO 100 IF(FNAMEB.EQ.'CON')GO TO 900 WRITE(LUB,9500) WRITE(LUB,9505) WRITE(LUB,9510) WRITE(LUB,9920)NAME WRITE(LUB,9910) WRITE(LUB,9930)NN IF(CLABN.EQ.'Y')WRITE(LUB,8070) IF(CLABN.EQ.'N')WRITE(LUB,8075) IF(CLABP.EQ.'Y')WRITE(LUB,8080) IF(CLABP.EQ.'N')WRITE(LUB,8085) IF(CARGE.EQ.'Y')WRITE(LUB,8090) IF(CARGE.EQ.'N')WRITE(LUB,8095) IF(CGRAP.EQ.'Y')WRITE(LUB,8100) IF(CGRAP.EQ.'N')WRITE(LUB,8105) WRITE(LUB,8115)JPPT IF(JPPT.GT.JPP)WRITE(LUB,8116)JPP IF(JPPT.EQ.JPP)WRITE(LUB,8113) WRITE(LUB,8114) DO 750 J=1,JPP WRITE(LUB,8117)(LABPP(K,J),K=1,3),JPLACE(J) 750 CONTINUE IF (CYNFF.EQ.'Y') WRITE(LUB,8160) IF (CYNFF.EQ.'N') WRITE(LUB,8165) JFMT IF (FNAMEB.EQ.'CON') PAUSE ' ' IF (FNAMEB.NE.'CON') WRITE(LUB,*) IF (YNSAVE.EQ.'Y') WRITE(LUB,8038) FNAMEC IF (FNAMEA.NE.'CON') WRITE(LUB,8039) FNAMEA CC CC INPUT OF DATA: NOTE THAT ONLY THE VALUES 'O' AND '1' ARE CC ALLOWED. OTHER VALUES ARE TREATED AS MISSING. CC 900 IF (FNAMEA.EQ.'CON') WRITE(*,8355) DO 930 L=1,NN IF (FNAMEA.NE.'CON')GO TO 910 WRITE(*,8359)JPPT,LABNN(1,L),LABNN(2,L),LABNN(3,L) 910 IF (CYNFF.EQ.'N') READ(LUA,JFMT)(HULP(J),J=1,JPPT) IF (CYNFF.EQ.'Y') READ(LUA,*)(HULP(J),J=1,JPPT) DO 920 J=1,JPP JH=JPLACE(J) KX(L,J)='9' IF(HULP(JH).GE.ABSL.AND.HULP(JH).LE.ABSH)KX(L,J)='0' IF(HULP(JH).GE.PRSL.AND.HULP(JH).LE.PRSH)KX(L,J)='1' 920 CONTINUE IF (YNSAVE.EQ.'N')GO TO 930 IF (CYNFF.EQ.'N') WRITE(LUC,JFMT)(HULP(J),J=1,JPPT) IF (CYNFF.EQ.'Y') WRITE(LUC,*)(HULP(J),J=1,JPPT) 930 CONTINUE IF (YNSAVE.EQ.'Y') CLOSE(LUC,STATUS='KEEP') IF (YNSAVE.EQ.'Y') WRITE(*,8038) FNAMEC RETURN 8030 FORMAT(/1X,' ARE ALL THESE OPTIONS OK? YES OR NO: '$) 8034 FORMAT(1X,' THE DATA WILL BE READ FROM THE KEYBOARD') 8038 FORMAT(' THE DATA WILL BE SAVED IN FILE: ',A30) 8039 FORMAT(' YOUR DATA RESIDE IN FILE: ',A30/) 8040 FORMAT(' YOUR OUTPUT WILL BE WRITTEN ON: ',A30) 8070 FORMAT(1X,' LABELS OF OBJECTS ARE READ') 8075 FORMAT(1X,' LABELS OF OBJECTS ARE NOT READ') 8080 FORMAT(1X,29H LABELS OF VARIABLES ARE READ) 8085 FORMAT(1X,33H LABELS OF VARIABLES ARE NOT READ) 8090 FORMAT(1X,' LARGE OUTPUT IS WANTED') 8095 FORMAT(1X,' SMALL OUTPUT IS WANTED') 8100 FORMAT(1X,' GRAPHICAL OUTPUT IS WANTED (BANNER)') 8105 FORMAT(1X,' NO GRAPHICAL OUTPUT IS WANTED') 8113 FORMAT(1X,' AND ALL OF THEM WILL BE USED IN THE ANALYSIS') 8114 FORMAT(1X,' THESE VARIABLES ARE:') 8115 FORMAT(/1X,' THERE ARE ',I4,' VARIABLES IN THE DATA SET,') 8116 FORMAT(1X,' AND 'I4,' OF THEM WILL BE USED IN THE ANALYSIS') 8117 FORMAT(10X,3A1,' (POSITION :',I3,')') 8160 FORMAT(1X,' THE MEASUREMENTS WILL BE READ IN FREE FORMAT') 8165 FORMAT(1X,' THE INPUT FORMAT FOR THE MEASUREMENTS IS'/2X,A60) 8355 FORMAT(//1X,'PLEASE ENTER YOUR DATA FOR EACH OBJECT'//) 8359 FORMAT(1X,' THE',I3,' MEASUREMENTS FOR OBJECT ',3A1,' : '/) 8500 FORMAT(3A1) 8520 FORMAT(BNI4,6X,3A1) 8530 FORMAT(A60) 8550 FORMAT(A30) 9500 FORMAT(////23X,33('*')/23X,'*',31X,'*'/23X,'* ' F 'MONOTHETIC ANALYSIS *'/23X,'*',31X,'*'/23X,33('*')/) 9505 FORMAT(/' Copyright (C) Leonard Kaufman and Peter' F ' Rousseeuw 1990. All rights reserved.') 9510 FORMAT(/5X,' Divisive hierarchical clustering algorithm', F ' for binary data,'/5X,' using association analysis.', F /5X,' More information can be found in chapter 7 of:' F //5X,' L. Kaufman and P.J. Rousseeuw (1990),' F /5X,' Finding Groups in Data:', F ' An Introduction to Cluster Analysis,' F /5X,' Wiley, New York.'/) 9520 FORMAT(1X,'NOT ALLOWED ! PLEASE ENTER YOUR CHOICE AGAIN: '$) 9525 FORMAT(/1X,'THE PRESENT VERSION OF THE PROGRAM CAN HANDLE' F ' UP TO',I6,' OBJECTS.'/1X,'(IF MORE ARE TO BE CLUSTERED' F ', THE ARRAYS INSIDE THE PROGRAM MUST BE ADAPTED.)') 9530 FORMAT(/1X,'HOW MANY OBJECTS ARE TO BE CLUSTERED ? '/1X, F38(1H-)/1X,'PLEASE GIVE A NUMBER BETWEEN 3 AND ',I6,' : '$) 9540 FORMAT(/1X,' AT LEAST 3 OBJECTS ARE NEEDED FOR CLUSTER' F ' ANALYSIS,'/1X,' PLEASE FORESEE MORE OBJECTS.') 9620 FORMAT(//1X,'THE PRESENT VERSION OF THE PROGRAM ALLOWS TO' F ' ENTER UP TO',I5,' VARIABLES,'/1X,'OF WHICH AT MOST',I5, F ' CAN BE USED IN THE ACTUAL COMPUTATIONS.'/1X,'(IF MORE ARE' F ' NEEDED, THE ARRAYS INSIDE THE PROGRAM MUST BE ADAPTED.)') 9625 FORMAT(/' AT LEAST THREE VARIABLES ARE NECESSARY FOR' F ' ASSOCIATION ANALYSIS.'/' IF FEWER ARE AVAILABLE' F ' A DIFFERENT CLUSTERING STRATEGY SHOULD BE USED.'/1X, F ' (FOR EXAMPLE, RUN THE PROGRAM DAISY TO COMPUTE A' F ' DISSIMILARITY MATRIX.)') 9630 FORMAT(/1X,'WHAT IS THE TOTAL NUMBER OF VARIABLES IN YOUR' F ' DATA SET ?'/1X,56(1H-)/1X, F 'PLEASE GIVE A NUMBER BETWEEN 3 AND ',I6,' : '$) 9640 FORMAT(/1X,'HOW MANY VARIABLES DO YOU WANT TO USE', F ' IN THE ANALYSIS ?'/1X,55('-')/1X, F 'PLEASE GIVE A NUMBER BETWEEN 3 AND ',I6,' : '$) 9645 FORMAT(/1X,'DO YOU WANT TO ENTER LABELS OF VARIABLES?' F ' PLEASE ANSWER YES OR NO: '$) 9650 FORMAT(//1X,'VARIABLE ', F ' LABEL (AT MOST 3 CHARACTERS)'/ F 1X,17(1H-),4(1H),6(1H-),3(1H),25(1H-)) 9660 FORMAT(' NUMBER : ',I4,6X$) 9670 FORMAT(//' VARIABLE TO BE USED : POSITION', F ' LABEL (AT MOST 3 CHARACTERS)'/ F 1X,32('-'),4(1H),6('-'),3(1H),25('-')) 9675 FORMAT(//1X,'VARIABLE TO BE USED : POSITION'/ F 1X,32('-'),4(1H),6('-')) 9680 FORMAT(' NUMBER ',I4,15X,': '$) 9690 FORMAT(/' THIS POSITION HAS ALREADY BEEN CHOSEN FOR', F' ANOTHER VARIABLE.'/' ENTER THE RIGHT POSITION PLEASE : ') 9720 FORMAT(/' PLEASE ENTER A TITLE FOR THE OUTPUT (AT MOST 60' F ' CHARACTERS)'/1X,60(1H-)/1X$) 9730 FORMAT(/' DO YOU WANT LARGE OUTPUT? (PLEASE ANSWER YES)'/ F' OR IS SMALL OUTPUT SUFFICIENT? (THEN ANSWER NO)'/2X, F'(IN THE FORMER CASE MEASUREMENT VALUES AND DETAILED' F' INFORMATION'/1X,' ON EACH SEPARATION STEP ARE PROVIDED.' F' IF THE PROGRAM FINDS MISSING'/' VALUES, THE ESTIMATES' F' ARE ALSO GIVEN.) ',28('.'),' : '$) 9740 FORMAT(/' DO YOU WANT GRAPHICAL OUTPUT (BANNER)?' F' PLEASE ANSWER YES OR NO....: '$) 9750 FORMAT(/' DO YOU WANT TO ENTER LABELS OF OBJECTS?' F' PLEASE ANSWER YES OR NO...: '$) 9760 FORMAT(/' EACH LABEL MAY CONSIST OF AT MOST 3 CHARACTERS'/ F/' OBJECT LABEL'/ 1 1X,12(1H-),4(1H),6(1H-),3(1H),5(1H-)) 9770 FORMAT(' NUMBER ',4X,I4,' : '$) 9780 FORMAT(/' DO YOU WANT TO READ THE DATA IN FREE FORMAT?'/1X, F45('-')/' THIS MEANS THAT YOU ONLY HAVE TO INSERT BLANK(S)', F ' BETWEEN MEASUREMENTS.'/' (NOTE: WE ADVISE USERS WITHOUT', F ' KNOWLEDGE OF FORTRAN FORMATS TO ANSWER YES.)'/ F ' MAKE YOUR CHOICE (YES/NO): '$) 9790 FORMAT(/' PLEASE ENTER A FORTRAN FORMAT.'/' THIS FORMAT' F ' MAY CONTAIN AT MOST 60 CHARACTERS AND SHOULD BE PUT'/ F ' BETWEEN BRACKETS, e.g. (10(2X,F1.0)).'/' ONLY F AND E' F ' FORMATS ARE ALLOWED (THIS DOES NOT MEAN'/' THAT YOUR' F ' MEASUREMENTS MUST CONTAIN DECIMAL POINTS,'/' BUT IT' F ' ENABLES YOU TO HANDLE MIXED DATA FILES).') 9800 FORMAT(/' PLEASE GIVE THE NAME OF THE FILE CONTAINING', F' THE DATA (e.g. A:EXAMPLE.DAT)',/1X,'OR TYPE', F' KEY IF YOU PREFER TO ENTER THE DATA BY KEYBOARD.'/ F1X,'WHAT DO YOU CHOOSE ? '$) 9810 FORMAT(/' DO YOU WANT TO SAVE YOUR DATA IN A FILE?'/ F ' PLEASE ANSWER YES OR NO: ',$) 9820 FORMAT(/' IN WHICH FILE DO YOU WANT TO SAVE YOUR DATA?'/ F ' (WARNING : IF THERE ALREADY EXISTS A FILE WITH THE SAME', F ' NAME'/12X,'THEN THE OLD FILE WILL BE OVERWRITTEN.)'/ F ' TYPE e.g. B:SAVE.DAT .....................: '$) 9830 FORMAT(/' WHERE DO YOU WANT YOUR OUTPUT ?'/1X,32('-')/ F ' TYPE CON IF YOU WANT IT ON THE SCREEN'/ F ' OR TYPE PRN IF YOU WANT IT ON THE PRINTER'/ F ' OR TYPE THE NAME OF A FILE (e.g. B:EXAMPLE.OUT)'/ F ' (WARNING : IF THERE ALREADY EXISTS A FILE WITH THE SAME' F ' NAME'/12X,'THEN THE OLD FILE WILL BE OVERWRITTEN.)'/ F ' WHAT DO YOU CHOOSE?......................: '$) 9832 FORMAT(/' FILE NAME IS INCORRECT, PLEASE ENTER ANOTHER') 9834 FORMAT(/' FORTRAN ERROR CODE : ',I8) 9836 FORMAT(/' THIS FILE WAS NOT FOUND, PLEASE ENTER ANOTHER ONE') 9900 FORMAT(//////////) 9910 FORMAT(//' DATA SPECIFICATIONS AND CHOSEN OPTIONS'/1X,38('-')) 9920 FORMAT(' TITLE : ',A60) 9930 FORMAT(' THERE ARE ',I6,' OBJECTS') RETURN END CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCCCCCC Data files for clustering: CCCCCCCCCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CC CCCCCCCCCC Chapter 1 (DAISY) file flower.dat (page 54) CCCCCCCCCCCCCCCCCCC .0000000 1.0000000 1.0000000 4.0000000 3.0000000 15.0000000 25.0000000 15.0000000 1.0000000 .0000000 .0000000 2.0000000 1.0000000 3.0000000 150.0000000 50.0000000 .0000000 1.0000000 .0000000 3.0000000 3.0000000 1.0000000 150.0000000 50.0000000 .0000000 .0000000 1.0000000 4.0000000 2.0000000 16.0000000 125.0000000 50.0000000 .0000000 1.0000000 .0000000 5.0000000 2.0000000 2.0000000 20.0000000 15.0000000 .0000000 1.0000000 .0000000 4.0000000 3.0000000 12.0000000 50.0000000 40.0000000 .0000000 .0000000 .0000000 4.0000000 3.0000000 13.0000000 40.0000000 20.0000000 .0000000 .0000000 1.0000000 2.0000000 2.0000000 7.0000000 100.0000000 15.0000000 1.0000000 1.0000000 .0000000 3.0000000 1.0000000 4.0000000 25.0000000 15.0000000 1.0000000 1.0000000 .0000000 5.0000000 2.0000000 14.0000000 100.0000000 60.0000000 1.0000000 1.0000000 1.0000000 5.0000000 3.0000000 8.0000000 45.0000000 10.0000000 1.0000000 1.0000000 1.0000000 1.0000000 2.0000000 9.0000000 90.0000000 25.0000000 1.0000000 1.0000000 .0000000 1.0000000 2.0000000 6.0000000 20.0000000 10.0000000 1.0000000 1.0000000 1.0000000 4.0000000 2.0000000 11.0000000 80.0000000 30.0000000 1.0000000 .0000000 .0000000 3.0000000 2.0000000 10.0000000 40.0000000 20.0000000 1.0000000 .0000000 .0000000 4.0000000 2.0000000 18.0000000 200.0000000 60.0000000 1.0000000 .0000000 .0000000 2.0000000 2.0000000 17.0000000 150.0000000 60.0000000 .0000000 .0000000 1.0000000 2.0000000 1.0000000 5.0000000 25.0000000 10.0000000 CCCCCCCCCC Chapter 1 (DAISY) file famikgcm.dat (page 59) CCCCCCCCCCCCCCCCC 15.0000000 95.0000000 1.0000000 82.0000000 49.0000000 156.0000000 5.0000000 55.0000000 13.0000000 95.0000000 11.0000000 81.0000000 45.0000000 160.0000000 7.0000000 56.0000000 85.0000000 178.0000000 6.0000000 48.0000000 66.0000000 176.0000000 6.0000000 56.0000000 12.0000000 90.0000000 12.0000000 83.0000000 10.0000000 78.0000000 1.0000000 84.0000000 CCCCCCCCCC Chapter 1 (DAISY) file variab.dat (page 61) CCCCCCCCCCCCCCCCCCC .957 -.036 .021 -.953 -.985 .013 CCCCCCCCCC Chapter 2 (PAM) file test.dat (pages 73, 82, 84, 87) CCCCCCCCCC 1.0 1.0 4.0 24.0 .6 2.0 5.0 1.0 26.5 -.3 3.0 5.0 2.0 27.0 .4 4.0 5.0 4.0 23.5 .2 5.0 10.0 4.0 24.5 -.6 6.0 25.0 4.0 25.5 .1 7.0 25.0 6.0 26.0 .3 8.0 25.0 7.0 23.5 -.2 9.0 25.0 8.0 22.0 .0 10.0 29.0 7.0 24.5 -.3 CCCCCCCCCC Chapter 2 (PAM) file miss.dat (page 90) CCCCCCCCCCCCCCCCCCCCCCC 12.3000000 8.3280000 38.7600000 -5.4000000 9.9990000 18.1200000 10.7000000 9.9990000 41.7100000 -4.6000000 2.9810000 20.8300000 -4.8000000 3.1560000 99.9900000 11.0000000 7.8260000 40.5400000 CCCCCCCCCC Chapter 2 (PAM) file country.dat (page 93) CCCCCCCCCCCCCCCCCCCC 5.58 7.00 6.50 7.08 7.00 3.83 4.83 5.08 8.17 5.83 2.17 5.75 6.67 6.92 4.92 6.42 5.00 5.58 6.00 4.67 6.42 3.42 5.50 6.42 6.42 5.00 3.92 6.17 2.50 4.92 6.25 7.33 4.50 2.25 6.33 2.75 6.08 6.67 4.25 2.67 6.00 6.17 6.17 6.92 6.17 5.25 6.83 4.50 3.75 5.75 5.42 6.08 5.83 6.67 3.67 4.75 3.00 6.08 6.67 5.00 5.58 4.83 6.17 5.67 6.50 6.92 CCCCCCCCCC Chapter 2 (PAM) file extreme1.dat (page 97) CCCCCCCCCCCCCCCCCCC .0000000 .0000000 .0000000 .0000000 .0000000 3.6000000 3.6000000 3.6000000 CCCCCCCCCC Chapter 2 (PAM) file extreme2.dat (page 98) CCCCCCCCCCCCCCCCCCC 1.0000000 1.0000000 1.0000000 1.0000000 1.0000000 1.0000000 1.0000000 4.6000000 CCCCCCCCCC Chapter 2 (PAM) file extreme3.dat (page 99) CCCCCCCCCCCCCCCCCCC 3.6000000 3.6000000 3.6000000 3.6000000 3.6000000 3.6000000 3.6000000 3.6000000 3.6000000 3.6000000 3.6000000 3.6000000 3.6000000 3.6000000 3.6000000 3.6000000 3.6000000 3.6000000 3.6000000 3.6000000 3.6000000 3.6000000 3.6000000 3.6000000 3.6000000 3.6000000 3.6000000 3.6000000 CCCCCCCCCC Chapter 2 (PAM) file ruspini.dat (page 101) CCCCCCCCCCCCCCCCCCC 4 53 5 63 10 59 9 77 13 49 13 69 12 88 15 75 18 61 19 65 22 74 27 72 28 76 24 58 27 55 28 60 30 52 31 60 32 61 36 72 28 147 32 149 35 153 33 154 38 151 41 150 38 145 38 143 32 143 34 141 44 156 44 149 44 143 46 142 47 149 49 152 50 142 53 144 52 152 55 155 54 124 60 136 63 139 86 132 85 115 85 96 78 94 74 96 97 122 98 116 98 124 99 119 99 128 101 115 108 111 110 111 108 116 111 126 115 117 117 115 70 4 77 12 83 21 61 15 69 15 78 16 66 18 58 13 64 20 69 21 66 23 61 25 76 27 72 31 64 30 CCCCCCCCCC Chapter 3 (CLARA) file ex200.dat (page 135) CCCCCCCCCCCCCCCCCC -.4419 8.7613 1.5233 8.7578 -1.8454 9.3390 1.9835 11.0422 -1.4269 12.1297 2.6726 6.2461 .7988 8.3507 -.8095 11.0538 1.6246 8.5198 2.6789 11.4680 1.2043 7.7398 .9047 8.4767 2.6670 12.6814 .2652 12.3139 -1.1044 9.3879 .8738 10.1555 2.3445 10.6905 -3.6155 9.3668 -2.4887 12.7497 .3709 8.0294 -.4831 8.4768 -1.3925 9.2801 -1.0232 10.1109 .5954 8.3125 -1.8240 10.3155 2.3384 10.6998 -2.4484 9.4914 -1.2234 9.9782 -.8878 10.0667 -1.8754 11.3739 .7852 11.3452 -2.1842 10.5750 2.7111 10.9064 -1.3726 8.6576 -.1980 11.0347 -3.5990 12.9655 -1.3894 6.7933 1.7418 9.6898 .6416 8.2100 .8848 12.3897 -1.3302 10.5009 .0094 9.8931 -1.8897 7.2778 -.9307 8.2272 1.9739 9.7833 -3.0495 7.2794 -.0421 5.7048 2.5321 8.8793 -1.6614 8.0426 -.5841 12.3563 2.2056 11.3635 -.7349 11.2330 .0236 12.7459 -1.7023 9.2867 .4973 4.6695 .6491 9.2000 -.1837 10.7953 -2.6410 10.3806 -2.1360 11.8468 .1753 10.1380 .7873 12.3929 -.7249 8.6172 1.3365 11.8268 3.1411 10.0241 .4407 11.1702 -3.4884 5.8969 -1.4252 9.5747 1.3503 11.2535 -1.5267 12.4325 1.3616 8.9702 -.1997 11.3809 2.5571 9.3306 -.1618 12.3890 .4033 9.5795 -.5991 5.2761 3.1909 11.9634 -1.9441 9.5210 -.0420 9.8486 -.4082 8.9478 -.4206 8.0357 -.1796 9.0357 2.2805 9.8902 -2.5186 9.3014 1.7769 8.6805 .8150 11.0708 -1.9459 12.5679 -.8647 8.8905 1.1915 9.6859 -2.8800 9.8553 1.0402 11.2149 -2.8974 12.0200 5.5194 9.5901 -.8425 6.6420 -.0745 11.8425 .5801 9.7421 -.0272 10.6213 -.5165 11.0990 1.9802 9.7598 -1.2728 9.1711 -.0382 9.3075 -1.7395 11.9497 -1.8022 9.5546 .8142 8.1280 -.3914 8.0254 1.6688 12.5528 -2.0495 8.5025 -1.2325 10.9414 -1.4631 11.7598 -.3739 8.8818 -.8434 14.0429 -.9194 9.0167 2.4520 9.6420 2.0878 6.9079 1.9150 7.6551 3.1213 13.8128 -.2230 12.2940 -1.3442 10.6231 .3344 10.3914 -2.0900 8.6196 -.5117 11.7352 19.9961 11.7348 19.8409 12.9857 21.4882 11.2482 19.9630 11.9799 19.9931 11.9938 21.1212 11.8283 20.0733 12.1630 19.4102 11.4427 20.2350 10.9616 19.6673 13.2074 18.8078 11.9447 19.8425 11.7570 20.0970 11.9322 20.6999 12.1744 20.1326 12.4195 18.6804 11.5595 20.2952 11.6533 19.7124 11.3401 20.5009 11.8822 21.0425 11.5058 20.0030 11.6601 19.3757 12.6807 19.8140 11.7412 19.2481 12.8086 20.4471 10.9453 19.2417 11.7747 19.3567 12.4171 18.5492 11.6535 19.2138 12.8558 19.8910 11.2923 20.8657 12.9649 19.9578 12.6810 18.9650 13.1065 20.2720 11.8222 19.7952 11.9226 20.6063 12.4141 19.2968 11.8220 18.3819 12.3779 20.9083 11.5764 20.2087 11.9131 20.8153 12.5993 20.5849 11.9395 20.4354 11.6738 20.1085 11.3975 19.6494 13.6236 20.5453 11.9303 19.5609 13.0138 20.2237 10.6462 19.5645 10.9349 19.4101 12.6627 20.8201 12.1622 19.7604 12.5613 19.1054 12.4837 19.5916 13.3502 20.5782 12.2059 20.8255 11.7669 19.4685 11.8833 20.2973 13.1620 20.4030 13.3648 20.7415 12.1044 10.6023 20.2713 9.2474 19.8701 10.3046 19.1919 7.9583 20.1852 10.9231 21.2269 9.1000 19.9391 9.8800 19.6631 8.4758 19.6854 8.7307 20.3339 9.1210 22.4236 10.2230 19.4225 9.1945 18.9828 11.0381 18.5047 9.5290 18.8236 10.2591 19.5714 10.0309 19.5185 9.5083 20.1860 8.9158 19.7520 9.6445 19.2671 9.3336 19.8601 CCCCCCCCCC Chapter 4 (FANNY) file 22.dat (pages 167, 172) CCCCCCCCCCCCCCCC 1 9 2 10 2 9 2 8 3 9 7 14 12 9 13 10 13 8 14 10 14 8 15 9 7 7 6 3 7 3 8 3 6 2 7 2 8 2 6 1 7 1 8 1 CCCCCCCCCC Chapter 4 (FANNY) file science.dat (pages 17, 197) CCCCCCCCCCCC 7.8600000 6.5000000 2.9300000 5.0000000 6.8600000 6.5000000 8.0000000 8.1400000 8.2100000 4.7900000 4.2900000 7.0000000 7.6400000 7.7100000 5.9300000 8.0700000 8.1400000 8.7100000 8.5700000 5.8600000 3.8600000 3.6400000 7.1400000 4.4300000 1.4300000 3.5700000 7.0700000 9.0700000 8.2100000 2.5000000 2.9300000 6.3600000 8.4300000 7.8600000 8.4300000 6.2900000 2.7100000 5.2100000 4.5700000 4.2100000 8.3600000 7.2900000 8.6400000 2.2100000 5.0700000 9.3600000 5.5700000 7.2900000 7.2100000 6.8600000 8.2900000 7.6400000 8.7100000 3.7900000 8.6400000 CC CC Chapter 4 (FANNY) also uses the data files: CC country.dat (on page 176) CC extreme1.dat (on page 178) CC extreme2.dat (on page 179) CC extreme3.dat (on page 180) CC ruspini.dat (on page 181) CC that were already listed above. CC CCCCCCCCCC Chapters 5 and 6 (TWINS) example.dat (pages 210, 260) CCCCCCCCC 2.0000000 6.0000000 5.0000000 10.0000000 9.0000000 4.0000000 9.0000000 8.0000000 5.0000000 3.0000000 CCCCCCCCCC Chapters 5 and 6 (TWINS) seven.dat (pages 212, 261) CCCCCCCCCCC 2.0000000 2.0000000 5.5000000 4.0000000 5.0000000 5.0000000 1.5000000 2.5000000 1.0000000 1.0000000 7.0000000 5.0000000 5.7500000 6.5000000 CCCCCCCCCC Chapters 5 and 6 (TWINS) vrijens.dat (page 220) CCCCCCCCCCCCCCC 9.900000E-001 9.200000E-001 1.0300000 1.1300000 1.1800000 1.0600000 8.200000E-001 6.500000E-001 7.400000E-001 1.2600000 9.400000E-001 7.600000E-001 9.500000E-001 1.2900000 8.200000E-001 9.200000E-001 1.1700000 1.0400000 7.100000E-001 1.1500000 9.500000E-001 1.0500000 6.900000E-001 8.200000E-001 7.400000E-001 8.700000E-001 8.600000E-001 1.2200000 9.500000E-001 8.600000E-001 1.0300000 9.800000E-001 8.400000E-001 9.600000E-001 6.700000E-001 9.000000E-001 CCCCCCCCCC Chapters 5 and 6 (TWINS) stars.dat (page 269) CCCCCCCCCCCCCCCCC 1 4.37 5.23 2 4.56 5.74 3 4.26 4.93 4 4.56 5.74 5 4.30 5.19 6 4.46 5.46 7 3.84 4.65 8 4.57 5.27 9 4.26 5.57 10 4.37 5.12 11 3.49 5.73 12 4.43 5.45 13 4.48 5.42 14 4.01 4.05 15 4.29 4.26 16 4.42 4.58 17 4.23 3.94 18 4.42 4.18 19 4.23 4.18 20 3.49 5.89 21 4.29 4.38 22 4.29 4.22 23 4.42 4.42 24 4.49 4.85 25 4.38 5.02 26 4.42 4.66 27 4.29 4.66 28 4.38 4.90 29 4.22 4.39 30 3.48 6.05 31 4.38 4.42 32 4.56 5.10 33 4.45 5.22 34 3.49 6.29 35 4.23 4.34 36 4.62 5.62 37 4.53 5.10 38 4.45 5.22 39 4.53 5.18 40 4.43 5.57 41 4.38 4.62 42 4.45 5.06 43 4.50 5.34 44 4.45 5.34 45 4.55 5.54 46 4.45 4.98 47 4.42 4.50 CC CC Chapters 5 and 6 (TWINS) also use the data files: CC country.dat (on pages 215, 264) CC extreme1.dat (on pages 218, 265) CC extreme2.dat (on pages 219, 265) CC extreme3.dat (on pages 217, 265) CC ruspini.dat (on page 270) CC that were already listed above. CC CCCCCCCCCC Chapter 7 (MONA) file table1.dat (page 284) CCCCCCCCCCCCCCCCCCC 1 1 0 1 1 0 1 1 0 0 0 1 1 1 1 1 1 0 1 1 1 1 1 0 0 0 0 1 0 1 0 0 0 0 0 0 0 0 1 1 0 1 0 0 1 1 1 0 CCCCCCCCCC Chapter 7 (MONA) file famimona.dat (page 292) CCCCCCCCCCCCCCCCC 1 0 1 1 0 0 1 0 0 0 0 1 0 0 1 0 0 0 0 0 0 0 1 0 0 0 1 0 0 1 0 1 0 0 0 0 0 1 1 0 1 1 0 0 1 1 0 1 1 0 1 1 0 0 1 0 1 1 0 0 0 0 0 1 0 1 0 0 0 0 0 0 0 1 0 1 0 0 0 0 CCCCCCCCCC Chapter 7 (MONA) file animals.dat (page 295) CCCCCCCCCCCCCCCCCC 0 0 0 0 1 0 0 1 0 0 1 1 1 0 1 0 0 1 0 0 0 0 0 1 1 0 1 1 1 1 1 0 1 0 1 1 1 1 1 0 1 0 1 1 1 1 0 0 1 0 1 1 1 0 0 1 0 0 0 0 0 0 1 1 2 0 0 0 1 0 1 0 1 0 1 2 1 1 0 0 1 0 0 0 0 0 0 0 2 0 1 0 1 1 1 1 1 0 1 0 1 1 0 0 1 0 2 0 0 0 0 2 0 1 1 0 1 1 1 0 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC