“Begin at the beginning,” the King said gravely, “and go on till you come to the end: then stop.”

Alice’s Adventures in Wonderland

Parallel programming in Fortran is mostly focused on the use of technologies such as OpenMP, that implements a set of compiler directives, library routines, and environment variables that provides an API for multi-platform shared memory multiprocessing programming, and OpenMPI, a library implements a language-independent communications protocol used to program parallel computers. However, applied problems often require the use of manual and flexible task management, and one of the possible technologies can be used is POSIX Threads, a set of C programming language types, functions and constants implements an API for creating multi-threaded applications.

Implementations of the Pthreads library are available on many POSIX - conformant operating systems, and therefore, available for a wide range of programming languages. Unfortunately, only a few Fortran compilers provides a native interface for Pthreads. In this article I will discuss a simple example implementation of an interface to the Pthreads library that can be used in Fortran programs and an example of Ping Pong game, where two simultaneously executable thread display a message.

Due to significant differences between C and Fortran programming languages, primarily in the implementation of pointers and arrays, a call to function written in C requires a pre-processing for values passed between functions. The proposed interface for Fortran implementation of POSIX threads based on three levels of abstraction. The first is a pre-processing, provides a helper code. The second layer provides an interface for calling C functions from programs written in Fortran language. The third layer is implements a post-processing and directly calls the desired function of the PThreads library.

Lets consider an example of pthread_create wrapper implementation used to create a new thread of execution in the calling process. At the stage of pre-processing a pointer to a procedure is added to the table of functions, including specified argument:

    subroutine pthread_create(thread_id, attr_id, routine, argument, info)
        integer, intent(out) :: thread_id
        integer, intent(in)  :: attr_id
        procedure(IRunnable) :: routine
        integer, target      :: argument
        integer, intent(out) :: info

        procedure(IRunnableRoutine), bind(c), pointer :: routine_ptr
        type(TRunnablePointer), dimension(:), pointer :: buffer
        integer                                       :: index

        call thread_mutex_lock(routine_table_mutex, info)

        call thread_alloc(thread_id, info)
        if (thread_id .gt. routine_table_size) then
            nullify(buffer)
            allocate(buffer(routine_table_size * 2))

            do index = 1, routine_table_size
                buffer(index) = routine_table(index)
            end do

            deallocate(routine_table)
            routine_table => buffer
            routine_table_size = routine_table_size * 2
        endif

        allocate(routine_table(thread_id)%value)
        routine_table(thread_id)%value%run      => routine
        routine_table(thread_id)%value%argument => argument
        routine_ptr => start_routine

        call thread_create(thread_id, attr_id, c_funloc(routine_ptr), &
                c_loc(routine_table(thread_id)%value), info)

        call thread_mutex_unlock(routine_table_mutex, info)
    end subroutine

The second level is much easier than other two and only declares the interface for the functions implemented on the third level, written in C:

   subroutine thread_create(thread_id, attribute_id, routine, argument, info) bind(c)
        use iso_c_binding
        integer(c_int),     intent(in)  :: thread_id
        integer(c_int),     intent(in)  :: attribute_id
        type(c_funptr),     intent(in)  :: routine
        type(c_ptr), value, intent(in)  :: argument
        integer(c_int),     intent(out) :: info
    end subroutine
          

The post-processing on the third level is validates the status of threads, passed arguments, also adds those entries to the appropriate tables and directly calls the desired function:

void thread_create(int *thread_id, int *attribute_id, void *(**routine)(void *),
                   void *argument, int* info) {
    pthread_attr_t *attribute;
    int index = 0;
        *info = FT_OK;

    if (is_initialized == false) {
        *info = FT_EINIT;
        return;
    }

    if (is_valid(threads, *thread_id) == false) {
        *info = FT_EINVALID;
        return;
    }

    pthread_mutex_lock(&(threads->mutex));
    if (*attribute_id == -1) {
        attribute = (pthread_attr_t*) malloc(sizeof(pthread_attr_t));
        pthread_attr_init(attribute);
        pthread_attr_setdetachstate(attribute, PTHREAD_CREATE_JOINABLE);
    } else {
        if (is_valid(thread_attributes, *attribute_id) == false) {
            pthread_mutex_unlock(&(threads->mutex));
            *info = FT_EINVALID;
            return;
        }

        attribute = thread_attributes->data[*attribute_id];
    }

    *info = pthread_create(threads->data[*thread_id], attribute, (*routine), argument);
    if (*attribute_id == -1) {
        free(attribute);
    }

    if (*info) {
        pthread_mutex_unlock(&(threads->mutex));
        return;
    }

    pthread_mutex_unlock(&(threads->mutex));
}

          

Next, lets consider the use of POSIX threads to write a simple Ping Pong game where two created threads are waiting each other and alternately outputs its name to console:

!
! The Laboratory of Algorithms
!
! The MIT License
!
! Copyright 2011-2015 Andrey Pudov.
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the 'Software'), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in
! all copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
!

module MEPingPong

    use MPThreads

    implicit none
    private

    logical :: pingpong = .false.
    integer :: mutex

    type, public :: TEPingPong
    contains
        procedure :: present
    end type
contains
    subroutine present(instance)
        class(TEPingPong), intent(in) :: instance

        integer pinger
        integer ponger

        integer attribute_id
        integer argument
        integer, target  :: result
        integer, pointer :: result_pointer
        integer info

        argument     = 0
        attribute_id = -1
        result_pointer => result

        call pthread_init(info)
        if (info .ne. 0) then
            print *, 'Error initializing.'
            return
        end if

        call pthread_mutex_init(mutex, attribute_id, info)

        call pthread_create(pinger, attribute_id, ping, argument, info)
        call pthread_create(ponger, attribute_id, pong, argument, info)
        if (info .ne. 0) then
            print *, 'Error creating threads.'
        endif

        call pthread_join(pinger, result_pointer, info)
        call pthread_join(ponger, result_pointer, info)
        if (info .ne. 0) then
            print *, 'Error joining threads.'
        endif

        call pthread_mutex_destroy(mutex, info)
        call pthread_destroy(info)
        if (info .ne. 0) then
            print *, 'Error destroying.'
        endif
    end subroutine

    subroutine ping(argument)
        integer :: argument
        integer index
        integer info
        integer, target  :: status
        integer, pointer :: status_pointer

        status_pointer => status
        status         =  0

        do index = 1, 10
            call pthread_mutex_lock(mutex, info)

            if (pingpong) then
                print *, 'Ping'
                pingpong = .false.
            end if

            ! additional async output
            print *, ''

            call pthread_mutex_unlock(mutex, info)
        end do

        call pthread_exit(status_pointer)
    end subroutine

    subroutine pong(argument)
        integer :: argument
        integer index
        integer info
        integer, target  :: status
        integer, pointer :: status_pointer

        status_pointer => status
        status         =  0

        do index = 1, 10
            call pthread_mutex_lock(mutex, info)

            if (pingpong .ne. .true.) then
                print *, 'Pong'
                pingpong = .true.
            end if

            call pthread_mutex_unlock(mutex, info)
        end do

        call pthread_exit(status_pointer)
    end subroutine
end module

In this example, the main procedure present initializes the mutex and then creates two threads. Each thread invokes a procedure specified as an argument. Accordingly, the first thread executes the procedure pinger and second, as you can guess, the procedure ponger:

call pthread_create(pinger, attribute_id, ping, argument, info)
call pthread_create(ponger, attribute_id, pong, argument, info)
          

Both procedures first, locks the mutex and then prints the message on the screen. Because only one thread can own a mutex, the second thread is always waiting queue on the right to mutex, that leads to the exchange of this right between threads and in our case, the alternately outputs message.

This interface implementation is based on the work of Omar Awile, computer scientist specializing in high-performance computing, and contains only a basic example of using POSIX threads in programs written in Fortran. The source code of the interface and the example is available in the repository: https://github.com/andreypudov/Algorithms - Core/Threads directory provides implementation of the interface, and Examples/PingPong.f file presents the game.