C++********************************************************************* C C UTIL2.F CHANGED: MAHIEDDINE LADJADJ 4/23/93 C JING SU 8/24/93 C REWRITTEN ARDEAN LEITH 8/30/96 C ADDED "PP S" ARDEAN LEITH 4/08/98 C STACKS IN "AD" ARDEAN LEITH 01/11/99 C REWROTE "AD".. ARDEAN LEITH 04/03/99 C USED RDPRM3S ARDEAN LEITH 08/05/99 C USED ALLOCATE ARDEAN LEITH 01/04/01 C 'PA' & 'IN' 3D ARDEAN LEITH 03/01/01 C 'CE VAR' ARDEAN LEITH 05/01/01 C 'CE RAN' ARDEAN LEITH 05/02/01 C 'CE MAX' ARDEAN LEITH 05/03/01 C 'CE MIN' ARDEAN LEITH 05/03/01 C 'CE LAP' ARDEAN LEITH 05/03/01 C 'CE SOB' ARDEAN LEITH 05/03/01 C 'CE PRE' ARDEAN LEITH 05/03/01 C 'CE TOP' ARDEAN LEITH 05/04/01 C 'CE RIDGE' ARDEAN LEITH 05/08/01 C 'CE HURST' ARDEAN LEITH 05/08/01 C 'CE HARALICK' ARDEAN LEITH 05/16/01 C NORM3 IN CE ARDEAN LEITH 04/02/02 C 'CE LAHE' ARDEAN LEITH 04/10/02 C 'CE AD' ARDEAN LEITH 04/18/02 C 'CE OR' ARDEAN LEITH 04/18/02 C 'AR SCA' ARDEAN LEITH 09/11/02 C 'AR SCA' NORM3 ARDEAN LEITH 10/04/02 C STACKS SUPPORT ARDEAN LEITH 10/04/02 C 'CE L' REMOVED ARDEAN LEITH 11/19/02 C 'WI' x,Y,Z ARDEAN LEITH 12/02/02 C OPFILEC ARDEAN LEITH 3/18/03 C 'AD F' ARDEAN LEITH 3/24/03 C 'AD S' ARDEAN LEITH 4/21/03 C 'DIV' ARDEAN LEITH 5/30/03 C 'SQRT' ARDEAN LEITH 5/30/03 C RDPRM3S BUG ARDEAN LEITH 9/05/03 C GPRP ARDEAN LEITH 9/08/03 C MPI CHAO YANG 10/31/03 C USEBORDER ARDEAN LEITH 11/21/03 C 'PD' LOCATION ARDEAN LEITH 5/14/04 C MPI REMOVED CHAO YANG 11/19/04 C 'CE WA' ARDEAN LEITH 11/19/04 C 'CE ME' ARDEAN LEITH 06/22/05 C 'BL' AV BUG ARDEAN LEITH 03/30/06 C 'WI' 1 SLICE BUG ARDEAN LEITH 10/19/06 C NSLICEW = -999999999 ARDEAN LEITH 03/05/07 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 UTIL2(MAXDIM) C C PARAMETERS: MAXDIM MAX LENGTH FOR UNLABELED COMMON C C23456789012345678901234567890123456789012345678901234567890123456789012 C--********************************************************************* SUBROUTINE UTIL2(MAXDIM) INCLUDE 'CMBLOCK.INC' INCLUDE 'CMLIMIT.INC' COMMON BUF(1) CHARACTER(LEN=MAXNAM) :: FILNAM1,FILNAM2,FILNAM3,FILNAM COMMON /COMMUN1/ FILNAM1,FILNAM2,FILNAM3 PARAMETER (NFUNC=31) CHARACTER(LEN=2),DIMENSION(NFUNC) :: FUNC REAL ,DIMENSION(3) :: FWA INTEGER ,DIMENSION(3) :: IORDER,ISIZE REAL, ALLOCATABLE, DIMENSION(:) :: Q CHARACTER(LEN=MAXNAM) :: EXPR CHARACTER(LEN=1) :: MODE,NULL CHARACTER(LEN=2) :: ANS LOGICAL :: NORMIT,USEBORDER DATA FUNC/'AD', 'BL', 'CP', 'IN', 'IP', & 'MU', 'PA', 'PD', 'SH', 'SQ', & 'SU', 'WI', 'CE', 'AR', 'MR', & 'DF', 'MA', 'WV', 'PP', 'SZ', & 'WU', 'MM', 'CM', 'PV', 'NK', & 'AS', 'MN', 'TH', 'GP', 'RP', & 'MX'/ DATA LUN1,LUN2,LUN3,LUN4/21,22,23,70/ NULL = CHAR(0) MAXIM = 0 MAXIM2 = 0 IRTFLG = 0 IF (FCHAR(1:4) .EQ. 'SQRT') GOTO 21 IF (FCHAR(1:2) .EQ. '12') GOTO 6 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, 13, 14, 15, 16, 17, 18, 19, 20, & 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31 ) IFUNC ENDIF ENDDO C FUNCTION NOT FOUND IN UTIL2 RETURN C OPERATION ADD ------------------------------------------- 'AD' C AD ADD IMAGES 1 IF (FCHAR(4:4) .EQ. 'S') THEN C ADD SERIES OF IMAGES, FASTER WITH LESS MEMORY ALLOCATED CALL ADS(LUN1,LUN2,LUN3) ELSE IF (FCHAR(4:4) .EQ. 'F' .OR. FCHAR(4:4) .EQ. 'R') THEN SIGN = 1000.0 IF (FCHAR(4:4) .EQ. 'R') SIGN = 2000.0 ELSE SIGN = +1.0 ENDIF CALL UTIL2SUP('FIRST INPUT','NEXT INPUT','SUMMED OUTPUT', & LUN1,LUN2,LUN3, SIGN) ENDIF GOTO 9000 C OPERATION ------ BLANK --------------------------------- 'BL' 2 IFORM = 3 NSAM2 = 0 NSLICE2 = -9999 CALL OPFILEC(0,.TRUE.,FILNAM,LUN2,'U',IFORM,NSAM2,NROW2,NSLICE2, & MAXIM,'BLANK OUTPUT',.FALSE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 CALL RDPRMC(ANS,NA,.TRUE.,'AVERAGE? (Y/N)',NULL,IRTFLG) IF (ANS(:1) .EQ. 'Y') THEN CALL OPFILEC(0,.TRUE.,FILNAM2,LUN1,'O',IDUM,NSAMR,NROWR,NDUM, & MAXIM2,'REFERENCE',.FALSE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 IF (IMAMI .NE. 1) THEN CALL NORM3(LUN1,NSAMR,NROWR,NDUM,FMAXR,FMINR,AVR) B = AVR ELSE B = AV ENDIF CLOSE(LUN1) ELSE C INPUT BACKGROUND VALUE CALL RDPRM(B,NOT_USED,'BACKGROUND') ENDIF CALL BLANK(LUN2,NSAM2,NROW2,NSLICE2,B) GOTO 9000 C OPERATION ----------- COPY ------------------------------ 'CP' 3 CALL COPY1(MAXDIM) GOTO 9000 C OPERATION -------- INSERT -------------------------------- 'IN' C IN : INSERT C IN S : INSERT AND CONTRAST STRETCH 4 CALL OPFILEC(0,.TRUE.,FILNAM,LUN1,'O',IFORM,NSAM1,NROW1,NSLICE1, & MAXIM,'SMALL INPUT',.FALSE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 AV1 = AV IF (FCHAR(4:4) .EQ. 'S' .AND. IMAMI .NE. 1) THEN CALL NORM3(LUN1,NSAM1,NROW1,NSLICE1,FMAX1,FMIN1,AV1) ENDIF CALL OPFILEC(0,.TRUE.,FILNAM,LUN2,'O',IFORM,NSAM2,NROW2,NSLICE2, & MAXIM2,'LARGE INPUT (OVERWRITTEN!)',.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 IF (IFORM .LT. 0) THEN C WRONG LARGE INPUT FORMAT IER = 2 GOTO 9900 ENDIF NSAMS = 1 NROWS = 1 NSLICES = 1 CALL RDPRI3S(NSAMS,NROWS,NSLICES,NOT_USED, & 'TOP LEFT COORDINATES',IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 IN = 1 CALL PATCH(LUN1,LUN2,NSAM1,NROW1,NSLICE1,NSAM2,NROW2,NSLICE2, & NSAMS,NROWS,NSLICES, IN,AV1,FCHAR(4:4),FMIN1,FMAX1, & .FALSE.) C SET UNDETERMINED SATATISTICS FLAG CALL SETPRMB(BUF,LUN2,NSAM2,NROW2,0.0,0.0,0.0,'U') GOTO 9000 C OPERATION INTERPOLATE ---------------------------------- 'IP' C IP INTERPOLATE C IP T TRIANGULAR INTERPOLATION 5 CALL OPFILEC(0,.TRUE.,FILNAM,LUN1,'O',IFORM,NSAM1,NROW1,NSLICE1, & MAXIM,'INPUT',.FALSE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 C OPEN THE OUTPUT FILE CALL FILERD(FILNAM,NLETO,NULL,'OUTPUT',IRTFLG) IF (IRTFLG .EQ. -1) GOTO 9000 NSAM2 = 0 NROW2 = 0 IF (NSLICE1 .GT. 1) THEN NSLICE2 = -1 CALL RDPRI3S(NSAM2,NROW2,NSLICE2,NOT_USED, & 'ENTER DIMENSIONS, NSAM, NROW, & NSLICE',IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 IF (NSLICE2 .LE. -1) THEN CALL RDPRI1S(NSLICE2,NOT_USED,'ENTER NSLICE',IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 ENDIF IF (NSLICE2 .EQ. 0) THEN NSLICE2 = (FLOAT(NSAM2) / FLOAT(NSAM1)) * FLOAT(NSLICE2) ENDIF ELSE NSLICE2 = 1 CALL RDPRIS(NSAM2,NROW2,NOT_USED, & 'ENTER DIMENSIONS, NSAM & NROW',IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 ENDIF C FOR RECTANGULAR IMAGES, THE USER IS ALLOWED TO ENTER ONLY C ONE DIMENSION, THE OTHER DIM. IS COMPUTED TO KEEP THE SAME C RELATION AS THE ONE BETWEEN THE DIMS. OF INPUT1. IF (NROW2 .EQ. 0) THEN NROW2 = (FLOAT(NSAM2) / FLOAT(NSAM1)) * FLOAT(NROW1) ENDIF CALL OPFILEC(LUN1,.FALSE.,FILNAM,LUN2,'U',IFORM, & NSAM2,NROW2,NSLICE2, MAXIM2,'OUTPUT',.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 IF (FCHAR(4:4) .EQ. 'T') THEN C TRIANGULAR INTERPOLATION CALL TRINTER(LUN1,LUN2,NSAM1,NROW1,1,NSAM2,NROW2,1) ELSE IF (NSLICE1 .EQ. 1) THEN CALL INTERP(LUN1,LUN2,NSAM1,NROW1,NSAM2,NROW2,MAXDIM) ELSE CALL INTERP3(LUN1,LUN2,NSAM1,NROW1,NSLICE1, & NSAM2,NROW2,NSLICE2,MAXDIM) ENDIF ENDIF GOTO 9000 C OPERATION MULTIPLY -------------------------------------- 'MU' C MU MULTIPLY REAL OR COMPLEX FILES C MU D OR DIV DIVIDE REAL FILES C MU M MULTIPLY FIRST COMPLEX FILE BY THE SECOND CONJUGATED. C MU O MULTIPLY WITH ARITHMETIC OR 6 SIGN = +2.0 IF (FCHAR(4:4) .EQ. 'D' .OR. FCHAR(1:2) .EQ. '12') THEN CALL UTIL2SUP('INPUT','DIVISOR','OUTPUT',LUN1,LUN2,LUN3, & SIGN) ELSEIF (FCHAR(4:4) .EQ. 'O') THEN CALL UTIL2SUP('INPUT','SECOND INPUT','OUTPUT', & LUN1,LUN2,LUN3, SIGN) ELSE CALL UTIL2SUP('INPUT','MULTIPLIER','OUTPUT', & LUN1,LUN2,LUN3, SIGN) ENDIF RETURN C OPERATION PATCH (ADDS INPUT TO ORIG) --------------------- 'PA' C OPEN FIRST INPUT FILE 7 CALL OPFILEC(0,.TRUE.,FILNAM,LUN1,'O',IFORM1, & NSAM1,NROW1,NSLICE1,MAXIM,'SMALL INPUT',.FALSE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 FMIN1 = FMIN FMAX1 = FMAX C OPEN SECOND INPUT FILE CALL OPFILEC(0,.TRUE.,FILNAM,LUN2,'O',IFORM2, & NSAM2,NROW2,NSLICE2, & MAXIM2,'LARGE INPUT (OVERWRITTEN!)',.TRUE.,IRTFLG) IF (IRTFLG .EQ. -1) GOTO 7 IF (IRTFLG .NE. 0) GOTO 9000 IF (IFORM .LE. 0) THEN IER = 2 GOTO 9900 ENDIF NSAMS = 1 NROWS = 1 NSLICES = 1 CALL RDPRI3S(NSAMS,NROWS,NSLICES,NOT_USED, & 'TOP LEFT COORDINATES',IRTFLG) CALL PATCH(LUN1,LUN2,NSAM1,NROW1,NSLICE1, NSAM2,NROW2, & NSLICE2, NSAMS,NROWS,NSLICES, 0,0,FCHAR(4:4), & FMIN1,FMAX1,.FALSE.) C SET UNDETERMINED STATISTICS FLAG CALL SETPRMB(BUF,LUN2,NSAM2,NROW2,0.,0.,0.,'U') GOTO 9000 C OPERATION PAD ----------------------------------------- 'PD' C EMBED A PICT. OR VOL. IN A LARGER EMPTY ARRAY. C OPEN INPUT FILE 8 CALL OPFILEC(0,.TRUE.,FILNAM,LUN1,'O',ITYPE,NSAM1,NROW1,NSLICE1, & MAXIM,'INPUT',.FALSE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 AV1 = AV IMAMI1 = IMAMI FMIN1 = FMIN FMAX1 = FMAX C OPEN THE OUTPUT FILE NSAM2 = 0 NSLICE2 = 0 CALL OPFILEC(LUN1,.TRUE.,FILNAM,LUN2,'U',ITYPE, & NSAM2,NROW2,NSLICE2,MAXIM2,'OUTPUT',.FALSE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9900 IN = 2 CALL RDPRMC(ANS,NC,.TRUE., & 'AVERAGE? (Y/N), (B)ORDER,(M)INIMUM,(C)IRCULAR',NULL,IRTFLG) IF (NC .GE. 2 .AND. ANS(2:2).EQ. 'C') IN = 3 IF (ANS(:1) .EQ. 'Y' .OR. ANS(:1) .EQ. 'M') THEN IF (IMAMI1 .NE. 1) THEN CALL NORM3(LUN1,NSAM1,NROW1,NSLICE1,FMAX1,FMIN1,AV1) ENDIF IF (ANS(:1) .EQ. 'M') THEN B = FMIN1 ELSE B = AV1 ENDIF ELSE IF (ANS(:1) .NE. 'B') THEN CALL RDPRM(B,NOT_USED,'BACKGROUND') ENDIF ENDIF NSAMS = 1 NROWS = 1 IF (NSLICE2 .LE. 1) THEN C PAD INTO A INTO AN IMAGE NSLICS = 1 CALL RDPRIS(NSAMS,NROWS,NOT_USED, & 'TOP LEFT COORDINATES',IRTFLG) ELSE C PAD INTO A VOLUME NSLICS = -1000000 CALL RDPRI3S(NSAMS,NROWS,NSLICS,NOT_USED, & 'TOP LEFT COORDINATES',IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 IF (NSLICS .LE. -1000000) THEN C NEED TO INQUIRE AS TO NSLICS NSLICS = 1 CALL RDPRI1S(NSLICS,NOT_USED,'TOP Z COORDINATE',IRTFLG) ENDIF ENDIF IF (IRTFLG .NE. 0) GOTO 9000 C A 'B' IS A SIGNAL FOR BORDERING PATCH USEBORDER = (ANS(:1) .EQ. 'B') CALL PATCH(LUN1,LUN2,NSAM1,NROW1,NSLICE1,NSAM2,NROW2,NSLICE2, & NSAMS,NROWS,NSLICS, IN,B,FCHAR(4:4), & FMIN1,FMAX1,USEBORDER) C SET UNDETERMINED STATISTICS FLAG CALL SETPRMB(BUF,LUN2,NSAM2,NROW2,0.,0.,0.,'U') GOTO 9000 C OPERATION ------------------------------------------------ 'SH' C SH SHIFT C SH F SHIFT USING FOURIER INTERPOLATION C OPEN FIRST INPUT FILE 9 CALL OPFILEC(0,.TRUE.,FILNAM,LUN1,'O',ITYPE,NSAM1,NROW1,NSLICE1, & MAXIM,'INPUT',.FALSE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 C OPEN OUTPUT FILE CALL OPFILEC(LUN1,.TRUE.,FILNAM,LUN2,'U',ITYPE, & NSAM1,NROW1,NSLICE1,MAXIM2,'OUTPUT',.FALSE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 SAMS = 0 ROWS = 0 SLICS = HUGE(SLICS) IF (IFORM .EQ. 3) THEN C SHIFT IN 3-D CALL RDPRM3S(SAMS,ROWS,SLICS,NOT_USED, & 'SHIFT COMPONENTS IN X, Y, & Z',IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 TVAL = HUGE(SLICS) IF (SLICS .EQ. TVAL) THEN CALL RDPRM1S(SLICS,NOT_USED,'SHIFT COMPONENT IN Z',IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 ENDIF IF (SAMS .EQ. FLOAT(IFIX(SAMS)) .AND. & ROWS .EQ. FLOAT(IFIX(ROWS)) .AND. & SLICS .EQ. FLOAT(IFIX(SLICS))) THEN C INTEGER SHIFT NSAMS = SAMS NROWS = ROWS NSLICS = SLICS IF (2*NSAM1 .GT. MAXDIM) THEN IER = 6 GOTO 9900 ENDIF CALL SHIFT3(LUN1,LUN2,NSAM1,NROW1,NSLICE1, & NSAMS,NROWS,NSLICS) ELSE IF (FCHAR(4:5) .EQ. 'F') THEN NNNN = NSAM1+2-MOD(NSAM1,2) MEMWANT = NNNN*NROW1*NSLICE1 ALLOCATE(Q(MEMWANT),STAT=IRTFLG) IF (IRTFLG .NE. 0) THEN IER = 6 GOTO 9900 ENDIF DO J = 1, NROW1*NSLICE1 CALL REDLIN(LUN1,Q(1 + (J-1)*NNNN),NSAM1,J) ENDDO INS = +1 CALL FMRS_3(Q(1),NSAM1,NROW1,NSLICE1,INS) IF (INS .EQ. 0) THEN IER = 38 GOTO 9900 ENDIF CALL SHIFT_PF(Q(1),NNNN/2,NSAM1,NROW1,NSLICE1,SAMS,ROWS, & SLICS) INS=-1 CALL FMRS_3(Q(1),NSAM1,NROW1,NSLICE1,INS) DO J = 1, NROW1*NSLICE1 CALL WRTLIN(LUN2,Q(1 + (J-1)*NNNN),NSAM1,J) ENDDO IF (ALLOCATED(Q)) DEALLOCATE(Q) ELSE IF (5*NSAM1 .GT. MAXDIM) THEN IER = 6 GOTO 9900 ENDIF CALL SHIFT_3D(LUN1,LUN2,BUF(1),BUF(4*NSAM1+1), & NSAM1,NROW1,NSLICE1,SAMS,ROWS,SLICS) ENDIF ENDIF ELSEIF (IFORM .EQ. 1) THEN CALL RDPRM2S(SAMS,ROWS,NOT_USED, & 'SHIFT COMPONENTS IN X & Y',IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 IF(REAL(IFIX(SAMS)).EQ.SAMS.AND.REAL(IFIX(ROWS)).EQ.ROWS) THEN C INTEGER SHIFT NSAMS = SAMS NROWS = ROWS IF (2*NSAM1 .GT. MAXDIM) THEN IER = 6 GOTO 9900 ENDIF CALL SHIFT2(LUN1,LUN2,NSAM1,NROW1,NSAMS,NROWS) ELSE IF (FCHAR(4:5).EQ.'F') THEN NNNN = NSAM1+2-MOD(NSAM1,2) MEMWANT = NNNN*NROW1 ALLOCATE(Q(MEMWANT),STAT=IRTFLG) IF (IRTFLG .NE. 0) THEN IER = 6 GOTO 9900 ENDIF DO J = 1, NROW1 CALL REDLIN(LUN1,Q(1 + (J-1)*NNNN),NSAM1,J) ENDDO INS = +1 CALL FMRS_2(Q(1),NSAM1,NROW1,INS) IF (INS .EQ. 0) THEN IER = 38 GOTO 9900 ENDIF NSLICE1 = 1 SLICS = 0.0 CALL SHIFT_PF(Q(1),NNNN/2,NSAM1,NROW1,NSLICE1, & SAMS,ROWS,SLICS) INS=-1 CALL FMRS_2(Q(1),NSAM1,NROW1,INS) DO J = 1, NROW1 CALL WRTLIN(LUN2,Q(1 + (J-1)*NNNN),NSAM1,J) ENDDO IF (ALLOCATED(Q)) DEALLOCATE(Q) ELSE C BILINEAR INTERPOLATION IF (6*NSAM1 .GT. MAXDIM) THEN IER = 6 GOTO 9900 ENDIF NNROWS = 1 NNROWE = NROW1 NNROWK = 1 CALL SHIFTR(LUN1,LUN2,NSAM1,NROW1,NNROWS,NNROWE, & NNROWK,SAMS,ROWS) ENDIF ENDIF ELSE CALL ERRT(2,'SH',NE) ENDIF GOTO 9000 C OPERATION ----------------------------------------------- 'SQ' C SQUARES POINT BY POINT FROM INPUT AND STORES IT IN OUTPUT 10 CALL OPFILEC(0,.TRUE.,FILNAM,LUN1,'O',ITYPE,NSAM1,NROW1,NSLICE1, & MAXIM,'INPUT',.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 C OPEN OUTPUT FILE (SAME SIZE AS INPUT) CALL OPFILEC(LUN1,.TRUE.,FILNAM,LUN3,'U',ITYPE, & NSAM1,NROW1,NSLICE1,MAXIM2,'OUTPUT',.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 CALL IMSQ(.FALSE.,LUN1,LUN3,ITYPE,NSAM1,NROW1,NSLICE1,IRTFLG) GOTO 9000 C OPERATION ------------------------------------------------- 'SU' C SUBTRACTS ONE OR MORE IMAGE FROM THE FIRST IMAGE 11 SIGN = -1.0 CALL UTIL2SUP('INPUT','SUBTRACTED','OUTPUT',LUN1,LUN2,LUN3, & SIGN) RETURN C OPERATION ------------------------------------------------ 'WI' C WI WINDOW C WI B WINDOW USING SPECIFIED BACKGROUND C OPEN INPUT FILE 12 CALL OPFILEC(0,.TRUE.,FILNAM,LUN1,'O',ITYPE,NSAM1,NROW1,NSLICE1, & MAXIM,'INPUT',.FALSE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 C OPEN OUTPUT FILE NSAM2 = 0 NSLICE2 = 0 CALL OPFILEC(LUN1,.TRUE.,FILNAM,LUN2,'U',ITYPE, & NSAM2,NROW2,NSLICE2,MAXIM2,'OUTPUT',.FALSE.,IRTFLG) NSAMW = 1 NROWW = 1 NSLICEW = -999999999 ! SOMEDAY THIS WILL CAUSE A PROBLEM, C ! BUT IT WILL BE AFTER I'M DEAD CALL RDPRI3S(NSAMW,NROWW,NSLICEW,NOT_USED, & 'TOP LEFT COORDINATES',IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 IF (NSLICE1 .GT. 1 .AND. NSLICEW .EQ. -999999999) THEN C FOR LEGACY INPUT OF X, Y ONLY, THEN Z ON NEXT LINE NSLICEW = 1 CALL RDPRI1S(NSLICEW,NOT_USED,'TOP SLICE',IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 ELSEIF (NSLICE1 .LE. 1) THEN NSLICEW = 1 ENDIF IF ((NSAMW .GT. NSAM1) .OR. & (NROWW .GT. NROW1) .OR. & (NSLICEW .GT. NSLICE1) .OR. & ((NSAMW + NSAM2) .LE. 1) .OR. & ((NROWW + NROW2) .LE. 1) .OR. & ((NSLICEW + NSLICE2) .LE. 1)) THEN WRITE(NOUT,*)' WARNING: NO INPUT PIXELS WITHIN OUTPUT IMAGE' ENDIF BACK = 0.0 IF (FCHAR(4:4) .EQ. 'B')CALL RDPRM(BACK,NOT_USED,'BACKGROUND') CALL WINDOW(LUN1,LUN2, NSAM1,NROW1,NSLICE1, & NSAMW,NROWW,NSLICEW, & NSAM2,NROW2,NSLICE2,BACK) GOTO 9000 C OPERATION ------------------------------------------------ 'CE' C CE CONTRAST ENHANCEMENT C CE FIT FIT HISTOGRAM C CE OD FIT HISTOGRAM FOR OD MICROGRAPHS. C CE GNC USING GRADUATED NON-CONVEX RESTORATION C CE MED USING MEDIAN FILTERING C CE VAR USING VARIANCE FILTERING C CE VS USING VARIANCE SMOOTHING FILTERING C CE G? USING GRADIENT FILTER C CE RAN USING RANGE FILTER C CE MAX USING MAX FILTER C CE MIN USING MIN FILTER C CE LAP USING LAPLACIAN FILTER C CE SOBEL USING SOBEL FILTER C CE PREWITT USING PREWITT FILTER C CE RIDGE RIDGE FOLLOWER C CE HURST USING HURST FILTER C CE HARALICK USING HARALICK FILTER C CE LAHE USING LOCAL AREA HISTOGRAM FILTER C CE AD USING ANISOTROPIC DIFFUSION FILTER C CE OR USING LOCAL ORIENTATION C CE ME USING MAXIMUM ENTROPY THRESHOLD 13 IF (FCHAR(4:6) .EQ. 'FIT') THEN C FITS HISTOGRAM OF IMAGE FILE TO THE HISTOGRAM OF REF. FILE. CALL HISTE(MAXDIM) GOTO 9911 ELSEIF (FCHAR(4:5) .EQ. 'OD') THEN C ADJUST OPTICAL DENSITIES CALL HISTOD GOTO 9911 ENDIF C OPEN INPUT FILE, SOME OPERATIONS CAN TAKE WHOLE STACKS IF (FCHAR(4:5) .EQ. 'AD') MAXIM = -1 CALL OPFILEC(0,.TRUE.,FILNAM,LUN1,'O',ITYPE,NSAM1,NROW1,NSLICE1, & MAXIM,'INPUT',.FALSE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 IF(IMAMI.NE.1) CALL NORM3(LUN1,NSAM1,NROW1,NSLICE1,FMAX,FMIN,AV) FMIN1 = FMIN FMAX1 = FMAX SIG1 = SIG C OPEN OUTPUT FILE IF (MAXIM .GT. 0) MAXIM2 = MAXIM CALL OPFILEC(LUN1,.TRUE.,FILNAM,LUN2,'U',ITYPE, & NSAM1,NROW1,NSLICE1,MAXIM2,'OUTPUT',.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 IF (FCHAR(4:6) .EQ. 'GNC') THEN C GRADUATED NON CONVEX RESTORATION CALL GNC(LUN1,LUN2,NSAM1,NROW1) ELSEIF (FCHAR(4:5) .EQ. 'AD') THEN C ANISO DIFFUSION (CAN HANDLE WHOLE STACKS) CALL ANISO(LUN1,LUN2,NSAM1,NROW1,NSLICE1,MAXIM,IRTFLG) ELSEIF (FCHAR(4:5) .EQ. 'OR') THEN C OPEN SECOND OUTPUT FILE CALL OPFILEC(LUN1,.TRUE.,FILNAM,LUN3,'U',ITYPE, & NSAM1,NROW1,NSLICE1, & MAXIM2,'CONFIDENCE OUTPUT',.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 CALL ORIENT(LUN1,LUN2,LUN3,NSAM1,NROW1,NSLICE1,IRTFLG) ELSEIF (FCHAR(4:6) .EQ. 'MED') THEN C MEDIAN FILTER CALL MEDIAN(LUN1,LUN2,NSAM1,NROW1,NSLICE1) ELSEIF (FCHAR(4:5) .EQ. 'HA') THEN C HARALICK TEXTURE FILTER CALL FILTER_HAR(LUN1,LUN2,NSAM1,NROW1,NSLICE1, & FMIN1,FMAX1) ELSEIF (FCHAR(4:6) .EQ. 'LAH' ) THEN C LAHE --> 'LH' CALL FILTER(LUN1,LUN2,NSAM1,NROW1,NSLICE1, & MAXIM,'LH',FMIN1,FMAX1,SIG1) ELSEIF (FCHAR(4:5) .EQ. 'ST') THEN C CONTRAST STRETCHING CALL ENHANC(FILNAM2,LUN1,LUN2,NSAM1,NROW1,NSLICE1) ELSEIF (FCHAR(4:5) .EQ. 'WA') THEN C WATERSHED CALL WATERSHED(LUN1,LUN2,NSAM1,NROW1,NSLICE1,FMIN1) ELSEIF (FCHAR(4:5) .EQ. 'HI') THEN C HISTOGRAM EQUALIZATION CALL EHIST(FILNAM,LUN1,LUN2,NSAM1,NROW1,NSLICE1) ELSEIF (FCHAR(4:6) .EQ. 'MET') THEN C MAX. ENTROPY THRESHOLDING CALL MEHIST(LUN1,LUN2,NSAM1,NROW1,NSLICE1,FMIN1,FMAX1) ELSEIF (FCHAR(4:4) .EQ. 'V' .OR. FCHAR(4:4) .EQ. 'G' .OR. & FCHAR(4:4) .EQ. 'R' .OR. FCHAR(4:4) .EQ. 'M' .OR. & FCHAR(4:4) .EQ. 'L' .OR. FCHAR(4:4) .EQ. 'S' .OR. & FCHAR(4:4) .EQ. 'P' .OR. FCHAR(4:4) .EQ. 'T' .OR. & FCHAR(4:4) .EQ. 'F' .OR. FCHAR(4:5) .EQ. 'HU') THEN C VARIANCE, GRADIENT, RANGE, MAX, MIN, LAPLACIAN, SOBEL, C PREWITT, TOP-HAT, FREI-CHEN, RIDGE, HURST CALL FILTER(LUN1,LUN2,NSAM1,NROW1,NSLICE1,MAXIM,FCHAR(4:5), & FMIN1,FMAX1,SIG1) ELSE C HANDLE OLD PLAIN 'CE' (SHOULD NOT BE USED NOW) CALL RDPRMC(MODE,NC,.TRUE., & '(S)TRETCH, (H)ISTOGRAM EQUALIZE, OR LOCAL? (S/H/L)', & NULL,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 IF (MODE .EQ. 'H') THEN C HISTOGRAM EQUALIZATION CALL EHIST(FILNAM,LUN1,LUN2,NSAM1,NROW1,NSLICE1) ELSEIF (MODE .EQ. 'L') THEN CALL LOCAL(LUN1,LUN2,NSAM1,NROW1,NSLICE1) ELSE CALL ENHANC(FILNAM2,LUN1,LUN2,NSAM1,NROW1,NSLICE1) ENDIF ENDIF GOTO 9000 C OPERATION ---------------------------------------------- 'AR' C AR ARITHMETIC OPERATION 14 IF (FCHAR(4:5) .NE. 'IF') MAXIM = -1 C OPEN INPUT FILE, STACK OK FOR PLAIN 'AR' CALL OPFILEC(0,.TRUE.,FILNAM,LUN1,'O',ITYPE,NSAM1,NROW1,NSLICE1, & MAXIM,'INPUT',.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 C OPEN THE OUTPUT FILE IF (MAXIM .GT. 0) MAXIM2 = MAXIM CALL OPFILEC(LUN1,.TRUE.,FILNAM,LUN2,'U',ITYPE, & NSAM1,NROW1,NSLICE1,MAXIM2,'OUTPUT',.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 IF (FCHAR(4:5) .EQ. 'IF') THEN CALL ARITHL(LUN1,LUN2,NSAM1,NROW1,NSLICE1) GOTO 9000 ELSE IF (FCHAR(4:5) .EQ. 'SC') THEN C AR SCA CALL RDPRM2S(FLOW,FHI,NOT_USED, & 'NEW IMAGE MIN. & MAX.',IRTFLG) ELSE C PLAIN AR IRTFLG = -999 ! NO UPPERCASE CALL RDPRMC(EXPR,NLET,.TRUE.,'FORMULA: P2=',NULL,IRTFLG) ENDIF IF (IRTFLG .NE. 0) GOTO 9000 NORMIT = (FCHAR(4:5) .EQ. 'SC') IMGNUM = -3 DO WHILE (IMGNUM .LT. MAXIM) CALL GETSTACK(LUN1,LUN2,IMGNUM,MAXIM, & VERBOSE,.FALSE.,FDUM,NORMIT,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 IF (FCHAR(4:5) .EQ. 'SC') THEN CALL ARITHSCA(LUN1,LUN2,NSAM1,NROW1,NSLICE1, & FMIN,FMAX,FLOW,FHI) ELSE CALL ARITH(LUN1,LUN2,NSAM1,NROW1,NSLICE1,EXPR(1:NLET)) ENDIF ENDDO GOTO 9000 C ------------------- MIRROR SYMMETRY --------------------- 'MR' C OPEN INPUT FILE 15 CALL OPFILEC(0,.TRUE.,FILNAM,LUN1,'O',ITYPE,NSAM1,NROW1,NSLICE1, & MAXIM,'INPUT',.FALSE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 C OPEN THE OUTPUT FILE CALL OPFILEC(LUN1,.TRUE.,FILNAM,LUN2,'U',ITYPE, & NSAM1,NROW1,NSLICE1,MAXIM2,'OUTPUT',.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 CALL MIRROR(LUN1,LUN2,NSAM1,NROW1,NSLICE1) GOTO 9000 C DENSITY FOLDOVER ----------------------------------------- 'DF' 16 CALL OPFILEC(0,.TRUE.,FILNAM,LUN1,'O',ITYPE, & NSAM1,NROW1,NSLICE1,MAXIM,'INPUT',.FALSE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 C OPEN OUTPUT FILE CALL OPFILEC(LUN1,.TRUE.,FILNAM,LUN2,'U',ITYPE, & NSAM1,NROW1,NSLICE1,MAXIM2,'OUTPUT',.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 CALL DENOV(LUN1,LUN2,NSAM1,NROW1,NSLICE1) GOTO 9000 C OPERATION ----------------------------------------------- 'MA' C MA MASK C MA X LATERAL MASKING IN SAMPLE DIRECTION C OPEN INPUT FILE 17 CALL OPFILEC(0,.TRUE.,FILNAM,LUN1,'O',ITYPE, & NSAM1,NROW1,NSLICE1,MAXIM,'INPUT',.FALSE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 AV1 = AV IF (IMAMI .NE. 1) & CALL NORM3(LUN1,NSAM1,NROW1,NSLICE1,FMAX1,FMIN1,AV1) C OPEN THE OUTPUT FILE CALL OPFILEC(LUN1,.TRUE.,FILNAM,LUN2,'U',ITYPE, & NSAM1,NROW1,NSLICE1,MAXIM2,'OUTPUT',.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 CALL MASK(LUN1,LUN2,NSAM1,NROW1,NSLICE1,AV1) GOTO 9000 C OPERATION ------------------------------------------------- 'WV' C WV WINDOW AVERAGING C WV S WINDOW AVERAGING -- SEQUENTIAL DOCUMENT SEARCH C WV P WINDOW AVERAGING OVER PATCHES C TRAP FOR WINDOW AVERAGING WITH PATCH OPTION 18 IF ( FCHAR(4:4) .EQ. 'P') THEN CALL WINAVE2(LUN1,LUN2,LUN3) GOTO 9000 END IF C OPEN INPUT FILE CALL OPFILEC(0,.TRUE.,FILNAM,LUN1,'O',ITYPE, & NSAM1,NROW1,NSLICE1,MAXIM,'INPUT',.FALSE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 C OPEN THE OUTPUT FILE NSAM2 = 0 NSLICE2 = 0 CALL OPFILEC(LUN1,.TRUE.,FILNAM,LUN2,'U',ITYPE, & NSAM2,NROW2,NSLICE2,MAXIM2,'OUTPUT',.FALSE.,IRTFLG) IF (IRTFLG .NE. 0) THEN IER = 4 GOTO 9900 ENDIF CALL WINAVE(LUN1,LUN2,LUN3,NSAM1,NROW1,NSAM2,NROW2) GOTO 9000 C OPERATION ------------------------------------------------ 'PP' C PP P PUT POINT C PP L PUT POINT SPECIFIED INTENSITY C PP LL PUT LINE 19 CONTINUE IF (FCHAR(4:5) .EQ. 'LL') THEN C PUT CONTINUOUS LINE IN IMAGE FILE CALL PUTLIN(LUN1,LUN2,MAXDIM) ELSEIF (FCHAR(4:4) .EQ. 'S') THEN C CONVERT FUNCTION TO A SURFACE IN A VOLUME 6400 ISIZE(1) = 32 ISIZE(2) = 32 ISIZE(3) = 32 CALL RDPRI3S(ISIZE(1),ISIZE(2),ISIZE(3),NOT_USED, & 'ENTER X, Y, & Z SIZES',IRTFLG) IF (IRTFLG .EQ. -1) GOTO 9000 6401 FWA(1) = 1.0 FWA(2) = 1.0 FWA(3) = 1.0 CALL RDPRM3S(FWA(1),FWA(2),FWA(3),NOT_USED, & 'ENTER NUMBER OF REPEATS IN X, Y, & Z',IRTFLG) IF (IRTFLG .EQ. -1) GOTO 6400 6402 IORDER(1) = 1 IORDER(2) = 2 IORDER(3) = 3 CALL RDPRI3S(IORDER(1),IORDER(2),IORDER(3), & NOT_USED,'ORDER FOR X, Y, & Z',IRTFLG) IF (IRTFLG .EQ. -1) GOTO 6401 IF ((IORDER(1) .LT. 1 .OR. IORDER(1) .GT. 3) .OR. & (IORDER(2) .LT. 1 .OR. IORDER(2) .GT. 3) .OR. & (IORDER(3) .LT. 1 .OR. IORDER(3) .GT. 3)) THEN CALL ERRT(101,'IMPROPER ORDER (MUST BE 1...3)',NDUM) GOTO 6402 ENDIF 6403 CALL RDPRMC(ANS,NCHAR,.TRUE., & 'SURFACE (G,D,D2)',NULL,IRTFLG) IF (IRTFLG .EQ. -1) GOTO 6402 IFORM = 3 NSAM = ISIZE(IORDER(1)) NROW = ISIZE(IORDER(2)) NSLICE = ISIZE(IORDER(3)) CALL OPFILEC(0,.TRUE.,FILNAM,LUN1,'U',ITYPE,NSAM,NROW,NSLICE, & MAXIM,'OUTPUT',.FALSE.,IRTFLG) IF (IRTFLG .EQ. -1) GOTO 6401 TINY = 1.0E-2 CALL SURFTOVOL(LUN1,ISIZE,FWA,IORDER,ANS,TINY) ELSE CALL OPFILEC(0,.TRUE.,FILNAM,LUN1,'O',ITYPE, & NSAM1,NROW1,NSLICE1,MAXIM,'INPUT',.FALSE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 IF (NSAM1 .GT. MAXDIM) THEN C TOO LONG LINE LENGTH IER = 9 GOTO 9900 ENDIF IF (FCHAR(4:4) .EQ. 'P') THEN CALL PUTPT(LUN1,LUN2,NSAM1,NROW1,NSLICE1) ELSEIF (FCHAR(4:4) .EQ. 'L') THEN CALL PUTPT2(LUN1,LUN2,NSAM1,NROW1,NSLICE1) ELSEIF (FCHAR(4:4) .EQ. 'V') THEN C CONVERT HEIGHT FIELD TO A BINARY VOLUME C NORMALIZE FILE IF NECESSARY FMIN1 = FMIN FMAX1 = FMAX IF (IMAMI .NE. 1) & CALL NORM3(LUN1,NSAM1,NROW1,NSLICE1,FMAX1,FMIN1,AV) WRITE(NOUT,90) FMIN,FMAX 90 FORMAT(' IMAGE DEPTH RANGE: ',G11.3,' ... ',G11.3) 6511 CALL RDPRI1S(NSLICE2,NOT_USED, & 'ENTER NUMBER OF SLICES IN OUTPUT VOLUME',IRTFLG) IF (IRTFLG .EQ. -1) GOTO 19 IFORM = 3 CALL OPFILEC(LUN1,.TRUE.,FILNAM,LUN2,'U',ITYPE, & NSAM1,NROW1,NSLICE2, MAXIM2,'OUTPUT',.FALSE.,IRTFLG) IF (IRTFLG .EQ. -1) GOTO 6511 CALL IMTOVOL(LUN1,NSAM1,NROW1,NSLICE2,LUN2,FMIN1,FMAX1, & MAXDIM) ELSE C INPUT FROM TERMINAL CALL PUTPT1(LUN1,NSAM1,NROW1,NSLICE1) ENDIF ENDIF GOTO 9000 C OPERATION ------------------------------------------------ 'SZ' C SZ SHEARS AN IMAGE BY OFSETTING EACH ROW C OPEN FIRST INPUT FILE 20 CALL OPFILEC(0,.TRUE.,FILNAM,LUN1,'O',ITYPE,NSAM1,NROW1,NSLICE1, & MAXIM,'INPUT',.FALSE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 CALL SQUEEZ(LUN1,LUN2,NSAM1,NROW1,NSLICE1,IERR) GOTO 9000 C OPERATION SQUARE ROOT (WURZEL) ------------------------- 'WU' C TAKES THE SQUARE ROOT OF AN IMAGE. C OPEN INPUT FILE 21 CALL OPFILEC(0,.TRUE.,FILNAM1,LUN1,'O',ITYPE, & NSAM1,NROW1,NSLICE1,MAXIM,'INPUT',.FALSE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 IF (FMIN .LT. 0) THEN CALL ERRT(101,'*** SQ. ROOT OF NEGATIVE NUMBER AVOIDED',IE) GOTO 9000 ENDIF C OPEN OUTPUT FILE CALL OPFILEC(LUN1,.TRUE.,FILNAM3,LUN3,'U',ITYPE, & NSAM1,NROW1,NSLICE1,MAXIM,'OUTPUT',.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 CALL IMSQ(.TRUE.,LUN1,LUN3,ITYPE,NSAM1,NROW1,NSLICE1,IRTFLG) GOTO 9000 C OPERATION MASK MULTIPLICATION -------------------------- 'MM' C MM MASK MULT. C MM C MULT. CONTINUOUS 22 CALL OPFILEC(0,.TRUE.,FILNAM,LUN1,'O',ITYPE,NSAM1,NROW1,NSLICE1, & MAXIM,'MASK REFERENCE',.FALSE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 FILNAM2 = FILNAM C OPEN IMAGE INPUT FILE CALL OPFILEC(0,.TRUE.,FILNAM,LUN2,'O',ITYPE,NSAM2,NROW2,NSLICE2, & MAXIM2,'IMAGE (OVERWRITTEN!)',.TRUE.,IRTFLG) IF (IRTFLG .EQ. -1) GOTO 22 IF (IRTFLG .NE. 0) GOTO 9000 IF (IFORM .LT. 0 .AND. IFORM .NE. -9) THEN IER = 2 GOTO 9900 ENDIF C MASKMU EXTENDED TO 3-D (JMC) CALL MASKMU(LUN1,LUN2,NSAM1,NROW1,NSLICE1) C SET UNDETERMINED SATATISTICS FLAG CALL SETPRMB(BUF,LUN2,NSAM2,NROW2,0.0,0.0,0.0,'U') GOTO 9000 C OPERATION ------------------------------------------------- 'CM' C OPEN OUTPUT FILE 23 CALL OPFILEC(0,.TRUE.,FILNAM,LUN2,'U',ITYPE,256,256,1, & MAXIM,'OUTPUT',.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 C NO MANUAL CHAPTER EITHER!! C CALL CLUMAP(LUN1,LUN2,256) !!!! commented out?????? GOTO 9000 C OPERATION ------------------------------------------------ 'PV' 24 CALL ERRT(100,'PV OPERATION NO LONGER SUPPORTED',NE) CCC CALL PDPVAX(LUN1,LUN2,FCHAR(4:4)) GOTO 9000 C OPERATION ------------------------------------------------ 'NK' C NK SHRINK C OPEN INPUT FILE 25 CALL OPFILEC(0,.TRUE.,FILNAM,LUN1,'O',ITYPE,NSAM1,NROW1,NSLICE1, & MAXIM,'INPUT',.FALSE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 CALL OPFILEC(LUN1,.TRUE.,FILNAM,LUN2,'U',ITYPE, & NSAM1,NROW1,NSLICE1,MAXIM2,'OUTPUT',.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 CALL SHR(LUN1,LUN2,NSAM1,NSAM2) GOTO 9000 C OPERATION ------------------------------------------------- 'AS' C AS ADD WITH VARIANCE COMPUTED C AS X10 OPTIONAL REGISTER TO HOLD AVE. OFFSET C AS AD ADD TO THE EXISTING AVERAGE WITH VARIANCE COMPUTED. C AS DC ADD WITH VARIANCE COMPUTED (NOW "AS R" C AS F ADD AND COMPUTE STATISTICS AND Q FACTOR MAP C AS R ADD WITH VARIANCE COMPUTED C ADDS 2 OR MORE (UP TO 500) PICTURES TOGETHER, COMPUTING C SEVERAL MEASURES OF VARIANCE (PER POINT, TOTAL, ETC.) 26 IF (FCHAR(4:4) .EQ. 'F') THEN CALL QFACT(LUN1,LUN2,LUN3) ELSE IF (FCHAR(4:5) .EQ. 'DC') THEN WRITE(NOUT,*) ' OPERATION RENAMED: AS R' FCHAR(4:5) = 'R ' ENDIF CALL ADDS(LUN1,LUN2,LUN3,LUN4,MAXDIM) ENDIF GOTO 9000 C OPERATION ----------------------------------------------- 'MN' C MN MONTAGE C MN S MONTAGE WITH INDIVIDUAL SCALING 27 CALL MONT(MAXDIM) GOTO 9000 C OPERATION ------------------------------------------------ 'TH' C TH THRESHOLD C TH F THRESHOLD--FIXUP CONSTANT C TH M THRESHOLD AND CREATE MASK C TH C THRESHOLD--CHANGE A VALUE C REPLACES ALL VALUES WITHIN AN IMAGE OR VOLUME BEYOND A C SPECIFIED THRESHOLD BY THE THRESHOLD VALUE. C OPEN INPUT FILE 28 CALL OPFILEC(0,.TRUE.,FILNAM,LUN1,'O',ITYPE,NSAM1,NROW1,NSLICE1, & MAXIM,'INPUT',.FALSE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 IF (NSAM1 .GT. MAXDIM) THEN IER = 9 GOTO 9900 END IF CALL OPFILEC(LUN1,.TRUE.,FILNAM,LUN2,'U',ITYPE, & NSAM1,NROW1,NSLICE1,MAXIM2,'OUTPUT',.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 IF (FCHAR(4:4) .EQ. 'C') THEN CALL CHANGEVAL(LUN1,LUN2,NSAM1,NROW1,NSLICE1) ELSE CALL THRESH(LUN1,LUN2,NSAM1,NROW1,NSLICE1) ENDIF GOTO 9000 C OPERATION GP -- (GET PIXEL VALUE)----------------------- 'GP' 29 CALL OPFILEC(0,.TRUE.,FILNAM,LUN1,'O',ITYPE,NSAM1,NROW1,NSLICE1, & MAXIM,'INPUT',.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 CALL GPRP(LUN1,NSAM1,NROW1,NSLICE1,FCHAR) GOTO 9000 C OPERATION RP -- (REPLACE PIXEL) ------------------------ 'RP' C RP REPLACE PIXEL 30 CALL OPFILEC(0,.TRUE.,FILNAM,LUN1,'O',ITYPE,NSAM1,NROW1,NSLICE1, & MAXIM,'INPUT',.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 CALL GPRP(LUN1,NSAM1,NROW1,NSLICE1,FCHAR) GOTO 9000 C OPERATION MAXIMUM ------------------------------------ 'MX' C COMPARES CORRESPONDING PIXELS OF 2 REAL IMAGES AND WRITES C THE MAXIMUM PIXEL VALUE AT THE CORRESPONDING POSITION OF THE C OUTPUT FILE 31 CALL OPFILEC(0,.TRUE.,FILNAM1,LUN1,'O',ITYPE,NSAM1,NROW1, & NSLICE1,MAXIM,'FIRST INPUT',.FALSE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 IF (ITYPE .LT. 0) THEN IER = 2 GOTO 9900 ENDIF C OPEN IMAGE INPUT FILE CALL OPFILEC(0,.TRUE.,FILNAM2,LUN2,'O',ITYPE,NSAM2,NROW2, & NSLICE2,MAXIM2,'SECOND INPUT',.FALSE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 IF (ITYPE .LT. 0) THEN IER = 2 GOTO 9900 ENDIF IF ((NSAM1 .NE. NSAM2) .OR. & (NROW1 .NE. NROW2) .OR. & (NSLICE1 .NE. NSLICE2) ) THEN IER = 1 GOTO 9900 ENDIF IF ((MAXIM .NE. -2) .AND. (MAXIM2 .NE. -2) ) THEN IER = 2 GOTO 9900 ENDIF NSAM3 = NSAM1 NROW3 = NROW1 NSLICE3 = NSLICE1 MAXIM = 0 CALL OPFILEC(0,.TRUE.,FILNAM3,LUN3,'U',ITYPE,NSAM3,NROW3, & NSLICE3,MAXIM,'OUTPUT',.FALSE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 9000 CALL MX(LUN1,LUN2,LUN3,NSAM1,NROW1,NSLICE1) GOTO 9000 9900 CALL ERRT(IER,'UTIL2 ',NE) 9000 CLOSE(LUN1) CLOSE(LUN2) CLOSE(LUN3) 9911 RETURN END