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 C----------------------------------=*=---------------------------------- C COPYRIGHT 1986 - 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 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 - COUPE C - CLULST C SCLASSI - RGRI C 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 .LT. 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 (/,2X,'FACTORS USED: 1...',I3) WRITE(NDAT, 2150) NBASE, NITER, NCLAS, NKLA 2150 FORMAT(/,2X,'NBASE:',I6,4X,'NITER:',I6,4X, & 'NCLAS:',I6,4X,'NKLA: ',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) + & 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 NKLAS = 1 + NUMIM ND = NKLAS + NUMIM NU = ND + MDIM NJV = NU + KDIM NJW = NJV + KDIM NIDK = NJW + KDIM NCI = NIDK + NKLA NGT = NCI + NFAC NNUM = NGT + N2DIM * KFAC NLA = NNUM + LDIM NLB = NLA + LDIM NIV = NLB + LDIM NIW = NIV + LDIM NV = NIW + LDIM NW = NV + LDIM NNT = NW + LDIM NVAL = NNT + L2DIM NPK = NVAL + L2DIM NNO = NPK + L2DIM NFIN = 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 THEIR FACTORIAL COORDINATES * CALL NOYAU(N2DIM,KDIM,MDIM,LDIM,L2DIM, & NFAC,KFAC,NUMIM,NBASE,NITER,NCLAS,NKLA, & Q(1),Q(NKLAS),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 = NK + NUMIM NPK = NI + NUMIM NGT = NPK + NKLA NIV = 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