C ********************************************************************** C C NOYAU.F 31-JAN-86 C DENDRO CALL ADDED TO PLOT DENDROGRAM NOV 86 al C DENDROGRAM DOC FILE BUGGY REMOVED DEC 03 al C CUTOFF CHANGED FEB 04 al C FORMATTING CHANGED DEC 07 al C COSMETIC OUTPUT CHANGES DEC 08 al * C DOC FILE * MAY 09 al * C DENDRO REWRITE MAY 09 al * C ********************************************************************** C=* FROM: SPIDER - MODULAR IMAGE PROCESSING SYSTEM. AUTHOR: J.FRANK * C=* Copyright (C) 1985-2009 Health Research Inc. * C=* * C=* HEALTH RESEARCH INCORPORATED (HRI), * C=* ONE UNIVERSITY PLACE, RENSSELAER, NY 12144-3455. * C=* * C=* Email: spider@wadsworth.org * C=* * C=* This program is free software; you can redistribute it and/or * C=* modify it under the terms of the GNU General Public License as * C=* published by the Free Software Foundation; either version 2 of the * C=* License, or (at your option) any later version. * C=* * C=* This program is distributed in the hope that it will be useful, * C=* but WITHOUT ANY WARRANTY; without even the implied warranty of * C=* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * C=* General Public License for more details. * C=* * C=* You should have received a copy of the GNU General Public License * C=* along with this program; if not, write to the * C=* Free Software Foundation, Inc., * C=* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. * C=* * C*---------------------------------------------------------------------* C * C PURPOSE: CLASSIFICATION ACCORDING TO FACTORIAL COORDINATES * C * C INPUT ... DATA AND WEIGHTS IN IMC FILE ON: LUNI (FORMATTED) * C N2DIM = SUP (NKLA, 2*NCLAS) * C KDIM = SUP (NUMIM, NCLAS**NBASE, 2*NKLA - 1) * C MDIM = SUP (NKLA*(NKLA-1)/2) * C LDIM = SUP (NKLA) * C L2DIM = SUP (2*NKLA - 1) * C NFAC = NUMBER OF COORDINATES IN RECORD FOLLOWED BY WEIGHT * C KFAC = NUMBER OF COORDINATES USED FOR CALCULATION * C NUMIM = NUMBER OF OBJECTS TO BE CLASSIFIED * C NBASE NITER ... PARAMETERS DEFINED IN SUBROUTINE PARST * C NCLAS NKLA ... PARAMETERS DEFINED IN SUBROUTINE PARST * C * C WORKING ARRAYS: GT(*,*) D(*) KLAS(*) CI(*) U(*) JV(*) JW(*) * C U(), JV(), JW() EQUIVALENCED TO D() * C * C*---------------------------------------------------------------------* SUBROUTINE NOYAU(N2DIM,KDIM,MDIM,LDIM,L2DIM,NFAC,KFAC,NUMIM, & NBASE, NITER, NCLAS, NKLA, IDI, & KLAS, D, U, JV, JW, IDK, CI, GT, & NUM,LA,LB,IV,IW,V,W,NT,VAL,PK,NO,LUNI,LUNK, & LUNDOC) INCLUDE 'CMLIMIT.INC' COMMON /UNITS/LUN,NIN,NOUT,NECHO,IFOUND,NPROC,NDAT DIMENSION GT(N2DIM,KFAC),D(MDIM),KLAS(NUMIM),CI(NFAC), & IDI(NUMIM), U(KDIM), JV(KDIM), JW(KDIM), IDK(NKLA) DIMENSION NUM(LDIM),LA(LDIM),LB(LDIM),NT(L2DIM),VAL(L2DIM), & PK(L2DIM),NO(L2DIM),IV(LDIM),W(LDIM),IW(LDIM),V(LDIM) CHARACTER(LEN=MAXNAM) :: DOCNAM CHARACTER(LEN=1) :: NULL,ANS NULL = CHAR(0) IRTFLG = 0 C AGGREGATION AROUND MOBILE CENTERS AND STABLE CLUSTERING CALL PARST(N2DIM,KDIM,NFAC,NUMIM,KFAC,NBASE,NITER,NCLAS,NKLA, & KLAS,JW,U,CI,JV,GT, KFIN,LUNI,LUNK,IDI) C HIERARCHICAL CLASSIFICATION OF THE CLUSTER GRAVITY C CENTERS ACCORDING TO THE WARD'S VARIANCE CRITERION C IMPORTANT CHANGE: LIMIT NUMBER OF CLUSTERS USED IN HAC. 8/25/86 WRITE(NDAT,*)' CLASS ASSIGNMENT FOR EACH IMAGE:' WRITE(NDAT,90) (KLAS(K),K=1,NUMIM) 90 FORMAT(10I5) IRANGE1 = MINVAL(JV(1:NKLA)) ! JV IS OCCUPANCY LEVEL IRANGE2 = MAXVAL(JV(1:NKLA)) IF (NDAT.NE.NOUT) WRITE(NOUT,91)IRANGE1,IRANGE2,NKLA WRITE(NDAT,91) IRANGE1,IRANGE2, NKLA 91 FORMAT(/' CLASS OCCUPANCY: ',I7,'....',I7,' CLASSES: ',I6,/) ILEVL = IRANGE1 CALL RDPRI1S(ILEVL,NOT_USED, & 'OCCUPANCY LEVEL FOR CLASS CUTOFF ( = NO CUTOFF)', & IRTFLG) IF (IRTFLG .NE. 0) RETURN IF (ILEVL .NE. IRANGE1) THEN DO I=1,NKLA IF (JV(I) .LT. ILEVL) THEN NKLA = I - 1 EXIT ENDIF ENDDO ENDIF IF (NDAT.NE.NOUT) WRITE(NOUT,92)NKLA WRITE(NDAT,92) NKLA 92 FORMAT(/,' USING: ',I6,' CLASSES.') C READS FROM _IMC TO CONSTRUCT MONO-INDEXED TABLE OF DISTANCES C BETWEEN NKLA CLASSES IN THE EUCLIDEAN SPACE CHARACTERIZED C BY THE KFAC FIRST FACTORIAL COORDINATES. READS FROM: LUNI * C OUTPUTS: D, GT & PK IF (NKLA .GT. KFIN) NKLA = KFIN MCARD = NKLA * (NKLA-1) / 2 CALL DEUCL(N2DIM,NKLA,MCARD,NUMIM,KFAC,NFAC,KLAS, & D,GT,PK,CI,LUNI) C CHAVA OVERWRITES AND THEN READS FROM: LUNK JFIN = 2 * NKLA - 1 CALL CHAVA(NKLA,MCARD,JFIN,D,PK,VAL,LA,LB,NT,NO,LUNK,5) C SAVES CLASSIFICATION TO FILE BY OVERWRITING: LUNK CALL REW(LUNK,0) WRITE(LUNK) NUMIM, NFAC, NKLA, KFAC WRITE(LUNK) (KLAS(I), I=1,NUMIM), & (IDI(I), I=1,NUMIM), & (PK(L),L=1,NKLA), & ((GT(L,J),L=1,NKLA),J=1,KFAC) C GENERATION OF IDENTIFIERS, ADDED 1/2001 al SEEMS TO BE C NEEDED IN DENDRO BUT REMOVED BY pp SOMETIME ?? DO I = 1,NKLA IDK(I) = I ENDDO #ifdef NEVER write(0,*) ' l2dim,nkla,jfin: ',l2dim,nkla,jfin #endif C DRAW CLASSIFICATION TREE OF THE NKLA CENTERS CALL DENDRO(NKLA, JFIN, VAL, LA, LB, PK, IDK, KLAS,NUMIM,IDI, & .TRUE., NO,NUM,NT,IV,IW,V,W) C SUCCESSIVE TRUNCATIONS OF THE CLASS. DO KPRO =2,NKLA-1 CALL COUPE(NUMIM,NKLA,KPRO, PK,LA,LB,IV,KLAS,NT, IW) C TRUNCATED TREE OUTPUT APPENDED TO LUNK WRITE(LUNK) (IV(J), J=1,NKLA) ENDDO END C ---------------- CLULST -------------------------------------------- SUBROUTINE CLULST(LUNDOC,NUMIM,KLAS,IDI,IRTFLG) INCLUDE 'CMLIMIT.INC' INTEGER :: KLAS(NUMIM),IDI(NUMIM) CHARACTER (LEN=MAXNAM) :: DOCNAM LOGICAL :: NEWFILE REAL, DIMENSION(2) :: DLIST CALL OPENDOC(DOCNAM,.TRUE.,NLET,LUNDOC,LUNDOCT,.TRUE., & 'IMAGE CLASS ASSIGNMENT OUTPUT DOC', & .FALSE.,.FALSE.,.TRUE.,NEWFILE,IRTFLG) IF (IRTFLG .NE. 0)RETURN CALL LUNDOCPUTCOM(LUNDOCT,'KEY: IMAGE NUMBER, CLASS',IRTFLG) DO I =1,NUMIM IM = IDI(I) DLIST(2) = KLAS(I) CALL LUNDOCWRTDAT(LUNDOCT,IM,DLIST(2),1,IRTFLG) ENDDO CLOSE(LUNDOCT) END