Index: /issm/trunk-jpl/test/MITgcm/code/eeboot_minimal.F =================================================================== --- /issm/trunk-jpl/test/MITgcm/code/eeboot_minimal.F (revision 22377) +++ /issm/trunk-jpl/test/MITgcm/code/eeboot_minimal.F (revision 22377) @@ -0,0 +1,387 @@ +C $Header: /u/gcmpack/MITgcm/eesupp/src/eeboot_minimal.F,v 1.31 2017/07/26 21:23:07 jmc Exp $ +C $Name: $ + +#include "PACKAGES_CONFIG.h" +#include "CPP_EEOPTIONS.h" + +#define ALLOW_CPL_ISSM + +CBOP +C !ROUTINE: EEBOOT_MINIMAL + +C !INTERFACE: + SUBROUTINE EEBOOT_MINIMAL( myComm ) + +C !DESCRIPTION: +C *==========================================================* +C | SUBROUTINE EEBOOT\_MINIMAL +C | o Set an initial environment that is predictable i.e. +C | behaves in a similar way on all machines and stable. +C *==========================================================* +C | Under MPI this routine calls MPI\_INIT to setup the +C | mpi environment ( on some systems the code is running as +C | a single process prior to MPI\_INIT, on others the mpirun +C | script has already created multiple processes). Until +C | MPI\_Init is called it is unclear what state the +C | application is in. Once this routine has been run it is +C | "safe" to do things like I/O to report erros and to get +C | run parameters. +C | Note: This routine can also be compiled with CPP +C | directives set so that no multi-processing is initialise. +C | This is OK and will work fine. +C *==========================================================* + +C !USES: + IMPLICIT NONE +C == Global data == +#include "SIZE.h" +#include "EEPARAMS.h" +#include "EESUPPORT.h" + +C !ROUTINE ARGUMENTS +C == Routine arguments == +C myComm :: Communicator that is passed down from +C upper level driver (if there is one). + INTEGER myComm + +C !LOCAL VARIABLES: +C == Local variables == +C myThid :: Temp. dummy thread number. +C fNam :: Used to build file name for standard and error output. +C msgBuf :: Used to build messages for printing. + INTEGER myThid +#ifdef USE_PDAF + CHARACTER*18 fNam +#else + CHARACTER*13 fNam +#endif /* USE_PDAF */ + CHARACTER*(MAX_LEN_MBUF) msgBuf +#ifdef ALLOW_USE_MPI +C mpiRC :: Error code reporting variable used with MPI. + INTEGER mpiRC + INTEGER mpiIsInitialized + LOGICAL doReport +#if defined(ALLOW_OASIS) || defined(COMPONENT_MODULE) + INTEGER mpiMyWid +#endif +#ifdef ALLOW_CPL_ISSM + COMMON /CPL_MPI_ID/ + & mpiMyWid, local_ocean_leader, local_ice_leader + integer :: n, myid, numprocs, i, mpiMyWid, numprocsworld + integer :: mycomponent + integer :: icesize, oceansize + integer :: local_ocean_leader, local_ice_leader + integer, dimension(:), allocatable :: components + integer, dimension(:), allocatable :: icegroup, oceangroup + + integer oceancommsize,icecommsize,rankzeros(2) + integer my_local_rank,my_size,my_local_size + integer modelcomm,toissmcomm + integer dummy1(1),dummy2(1) + +#endif /* ALLOW_CPL_ISSM */ +#if defined(ALLOW_NEST_PARENT) || defined(ALLOW_NEST_CHILD) + INTEGER mpiMyWid, color +#endif +#ifdef USE_PDAF + INTEGER mpi_task_id +#endif /* USE_PDAF */ +#endif /* ALLOW_USE_MPI */ +CEOP + +C-- Default values set to single processor case + numberOfProcs = 1 + myProcId = 0 + pidIO = myProcId + myProcessStr = '------' +C Set a dummy value for myThid because we are not multi-threading yet. + myThid = 1 + +C Annoyingly there is no universal way to have the usingMPI +C parameter work as one might expect. This is because, on some +C systems I/O does not work until MPI_Init has been called. +C The solution for now is that the parameter below may need to +C be changed manually! +#ifdef ALLOW_USE_MPI + usingMPI = .TRUE. +#else + usingMPI = .FALSE. +#endif + + IF ( .NOT.usingMPI ) THEN + + WRITE(myProcessStr,'(I4.4)') myProcId + WRITE(fNam,'(A,A)') 'STDERR.', myProcessStr(1:4) + OPEN(errorMessageUnit,FILE=fNam,STATUS='unknown') +c WRITE(fNam,'(A,A)') 'STDOUT.', myProcessStr(1:4) +c OPEN(standardMessageUnit,FILE=fNam,STATUS='unknown') + +#ifdef ALLOW_USE_MPI + ELSE +C-- MPI style multiple-process initialisation +C-- ========================================= + + CALL MPI_Initialized( mpiIsInitialized, mpiRC ) + + IF ( mpiIsInitialized .EQ. 0 ) THEN +C-- Initialise MPI multi-process parallel environment. +C On some systems program forks at this point. Others have already +C forked within mpirun - now thats an open standard! + CALL MPI_INIT( mpiRC ) + IF ( mpiRC .NE. MPI_SUCCESS ) THEN + eeBootError = .TRUE. + WRITE(msgBuf,'(A,I5)') + & 'EEBOOT_MINIMAL: MPI_INIT return code', mpiRC + CALL PRINT_ERROR( msgBuf, myThid ) + GOTO 999 + ENDIF + +C-- MPI has now been initialized ; now we need to either +C ask for a communicator or pretend that we have: +C Pretend that we have asked for a communicator + MPI_COMM_MODEL = MPI_COMM_WORLD + + ELSE +C-- MPI was already initialized and communicator has been passed +C down from upper level driver + MPI_COMM_MODEL = myComm + + ENDIF + + doReport = .FALSE. +#ifdef USE_PDAF +C initialize PDAF +C for more output increase second parameter from 1 to 2 + CALL INIT_PARALLEL_PDAF(0, 1, MPI_COMM_MODEL, MPI_COMM_MODEL, + & mpi_task_id) +#endif /* USE_PDAF */ + +#ifdef ALLOW_OASIS +C add a 1rst preliminary call EESET_PARAMS to set useOASIS +C (needed to decide either to call OASIS_INIT or not) + CALL MPI_COMM_RANK( MPI_COMM_WORLD, mpiMyWId, mpiRC ) + CALL EESET_PARMS ( mpiMyWId, doReport ) + IF ( useOASIS ) CALL OASIS_INIT(MPI_COMM_MODEL) +#endif /* ALLOW_OASIS */ + +#ifdef COMPONENT_MODULE +C-- Set the running directory + CALL MPI_COMM_RANK( MPI_COMM_WORLD, mpiMyWId, mpiRC ) + CALL SETDIR( mpiMyWId ) + +C- jmc: test: +C add a 1rst preliminary call EESET_PARAMS to set useCoupler +C (needed to decide either to call CPL_INIT or not) + CALL EESET_PARMS ( mpiMyWId, doReport ) +C- jmc: test end ; otherwise, uncomment next line: +c useCoupler = .TRUE. + +C-- Ask coupler interface for a communicator + IF ( useCoupler) CALL CPL_INIT +#endif /* COMPONENT_MODULE */ + +C-- Case with Nest(ing) +#if defined(ALLOW_NEST_PARENT) || defined(ALLOW_NEST_CHILD) +C-- Set the running directory + CALL MPI_COMM_RANK( MPI_COMM_WORLD, mpiMyWId, mpiRC ) + CALL SETDIR( mpiMyWId ) + +C-- Setup Nesting Execution Environment + CALL NEST_EEINIT( mpiMyWId, color ) +#endif /* ALLOW_NEST_PARENT | ALLOW_NEST_CHILD */ + +#ifdef ALLOW_CPL_ISSM +cdm CALL SETDIR_OCEAN( ) + call MPI_COMM_RANK(MPI_COMM_WORLD, mpiMyWid, mpiRC) + call MPI_COMM_SIZE(MPI_COMM_WORLD, numprocsworld, mpiRC) + print*,'choubi 2' + + +c ocean comm size: 4 (normally should be recovered from list of +c arguments after mpirun:) */ + icecommsize=2 + oceancommsize=8 + +c Build array of who is rank 0 of their own group:*/ + rankzeros(1)=0 + rankzeros(2)=icecommsize + +c Split world into sub-communicators for each and every model:*/ + call MPI_COMM_SPLIT(MPI_COMM_WORLD,1, MPIMYWID, modelcomm,mpiRC) + print*,'choubi 3' + + call MPI_INTERCOMM_CREATE(modelcomm,0,MPI_COMM_WORLD,rankzeros(1), + & 0,toissmcomm,mpiRC) + print*,'choubi 4a' + + call MPI_COMM_RANK(modelcomm, my_local_rank, mpiRC) + print*,'choubi 4b' + call MPI_COMM_SIZE(modelcomm, my_local_size, mpiRC) + + print*,'Oc My global rank',mpiMyWid,'MyLocal rank: ',my_local_rank + print*,'Oc My world size:',my_size,'My local size: ',my_local_size + + +cdmC allocate array components based on the number of processors +cdm allocate(components(numprocsworld)) +cdm +cdmC assign a component to the ocean code to organize processors into a group +cdm mycomponent=0 +cdm +cdmC gather components to all processors, +cdmC so each knows who is ice and who is ocean +cdm call MPI_allgather(mycomponent,1,MPI_INTEGER,components,1, +cdm & MPI_INTEGER,MPI_COMM_WORLD,mpiRC) +cdm print*,'choubi 3' +cdmC form ice and ocean groups +cdmC count the processors in each groups +cdm icesize=0 +cdm oceansize=0 +cdm do i=1,numprocsworld +cdm if(components(i).eq.0) then +cdm oceansize=oceansize+1 +cdm elseif(components(i).eq.1) then +cdm icesize=icesize+1 +cdm else +cdm write(6,*) 'error: processor', i, +cdm & 'not associated with ice or ocean' +cdm stop +cdm endif +cdm enddo +cdm +cdmC allocate group arrays +cdm allocate(icegroup(icesize)) +cdm allocate(oceangroup(oceansize)) +cdmC form the groups +cdm icesize=0 +cdm oceansize=0 +cdm do i=1,numprocsworld +cdm if(components(i).eq.0) then +cdm oceansize=oceansize+1 +cdm oceangroup(oceansize)=i-1 ! ranks are from 0 to numprocsworld-1 +cdm elseif(components(i).eq.1) then +cdm icesize=icesize+1 +cdm icegroup(icesize)=i-1 ! ranks are from 0 to numprocsworld-1 +cdm else +cdm write(6,*) 'error: processor', i, +cdm & 'not associated with ice or ocean' +cdm endif +cdm enddo +cdm +cdmC pick the lowest rank in the group as the local group leader +cdm local_ocean_leader=oceangroup(1) +cdm local_ice_leader=icegroup(1) +cdm print*,'choubi 3' +cdmC form ocean communicator +cdm call MPI_comm_split(MPI_COMM_WORLD,mycomponent,mpiMyWid, +cdm & MPI_COMM_MODEL,mpiRC) +cdm call MPI_comm_rank(MPI_COMM_MODEL,myid,mpiRC) +cdm call MPI_comm_size(MPI_COMM_MODEL,numprocs,mpiRC) + print*,'choubi 4' +#endif /* ALLOW_CPL_ISSM */ + +C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| +C-- Get my process number + CALL MPI_COMM_RANK( MPI_COMM_MODEL, mpiMyId, mpiRC ) + IF ( mpiRC .NE. MPI_SUCCESS ) THEN + eeBootError = .TRUE. + WRITE(msgBuf,'(A,I5)') + & 'EEBOOT_MINIMAL: MPI_COMM_RANK return code', mpiRC + CALL PRINT_ERROR( msgBuf, myThid ) + GOTO 999 + ENDIF + myProcId = mpiMyId +#ifdef USE_PDAF + WRITE(myProcessStr,'(I4.4,A1,I4.4)') mpi_task_id,'.',myProcId +#else + WRITE(myProcessStr,'(I4.4)') myProcId +#endif /* USE_PDAF */ + mpiPidIo = myProcId + pidIO = mpiPidIo + IF ( mpiPidIo .EQ. myProcId ) THEN +#ifdef SINGLE_DISK_IO + IF( myProcId .EQ. 0 ) THEN +#endif + WRITE(fNam,'(A,A)') 'STDERR.', myProcessStr(1:4) +#ifdef USE_PDAF + WRITE(fNam,'(A,A)') 'STDERR.', myProcessStr(1:9) +#endif + OPEN(errorMessageUnit,FILE=fNam,STATUS='unknown') + WRITE(fNam,'(A,A)') 'STDOUT.', myProcessStr(1:4) +#ifdef USE_PDAF + WRITE(fNam,'(A,A)') 'STDOUT.', myProcessStr(1:9) +#endif + print*,'choubi 5' + OPEN(standardMessageUnit,FILE=fNam,STATUS='unknown') + print*,'choubi 5a' +#ifdef SINGLE_DISK_IO + ELSE + OPEN(errorMessageUnit,FILE='/dev/null',STATUS='unknown') + standardMessageUnit=errorMessageUnit + ENDIF + print*,'choubi 6' + IF( myProcId .EQ. 0 ) THEN + WRITE(msgBuf,'(2A)') '** WARNING ** EEBOOT_MINIMAL: ', + & 'defined SINGLE_DISK_IO will result in losing' + CALL PRINT_MESSAGE( msgBuf, errorMessageUnit, + & SQUEEZE_RIGHT, myThid ) + WRITE(msgBuf,'(2A)') '** WARNING ** EEBOOT_MINIMAL: ', + & 'any message (error/warning) from any proc <> 0' + CALL PRINT_MESSAGE( msgBuf, errorMessageUnit, + & SQUEEZE_RIGHT, myThid ) + ENDIF + print*,'choubi 7' +#endif + print*,'choubi 8' + ENDIF + print*,'choubi 10' +#if defined(ALLOW_NEST_PARENT) || defined(ALLOW_NEST_CHILD) + WRITE(standardMessageUnit,'(2(A,I6))') + & ' mpiMyWId =', mpiMyWId, ' , color =',color +#endif /* ALLOW_NEST_PARENT | ALLOW_NEST_CHILD */ + +C-- Synchronise all processes +C Strictly this is superfluous, but by using it we can guarantee to +C find out about processes that did not start up. + CALL MPI_BARRIER( MPI_COMM_MODEL, mpiRC ) + IF ( mpiRC .NE. MPI_SUCCESS ) THEN + eeBootError = .TRUE. + WRITE(msgBuf,'(A,I6)') + & 'EEBOOT_MINIMAL: MPI_BARRIER return code', mpiRC + CALL PRINT_ERROR( msgBuf, myThid ) + GOTO 999 + ENDIF + +C-- Get number of MPI processes + CALL MPI_COMM_SIZE ( MPI_COMM_MODEL, mpiNProcs, mpiRC ) + IF ( mpiRC .NE. MPI_SUCCESS ) THEN + eeBootError = .TRUE. + WRITE(msgBuf,'(A,I6)') + & 'EEBOOT_MINIMAL: MPI_COMM_SIZE return code', mpiRC + CALL PRINT_ERROR( msgBuf, myThid ) + GOTO 999 + ENDIF + numberOfProcs = mpiNProcs + +#endif /* ALLOW_USE_MPI */ + ENDIF + print*,'choubi 11' +C-- Under MPI only allow same number of processes as proc grid size. +C Strictly we are allowed more procs but knowing there +C is an exact match makes things easier. + IF ( numberOfProcs .NE. nPx*nPy ) THEN + eeBootError = .TRUE. + WRITE(msgBuf,'(2(A,I6))') + & 'EEBOOT_MINIMAL: No. of procs=', numberOfProcs, + & ' not equal to nPx*nPy=', nPx*nPy + CALL PRINT_ERROR( msgBuf, myThid ) + GOTO 999 + ENDIF + +#ifdef USE_LIBHPM + CALL F_HPMINIT(myProcId, "mitgcmuv") +#endif + print*,'choubi 12' + 999 CONTINUE + RETURN + END