eesupp/src/open_copy_data_file.F

548a795951 Jean*0001 #include "CPP_EEOPTIONS.h"
                0002
                0003 CBOP
                0004 C     !ROUTINE: OPEN_COPY_DATA_FILE
                0005 C     !INTERFACE:
                0006       SUBROUTINE OPEN_COPY_DATA_FILE(
                0007      I                                data_file, caller_sub,
                0008      O                                iUnit,
                0009      I                                myThid )
                0010 C     !DESCRIPTION: \bv
                0011 C     *==========================================================*
                0012 C     | SUBROUTINE OPEN_COPY_DATA_FILE
                0013 C     | o Routine to open and copy a data.* file to STDOUT
                0014 C     |   and return the open unit in iUnit
                0015 C     *==========================================================*
                0016 C     \ev
                0017
                0018 C     !USES:
                0019       IMPLICIT NONE
                0020 C     === Global variables ===
                0021 #include "SIZE.h"
                0022 #include "EEPARAMS.h"
06c7c05b27 Dimi*0023 #ifdef SINGLE_DISK_IO
                0024 # include "EESUPPORT.h"
                0025 #endif
548a795951 Jean*0026
                0027 C     !INPUT/OUTPUT PARAMETERS:
                0028 C     === Routine arguments ===
d930dffc07 Jean*0029 C     data_file  :: parameter file to open and copy
                0030 C     caller_sub :: name of subroutine which is calling this S/R
                0031 C     iUnit      :: IO unit of parameter-file copy (already opened)
                0032 C     myThid     :: my Thread Id number
548a795951 Jean*0033       CHARACTER*(*) data_file
                0034       CHARACTER*(*) caller_sub
                0035       INTEGER iUnit
                0036       INTEGER myThid
                0037
b5912aa7d7 Jean*0038 C     !FUNCTIONS:
                0039       INTEGER  ILNBLNK
                0040       EXTERNAL ILNBLNK
                0041
548a795951 Jean*0042 C     !LOCAL VARIABLES:
                0043 C     === Local variables ===
d930dffc07 Jean*0044 C     msgBuf    :: Informational/error message buffer
548a795951 Jean*0045       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0046       CHARACTER*(MAX_LEN_PREC) record
17153f70d8 Mart*0047 #if !defined(USE_FORTRAN_SCRATCH_FILES) || defined(SINGLE_DISK_IO)
b5912aa7d7 Jean*0048       CHARACTER*(MAX_LEN_FNAM) scratchFile1
90807ba1b6 Jean*0049 #endif
548a795951 Jean*0050       INTEGER  errIO,IL
                0051       LOGICAL  exst
06c7c05b27 Dimi*0052 #ifdef SINGLE_DISK_IO
8336c6aa6d Dimi*0053 C     mpiRC  :: Error code reporting variable used with MPI.
                0054       INTEGER mpiRC
                0055 #endif
c3d0b098ae Lars*0056 #ifdef USE_PDAF
                0057       INTEGER mpi_task_id
                0058 #endif
548a795951 Jean*0059 CEOP
                0060
                0061       _BEGIN_MASTER(myThid)
                0062
6b551785d1 Jean*0063 C--   Check for parameter file
548a795951 Jean*0064       INQUIRE( FILE=data_file, EXIST=exst )
                0065       IF (exst) THEN
90807ba1b6 Jean*0066        WRITE(msgBuf,'(A,A)')
548a795951 Jean*0067      &   ' OPEN_COPY_DATA_FILE: opening file ',data_file
                0068        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
d930dffc07 Jean*0069      &                     SQUEEZE_RIGHT, myThid )
548a795951 Jean*0070       ELSE
                0071        WRITE(msgBuf,'(A,A,A)')
                0072      &  'File ',data_file,' does not exist!'
d930dffc07 Jean*0073        CALL PRINT_ERROR( msgBuf, myThid )
548a795951 Jean*0074        WRITE(msgBuf,'(A,A)') 'S/R CALLED BY ',caller_sub
d930dffc07 Jean*0075        CALL PRINT_ERROR( msgBuf, myThid )
548a795951 Jean*0076        STOP 'ABNORMAL END: S/R OPEN_COPY_DATA_FILE'
                0077       ENDIF
                0078
6b551785d1 Jean*0079 C     Make a scratch copy of parameter file without comments
eb083ce29c Dimi*0080 #ifdef SINGLE_DISK_IO
6eca4a9ded Dimi*0081       WRITE(scratchFile1,'(A,A)') 'scratch1_', data_file
90807ba1b6 Jean*0082       IF ( myProcId .EQ. 0 ) THEN
6b551785d1 Jean*0083        OPEN( UNIT=scrUnit1, FILE=scratchFile1, STATUS='UNKNOWN' )
eb083ce29c Dimi*0084       ENDIF
                0085 #else /* ifndef SINGLE_DISK_IO */
17153f70d8 Mart*0086 #ifdef USE_FORTRAN_SCRATCH_FILES
                0087 C     this is the old default, which can cause filename conflicts on some
                0088 C     multi-node/multi-processor systems
6b551785d1 Jean*0089       OPEN( UNIT=scrUnit1, STATUS='SCRATCH' )
17153f70d8 Mart*0090 #else
                0091 C     After opening regular files here, they are closed with STATUS='DELETE'
c3d0b098ae Lars*0092 #ifdef USE_PDAF
                0093       CALL GET_TASKID_PDAF(mpi_task_id)
                0094       WRITE(scratchFile1,'(A,'//FMT_PROC_ID//',A,'//FMT_TSK_ID//')')
                0095      &     'scratch1.', myProcId, '.', mpi_task_id
                0096 #else
17153f70d8 Mart*0097       WRITE(scratchFile1,'(A,'//FMT_PROC_ID//')') 'scratch1.', myProcId
c3d0b098ae Lars*0098 #endif
6b551785d1 Jean*0099       OPEN( UNIT=scrUnit1, FILE=scratchFile1, STATUS='UNKNOWN' )
17153f70d8 Mart*0100 #endif /* USE_FORTRAN_SCRATCH_FILES */
eb083ce29c Dimi*0101 #endif /* SINGLE_DISK_IO */
                0102
                0103 #ifdef SINGLE_DISK_IO
90807ba1b6 Jean*0104       IF ( myProcId .EQ. 0 ) THEN
548a795951 Jean*0105 #endif
eb083ce29c Dimi*0106
6b551785d1 Jean*0107 C--   Open the parameter file
                0108       OPEN( UNIT=modelDataUnit, FILE=data_file,
                0109      &      _READONLY_ACTION STATUS='OLD', IOSTAT=errIO )
548a795951 Jean*0110       IF ( errIO .LT. 0 ) THEN
                0111        WRITE(msgBuf,'(A,A)')
d930dffc07 Jean*0112      &  'Unable to open parameter file: ',data_file
                0113        CALL PRINT_ERROR( msgBuf, myThid )
548a795951 Jean*0114        WRITE(msgBuf,'(A,A)') 'S/R CALLED BY ',caller_sub
d930dffc07 Jean*0115        CALL PRINT_ERROR( msgBuf, myThid )
548a795951 Jean*0116        STOP 'ABNORMAL END: S/R OPEN_COPY_DATA_FILE'
                0117       ENDIF
                0118
6b551785d1 Jean*0119 C--   Read parameter file, make a scratch copy without comments
                0120 C     and report contents of parameter file to STDOUT
548a795951 Jean*0121       WRITE(msgBuf,'(A)')
                0122      &'// ======================================================='
                0123       CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
d930dffc07 Jean*0124      &                    SQUEEZE_RIGHT, myThid )
548a795951 Jean*0125       WRITE(msgBuf,'(A,A,A)') '// Parameter file "',data_file,'"'
                0126       CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
d930dffc07 Jean*0127      &                    SQUEEZE_RIGHT, myThid )
548a795951 Jean*0128       WRITE(msgBuf,'(A)')
                0129      &'// ======================================================='
                0130       CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
d930dffc07 Jean*0131      &                    SQUEEZE_RIGHT, myThid )
6b551785d1 Jean*0132
                0133 C     Read file, remove comments and apply specific syntax changes:
548a795951 Jean*0134       DO WHILE ( .TRUE. )
6b551785d1 Jean*0135        READ(modelDataUnit,FMT='(A)',END=1001) RECORD
548a795951 Jean*0136        IL = MAX(ILNBLNK(RECORD),1)
6b551785d1 Jean*0137        IF ( RECORD(1:1) .NE. commentCharacter ) THEN
                0138 c        CALL NML_SET_TERMINATOR( RECORD )
                0139          CALL NML_CHANGE_SYNTAX( RECORD, data_file, myThid )
                0140          WRITE(UNIT=scrUnit1,FMT='(A)') RECORD(:IL)
                0141        ENDIF
548a795951 Jean*0142        WRITE(msgBuf,'(A,A)') '>',RECORD(:IL)
                0143        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
d930dffc07 Jean*0144      &                     SQUEEZE_RIGHT, myThid )
548a795951 Jean*0145       ENDDO
6b551785d1 Jean*0146  1001 CONTINUE
                0147       CLOSE(modelDataUnit)
548a795951 Jean*0148       WRITE(msgBuf,'(A)') ' '
                0149       CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
d930dffc07 Jean*0150      &                    SQUEEZE_RIGHT, myThid )
548a795951 Jean*0151
8336c6aa6d Dimi*0152 #ifdef SINGLE_DISK_IO
06c7c05b27 Dimi*0153       CALL FLUSH(scrUnit1)
90807ba1b6 Jean*0154       CLOSE(scrUnit1)
8336c6aa6d Dimi*0155       ENDIF
06c7c05b27 Dimi*0156 # ifdef ALLOW_USE_MPI
8336c6aa6d Dimi*0157 C--   all processes must wait for process 0 to complete
                0158 C     writing scratchFile1 before opening it
90807ba1b6 Jean*0159       IF ( usingMPI ) THEN
                0160         CALL MPI_BARRIER( MPI_COMM_MODEL, mpiRC )
                0161       ENDIF
06c7c05b27 Dimi*0162 # endif
daa19abb49 Jean*0163 #ifdef HAVE_SYSTEM
6eca4a9ded Dimi*0164       CALL SYSTEM('sleep 1')
daa19abb49 Jean*0165 #endif
6b551785d1 Jean*0166       OPEN( UNIT=scrUnit1, FILE=scratchFile1,
                0167      &      _READONLY_ACTION STATUS='OLD' )
8336c6aa6d Dimi*0168 #endif /* SINGLE_DISK_IO */
                0169
548a795951 Jean*0170 C--   Return open unit to caller
                0171       iUnit = scrUnit1
                0172       REWIND(iUnit)
                0173
                0174       _END_MASTER(myThid)
                0175
                0176       RETURN
                0177       END