C++********************************************************************* C C SETVAL.F REMOVED FROM UTIL1 OCT 88 ARDEAN LEITH C LONG FILE NAMES FEB 89 ARDEAN LEITH C CAN OPEN STACK WITHOUT @ NOW SEPT 98 ARDEAN LEITH C OPFILEC FEB 03 ARDEAN LEITH C RDPRAF REMOVED DEC 05 ARDEAN LEITH C ********************************************************************** C=* * C=* This file is part of: SPIDER - Modular Image Processing System. * C=* SPIDER System Authors: Joachim Frank & ArDean Leith * C=* Copyright 1985-2010 Health Research Inc., * C=* Riverview Center, 150 Broadway, Suite 560, Menands, NY 12204. * C=* Email: spider@wadsworth.org * C=* * C=* SPIDER 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=* SPIDER 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=* You should have received a copy of the GNU General Public License * C=* along with this program. If not, see * C=* * C ********************************************************************** C C SETVAL(LUN1) C C PURPOSE: SET PARTICULAR LABEL LOCATIONS TO SPECIFIED VALUES C C23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 C--********************************************************************* SUBROUTINE SETVAL(LUN1,NSAM1,NROW1,NSLICE1) INCLUDE 'CMBLOCK.INC' INCLUDE 'CMLIMIT.INC' CHARACTER(LEN=MAXNAM) :: FILNAM CHARACTER(LEN=1) :: SET,ANS,NULL INTEGER, PARAMETER :: NMAX = 200 INTEGER :: ILIST(NMAX) REAL :: FLIST(NMAX) REAL :: FARRAY(4) REAL, PARAMETER :: PI = 3.14159 NULL = CHAR(0) LUN2 = 21 10 CALL RDPRMC(SET,NCHAR,.TRUE., & '(A)NGLES, (BUF), (P)COPY, (C)LEAR, OR (F)IX',NULL,IRTFLG) IF (SET .EQ. 'A') THEN C CHANGE THE TILT ANGLES ---------------------------------- A CALL RDPRMI(ILPOS,IDUM,NOT_USED,'ANGLE SET 1, 2, OR 3') CALL RDPRM2(PHI,THETA,NOT_USED,'ENTER PHI AND THETA') FARRAY(2) = PHI FARRAY(3) = THETA CALL RDPRM(PSI,NOT_USED,'ENTER PSI') FARRAY(4) = PSI FARRAY(1) = 1.0 IF (ILPOS.EQ.1) THEN LOCATION = 14 NANG = 4 CALL SETLAB(LUN1,NSAM1,DUM,LOCATION,NANG,FARRAY,'U',IRTFLG) ELSEIF (ILPOS .EQ. 2)THEN LOCATION = 30 NANG = 4 CALL SETLAB(LUN1,NSAM1,DUM,LOCATION,NANG,FARRAY,'U',IRTFLG) ELSEIF (ILPOS .EQ. 3)THEN FARRAY(1) = 2 LOCATION = 30 NANG = 1 CALL SETLAB(LUN1,NSAM1,DUM,LOCATION,NANG,FARRAY,'U',IRTFLG) LOCATION = 34 NANG = 3 CALL SETLAB(LUN1,NSAM1,DUM,LOCATION,NANG, & FARRAY(2),'U',IRTFLG) ELSE CALL ERRT(102,'INCORRECT NUMBER FOR SET',ILPOS) GOTO 9000 ENDIF ELSEIF (SET .EQ. 'B') THEN C CHANGE A PARTICULAR BUFFER LOCATION IN THE FILE LABEL ---- B 1601 NVAL1 = NMAX CALL RDPRAI(ILIST,NMAX,NVAL1,1,1024, & 'ENTER NUMBER(S) OF HEADER LOCATION TO BE CHANGED', & NULL,IRTFLG) IF (IRTFLG .EQ. -1) GOTO 10 NMAX2 = NVAL1 CALL RDPRA( & 'ENTER NEW VALUE FOR EACH HEADER LOCATION CHANGED', & NMAX2,0,.FALSE.,FLIST,NVAL2,IRTFLG) IF (IRTFLG .EQ. -1) GOTO 1601 IF (NVAL2 .NE. NVAL1) THEN CALL ERRT(102,'INCORRECT NUMBER OF VALUES',NVAL2) GOTO 9000 ENDIF IF (IFORM .EQ. 8 .OR. IFORM .EQ. 11) THEN C FOR 8 BIT FILES LENREC = NSAM1 / 4 IF ((LENREC * 4) .LT. NSAM1) LENREC = LENREC + 1 ELSE C FOR NORMAL 32 BIT SPIDER FILES LENREC = NSAM1 ENDIF DO I = 1,NVAL1 CALL SETLAB(LUN1,LENREC,DUM,ILIST(I),1,FLIST(I),'U',IRTFLG) ENDDO ELSEIF (SET .EQ. 'P') THEN C COPY ANGLES FROM HEADER OF INPUT FILE TO OUTPUT FILE ----- P C OUTPUT FILE PREEXISTS, IT IS NOT CREATED HERE. MAXIM = 0 CALL OPFILEC(0,.TRUE.,FILNAM,LUN2,'O',ITYPE, & NSAM2,NROW2,NSLICE2,MAXIM,'OUTPUT',.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) RETURN CALL COPYANGLES(LUN1,LUN2,NSAM1,NSAM2) ELSEIF (SET .EQ. 'C') THEN C CLEAR ---------------------------------------------------- C SIG = -1.0 CALL SETPRM(LUN1,NSAM1,NROW1,0.0,0.0,0.0,'U') ELSEIF (SET .EQ. 'F') THEN C SET FMIN, FMAX, AV, AND S.D. C INPUT PHI AND THETA TO BE STORED IN FMAX AND FMIN CALL RDPRM(FMAX,NOT_USED,'ENTER IMAGE MAXIMUM') CALL RDPRM(FMIN,NOT_USED,'ENTER IMAGE MINIMUM') CALL RDPRMC(ANS,NCHAR,.TRUE., & 'AVERAGE AND STANDARD DEVIATION AVAILABLE (Y/N)', & NULL,IRTFLG) IF (ANS .EQ. 'N') THEN CALL ERRT(101,'MUST PROVIDE AVERAGE AND S.D. NOW',NE) GOTO 9000 ENDIF CALL RDPRM2(AV,SIG,NOT_USED, & 'ENTER AVERAGE, STANDARD DEVIATION') IF (IFORM .LT. 0) THEN C FOURIER FMAX = FMAX * PI / 180.0 FMIN = FMIN * PI / 180.0 ENDIF CALL SETPRM(LUN1,NSAM1,NROW1,FMAX,FMIN,AV,'U') ELSE C UNKNOWN OPTION ------------------------------------------- ? CALL ERRT(23,'SETVAL',NE) GOTO 9000 ENDIF 9000 CONTINUE CLOSE(LUN1) CLOSE(LUN2) RETURN END