C++********************************************************************* C C RCONV.F LONG FILENAMES JAN 89 al C USED OPFILE NOV 00 ARDEAN LEITH C OPFILEC FEB 03 ARDEAN LEITH 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 RCONV(LUN1,LUN2,LUNP,NSAM,NROW,NSLICE,MODE,MBUF) C LUN1 LOGICAL UNIT NUMBER OF FILE C LUN2 LOGICAL UNIT NUMBER OF FILE C LUNP LOGICAL UNIT NUMBER OF FILE C NSAM,NROW,NSLICE DIMENSIONS OF FILE C MODE C MBUF C C--******************************************************************* SUBROUTINE RCONV(LUN1,LUN2,LUNP,NSAM,NROW,NSLICE,MODE,MBUF) INCLUDE 'CMBLOCK.INC' INCLUDE 'CMLIMIT.INC' CHARACTER(LEN=MAXNAM) :: FILEP COMMON /COMMUN/FILEP COMMON Q(1) DOUBLE PRECISION A CHARACTER *1 NULL NULL = CHAR(0) C OPTIONS WITH MODE .GT.1 RESERVED FOR STANDARD PSFS C TO BE IMPLEMENTED LATER IF (MODE.NE.1) THEN CALL ERRT(101,' OPTION NOT YET IMPLEMENTED',NE) RETURN ENDIF CALL FILERD(FILEP,NLET,NULL,'PSF IN',IRTFLG) IF (NSLICE.EQ.1) THEN C ----------------------------------------------------------- C NEW PSF, INPUT FROM CONSOLE OR INPUT STREAM EXPECTED, C PSF NOT TO BE SAVED C C NEW PSF, INPUT AS BEFORE, BUT PSF TO BE SAVED IF(FILEP(1:1).NE.'*' .AND. FILEP(1:1).NE.'#') GOTO 100 IF (FILEP(1:1).EQ.'*') GOTO 405 40 CALL FILERD(FILEP,NLETO,NULL,'PSF OUT',IRTFLG) 405 CALL RDPRMI(NSPRD,NDUM,NOT_USED,'PSF WIDTH') C MEMORY AVAILABLE ? NSPRDH = NSPRD/2 K_Q = 1 K_B = K_Q+NSPRD*NSAM K_PSF=K_B+NSAM MUBUF = K_PSF+NSPRD**2 IF (MUBUF.GT.MBUF) THEN CALL ERRT(3,'RCONV',NE) RETURN ENDIF IOUT = 1 C nov 2000 how can iform be zero???? al IFORM = 0 IF (FILEP(1:1).EQ.'*') GOTO 42 MAXIM = 0 CALL OPFILEC(0,.FALSE.,FILEP,LUNP,'U',IFORM,NSPRD,NSPRD,1, & MAXIM,' ',.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) RETURN IOUT = 2 42 NSPRD1 = NSPRD/2 + 1 NSPRD2 = NSPRD1 + 1 NSPRDS =NSPRD*NSPRD WRITE(NOUT,43) NSPRD1,NSPRD IF (NDAT.NE.0) WRITE(NDAT,43) NSPRD 43 FORMAT(' ENTER PSF MATRIX(',I2,' ROWS AND COLUMNS ') A = 0. DO I = 1,NSPRD I1 = (I-1)* NSPRD+1 I2 = I1 + NSPRD - 1 READ(NIN,*) (Q(K_PSF+K-1),K=I1,I2) WRITE(NOUT,436) (Q(K_PSF+K-1),K=I1,I2) IF(NDAT.NE.0) WRITE(NDAT,436) (Q(K_PSF+K-1),K=I1,I2) 436 FORMAT(5X,15F5.1) DO K = I1,I2 A = A + Q(K_PSF+K-1) ENDDO ENDDO C NORMALIZE IF POSSIBLE IF (A.NE.0.) GOTO 46 A = 1. WRITE(NOUT,465) 465 FORMAT(' *** PSF CANNOT BE NORMALIZED') 46 DO 48 I = 1,NSPRD LL=(I-1)*NSPRD I1=LL+1 DO KK=1,NSPRD II=LL+KK Q(K_PSF+II-1) = Q(K_PSF+II-1)/A ENDDO GOTO(48,475),IOUT 475 CALL WRTLIN(LUNP,Q(K_PSF+I1-1),NSPRD,I) 48 CONTINUE GOTO 150 100 MAXIM = 0 CALL OPFILEC(0,.FALSE.,FILEP,LUNP,'O',IFORM,NSPRD,NSPRD,NDUM, & MAXIM,' ',.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) RETURN C Memory K_Q = 1 K_B = K_Q+NSPRD*NSAM K_PSF=K_B+NSAM MUBUF = K_PSF+NSPRD**2 IF (MUBUF.GT.MBUF) THEN CALL ERRT(3,'RCONV',NE) RETURN ENDIF DO I = 1,NSPRD I1 = (I-1)*NSPRD + 1 CALL REDLIN(LUNP,Q(K_PSF+I1-1),NSPRD,I) ENDDO 150 CLOSE(LUNP) C WRITE OUT PSF FOR VERIFICATION 1905 WRITE(NOUT,191) 191 FORMAT(' PSF IN EFFECT'/) K1 = 1 K2 = K1+NSPRD-1 DO I = 1,NSPRD WRITE(NOUT,192) (Q(K_PSF+K-1),K=K1,K2) K1 = K1+NSPRD K2 = K2+NSPRD ENDDO 192 FORMAT(1X,15F5.2) C------------------------------------------------------------ NQ=NSPRD/2 CALL RCNV2_P(LUN1,LUN2,Q(K_B),Q(K_Q),NSAM,NROW,Q(K_PSF),NQ) C------------------------------------------------------------ ELSE C 3-D REAL CONVOLUTION WITH PSF READ FROM THE FILE MAXIM = 0 CALL OPFILEC(0,.FALSE.,FILEP,LUNP,'O',IFORM,NSPRD,NSPRD,NSPRD, & MAXIM,' ',.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) RETURN IF (NSAM*NROW*NSPRD+NSAM+NSPRD**3.GT.MBUF) THEN CALL ERRT(3,'RCONV',NE) RETURN ENDIF DO K=1,NSPRD DO I = 1,NSPRD NR=(K-1)*NSPRD+I I1 = (K-1)*NSPRD*NSPRD+(I-1)*NSPRD + 1 CALL REDLIN(LUNP,Q(I1),NSPRD,NR) ENDDO ENDDO 850 CLOSE(LUNP) WRITE(NOUT,191) K1=1 K2=NSPRD DO K=1,NSPRD WRITE(NOUT,*) K DO I=1,NSPRD WRITE(NOUT,892) (Q(J),J=K1,K2) K1=K1+NSPRD K2=K2+NSPRD ENDDO ENDDO 892 FORMAT(9(1X,1PE10.3)) C K1 = NSPRD*NSPRD*NSPRD CALL RCNV3_P(LUN1,LUN2, & Q(NSAM*NROW*NSPRD+K1+1),Q(K1+1),NSAM,NROW,NSLICE,Q,NSPRD) ENDIF END