Trailing-Edge
-
PDP-10 Archives
-
decuslib10-06
-
43,50430/dendro.f4
There are no other files named dendro.f4 in the archive.
DIMENSION IN(1),S(1),LZ(1),DMIN(1),MINCOL(1),LAB(1)
DIMENSION EDSQ(1)
COMMON KI,KO,INDSK,IODSK
C
C MAIN PROGRAM TO SET UP CORE SPACE FOR OLD DENDRO PROGRAM
C WHICH IS NOW CONTAINED IN DENWKS.
C
CALL INIT
CALL IFILE(INDSK,'AVGE')
C
C GETTHE DIMENSION OF THE PROBLEM
C
READ(INDSK)MSIT,MSES,MSPC
CALL RELEAS(INDSK)
C
C NOW GET CORE FOR MAXIMUM CASE OF THE FOUR
C
IMAX=MAX0(MSES,MSPC)
IMAX=MAX0(MSIT,IMAX)
C
CALL MORCOR(IN,I1,IMAX)
CALL MORCOR(S,I2,IMAX)
CALL MORCOR(LZ,I3,IMAX)
CALL MORCOR(DMIN,I4,IMAX)
CALL MORCOR(MINCOL,I5,IMAX)
CALL MORCOR(LAB,I6,IMAX)
CALL MORCOR(EDSQ,I7,IMAX*(IMAX+1)/2+1)
C
C NO CHECK FOR ERRORS OF NOT ENOUGH CORE SINCE PREVIOUS PROGS
C WOULD HAVE BEEN THROWN OUT
C
CALL DENWKS(IN(I1),S(I2),LZ(I3),DMIN(I4),MINCOL(I5),
1 LAB(I6),EDSQ(I7))
C
CALL RUN4
CALL EXIT
END
C
C THE OLD DENDRO PROGRAM NOW SUBROUTINED TO USE VARICORE
C PERFORMS SORTING BY ONE OF 8 STRATEGIES ON 4 MATRICES
C
SUBROUTINE DENWKS(IN,S,LZ,DMIN,MINCOL,LAB,EDSQ)
DIMENSION IN(1),S(1),LZ(1),DMIN(1),MINCOL(1)
1,T(8),ST(13),LAB(1),EDSQ(1)
DIMENSION IDO(4),J1(4)
COMMON KI,KO,INDSK,IODSK
DATA BIG/1.0E38/
CJM ****** REVISION HISTORY *****
CJM
CJM 1) JAN 1977 PATCHES TO CLUSTERING ALGORITHM. BELIEVE THESE PATCHES
CJM ARE NECESSARY BUT FIND IT HARD TO BELIEVE THAT THE
CJM RESULTING ERRONEOUS (ALBEIT SLIGHTLY) RESULTS WENT
CJM UNDETECTED FOR SO LONG.
CJM MARCH 1977 ALL OCCURENCES OF THE CONSTANT 1000.0 CHANGED
CJM TO THE VARIABLE 'BIG' WHICH IS INITALISED TO
CJM 1.E38. REMOVES PROBS. WITH ALGORITH WHEN THE
CJM EUCLIDEAN DIST**2 METRIC IS USED (THIS METRIC
CJM CAN GENERATE LEGIT. DISTANCES > 1000.0)
C
C GET OPTIONS AND START 4 SORTS IF REQD
C
CALL GDEN(IDO,J1)
DO 1101 NFIL=1,4
IF(J1(NFIL).LE.0) GO TO 1101
C
C MAKE FILENAMES FOR INPUT AND OUTPUT
C
ENCODE(5,31,FLE)NFIL
31 FORMAT('DEN',I1,' ')
CALL IFILE(INDSK,FLE)
ENCODE(5,29,OFLE)NFIL
29 FORMAT('DENI',I1)
CALL OFILE(IODSK,OFLE)
C
C READ NO OF ENTITIES ;TEST IF TOO MANY; READ & WRITE TITLES
C
READ(INDSK)NENT
WRITE(IODSK)NENT
IF(NENT.GT.200)GO TO 1101
READ(INDSK)T,ST
WRITE(IODSK)T,ST
C
C LZ IS A MAPPING VECTOR FROM 2D INTO 1D BY COLUMN
C
LZ(1)=0
DO 2090 I=2,NENT
LZ(I)=LZ(I-1)+I-2
IRUN=LZ(I)+1
IM=IRUN+I-2
READ(INDSK)(EDSQ(J),J=IRUN,IM)
C
C CALCULATE MIN IN EACH COLUMN - IE DMIN
C AND WHERE IT OCCURS IN EDSQ - MINCOL
C
DM=BIG
MCOL=0
DO 2085J=IRUN,IM
IF(EDSQ(J).GE.DM)GOTO 2085
DM=EDSQ(J)
MCOL=J
2085 CONTINUE
DMIN(I)=DM
MINCOL(I)=MCOL-IRUN+1
2090 CONTINUE
C
C ORIGINAL FROM HTC STARTS HERE
C
C INITIALIZE LAB(I) = CLUSTER LABEL CORRESPONDING TO ROW I
C INTIALIZE IN = CLUSTER SIZE, S = SSWC
C
C INITIALLY EACH COL IS 1 CLUSTER OF SIZE 1
C
CJM
CJM
IF(IDO(NFIL) .EQ. 2) GO TO 2095
WRITE(KO,2091) ST,T
2091 FORMAT(1H1,10X,13A5//11X,8A5/21X,'FUSIONS ON DENDROGRAM'
# /14X,'GROUP LABELS',8X,'DISSIM',2X,'NO. IN GRPS'/)
CJM
CJM
2095 DO 2100 I = 1,NENT
IN(I) = 1
S(I) = 0.0
2100 LAB(I) = I
NNENT = NENT
C
C * MAJOR FUSION LOOP *
C PERFORMED UNTIL NO OF ENTITIES HAS DOUBLED
C FUSION CYCLE BEGINS. FIND SMALLEST DIJ
2110 NNENT = NNENT + 1
IF(NNENT.GE.NENT+NENT) GO TO 1100
C
C FIND SMALLEST DISSIMILARITY IN MATRIX
C
DIJ = BIG
DO 2120 K=2,NENT
IF(DMIN(K).GE.DIJ) GO TO 2120
DIJ = DMIN(K)
I = K
J = MINCOL(K)
2120 CONTINUE
IF (DIJ.GE.BIG) GO TO 1100
C
C WRITE OUT CURRENT FUSION
C
WRITE(IODSK) LAB(J), LAB(I), NNENT, DIJ
C
C AND FUSE THESE INTO A CURRENT GROUP
C
INI=IN(I)
INJ=IN(J)
A = INI
B = INJ
C = A + B
C
C A IS SIZE OF GROUP I; B IS SIZE OF GROUP J;
C C SIZE AFTER FUSION
C
SI=S(I)
SINEW = (C-1.)*DIJ
PIJ = C*SINEW
S(I) = SINEW
SINI = A*SI
SJNJ = A*S(J)
C
C NOW J HAS JOINED I AND CEASED TO EXIST
C
IN(I) = INI + INJ
IN(J) = 0
CJM
IF(IDO(NFIL) .EQ. 2) GO TO 2125
WRITE(KO,2121) LAB(J),LAB(I),NNENT,DIJ,INJ,INI
2121 FORMAT(11X,I4,' + ',I4,' = ',I4,2X,F9.3,2(2X,I4))
CJM
C
C AND I IS A NEW GOUP WITH J ADDED - NNENT
C
2125 LAB(I) = NNENT
C
C REMOVE J FROM MINIMUM CONSIDERATIONS
C * HERE UNDERSTANDING OF THIS MESS ENDS!!!!!
C
C PATCH BY C J MCGOVERN JAN 1977
DMIN (I) = BIG
C END PATCH
DMIN(J) = BIG
DO 2130 K=J,NENT
IF(IN(K).LE.0) GO TO 2130
IF(MINCOL(K).NE.I.AND.MINCOL(K).NE.J) GO TO 2130
C PATCH BY C J MCGOVERN JAN 1977
IF ( K .EQ. I) GO TO 2130
C END PATCH
LMIN = 0
DMK = BIG
KM = K-1
IF(KM.EQ.0) GO TO 2129
DO 2128 L = 1,KM
IF(L.EQ.I) GO TO 2128
IF(IN(L).LE.0) GO TO 2128
KL = LZ(K) + L
IF(EDSQ(KL).GE.DMK) GO TO 2128
DMK = EDSQ(KL)
LMIN = L
2128 CONTINUE
2129 DMIN(K) = DMK
MINCOL(K) = LMIN
2130 CONTINUE
C RECOMPUTE DISTANCES IN ROW I AND COLUMN I
DO 2320 K = 1,NENT
C EXTRACT DIK AMD DJK UNLESS K IS DISCARDED
D = IN(K)
IF(D.LE.0.0) GO TO 2320
IF(K-J) 2140,2320,2150
2140 JK = LZ(J) + K
GO TO 2160
2150 JK = LZ(K) + J
2160 DJK = EDSQ(JK)
IF(K-I) 2170,2320,2180
2170 IK = LZ(I) + K
NROW = I
NCOL = K
GO TO 2190
2180 IK = LZ(K) + I
NROW = K
NCOL = I
2190 DIK = EDSQ(IK)
GO TO (2210,2220,2230,2240,2250,2260,2270,2280),J1(NFIL)
C 1 - NEAREST NEIGHBOUR
2210 IF(DIK - DJK) 2212,2212,2214
2212 DNEW = DIK
GO TO 2300
2214 DNEW = DJK
GO TO 2300
C 2 - FURTHEST NEIGHBOUR
2220 IF(DIK - DJK) 2214,2212,2212
C 3 - WEIGHTED AVERAGE
2230 DNEW = (A*DIK + B*DJK)/C
GO TO 2300
C 4 - SIMPLE AVERAGE
2240 DNEW = (DIK + DJK)*0.5
GO TO 2300
C 5 - CENTROID
2250 DNEW = (A*DIK + B*DJK - A*B*DIJ/C)/C
GO TO 2300
C 6 - INCREMENTAL SS
2260 DNEW = ((A+D)*DIK + (B+D)*DJK -D*DIJ)/(C+D)
GO TO 2300
C 7 - VARIANCE
2270 SKNK =D*S(K)
PIJK = C+D
PIJK = PIJK*PIJK-PIJK
PIK = A+D
PIK = (PIK*PIK - PIK)*DIK
PJK = B+D
PJK = (PJK*PJK - PJK)*DJK
DNEW = (PIK+PJK+PIJ-SINI-SJNJ-SKNK)/PIJK
GO TO 2300
C
C 8 - FLEXIBLE ADDED BY CJA
C
2280 DNEW=(0.625*(DIK+DJK)-0.25*DIJ)
C FINALLY, UPDATE DMIN IF REQUIRED
2300 EDSQ(IK) = DNEW
IF(DNEW.GE.DMIN(NROW)) GO TO 2320
DMIN(NROW) = DNEW
MINCOL(NROW) = NCOL
2320 CONTINUE
GO TO 2110
1100 CALL RELEAS(INDSK)
CALL RELEAS (IODSK)
1101 CONTINUE
RETURN
3000 CALL EXIT
END