C++********************************************************************* C C UTIL2SUP.F NEW 8/1/97 ARDEAN LEITH C REWRITTEN MAR 99 ARDEAN LEITH C USED REDVOL DEC 2000 ARDEAN LEITH C USED OPFILEC FEB 2003 ARDEAN LEITH C ADDFAC MAR 2003 ARDEAN LEITH 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 UTIL2SUP(PROMPT1,PROMPT2,PROMPT3,LUN1,LUN2,LUN3,SIGN,FACT1,FACT2) C C PARAMETERS: C C23456789012345678901234567890123456789012345678901234567890123456789012 C--********************************************************************* SUBROUTINE UTIL2SUP(PROMPT1,PROMPT2,PROMPT3,LUN1,LUN2,LUN3, & SIGN) INCLUDE 'CMBLOCK.INC' INCLUDE 'CMLIMIT.INC' CHARACTER *(*) PROMPT1,PROMPT2,PROMPT3 CHARACTER(LEN=MAXNAM) :: FILNAM1,FILNAM2,FILNAM3 COMMON /COMMUN1/ FILNAM1,FILNAM2,FILNAM3 CHARACTER (LEN=1) :: NULL REAL, ALLOCATABLE, DIMENSION(:) :: VOLBUF LOGICAL :: ASKNAME,MUSTGET,WANTNEXT,BARE1,BARE2,ISBARE NULL = CHAR(0) C IN CASE LUN1,... ARE CONSTANTS LUNA = LUN1 LUNB = LUN2 LUNOUT = LUN3 IPVOL = 0 CALL FILERD(FILNAM1,NLETI,NULL,PROMPT1,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9999 CALL FILERD(FILNAM2,NLETI,NULL,PROMPT2,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9999 BARE1 = ISBARE(FILNAM1) BARE2 = ISBARE(FILNAM2) IF (SIGN .GE. 1000) THEN CALL RDPRM2S(FACT1,FACT2,NOT_USED, & 'FACTORS FOR FIRST & SECOND FILES',IRTFLG) IF (IRTFLG .NE. 0) GOTO 9999 ENDIF IF (.NOT.(BARE1 .OR. BARE2)) THEN MAXIM1 = 0 MAXIM2 = 0 MAXIM3 = 0 C NOT A STACKS OPERATION, OPEN FIRST INPUT FILE ON LUNA CALL OPFILEC(0,.FALSE.,FILNAM1,LUNA,'O',IFORM1, & NSAM,NROW,NSLICE, & MAXIM1,PROMPT1,.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9998 C ALLOCATE SPACE IN VOLBUF ALLOCATE(VOLBUF(NSAM*NROW*NSLICE), STAT=IRTFLGT) IF (IRTFLGT .NE. 0) THEN CALL ERRT(46,'UTIL2SUP,VOLBUF',NDUM) GOTO 9999 ENDIF C LOAD VOLUME FROM FIRST FILE INTO VOLBUF CALL REDVOL(LUNA,NSAM,NROW,1,NSLICE,VOLBUF,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9998 CLOSE(LUNA) ITER = 0 C OPEN 2ND... INPUT FILE ON LUNB 10 ITER = ITER + 1 ASKNAME = (ITER .GT. 1) CALL OPFILEC(0,ASKNAME,FILNAM2,LUNB,'O',IFORM2, & NSAMT,NROWT,NSLICET,MAXIM2,PROMPT2,.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9998 IF (NSAMT.NE.NSAM.OR.NROWT.NE.NROW.OR.NSLICET.NE.NSLICE)THEN CALL ERRT(1,'UTIL2SUP',NE) GOTO 9998 ELSEIF (IFORM2 .NE. IFORM1) THEN CALL ERRT(40,'UTIL2SUP',NE) GOTO 9998 ENDIF IF (SIGN .LT. 1000) THEN C ADD, ETC SECOND FILE TO STORED VOLUME CALL ADD(VOLBUF,LUNB,IFORM1,NSAM,NROW,NSLICE,SIGN) ELSE C CARRY OUT ADDITION, ETC CALL ADDFAC(VOLBUF,LUNB,IFORM1,NSAM,NROW,NSLICE,SIGN, & FACT1,FACT2) ENDIF C CLOSE SECOND FILE (IN CASE OUTPUT IS SAME FILE) CLOSE(LUNB) C OPEN OUTPUT FILE ON LUNOUT ASKNAME = (ITER .LE. 1) CALL OPFILEC(LUNA,ASKNAME,FILNAM3,LUNOUT,'U',IFORM1, & NSAM,NROW,NSLICE,MAXIM3,PROMPT3,.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9998 C PUT SUM,ETC. IN OUTPUT FILE ON LUNOUT ILOC = 1 DO IREC=1,NROW*NSLICE CALL WRTLIN(LUNOUT,VOLBUF(ILOC),NSAM,IREC) ILOC = ILOC + NSAM ENDDO CLOSE(LUNOUT) C CONTINUE UNTIL '*' IS INPUT IF (SIGN .LT. 1000) GOTO 10 ELSE C STACKS OPERATION MAXIM1 = -1 MAXIM2 = -1 MAXIM3 = -1 IMGNUM = 0 C OPEN FIRST INPUT FILE ON LUNA CALL OPFILEC(0,.FALSE.,FILNAM1,LUNA,'O',IFORM1, & NSAM,NROW,NSLICE, & MAXIM1,PROMPT1,.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9998 C ALLOCATE SPACE IN VOLBUF ALLOCATE(VOLBUF(NSAM*NROW*NSLICE), STAT=IRTFLGT) IF (IRTFLGT .NE. 0) THEN CALL ERRT(46,'UTIL2SUP,VOLBUF',NDUM) GOTO 9999 ENDIF C OPEN SECOND INPUT FILE ON LUNB (IF NECESSARY) IF (FILNAM2 .EQ. FILNAM1) THEN LUNB = LUNA ELSE CALL OPFILEC(0,.FALSE.,FILNAM2,LUNB,'O',IFORM2, & NSAMT,NROWT,NSLICET,MAXIM2,PROMPT2,.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9998 IF (NSAMT.NE.NSAM.OR.NROWT.NE.NROW.OR.NSLICET.NE.NSLICE) & THEN CALL ERRT(1,'UTIL2SUP',NE) GOTO 9998 ELSEIF (IFORM2 .NE. IFORM1) THEN CALL ERRT(40,'UTIL2SUP',NE) GOTO 9998 ENDIF ENDIF C FIND TOTAL NUMBER OF COMMON IMAGES IN STACKS IF (MAXIM1 .GT. 0) NIMAGE = MAXIM1 IF (MAXIM2 .GT. 0) NIMAGE = MAXIM2 IF (MAXIM1 .GT. 0 .AND. MAXIM2 .GT. 0) & NIMAGE = MIN(MAXIM1,MAXIM2) C FIND OUTPUT STACK NAME CALL FILERD(FILNAM3,NLETI,NULL,PROMPT2,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9998 C OPEN OUTPUT STACK ON LUNOUT (IF NECESSARY) IF (FILNAM3 .EQ. FILNAM2) THEN LUNOUT = LUNB ELSEIF (FILNAM3 .EQ. FILNAM1) THEN LUNOUT = LUNA ELSE C OUTPUT IS DIFFERENT STACK FROM EITHER INPUT CALL OPFILEC(LUNA,.FALSE.,FILNAM3,LUNOUT,'U',IFORM1, & NSAM,NROW,NSLICE,MAXIM3,PROMPT3,.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9998 ENDIF C IF FIRST FILE IS NOT A STACK CAN SKIP TO NEXTIMAGE WANTNEXT = (MAXIM1 .LT. 0) C IF FIRST FILE IS STACK MUSTGET SPECIFIED IMGNUM MUSTGET = .NOT. WANTNEXT 20 IMGNUM = IMGNUM + 1 IF (VERBOSE) WRITE(NOUT,*) ' ' C GET IMGNUM FROM FIRST INPUT CALL GETOLDSTACK(LUNA,NSAM,IMGNUM,.TRUE.,.FALSE., & .TRUE.,IRTFLG) IF (IRTFLG .GT. 0 .AND. IMGNUM .LE. 1) GOTO 9998 IF (IRTFLG .GT. 0) GOTO 9998 C LOAD VOLUME FROM FIRST INPUT FILE INTO VOLBUF CALL REDVOL(LUNA,NSAM,NROW,1,NSLICE,VOLBUF,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9998 C WHAT HAPPENS IF STACK + STACK BUT ONE STACKED IMAGE C NOT PRESENT?? CURRENTLY PART OF STACK COULD BE C INCONSISTENT WITH PREVIOUS PART OF STACK SINCE IT WILL C HALT ON ERROR!!!!!!!!!!!!!!al CALL GETOLDSTACK(LUNB,NSAM,IMGNUM,WANTNEXT,MUSTGET, & .TRUE.,IRTFLG) IF (IRTFLG .GT. 0) GOTO 9998 IF (SIGN .LT. 1000) THEN C CARRY OUT ADDITION, ETC CALL ADD(VOLBUF,LUNB,IFORM1,NSAM,NROW,NSLICE,SIGN) ELSE C CARRY OUT ADDITION, ETC CALL ADDFAC(VOLBUF,LUNB,IFORM1,NSAM,NROW,NSLICE,SIGN, & FACT1,FACT2) ENDIF c STACK OPERATION, POINT TO NEXT STACKED IMAGE CALL GETNEWSTACK(LUNA,LUNOUT,NSAM,IMGNUM,IRTFLG) IF (IRTFLG .GT. 0) GOTO 9998 C PUT SUM,ETC. IN OUTPUT FILE ON LUNOUT ILOC = 1 DO IREC=1,NROW*NSLICE CALL WRTLIN(LUNOUT,VOLBUF(ILOC),NSAM,IREC) ILOC = ILOC + NSAM ENDDO C CONTINUE UNTIL LAST STACKED IMAGE REACHED, DO NOT CLOSE IF (IMGNUM .LT. NIMAGE) GOTO 20 ENDIF C DEALLOCATE VOLBUF 9998 IF (ALLOCATED(VOLBUF)) DEALLOCATE(VOLBUF) 9999 CLOSE(LUN1) CLOSE(LUN2) CLOSE(LUN3) RETURN END