C++********************************************************************* C C UTIL4.F ADDED IQ SEP 97 ARDEAN LEITH C ADDED IQ SYNC JUN 99 ARDEAN LEITH C ADDED NEG JUN 99 ARDEAN LEITH C NEG BUG FEB 01 ARDEAN LEITH C 'AP MQ I' APR 01 ARDEAN LEITH C ADDED 'AP RQ' OCT 01 HAIXIAO GAO C ADDED 'IQ W' MAR 02 ARDEAN LEITH C ADDED 'IQ PAR' JUN 02 ARDEAN LEITH C ADDED 'IQ GONE' AUG 02 ARDEAN LEITH C ADDED 'MS' VOLUMES AUG 02 ARDEAN LEITH C ADDED 'MS I' JAN 03 ARDEAN LEITH C OPFILEC FEB 03 ARDEAN LEITH C REMOVED 'AP MR' APR 03 ARDEAN LEITH C USED APMASTER AUG 03 ARDEAN LEITH C MPI FEB 04 CHAO YANG C ADDED 'IQ PID' JAN 05 ARDEAN LEITH C ADDED 'IQ R' NOV 05 ARDEAN LEITH C 'MS IF' IFORM BUG FEB 07 ARDEAN LEITH C 'AP C' JUN 08 ARDEAN LEITH C REMOVED VAR3* NO MAN MAY 09 ARDEAN LEITH C 'AP SCC' OUT OF APMASTER AUG 08 ARDEAN LEITH C ********************************************************************** C=* This file is part of: * C=* SPIDER - Modular Image Processing System. Author: J. FRANK * C=* Copyright 1985-2009 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=* * 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 UTIL4 DRIVER FOR CERTAIN ROUTINES C C--********************************************************************* SUBROUTINE UTIL4(MAXDIM) INCLUDE 'CMBLOCK.INC' INCLUDE 'CMLIMIT.INC' CHARACTER (LEN=MAXNAM) :: CID,CORRECT,FILNAM CHARACTER(LEN=1) :: NULL,MODE LOGICAL :: MAKEREFFILE,USEREFFILE,FLIP,FOLD LOGICAL :: GETANS,UPPER,WANTSUB,SAYPRMT,SAYANS LOGICAL :: STRIP,ENDATSEMI INTEGER getpid DATA LUN,LUN1/10,11/ NULL = CHAR(0) MAXIM1 = 0 IRTFLG = 0 IF (FCHAR(1:2) .EQ. 'AP') THEN C OPERATION AP ------------------------------------------- AP IF (FCHAR(4:5) .EQ. 'RA') THEN CALL FALB ELSEIF (FCHAR(4:5).EQ. 'SA') THEN CALL SAQB ELSEIF(FCHAR(4:5) .EQ. 'SR') THEN CALL GALI ELSEIF (FCHAR(4:5) .EQ. 'MS') THEN CALL MULTISHIFT ELSEIF (FCHAR(4:5) .EQ. 'CA') THEN WRITE(NOUT,91) 91 FORMAT( & ' OBSOLETE OPERATION, NEXT TIME PLEASE USE: ',/) CALL HALI('A') ELSEIF (FCHAR(4:5) .EQ. 'CM') THEN WRITE(NOUT,91) CALL HALI('M') ELSEIF (FCHAR(4:4) .EQ. 'C') THEN CALL HALI('C') ELSEIF (FCHAR(4:6) .EQ. 'SCC') THEN C 2D & 3D PADDED, CROSS CORRELATION MULTI-REF SHIFT ALIGNMENT CALL APSCC() ELSEIF (FCHAR(4:5) .EQ. 'RH') THEN MODE = 'H' CALL APMASTER(MODE,'RD') ELSEIF (FCHAR(4:5) .EQ. 'MH') THEN MODE = 'H' CALL APMASTER(MODE,'MD') ELSEIF (FCHAR(4:5) .EQ. 'NH') THEN MODE = 'H' CALL APMASTER(MODE,'RN') ELSE MODE = 'F' CALL APMASTER(MODE,FCHAR(4:)) ENDIF ELSEIF(FCHAR(1:2) .EQ. 'HF') THEN C OPERATION HF -------------------------------------------- HF CALL HF ELSEIF(FCHAR(1:2) .EQ. 'AT') THEN C AUTOMATIC PARTICULE PICKING.----------------------------- AT IF (FCHAR(4:5) .EQ. 'IT') THEN CALL DOCS1(MAXDIM) ELSEIF(FCHAR(4:5) .EQ. 'PK') THEN CALL OPFILEC(0,.TRUE.,FILNAM,LUN1,'O',ITYPE, & NSAM,NROW,NSLICE,MAXIM1,'INPUT',.FALSE.,IRTFLG) IF (IRTFLG .NE. 0) RETURN CALL ATPK(LUN1,NSAM,NROW,NSLICE) CLOSE(LUN1) ELSEIF(FCHAR(4:5) .EQ. 'MC') THEN CALL ATMC ELSEIF(FCHAR(4:5) .EQ. 'SA') THEN CALL ATSA(MAXDIM) ELSEIF(FCHAR(4:5) .EQ. 'WN') THEN CALL ATWN(MAXDIM) ENDIF ELSEIF(FCHAR(1:4) .EQ. 'MS I') THEN C MAKE INLINE OR FILE BASED INDEXED STACK --------------- MS I C MAKE AN INLINE OR FILE BASED INDEXED FOURIER STACK----- MS IF MAXIM = -1 NSAM = 0 NSLICE = 0 IFORM = 0 IF (FCHAR(5:5) .EQ. 'F') IFORM = -1 CALL OPFILEC(0,.TRUE.,FILNAM,LUN,'N',IFORM,NSAM,NROW,NSLICE, & MAXIM,'NEW INDEXED STACK',.FALSE.,IRTFLG) CLOSE(LUN) ELSEIF(FCHAR(1:2) .EQ. 'MS') THEN C MAKE AN INLINE STACK ---------------------------------- MS C MAKE AN INLINE FOURIER STACK -------------------------- MS F C SOLICIT FILE NAME IF (FCHAR(4:4) .EQ. 'F') THEN CALL FILERD(FILNAM,NLET,NULL, & 'NEW INLINE FOURIER STACK',IRTFLG) IFORM = -1 ELSE CALL FILERD(FILNAM,NLET,NULL,'NEW INLINE STACK',IRTFLG) IFORM = 0 ENDIF IF (IRTFLG .NE. 0) RETURN IF (FILNAM(1:1) .NE. '_') THEN CALL ERRT(101,'NOT AN INLINE FILE',NE) RETURN ENDIF IF (NLET .LT. MAXNAM) FILNAM(NLET+1:) = CHAR(0) MAXIM = 1 NSAM = 0 NSLICE = 0 CALL OPFILEC(0,.FALSE.,FILNAM,LUN,'N',IFORM,NSAM,NROW,NSLICE, & MAXIM,' ',.FALSE.,IRTFLG) ELSEIF(FCHAR(1:2) .EQ. 'NE') THEN C NEGATE/INVERT AN IMAGE --------------------------------- NE C OPEN INPUT FILE MAXIM = 0 CALL OPFILEC(0,.TRUE.,FILNAM,LUN,'O',IFORM,NSAM,NROW,NSLICE, & MAXIM,'INPUT',.FALSE.,IRTFLG) IF (IRTFLG .NE. 0) RETURN C NEED FMAX & AV BELOW FMAXVAL = FMAX AVVAL = AV IF (IMAMI.EQ.0) CALL NORM3(LUN,NSAM,NROW,NSLICE, & FMAXVAL,FMINVAL,AVVAL) C OPEN OUTPUT FILE MAXIM = 0 CALLOPFILEC(LUN,.TRUE.,FILNAM,LUN1,'U',IFORM, & NSAM,NROW,NSLICE,MAXIM,'OUTPUT',.FALSE.,IRTFLG) IF (IRTFLG .NE. 0) THEN CLOSE(LUN) RETURN ENDIF C FOR NEG A (FCHAR ONLY HAS FIRST TWO LETTERS!!) IF (FCHAR(4:4) .NE. 'A') THEN C NEGATE THEN ADD ORIGINAL FMAX TO EACH VALUE CALL NEGATE(LUN,LUN1,NSAM,NROW,NSLICE,FMAXVAL) ELSE C NEGATE AROUND AVERAGE VALUE CALL NEGATI(LUN,LUN1,NSAM,NROW,NSLICE,AVVAL) ENDIF CLOSE(LUN) CLOSE(LUN1) RETURN ELSEIF(FCHAR(1:2) .EQ. 'IQ') THEN C INQUIRE SOMETHING -------------------------------------- IQ IF (FCHAR(4:5) .EQ. 'FI') THEN C SEE IF FILE EXISTS CALL INQUIREIF() ELSE IF (FCHAR(4:5) .EQ. 'SY') THEN C WAIT TILL FILE EXISTS CALL INQUIRESYNC(.FALSE.) ELSE IF (FCHAR(4:4) .EQ. 'G') THEN C WAIT TILL FILE GONE CALL INQUIRESYNC(.TRUE.) ELSE IF (FCHAR(4:4) .EQ. 'R') THEN C CHECK ON REGISTER VARIABLE CONTENTS CALL INQUIREREG(.TRUE.,.TRUE.,IRTFLG) ELSE IF (FCHAR(4:4) .EQ. 'A') THEN C CHECK ON ALLOCABLE MEMORY -------------------------- IQ A CALL RDPRM1S(GSTART,NOT_USED,'MEMORY DESIRED',IRTFLG) IF (IRTFLG .NE. 0) RETURN CALL INQUIREALLOC(GSTART,IMBYTES,.TRUE.,IRTFLG) RGOT = IMBYTES CALL REG_SET_NSEL(1,1,RGOT,0.0, 0.0, 0.0, 0.0, IRTFLG) ELSE IF (FCHAR(4:4) .EQ. 'W') THEN C CHECK ON MACHINE ARCHITECTURE CALL INQUIREARCH(LUN,FLIP,FOLD,IRTFLG) ELSEIF (FCHAR(4:6) .EQ. 'PID') THEN C TEST OF PARAMETER SUBSTITUTION MECHANISM --------- IQ PID #ifdef SP_NT CALL ERRT(101,'NOT AVAILABLE IN WINDOWS',NE) RETURN #if defined (SP_GFORTRAN) IPID = getpid() #else IPID = getpid(IPID) #endif WRITE(NOUT,92) IPID 92 FORMAT(' Current process id: ',I9,/) CALL REG_GET_USED(NSEL_USED) IF (NSEL_USED .GT. 0) THEN C OUTPUT TO SPIDER'S REGISTERS/REAL VARIABLES FPID = IPID CALL REG_SET_NSEL(1,1,FPID,FPID,FPID,FPID,FPID,IRTFLG) ENDIF #endif ELSEIF (FCHAR(4:4) .EQ. 'P') THEN C TEST OF PARAMETER SUBSTITUTION MECHANISM --------- IQ PAR C DO NOT UPPERCASE THE INPUT LINE, DO NOT STRIP AFTER ; GETANS = .TRUE. UPPER = .FALSE. WANTSUB = .TRUE. SAYPRMT = .TRUE. SAYANS = .TRUE. ENDATSEMI = .TRUE. STRIP = .TRUE. CALL RDPR('VARIABLE (WITH [])',NCHAR,CID,GETANS, & UPPER,WANTSUB,SAYPRMT,SAYANS,ENDATSEMI,STRIP,IRTFLG) IF (IRTFLG .NE. 0) RETURN IRTFLG = -999 CALL RDPRMC(CORRECT,NLET2,.TRUE.,'CORRECT VALUE', & NULL,IRTFLG) IF (IRTFLG .EQ. 0 .AND. & CID(1:NCHAR) .NE. CORRECT(1:NLET2)) THEN WRITE(NOUT,90) CID(1:NCHAR), CORRECT(1:NLET2) 90 FORMAT(' *** GOT: ',A,' SHOULD BE: ',A) CALL ERRT(101,'SYMBOL SUBSTITUTION INCORRECT',NE) ENDIF ELSE C UNKNOWN OPTION CALL ERRT(23,'UTIL4',NE) ENDIF ELSEIF(FCHAR(1:2) .EQ. 'VA') THEN C VARIANCE CALCULATION ---------------------------------- VA IF (FCHAR(4:4) .EQ. 'F') THEN C FOURIER SPACE VARIANCE CALCULATION ----------------- VA F CALL VARF ELSE CALL ERRT(101,'UNDOCUMENTED, BUGGY OPERATION REMOVED',NE) ENDIF ELSEIF(FCHAR(1:2) .EQ. 'SN') THEN C SNR FROM FSC -------------------------------------------- SN IF (FCHAR(4:5) .EQ. 'RB') THEN C APPROXIMATE SNR BY BUTTERWORTH FILTER ------------- SN RB CALL SNRB ELSEIF (FCHAR(4:5) .EQ. 'RF') THEN C CREATE BUTTERWORTH FILTER ------------------------ SN RF CALL SNRF ENDIF ENDIF END