ini_threading_environment.F

#include "CPP_EEOPTIONS.h"
#include "PACKAGES_CONFIG.h"

CBOP
C     !ROUTINE: INI_THREADING_ENVIRONMENT

C     !INTERFACE:
      SUBROUTINE INI_THREADING_ENVIRONMENT

C     !DESCRIPTION:
C     *==========================================================*
C     | SUBROUTINE INI\_THREADING\_ENVIRONMENT
C     | o Initialise multi-threaded environment.
C     *==========================================================*
C     | Generally we do not start separate threads here.
C     | The separate threads a spawned at later on.
C     | Here we perform initialisation of data-structures
C     | that indicate which of the nSx x nSy tiles a thread is
C     | responsible for.
C     | The multiple threads are spawned in the top level MAIN
C     | routine.
C     *==========================================================*

C     !USES:
      IMPLICIT NONE
C     == Global data ==
#include "SIZE.h"
#include "EEPARAMS.h"
#include "EESUPPORT.h"

C     !LOCAL VARIABLES:
C     == Local variables ==
C     bXPerThread - Blocks of size sNx per thread.
C     byPerThread - Blocks of size sNy per thread.
C     thId        - Thread index. Temporary used in loops
C                   which set per. thread values on a
C                   cartesian grid.
C     bxLo, bxHi  - Work vars. for thread index
C     byLo, byHi    range. bxLo is the lowest i index
C                   that a thread covers, bxHi is the
C                   highest i index. byLo is the lowest
C                   j index, byHi is the highest j index.
C     I, J        - Loop counter
C     msgBuf      - I/O buffer for reporting status information.
C     myThid      - Dummy thread id for use in printed messages
C                   ( this routine "INI_THREADING_ENVIRONMENT" is
C                     called before multi-threading has started.)
      INTEGER bxPerThread
      INTEGER byPerThread
      INTEGER thId
      INTEGER bxLo, bxHi
      INTEGER byLo, byHi
      INTEGER I, J
      CHARACTER*(MAX_LEN_MBUF) msgBuf
      INTEGER myThid
#ifndef ALLOW_EXCH2
      LOGICAL flag
#endif
CEOP

C--   Set default for all threads of having no blocks to
C--   work on - except for thread 1.
      myBxLo(1) = 1
      myBxHi(1) = nSx
      myByLo(1) = 1
      myByHi(1) = nSy
      DO I = 2, MAX_NO_THREADS
       myBxLo(I) = 0
       myBxHi(I) = 0
       myByLo(I) = 0
       myByHi(I) = 0
      ENDDO
      myThid = 1
      commName(COMM_NONE) = 'none'
      commName(COMM_MSG ) = 'messages'
      commName(COMM_PUT ) = 'put'
      commName(COMM_GET ) = 'get'

C--   If there are multiple threads allocate different range of the
C--   nSx*nSy blocks to each thread.
C     For now handle simple case of no. blocks nSx = n*nTx and
C     no. blocks nSy = m*nTy ( where m and n are integer ). This
C     is handled by simply mapping threads to blocks in sequence
C     with the x thread index moving fastest.
C     Later code which sets the thread number of neighboring blocks
C     needs to be consistent with the code here.
      nThreads = nTx * nTy
      IF   ( nThreads .GT. MAX_NO_THREADS ) THEN
       WRITE(msgBuf,'(2A,2I6)')
     &  'S/R INI_THREADING_ENVIRONMENT:',
     &  ' Total number of threads exceeds MAX_NO_THREADS',
     &   nTx*nTy, MAX_NO_THREADS
       CALL PRINT_ERROR(msgBuf, myThid)
       WRITE(msgBuf,'(2A)')
     &    ' Needs to increase MAX_NO_THREADS',
     &    ' in file "EEPARAMS.h" and to re-compile'
       CALL PRINT_ERROR(msgBuf, myThid)
       eeBootError = .TRUE.
       STOP 'ABNORMAL END: S/R INI_THREADING_ENVIRONMENT'
      ENDIF

C--   Initialise the barrier mechanisms
C     BAR2 will eventually replace barrier everywhere.
      CALL BARRIER_INIT
      DO I=1, MAX_NO_THREADS
       CALL BAR2_INIT(I)
      ENDDO

C--   Initialise exchange mechanism
      CALL EXCH_INIT

      IF   ( nThreads .NE. nTx*nTy ) THEN
       WRITE(msgBuf,'(A,A,A,I5,A,I5)')
     &  'S/R INI_THREADING_ENVIRONMENT:',
     &  ' Total number of threads is not the same as nTx*nTy.',
     &  ' nTx * nTy = ',nTx*nTy,' nThreads = ',nThreads
       CALL PRINT_ERROR(msgBuf, myThid)
       eeBootError = .TRUE.
       STOP 'ABNORMAL END: S/R INI_THREADING_ENVIRONMENT'
      ENDIF
      bxPerThread = nSx/nTx
      IF ( bxPerThread*nTx .NE. nSx ) THEN
       WRITE(msgBuf,'(A,A,A)')
     &  'S/R INI_THREADING_ENVIRONMENT:',
     &  ' Number of blocks in X (nSx)',
     &  ' must be exact multiple of threads in X (nTx).'
       CALL PRINT_ERROR(msgBuf, myThid)
       eeBootError = .TRUE.
       STOP 'ABNORMAL END: S/R INI_THREADING_ENVIRONMENT'
      ENDIF
      byPerThread = nSy/nTy
      IF ( byPerThread*nTy .NE. nSy ) THEN
       WRITE(msgBuf,'(A,A,A)')
     &  'S/R INI_THREADING_ENVIRONMENT:',
     &  ' Number of blocks in Y (nSy)',
     &  ' must be exact multiple of threads in Y (nTy).'
       CALL PRINT_ERROR(msgBuf, myThid)
       eeBootError = .TRUE.
       STOP 'ABNORMAL END: S/R INI_THREADING_ENVIRONMENT'
      ENDIF
      IF ( .NOT. eeBootError ) THEN
       byLo = 1
       DO J=1,nTy
        byHi = byLo+byPerThread-1
        bxLo = 1
        DO I=1,nTx
         thId = (J-1)*nTx+I
         bxHi = bxLo+bxPerThread-1
         myBxLo(thId) = bxLo
         myBxHi(thId) = bxHi
         myByLo(thId) = byLo
         myByHi(thId) = byHi
         bxLo = bxHi+1
        ENDDO
        byLo = byHi+1
       ENDDO
      ENDIF

      DO thId=1,nThreads
       CALL INI_COMMUNICATION_PATTERNS( thId )
      ENDDO

C--   Print mapping of threads to grid points.
      WRITE(msgBuf,'(A)')
     &'// ======================================================'
      CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
     &  SQUEEZE_RIGHT , 1)
      WRITE(msgBuf,'(A)') '// Mapping of tiles to threads'
      CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
     &  SQUEEZE_RIGHT , 1)
C     o Write list of tiles each thread is responsible for
      WRITE(msgBuf,'(A)')
     &'// ======================================================'
      CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
     &  SQUEEZE_RIGHT , 1)
      DO I=1,nThreads
       WRITE(msgBuf,'(A,I4,A,4(I4,A1))')
     & '// -o- Thread',I,', tiles (',
     & myBxLo(I),':',myBxHi(I),',',myByLo(I),':',myByHi(I),')'
       CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,SQUEEZE_BOTH , 1)
      ENDDO
      WRITE(msgBuf,'(A)')  ' '
      CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,SQUEEZE_RIGHT , 1)

#ifndef ALLOW_EXCH2
C     o For each tile print its communication method(s)
      WRITE(msgBuf,'(A)')
     &'// ======================================================'
      CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
     &  SQUEEZE_RIGHT , 1)
      WRITE(msgBuf,'(A)') '// Tile <-> Tile connectvity table'
      CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
     &  SQUEEZE_RIGHT , 1)
      WRITE(msgBuf,'(A)')
     &'// ======================================================'
      CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
     &  SQUEEZE_RIGHT , 1)
      DO J=1,nSy
       DO I=1,nSx
        WRITE(msgBuf,'(A,A,I6.6,A,I6.6,A)')
     &   '//',' Tile number: ',tileNo(I,J),
     &   ' (process no. = ',myPid,')'
        CALL PRINT_MESSAGE(msgBuf,standardMessageUnit,SQUEEZE_RIGHT , 1)
C       o West communication details
        IF ( tileNoW(I,J).NE. NULL_TILE ) THEN
         WRITE(msgBuf,'(A,A,I6.6,A,I6.6,A,A)')
     &   '//        WEST: ',
     &   'Tile = ',tileNoW(I,J),
     &   ', Process = ',tilePidW(I,J),
     &   ', Comm = ',commName(tileCommModeW(I,J))
         CALL PRINT_MESSAGE(msgBuf,standardMessageUnit,SQUEEZE_RIGHT, 1)
         WRITE(msgBuf,'(A,A,I6.6,A,I6.6)')
     &   '//              ',
     &   '  bi = ',tileBiW(I,J),
     &   ', bj = ',tileBjW(I,J)
         CALL PRINT_MESSAGE(msgBuf,standardMessageUnit,SQUEEZE_RIGHT, 1)
        ELSE
         WRITE(msgBuf,'(A)')
     &   '//         WEST: no neighbor'
         CALL PRINT_MESSAGE(msgBuf,standardMessageUnit,SQUEEZE_RIGHT, 1)
        ENDIF
C       o East communication details
        IF ( tileNoE(I,J).NE. NULL_TILE ) THEN
         WRITE(msgBuf,'(A,A,I6.6,A,I6.6,A,A)')
     &   '//        EAST: ',
     &   'Tile = ',tileNoE(I,J),
     &   ', Process = ',tilePidE(I,J),
     &   ', Comm = ',commName(tileCommModeE(I,J))
         CALL PRINT_MESSAGE(msgBuf,standardMessageUnit,SQUEEZE_RIGHT, 1)
         WRITE(msgBuf,'(A,A,I6.6,A,I6.6)')
     &   '//              ',
     &   '  bi = ',tileBiE(I,J),
     &   ', bj = ',tileBjE(I,J)
         CALL PRINT_MESSAGE(msgBuf,standardMessageUnit,SQUEEZE_RIGHT, 1)
        ELSE
         WRITE(msgBuf,'(A)')
     &   '//         EAST: no neighbor'
         CALL PRINT_MESSAGE(msgBuf,standardMessageUnit,SQUEEZE_RIGHT, 1)
        ENDIF
C       o South communication method
        IF ( tileNoS(I,J).NE. NULL_TILE ) THEN
         WRITE(msgBuf,'(A,A,I6.6,A,I6.6,A,A)')
     &   '//       SOUTH: ',
     &   'Tile = ',tileNoS(I,J),
     &   ', Process = ',tilePidS(I,J),
     &   ', Comm = ',commName(tileCommModeS(I,J))
         CALL PRINT_MESSAGE(msgBuf,standardMessageUnit,SQUEEZE_RIGHT, 1)
         WRITE(msgBuf,'(A,A,I6.6,A,I6.6)')
     &   '//              ',
     &   '  bi = ',tileBiS(I,J),
     &   ', bj = ',tileBjS(I,J)
         CALL PRINT_MESSAGE(msgBuf,standardMessageUnit,SQUEEZE_RIGHT, 1)
        ELSE
         WRITE(msgBuf,'(A)')
     &   '//        SOUTH: no neighbor'
         CALL PRINT_MESSAGE(msgBuf,standardMessageUnit,SQUEEZE_RIGHT, 1)
        ENDIF
C       o North communication method
        IF ( tileNoN(I,J).NE. NULL_TILE ) THEN
         WRITE(msgBuf,'(A,A,I6.6,A,I6.6,A,A)')
     &   '//       NORTH: ',
     &   'Tile = ',tileNoN(I,J),
     &   ', Process = ',tilePidN(I,J),
     &   ', Comm = ',commName(tileCommModeN(I,J))
         CALL PRINT_MESSAGE(msgBuf,standardMessageUnit,SQUEEZE_RIGHT, 1)
         WRITE(msgBuf,'(A,A,I6.6,A,I6.6)')
     &   '//              ',
     &   '  bi = ',tileBiN(I,J),
     &   ', bj = ',tileBjN(I,J)
         CALL PRINT_MESSAGE(msgBuf,standardMessageUnit,SQUEEZE_RIGHT, 1)
        ELSE
         WRITE(msgBuf,'(A)')
     &   '//        NORTH: no neighbor'
         CALL PRINT_MESSAGE(msgBuf,standardMessageUnit,SQUEEZE_RIGHT, 1)
        ENDIF
       ENDDO
      ENDDO
      WRITE(msgBuf,'(A)')  ' '
      CALL PRINT_MESSAGE( msgBuf,standardMessageUnit,SQUEEZE_RIGHT, 1)
#endif /* ndef ALLOW_EXCH2 */

C--   Check EXCH-1 options
#ifndef ALLOW_EXCH2
      IF ( usingMPI .AND. useCubedSphereExchange ) THEN
C-    not working with multi-procs (checked within EXCH1-CUBE S/R) and
C-    if compiled with MPI (without EXCH2) safer to set usingMPI to False.
        WRITE(msgBuf,'(2A)') 'EXCH-1 useCubedSphereExchange',
     &                       ' unsafe with usingMPI=True'
        CALL PRINT_ERROR( msgBuf, myThid )
        STOP 'ABNORMAL END: S/R INI_THREADING_ENVIRONMENT'
      ENDIF
      IF ( nThreads.GT.1 .AND. useCubedSphereExchange ) THEN
C-    multi-threads not working for local arrays; could remove the stop if
C     we are sure that only shared array (=in common blocks) are exchanged.
        WRITE(msgBuf,'(2A)') 'EXCH-1 useCubedSphereExchange',
     &                       ' unsafe with multi-threads'
        CALL PRINT_ERROR( msgBuf, myThid )
        STOP 'ABNORMAL END: S/R INI_THREADING_ENVIRONMENT'
      ENDIF
      IF ( nThreads.GT.1 ) THEN
       flag = .FALSE.
       DO J=1,nSy
        DO I=1,nSx
          flag = flag
     &       .OR. tileCommModeW(I,J).EQ.COMM_GET
     &       .OR. tileCommModeE(I,J).EQ.COMM_GET
     &       .OR. tileCommModeS(I,J).EQ.COMM_GET
     &       .OR. tileCommModeN(I,J).EQ.COMM_GET
        ENDDO
       ENDDO
       IF ( flag ) THEN
C-    multi-threads not working for local arrays; not safe neither for shared arrays
        WRITE(msgBuf,'(3A)') 'EXCH-1 using Comm = ',
     &   commName(COMM_GET), ' unsafe with multi-threads'
        CALL PRINT_ERROR( msgBuf, myThid )
        STOP 'ABNORMAL END: S/R INI_THREADING_ENVIRONMENT'
       ENDIF
      ENDIF
#endif /* ndef ALLOW_EXCH2 */

      RETURN
      END