C $Header: /u/gcmpack/MITgcm/eesupp/src/all_proc_die.F,v 1.8 2012/10/11 19:15:18 jmc Exp $ C $Name: $ #include "CPP_EEOPTIONS.h" CBOP C !ROUTINE: ALL_PROC_DIE C !INTERFACE: SUBROUTINE ALL_PROC_DIE( myThArg ) C !DESCRIPTION: C *==========================================================* C | SUBROUTINE ALL_PROC_DIE C | o when all process call this routine, die cleanly: C | set Error-Flag and call MPI finalise C *==========================================================* C | used before a STOP: C | - Only implemented for MPI multi-proc. C | - if some Proc do not call this S/R, MPI will hang. C *==========================================================* C !USES: IMPLICIT NONE C == Global variables == #include "SIZE.h" #include "EEPARAMS.h" #include "EESUPPORT.h" C !INPUT/OUTPUT PARAMETERS: C myThArg :: thread argument (= my Thread Id number C :: or = 0 if called within single-thread section) INTEGER myThArg CEOP C !FUNCTIONS INTEGER ILNBLNK EXTERNAL C == Local variables == C msgBuf :: I/O Buffer C myThid :: my Thread Id number CHARACTER*(MAX_LEN_MBUF) msgBuf INTEGER myThid #ifdef ALLOW_USE_MPI C mpiRC :: Error code reporting variable used with MPI. INTEGER mpiRC #endif /* ALLOW_USE_MPI */ myThid = MAX(myThArg,1) C-- Print message WRITE(msgBuf,'(A)') 'S/R ALL_PROC_DIE: ending the run' CALL PRINT_ERROR( msgBuf, myThid ) _BEGIN_MASTER(myThid) C-- Finishes eeEndError = .TRUE. fatalError = .TRUE. C- Flush IO-unit before MPI termination CALL MDS_FLUSH( errorMessageUnit, myThid ) c#ifdef ALLOW_USE_MPI CALL MDS_FLUSH( standardMessageUnit, myThid ) c#endif /* ALLOW_USE_MPI */ #ifdef ALLOW_USE_MPI C- Note: since MPI_INIT is always called, better to also always terminate MPI C (even if usingMPI=F) --> comment out test on usingMPI c IF ( usingMPI ) THEN C better to avoid this call if multi-components set-up ; otherwise will C hang here since procs of other comp. are not calling MPI_finalize now. IF ( .NOT.( useCoupler & .OR. useNEST_PARENT & .OR. useNEST_CHILD ) & ) THEN #ifdef ALLOW_OASIS IF ( useOASIS ) CALL OASIS_ABORT #endif /* ALLOW_OASIS */ CALL MPI_FINALIZE ( mpiRC ) IF ( mpiRC .NE. MPI_SUCCESS ) THEN WRITE(msgBuf,'(A,I5)') & 'S/R FIN_PROCS: MPI_FINALIZE return code', mpiRC CALL PRINT_ERROR( msgBuf, myThid ) ENDIF ENDIF c ENDIF #endif /* ALLOW_USE_MPI */ C- Some systems do not always flush the IO buffer to disk. C To fix this, can either close these files (implies not to write C anything after) or flush the io-unit (done above). c CLOSE( errorMessageUnit ) #ifdef ALLOW_USE_MPI C- Note: comment out if usingMPI ... since we always open standardMessageUnit C when ALLOW_USE_MPI is defined, better to flush/close also if usingMPI=F cc IF ( usingMPI ) THEN c CLOSE( standardMessageUnit ) cc ENDIF #endif /* ALLOW_USE_MPI */ _END_MASTER(myThid) IF ( myThArg.GE.1 ) THEN _BARRIER ENDIF RETURN END