C C++********************************************************************* C C UTIL1.F TITLE PROCESSING MODIFIED NOV 87 ARDEAN LEITH C LONG FILE NAMES ADDED DEC 88 ARDEAN LEITH C ALTERED 4/21/93 MAHIEDDINE LADJADJ C ALTERED 8/25/93 JING SU C LI COMMAND REWRITTEN 8/30/96 ARDEAN LEITH C TT COMMAND REWRITTEN 6/28/97 ARDEAN LEITH C ST PARAMETERS ALTERED SEPT 98 ARDEAN LEITH C 'TT COP' ADDED JUNE 99 ARDEAN LEITH C 'CA SM' ALTERED AUG 99 ARDEAN LEITH C 'TF CTS' ALTERED NOV 00 HAIXIAO GAO C 'TF CTF' REMOVED JAN 01 ARDEAN LEITH C 'TF CRF' ADDED JAN 11 Paul Penczek C 'TF ECTF' ADDED JUL 31 Paul Penczek C 'TF ECTF' --> 'TF ED' JUN 02 Bill Baxter C 'HI E' ADDED FEB 03 ARDEAN LEITH C OPFILEC FEB 03 ARDEAN LEITH C 'HI J' ADDED MAR 03 ARDEAN LEITH C 'PK DR' ADDED MAR 03 BIMAL RATH C 'CA' REWRITE SEP 03 ARDEAN LEITH C 'TF EA' REMOVED NOV 03 PAUL PENCZEK C 'TF ED' REPLACED NOV 03 PAUL PENCZEK C 'CA SMI' ADDED JAN 04 ARDEAN LEITH C 'HI J' VMIN, VMAX FEB 04 ArDean Leith C TRAFC & TRAFCT MERGED MAR 04 ArDean Leith C ~7 REPLACES IRTFLG APR 04 ARDEAN LEITH C 'PK 3R' NOV 04 ARDEAN LEITH C 'TF SIM' ADDED NOV 07 BIMAL RATH C 'TF LM4'ADDED MAR 06 ZHONG HUANG C 'HI DOC' DUPLICATES HI D MAR 06 ARDEAN LEITH C 'FI H' ON STACK HEADER OCT 10 ARDEAN LEITH C 'TF COR' NOV 10 ARDEAN LEITH C 'FI H' INQUIREHEAD ARGS NOV 10 ARDEAN LEITH C 'ST H' NOV 10 ARDEAN LEITH C 'FI H' NO FILE BUG JAN 11 ARDEAN LEITH C CASE JAN 11 ARDEAN LEITH C ********************************************************************** C=* * C=* This file is part of: SPIDER - Modular Image Processing System. * C=* SPIDER System Authors: Joachim Frank & ArDean Leith * C=* Copyright 1985-2011 Health Research Inc., * C=* Riverview Center, 150 Broadway, Suite 560, Menands, NY 12204. * C=* Email: spider@wadsworth.org * C=* * C=* SPIDER 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=* SPIDER 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=* You should have received a copy of the GNU General Public License * C=* along with this program. If not, see * C=* * C ********************************************************************** C C UTIL1(MAXDIM,IRTRET) C C PURPOSE: ORIGINALLY A DRIVER FOR ROUTINES REQUIRING ONLY ONE FILE C C PARAMETERS: MAXDIM MAX LENGTH OF COMMON BUFFER C C23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 C--********************************************************************* SUBROUTINE UTIL1(MAXDIM,IRTRET) INCLUDE 'CMBLOCK.INC' INCLUDE 'CMLIMIT.INC' INTEGER, PARAMETER :: NFUNC=19 CHARACTER(LEN=2) :: FUNC(NFUNC) CHARACTER(LEN=MAXNAM) :: FILNAM,CLINE LOGICAL :: DOCPRNT,TERMPRNT CHARACTER(LEN=1) :: NULL C DATA FUNC/'DE', 'DU', 'FI', 'HI', 'LI', C & 'MO', 'PK', 'RA', 'RN', 'TT', C & 'ST', 'TF', 'FS', 'CA', 'GR', C & 'CG', 'CV', 'CL', 'HD'/ NULL = CHAR(0) IRTRET = 0 IRTFLG = 0 LUN1 = 8 LUN2 = 12 LUN3 = 7 LUN4 = 9 LUN5 = 13 LUNDOC = 80 LUNXM = 81 MAXIM = 0 MAXIM2 = 0 CALL SET_MPI(icomm,mypid,mpierr) ! SET MYPID SELECT CASE(FCHAR(1:2)) CASE ('DE') ! ----------------------------------------------- 'DE' 1 CALL DELETF(FILNAM,LUN1) RETURN C DO NOT USE GOTO 9000 HERE AS IT CAUSES DOUBLE CLOSING ERROR CASE ('DU') ! ---------------------------------------------- 'DU' C OPEN INPUT FILE, NO FOURIER INPUT ALLOWED 2 CALL OPFILEC(0,.TRUE.,FILNAM,LUN1,'O',ITYPE, & NSAM,NROW,NSLICE, & MAXIM,'INPUT',.FALSE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 C DETERMINE HSIG & HMODE CALL HIST(LUN1,0,0,NSAM,NROW,NSLICE,HMIN,HMAX,HSIG,HMODE) C REMOVE OUT-LIERS CALL DUST(LUN1,NSAM,NROW,NSLICE,HSIG,HMODE,IRTFLG) GOTO 9000 CASE ('FI') ! ----------- FILE INFO ------------------------ 'FI' 3 IF (FCHAR(4:4) .EQ. 'A') THEN C FILE INFO FOR MULTIPLE FILES CALL FILERD(FILNAM,NLETI,NULL,'FILE INFO. ON',IRTFLG) IF (IRTFLG .EQ. -1) GOTO 9000 CALL FILGEN(FILNAM,NLETI,LUN1) ELSEIF (FCHAR(4:4) .EQ. 'H') THEN ! -------------------- 'FI H' C RETRIEVE HEADER VARIABLE CONTENTS FROM SINGLE FILE MAXIM = 2 ! ALLOWS QUERY ON STACK HEADER CALL OPFILEC(0,.TRUE.,FILNAM,LUN1,'O',ITYPE, & NSAM,NROW,NSLICE, & MAXIM,'RETRIEVE HEADER VALUES FROM',.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) THEN C FILE NOT FOUND CALL ERRT(101,'OPENING FILE',IDUM) GOTO 9000 ENDIF CALL INQUIREHEAD(LUN1,NSAM,NROW,NSLICE,IRTFLG) ELSEIF (FCHAR(4:4) .EQ. 'N') THEN ! -------------------- 'FI N' C FILE INFO FOR SINGLE FILE, NO ERROR STOP IF NOT FOUND CALL OPFILEC(0,.TRUE.,FILNAM,LUN1,'Z',ITYPE, & NSAM,NROW,NSLICE, & MAXIM,'FILE INFO. ON',.TRUE.,IRTFLG) IF (IRTFLG .EQ. 0) THEN C FILE FOUND CALL FILDAT(LUN1,NSAM) ELSE C FILE NOT FOUND, ZERO REG. FOR NSAM, NROW ... CALL REG_SET(1,0.0,NULL,IRTFLG) CALL REG_SET(2,0.0,NULL,IRTFLG) CALL REG_SET(3,0.0,NULL,IRTFLG) CALL REG_SET(4,0.0,NULL,IRTFLG) CALL REG_SET(7,0.0,NULL,IRTFLG) ENDIF ELSEIF (FCHAR(4:4) .EQ. 'T') THEN ! -------------------- 'FI T' C TEST OF FILENAME SUBSTITUTION MECHANISM CALL FILERD(FILNAM,NLET1,NULL,'TEST FILE NAME',IRTFLG) IF (IRTFLG .EQ. -1) RETURN IRTFLG = -999 CALL RDPRMC(CLINE,NLET2,.TRUE.,'CORRECT NAME', & NULL,IRTFLG) IF (IRTFLG .EQ. 0 .AND. & FILNAM(1:NLET1) .NE. CLINE(1:NLET2)) THEN WRITE(NOUT,*) '*** ERROR IN FILENAME FORMATION!!!' WRITE(NOUT,9065) FILNAM(1:NLET1),CLINE(1:NLET2) 9065 FORMAT( '*** GOT: ',A,' -- SHOULD BE: ',A/) CALL ERRT(100,'DRIV1',NE) ENDIF ELSE ! --------------------------------------------------- 'FI' C FILE INFO FOR SINGLE FILE, ERROR IF NOT FOUND CALL FILERD(FILNAM,NLETI,NULL,'FILE INFO. ON',IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 IF (FILNAM(1:1) .EQ. '?') THEN C OLD FASHIONED "FR" SETTING WRITE(NOUT,*) & '*** OBSOLETE: PLEASE USE OPERATION NOW' IRTRET = 1 BACKSPACE(NIN) IBCNT = IBCNT - 1 RETURN ENDIF ILOCAT = INDEX(FILNAM,'@') IF (FCHAR(4:4) .EQ. '[' .AND. ILOCAT .EQ. NLETI) THEN C NEED HEADER LOCATION MAXIM = 2 ENDIF IF (FCHAR(4:4) .EQ. 'X' .AND. ILOCAT .EQ. NLETI) THEN C NEED HEADER LOCATION MAXIM = 2 ENDIF CALL OPFILEC(0,.FALSE.,FILNAM,LUN1,'O',ITYPE, & NSAM,NROW,NSLICE,MAXIM,' ',.TRUE.,IRTFLG) IF (IRTFLG .EQ. 0) CALL FILDAT(LUN1,NSAM) ENDIF GOTO 9000 CASE ('HI') ! -------------- HISTOGRAM --------------------- 'HI' 4 IF (FCHAR(4:6) .EQ. 'DOC') THEN CALL ERRT(101,"USE OPERATION: 'HD D'",IDUM) GOTO 9000 ENDIF C OPEN INPUT FILE, FOURIER NOT ALLOWED CALL OPFILEC(0,.TRUE.,FILNAM,LUN1,'O',ITYPE1, & NSAM1,NROW1,NSLICE, & MAXIM,'INPUT',.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 IF (FCHAR(4:4) .EQ. 'E') THEN C ENTROPY HISTOGRAM CALL ENTROP(LUN1,NSAM1,NROW1,NSLICE,ENTROPY,IRTFLG) ELSEIF (FCHAR(4:4) .EQ. 'J') THEN C JOINT HISTOGRAM FOR MUTUAL SHARED INFORMATION C MAKE SURE STATISTICS ARE CURRENT FMIN1 = FMIN FMAX1 = FMAX IF (IMAMI .NE. 1 .AND. ITYPE1 .GE. 0) & CALL NORM3(LUN1,NSAM1,NROW1,NSLICE,FMAX1,FMIN1,AV) C OPEN SECOND INPUT FILE, FOURIER ALLOWED CALL OPFILEC(0,.TRUE.,FILNAM,LUN2,'O',ITYPE2, & NSAM2,NROW2,NSLICE2, & MAXIM2,'SECOND INPUT',.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 8999 CALL SIZCHK(UNUSED,NSAM1,NROW1,NSLICE, 0, & NSAM2,NROW2,NSLICE2,0,IRTFLG) IF (IRTFLG .NE. 0) GOTO 8999 C MAKE SURE STATISTICS ARE CURRENT FMIN2 = FMIN FMAX2 = FMAX IF (IMAMI .NE. 1.AND. ITYPE1 .GE. 0) & CALL NORM3(LUN2,NSAM2,NROW2,NSLICE2,FMAX2,FMIN2,AV) IF (ITYPE1 .GE. 0) THEN C NOT FOURIER CALL RDPRI1S(NBINS,NOT_USED, & 'ENTER NUMBER OF BINS IN HISTOGRAM',IRTFLG) IF (NBINS .LT. 1) THEN CALL ERRT(1,'UTIL1',IDUM) GOTO 8999 ENDIF WRITE(NOUT,*) ' FIRST IMAGE RANGE: ',FMIN1,'.....',FMAX1 WRITE(NOUT,*) ' SECOND IMAGE RANGE: ',FMIN2,'.....',FMAX2 VMIN = MIN(FMIN1,FMIN2) VMAX = MAX(FMAX1,FMAX2) CALL RDPRM2S(VMIN,VMAX,NOT_USED,'HISTOGRAM RANGE',IRTFLG) IF (IRTFLG .NE. 0) RETURN CALL JOHIST(LUN1,LUN2,NSAM1,NROW1,NSLICE,NBINS, & FMIN1,FMAX1,FMIN2,FMAX2,VMIN,VMAX,IRTFLG) ELSE C FOURIER NBINSA = 128 NBINSP = 360 CALL RDPRIS(NBINSA,NBINSP,NOT_USED, & 'ENTER NUMBER OF AMPLITUDE & PHASE BINS IN HISTOGRAM', & IRTFLG) IF (NBINSA .LT. 1 .OR. NBINSP .LT. 1) THEN CALL ERRT(1,'UTIL1',IDUM) GOTO 8999 ENDIF CALL JOHISTF(LUN1,LUN2,NSAM1,NROW1,NSLICE, & NBINSA,NBINSP,IRTFLG) ENDIF GOTO 8999 ELSEIF (FCHAR(4:4) .NE. 'M') THEN C NORMAL HISTOGRAM CALL HIST(LUN1,0,LUN2,NSAM1,NROW1,NSLICE,HMIN,HMAX, & HSIG,HMODE) ELSE C HISTOGRAM UNDER MASK --------------------------------- 'HI M' IFORM1 = IFORM CALL OPFILEC(0,.TRUE.,FILNAM,LUN2,'O',ITYPE, & NSAM2,NROW2,NSLICE2,MAXIM2, & 'MASK',.FALSE.,IRTFLG) IFORM2 = IFORM IF (IRTFLG .EQ. -1) THEN CLOSE(LUN1) GOTO 4 ELSEIF (IRTFLG .NE. 0) THEN GOTO 9000 ENDIF C IMAGES NUST HAVE SAME DIMENSIONS CALL SIZCHK(UNUSED,NSAM1,NROW1,NSLICE, IFORM1, & NSAM2,NROW2,NSLICE2,IFORM2,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 CALL HIST(LUN1,LUN2,LUN3,NSAM1,NROW1,NSLICE,HMIN,HMAX, & HSIG,HMODE) CLOSE(LUN2) ENDIF GOTO 9000 CASE ('HD') ! --- HISTOGRAM OF A DOCUMENT FILE COLUMN ------ 'HD' 20 CALL HISD(LUN3) CLOSE(LUN3) GOTO 9000 CASE ('LI') ! ---------------------------------------------- 'LI' C CHECK FOR 'LI R' WHICH DOES NOT USE INPUT FILE JUST REGISTERS 5 IF (FCHAR(4:4) .EQ. 'R') THEN C FOR 'LI R', 'LI RT', 'LI RD' (listregs.f) CALL ERRT(101,'OPERATION NO LONGER SUPPORTED',NE) GOTO 9000 ENDIF C NEED INPUT FILE, USE ~7 TO ALLOW STACK HEADER ACCESS CALL OPFILEC(0,.TRUE.,FILNAM,LUN1,'O',ITYPE, & NSAM,NROW,NSLICE, & MAXIM,'INPUT~7',.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) RETURN IF (FCHAR (4:5) .EQ. '2D') THEN C UNDOCUMENTED COMMAND 'LI 2D' CALLED LISTIM CALL ERRT(101,'THIS OPERATION NO LONGER SUPPORTED',NE) ELSE DOCPRNT = .FALSE. IF (FCHAR(4:4) .EQ. 'D') DOCPRNT = .TRUE. TERMPRNT = .FALSE. IF (FCHAR(4:4) .EQ. 'T') TERMPRNT = .TRUE. CALL REG_GET_USED(NSEL_USED) IF (NSEL_USED .GT. 0) THEN C SINGLE NUMBER (REGISTER) OPTION: CALL LISTITR(FILNAM,LUN1,NSAM,NROW,NSLICE) ELSE CALL LISTIT(FILNAM,LUN1,NSAM,NROW,NSLICE,DOCPRNT,TERMPRNT) ENDIF ENDIF GOTO 9000 CASE ('MO') ! ---------------- MODEL ------------------------ 'MO' 6 NSAM2 = 0 NROW2 = 0 NSLICE = 1 IFORM = 1 IF (FCHAR(4:4) .EQ. '3') THEN NSLICE = 0 IFORM = 3 ENDIF CALL OPFILEC(0,.TRUE.,FILNAM,LUN1,'U',IFORM, & NSAM2,NROW2,NSLICE, & MAXIM,'OUTPUT',.TRUE.,IRTFLG) IF (IRTFLG .NE. 0 .AND. FILNAM(1:1) .NE. '*') GOTO 9000 IF (FCHAR(4:4) .EQ. '3') THEN IF (FCHAR(5:5) .EQ. 'H') THEN CALL ERRT(101,'OPERATION NO LONGER SUPPORTED',IDUM) GOTO 9000 ELSE C FOR 'MO 3' CALL MODEL3(LUN1,LUN2,FILNAM,NSAM2,NROW2,NSLICE) CLOSE(LUN2) ENDIF ELSE C FOR 'MO' CALL MODEL(LUN1,NSAM2,NROW2) ENDIF GOTO 9000 CASE ('PK') ! ---------------- PEAK SEARCH ----------------- 'PK' CALL OPFILEC(0,.TRUE.,FILNAM,LUN1,'O',ITYPE, & NSAM1,NROW1,NSLICE1, & MAXIM,'INPUT',.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 FMAX1 = FMAX IF (FCHAR(4:4) .EQ. 'M') THEN IF (IMAMI.NE.1) & CALL NORM3(LUN1,NSAM1,NROW1,NSLICE1,FMAX1,FMIN1,AVR1) CALL SPEAKM(LUN1,NSAM1,NROW1,NSLICE1,FMAX1) ELSEIF (FCHAR(4:4) .EQ. '3') THEN CALL SPEAK3(LUN1,NSAM1,NROW1,NSLICE1,FCHAR(5:5),LUNDOC) ELSE CALL RDPRMI(ML,NOR,NOT_USED, & 'ENTER NUMBER OF PEAKS, CENTER ORIGIN OVERRIDE (0/1)') IF (ML .LT. 1) ML = 1 IF (FCHAR(4:4).EQ. 'C' .OR. FCHAR(5:5).EQ.'C') THEN CALL SPEAKC(FILNAM,LUN1,NSAM1,NROW1,MAXDIM,FCHAR(4:4), & LUNDOC,ML,NOR) ELSEIF ( FCHAR(5:5).EQ.'R') THEN CALL SPEAKR(FILNAM,LUN1,NSAM1,NROW1,MAXDIM,FCHAR(4:4), & LUNDOC,ML,NOR) ELSE CALL SPEAK(FILNAM,LUN1,NSAM1,NROW1,MAXDIM,FCHAR(4:4), & LUNDOC,ML,NOR) ENDIF ENDIF GOTO 9000 CASE ('RA') ! ------------- RAMP --------------------------- 'RA' CALL OPFILEC(0,.TRUE.,FILNAM,LUN1,'O',ITYPE, & NSAM,NROW,NSLICE, & MAXIM,'INPUT',.FALSE.,IRTFLG) IF (IRTFLG .NE. 0) RETURN IF (ITYPE .NE. 1) THEN CALL ERRT(2,'RAMP',NE) GOTO 9001 ENDIF CALL OPFILEC(LUN1,.TRUE.,FILNAM,LUN2,'U',ITYPE, & NSAM,NROW,NSLICE, & MAXIM2,'OUTPUT',.FALSE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 CALL RAMP_P(LUN1,LUN2,NSAM,NROW,NOUT) GOTO 8999 CASE ('RN') ! ----------------- RENAME ---------------------- 'RN' CALL ERRT(101,'OPERATION NO LONGER SUPPORTED',NE) GOTO 9001 CASE ('TT') ! -----------CHANGE TITLE---------------------- 'TT' IF (FCHAR(4:4) .EQ. 'C') THEN C OPEN THE FILE THAT CONTAINS DESIRED TITLE CALL OPFILEC(0,.TRUE.,FILNAM,LUN1,'O',ITYPE, & NSAM1,NROW1,NSLICE1, & MAXIM,'TITLE SOURCE',.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9001 ENDIF C OPEN THE FILE THAT RECEIVES TITLE CALL OPFILEC(0,.TRUE.,FILNAM,LUN2,'O',ITYPE, & NSAM1,NROW1,NSLICE1, & MAXIM,'OUTPUT',.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 C GET NEW TITLE HERE IF (FCHAR(4:4) .EQ. 'C') THEN CALL LUNGETTITLE(LUN1,CTIT,LENTIT,IRTFLG) ELSE CALL RDPRMC(CTIT,LENTIT,.FALSE.,'NEW TITLE',NULL,IRTFLG) ENDIF IF (IRTFLG .NE. 0) GOTO 9000 C TITLE ALTERATION CAN PROCEED NOW CALL TITLE(LUN2,CTIT,LENTIT,.TRUE.,IRTFLG) CLOSE(LUN2) GOTO 9000 CASE ('ST') ! ------ SET BUFFER LOCATIONS ------------------ 'ST' C DISP OF "Z" ALLOWS CORRECTING STACK ERROR IF (FCHAR(4:4) .EQ. 'H') THEN MAXIM = 2 ! ALLOWS OPENING OVERALL STACK HEADER CALL OPFILEC(0,.TRUE.,FILNAM,LUN1,'Z',ITYPE, & NSAM,NROW,NSLICE, & MAXIM,'SET HEADER VALUES IN',.TRUE.,IRTFLG) C SET HEADER VARIABLES IN FILE IF (IRTFLG .EQ. 0) & CALL SETHEAD(LUN1,NSAM,NROW,NSLICE,IRTFLG) ELSE CALL OPFILEC(0,.TRUE.,FILNAM,LUN1,'Z',ITYPE, & NSAM,NROW,NSLICE, & MAXIM,'INPUT~7',.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) RETURN C SET LABEL VALUES TO SOLICITED INPUT CALL SETVAL(LUN1,NSAM,NROW,NSLICE) ENDIF GOTO 9000 CASE ('TF') ! ------------TRANSFER FUNCTION ---------------- 'TF' LENF = LNBLNK(FCHAR(4:)) LENCOMMA = INDEX(FCHAR(4:4+LENF-1),',') IF (LENCOMMA .GT. 1) LENF = LENCOMMA-1 LENBLANK = INDEX(FCHAR(4:4+LENF-1),' ') IF (LENBLANK .GT. 1) LENF = LENBLANK-1 SELECT CASE(FCHAR(4:4+LENF-1)) CASE ('D') CALL TRAFD(LUN1) CASE ('C') CALL TRAFC(LUN1,.FALSE.) CASE ('C3') CALL TRAFC3(LUN1) CASE ('DDF') CALL DEFOCUS(IRTFLG) CASE ('DNS') CALL NOISE(IRTFLG) CASE ('DEV') CALL ENVELOPE(IRTFLG) CASE ('CT') CALL TRAFC(LUN1,.TRUE.) CASE ('CT3') CALL TRAFCT3(LUN1) CASE ('CTS') CALL RCTFSS(LUN1,LUN2) CASE ('SIM') CALL TRAFSIM(LUN1) CASE ('CRF') CALL TFCRF CASE ('ED') CALL TFED CASE ('L') CALL TRAFL CASE ('LM4') CALL TFLM4 CASE ('RCTF') CALL RCTF CASE ('COR') CALL RCTFONE(LUN1) CASE ('SNR') CALL TFSNR CASE DEFAULT CALL TRAF(LUN1) END SELECT GOTO 9000 CASE ('FS') ! ------------- FILE STATISTICS ---------------- 'FS' CALL QSTAT(LUN1,LUN2,LUNDOC,LUNXM) CLOSE(LUN2) GOTO 9000 CASE ('CA') ! ------------ CLUSTER ANALYSIS ------------- 'CA' SELECT CASE(FCHAR(4:)) CASE ('S') C FACTOR MAP CALCULATION CALL JPMSK1() CASE ('SM','SME') C FACTOR MAP PLOT CALL SGRAF(LUN1,LUN2,LUN3,LUN4) CLOSE(LUN2) CASE ('SMI') C INACTIVE FACTOR MAP PLOT CALL JPMSK3(LUN1,LUN2,LUN3,LUN4,LUN5) CASE ('SR', 'SRD', 'SRI', 'SRA', 'SRE') C IMAGE RECONSTITUTION CALL JPMSK2(LUN1,LUN2,LUN3,LUN4,LUN5) CLOSE(LUN3) CLOSE(LUN4) CLOSE(LUN5) CASE ('VIS') C VISUAL MAP CREATION CALL VISMAP(LUN1,LUN2,LUN3,LUN4) CASE DEFAULT C 'CA E', 'CA ES', removed PAP 10/05/99 CALL ERRT(101,'UNIDENTIFIED OPERATION',IDUM) END SELECT GOTO 8999 CASE ('GR') ! --------- GRAPH A ROW IN RESULTS FILE -------- 'GR' 16 CALL OPFILEC(0,.TRUE.,FILNAM,LUN1,'O',ITYPE, & NSAM1,NROW1,NSLICE, MAXIM,'INPUT',.FALSE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 CALL GRAPHP(LUN1,NSAM1,NROW1) GOTO 9000 CASE ('CG') ! ------------ CENTER OF GRAVITY ---------------- 'CG' C 3-D CENTER OF GRAVITY AND RADIUS OF GYRATION 17 IF (FCHAR(4:4) == 'S' .OR. FCHAR(4:5) == 'PH') THEN CALL CENT GOTO 9001 ENDIF CALL CENGR3(LUN1) GOTO 9000 CASE ('CV') ! ---------------------------------------------- 'CV' C POCS PROGRAMS (06/05/90), MODULAR POCS PROGRAMS: (12/5/91) M.R. IF (FCHAR(4:8) .EQ. 'REPL2') THEN C tdfrepl uses old Fourier format and was disabled CALL ERRT(41,'CV REPL2',NE) C CALL TDFREPL(LUN1,LUN2,LUN3) ELSE CALL MRREPLACE(LUN1,LUN2) ENDIF GOTO 9000 CASE ('CL') ! ---------------------------------------------- 'CL' SELECT CASE (FCHAR(4:5)) CASE('KM') ! KMEANS CLUSTERING CALL SUBKMNS(LUN1,LUN2) CASE('HC') ! HIERARCHICAL CLUSTERING CALL HCLS(LUN1,LUN2,LUN3) CASE('HD') ! HIERARCHICAL CLUSTERING, CALCULATE CLASSES CALL HDLS(LUN1,LUN2) CASE('HE') ! HIERARCHICAL CLUSTERING, CREATE DOC FILE CALL HELS(LUN1,LUN2) CASE('CL') ! HIERARCHICAL CLUSTERING CALL SCLASSI(LUN1,LUN2,LUN3) CLOSE(LUN3) END SELECT RETURN END SELECT C -------------------------------------------------------- END 8999 CLOSE(LUN2) 9000 CLOSE(LUN1) 9001 CONTINUE END