#ifdef __osf__ SUBROUTINE COPYPDS(LUN1,LUN) CALL ERRT(101,'COPYPDS NOT IMPLEMENTED ON THIS MACHINE',NE) RETURN END #else C ++******************************************************************** C * C COPYPDS.F * C USED OPAUXFILE FEB 99 ARDEAN LEITH * C ********************************************************************** C * AUTHOR: M.RADERMACHER 10/94 * 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 COPYPDS(LUN1,LUN) C C PURPOSE: CONVERT PERKIN ELMER SCANSALOT FILE TO SPIDER FORMAT. C C PARAMETERS: C C*********************************************************************** SUBROUTINE COPYPDS(LUN1,LUN) INCLUDE 'CMBLOCK.INC' INCLUDE 'CMLIMIT.INC' CHARACTER *81 INPUTN,INPUTNE,FILNAM COMMON /COMMUN/INPUTN,INPUTNE,FILNAM COMMON IBUF(NBUFSIZ),BUF(NBUFSIZ),DBUF(NBUFSIZ) INTEGER*2 IBUF CHARACTER*40 TEXT,BLANK CHARACTER*1 NULL,SCANDIR,TRADE,UNUSED REAL*8 ADD,DGAIN,SUM,DBUF LOGICAL TDFLAG,IFNS NULL = CHAR(0) NBUFSIZT = NBUFSIZ CALL FILERD(INPUTN,NLET,NULL,'SCAN INPUT',IRTFLG) IF (IRTFLG .NE. 0) RETURN C SAVE INPUTN FOR .IMG FILE USE ALSO INPUTNE = INPUTN C OPEN HEADER FILE (WHICH IS READABLE ASCII) AS FORMATTED SEQ. LENREC = 0 CALL OPAUXFILE(.FALSE.,INPUTNE,'HDR',LUN,LENREC,'O', & ' ',.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) RETURN C FIRST LINE CONTAINS IDENTIFIER: (UNUSED ?? AL) READ(LUN,300) UNUSED 300 FORMAT(19X,A40) C SECOND LINE CONTAINS X-DIMENSION READ(LUN,301) NSAM 301 FORMAT(24X,I5) C THIRD LINE CONTAINS Y-DIMENSION READ(LUN,301) NROW C THESE LINES CONTAIN SCAN SPECIFICS, THEY ARE SKIPPED HERE. READ(LUN,300) BLANK READ(LUN,300) BLANK READ(LUN,300) BLANK READ(LUN,300) BLANK C THE STEP SIZES IN X AND Y MAY BECOME INTERESTING. READ(LUN,301) ISTEPX READ(LUN,301) ISTEPY READ(LUN,302) SCANDIR 302 FORMAT(28X,A1) C IF THE SCANNING WENT IN Y-DIRECTION, INTERCHANGE NSAM AND NROW. IF (SCANDIR .EQ. 'Y') THEN II = NSAM NSAM = NROW NROW = II ENDIF NLINES = 10 C LL REQUESTED THIS ADDITION FOR LONG .HDR FILE al C THESE LINES CONTAIN SCAN SPECIFICS, THEY ARE SKIPPED HERE. READ(LUN,300,END=777,ERR=777) BLANK READ(LUN,300,END=777,ERR=777) BLANK READ(LUN,300,END=777,ERR=777) BLANK READ(LUN,300,END=777,ERR=777) BLANK READ(LUN,300,END=777,ERR=777) BLANK C READ THE RECORD LENGTH READ(LUN,301,END=777,ERR=777) NRECLENT C END CHANGE BY LL 16-6-98 10 LINES NLINES = 16 777 CLOSE(LUN) IF (NSAM .GT. NBUFSIZT) THEN WRITE(NOUT,444) NSAM, NBUFSIZT 444 FORMAT(' NSAM: ',I5,' > THAN PARAMETER NBUFSIZT=',I5) CALL ERRT(101, & 'INCREASE PARAMETER NBUFSIZT IN COPYPDS FILE',NE) GOTO 999 ENDIF IF (NLINES .EQ. 16) THEN C LL REQUESTED THIS CHANGE FOR LONG .HDR FILE al C LINE BELOW CHANGED LL 16-6-98 IFNS = MOD(NSAM*2,NRECLENT) .EQ. 0 ELSE C OUR USUAL SHORT .HDR FILE IFNS = MOD(NSAM,2) .EQ. 0 ENDIF C NOW OPEN IMAGE FILE: C FOR UNIX FILES IF (IFNS) THEN C NSAM EVEN, LONG OR SHORT .HDR FILE NRECLEN = 2 * NSAM ELSE C NSAM IS ODD IF (NLINES .GE. 16) THEN C FOR LONG .HDR FILE C NSAM IS NOT EVEN MULTIPLE OF RECLEN, LL 16-6-98 NRECLEN = (2 * NSAM / NRECLENT) * NRECLENT + NRECLENT ELSE C FOR OUR USUAL SHORT .HDR FILE NRECLEN = 2 * NSAM + 2 ENDIF ENDIF C OPEN IMG FILE : LENREC = NRECLEN CALL OPAUXFILE(.FALSE.,INPUTN,'IMG',LUN,LENREC,'O', & ' ',.TRUE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 999 C ASK FOR SPIDER OUTPUT FILE NAME: CALL FILERD(FILNAM,NLET,NULL,'OUTPUT',IRTFLG) IF (IRTFLG .NE. 0) GOTO 999 C CHECK IF SCAN WAS DONE IN DENSITY MODE OR TRANSMISSION MODE. C IF TRANSMITION MODE THEN ASK FOR CONVERTION PARAMETERS. 1 CALL RDPRMC(TRADE,NCHAR,.TRUE.,'(D)ENSITY OR (T)RANSMISSION', & NULL,IRT) IF (TRADE.NE.'D' .AND. TRADE.NE.'T') THEN WRITE(NOUT,102) 102 FORMAT(1X,/' NO DEFAULT FOR TRANSMISSION OR DENSITY, ' & /' SO PLEASE ENTER EITHER D OR T '/) GOTO 1 ENDIF TDFLAG = (TRADE .EQ. 'T') IF (TDFLAG) THEN WRITE(NOUT,101) 101 FORMAT(' YOU CHOSE TRANSMISSION, PLEASE JUDGE IF THE ',/, & ' RESULTS MAKE SENSE. IF YOU ADJUSTED THE MICROD ACCORDING'/, & ' TO SPECIFICATIONS, YOU HAVE A GAIN FACTOR OF 5',/) CALL RDPRM(GAIN,NOT_USED,'GAIN FACTOR') IF (GAIN .EQ. 0) DGAIN = 1.0 DGAIN = 1/GAIN ENDIF IRED = 1 CALL RDPRI1S(IRED,NOT_USED, & 'REDUCTION FACTOR (0 IF NO RED.)',IRTFLG) IF (IRED .LE. 0) IRED = 1 C OPEN SPIDER OUTPUT FILE NSAMR = NSAM / IRED NROWR = NROW / IRED NSLICE = 1 IFORM = 1 MAXIM = 0 CALL OPFILEC(0,.FALSE.,FILNAM,LUN1,'U',IFORM,NSAMR,NROWR,NSLICE, & MAXIM,' ',.FALSE.,IRTFLG) IF (IRTFLG .NE. 0) GOTO 999 C CLEAR BUFFER: DO L=1,NSAM DBUF(L) = 0. ENDDO C ICOUNT IS INPUT LINE COUNTER, ILINE OUTPUT LINE COUNTER. C ILINE IS INCREASED EVERY IRED INPUT LINES. ICOUNT = 0 ILINE = 0 DO I1=1,NROW ICOUNT = ICOUNT + 1 C READ A LINE READ(LUN,REC=I1,IOSTAT=IER) (IBUF(I),I=1,NSAM) IF (IER .LT. 0) THEN C END OF FILE, NO ERROR GOTO 200 ELSE IF (IER .GT. 0) THEN WRITE(NOUT,*) '*** ERROR READING IBUF IN COPYPDS' CALL ERRT(100,'COPYPDS',NE) END IF END IF C CONVERT IT TO FLOATS: DO K=1,NSAM IBUF(K) = ISHFTC(IBUF(K),8,16) ADD = DBLE(IBUF(K))/800. IF (TDFLAG) THEN IF(ADD.LE.10D-5) ADD=10D-5 ADD = -DLOG10(ADD*DGAIN) ENDIF DBUF(K) = DBUF(K)+ADD ENDDO IF (ICOUNT .EQ. IRED) THEN ILINE = ILINE+1 DO LL=1,NSAMR SUM = 0 DO LLL=1,IRED SUM = SUM+DBUF(LLL+(LL-1)*IRED) ENDDO BUF(LL) = SUM/DBLE(IRED*IRED) ENDDO C WRITE IT: CALL WRTLIN(LUN1,BUF,NSAMR,ILINE) DO LL=1,NSAM DBUF(LL) = 0.0 ENDDO ICOUNT=0 ENDIF ENDDO 200 IF (I1 .LT. NROW) THEN WRITE(NOUT,201) I1,NROW 201 FORMAT(1X,'PERKIN ELMER FILE HAD ONLY: ',I5,' LINES', & / ' LINE NUMBER PARAMETER WAS: ',I5,' LINES') ENDIF C CLOSE EVERYTHING AND RETURN 999 CLOSE(LUN1) CLOSE(LUN) RETURN END C from ifdef __osf__ #endif