C++********************************************************************* C C FOUR1.F 08/22/96 C OPFILEC FEB 03 ARDEAN LEITH C MPI OCT 03 CHAO YANG C C ********************************************************************** C=* FROM: SPIDER - MODULAR IMAGE PROCESSING SYSTEM. AUTHOR: J.FRANK * C=* Copyright (C) 1985-2005 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--********************************************************************* SUBROUTINE FOUR1(MAXMEM) INCLUDE 'CMBLOCK.INC' INCLUDE 'CMLIMIT.INC' PARAMETER (NFUNC=12) CHARACTER(LEN=2),DIMENSION(NFUNC) :: FUNC CHARACTER(LEN=MAXNAM) :: FILNAM,FILNAM2 COMMON /COMMUN/FILNAM,FILNAM2 CHARACTER(LEN=1) :: NULL REAL, DIMENSION(6):: VALUES DATA FUNC/'FQ','FT', 'FF', 'FL', 'FP', & 'EF','PW', 'RF', 'CF', 'GF', 'RD','FD'/ DATA LUN1,LUN2,LUNF,LUN3 /21,22,23,24/ NULL = CHAR(0) MAXIM = 0 MAXIM2 = 0 IRTFLG = 0 C FQ, FT, FF, FL, FP, EF, PW, RF, CF, GF, RD, FD DO IFUNC = 1,NFUNC IF (FCHAR(1:2) .EQ. FUNC(IFUNC)) THEN GOTO ( 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12), (IFUNC) ENDIF ENDDO C OPERATION NOT IN FOUR1, RETURN TO SPIDER RETURN C ---------------- QUICK FILTERING ------------------------- 'FQ' 1 CALL FOUR1A RETURN C ---------------- FOURIER TRANSFORM ----------------------- 'FT' 2 IF (FCHAR(4:4) .EQ. 'R') THEN CALL FTR ELSE CALL FOUR1C ENDIF RETURN C ---------------- FOURIER FILTER -------------------------- 'FF' C APPLIES FILTERS TO 2-D OR 3-D FOURIER TRANSFORMS. 3 IF (FCHAR(4:7) .EQ. 'PLOT') THEN CALL FILTPLOT(MAXMEM) RETURN ENDIF CALL OPFILEC(0,.TRUE.,FILNAM,LUN1,'O',IFORM,NSAM,NROW,NSLICE, & MAXIM,'INPUT',.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) RETURN IF (IFORM.NE.-11 .AND. IFORM.NE.-12 .AND. & IFORM.NE.-21 .AND. IFORM.NE.-22) THEN CALL ERRT(2,'FF',NE) GOTO 9001 ENDIF IF (FCHAR(4:4) .EQ. 'S') THEN CALL ERRT(41,'FF S',NE) C CALL FSHADO(LUN1,NSAM,NROW) ELSEIF (FCHAR(4:4).EQ.'L' .OR. FCHAR(4:4).EQ.'B') THEN CALL ERRT(41,'FF L/B',NE) C CALL FILTB(LUN1,NSAM,NROW) ELSE NSAMO = NSAM-MOD(-IFORM,10) CALL OPFILEC(LUN1,.TRUE.,FILNAM,LUN2,'U',IFORM, & NSAM,NROW,NSLICE, & MAXIM,'OUTPUT',.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) THEN CLOSE(LUN1) CALL ERRT(4,'FF',NE) RETURN ENDIF CALL FFILTS(LUN1,LUN2,NSAM,NROW,NSLICE,NSAMO) ENDIF GOTO 9000 C ---------------- FOURIER LISTING ------------------------- 'FL' C LISTS MODULI AND PHASES OF 2-D FOURIER TRANSFORMATION. 4 CALL ERRT(41,'FL',NE) RETURN C ---------------- FOURIER INTERPOLATION ------------------- 'FP' 5 CALL FOUR1A_FP RETURN c --------- EXTRACT FOURIER -------------------------------- 'EF' C EXTRACTS CENTRAL SECTION FROM 3-D FOURIER UNDER ARBITRARY ANGLES. 6 CALL ERRT(41,'EF',NE) RETURN C ---------------------- POWER SPECTRUM -------------------------- 'PW' 7 CALL FOUR1B RETURN C -------------- R-FACTOR -------------------------------- 'RF' C COMPUTES VARIOUS MEASURES OF PROXIMITY BETWEEN 2 GIVEN C TRANSFORMS 8 IF(FCHAR(4:6).EQ.'3SN') THEN CALL SSNR3 ELSEIF(FCHAR(4:6).EQ.'3NN') THEN CALL SSNR3DNN ELSEIF (FCHAR(4:4) .EQ. '3') THEN CALL PR3D ELSEIF (FCHAR(4:5) .EQ. 'SN') THEN CALL SSNR ELSE CALL OPFILEC(0,.TRUE.,FILNAM,LUN1,'O',ITYPE1,NSAM,NROW, & NSLICE,MAXIM,'FIRST INPUT',.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) RETURN IF (ITYPE1 .GT. 1) THEN CALL ERRT(2,'RF',NE) GOTO 9001 ENDIF C INPUT SECOND IMAGE CALL OPFILEC(0,.TRUE.,FILNAM2,LUN2,'O',ITYPE2,NSAM2,NROW2, & NSLICE2,MAXIM2,'SECOND INPUT',.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9001 IF (ITYPE1 .NE. ITYPE2) THEN CALL ERRT(2,'RF',NE) GOTO 9000 ELSEIF (NSAM.NE.NSAM2 .OR. NROW.NE.NROW2) THEN CALL ERRT(1,'RF',NE) GOTO 9000 ENDIF CALL RFACTSDO(LUN1,LUN2,NSAM,NROW,NSLICE, & NSAM2,NROW2,NSLICE2, ITYPE1,ITYPE2) ENDIF RETURN C ---------------- CONSTRUCT FOURIER ----------------------- 'CF' C CONSTRUCT FOURIER FILE FROM AMPLITUDES & PHASES OF REFLECTIONS. 9 CALL ERRT(41,'CF',NE) RETURN C ---------------- GENERAL FILTER -------------------------- 'GF' C FOR QUASI-OPTICAL FOURIER FILTRATION 10 CALL ERRT(41,'GF',NE) RETURN C ---------------- REDUCE TRANSFORM ------------------------ 'RD' C GENERATES REDUCED FOURIER TRANSFORM FROM MASKED FOURIER 11 CALL ERRT(41,'RD',NE) RETURN C FILTER ACCORDING TO A DOCUMENT FILE ---------------------- 'FD' 12 IF (FCHAR(4:4) .EQ. 'R') THEN CALL RADWEIGHT ELSE CALL OPFILEC(0,.TRUE.,FILNAM,LUN1,'O',IFORM,NSAM,NROW,NSLICE, & MAXIM,'INPUT',.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) RETURN MAXIM = 0 CALL OPFILEC(LUN1,.TRUE.,FILNAM,LUN2,'U',IFORM, & NSAM,NROW,NSLICE, MAXIM,'OUTPUT',.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) RETURN CALL FILTDOC(LUN1,LUN2,NSAM,NROW,NSLICE,IFORM) ENDIF 9000 CLOSE(LUN2) 9001 CLOSE(LUN1) RETURN END