C++********************************************************************* C C PATCH.F USED REG_SET AUG 00 ARDEAN LEITH C ADDED 3D to 'PA' & 'IN' FEB 01 ARDEAN LEITH C 0,0 BUG FEB 03 ARDEAN LEITH C 1,1 'PD' SPEEDUP NOV 03 ARDEAN LEITH C 1,1 BACKGROUND BUG JAN 07 ARDEAN LEITH C C ********************************************************************** C=* FROM: SPIDER - MODULAR IMAGE PROCESSING SYSTEM. AUTHOR: J.FRANK * C=* Copyright (C) 1985-2007 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 PATCH(LUN2,LUN1,NSAM2,NROW2,NSAM1,NROW1,NSAMS,NROWS,IN,AVS,OPT) C C PURPOSE: PATCH, PAD OR INSERT IMAGE C C THIS SUBROUTINE TAKES IMAGE STORED ON LUN1 AND ADDS IT ONTO OR C INSERTS IT INTO IMAGE STORED ON LUN2 AT A SPECIFIED LOCATION. C C PARAMETERS: C LUN2 SMALL INPUT IMAGE C LUN1 BIG INPUT IMAGE (= OUTPUT IMAGE) C NSAM1,NROW1 DIMENSIONS OF BIG IMAGE 1 C NSLIC1 C NSAM2,NROW2 DIMENSIONS OF IMAGE 2 (NSAM2 < OR = NSAM1) C NSLIC2 (NROW2 < OR = NROW1) C NSAMS,NROWS TOP LEFT COORDINATES OF PATCH WITH RESPECT TO C BIG IMAGE C IN 0 PATCH 'PA' C 1 INSERT 'IN' C 2 PAD: CREATE IMAGE ON LUN1 WITH VALUE AVS C AND IMAGE FROM LUN2 INSERTED. 'PD' C IT WORKS FOR 3-D FILES. C 3 SAME AS FOR 2 BUT WITH CIRCULAR 'PD' C CONTINUATION C AVS PADDING VALUE C OPT FCHAR(4:4) C FMIN2,FMAX2 MIN & MAX FOR SMALL INPUT FILE C C--******************************************************************** SUBROUTINE PATCH(LUN2,LUN1,NSAM2,NROW2,NSLIC2, & NSAM1,NROW1,NSLIC1, & NSAMS,NROWS,NSLICS, & IN,AVS,OPT, & FMIN2,FMAX2,USEBORDER) INCLUDE 'CMBLOCK.INC' INCLUDE 'CMLIMIT.INC' COMMON /IOBUF/ BUF(NBUFSIZ) REAL, DIMENSION(NSAM1) :: BUF1 REAL, DIMENSION(NSAM2) :: BUF2 LOGICAL :: USEBORDER CHARACTER OPT #ifdef USE_MPI include 'mpif.h' INTEGER MYPID, ICOMM, MPIERR ICOMM = MPI_COMM_WORLD MPIERR = 0 CALL MPI_COMM_RANK(ICOMM, MYPID, MPIERR) #else MYPID = -1 #endif C SKIP DIRECTLY TO CIRCULAR PADDING IF DESIRED -------------- IF (IN .EQ. 3) GOTO 300 NSAMP = NSAM1 + 1 C TRUNCATE INSERTION AT BOUNDARIES NS = NROWS IF (NS .LE. 0) NS = 1 NE = NS + NROW2 - 1 IF (NE .GT. NROW1) NE = NROW1 KS = NSAMS IF (KS .LE. 0) KS = 1 KE = KS + NSAM2 - 1 IF (KE .GT. NSAM1) KE = NSAM1 KKS = NSLICS IF (KKS .LE. 0) KKS = 1 KKE = KKS + NSLIC2 - 1 IF (KKE .GT. NSLIC1) KKE = NSLIC1 IF (IN .EQ. 0) THEN C FOR PATCH OPERATION --------------------------------------'PA' IREC2 = 1 DO ISLICE = KKS,KKE DO IROW = NS, NE IREC1 = (ISLICE-1)*NROW1+IROW CALL REDLIN(LUN1,BUF1,NSAM1,IREC1) CALL REDLIN(LUN2,BUF2,NSAM2,IREC2) DO K = KS,KE C ADD THE TWO PIXELS BUF1(K) = BUF1(K) + BUF2(K-KS+1) ENDDO CALL WRTLIN(LUN1,BUF1,NSAM1,IREC1) IREC2 = IREC2 + 1 ENDDO ENDDO RETURN ELSEIF (IN .EQ. 1) THEN C FOR INSERT OPERATION --------------------------------------'IN' 60 IF (OPT .EQ. 'S') THEN SCALE = (FMAX - FMIN) / (FMAX2 - FMIN2) SCALE2 = FMIN - FMIN2 * SCALE ELSEIF (OPT .EQ. 'M') THEN FMINS = FMIN FMAXS = FMAX SCALE = 2.0 / (FMAXS-FMINS) ENDIF IREC2 = 1 DO ISLICE = KKS,KKE DO IROW = NS, NE IREC1 = (ISLICE-1)*NROW1+IROW CALL REDLIN(LUN1,BUF1,NSAM1,IREC1) CALL REDLIN(LUN2,BUF2,NSAM2,IREC2) IF (OPT .NE. 'S' .AND. OPT .NE. 'M') THEN C SIMPLE 'IN' DO K = KS,KE C REPLACE THE PIXEL BUF1(K) = BUF2(K-KS+1) ENDDO ELSE C 'IN S' OR 'IN M' ('IN M' IS UNDOCUMENTED!) DO K = KS,KE C BUF(K) = FMIN + (BUF(NSAMP+K-KS) - FMIN2) * C & (FMAX - FMIN) / (FMAX2 - FMIN2) C SCALE = (FMAX - FMIN) / (FMAX2 - FMIN2) C BUF(K) = FMIN + (BUF(NSAMP+K-KS) - FMIN2) * SCALE C BUF(K) = FMIN + BUF(NSAMP+K-KS) * SCALE - FMIN2 * SCALE C SCALE2 = FMIN - FMIN2 * SCALE C REPLACE THE PIXEL BUF1(K) = BUF2(K-KS+1) * SCALE + SCALE2 ENDDO ENDIF CALL WRTLIN(LUN1,BUF1,NSAM1,IREC1) IREC2 = IREC2 + 1 ENDDO ENDDO RETURN ENDIF C FOR PADDING ----------------------------------------------- "PD' C MODIFIED FOR 3D PADDING (11/11/86. JMC) C FIRST FILL WITH AVS ALL THE PLANES BETWEEN 1 AND (NSLICS-1) C AVS MAY BE THE AVERAGE IN THE OUTER TWO-PLANES OF THE VOLUME C IT APPEARS THAT AVS WAS ALSO USED TO SIGNAL (AVS .LT. 99999). C BAD BUG IF ACTUAL AVS WAS > 99999 Nov 03 al IF (USEBORDER) THEN C CALCULATE THE MEAN (=AVS) OF THE 2 OUTSIDE VOXELS OF THE FILE C (IT IS DONE THIS WAY TO AVOID PASSING A NEW VARIABLE IN A C PROGRAM THAT IS CALLED SOMEWHERE ELSE ALSO). KKKCOU = 0 RRRBOR = 0 IF (NSLIC2 .NE. 1) THEN C VOLUME DO KKSLIC=1,2 DO KKROW=1,NROW2 CALL REDLIN(LUN2,BUF,NSAM2,(KKSLIC-1)*NROW2+KKROW) CALL REDLIN(LUN2,BUF(NSAM2+1),NSAM2,(NSLIC2-KKSLIC)* & NROW2+KKROW) DO KKSAM=1,2*NSAM2 RRRBOR = RRRBOR + BUF(KKSAM) KKKCOU = KKKCOU + 1 ENDDO ENDDO ENDDO DO KKSLIC=3,NSLIC2-2 DO KKROW=1,NROW2 CALL REDLIN(LUN2,BUF,NSAM2,(KKSLIC-1)*NROW2+KKROW) RRRBOR = BUF(1)+BUF(2)+BUF(NSAM2-1)+BUF(NSAM2)+RRRBOR KKKCOU = KKKCOU + 4 ENDDO ENDDO ELSE C IMAGE NOT A VOLUME DO KKROW=1,2 CALL REDLIN(LUN2,BUF,NSAM2,KKROW) CALL REDLIN(LUN2,BUF(NSAM2+1),NSAM2,NROW2-(KKROW-1)) DO KKSAM=1,2*NSAM2 RRRBOR = RRRBOR+BUF(KKSAM) KKKCOU = KKKCOU + 1 ENDDO ENDDO DO KKROW=3,(NROW2-2) CALL REDLIN(LUN2,BUF,NSAM2,KKROW) RRRBOR = RRRBOR+BUF(1)+BUF(2)+BUF(NSAM2)+BUF(NSAM2-1) KKKCOU = KKKCOU + 4 ENDDO ENDIF AVST = RRRBOR / KKKCOU C JUST TO KNOW THE OUTER AVERAGE IF (MYPID .LE. 0) WRITE (NOUT,3555) AVST 3555 FORMAT(' OUTER AVERAGE: ',1PG15.5) C WRITE INTO REGISTER THE OUTER AVERAGE CALL REG_SET_NSEL(1,1, AVST,0.0,0.0,0.0,0.0,IRTFLG) ELSE AVST = AVS ENDIF IF (NSAMS .EQ. 1 .AND. NROWS .EQ. 1 .AND. NSLICS .EQ. 1 .AND. & NSAM2 .LE. NSAM1 .AND. NROW2 .LE. NROW1 .AND. & NSLIC2 .LE. NSLIC1 .AND. IN .EQ. 2) THEN C FAST & SIMPLE PAD AROUND UPPER LEFT CORNER C SET PAD TO AVST IF (NSAM2 .LT. NSAM1) BUF(NSAM2+1:NSAM1) = AVST IREC1 = 0 DO ISLICE2 = 1,NSLIC2 IGO2 = (ISLICE2 -1) * NROW2 + 1 DO IREC2 = IGO2,IGO2+NROW2-1 CALL REDLIN(LUN2,BUF,NSAM2,IREC2) IREC1 = IREC1 + 1 CALL WRTLIN(LUN1,BUF,NSAM1,IREC1) ENDDO IF (NROW2 .LT. NROW1) THEN C STILL HAVE SOME PAD ROWS LEFT FOR OUTPUT BUF(1:NSAM1) = AVST DO IREC = 1,NROW1-NROW2 IREC1 = IREC1 + 1 CALL WRTLIN(LUN1,BUF,NSAM1,IREC1) ENDDO ENDIF ENDDO IF (NSLIC2 .LT. NSLIC1) THEN C STILL HAVE SOME PAD SLICES LEFT FOR OUTPUT BUF(1:NSAM1) = AVST DO IREC = NROW1 * NSLIC2 + 1, NROW1 * NSLIC1 CALL WRTLIN(LUN1,BUF,NSAM1,IREC) ENDDO ENDIF RETURN ENDIF NSAMP = NSAM1 + 1 NS = NROWS NE = NS + NROW2 - 1 IF (KKS .NE. 1) THEN KKS1 = KKS-1 DO JJ=1,NSAM1 BUF(JJ) = AVST ENDDO DO KK=1,KKS1 DO K=1,NROW1 CALL WRTLIN(LUN1,BUF,NSAM1,K+(NROW1*(KK-1))) ENDDO ENDDO ENDIF C THE PLANES BETWEEN NSLICS AND NSLICS WILL BE REALLY PADDED DO 130 KK=KKS, KKE IF (NS.NE.1) THEN NS1=NS-1 DO I=1,NS1 DO K=1,NSAM1 BUF(K) = AVST ENDDO CALL WRTLIN(LUN1,BUF,NSAM1,I+(NROW1*(KK-1))) ENDDO ENDIF DO I = NS,NE IF (KS.EQ.1) GOTO 160 KS1 = KS - 1 DO K = 1,KS1 BUF(K) = AVST ENDDO 160 CALL REDLIN & (LUN2,BUF(NSAMP),NSAM2,(I-NS+1)+(NROW2*(KK-KKS))) DO K = KS,KE BUF(K) = BUF(NSAMP+K-KS) ENDDO IF (KE. EQ. NSAM1) GOTO 179 KE1 = KE + 1 DO K = KE1,NSAM1 BUF(K) = AVST ENDDO 179 CALL WRTLIN(LUN1,BUF,NSAM1,I+(NROW1*(KK-1))) ENDDO IF (NE.EQ.NROW1) GOTO 130 IE1 = NE + 1 DO I = IE1,NROW1 DO K = 1,NSAM1 BUF(K) = AVST ENDDO CALL WRTLIN(LUN1,BUF,NSAM1,I+(NROW1*(KK-1))) ENDDO 130 CONTINUE C FILL THE REST OF THE PLANES BETWEEN NSLICS AND NSLIC1 WITH AVST IF (KKE.NE.NSLIC1) THEN KKE1=KKE+1 DO I=1,NSAM1 BUF(I) = AVST ENDDO DO KK=KKE1,NSLIC1 DO K=1,NROW1 CALL WRTLIN(LUN1,BUF,NSAM1,K+(NROW1*(KK-1))) ENDDO ENDDO ENDIF RETURN 300 NSAMP = NSAM1 + 1 NS = NROWS NE = NS + NROW2 - 1 C INDEX ASSIGNMENTS FOR CIRCULAR PADDING --------------------------- PD C C KS2 KE2 KS1 KE1 C NS2 I----------------------------------------I C I . . C I . . C I . . C NE2 I........... ............. C I C I C I C NS1 I........... C I . C I . C NE1 I------------------------------------------I C C NE2 = 0 NS2 = 0 IF (NS.LT.0) NS = NS+NROW1 NS1 = NS NE1 = NS+NROW2-1 NPASS = 1 IF (NE1 .LE. NROW1) GOTO 320 NS2 = 1 NE2 = NE1-NROW1 NE1 = NROW1 320 KS = NSAMS KE2 = 1 KS2 = 0 IF (KS.LT.0) KS = KS+NSAM1 KS1 = KS KE1 = KS+NSAM2-1 IF (KE1.LE.NSAM1) GOTO 3205 KS2 = 1 KE2 = KE1 - NSAM1 KE1 = NSAM1 3205 ISTART = NS2 IEND = NE2 IFILLS = NE2+1 IFILLE = NS1-1 IRECOF = NROW1-NROWS+1 NPASS = 1 321 IF (ISTART.EQ.IEND) GOTO 350 DO 340 I = ISTART,IEND IRECIN = I-ISTART+IRECOF+1 CALL REDLIN(LUN2,BUF(NSAMP),NSAM2,IRECIN) IF (KS2.EQ.0) GOTO 330 NOFFS = NSAMP+KE2-2*KS2 DO K = KS2,KE2 BUF(K) = BUF(K+NOFFS+1) ENDDO DO K = KE2+1,KS1-1 BUF(K) = AVST ENDDO 330 NOFFS = NSAMP-KS1 DO K = KS1,KE1 BUF(K) = BUF(K+NOFFS) ENDDO IF (KE1.EQ.NSAM1) GOTO 340 DO K = KE1+1,NSAM1 BUF(K) = AVST ENDDO 340 CALL WRTLIN(LUN1,BUF,NSAM1,I) 350 IF (IFILLS.EQ.IFILLE) GOTO 390 DO I = IFILLS,IFILLE DO K = 1,NSAM1 BUF(K) = AVST ENDDO CALL WRTLIN(LUN1,BUF,NSAM1,I) ENDDO 390 GOTO (400,410),NPASS 400 NPASS = 2 ISTART = NS1 IEND = NE1 IFILLS = NE1 +1 IFILLE = NROW1 IRECOF = 0 GOTO 321 410 RETURN END