C++********************************************************************* C C OPENDOC.F CHANGED PARAMETERS DEC 2000 ARDEAN LEITH C NO LONGER RETURN EXTENSION JAN 2001 ARDEAN LEITH C NICDOC ADDED JUL 2003 ARDEAN LEITH C MPI SEP 2003 CHAO YANG C CSTRING TOO SHORT JUL 2006 ARDEAN LEITH 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 OPENDOC: SUBROUTINE TO OPEN DOCUMENT FILE C C OPENDOC(DOCNAM,ADDEXT,NLET,NDOC,NICDOC,GETNAME,PROMPT, C ISOLDFILE,APPEND,MESSAGE,NEWFILE,IRTFLG) C C PARAMETERS: DOCNAM NAME OF DOC FILE SENT/RET C ADDEXT LOGICAL FLAG TO ADD .EXT SENT C NLET NO. OF CHAR. IN DOCNAM (NO EXT) RETURNED C NDOC UNIT FOR DOC FILE SENT C NICDOC INDEX FOR INCOREDOC FILE SENT/RET. C (< 0 INDICATES INCORE FILE) C GETNAME FLAG TO REQUEST NAME SENT C PROMPT PROMPT TO REQUEST NAME SENT C ISOLDFILE FLAG THAT FILE IS EXISTING SENT C APPEND FLAG TO OPEN FILE AS APPEND SENT C MESSAGE FLAG TO WRITE COMMENT SENT C NEWFILE FLAG THAT FILE WAS NEW RETURNED C IRTFLG ERROR FLAG (0 IS NORMAL) RETURNED C (-9 ON INPUT IS DO NOT SAYOPEN) C C--******************************************************************* SUBROUTINE OPENDOC(DOCNAM,ADDEXT,NLET,NDOC,NICDOC,GETNAME, & PROMPT,ISOLDFILE,APPEND,MESSAGE,NEWFILE,IRTFLG) INCLUDE 'CMBLOCK.INC' INCLUDE 'CMLIMIT.INC' CHARACTER (LEN=*) :: DOCNAM,PROMPT CHARACTER (LEN=MAXNAM) :: DOCNAMPE CHARACTER (LEN=160) :: CSTRING CHARACTER (LEN=12) :: CDATT CHARACTER (LEN=8) :: CTIMT CHARACTER (LEN=1) :: NULL LOGICAL :: EX,ADDEXT,ISOLDFILE,GETNAME,APPEND,MESSAGE LOGICAL :: SAYOPEN,ISOPEN,NEWFILE #ifdef USE_MPI include 'mpif.h' INTEGER MYPID, COMM, MPIERR COMM = MPI_COMM_WORLD MPIERR = 0 CALL MPI_COMM_RANK(COMM, MYPID, MPIERR) #else MYPID = -1 #endif NULL = CHAR(0) SAYOPEN = (IRTFLG .NE. -9) IF (GETNAME) THEN CALL FILERD(DOCNAM,NLET,NULL,PROMPT,IRTFLG) IF (IRTFLG .EQ. -1) RETURN ELSE NLET = LNBLNKN(DOCNAM) ENDIF IRTFLG = 2 IF (ADDEXT) THEN C MERGE DOCNAM WITH DATEXC CALL FILNAMANDEXT(DOCNAM,DATEXC,DOCNAMPE,NLETPE,.TRUE., & IRTFLG) IF (IRTFLG .NE. 0) RETURN ELSE DOCNAMPE = DOCNAM NLETPE = NLET ENDIF C SEE IF THIS FILE IS ALREADY OPEN IN-CORE CALL ISDOCINCORE(DOCNAM(1:NLET),NICDOC,MT,IRTFLG) IF (FCHAR(1:2) .EQ. 'UD' .AND. FCHAR(4:5) .NE. 'IC') THEN C (IF UD BUT NOT INCORE, DO NOT USE INCORE EVEN IF PRESENT) CONTINUE ELSEIF (NICDOC .GT. 0) THEN C (IF UD BUT NOT INCORE, DO NOT USE INCORE EVEN IF PRESENT) C IN-CORE FILE EXISTS, USE IT INSTEAD OF PHYSICAL FILE NICDOC = -NICDOC IRTFLG = 0 RETURN ENDIF NICDOC = NDOC C SEE IF PHYSICAL FILE EXISTS IF (MYPID .LE. 0) THEN INQUIRE(FILE=DOCNAMPE(1:NLETPE),EXIST=EX,OPENED=ISOPEN, & NUMBER=LUNOP,IOSTAT=IOS) ENDIF #ifdef USE_MPI CALL MPI_BCAST(EX,1,MPI_LOGICAL,0,COMM,MPIERR) IF (MPIERR .NE. 0) THEN WRITE(0,*) ' OPENDOC: FAILED TO BCAST EX' STOP ENDIF CALL MPI_BCAST(ISOPEN,1,MPI_LOGICAL,0,COMM,MPIERR) IF (MPIERR .NE. 0) THEN WRITE(0,*) ' OPENDOC: FAILED TO BCAST ISOPEN' STOP ENDIF CALL MPI_BCAST(IOS,1,MPI_INTEGER,0,COMM,MPIERR) IF (MPIERR .NE. 0) THEN WRITE(0,*) ' OPENDOC: FAILED TO BCAST IOS' STOP ENDIF CALL MPI_BCAST(LUNOP,1,MPI_INTEGER,0,COMM,MPIERR) IF (MPIERR .NE. 0) THEN WRITE(0,*) ' OPENDOC: FAILED TO BCAST LUNOP' STOP ENDIF #endif IF (IOS .NE. 0) THEN WRITE(NOUT,*)' *** ERROR INQUIRING FILE: ',DOCNAMPE(1:NLETPE) CALL ERRT(100,' ',NE) RETURN ENDIF NEWFILE = .NOT. EX IF (ISOLDFILE .AND. .NOT. EX) THEN C OLD DOC FILE SHOULD EXIST FOR READING, BUT DOES NOT! WRITE(NOUT,*)' *** DOC FILE DOES NOT EXIST: ', & DOCNAMPE(1:NLETPE) CALL ERRT(100,' ',NE) RETURN ELSEIF (ISOLDFILE .AND. EX) THEN C SEE IF FILE IS ALREADY OPEN IF (ISOPEN) THEN IF (MYPID .LE. 0) THEN CLOSE(LUNOP) WRITE(NOUT,*) ' FILE ALREADY OPEN, HAS BEEN CLOSED!' ENDIF ENDIF C OPEN EXISTING DOC FILE FOR READING IF (MYPID .LE. 0) THEN OPEN(UNIT=NDOC,FILE=DOCNAMPE(1:NLETPE),STATUS='OLD', & IOSTAT=IOS) ENDIF ELSEIF (.NOT. ISOLDFILE .AND. EX) THEN C OPEN EXISTING EXISTING DOC FILE FOR WRITING IF (APPEND) THEN IF (MYPID .LE. 0) THEN OPEN(UNIT=NDOC,FILE=DOCNAMPE(1:NLETPE),STATUS='OLD', & ACCESS="SEQUENTIAL",POSITION="APPEND",IOSTAT=IOS) ENDIF ELSE IF (MYPID .LE. 0) THEN OPEN(UNIT=NDOC,FILE=DOCNAMPE(1:NLETPE),STATUS='OLD', & ACCESS='SEQUENTIAL',IOSTAT=IOS) ENDIF ENDIF ELSEIF (.NOT. ISOLDFILE) THEN C OPEN NEW DOC FILE FOR WRITING IF (MYPID .LE. 0) THEN OPEN(UNIT=NDOC,FILE=DOCNAMPE(1:NLETPE),STATUS='UNKNOWN', & IOSTAT=IOS) ENDIF ENDIF IF (IOS .NE. 0) THEN WRITE(NOUT,*) ' *** ERROR OPENING DOC FILE: ', & DOCNAMPE(1:NLETPE) CALL ERRT(100,' ',NE) RETURN ENDIF IF (.NOT. ISOLDFILE .AND. MESSAGE) THEN C WRITE HEADER INTO FILE CALL DATE_2K(CDATT) CALL MYTIME(CTIMT) IF (MYPID .LE. 0) THEN WRITE(NDOC,90) PRJEXC(1:3),DATEXC(1:3), & CDATT(1:11),CTIMT,DOCNAMPE(1:NLETPE) ENDIF 90 FORMAT(' ;' ,A,'/',A,3X,A,' AT ',A,3X,A) ENDIF IF (SAYOPEN .AND. MYPID .LE. 0) THEN IF (NEWFILE) THEN WRITE(NOUT,92) CDATT(1:11),CTIMT, DOCNAM(1:NLET) 92 FORMAT(' ',A,' AT ',A,3X,' OPENED NEW DOC FILE: ',A) IF (USE_SPIRE) THEN WRITE(CSTRING,92) CDATT(1:11),CTIMT, DOCNAM(1:NLET) CALL SPIREOUT(CSTRING,IRTFLG) ENDIF ELSE WRITE(NOUT,*) ' OPENED EXISTING DOC FILE: ',DOCNAM(1:NLET) ENDIF ENDIF IRTFLG = 0 RETURN END