C ++******************************************************************** C C SCLASSI.F C 02.09.81 C 31-JAN-86 C DENDRO CALL ADDED NOV 86 ARDEAN LEITH C LONG FILE NAMES JAN 89 ARDEAN LEITH C INCLUDED FILES FOR SCLASSY, SEMIS MAR 02 ARDEAN LEITH * C NEW IMC FORMAT OCT 02 ARDEAN LEITH C EXCESSIVE PARTITION TRAP DEC 05 ARDEAN LEITH C NFAC VS KFAC BUG DEC 07 ARDEAN LEITH C IPALIGN & REFACTORING DEC 08 ARDEAN LEITH C C ********************************************************************** C=* FROM: SPIDER - MODULAR IMAGE PROCESSING SYSTEM. AUTHOR: J.FRANK * C=* Copyright (C) 1985-2008 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 AUTHOR: JEAN-PIERRE BRETAUDIERE C THE UNIVERSITY OF TEXAS HEALTH SCIENCE CENTER AT HOUSTON C MEDICAL SCHOOL - DEPARTMENT OF PATHOLOGY AND LABORATORY MEDICINE C P.O. BOX 20708, HOUSTON, TX 77225. C C ********************************************************************** C C SCLASSI(LUNI,LUNK,LUNDOC) C C PURPOSE: PERFORMS FIRST STEP AN AUTOMATIC CLUSTERING OF C OBJECTS BY AGGREGATION AROUND MOBILE CENTERS AND IN A 2ND C STEP, A HIERARCHIC ASCENDENT CLASSIFICATION OF THE GRAVITY C CENTERS OF THE CLUSTERS DETERMINED IN THE FIRST STEP. C C CALL TREE: SCLASSI - NOYAU - PARST - RETIR C - CLAST C - STABK - SHELK C - DEUCL C - CHAVA C - ARBRE C - DENDRO C - DENDRO2 C - DENLST C - CLULST C - COUPE C SCLASSI - RGRI C C23456789012345678901234567890123456789012345678901234567890123456789012 C*********************************************************************** SUBROUTINE SCLASSI(LUNI,LUNK,LUNDOC) INCLUDE 'CMBLOCK.INC' INCLUDE 'CMLIMIT.INC' CHARACTER(LEN=MAXNAM) :: CLUSFILE,IMCFILE,FILPRE #ifndef SP_32 INTEGER *8 :: IBIG #else INTEGER *4 :: IBIG #endif CHARACTER(LEN=1) :: NULL REAL, ALLOCATABLE, DIMENSION(:) :: Q NULL = CHAR(0) C MARCH 02 al NKLA IS REDEFINED LATER! SO REPEAT FAILED NKLA = 100 CALL FILERD(FILPRE,NLET,NULL, & 'CORAN/PCA FILE PREFIX (e.g.. CORAN_01_)~',IRTFLG) IF (IRTFLG .NE. 0) RETURN IMCFILE = FILPRE(1:NLET) // '_IMC'//NULL C GET CLUSTER OUTPUT FILE NAME CALL FILERD(CLUSFILE,NLET,DATEXC,'CLUSTER OUTPUT',IRTFLG) IF (IRTFLG .NE. 0) RETURN KFAC = 2 CALL RDPRI1S(KFAC,NOT_USED,'NUMBER OF FACTORS',IRTFLG) IF (IRTFLG .NE. 0) RETURN IF (KFAC .LE. 0) THEN CALL ERRT(102,'FACTORS <= 0',KFAC) RETURN ENDIF NITER = 5 NCLAS = 5 CALL RDPRIS(NITER,NCLAS,NOT_USED, & 'NUMBER OF ITERATIONS & CENTERS PER PARTITION',IRTFLG) IF (NITER .LE. 0 .OR. NCLAS .LE. 0) THEN CALL ERRT(100,'ILLEGAL: ITERATIONS OR CENTERS',NE) RETURN ENDIF NBASE = 4 CALL RDPRI1S(NBASE,NOT_USED,'NUMBER OF PARTITIONS',IRTFLG) IF (NBASE .LE. 0) THEN CALL ERRT(102,'ILLEGAL: NUMBER OF PARTITIONS',NBASE) RETURN ENDIF C OPEN & READ HEADER OF _IMC FILE FORM='FORMATTED' CALL OPAUXFILE(.FALSE.,IMCFILE,DATEXC,LUNI,0, & 'O', ' ',.TRUE.,IRTFLG) READ(LUNI,*) NUMIM, NFAC,IDUM,IDUM,IDUM,IDUM C OPEN NEW CLUSTER FILE (ALREADY HAS EXTENSION ON IT) CALL OPAUXFILE(.FALSE.,CLUSFILE,NULL,-LUNK,0, & 'N', ' ',.TRUE.,IRTFLG) WRITE(NDAT, 2100) KFAC 2100 FORMAT (/,' FACTORS USED: 1...',I3) WRITE(NDAT, 2150) NBASE, NITER, NCLAS, NKLA 2150 FORMAT(/,' #PARTITIONS:',I6,' #ITER:',I6,/, & ' #CENTERS:', I6,' INITIAL CLASSES: ',I6,/) C MEMORY SEGMENTATION N2DIM = MAX(NKLA, 2*NCLAS) KDIM = MAX(NUMIM, NCLAS**NBASE) KDIM = MAX(KDIM, 2*NKLA - 1) MDIM = NKLA*(NKLA-1) / 2 LDIM = NKLA L2DIM = 2*NKLA - 1 IBIG = NCLAS IBIG = (IBIG**NBASE) * 3 IBIG = IBIG + (LDIM * 7) + (L2DIM * 4) + 2 * NUMIM + & MDIM + (3 *KDIM)+ NKLA + NFAC + N2DIM * KFAC IBIG4 = HUGE(IBIG4) IF (IBIG .GE. IBIG4) THEN WRITE(NOUT,*)' *** MUST REDUCE NUMBER OF PARTITIONS' CALL ERRT(102,'EXCESSIVE MEMORY NEEDED>',IBIG4) GOTO 9999 ENDIF N1 = 1 NK = IPALIGN64(N1 + NUMIM) ND = IPALIGN64(NK + NUMIM) NU = IPALIGN64(ND + MDIM) NJV = IPALIGN64(NU + KDIM) NJW = IPALIGN64(NJV + KDIM) NIDK = IPALIGN64(NJW + KDIM) NCI = IPALIGN64(NIDK + NKLA) NGT = IPALIGN64(NCI + NFAC) NNUM = IPALIGN64(NGT + N2DIM * KFAC ) NLA = IPALIGN64(NNUM + LDIM) NLB = IPALIGN64(NLA + LDIM) NIV = IPALIGN64(NLB + LDIM) NIW = IPALIGN64(NIV + LDIM) NV = IPALIGN64(NIW + LDIM) NW = IPALIGN64(NV + LDIM) NNT = IPALIGN64(NW + LDIM) NVAL = IPALIGN64(NNT + L2DIM) NPK = IPALIGN64(NVAL + L2DIM) NNO = IPALIGN64(NPK + L2DIM) NFIN = IPALIGN64(NNO + L2DIM) ALLOCATE (Q(NFIN),STAT=IRTFLG) IF (IRTFLG .NE. 0) THEN CALL ERRT(46,'Q',NFIN) GOTO 9999 ENDIF C CLASSIFICATION OF OBJECTS ACCORDING TO FACTORIAL COORDINATES CALL NOYAU(N2DIM,KDIM,MDIM,LDIM,L2DIM, & NFAC,KFAC,NUMIM,NBASE,NITER,NCLAS,NKLA, & Q(N1),Q(NK),Q(ND),Q(NU),Q(NJV),Q(NJW),Q(NIDK),Q(NCI),Q(NGT), & Q(NNUM),Q(NLA),Q(NLB),Q(NIV),Q(NIW),Q(NV),Q(NW), & Q(NNT),Q(NVAL),Q(NPK),Q(NNO) ,LUNI,LUNK,LUNDOC) C PRINT OUT LIST OF CLUSTER MEMBERS, LIST OF CENTERS OF GRAVITY, C AND RE-CLASSIFICATION LOOKUP TABLE REWIND(LUNK) READ(LUNK) NUMIM, NFAC, NKLA, KFAC NK = 1 NI = IPALIGN64(NK + NUMIM ) NPK = IPALIGN64(NI + NUMIM) NGT = IPALIGN64(NPK + NKLA ) NIV = IPALIGN64(NGT + NKLA * KFAC) C READS: LUNK CALL RGRI(NUMIM, KFAC, NKLA, & Q(NK),Q(NI),Q(NPK),Q(NGT),Q(NIV), LUNK,LUNI,NFAC) 9999 CLOSE(LUNK) CLOSE(LUNI) RETURN END