INTEGER FUNCTION GETEFILE( LNAME, RDONLY, FMTFLAG, CALLER ) C*********************************************************************** C Version "$Id: getefile.F 1 2017-06-10 18:05:20Z coats $" C EDSS/Models-3 I/O API. C Copyright (C) 1992-2002 MCNC and Carlie J. Coats, Jr., C (C) 2003-2013 Baron Advanced Meteorological Systems, C (C) 2007-2013 Carlie J. Coats, Jr., and C (C) 2014-2016 UNC Institute for the Environment. C Distributed under the GNU LESSER GENERAL PUBLIC LICENSE version 2.1 C See file "LGPL.txt" for conditions of use. C......................................................................... C function body starts at line 78 C C DESCRIPTION: C Gets value of logical name LNAME from the environment, checks for C existence of a file whose file name is that value, then opens the C file as a sequential file on unit IUNIT according to the flags RDONLY C (open for read-only iff TRUE, read/write if FALSE) and FMTFLAG C (formatted iff TRUE, else unformatted). C Logs the file-opening, together with the CALLER version, and C returns the unit number (or -1 for failure) C C RETURNS: unit number, (or -1 for failure) C C PRECONDITIONS REQUIRED: C C C SUBROUTINES AND FUNCTIONS CALLED: C TRIMLEN, JUNIT C C REVISION HISTORY: C Prototype 2/1995 by CJC. C C Modified 9/1999 by CJC: portability/standardization changes C C Modified 7/2003 by CJC: OMP thread safety -- critical sections C associated with INIT3() C C Modified 11/2004 by CJC: IOSTAT check for INQUIRE C C Modified 03/2010, 09/2014 by CJC: F9x changes for I/O API v3.1 C C Modified 02/2016 by CJC: eliminate non-F90 cases. C*********************************************************************** USE M3UTILIO, ONLY : INIT3, M3MESG IMPLICIT NONE C........... ARGUMENTS and their descriptions: CHARACTER*(*), INTENT(IN ) :: LNAME ! logical file name LOGICAL , INTENT(IN ) :: RDONLY ! TRUE iff file is input-only LOGICAL , INTENT(IN ) :: FMTFLAG ! TRUE iff file should be formatted CHARACTER*(*), INTENT(IN ) :: CALLER ! caller-name for logging C........... EXTERNAL FUNCTIONS and their descriptions: INTEGER, EXTERNAL :: JUNIT C........... LOCAL VARIABLES and their descriptions: INTEGER IUNIT INTEGER ISTAT, JSTAT LOGICAL LCHECK CHARACTER*512 PNAME CHARACTER*512 MESG CHARACTER*16 FMTSTRING INTEGER, SAVE :: LOGDEV = -1 C*********************************************************************** C begin body of GETEFILE() !$OMP CRITICAL( S_INIT ) IF ( LOGDEV .LT. 0 ) THEN LOGDEV = INIT3() END IF !$OMP END CRITICAL( S_INIT ) C........... Read filename from environment --- CALL NAMEVAL( LNAME, PNAME ) IF ( FMTFLAG ) THEN FMTSTRING = 'FORMATTED' ELSE FMTSTRING = 'UNFORMATTED' END IF C....... Check for existence of files --- INQUIRE( FILE=TRIM( PNAME ), EXIST=LCHECK, IOSTAT=JSTAT ) IF ( JSTAT .NE. 0 ) THEN WRITE( MESG, '( A, I11, 2X, A, 1X, A)' ) & 'GETEFILE: Error', JSTAT, 'inquiring about', LNAME CALL M3MESG( MESG ) MESG = 'Path-name: ' // PNAME CALL M3MESG( MESG ) GETEFILE = -1 RETURN END IF IF ( RDONLY ) THEN IF ( .NOT. LCHECK ) THEN WRITE( LOGDEV, 9000, IOSTAT=JSTAT, ERR=9999 ) & 'ERROR: input file not found: ', & TRIM( LNAME ), & TRIM( PNAME ) GETEFILE = -1 RETURN END IF IUNIT = JUNIT() OPEN( UNIT = IUNIT, & FILE = PNAME, & FORM = FMTSTRING, & ACTION = 'READ', & IOSTAT = ISTAT ) IF ( ISTAT .NE. 0 ) THEN CALL PERROR( 'ERROR: file not opened successfully') WRITE( LOGDEV, 9100, IOSTAT=JSTAT, ERR=9999 ) & TRIM( LNAME ), & TRIM( PNAME ), & 'I/O status: ', ISTAT GETEFILE = -1 RETURN END IF WRITE( LOGDEV, 9001, IOSTAT=JSTAT, ERR=9999 ) & 'File "', TRIM( LNAME ), & '" opened for input on unit:', IUNIT, & TRIM( PNAME ) ELSE ! not read-only: open for write IF ( LCHECK ) THEN WRITE( LOGDEV, 9000, IOSTAT=JSTAT, ERR=9999 ) & 'WARNING: output file already exists: ', & TRIM( LNAME ), & TRIM( PNAME ) END IF IUNIT = JUNIT() #ifdef __alpha OPEN( UNIT = IUNIT, & FILE = PNAME, & FORM = FMTSTRING, & STATUS = 'UNKNOWN', & IOSTAT = ISTAT ) #endif /* ifdef __alpha */ #ifdef _WIN32 OPEN( UNIT = IUNIT, & FILE = PNAME, & FORM = FMTSTRING, & CONVERT= 'BIG_ENDIAN', & IOSTAT = ISTAT ) #endif /* ifdef _WIN32 */ #ifndef __alpha #ifndef _WIN32 OPEN( UNIT = IUNIT, & FILE = PNAME, & FORM = FMTSTRING, & IOSTAT = ISTAT ) #endif /* ifndef _WIN32 */ #endif /* ifndef __alpha */ IF ( ISTAT .NE. 0 ) THEN CALL PERROR( 'ERROR: file not opened successfully') WRITE( LOGDEV, 9100, IOSTAT=JSTAT, ERR=9999 ) & TRIM( LNAME ), & TRIM( PNAME ), & 'I/O status: ', ISTAT GETEFILE = -1 RETURN END IF WRITE( LOGDEV, 9001, IOSTAT=JSTAT, ERR=9999 ) & 'File "', TRIM( LNAME ), & '" opened for output on unit:', IUNIT, & TRIM( PNAME ) END IF GETEFILE = IUNIT RETURN C---------------------------------------------------------------------- C handle messaging errors: 9999 CONTINUE IF ( JSTAT .NE. 0 ) THEN CALL PERROR( 'ERROR writing log message.') WRITE( LOGDEV, 9200, IOSTAT=ISTAT ) & 'I/O status:', JSTAT GETEFILE = -1 RETURN END IF C----------------------------------------------------------------------- C Format statements: 8000 FORMAT( A ) 9000 FORMAT( /, 1X, 2A, /, :, 1X, A, / ) 9001 FORMAT( /, 5X, 3A, I4, & /, 5X, A, /) 9100 FORMAT( /, 1X, A, ':', A, & /, 1X, A, I7 , / ) 9200 FORMAT( /, 1X, A, I7 , / ) END FUNCTION GETEFILE #ifndef sgi #ifndef __sun #ifndef __alpha #ifndef __hpux SUBROUTINE PERROR( ERRMSG ) USE M3UTILIO, ONLY : INIT3 CHARACTER*(*) ERRMSG INTEGER LOGDEV LOGDEV = INIT3() WRITE( LOGDEV, '(/5X, A )' ) ERRMSG RETURN END #endif /* ndef __hpux */ #endif /* ndef __alpha */ #endif /* ndef __sun */ #endif /* ndef sgi */