Fortran并行计算的一些例子

以下例子来自https://computing.llnl.gov/tutorials/openMP/exercise.html网站

一、打印线程（Hello world）

C******************************************************************************
C FILE: omp_hello.f
C DESCRIPTION:
C   OpenMP Example - Hello World - Fortran Version
C   In this simple example, the master thread forks a parallel region.
C   All threads in the team obtain their unique thread number and print it.
C   The master thread only prints the total number of threads.  Two OpenMP
C   library routines are used to obtain the number of threads and each
C   thread's number.
C AUTHOR: Blaise Barney  5/99
C LAST REVISED: 
C******************************************************************************

      PROGRAM HELLO
     
      INTEGER NTHREADS, TID, OMP_GET_NUM_THREADS, OMP_GET_THREAD_NUM
  
C     Fork a team of threads giving them their own copies of variables
!$OMP PARALLEL PRIVATE(NTHREADS, TID)


C     Obtain thread number
      TID = OMP_GET_THREAD_NUM()
      PRINT *, 'Hello World from thread = ', TID

C     Only master thread does this
      IF (TID .EQ. 0) THEN
        NTHREADS = OMP_GET_NUM_THREADS()
        PRINT *, 'Number of threads = ', NTHREADS
      END IF

C     All threads join master thread and disband
!$OMP END PARALLEL

      END

 二、循环（Loop work-sharing）

 1 C******************************************************************************
 2 C FILE: omp_workshare1.f
 3 C DESCRIPTION:
 4 C   OpenMP Example - Loop Work-sharing - Fortran Version
 5 C   In this example, the iterations of a loop are scheduled dynamically
 6 C   across the team of threads.  A thread will perform CHUNK iterations
 7 C   at a time before being scheduled for the next CHUNK of work.
 8 C AUTHOR: Blaise Barney  5/99
 9 C LAST REVISED: 01/09/04
10 C******************************************************************************
11  
12       PROGRAM WORKSHARE1
13 
14       INTEGER NTHREADS, TID, OMP_GET_NUM_THREADS,
15      +  OMP_GET_THREAD_NUM, N, CHUNKSIZE, CHUNK, I
16       PARAMETER (N=100)
17       PARAMETER (CHUNKSIZE=10) 
18       REAL A(N), B(N), C(N)
19 
20 !     Some initializations
21       DO I = 1, N
22         A(I) = I * 1.0
23         B(I) = A(I)
24       ENDDO
25       CHUNK = CHUNKSIZE
26 
27 !$OMP PARALLEL SHARED(A,B,C,NTHREADS,CHUNK) PRIVATE(I,TID)
28 
29       TID = OMP_GET_THREAD_NUM()
30       IF (TID .EQ. 0) THEN
31         NTHREADS = OMP_GET_NUM_THREADS()
32         PRINT *, 'Number of threads =', NTHREADS
33       END IF
34       PRINT *, 'Thread',TID,' starting...'
35 !$OMP DO SCHEDULE(DYNAMIC,CHUNK)
36       DO I = 1, N
37         C(I) = A(I) + B(I)
38         WRITE(*,100) TID,I,C(I)
39  100    FORMAT(' Thread',I2,': C(',I3,')=',F8.2)
40       ENDDO
41 !$OMP END DO NOWAIT
42       PRINT *, 'Thread',TID,' done.'
43 !$OMP END PARALLEL
44 
45       END

三、Sections work-sharing

C******************************************************************************
C FILE: omp_workshare2.f
C DESCRIPTION:
C   OpenMP Example - Sections Work-sharing - Fortran Version
C   In this example, the OpenMP SECTION directive is used to assign
C   different array operations to each thread that executes a SECTION. 
C AUTHOR: Blaise Barney  5/99
C LAST REVISED: 07/16/07
C******************************************************************************

      PROGRAM WORKSHARE2

      INTEGER N, I, NTHREADS, TID, OMP_GET_NUM_THREADS, 
     +        OMP_GET_THREAD_NUM
      PARAMETER (N=50)
      REAL A(N), B(N), C(N), D(N)

!     Some initializations
      DO I = 1, N
        A(I) = I * 1.5
        B(I) = I + 22.35
        C(N) = 0.0
        D(N) = 0.0
      ENDDO

!$OMP PARALLEL SHARED(A,B,C,D,NTHREADS), PRIVATE(I,TID)
      TID = OMP_GET_THREAD_NUM()
      IF (TID .EQ. 0) THEN
        NTHREADS = OMP_GET_NUM_THREADS()
        PRINT *, 'Number of threads =', NTHREADS
      END IF
      PRINT *, 'Thread',TID,' starting...'

!$OMP SECTIONS

!$OMP SECTION
      PRINT *, 'Thread',TID,' doing section 1'
      DO I = 1, N
         C(I) = A(I) + B(I)
         WRITE(*,100) TID,I,C(I)
 100     FORMAT(' Thread',I2,': C(',I2,')=',F8.2)
      ENDDO

!$OMP SECTION
      PRINT *, 'Thread',TID,' doing section 2'
      DO I = 1, N
         D(I) = A(I) * B(I)
         WRITE(*,100) TID,I,D(I)
      ENDDO


!$OMP END SECTIONS NOWAIT

      PRINT *, 'Thread',TID,' done.'

!$OMP END PARALLEL

      END

四、Combined parallel loop reduction

C******************************************************************************
C FILE: omp_reduction.f
C DESCRIPTION:
C   OpenMP Example - Combined Parallel Loop Reduction - Fortran Version
C   This example demonstrates a sum reduction within a combined parallel loop
C   construct.  Notice that default data element scoping is assumed - there
C   are no clauses specifying shared or private variables.  OpenMP will
C   automatically make loop index variables private within team threads, and
C   global variables shared.
C AUTHOR: Blaise Barney  5/99
C LAST REVISED:
C******************************************************************************

      PROGRAM REDUCTION

      INTEGER I, N
      REAL A(100), B(100), SUM

!     Some initializations
      N = 100
      DO I = 1, N
        A(I) = I *1.0
        B(I) = A(I)
      ENDDO
      SUM = 0.0

!$OMP PARALLEL DO REDUCTION(+:SUM)
      DO I = 1, N
        SUM = SUM + (A(I) * B(I))
      ENDDO

      PRINT *, '   Sum = ', SUM
      END

五、Orphaned parallel loop reduction

C******************************************************************************
C FILE: omp_orphan.f
C DESCRIPTION:
C   OpenMP Example - Parallel region with an orphaned directive - Fortran 
C   Version
C   This example demonstrates a dot product being performed by an orphaned
C   loop reduction construct.  Scoping of the reduction variable is critical.
C AUTHOR: Blaise Barney  5/99
C LAST REVISED:
C******************************************************************************

      PROGRAM ORPHAN
      COMMON /DOTDATA/ A, B, SUM
      INTEGER I, VECLEN
      PARAMETER (VECLEN = 100)
      REAL*8 A(VECLEN), B(VECLEN), SUM

      DO I=1, VECLEN
         A(I) = 1.0 * I
         B(I) = A(I)
      ENDDO
      SUM = 0.0
!$OMP PARALLEL
      CALL DOTPROD
!$OMP END PARALLEL
      WRITE(*,*) "Sum = ", SUM
      END



      SUBROUTINE DOTPROD
      COMMON /DOTDATA/ A, B, SUM
      INTEGER I, TID, OMP_GET_THREAD_NUM, VECLEN
      PARAMETER (VECLEN = 100)
      REAL*8 A(VECLEN), B(VECLEN), SUM

      TID = OMP_GET_THREAD_NUM()
!$OMP DO REDUCTION(+:SUM)
      DO I=1, VECLEN
         SUM = SUM + (A(I)*B(I))
         PRINT *, '  TID= ',TID,'I= ',I
      ENDDO
      RETURN
      END

六、Matrix multiply

C******************************************************************************
C FILE: omp_mm.f
C DESCRIPTION:  
C   OpenMp Example - Matrix Multiply - Fortran Version 
C   Demonstrates a matrix multiply using OpenMP. Threads share row iterations
C   according to a predefined chunk size.
C AUTHOR: Blaise Barney
C LAST REVISED: 1/5/04 Blaise Barney
C******************************************************************************

      PROGRAM MATMULT

      INTEGER  NRA, NCA, NCB, TID, NTHREADS, I, J, K, CHUNK,
     +         OMP_GET_NUM_THREADS, OMP_GET_THREAD_NUM
C     number of rows in matrix A 
      PARAMETER (NRA=62)
C     number of columns in matrix A
      PARAMETER (NCA=15)
C     number of columns in matrix B
      PARAMETER (NCB=7)

      REAL*8 A(NRA,NCA), B(NCA,NCB), C(NRA,NCB)

C     Set loop iteration chunk size 
      CHUNK = 10

C     Spawn a parallel region explicitly scoping all variables
!$OMP PARALLEL SHARED(A,B,C,NTHREADS,CHUNK) PRIVATE(TID,I,J,K)
      TID = OMP_GET_THREAD_NUM()
      IF (TID .EQ. 0) THEN
        NTHREADS = OMP_GET_NUM_THREADS()
        PRINT *, 'Starting matrix multiple example with', NTHREADS,
     +           'threads'
        PRINT *, 'Initializing matrices'
      END IF

C     Initialize matrices
!$OMP DO SCHEDULE(STATIC, CHUNK)
      DO 30 I=1, NRA
        DO 30 J=1, NCA
          A(I,J) = (I-1)+(J-1)
  30  CONTINUE
!$OMP DO SCHEDULE(STATIC, CHUNK)
      DO 40 I=1, NCA
        DO 40 J=1, NCB
          B(I,J) = (I-1)*(J-1)
  40  CONTINUE
!$OMP DO SCHEDULE(STATIC, CHUNK)
      DO 50 I=1, NRA
        DO 50 J=1, NCB
          C(I,J) = 0
  50  CONTINUE

C     Do matrix multiply sharing iterations on outer loop
C     Display who does which iterations for demonstration purposes
      PRINT *, 'Thread', TID, 'starting matrix multiply...'
!$OMP DO SCHEDULE(STATIC, CHUNK)
      DO 60 I=1, NRA
      PRINT *, 'Thread', TID, 'did row', I
        DO 60 J=1, NCB
          DO 60 K=1, NCA
            C(I,J) = C(I,J) + A(I,K) * B(K,J)
  60  CONTINUE

C     End of parallel region 
!$OMP END PARALLEL

C     Print results
      PRINT *, '******************************************************'
      PRINT *, 'Result Matrix:'
      DO 90 I=1, NRA
        DO 80 J=1, NCB
          WRITE(*,70) C(I,J)
  70      FORMAT(2x,f8.2,$)
  80      CONTINUE
          PRINT *, ' '
  90      CONTINUE
      PRINT *, '******************************************************'
      PRINT *, 'Done.'

      END

七、Get and print environment information

C******************************************************************************
C FILE: omp_getEnvInfo.f
C DESCRIPTION:
C   OpenMP Example - Get Environment Information - Fortran Version
C   The master thread queries and prints selected environment information.
C AUTHOR: Blaise Barney  7/06
C LAST REVISED: 07/12/06
C******************************************************************************

      PROGRAM GETINFO
     
      INTEGER NTHREADS, TID, OMP_GET_NUM_THREADS,
     +  OMP_GET_THREAD_NUM, OMP_GET_NUM_PROCS, OMP_GET_MAX_THREADS,
     +  OMP_IN_PARALLEL, OMP_GET_DYNAMIC, OMP_GET_NESTED,
     +  PROCS, MAXT

C     These are for AIX compilations
C     INTEGER INPAR, DYNAMIC, NESTED
C     These are for non-AIX compilations
      LOGICAL INPAR, DYNAMIC, NESTED
  
C     Start parallel region
!$OMP PARALLEL PRIVATE(NTHREADS, TID)

C     Obtain thread number
      TID = OMP_GET_THREAD_NUM()

C     Only master thread does this
      IF (TID .EQ. 0) THEN

        PRINT *, 'Thread',tid,'getting environment information'

C     Get environment information
        PROCS = OMP_GET_NUM_PROCS() 
        NTHREADS = OMP_GET_NUM_THREADS()
        MAXT = OMP_GET_MAX_THREADS()
        INPAR = OMP_IN_PARALLEL()
        DYNAMIC = OMP_GET_DYNAMIC()
        NESTED = OMP_GET_NESTED()

C     Print environment information
    
        PRINT *, 'Number of processors = ', PROCS
        PRINT *, 'Number of threads = ', NTHREADS
        PRINT *, 'Max threads = ', MAXT
        PRINT *, 'In parallel? = ', INPAR
        PRINT *, 'Dynamic threads enabled? = ', DYNAMIC
        PRINT *, 'Nested parallelism supported? = ', NESTED

      END IF

C     Done
!$OMP END PARALLEL

      END

八、Programs with bugs

（1)omp_bug1.f

C******************************************************************************
C FILE: omp_bug1.f
C DESCRIPTION:
C   This example attempts to show use of the PARALLEL DO construct.  However
C   it will generate errors at compile time.  Try to determine what is causing
C   the error.  See omp_bug1fix.f for a corrected version.
C AUTHOR: Blaise Barney  5/99
C LAST REVISED: 
C******************************************************************************

      PROGRAM WORKSHARE3

      INTEGER TID, OMP_GET_THREAD_NUM, N, I, CHUNKSIZE, CHUNK
      PARAMETER (N=50)
      PARAMETER (CHUNKSIZE=5) 
      REAL A(N), B(N), C(N)

!     Some initializations
      DO I = 1, N
        A(I) = I * 1.0
        B(I) = A(I)
      ENDDO
      CHUNK = CHUNKSIZE
            
!$OMP  PARALLEL DO SHARED(A,B,C,CHUNK) 
!$OMP& PRIVATE(I,TID) 
!$OMP& SCHEDULE(STATIC,CHUNK)

      TID = OMP_GET_THREAD_NUM()
      DO I = 1, N
         C(I) = A(I) + B(I)
         PRINT *,'TID= ',TID,'I= ',I,'C(I)= ',C(I)
      ENDDO

!$OMP  END PARALLEL DO

      END

（2）omp_bug1fix.f

C******************************************************************************
C FILE: omp_bug1fix.f
C DESCRIPTION:
C   This is a corrected version of the omp_bug1fix.f example. Corrections
C   include removing all statements between the PARALLEL DO construct and
C   the actual DO loop, and introducing logic to preserve the ability to 
C   query a thread's id and print it from inside the DO loop.
C AUTHOR: Blaise Barney  5/99
C LAST REVISED:
C******************************************************************************

      PROGRAM WORKSHARE4

      INTEGER TID, OMP_GET_THREAD_NUM, N, I, CHUNKSIZE, CHUNK
      PARAMETER (N=50)
      PARAMETER (CHUNKSIZE=5) 
      REAL A(N), B(N), C(N)
      CHARACTER FIRST_TIME

!     Some initializations
      DO I = 1, N
        A(I) = I * 1.0
        B(I) = A(I)
      ENDDO
      CHUNK = CHUNKSIZE
      FIRST_TIME = 'Y'
            
!$OMP  PARALLEL DO SHARED(A,B,C,CHUNK) 
!$OMP& PRIVATE(I,TID) 
!$OMP& SCHEDULE(STATIC,CHUNK)
!$OMP& FIRSTPRIVATE(FIRST_TIME) 

      DO I = 1, N
         IF (FIRST_TIME .EQ. 'Y') THEN
            TID = OMP_GET_THREAD_NUM()
            FIRST_TIME = 'N'
         ENDIF
         C(I) = A(I) + B(I)
         PRINT *,'TID= ',TID,'I= ',I,'C(I)= ',C(I)
      ENDDO

!$OMP  END PARALLEL DO

      END

（3）omp_bug2.f

C******************************************************************************
C FILE: omp_bug2.f
C DESCRIPTION:
C   Another OpenMP program with a bug
C AUTHOR: Blaise Barney  1/7/04
C LAST REVISED: 
C******************************************************************************

      PROGRAM BUG2
     
      INTEGER NTHREADS, I, TID, OMP_GET_NUM_THREADS,
     +        OMP_GET_THREAD_NUM
      REAL*8 TOTAL
  
C     Spawn parallel region
!$OMP PARALLEL 

C     Obtain thread number
      TID = OMP_GET_THREAD_NUM()
C     Only master thread does this
      IF (TID .EQ. 0) THEN
        NTHREADS = OMP_GET_NUM_THREADS()
        PRINT *, 'Number of threads = ', NTHREADS
      END IF
      PRINT *, 'Thread ',TID,'is starting...'

!$OMP BARRIER

C     Do some work
      TOTAL = 0.0
!$OMP DO SCHEDULE(DYNAMIC,10)
      DO I=1, 1000000
        TOTAL = TOTAL + I * 1.0
      END DO

      WRITE(*,100) TID,TOTAL
 100  FORMAT('Thread',I2,' is done! Total= ',E12.6)

!$OMP END PARALLEL

      END

（4）omp_bug3.f

C******************************************************************************
C FILE: omp_bug3.f
C DESCRIPTION:
C   Run time bug
C AUTHOR: Blaise Barney  01/09/04
C LAST REVISED: 06/28/05
C******************************************************************************

      PROGRAM BUG3

      INTEGER N, I, NTHREADS, TID, SECTION, OMP_GET_NUM_THREADS, 
     +        OMP_GET_THREAD_NUM
      PARAMETER (N=50)
      REAL A(N), B(N), C(N)

C     Some initializations
      DO I = 1, N
        A(I) = I * 1.0
        B(I) = A(I)
      ENDDO

!$OMP PARALLEL PRIVATE(C,I,TID,SECTION)
      TID = OMP_GET_THREAD_NUM()
      IF (TID .EQ. 0) THEN
        NTHREADS = OMP_GET_NUM_THREADS()
        PRINT *, 'Number of threads = ', NTHREADS
      END IF

C     Use barriers for clean output
!$OMP BARRIER
      PRINT *, 'Thread ',TID,' starting...'
!$OMP BARRIER

!$OMP SECTIONS
!$OMP SECTION
      SECTION = 1
      DO I = 1, N
         C(I) = A(I) * B(I)
      ENDDO
      CALL PRINT_RESULTS(C, TID, SECTION)

!$OMP SECTION
      SECTION = 2
      DO I = 1, N
         C(I) = A(I) + B(I)
      ENDDO
      CALL PRINT_RESULTS(C, TID, SECTION)

!$OMP END SECTIONS 

C     Use barrier for clean output
!$OMP BARRIER
      PRINT *, 'Thread',tid,' exiting...'

!$OMP END PARALLEL

      END



      SUBROUTINE PRINT_RESULTS(C, TID, SECTION)
      INTEGER TID, SECTION, N, I, J
      PARAMETER (N=50)
      REAL C(N)

      J = 1
C     Use critical for clean output
!$OMP CRITICAL
      PRINT *, ' '
      PRINT *, 'Thread',TID,' did section',SECTION
      DO I=1, N
        WRITE(*,100) C(I)
 100    FORMAT(E12.6,$)
        J = J + 1
        IF (J .EQ. 6) THEN
          PRINT *, ' '
          J = 1
        END IF
      END DO
      PRINT *, ' '
!$OMP END CRITICAL

!$OMP BARRIER
      PRINT *,'Thread',TID,' done and synchronized'

      END SUBROUTINE PRINT_RESULTS

(4)omp_bug4.f

C******************************************************************************
C FILE: omp_bug4.f
C DESCRIPTION:
C   This very simple program causes a segmentation fault.
C AUTHOR: Blaise Barney  01/09/04
C LAST REVISED: 
C******************************************************************************

      PROGRAM BUG4
     
      INTEGER N, NTHREADS, TID, I, J, OMP_GET_NUM_THREADS,
     +        OMP_GET_THREAD_NUM
      PARAMETER(N=1048)
      REAL*8 A(N,N)
  
C     Fork a team of threads with explicit variable scoping
!$OMP PARALLEL SHARED(NTHREADS) PRIVATE(I,J,TID,A)

C     Obtain/print thread info
      TID = OMP_GET_THREAD_NUM()
      IF (TID .EQ. 0) THEN
        NTHREADS = OMP_GET_NUM_THREADS()
        PRINT *, 'Number of threads = ', NTHREADS
      END IF
      PRINT *, 'Thread',TID,' starting...'

C     Each thread works on its own private copy of the array
      DO I=1,N
        DO J=1,N
          A(J,I) = TID + I + J
        END DO
      END DO

C     For confirmation
      PRINT *, 'Thread',TID,'done. Last element=',A(N,N)

C     All threads join master thread and disband
!$OMP END PARALLEL

      END

(5)omp_bug4fix.f

#!/bin/csh

#******************************************************************************
# FILE: omp_bug4fix
# DESCRIPTION:
#   This script is used to set the thread stack size limit to accomodate
#   the omp_bug4 example. The example code requires @16MB per thread. For
#   safety, this script sets the stack limit to 20MB. Note that the way
#   to do this differs between architectures. 
# AUTHOR: Blaise Barney  01/12/04
# LAST REVISED: 
#*****************************************************************************/

# This is for all systems
limit stacksize unlimited

# This is for IBM AIX systems
setenv XLSMPOPTS "stack=20000000"

# This is for Linux systems 
setenv KMP_STACKSIZE 20000000

# This is for HP/Compaq Tru64 systems
setenv MP_STACK_SIZE 20000000

# Now call the executable - change the name to match yours
omp_bug4

(6)omp_bug5.f

C******************************************************************************
C FILE: omp_bug5.f
C DESCRIPTION:
C   Using SECTIONS, two threads initialize their own array and then add 
C   it to the other's array, however a deadlock occurs.
C AUTHOR: Blaise Barney  01/09/04
C LAST REVISED:
C******************************************************************************

      PROGRAM BUG5
     
      INTEGER*8 LOCKA, LOCKB
      INTEGER NTHREADS, TID, I, 
     +        OMP_GET_NUM_THREADS, OMP_GET_THREAD_NUM
      PARAMETER (N=1000000)
      REAL A(N), B(N), PI, DELTA
      PARAMETER (PI=3.1415926535)
      PARAMETER (DELTA=.01415926535)

C     Initialize the locks
      CALL OMP_INIT_LOCK(LOCKA)
      CALL OMP_INIT_LOCK(LOCKB)

C     Fork a team of threads giving them their own copies of variables
!$OMP PARALLEL SHARED(A, B, NTHREADS, LOCKA, LOCKB) PRIVATE(TID)

C     Obtain thread number and number of threads
      TID = OMP_GET_THREAD_NUM()
!$OMP MASTER
      NTHREADS = OMP_GET_NUM_THREADS()
      PRINT *, 'Number of threads = ', NTHREADS
!$OMP END MASTER
      PRINT *, 'Thread', TID, 'starting...'
!$OMP BARRIER

!$OMP SECTIONS

!$OMP SECTION
      PRINT *, 'Thread',TID,' initializing A()'
      CALL OMP_SET_LOCK(LOCKA)
      DO I = 1, N
         A(I) = I * DELTA
      ENDDO
      CALL OMP_SET_LOCK(LOCKB)
      PRINT *, 'Thread',TID,' adding A() to B()'
      DO I = 1, N
         B(I) = B(I) + A(I)
      ENDDO
      CALL OMP_UNSET_LOCK(LOCKB)
      CALL OMP_UNSET_LOCK(LOCKA)

!$OMP SECTION
      PRINT *, 'Thread',TID,' initializing B()'
      CALL OMP_SET_LOCK(LOCKB)
      DO I = 1, N
         B(I) = I * PI
      ENDDO
      CALL OMP_SET_LOCK(LOCKA)
      PRINT *, 'Thread',TID,' adding B() to A()'
      DO I = 1, N
         A(I) = A(I) + B(I)
      ENDDO
      CALL OMP_UNSET_LOCK(LOCKA)
      CALL OMP_UNSET_LOCK(LOCKB)

!$OMP END SECTIONS NOWAIT

      PRINT *, 'Thread',TID,' done.'

!$OMP END PARALLEL

      END

(7)omp_bug5fix.f

C******************************************************************************
C FILE: omp_bug5fix.f
C DESCRIPTION:
C   The problem in omp_bug5.f is that the first thread acquires locka and then
C   tries to get lockb before releasing locka. Meanwhile, the second thread
C   has acquired lockb and then tries to get locka before releasing lockb.
C   This solution overcomes the deadlock by using locks correctly.
C AUTHOR: Blaise Barney  01/09/04
C LAST REVISED:
C******************************************************************************

      PROGRAM BUG5
     
      INTEGER*8 LOCKA, LOCKB
      INTEGER NTHREADS, TID, I, 
     +        OMP_GET_NUM_THREADS, OMP_GET_THREAD_NUM
      PARAMETER (N=1000000)
      REAL A(N), B(N), PI, DELTA
      PARAMETER (PI=3.1415926535)
      PARAMETER (DELTA=.01415926535)

C     Initialize the locks
      CALL OMP_INIT_LOCK(LOCKA)
      CALL OMP_INIT_LOCK(LOCKB)

C     Fork a team of threads giving them their own copies of variables
!$OMP PARALLEL SHARED(A, B, NTHREADS, LOCKA, LOCKB) PRIVATE(TID)

C     Obtain thread number and number of threads
      TID = OMP_GET_THREAD_NUM()
!$OMP MASTER
      NTHREADS = OMP_GET_NUM_THREADS()
      PRINT *, 'Number of threads = ', NTHREADS
!$OMP END MASTER
      PRINT *, 'Thread', TID, 'starting...'
!$OMP BARRIER

!$OMP SECTIONS

!$OMP SECTION
      PRINT *, 'Thread',TID,' initializing A()'
      CALL OMP_SET_LOCK(LOCKA)
      DO I = 1, N
         A(I) = I * DELTA
      ENDDO
      CALL OMP_UNSET_LOCK(LOCKA)
      CALL OMP_SET_LOCK(LOCKB)
      PRINT *, 'Thread',TID,' adding A() to B()'
      DO I = 1, N
         B(I) = B(I) + A(I)
      ENDDO
      CALL OMP_UNSET_LOCK(LOCKB)

!$OMP SECTION
      PRINT *, 'Thread',TID,' initializing B()'
      CALL OMP_SET_LOCK(LOCKB)
      DO I = 1, N
         B(I) = I * PI
      ENDDO
      CALL OMP_UNSET_LOCK(LOCKB)
      CALL OMP_SET_LOCK(LOCKA)
      PRINT *, 'Thread',TID,' adding B() to A()'
      DO I = 1, N
         A(I) = A(I) + B(I)
      ENDDO
      CALL OMP_UNSET_LOCK(LOCKA)

!$OMP END SECTIONS NOWAIT

      PRINT *, 'Thread',TID,' done.'

!$OMP END PARALLEL

      END

(8)omp_bug6.f

C******************************************************************************
C FILE: omp_bug6.f
C DESCRIPTION:
C   This program compiles and runs fine, but produces the wrong result.
C   Compare to omp_orphan.f.
C AUTHOR: Blaise Barney  6/05
C LAST REVISED: 06/27/05
C******************************************************************************

      PROGRAM ORPHAN
      COMMON /DOTDATA/ A, B
      INTEGER I, VECLEN
      REAL*8 SUM
      PARAMETER (VECLEN = 100)
      REAL*8 A(VECLEN), B(VECLEN)

      DO I=1, VECLEN
         A(I) = 1.0 * I
         B(I) = A(I)
      ENDDO
      SUM = 0.0
!$OMP PARALLEL SHARED (SUM)
      CALL DOTPROD
!$OMP END PARALLEL
      WRITE(*,*) "Sum = ", SUM
      END



      SUBROUTINE DOTPROD
      COMMON /DOTDATA/ A, B
      INTEGER I, TID, OMP_GET_THREAD_NUM, VECLEN
c     REAL*8 SUM
      PARAMETER (VECLEN = 100)
      REAL*8 A(VECLEN), B(VECLEN)

      TID = OMP_GET_THREAD_NUM()
!$OMP DO REDUCTION(+:SUM)
      DO I=1, VECLEN
         SUM = SUM + (A(I)*B(I))
         PRINT *, '  TID= ',TID,'I= ',I
      ENDDO
      RETURN
      END