eesupp/src/barrier.F

924557e60a Chri*0001 #include "CPP_EEOPTIONS.h"
                0002
4c563c2ee9 Chri*0003 CBOP
                0004 C     !ROUTINE: BARRIER_INIT
                0005
                0006 C     !INTERFACE:
924557e60a Chri*0007       SUBROUTINE BARRIER_INIT
e7ea7a463f Alis*0008       IMPLICIT NONE
a85d6ab24e Chri*0009
4c563c2ee9 Chri*0010 C     !DESCRIPTION:
                0011 C     *=====================================================================*
2b4c849245 Ed H*0012 C     | SUBROUTINE BARRIER\_INIT
4c563c2ee9 Chri*0013 C     | o Setup global barrier data structures.
                0014 C     *=====================================================================*
                0015 C     | Initialise global barrier data structures that can be used in
                0016 C     | conjunction with MPI or that can also be used to create
                0017 C     *=====================================================================*
                0018
                0019 C     !USES:
                0020 C     == Global variables ==
a85d6ab24e Chri*0021 #include "SIZE.h"
924557e60a Chri*0022 #include "EEPARAMS.h"
                0023 #include "EESUPPORT.h"
                0024 #include "BARRIER.h"
                0025
4c563c2ee9 Chri*0026 C     !LOCAL VARIABLES:
                0027 C     == Local Variables ==
                0028 C     I :: Loop counter
924557e60a Chri*0029       INTEGER I
4c563c2ee9 Chri*0030 CEOP
924557e60a Chri*0031
                0032       DO I=1,nThreads
                0033        key1(1,I) = INVALID
                0034        key2(1,I) = INVALID
                0035        key3(1,I) = INVALID
                0036        door1     = SHUT
                0037        door2     = SHUT
                0038        door3     = SHUT
a6a74ff42f Chri*0039        bCount(I) = 0
5bfeee1bf0 Chri*0040        masterSet(I) = 0
924557e60a Chri*0041       ENDDO
                0042
                0043       RETURN
                0044       END
4c563c2ee9 Chri*0045
                0046 CBOP
                0047 C     !ROUTINE: BARRIER
                0048
                0049 C     !INTERFACE:
924557e60a Chri*0050       SUBROUTINE BARRIER( myThid )
                0051       IMPLICIT NONE
a85d6ab24e Chri*0052
4c563c2ee9 Chri*0053 C     !DESCRIPTION:
                0054 C     *==========================================================*
84f025f053 Jean*0055 C     | SUBROUTINE BARRIER
                0056 C     | o Barrier routine that uses "busy waiting".
4c563c2ee9 Chri*0057 C     *==========================================================*
84f025f053 Jean*0058 C     | This routine provides a pure fortran mechanism to
                0059 C     | synchronise multiple threads in a multi-threaded code.
                0060 C     | No thread can leave this routine before all the threads
                0061 C     | have entered it.
                0062 C     | Notes
                0063 C     | =====
                0064 C     | The door and key variables are assumed to have been
                0065 C     | initialized once an initial state of key = INVALID
                0066 C     | and door = SHUT.
                0067 C     | We use the routine FOOL\_THE\_COMPILER to stop compilers
                0068 C     | generating code which might simply set and test a
                0069 C     | register value. Shared-memory systems only maintain
                0070 C     | coherency over process caches and not registers.
                0071 C     | Also we have to be a bit careful regarding sequential
                0072 C     | consistency - or lack of it. At the moment the code
                0073 C     | assumes a total store order memory model, which some
                0074 C     | machines do not have! However, I have yet to find a
                0075 C     | problem with this I think because the tolerances in
                0076 C     | terms of memory ordering i.e. a little bit of reordering
                0077 C     | probably will not break the barrier mechanism!
                0078 C     | On non-cache coherent systems e.g. T3E we need to use
                0079 C     | a library function to do barriers.
                0080 C     | Note - The PANIC tests can be removed for working code
                0081 C     |        I have left them in without an ifdef option
                0082 C     |        because without them programming errors can
                0083 C     |        lead to infinitely spinning code. If you are
                0084 C     |        confident that your code is OK then removing
                0085 C     |        them may increase performance. Do not remove these
                0086 C     |        lines to make your code "work" If the code is
                0087 C     |        stopping in these PANIC blocks then something is
                0088 C     |        wrong with your program and it needs to be fixed.
4c563c2ee9 Chri*0089 C     *==========================================================*
                0090
                0091 C     !USES:
                0092 C     == Global variables ==
a85d6ab24e Chri*0093 #include "SIZE.h"
924557e60a Chri*0094 #include "EEPARAMS.h"
                0095 #include "EESUPPORT.h"
                0096 #include "BARRIER.h"
                0097
4c563c2ee9 Chri*0098 C     !INPUT PARAMETERS:
                0099 C     == Routine arguments ==
924557e60a Chri*0100       INTEGER myThid
                0101
4c563c2ee9 Chri*0102 C     !LOCAL VARIABLES:
924557e60a Chri*0103 C     === Local variables ===
84f025f053 Jean*0104 C     nDone :: Counter for number of threads that have
4c563c2ee9 Chri*0105 C              completed a section.
                0106 C     I     :: Loop counter
924557e60a Chri*0107       INTEGER nDone
                0108       INTEGER I
4c563c2ee9 Chri*0109 CEOP
924557e60a Chri*0110
                0111 CcnhDebugStarts
1d73358b0d Chri*0112 C      WRITE(myThid,*) ' Barrier entered '
924557e60a Chri*0113 CcnhDebugEnds
                0114
a6a74ff42f Chri*0115 #ifdef USE_OMP_THREADING
                0116 C$OMP BARRIER
                0117       bCount(myThid) = bCount(myThid) + 1
5bfeee1bf0 Chri*0118       IF ( masterSet(myThid) .NE. 0 ) THEN
84f025f053 Jean*0119        PRINT *, 'BARRIER called for master reg myThid == ',
5bfeee1bf0 Chri*0120      &   myThid, masterSet(myThid)
                0121       ENDIF
a6a74ff42f Chri*0122 Cdbg C$OMP BARRIER
                0123 Cdbg       DO I=2, nThreads
                0124 Cdbg        IF (bCount(I) .NE. bCount(1) ) THEN
                0125 Cdbg          PRINT *, bCount(1:nThreads)
                0126 Cdbg          CALL SYSTEM('sleep 1')
                0127 Cdbg          PRINT *, bCount(1:nThreads)
                0128 Cdbg          PRINT *, bCount(1:nThreads)
                0129 Cdbg          PRINT *, bCount(1:nThreads)
                0130 Cdbg          PRINT *, bCount(1:nThreads)
                0131 Cdbg          STOP ' barrier out of sync '
                0132 Cdbg        ENDIF
                0133 Cdbg       ENDDO
                0134 Cdbg C$OMP BARRIER
                0135       RETURN
                0136 #endif
                0137
924557e60a Chri*0138 C--   Check that thread number is expected range
                0139       IF ( myThid .LT. 1 .OR. myThid .GT. nThreads ) THEN
2cfc9d59a2 Patr*0140        WRITE(*,*) '!!!!!!! PANIC !!!!!!! CATASTROPHIC ERROR'
84f025f053 Jean*0141        WRITE(*,*) '!!!!!!! PANIC !!!!!!! in S/R BARRIER  myThid = ',
46dc4f419b Chri*0142      &  myThid, ' nThreads = ', nThreads
924557e60a Chri*0143        STOP 'ABNROMAL END: S/R BARRIER'
                0144       ENDIF
                0145
                0146 C--   When every threads key1 is valid thread 1 will open door1.
                0147       IF ( key1(1,myThid) .EQ. VALID ) THEN
2cfc9d59a2 Patr*0148        WRITE(*,*) '!!!!!!! PANIC !!!!!!! CATASTROPHIC ERROR'
84f025f053 Jean*0149        WRITE(*,*) '!!!!!!! PANIC !!!!!!! in S/R BARRIER  myThid = ',
46dc4f419b Chri*0150      &  myThid, ' key1 already validated'
924557e60a Chri*0151        STOP 'ABNROMAL END: S/R BARRIER'
                0152       ENDIF
                0153       key1(1,myThid) = VALID
                0154
                0155       IF ( myThid .eq. 1 ) THEN
                0156    10  CONTINUE
                0157         nDone = 0
                0158         DO I=1,nThreads
                0159          if ( key1(1,I) .EQ. VALID ) nDone = nDone+1
                0160         ENDDO
84f025f053 Jean*0161         CALL FOOL_THE_COMPILER( key1(1,1) )
924557e60a Chri*0162        IF ( nDone .LT. nThreads ) GOTO 10
                0163        door1 = OPEN
                0164       ELSE
                0165   11   CONTINUE
                0166         CALL FOOL_THE_COMPILER( door1 )
                0167        IF ( door1 .NE. OPEN ) GOTO 11
                0168       ENDIF
                0169 C--   Invalidate keys for door1 here as it is now open
                0170       key1(1,myThid) = INVALID
                0171
                0172 CcnhDebugStarts
                0173 C     IF ( myThid .EQ. 1 ) THEN
2cfc9d59a2 Patr*0174 C      WRITE(*,*) ' DOOR1 Opened '
924557e60a Chri*0175 C     ENDIF
                0176 CcnhDebugEnds
                0177
                0178 C--   I can now shut door3 because I know everyone has reached
a28319ceb3 Alis*0179 C--   door1. I can not shut door1 because I do not know if everyone
924557e60a Chri*0180 C--   has "gone" through the door yet. Nobody has yet reached
                0181 C--   door3 because they have to go through door2 first.
                0182       IF ( myThid .EQ. 1 ) THEN
                0183        door3 = SHUT
                0184       ENDIF
                0185
                0186 C--   When every threads key2 is valid thread 1 will open door2.
                0187 C     Notes
                0188 C     =====
84f025f053 Jean*0189 C     I think that to work with any memory model ( i.e. relaxed,
924557e60a Chri*0190 C     partial store, total store) the variables key1, key2 and key3
                0191 C     might need to be set to invalid by thread 1.
84f025f053 Jean*0192 C
924557e60a Chri*0193       IF ( key2(1,myThid) .EQ. VALID ) THEN
2cfc9d59a2 Patr*0194        WRITE(*,*) '!!!!!!! PANIC !!!!!!! CATASTROPHIC ERROR'
84f025f053 Jean*0195        WRITE(*,*) '!!!!!!! PANIC !!!!!!! in S/R BARRIER  myThid = ',
46dc4f419b Chri*0196      &  myThid, ' key2 already validated'
924557e60a Chri*0197        STOP 'ABNROMAL END: S/R BARRIER'
                0198       ENDIF
                0199       key2(1,myThid) = VALID
                0200 C
                0201       IF ( myThid .eq. 1 ) THEN
                0202    20  CONTINUE
                0203         nDone = 0
                0204         DO I=1,nThreads
                0205          if ( key2(1,I) .EQ. VALID ) nDone = nDone+1
                0206         ENDDO
84f025f053 Jean*0207         CALL FOOL_THE_COMPILER( key2(1,1) )
924557e60a Chri*0208        IF ( nDone .LT. nThreads ) GOTO 20
                0209        door2 = OPEN
                0210       ELSE
                0211   21   CONTINUE
                0212         CALL FOOL_THE_COMPILER( door2 )
                0213        IF ( door2 .NE. OPEN ) GOTO 21
                0214       ENDIF
                0215
                0216 C--   Invalidate keys for door2 here as it is now open
                0217       key2(1,myThid) = INVALID
                0218
                0219 C--   I can now shut door1 because I know everyone has reached
a28319ceb3 Alis*0220 C--   door2. I can not shut door2 because I do not know if everyone
924557e60a Chri*0221 C--   has "gone" through the door yet. Nobody has yet reached
                0222 C--   door1 because they have to go through door3 first.
                0223       IF ( myThid .EQ. 1 ) THEN
                0224        door1 = SHUT
                0225       ENDIF
84f025f053 Jean*0226
                0227
924557e60a Chri*0228 C--   When every threads key3 is valid thread 1 will open door3.
                0229       IF ( key3(1,myThid) .EQ. VALID ) THEN
2cfc9d59a2 Patr*0230        WRITE(*,*) '!!!!!!! PANIC !!!!!!! CATASTROPHIC ERROR'
84f025f053 Jean*0231        WRITE(*,*) '!!!!!!! PANIC !!!!!!! in S/R BARRIER  myThid = ',
46dc4f419b Chri*0232      &  myThid, ' key3 already validated'
924557e60a Chri*0233        STOP 'ABNROMAL END: S/R BARRIER'
                0234       ENDIF
                0235       key3(1,myThid) = VALID
                0236 C
                0237       IF ( myThid .eq. 1 ) THEN
                0238    30  CONTINUE
                0239         nDone = 0
                0240         DO I=1,nThreads
                0241          if ( key3(1,I) .EQ. VALID ) nDone = nDone+1
                0242         ENDDO
84f025f053 Jean*0243         CALL FOOL_THE_COMPILER( key3(1,1) )
924557e60a Chri*0244        IF ( nDone .LT. nThreads ) GOTO 30
                0245        door3 = OPEN
                0246       ELSE
                0247   31   CONTINUE
                0248         CALL FOOL_THE_COMPILER( door3 )
                0249        IF ( door3 .NE. OPEN ) GOTO 31
                0250       ENDIF
                0251
                0252 C--   Invalidate keys for door3 here as it is now open
                0253       key3(1,myThid) = INVALID
                0254
                0255 C--   I can now shut door2 because I know everyone has reached
a28319ceb3 Alis*0256 C--   door3. I can not shut door3 because I do not know if everyone
924557e60a Chri*0257 C--   has "gone" through the door yet. Nobody has yet reached
                0258 C--   door2 because they have to go through door1 first.
                0259       IF ( myThid .EQ. 1 ) THEN
                0260        door2 = SHUT
                0261       ENDIF
                0262
                0263 CcnhDebugStarts
1d73358b0d Chri*0264 C      WRITE(myThid,*) ' Barrier exited '
924557e60a Chri*0265 CcnhDebugEnds
84f025f053 Jean*0266
924557e60a Chri*0267       RETURN
                0268       END
5bfeee1bf0 Chri*0269
                0270 CBOP
                0271       SUBROUTINE BARRIER_MS( myThid )
                0272       IMPLICIT NONE
                0273
                0274 C     !USES:
                0275 C     == Global variables ==
                0276 #include "SIZE.h"
                0277 #include "EEPARAMS.h"
                0278 #include "EESUPPORT.h"
                0279 #include "BARRIER.h"
                0280       INTEGER myThid
                0281
                0282       masterSet(myThid) = masterSet(myThid) + 1
                0283
                0284       RETURN
                0285       END
                0286       SUBROUTINE BARRIER_MU( myThid )
                0287       IMPLICIT NONE
                0288
                0289 C     !USES:
                0290 C     == Global variables ==
                0291 #include "SIZE.h"
                0292 #include "EEPARAMS.h"
                0293 #include "EESUPPORT.h"
                0294 #include "BARRIER.h"
                0295       INTEGER myThid
                0296
                0297       masterSet(myThid) = masterSet(myThid) - 1
                0298
                0299       RETURN
                0300       END