! bof
! **********************************************************************
! Fortran 95 module fthreads

! **********************************************************************
! Source Control Strings

! $Source$
! $Revision$
! $State$
! $Date$

! **********************************************************************
!  Copyright 2000 Purple Sage Computing Solutions, Inc.

!   This library is free software; you can redistribute it and/or
!   modify it under the terms of the GNU Library General Public
!   License as published by the Free Software Foundation; either
!   version 2 of the License, or (at your option) any later version.

!   This library is distributed in the hope that it will be useful,
!   but WITHOUT ANY WARRANTY; without even the implied warranty of
!   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!   Library General Public License for more details.

!   You should have received a copy of the GNU Library General Public
!   License along with this library; if not, write to the Free
!   Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

! To report bugs, suggest enhancements, etc. to the Authors,
! Contact:
!    Purple Sage Computing Solutions, Inc.
!                               send email to dnagle@erols.com
!                                   or fax to 703 471 0684 (USA)
!                                  or mail to 12142 Purple Sage Ct.
!                                             Reston, VA 20194-5621 USA

! **********************************************************************
! fthreads provides a fork-join thread kit for Fortran 95 on Win32.

! This verison of fthreads supports Compaq's CVF 6.1 compiler.

! **********************************************************************
! use standard_types for processor dependent kind parameters

! **********************************************************************

!  fthreads public types

!     thread_t    public thread type
!     team_t      public team type
!     barrier_t   public barrier type
!     event_t     public event type
!     mutex_t     public mutex type

!     trace_t     public buffer for logging fthreads actions

! ----------------------------------------------------------------------

!  fthreads private types

!     p_thread_t  private thread type
!     p_team_t    private team type
!     p_barrier_t private barrier type
!     p_event_t   private event type
!     p_mutex_t   private mutex type

! ----------------------------------------------------------------------

!  fthreads public constants

!     fthread_rcs_source       public string
!     fthread_rcs_revision     public string
!     fthread_rcs_state        public string
!     fthread_rcs_date         public string

!     name_length              public length of fthreads names
!     dt_values_size           public size of date_and_time values array

!     fthread_ok               public status ok value
!     fthread_buffer_wrap      public trace_t wrapped value
!     fthread_running          public worker thread(s) still executing

!     fthread_error_state       public state error
!     fthread_error_number      public bad number
!     fthread_error_allocate    public allocate/deallocate failed
!     fthread_error_syscall     public NT system call error
!     fthread_error_active      public threads are still active
!     fthread_error_not_primary public call not made by thread 1
!     fthread_error_io          public io failed
!     fthread_error_team        public nonteam thread used team resources

!     default_max_team         public default number of teams
!     default_barrier_max      public default number of barriers
!     default_event_max        public default number of events
!     default_mutex_max        public default number of mutexs

!  fthreads private constants

!     cs_size                  private size of critical section struct

!  fthreads private variables

!     threads    private array of p_thread_t
!     teams      private array of p_team_t
!     barriers   private array of p_barrier_t
!     events     private array of p_event_t
!     mutexs     private array of p_mutex_t

!  fthreads library

!     trace_init()      initialize a trace variable
!     trace_msg()       put a message in a trace variable
!     trace_print()     write the contents of a trace variable
!     trace_status()    get trace variable statistics

!     fthread_cpus()       number of processors
!     fthread_count()      number of threads
!     is_fthreads_error()  true if flag is an error code
!     fthreads_error_msg() return message for flag

!     fthread_init()    starts fthreads
!     fthread_end()     ends fthreads
!     fthread_status()  get fthreads statistics

!     thread_create()   creates a thread, gives procedure to execute
!     thread_wait()     waits for given thread to exit
!     thread_waitall()  waits for all threads to exit
!     thread_return()   thread returns

!     thread_pause()    suspend thread
!     thread_run()      resume thread

!     thread_id()       get thread identifier
!     thread_priority() get or set thread priority
!     thread_status()   get thread statistics

!     team_init()       initializes a team
!     team_del()        ends a team

!     team_id()         get team identifier
!     team_member()     true if thread is member of team
!     team_status()     get team statistics

!     barrier_init()    initialize a barrier
!     barrier_del()     ends a barrier
!     barrier_sync()    mark arrival at a barrier

!     barrier_id()      get barrier identifier
!     barrier_status()  get barrier statistics

!     event_init()      initialize an event
!     event_del()       end an event
!     event_wait()      wait for an event
!     event_clear()     clear a posted event
!     event_waitclear() wait for then clear an event
!     event_post()      post an event
!     event_pulse()     post then clear an event

!     event_id()        get event identifier
!     event_status()    get event statistics

!     mutex_init()      initialize a mutex
!     mutex_del()       ends a mutex
!     mutex_lock()      lock a mutex
!     mutex_try()       immediate return w/ or w/o mutex
!     mutex_unlock()    unlock a mutex

!     mutex_id()        get mutex identifier
!     mutex_status()    get mutex statistics

!     critical_add()    atomic add
!     critical_mul()    atomic multiply
!     critical_inc()    atomic default integer increment (+1)
!     critical_dec()    atomic default integer decrement (-1)

!     critical_and()    atomic and
!     critical_or()     atomic or
!     critical_eor()    atomic eor

!     critical_max()       atomic maximum
!     critical_min()       atomic minimum
!     critical_maxcopy()   atomic max and copy
!     critical_mincopy()   atomic min and copy

! **********************************************************************

!  fthreads

! **********************************************************************

module fthreads

! **********************************************************************

!  fthreads uses

! **********************************************************************

use standard_types                                         ! processor dependencies

! **********************************************************************

!  set implicit none

! **********************************************************************

implicit none                                              ! declare all variables

! **********************************************************************

!  fthread RCS strings

! **********************************************************************

!  module source filename supplied by RCS

character( len= *), parameter :: fthreads_rcs_source = &
      '$Source$'

!  module revision supplied by RCS

character( len= *), parameter :: fthreads_rcs_revision = &
      '$Revision$'

!  module revision state supplied by RCS

character( len= *), parameter :: fthreads_rcs_state = &
      '$State$'

!  module revision date supplied by RCS

character( len= *), parameter :: fthreads_rcs_date = &
      '$Date$'

! **********************************************************************

!  fthreads types

! **********************************************************************

!  constants describing fthreads types

! **********************************************************************

!  length of fthreads type's name component

integer, parameter :: name_length = 80                     ! characters reserved for labels

!  date & time values array size

integer, private, parameter :: t_size = 2                  ! elements in values array

!  critical section size

integer, private, parameter :: cs_size = 8                 ! words in critical section

! **********************************************************************

!  fthreads derived types

! **********************************************************************

!  fthreads public derived types

! ----------------------------------------------------------------------

!  fthreads public thread type

type :: thread_t                                           ! user's thread type

   private                                                 ! use thread_id()

   integer :: id                                           ! thread id

end type thread_t                                          ! user's thread type

!  fthreads public team type

type :: team_t                                             ! user's team type

   private                                                 ! use team_id()

   integer :: id                                           ! team id

end type team_t                                            ! user's team type

!  fthreads public barrier type

type :: barrier_t                                          ! user's barrier type

   private                                                 ! use barrier_id()

   integer :: id                                           ! barrier id

end type barrier_t                                         ! user's barrier type

!  fthreads public event type

type :: event_t                                            ! user's event type

   private                                                 ! use event_id()

   integer :: id                                           ! event id

end type event_t                                           ! user's event type

!  fthreads public mutex type

type :: mutex_t                                            ! user's mutex type

   private                                                 ! use mutex_id()

   integer :: id                                           ! mutex id

end type mutex_t                                           ! user's mutex type

!  fthreads public trace buffer type

integer, parameter :: msgs_length = 120                    ! length of trace message

type :: trace_t                                            ! user's trace type

   private                                                 ! use supplied interface

   logical :: have_cs                                      ! have or not critical section

   integer, dimension( cs_size) :: cs                      ! critical section

   integer :: next_in, next_out, first, last               ! define buffer size

   logical :: empty                                        ! no messages if true

   integer :: tmsgs, tpr                                   ! trace buffer statistics

   character( len= msgs_length), dimension( :), pointer :: msgs

end type trace_t                                           ! user's trace type

! **********************************************************************

!  fthreads private dreived types

! ----------------------------------------------------------------------

!  p_thread_t private thread type

type, private :: p_thread_t                                ! per thread data

   integer :: handle                                       ! Win32 thread handle

   integer :: win32_id                                     ! Win32 id

   integer :: rv                                           ! thread return value

   integer, dimension( t_size) :: ctime                    ! creation filetime

   integer, dimension( t_size) :: etime                    ! end filetime

   real :: utime                                           ! user time

   real :: ktime                                           ! kernel time

   character( len= name_length) :: label                   ! thread name string

end type p_thread_t                                        ! per thread data

! ----------------------------------------------------------------------

!  p_team_t private team type

type, private :: p_team_t                                  ! per team data

   logical, dimension( :), pointer :: list                 ! true if on team

   character( len= name_length) :: label                   ! team name string

end type p_team_t                                          ! per team data

! ----------------------------------------------------------------------

!  p_barrier_t private barrier type

type, private :: p_barrier_t                               ! per barrier data

   integer :: mutex                                        ! barrier Win32 mutex handle

   integer :: event                                        ! barrier Win32 event handle

   integer :: team                                         ! team using this barrier

   integer :: height                                       ! number required to pass barrier

   integer :: current                                      ! threads at barrier

   integer :: syncs                                        ! threads sync at barrier

   character( len= name_length) :: label                   ! barrier name string

end type p_barrier_t                                       ! per barrier data

! ----------------------------------------------------------------------

!  p_event_t private event type

type, private :: p_event_t                                 ! per event data

   integer :: handle                                       ! Win32 event handle

   integer :: team                                         ! team using this event

   integer :: waits                                        ! threads waited on event

   integer :: posts                                        ! threads posted event

   integer :: clears                                       ! threads cleared event

   character( len= name_length) :: label                   ! event name string

end type p_event_t                                         ! per event data

! ----------------------------------------------------------------------

!  p_mutex_t private mutex type

type, private :: p_mutex_t                                 ! per mutex data

   integer, dimension( cs_size) :: cs                      ! Win32 critical_section

   integer :: team                                         ! team using this mutex

   integer :: locks                                        ! threads locked mutex

   integer :: unlocks                                      ! threads unlocked mutex

   character( len= name_length) :: label                   ! mutex name string

end type p_mutex_t                                         ! per mutex data

! **********************************************************************

!  Win32 constants

! **********************************************************************

!  private Win32 C constants

! ----------------------------------------------------------------------

integer, private, parameter :: win32_null = 0              ! Win32 C NULL

integer, private, parameter :: win32_true = 1              ! Win32 C TRUE
integer, private, parameter :: win32_false = 0             ! Win32 C FALSE

!  public Win32 duplicate handle options

integer, private, parameter :: win32_same_access = 2       ! want same access

!  public Win32 wait return values

integer, private, parameter :: win32_infinite = -1         ! = 0xffffffff
integer, private, parameter :: win32_wait_object_0 = 0     ! thread, event or mutex

!  public Win32 thread exit codes

integer, private, parameter :: win32_still_active = 259    ! = 0x00000103

!  public Win32 thread suspend/resume error

integer, private, parameter :: win32_bad_suspend = -1      ! = 0xffffffff

!  private Win32 priority get/set error

integer, private, parameter :: win32_priority_error = huge( 0)

! **********************************************************************

!  public Win32 C constants

! ----------------------------------------------------------------------

!  public Win32 thread priorities

integer, parameter :: win32_priority_lowest = -2           ! lowest priority within process
integer, parameter :: win32_priority_below_normal = -1     ! mid low priority within process
integer, parameter :: win32_priority_normal = 0            ! average priority within process
integer, parameter :: win32_priority_above_normal = 1      ! mid high priority within process
integer, parameter :: win32_priority_highest = 2           ! highest priority within process

! **********************************************************************

!  fthreads public status and error codes

integer, parameter :: fthread_ok = 0                       ! no error

integer, parameter :: fthread_buffer_wrap = 1              ! trace buffer wrapped

!  fthreads public error codes

integer, parameter :: fthread_error_number = -1            ! user's number too big or too small
integer, parameter :: fthread_error_state = -2             ! initialized versus not initialized
integer, parameter :: fthread_error_allocate = -3          ! Fortran allocate error
integer, parameter :: fthread_error_syscall = -4           ! Win32 system called failed
integer, parameter :: fthread_error_active = -5            ! thread is active versus inactive
integer, parameter :: fthread_error_not_primary = -6       ! action only by primary thread
integer, parameter :: fthread_error_io = -7                ! Fortran I/O error
integer, parameter :: fthread_error_team = -8              ! on team versus not on team

! **********************************************************************

!  fthread constants

! **********************************************************************

!  default maximum number of barriers, events, mutexs

integer, parameter :: default_barrier_max = 128            ! entries in barriers array
integer, parameter :: default_event_max = 128              ! entries in events array
integer, parameter :: default_mutex_max = 128              ! entries in mutexs array

! ----------------------------------------------------------------------

!  fthreads names and ids of threads and teams

! ----------------------------------------------------------------------

!  Primary thread id

integer, parameter :: primary_id = 0                       ! first thread is 'primary'
integer, private, parameter :: worker_1 = primary_id + 1   ! first worker thread

!  Primary thread variable

type( thread_t), parameter :: primary = thread_t( primary_id)

!  'all threads' team id

integer, parameter :: all_threads_id = 0                   ! first team is 'all threads'

!  'all workers' team id

integer, parameter :: all_workers_id = 1                   ! second team is 'all worker threads'

!  'all threads' team variable

type( team_t), parameter :: all_threads = team_t( all_threads_id)

!  'all workers' team variable

type( team_t), parameter :: all_workers = team_t( all_workers_id)

! ----------------------------------------------------------------------

!  default name of thread 0 is Primary

character( len= *), private, parameter :: default_primary_name = 'Primary'

!  default name of thread n, n > 0, is Worker_n

character( len= *), private, parameter :: default_thread_name = 'Worker_'

!  default name of team 0 is All_Threads

character( len= *), private, parameter :: default_all_threads_name = 'All_Threads'

!  default name of team 1 is all_workers_id

character( len= *), private, parameter :: default_all_workers_name = 'All_Workers'

!  default name of team n, n > 1, is Team_n

character( len= *), private, parameter :: default_team_name = 'Team_'

!  default name of barrier n, is Barrier_n

character( len= *), private, parameter :: default_barrier_name = 'Barrier_'

!  default name of event n, is Event_n

character( len= *), private, parameter :: default_event_name = 'Event_'

!  default name of mutex n, is Mutex_n

character( len= *), private, parameter :: default_mutex_name = 'Mutex_'

! **********************************************************************

!  fthread private data

! **********************************************************************

!  mark when fthreads is initialized

logical, private, save :: initialized = .false.

! ----------------------------------------------------------------------

!  thread array

type( p_thread_t), private, dimension( :), pointer, save :: threads => null()

!  only primary thread exists now

integer, private, save :: this_thread = primary_id
integer, private, save :: max_thread_id = primary_id

! ----------------------------------------------------------------------

!  team array

type( p_team_t), private, dimension( :), pointer, save :: teams => null()

!  only 'all threads' team exists now

integer, private, save :: this_team = all_workers_id
integer, private, save :: max_team_id = all_workers_id

! ----------------------------------------------------------------------

!  barrier array

type( p_barrier_t), private, dimension( :), pointer, save :: barriers => null()

integer, private, save :: this_barrier = 0                 ! no barriers initialized til barrier_init()
integer, private, save :: max_barrier_id = 0               ! none allocated til fthread_init()

! ----------------------------------------------------------------------

!  event array

type( p_event_t), private, dimension( :), pointer, save :: events => null()

integer, private, save :: this_event = 0                   ! no events initialized til event_init()
integer, private, save :: max_event_id = 0                 ! none allocated til fthread_init()

! ----------------------------------------------------------------------

!  mutex array

type( p_mutex_t), private, dimension( :), pointer, save :: mutexs => null()

integer, private, save :: this_mutex = 0                   ! no mutexs initialized til mutex_init()
integer, private, save :: max_mutex_id = 0                 ! none allocated til fthread_init()

! **********************************************************************

!  fthreads library

! **********************************************************************

!  use generic interfaces to specific procedures

! **********************************************************************

!  interface critical_add()

public :: critical_add                                     ! use generic name

private :: byte_critical_add                               ! access by generic critical_add() only
private :: short_critical_add                              ! access by generic critical_add() only
private :: int_critical_add                                ! access by generic critical_add() only
private :: single_critical_add                             ! access by generic critical_add() only
private :: double_critical_add                             ! access by generic critical_add() only
private :: single_complex_critical_add                     ! access by generic critical_add() only
private :: double_complex_critical_add                     ! access by generic critical_add() only

interface critical_add

   module procedure byte_critical_add                      ! critical_add( byte)
   module procedure short_critical_add                     ! critical_add( short)
   module procedure int_critical_add                       ! critical_add( int)
   module procedure single_critical_add                    ! critical_add( single)
   module procedure double_critical_add                    ! critical_add( double)
   module procedure single_complex_critical_add            ! critical_add( single_complex)
   module procedure double_complex_critical_add            ! critical_add( double_complex)

end interface

! ----------------------------------------------------------------------

!  interface critical_mul()

public :: critical_mul                                     ! use generic name

private :: byte_critical_mul                               ! access by generic critical_mul() only
private :: short_critical_mul                              ! access by generic critical_mul() only
private :: int_critical_mul                                ! access by generic critical_mul() only
private :: single_critical_mul                             ! access by generic critical_mul() only
private :: double_critical_mul                             ! access by generic critical_mul() only
private :: single_complex_critical_mul                     ! access by generic critical_mul() only
private :: double_complex_critical_mul                     ! access by generic critical_mul() only

interface critical_mul

   module procedure byte_critical_mul                      ! critical_mul( byte integer)
   module procedure short_critical_mul                     ! critical_mul( short integer)
   module procedure int_critical_mul                       ! critical_mul( int integer)
   module procedure single_critical_mul                    ! critical_mul( single real)
   module procedure double_critical_mul                    ! critical_mul( double real)
   module procedure single_complex_critical_mul            ! critical_mul( single complex)
   module procedure double_complex_critical_mul            ! critical_mul( double complex)

end interface

! ----------------------------------------------------------------------

!  interface critical_and()

public :: critical_and                                     ! use generic name

private :: byte_critical_and                               ! access by critical_and() only
private :: short_critical_and                              ! access by critical_and() only
private :: int_critical_and                                ! access by critical_and() only
private :: l_byte_critical_and                             ! access by critical_and() only
private :: l_short_critical_and                            ! access by critical_and() only
private :: l_int_critical_and                              ! access by critical_and() only

interface critical_and

   module procedure byte_critical_and                      ! critical_and( byte integer)
   module procedure short_critical_and                     ! critical_and( short integer)
   module procedure int_critical_and                       ! critical_and( int integer)
   module procedure l_byte_critical_and                    ! critical_and( byte logical)
   module procedure l_short_critical_and                   ! critical_and( short logical)
   module procedure l_int_critical_and                     ! critical_and( int logical)

end interface

! ----------------------------------------------------------------------

!  interface critical_or()

public :: critical_or                                      ! use generic name

private :: byte_critical_or                                ! access by critical_or() only
private :: short_critical_or                               ! access by critical_or() only
private :: int_critical_or                                 ! access by critical_or() only
private :: l_byte_critical_or                              ! access by critical_or() only
private :: l_short_critical_or                             ! access by critical_or() only
private :: l_int_critical_or                               ! access by critical_or() only

interface critical_or

   module procedure byte_critical_or                       ! critical_or( byte integer)
   module procedure short_critical_or                      ! critical_or( short integer)
   module procedure int_critical_or                        ! critical_or( int integer)
   module procedure l_byte_critical_or                     ! critical_or( byte logical)
   module procedure l_short_critical_or                    ! critical_or( short logical)
   module procedure l_int_critical_or                      ! critical_or( int logical)

end interface

! ----------------------------------------------------------------------

!  interface critical_eor()

public :: critical_eor                                     ! use generic name

private :: byte_critical_eor                               ! access by critical_eor() only
private :: short_critical_eor                              ! access by critical_eor() only
private :: int_critical_eor                                ! access by critical_eor() only
private :: l_byte_critical_eor                             ! access by critical_eor() only
private :: l_short_critical_eor                            ! access by critical_eor() only
private :: l_int_critical_eor                              ! access by critical_eor() only

interface critical_eor

   module procedure byte_critical_eor                      ! critical_eor( byte integer)
   module procedure short_critical_eor                     ! critical_eor( short integer)
   module procedure int_critical_eor                       ! critical_eor( int integer)
   module procedure l_byte_critical_eor                    ! critical_eor( byte logical)
   module procedure l_short_critical_eor                   ! critical_eor( short logical)
   module procedure l_int_critical_eor                     ! critical_eor( int logical)

end interface

! ----------------------------------------------------------------------

!  interface critical_max()

public :: critical_max                                     ! use generic name

private :: byte_critical_max                               ! access by critical_max() only
private :: short_critical_max                              ! access by critical_max() only
private :: int_critical_max                                ! access by critical_max() only
private :: single_critical_max                             ! access by critical_max() only
private :: double_critical_max                             ! access by critical_max() only

interface critical_max

   module procedure byte_critical_max                      ! critical_max( byte integer)
   module procedure short_critical_max                     ! critical_max( short integer)
   module procedure int_critical_max                       ! critical_max( int integer)
   module procedure single_critical_max                    ! critical_max( single real)
   module procedure double_critical_max                    ! critical_max( double real)

end interface

! ----------------------------------------------------------------------

!  interface critical_min()

public :: critical_min                                     ! use generic name

private :: byte_critical_min                               ! access by critical_min() only
private :: short_critical_min                              ! access by critical_min() only
private :: int_critical_min                                ! access by critical_min() only
private :: single_critical_min                             ! access by critical_min() only
private :: double_critical_min                             ! access by critical_min() only

interface critical_min

   module procedure byte_critical_min                      ! critical_min( byte integer)
   module procedure short_critical_min                     ! critical_min( short integer)
   module procedure int_critical_min                       ! critical_min( int integer)
   module procedure single_critical_min                    ! critical_min( single real)
   module procedure double_critical_min                    ! critical_min( double real)

end interface

! ----------------------------------------------------------------------

!  interface critical_maxcopy()

public :: critical_maxcopy                                 ! use generic name

private :: byte_critical_maxcopy                           ! access by critical_maxcopy() only
private :: short_critical_maxcopy                          ! access by critical_maxcopy() only
private :: int_critical_maxcopy                            ! access by critical_maxcopy() only
private :: single_critical_maxcopy                         ! access by critical_maxcopy() only
private :: double_critical_maxcopy                         ! access by critical_maxcopy() only

interface critical_maxcopy

   module procedure byte_critical_maxcopy                  ! critical_maxcopy( byte integer)
   module procedure short_critical_maxcopy                 ! critical_maxcopy( short integer)
   module procedure int_critical_maxcopy                   ! critical_maxcopy( int integer)
   module procedure single_critical_maxcopy                ! critical_maxcopy( single real)
   module procedure double_critical_maxcopy                ! critical_maxcopy( double real)

end interface

! ----------------------------------------------------------------------

!  interface critical_mincopy()

public :: critical_mincopy                                 ! use generic name

private :: byte_critical_mincopy                           ! access by critical_mincopy() only
private :: short_critical_mincopy                          ! access by critical_mincopy() only
private :: int_critical_mincopy                            ! access by critical_mincopy() only
private :: single_critical_mincopy                         ! access by critical_mincopy() only
private :: double_critical_mincopy                         ! access by critical_mincopy() only

interface critical_mincopy

   module procedure byte_critical_mincopy                  ! critical_mincopy( byte integer)
   module procedure short_critical_mincopy                 ! critical_mincopy( short integer)
   module procedure int_critical_mincopy                   ! critical_mincopy( int integer)
   module procedure single_critical_mincopy                ! critical_mincopy( single real)
   module procedure double_critical_mincopy                ! critical_mincopy( double real)

end interface

! **********************************************************************

!  fthreads module procedures

! **********************************************************************

contains                                                   ! fthreads

! **********************************************************************
! **********************************************************************

!  ### public fthreads trace procedures

!  these procedures implement the fthreads trace facility

! **********************************************************************

!  trace_init() initialize a trace_t variable

! **********************************************************************

subroutine trace_init( max_msgs, lock, trace_v, flag)

!  trace_init() interface

integer, intent( in) :: max_msgs                           ! messages in buffer

logical, optional, intent( in) :: lock                     ! true --> single thread access

type( trace_t), intent( out) :: trace_v                    ! the trace variable

integer, optional, intent( out) :: flag                    ! status flag

! ----------------------------------------------------------------------

!  trace_init() NT system calls

interface
   subroutine InitializeCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: InitializeCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_InitializeCriticalSection@4' ::  InitializeCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine InitializeCriticalSection
end interface

! **********************************************************************

!  trace_init() local

! ----------------------------------------------------------------------

!  return values

   integer :: astat                                        ! allocate() buffer status

   integer :: error_code                                   ! local status flag

! **********************************************************************

!  trace_init() steps:

!  1. verify that the number of messages allowed in the buffer is ok
!  2. if lock present and true, init critical section in tr
!  3. set up the buffer parameters in, out, first, last
!  4. allocate the buffer array and check for allocate errors

! **********************************************************************

!  trace_init() text

! ----------------------------------------------------------------------

continue                                                   ! trace_init()

! ----------------------------------------------------------------------

!  check number of messages to be reserved

   bad_max_msgs: if( max_msgs < 1 )then                    ! trace_t must have entries

      error_code = fthread_error_number                    ! set status code

      goto 1                                               ! goto error exit

   endif bad_max_msgs                                      ! trace_t must have entries

! ----------------------------------------------------------------------

!  process lock

   lock_arg: if( present( lock) )then                      ! if lock is in arg list

      trace_v% have_cs = lock                              ! use cs

   else lock_arg                                           ! if lock not in arg list

      trace_v% have_cs = .false.                           ! use not cs

   endif lock_arg                                          ! if lock is (not) in arg list

!  if requested, init critical section

   make_cs: if( trace_v% have_cs )then                     ! if trace has cs

      call InitializeCriticalSection( &                    ! make critical section
                                 loc( trace_v% cs) )       ! cs variable

   endif make_cs                                           ! if trace has cs

! ----------------------------------------------------------------------

!  set buffer pointers

   trace_v% next_in = 1                                    ! buffer empty
   trace_v% next_out = 1                                   ! buffer empty
   trace_v% first = 1                                      ! beginning of buffer
   trace_v% last = max_msgs                                ! limit of buffer

! ----------------------------------------------------------------------

!  nothing to print

   trace_v% empty = .true.                                 ! buffer empty

!  initialize buffer statistics

   trace_v% tmsgs = 0                                      ! total messages entered
   trace_v% tpr = 0                                        ! total messages printed

! ----------------------------------------------------------------------

!  allocate message buffer

   nullify( trace_v% msgs)                                 ! force pointer to defined state

   allocate( trace_v% msgs( max_msgs), stat= astat)        ! messages in this trace variable

   msgs_error: if( is_alloc_error( astat) )then            ! report allocate error

      error_code = fthread_error_allocate                  ! set status code

      goto 1                                               ! goto error exit

   endif msgs_error                                        ! report allocate error

! ----------------------------------------------------------------------

!  trace_init() normal exit

   if( present( flag) ) flag = fthread_ok                  ! set status flag

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! trace_init()

! ----------------------------------------------------------------------

!  hither upon error

 1 continue                                                ! here upon error

   if( present( flag) ) flag = error_code                  ! set status flag

! ----------------------------------------------------------------------

!  error exit

return                                                     ! trace_init()

!  trace_init()

! **********************************************************************

end subroutine trace_init

! **********************************************************************
! **********************************************************************

!  add a record to a trace_t variable

! **********************************************************************

subroutine trace_msg( msg, code, trace_v, flag)

!  trace_msg() interface

character( len= *), intent( in) :: msg                     ! text of message

integer, optional, intent( in) :: code                     ! associated value

type( trace_t), intent( inout) :: trace_v                  ! trace variable

integer, optional, intent( out) :: flag                    ! status flag

! ----------------------------------------------------------------------

!  trace_msg() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  trace_msg() local

! ----------------------------------------------------------------------

!  characters construct message

   character( len= 1), parameter :: blank = ' '            ! characters used to
   character( len= 1), parameter :: colon = ':'            ! construct message
   character( len= 1), parameter :: slash = '/'            ! in buffer

   character( len= 1), parameter :: minus = '-'            ! if negative code

!  convert integer to character without write()

   integer, parameter :: cbuff_size = 10                   ! size of code string
   character( len= cbuff_size) :: cbuff                    ! construct string code
   integer :: idigit                                       ! loop thru digits
   integer :: abs_code                                     ! process code

!  call clock

   character( len= 8) :: dat                               ! date string
   character( len= 10) :: clk                              ! time string

   integer :: isc                                          ! integer system clock
   character( len= cbuff_size) :: csc                      ! character system clock

   character( len= name_length) :: buffer                  ! construct message

! **********************************************************************

!  trace_msg() steps:

!  1. if code present, convert integer to string
!  2. get time and date
!  3. put time stamp and message into message buffer
!  4. update trace variable's buffer pointers

! **********************************************************************

!  trace_msg() text

! ----------------------------------------------------------------------

continue                                                   ! trace_msg()

! ----------------------------------------------------------------------

!  single thread tracing if requested

   enter_cs: if( trace_v% have_cs )then                    ! if single thread access

      call EnterCriticalSection( &                         ! lock mutex
                            loc( trace_v% cs) )            ! mutex

   endif enter_cs                                          ! if single thread access

! ----------------------------------------------------------------------

!  count messages entered

   trace_v% tmsgs = trace_v% tmsgs + 1                     ! one more message

!  check for buffer wrap-around (in overtaking out)

   wrap: if( trace_v% next_in == trace_v% next_out )then   ! if in has reached out

      buffer_empty: if( .not. trace_v% empty )then         ! if buffer has entries

         out_limit: if( trace_v% next_out == trace_v% last )then

            trace_v% next_out = trace_v% first             ! go back to first

         else out_limit                                    ! if out not at limit

            trace_v% next_out = trace_v% next_out + 1      ! increment out

         endif out_limit                                   ! adjust out pointer

      endif buffer_empty                                   ! if buffer has entries

   endif wrap                                              ! check for buffer wrap-around

! ----------------------------------------------------------------------

!  process code if present

   code_arg: if( present( code) )then                      ! if have code

!  convert code to character

      code_0: if( code /= 0 )then                          ! special case zero

!  process positive numbers only

         abs_code = abs( code)                             ! convert integer to ascii
         cbuff = blank
         idigit = cbuff_size

         each_digit: do while( abs_code > 0)               ! loop thru digits

            cbuff( idigit: idigit) = achar( mod( abs_code, 10) + iachar( '0'))

            abs_code = abs_code / 10                       ! next magnitude

            idigit = idigit - 1                            ! next digit

         enddo each_digit                                  ! loop thru digits

!  if code was negative, add minus sign

         if( code < 0 ) cbuff( idigit: idigit) = minus     ! negative --> minus

         buffer = trim(  msg) // blank // adjustl( cbuff)  ! assemble msg and code

!  code is zero

      else code_0                                          ! do zero here

         buffer =trim( msg) // ' 0'                        ! append zero

      endif code_0                                         ! code 0 or not

!  else no code

   else code_arg                                           ! if no code

      buffer = msg                                         ! copy msg

   endif code_arg                                          ! if have/have not code

! ----------------------------------------------------------------------

!  get clock and date strings

   call date_and_time( time= clk, date= dat)               ! date stamp
   call system_clock( count= isc)                          ! time stamp

!  convert system clock to character

      csc = blank                                          ! start with blanks

      clock_digit: do idigit = cbuff_size, 1, -1           ! loop thru digits

         csc( idigit: idigit) = achar( mod( isc, 10) + iachar( '0'))

         isc = isc / 10

      enddo clock_digit                                    ! loop thru digits

! **********************************************************************

!  write 'yyyy/mm/dd hh:mm:ss.s system_clock string' in trace buffer

   trace_v% msgs( trace_v% next_in) = dat( 1: 4) // slash // dat( 5: 6) // slash // dat( 7: 8) &
                     // blank // clk( 1: 2) // colon // clk( 3: 4) // colon // clk( 5: 9) &
                     // blank // csc // blank // trim( buffer)

! **********************************************************************

!  check buffer in pointer for extremum

   in_limit: if( trace_v% next_in == trace_v% last )then   ! if in is at limit

      trace_v% next_in = trace_v% first                    ! go back to first

   else in_limit                                           ! in not at limit

      trace_v% next_in = trace_v% next_in + 1              ! increment in

   endif in_limit                                          ! adjust in pointer

!  buffer now has a message to print

   trace_v% empty = .false.                                ! message is in buffer

! ----------------------------------------------------------------------

!  single thread tracing if requested

   exit_cs: if( trace_v% have_cs )then                     ! if single thread access

      call LeaveCriticalSection( &                         ! unlock mutex
                            loc( trace_v% cs) )            ! mutex

   endif exit_cs                                           ! if single thread access

! ----------------------------------------------------------------------

!  trace_msg() normal exit

   if( present( flag) ) flag = fthread_ok                  ! status

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! trace_msg()

!  trace_msg()

! **********************************************************************

end subroutine trace_msg

! **********************************************************************
! **********************************************************************

!  print a trace_t

! **********************************************************************

subroutine trace_print( log_unit, trace_v, printed, flag)

!  trace_print() interface

integer, optional, intent( in) :: log_unit                 ! logical unit whence msgs

type( trace_t), intent( inout) :: trace_v                  ! trace variable whither msgs

integer, optional, intent( out) :: printed                 ! number of msgs printed

integer, optional, intent( out) :: flag                    ! status flag

! ----------------------------------------------------------------------

!  trace_print() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  trace_print() local

! ----------------------------------------------------------------------

!  local unit

   integer :: l_unit                                       ! unit to write messages

!  return value

   integer :: pr_stat                                      ! iostat of write messages

!  counters

   integer :: count_msgs                                   ! count msgs printed

   integer :: imsg                                         ! loop thru messages

   character( len= *), parameter :: ts_fmt = '( " ", a)'   ! format with carriage control

!  status if requested

   integer :: error_code                                   ! status code

! **********************************************************************

!  trace_print() steps:

!  1. check for no messages in buffer
!  2. print messages from out pointer to in pointer
!  3. update out pointer

! **********************************************************************

!  trace_print() text

! ----------------------------------------------------------------------

continue                                                   ! trace_print()

! ----------------------------------------------------------------------

!  initialize and check for work

   count_msgs = 0                                          ! none printed yet

!  check for no messages in buffer

   no_msgs: if( trace_v% empty )then                       ! if buffer empty

      error_code = fthread_ok                              ! status

      goto 1                                               ! go process error

   endif no_msgs                                           ! if buffer empty

!  check for optional unit

   got_unit: if( present( log_unit) )then                  ! if unit specified

      l_unit= log_unit                                     ! use specified unit

   else got_unit                                           ! if unit specified

      l_unit = error_unit                                  ! use stderr

   endif got_unit                                          ! if unit specified

! ----------------------------------------------------------------------

!  single thread tracing if requested

   enter_cs: if( trace_v% have_cs )then                    ! if single thread access

      call EnterCriticalSection( &                         ! lock mutex
                            loc( trace_v% cs) )            ! mutex

   endif enter_cs                                          ! if single thread access

! ----------------------------------------------------------------------

!  determine out relative to in

   in_v_out: if( trace_v% next_in > trace_v% next_out )then

!  write from out pointer to before in pointer

      out_to_in: do imsg = trace_v% next_out, trace_v% next_in - 1

         write( unit= l_unit, fmt= ts_fmt, iostat= pr_stat) &
            trim( trace_v% msgs( imsg))

         write_1_error: if( is_io_error( pr_stat) )then    ! io error

            error_code = fthread_error_io                  ! set status to io error

            goto 1                                         ! goto error exit

         endif write_1_error                               ! io error

         count_msgs = count_msgs + 1                       ! count messages written

      enddo out_to_in                                      ! from out to in

      trace_v% next_out = trace_v% next_in                 ! buffer empty

   else in_v_out                                           ! in is behind out

!  write from out pointer to last, then first to before in pointer

      out_to_last: do imsg = trace_v% next_out, trace_v% last

         write( unit= l_unit, fmt= ts_fmt, iostat= pr_stat) &
            trim( trace_v% msgs( imsg))

         write_2_error: if( is_io_error( pr_stat) )then    ! io error

            error_code = fthread_error_io                  ! set status to io error

            goto 1                                         ! goto error exit

         endif write_2_error                               ! io error

         count_msgs = count_msgs + 1                       ! count messages written

      enddo out_to_last                                    ! out to last

      first_to_in: do imsg = trace_v% first, trace_v% next_in - 1

         write( unit= l_unit, fmt= ts_fmt, iostat= pr_stat) &
            trim( trace_v% msgs( imsg))

         write_3_error: if( is_io_error( pr_stat) )then    ! io error

            error_code = fthread_error_io                  ! set status to io error

            goto 1                                         ! goto error exit

         endif write_3_error                               ! io error

         count_msgs = count_msgs + 1                       ! count messages written

      enddo first_to_in                                    ! first to in

      trace_v% next_out = trace_v% next_in                 ! buffer empty

   endif in_v_out                                          ! in relative to out

!  nothing left to print

   trace_v% empty = .true.                                 ! no unprinted messages

! ----------------------------------------------------------------------

!  single thread tracing if requested

   exit_cs: if( trace_v% have_cs )then                     ! if single thread access

      call LeaveCriticalSection( &                         ! unlock mutex
                            loc( trace_v% cs) )            ! mutex

   endif exit_cs                                           ! if single thread access

! ----------------------------------------------------------------------

!  trace_print() normal exit

   trace_v% tpr = trace_v% tpr + count_msgs                ! messages printed

   if( present( printed) ) printed = count_msgs            ! count messages

   if( present( flag) ) flag = fthread_ok                  ! status

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! trace_print()

! ----------------------------------------------------------------------

!  hither upon error

 1 continue                                                ! come here upon error

   trace_v% tpr = trace_v% tpr + count_msgs                ! messages printed

   if( present( printed) ) printed = count_msgs            ! count messages

   if( present( flag) ) flag = error_code                  ! status

! ----------------------------------------------------------------------

!  error exit

return                                                     ! trace_print()

!  trace_print()

! **********************************************************************

end subroutine trace_print

! **********************************************************************
! **********************************************************************

!  trace_status() inquires about a thread

subroutine trace_status( trace_v, msgs, printed, size, count)

!  trace_status() interface

type( trace_t), intent( in) :: trace_v                     ! trace variable to inquire

integer, optional, intent( out) :: msgs                    ! total messages written to trace

integer, optional, intent( out) :: printed                 ! printed messages from trace

integer, optional, intent( out) :: size                    ! capacity of trace

integer, optional, intent( out) :: count                   ! number of current messagest

! **********************************************************************

!  trace_status() steps:

!  1. if query present, return value

! **********************************************************************

!  trace_status() text

! ----------------------------------------------------------------------

continue                                                   ! trace_status()

! ----------------------------------------------------------------------

!  number of messages

   msgs_arg: if( present( msgs) )then                      ! if want messages

      msgs = trace_v% tmsgs                                ! report messages

   endif msgs_arg                                          ! if want messages

! ----------------------------------------------------------------------

!  messages printed

   pr_arg: if( present( printed) )then                     ! if want messages printed

      printed = trace_v% tpr                               ! report messages printed

   endif pr_arg                                            ! if want messages printed

! ----------------------------------------------------------------------

!  buffer size

   size_arg: if( present( size) )then                      ! if want buffer size

      size = trace_v% last - trace_v% first + 1            ! report buffer size

   endif size_arg                                          ! if want buffer size

! ----------------------------------------------------------------------

!  messages in buffer now

   count_arg: if( present( count) )then                    ! if want number of messages in buffer

      in_v_out: if( trace_v% next_in > trace_v% next_out )then

         count = trace_v% next_in - trace_v% next_out      ! number is difference

      elseif( trace_v% next_in < trace_v% next_out )then in_v_out

         count = trace_v% last + trace_v% next_in - trace_v% next_out

      else in_v_out                                        ! if is in ahead of out

         count = 0                                         ! none

      endif in_v_out                                       ! if is in ahead of out

   endif count_arg                                         ! if want number of messages in buffer

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! trace_status()

!  trace_status()

! **********************************************************************

end subroutine trace_status

! **********************************************************************
! **********************************************************************

!  ### public query procedures

!  these procedures retrun the number of processors and active threads

! **********************************************************************

!  fthread_cpus() number of (hw) processors in system

! **********************************************************************

integer function fthread_cpus()

! ----------------------------------------------------------------------

!  fthread_cpus() NT system calls

interface
   subroutine  GetSystemInfo( lpSystemInfo)
!DEC$ ATTRIBUTES DEFAULT :: GetSystemInfo
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_GetSystemInfo@4' :: GetSystemInfo
!DEC$ ATTRIBUTES REFERENCE :: lpSystemInfo
      integer( 4), dimension( 9) :: lpSystemInfo
   end subroutine GetSystemInfo
end interface

! ----------------------------------------------------------------------

!  fhtread_cpus() local

   integer, parameter :: size_si = 9                       ! size of system info buffer

   integer, parameter :: loc_nprocs = 6                    ! location of number of processors

   integer, dimension( size_si) :: sysinfo                 ! system info buffer

! **********************************************************************

!  fthread_cpus() steps:

!  1. call Win32 to fill system info buffer
!  2. return number of cpus field

! **********************************************************************

!  fthread_cpus() text

! ----------------------------------------------------------------------

continue                                                   ! fthread_cpus()

! ----------------------------------------------------------------------

   call GetSystemInfo( &                                   ! get processor data
                       sysinfo)                            ! system info buffer

! ----------------------------------------------------------------------

   fthread_cpus = sysinfo( loc_nprocs)                     ! return number of cpus

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! fthread_cpus()

!  fthread_cpus()

! **********************************************************************

end function fthread_cpus

! **********************************************************************
! **********************************************************************

!  fthread_count() number of threads

! **********************************************************************

integer function fthread_count()

! **********************************************************************

!  fthread_count() steps:

!  1. return number of threads

! **********************************************************************

!  fthread_count() text

! ----------------------------------------------------------------------

continue                                                   ! fthread_count()

! ----------------------------------------------------------------------

   fthread_count = count( threads% win32_id /= win32_null) ! active threads have id's

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! fthread_count()

!  fthread_count()

! **********************************************************************

end function fthread_count

! **********************************************************************
! **********************************************************************

!  fthread_is_error() true if status indicates an error

! **********************************************************************

logical function fthread_is_error( flag)

!  fthread_is_error() interface

integer, intent( in) :: flag                               ! test status variable

! **********************************************************************

!  fthread_is_error() steps:

!  1. normal completion messages are fthreads_ok or greater

! **********************************************************************

!  fthread_is_error() text

! ----------------------------------------------------------------------

continue                                                   ! fthread_is_error()

! ----------------------------------------------------------------------

   fthread_is_error = flag < fthread_ok                    ! errors are negative

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! fthread_is_error()

!  fthread_is_error()

! **********************************************************************

end function fthread_is_error

! **********************************************************************
! **********************************************************************

!  fthread_error_msg() provide error message for flag value

! **********************************************************************

subroutine fthread_error_msg( flag, msg)

!  fthread_error_msg() interface

integer, intent( in) :: flag                               ! status variable

character( len= *), intent( out) :: msg                    ! error message returned

! **********************************************************************

!  fthread_error_msg() steps:

!  1. choose message by flag value

! **********************************************************************

!  fthread_error_msg() text

! ----------------------------------------------------------------------

continue                                                   ! fthread_error_msg()

! ----------------------------------------------------------------------

   select case( flag)                                      ! choose a message

   case( fthread_buffer_wrap)                              ! trace buffer wrapped

      msg = 'trace buffer wrapped around'

   case( fthread_ok)                                       ! no error

      msg = 'fthreads ok'

   case( fthread_error_number)                             ! user's number too big or too small

      msg = 'number is not usable'

   case( fthread_error_state)                              ! initialized versus not initialized

      msg = 'initialized or terminated twice'

   case( fthread_error_allocate)                           ! an allocation failed

      msg = 'Fortran allocate error'

   case( fthread_error_syscall)                            ! Win32 system called failed

      msg = 'Win32 system called error'

   case( fthread_error_active)                             ! thread is active versus inactive

      msg = 'a thread is still running'

   case( fthread_error_not_primary)                        ! action only by primary thread

      msg = 'this action can be performed only by primary thread'

   case( fthread_error_io)                                 ! Fortran I/O error

      msg = 'Fortran input/output error'

   case( fthread_error_team)                               ! on team versus not on team

      msg = 'thread not on team'

   case default                                            ! none of the above

      msg = 'unknown error code'

   end select                                              ! choose a message

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! fthread_error_msg()

!  fthread_error_msg()

! **********************************************************************

end subroutine fthread_error_msg

! **********************************************************************
! **********************************************************************

!  ### public fthreads fthreads procedures

!  these procedures operate on fthreads global data

! **********************************************************************

!  fthread_init() initializes and allocates fthreads private data structures

! **********************************************************************

subroutine fthread_init( max_threads, max_teams, max_barriers, max_events, max_mutexs, &
                         thread_name, trace_v, flag)

!  fthread_init() interface

integer, intent( in) :: max_threads                        ! total number of threads

integer, optional, intent( in) :: max_teams                ! number of teams
integer, optional, intent( in) :: max_barriers             ! number of barriers
integer, optional, intent( in) :: max_events               ! number of events
integer, optional, intent( in) :: max_mutexs               ! number of mutexs

character( len= *), optional, intent( in) :: thread_name   ! user specified label

type( trace_t), optional, intent( inout) :: trace_v        ! record actions

integer, optional, intent( out) :: flag                    ! status flag

! ----------------------------------------------------------------------

!  fthread_init() NT system calls

interface
   integer( 4) function GetCurrentProcess()
!DEC$ ATTRIBUTES DEFAULT :: GetCurrentProcess
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_GetCurrentProcess@0' :: GetCurrentProcess
   end function GetCurrentProcess

   integer( 4) function GetCurrentThread()
!DEC$ ATTRIBUTES DEFAULT :: GetCurrentThread
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_GetCurrentThread@0' :: GetCurrentThread
   end function GetCurrentThread

   integer( 4) function GetCurrentThreadId()
!DEC$ ATTRIBUTES DEFAULT :: GetCurrentThreadId
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_GetCurrentThreadId@0' :: GetCurrentThreadId
   end function GetCurrentThreadId

   integer( 4) function DuplicateHandle                     &
     &  (hSourceProcessHandle, hSourceHandle,                           &
     &  hTargetProcessHandle, lpTargetHandle,                           &
     &  dwDesiredAccess, bInheritHandle, dwOptions)
!DEC$ ATTRIBUTES DEFAULT :: DuplicateHandle
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_DuplicateHandle@28' :: DuplicateHandle
      integer( 4) :: hSourceProcessHandle
!DEC$ ATTRIBUTES VALUE ::   hSourceProcessHandle
      integer( 4) :: hSourceHandle
!DEC$ ATTRIBUTES VALUE ::   hSourceHandle
      integer( 4) :: hTargetProcessHandle
!DEC$ ATTRIBUTES VALUE ::   hTargetProcessHandle
      integer( 4) :: lpTargetHandle
!DEC$ ATTRIBUTES REFERENCE ::   lpTargetHandle
      integer( 4) :: dwDesiredAccess
!DEC$ ATTRIBUTES VALUE ::   dwDesiredAccess
      integer( 4) :: bInheritHandle
!DEC$ ATTRIBUTES VALUE ::   bInheritHandle
      integer( 4) :: dwOptions
!DEC$ ATTRIBUTES VALUE ::   dwOptions
   end function DuplicateHandle

   integer( 4) function GetLastError()
!DEC$ ATTRIBUTES DEFAULT :: GetLastError
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_GetLastError@0' :: GetLastError
   end function GetLastError
end interface

! **********************************************************************

!  fhtread_init() local

! ----------------------------------------------------------------------

!  return values from allocate or Win32

   integer :: astat                                        ! allocate status

   integer :: win32_return                                 ! Win32 system call result

!  convert binary integers to characters without using write()

   integer, parameter :: name_digits_size = 10             ! digits in worker name

   character( len= name_digits_size) :: name_digits

   integer :: ith                                          ! loop thru threads
   integer :: idigit                                       ! loop thru digits
   integer :: loop_i

!  do loop indices

   integer :: itm                                          ! loop thru teams

   integer :: ibar                                         ! loop thru barriers
   integer :: iev                                          ! loop thru events
   integer :: imu                                          ! loop thru mutexs

!  for informative and error messages

   character( len= *), parameter :: name_msg = 'fthread_init(): '

   integer :: error_code                                   ! status flag
   character( len= name_length) :: error_msg               ! error text

! **********************************************************************

!  fthread_init() steps:

!  1. check initialization flag
!  2. set initialization flag
!  3. set pointers to allocated storage to known state
!  4. check number of threads
!  5. allocate thread array and initialize pointers
!  6. initialize thread 1 data
!  7. initialize thread n data to null or default values
!  8. check number of teams
!  9. initialize team 1 data
! 10. initialize team n data to null or default values
! 11. check number of barriers requested
! 12. allocate barrier array
! 13. check number of events requested
! 14. allocate event array
! 15. check number of mutexs requested
! 16. allocate mutex array

! **********************************************************************

!  fthread_init() text

! ----------------------------------------------------------------------

continue                                                   ! fthread_init()

! ----------------------------------------------------------------------

!  check that fthreads is not already initialized

   initialized = associated( threads) &                    ! thread array is allocated
            .or. associated( teams) &                      ! team array is allocated
            .or. associated( barriers) &                   ! barrier array is allocated
            .or. associated( events) &                     ! event array is allocated
            .or. associated( mutexs)                       ! mutex array is allocated

   state_error: if( initialized )then                      ! already run fthread_init()

      error_code = fthread_error_state                     ! set status flag

      error_msg = 'already initialized'                    ! complaint

      goto 1                                               ! go process error

   endif state_error                                       ! already run fthread_init()

! ----------------------------------------------------------------------

!  allow fthread_end() to run to clean up

   initialized = .true.                                    ! hereafter committed to initialize

! **********************************************************************

!  setup threads array

! **********************************************************************

!  check number of threads requested

   bad_max_threads: if( max_threads < primary_id )then     ! at least primary_id

      error_code = fthread_error_number                    ! max_threads can't be used

      error_msg = 'max_threads is an unusable value'

      goto 1                                               ! go process error

   endif bad_max_threads                                   ! at least primary_id

!  allocate thread array

   allocate( threads( primary_id: max_threads), stat= astat)

   threads_allocate: if( is_alloc_error( astat) )then      ! if allocate trouble

      error_code = fthread_error_allocate                  ! can't allocate threads array

      error_msg = 'error allocating threads array'

      goto 1                                               ! go process error

   endif threads_allocate                                  ! if allocate trouble

!  setup bounds threads array

   this_thread = primary_id                                ! set thread array pointer
   max_thread_id = max_threads                             ! set thread array maximum

! ----------------------------------------------------------------------

!  initialize primary_id thread data

   win32_return = DuplicateHandle( &                       ! pseudo handle convert to handle
                     GetCurrentProcess(), &                ! source process
                     GetCurrentThread(), &                 ! this thread's pseudo handle
                     GetCurrentProcess(), &                ! target process
                     threads( primary_id)% handle, &       ! return primary thread's handle
                     0, &                                  ! access flags ignored
                     win32_false, &                        ! inherit not
                     win32_same_access)                    ! security attributes

   handle_error: if( win32_return == win32_null )then      ! invalid handle

      error_code = fthread_error_syscall                   ! NT system call failed

      error_msg = 'get thread handle error'                ! duplicate handle

      goto 1                                               ! go process error

   endif handle_error                                      ! invalid handle

!  initialize primary_id Win32 thread id

   threads( primary_id)% win32_id = GetCurrentThreadId()   ! not null => thread running

!  set primary_id name

   name_arg: if( present( thread_name) )then               ! thread 1 name

      threads( primary_id)% label = thread_name            ! if called with name

   else name_arg                                           ! thread 1 name

      threads( primary_id)% label = default_primary_name   ! 'primary_id'

   endif name_arg                                          ! thread 1 name

! ----------------------------------------------------------------------

!  log thread 1 initialized

   log_primary_init: if( present( trace_v) )then           ! if tracing

      call trace_msg( name_msg // 'initialized primary thread ' // threads( primary_id)% label, &
                      trace_v= trace_v)

   endif log_primary_init                                  ! if tracing

! ----------------------------------------------------------------------

!  initialize rest of thread array to null or default values

   worker_threads: do ith = worker_1, max_thread_id        ! do worker threads

      threads( ith)% handle = win32_null                   ! not initialized yet

      threads( ith)% win32_id = win32_null                 ! not initialized yet

!  make default worker thread names

      loop_i = ith                                         ! integer to ascii
      idigit = name_digits_size
      name_digits = ' '

      th_to_a: do while( loop_i > 0)                       ! loop thru digits

         name_digits( idigit: idigit) = achar( mod( loop_i, 10) + iachar( '0'))

         loop_i = loop_i / 10                              ! next magnitude

         idigit = idigit - 1                               ! next digit

      enddo th_to_a                                        ! loop thru digits

!  set default worker thread names

      threads( ith)% label = default_thread_name // adjustl( name_digits)

   enddo worker_threads                                    ! do worker threads

! ----------------------------------------------------------------------

!  log thread array setup

   log_workers: if( present( trace_v) )then                ! if tracing

      call trace_msg( name_msg // 'allocated space for worker threads', &
                             code= max_thread_id, trace_v= trace_v)

   endif log_workers                                       ! if tracing

! **********************************************************************

!  setup teams array

! **********************************************************************

!  check number of teams requested

   team_arg: if( present( max_teams) )then                 ! if number of teams requested

      max_team_id = max_teams                              ! use it

      bad_max_teams: if( max_team_id < all_workers_id )then

         error_code = fthread_error_number                 ! can't use max_teams

         error_msg = 'max_teams must be greater than zero' ! must be >0

         goto 1                                            ! go process error

      endif bad_max_teams                                  ! if invalid number

   else team_arg                                           ! if number of teams requested

      max_team_id = all_workers_id                         ! only default team

   endif team_arg                                          ! if number of teams requested

!  try to allocate teams array

   allocate( teams( all_threads_id: max_team_id), stat= astat)

   teams_allocate: if( is_alloc_error( astat) )then        ! if allocate failed

      error_code = fthread_error_allocate                  ! can't allocate teams array

      error_msg = 'error allocating teams array'

      goto 1                                               ! go process error

   endif teams_allocate                                    ! if allocate failed

! ----------------------------------------------------------------------

!  allocate list arrays for each team

   allocate_lists: do itm = all_threads_id, max_team_id    ! do all teams

      nullify( teams( itm)% list)                          ! ensure a defined state

      allocate( teams( itm)% list( primary_id: max_thread_id), stat = astat)

      list_allocate: if( is_alloc_error( astat) )then      ! if allocate failed

         error_code = fthread_error_allocate               ! can't allocate team list array

         error_msg = 'error allocating team lists'         ! report error

         goto 1                                            ! go process error

      endif list_allocate                                  ! if allocate failed

   enddo allocate_lists                                    ! do all teams

!  setup default team membership

   teams( all_threads_id)% list = .true.                   ! all threads on all_threads_id only

!  setup workers team membership

   teams( all_workers_id)% list( primary_id) = .false.      ! primary thread is not a worker
   teams( all_workers_id)% list( worker_1: max_thread_id) = .true.

!  team names

   teams( all_threads_id)% label = default_all_threads_name
   teams( all_workers_id)% label = default_all_workers_name

!  log default teams initialized

   log_def_init: if( present( trace_v) )then               ! if tracing

      call trace_msg( name_msg // 'initialized default team ' // teams( all_threads_id)% label, &
                      trace_v= trace_v)

      call trace_msg( name_msg // 'initialized default team ' // teams( all_workers_id)% label, &
                      trace_v= trace_v)

   endif log_def_init                                      ! if tracing

!  make default team names

   team_names: do itm = all_workers_id + 1, max_team_id    ! 'Team_n'

      loop_i = itm                                         ! integer to ascii
      idigit = name_digits_size
      name_digits = ' '

      t_to_a: do while( loop_i > 0)                        ! loop thru digits

         name_digits( idigit: idigit) = achar( mod( loop_i, 10) + iachar( '0'))

         loop_i = loop_i / 10                              ! next magnitude

         idigit = idigit - 1                               ! next digit

      enddo t_to_a                                         ! loop thru digits

!  set default team names

      teams( itm)% label = default_team_name // adjustl( name_digits)

   enddo team_names                                        ! 'Team_n'

!  set team array pointer

   this_team = all_workers_id                              ! first team is all workers

! ----------------------------------------------------------------------

!  log teams allocated

   log_team_init: if( present( trace_v) )then              ! if tracing

      call trace_msg( name_msg // 'teams allocated', &
                      code= size( teams), trace_v= trace_v)

   endif log_team_init                                     ! if tracing

! **********************************************************************

!  allocate barrier, event & mutex arrays

! **********************************************************************

!  barriers

   barrier_arg: if( present( max_barriers) )then           ! if barriers requested

      max_barrier_id = max_barriers                        ! use arg

      bad_max_barriers: if( max_barrier_id < 0 )then       ! must not be negative

         error_code = fthread_error_number                 ! bad number of barriers

         error_msg = 'number of barriers is negative'      ! can't allocate barrier array

         goto 1                                            ! go process error

      endif bad_max_barriers                               ! must not be negative

   else barrier_arg                                        ! if barriers requested

      max_barrier_id = default_barrier_max                 ! use default

   endif barrier_arg                                       ! if barriers requested

!  allocate barrier array

   want_barriers: if( max_barrier_id > 0 )then             ! want barriers

      allocate( barriers( max_barrier_id), stat= astat)    ! allocate array

      bar_alloc: if( is_alloc_error( astat) )then          ! if allocate failed

         error_code = fthread_error_allocate               ! can't allocate barriers array

         error_msg = 'error allocating barriers array'     ! report error

         goto 1                                            ! go process error

      endif bar_alloc                                      ! if allocate failed

!  make default barrier names

      barrier_names: do ibar = 1, max_barrier_id           ! 'Barrier_n'

         loop_i = ibar                                     ! integer to ascii
         idigit = name_digits_size
         name_digits = ' '

         b_to_a: do while( loop_i > 0)                     ! loop thru digits

            name_digits( idigit: idigit) = achar( mod( loop_i, 10) + iachar( '0'))

            loop_i = loop_i / 10                           ! next magnitude

            idigit = idigit - 1                            ! next digit

         enddo b_to_a                                      ! loop thru digits

!  default names

         barriers( ibar)% label = default_barrier_name // adjustl( name_digits)

      enddo barrier_names                                  ! 'Barrier_n'

! ----------------------------------------------------------------------

!  log barrier array setup

      log_barrier_init: if( present( trace_v) )then        ! if tracing

         call trace_msg( name_msg // 'barriers allocated', &
                         code= max_barriers, trace_v= trace_v)

      endif log_barrier_init                               ! if tracing

   endif want_barriers                                     ! want barriers

! **********************************************************************

!  events

   event_arg: if( present( max_events) )then               ! if events requested

      max_event_id = max_events                            ! use it

      bad_max_events: if( max_event_id < 0 )then           ! if number of events ok

         error_code = fthread_error_number                 ! bad number of events

         error_msg = 'number of events is negative'        ! can't allocate events array

         goto 1                                            ! go process error

      endif bad_max_events                                 ! if number of events ok

   else event_arg                                          ! if events requested

      max_event_id = default_event_max                     ! use default

   endif event_arg                                         ! if events requested

!  allocate event array

   want_events: if( max_event_id > 0 )then                 ! want events

      allocate( events( max_event_id), stat= astat)        ! allocate events

      event_error: if( is_alloc_error( astat) )then        ! if allocate failed

         error_code = fthread_error_allocate               ! can't allocate events array

         error_msg = 'error allocating events array'       ! report error

         goto 1                                            ! go process error

      endif event_error                                    ! if allocate failed

!  make default event names

      event_names: do iev = 1, max_event_id                ! 'Event_n'

         loop_i = iev                                      ! integer to ascii
         idigit = name_digits_size
         name_digits = ' '

         e_to_a: do while( loop_i > 0)                     ! loop thru digits

            name_digits( idigit: idigit) = achar( mod( loop_i, 10) + iachar( '0'))

            loop_i = loop_i / 10                           ! next magnitude

            idigit = idigit - 1                            ! next digit

         enddo e_to_a                                      ! loop thru digits

!  default names

         events( iev)% label = default_event_name // adjustl( name_digits)

      enddo event_names                                    ! 'Event_n'

! ----------------------------------------------------------------------

!  log event array setup

      log_event_init: if( present( trace_v) )then          ! if tracing

         call trace_msg( name_msg // 'events allocated', &
                         code= max_events, trace_v= trace_v)

      endif log_event_init                                 ! if tracing

   endif want_events                                       ! want events

! **********************************************************************

!  mutexs

   mutex_arg: if( present( max_mutexs) )then               ! if mutexs requested

      max_mutex_id = max_mutexs                            ! use it

      bad_max_mutexs: if( max_mutex_id < 0 )then           ! if number of mutexs ok

         error_code = fthread_error_number                 ! bad number of mutexs

         error_msg = 'number of  mutexs is negative'       ! can't allocate mutexs

         goto 1                                            ! go process error

      endif bad_max_mutexs                                 ! if number of mutexs ok

   else mutex_arg                                          ! if mutexs requested

      max_mutex_id = default_mutex_max                     ! use default

   endif mutex_arg                                         ! if mutexs requested

!  allocate mutex array

   want_mutexs: if( max_mutex_id > 0 )then                 ! want mutexs

      allocate( mutexs( max_mutex_id), stat= astat)

      mutex_alloc: if( is_alloc_error( astat) )then        ! if allocate failed

         error_code = fthread_error_allocate               ! can't allocate mutex array

         error_msg = 'error allocating mutex array'        ! report error

         goto 1                                            ! go process error

      endif mutex_alloc                                    ! if allocate failed

!  make default mutex names

      mutex_names: do imu = 1, max_mutex_id                ! 'Mutex_n'

         loop_i = imu                                      ! integer to ascii
         idigit = name_digits_size
         name_digits = ' '

         m_to_a: do while( loop_i > 0)                     ! loop thru digits

            name_digits( idigit: idigit) = achar( mod( loop_i, 10) + iachar( '0'))

            loop_i = loop_i / 10                           ! next magnitude

            idigit = idigit - 1                            ! next digit

         enddo m_to_a                                      ! loop thru digits

!  default names

         mutexs( imu)% label = default_mutex_name // adjustl( name_digits)

      enddo mutex_names                                    ! 'Mutex_n'

! ----------------------------------------------------------------------

!  log mutex array setup

      log_mutex_init: if( present( trace_v) )then          ! if tracing

         call trace_msg( name_msg // 'mutexs allocated', &
                         code= max_mutexs, trace_v= trace_v)

      endif log_mutex_init                                 ! if tracing

   endif want_mutexs                                       ! want mutexs

! **********************************************************************

!  successful init

   if( present( flag) ) flag = fthread_ok                  ! status

   trace_init: if( present( trace_v) )then                 ! trace fthreads initialization

      call trace_msg( name_msg // 'start fthreads ok', &
                      trace_v= trace_v)

   endif trace_init                                        ! trace fthreads initialization

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! fthread_init()

! ----------------------------------------------------------------------

!  hither upon error

 1 continue                                                ! catch errors

!  set status flag

   if( present( flag) ) flag = error_code                  ! status

!  if tracing enabled, trace action

   trace_error: if( present( trace_v) )then                ! log error message if possible

      syserr: if( error_code == fthread_error_syscall )then

         win32_return = GetLastError()                     ! record Win32 error code

         call trace_msg( name_msg // error_msg, &
                         code= win32_return, trace_v= trace_v)

      else syserr

         call trace_msg( name_msg // error_msg, trace_v= trace_v)

      endif syserr

   endif trace_error                                       ! log error message if possible

! ----------------------------------------------------------------------

!  error exit

return                                                     ! fthread_init()

!  fthread_init()

! **********************************************************************

end subroutine fthread_init

! **********************************************************************
! **********************************************************************

!  fthread_end() cleans and deallocates fthreads private data structures

! **********************************************************************

subroutine fthread_end( th, trace_v, flag)

!  fthread_end() interface

type( thread_t), intent( in) :: th                         ! call from primary only

type( trace_t), optional, intent( inout) :: trace_v        ! trace actions

integer, optional, intent( out) :: flag                    ! status

! **********************************************************************

!  fthread_end() local

! ----------------------------------------------------------------------

!  status from deallocate

   integer :: astat                                        ! deallocation status

!  do loop indices

   integer :: ith                                          ! loop thru threads
   integer :: imu

!  for informative and error messages

   character( len= *), parameter :: name_msg = 'fthread_end(): '

   integer :: error_code                                   ! status flag
   character( len= name_length) :: error_msg               ! error text

! **********************************************************************

!  fthread_end() steps:

!  1. check that fthreads is initialized
!  2. check that fthread_end() is called by thread 1
!  3. check that no other thread is still active
!  4. deallocate thread array
!  5. deallocate team arrays
!  6. deallocate barriers array
!  7. deallocate event array
!  8. deallocate mutex array

! **********************************************************************

!  fthread_end() text

! ----------------------------------------------------------------------

continue                                                   ! fthread_end()

! ----------------------------------------------------------------------

!  check that fthreads is initialized

   state_error: if( .not. initialized )then                ! if not run fthread_init()

      error_code = fthread_error_state                     ! fthread_end() only after fthread_init()

      error_msg = 'fthreads not initialized'               ! must be initialized to be uninitialized

      goto 1                                               ! go process error

   endif state_error                                       ! if not run fthread_init()

!  called only from thread 1

   thread_error: if( th% id /= primary_id )then            ! primary must end fthreads

      error_code = fthread_error_not_primary               ! must end fthreads from primary

      error_msg = 'not called by primary thread'

      goto 1                                               ! go process error

   endif thread_error                                      ! primary must end fthreads

!  if any thread still running, can't shutdown yet

   workers_error: if( any( threads(worker_1: this_thread)% handle /= win32_null) )then

      error_code = fthread_error_active                    ! end fthreads only when no other is running

      error_msg = 'worker threads still active'            ! musn't lose handle to active worker

      goto 1                                               ! go process error

   endif workers_error                                     ! workers running --> can't shutdown

! ----------------------------------------------------------------------

!  try to allow fthread_init() to run again

   initialized = .false.                                   ! hereafter committed to not initialized

! ----------------------------------------------------------------------

!  deallocate threads array

! ----------------------------------------------------------------------

!  if threads allocated, deallocate

   threads_array: if( associated( threads) )then           ! threads

      deallocate( threads, stat= astat)                    ! no more thread data

      threads_error: if( is_alloc_error( astat) )then      ! deallocate failed

         error_code = fthread_error_allocate               ! can't deallocate

         error_msg = 'error deallocating threads'

         goto 1                                            ! go process error

      endif threads_error                                  ! deallocate failed

   endif threads_array                                     ! threads

! ----------------------------------------------------------------------

!  reset threads pointers

   this_thread = primary_id                                ! only thread now

   max_thread_id = primary_id                              ! maximum threads now

! ----------------------------------------------------------------------

!  deallocate teams array and each team's list

! ----------------------------------------------------------------------

!  if teams allocated, deallocate

   teams_array: if( associated( teams) )then               ! teams

!  first, deallocate each team% list

      all_lists: do ith = all_threads_id, max_team_id      ! do each team's list

         list_array: if( associated( teams( ith)% list) )then

            deallocate( teams( ith)% list, stat= astat)    ! deallocate list

            list_error: if( is_alloc_error( astat) )then   ! can't deallocate lists

               error_code = fthread_error_allocate

               error_msg = 'error deallocating lists'

               goto 1                                      ! go process error

            endif list_error                               ! can't deallocate lists

         endif list_array                                  ! team lists

      enddo all_lists                                      ! do each team's list

! then deallocate teams

      deallocate( teams, stat= astat)                      ! no more team data

      teams_error: if( is_alloc_error( astat) )then        ! can't deallocate teams

         error_code = fthread_error_allocate

         error_msg = 'error deallocating teams'

         goto 1                                            ! go process error

      endif teams_error                                    ! can't deallocate teams

   endif teams_array                                       ! teams

! ----------------------------------------------------------------------

!  reset teams pointers

   this_team = all_threads_id                              ! no teams now

   max_team_id = all_threads_id                            ! maximum team now

! ----------------------------------------------------------------------

!  deallocate barriers array

! ----------------------------------------------------------------------

!  ensure all barriers' mutexs and events handles are null

   all_barriers: if( any( barriers( : this_barrier)% mutex /= win32_null) &
     .or. any( barriers( : this_barrier)% event /= win32_null) )then

         error_code = fthread_error_state

         error_msg = 'barrier still has handles'

         goto 1                                            ! go process error

   endif all_barriers                                      ! if any mutex or event still live

!  deallocate barriers

   barriers_array: if( associated( barriers) )then         ! if barriers allocated

      deallocate( barriers, stat= astat)                   ! no more barrier data

      barriers_error: if( is_alloc_error( astat) )then     ! can't deallocate barriers

         error_code = fthread_error_allocate

         error_msg = 'error deallocating barriers'

         goto 1                                            ! go process error

      endif barriers_error                                 ! can't deallocate barriers

   endif barriers_array                                    ! if barriers allocated

! ----------------------------------------------------------------------

!  reset barriers pointers

   this_barrier = 0                                        ! none initialized

   max_barrier_id = 0                                      ! none allocated

! ----------------------------------------------------------------------

!  deallocate events array

! ----------------------------------------------------------------------

!  ensure all events handles are null

   all_events: if( any( events( : this_event)% handle /= win32_null) )then

         error_code = fthread_error_state

         error_msg = 'event still has handle'

         goto 1                                            ! go process error

   endif all_events

!  deallocate events

   events_array: if( associated( events) )then             ! have events

      deallocate( events, stat= astat)                     ! no more event data

      events_error: if( is_alloc_error( astat) )then       ! can't deallocate events

         error_code = fthread_error_allocate

         error_msg = 'error deallocating events'

         goto 1                                            ! go process error

      endif events_error                                   ! can't deallocate events

   endif events_array                                      ! have events

! ----------------------------------------------------------------------

!  reset events pointers

   this_event = 0                                          ! none initialized

   max_event_id = 0                                        ! none allocated

! ----------------------------------------------------------------------

!  deallocate mutexs array

! ----------------------------------------------------------------------

!  ensure all mutexs critical sections are zero

   all_mutexs: do imu = 1, this_mutex                      ! check that cs has been zeroed

      all_cs: if( any( mutexs( imu)% cs /= 0) )then

         error_code = fthread_error_state

         error_msg = 'mutex still active'

         goto 1                                            ! go process error

      endif all_cs

   enddo all_mutexs                                        ! check that cs has been zeroed

!  deallocate mutexs

   mutexs_array: if( associated( mutexs) )then             ! have mutexs

      deallocate( mutexs, stat= astat)                     ! no more mutex data

      mutexs_error: if( is_alloc_error( astat) )then       ! can't deallocate mutexs

         error_code = fthread_error_allocate

         error_msg = 'error deallocating mutexs'

         goto 1                                            ! go process error

      endif mutexs_error                                   ! can't deallocate mutexs

   endif mutexs_array

! ----------------------------------------------------------------------

!  reset mutexs pointers

   this_mutex = 0                                          ! none initialized

   max_mutex_id = 0                                        ! none allocated

! ----------------------------------------------------------------------

!  report success

   if( present( flag) ) flag = fthread_ok                  ! flag set to success

   trace_end: if( present( trace_v) )then                  ! if tracing

      call trace_msg( name_msg // 'end fthreads ok', trace_v= trace_v)

   endif trace_end                                         ! if tracing

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! fthread_end()

! ----------------------------------------------------------------------

!  hither upon error

 1 continue

   if( present( flag) ) flag = error_code                  ! set flag error status

   trace_error: if( present( trace_v) )then                ! log error message if possible

      call trace_msg( name_msg // error_msg, trace_v= trace_v)

   endif trace_error                                       ! log error message if possible

! ----------------------------------------------------------------------

!  error exit

return                                                     ! fthread_end()

!  fthread_end()

! **********************************************************************

end subroutine fthread_end

! **********************************************************************
! **********************************************************************

!  fthread_status() inquires about a thread

subroutine fthread_status( th, maxth, tm, maxtm, b, maxb, ev, maxev, &
                           m, maxm, init, trace_v)

!  fthread_status() interface

integer, optional, intent( out) :: th                      ! number of threads initialized

integer, optional, intent( out) :: maxth                   ! number of threads allocated

integer, optional, intent( out) :: tm                      ! number of teams initialized

integer, optional, intent( out) :: maxtm                   ! number of teams allocated

integer, optional, intent( out) :: b                       ! number of barriers initialized

integer, optional, intent( out) :: maxb                    ! number of barriers allocated

integer, optional, intent( out) :: ev                      ! number of events initialized

integer, optional, intent( out) :: maxev                   ! number of events allocate

integer, optional, intent( out) :: m                       ! number of mutexs initialized

integer, optional, intent( out) :: maxm                    ! number of mutexs allocated

logical, optional, intent( out) :: init                    ! initialized or not

type( trace_t), intent( inout), optional :: trace_v        ! trace actions

! **********************************************************************

!  fthread_status() local

! ----------------------------------------------------------------------

!  routine name

   character( len= *), parameter :: name_msg = 'fthread_status(): '

! **********************************************************************

!  fthread_status() steps:

!  1. if query present, return value

! **********************************************************************

!  fthread_status() text

! ----------------------------------------------------------------------

continue                                                   ! fthread_status()

! ----------------------------------------------------------------------

!  number of threads initialized

   th_arg: if( present( th) )then                          ! if want threads initialized

      th = this_thread                                     ! return threads initialized

   endif th_arg                                            ! if want threads initialized

! ----------------------------------------------------------------------

!  number of threads allocated

   maxth_arg: if( present( maxth) )then                    ! if want threads allocated

      maxth = max_thread_id                                ! return threads allocated

   endif maxth_arg                                         ! if want threads allocated

! ----------------------------------------------------------------------

!  number of teams initialized

   tm_arg: if( present( tm) )then                          ! if want teams initialized

      tm = this_team                                       ! return teams initialized

   endif tm_arg                                            ! if want teams initialized

! ----------------------------------------------------------------------

!  number of teams allocated

   maxtm_arg: if( present( maxtm) )then                    ! if want teams allocated

      maxtm = max_team_id                                  ! return teams allocated

   endif maxtm_arg                                         ! if want teams allocated

! ----------------------------------------------------------------------

!  number of barriers initialized

   b_arg: if( present( b) )then                            ! if want barriers initialized

      b = this_barrier                                     ! return barriers initialized

   endif b_arg                                             ! if want barriers initialized

! ----------------------------------------------------------------------

!  number of barriers allocated

   maxb_arg: if( present( maxb) )then                      ! if want barriers allocated

      maxb = max_barrier_id                                ! return barriers allocated

   endif maxb_arg                                          ! if want barriers allocated

! ----------------------------------------------------------------------

!  number of events initialized

   ev_arg: if( present( ev) )then                          ! if want events initialized

      ev = this_event                                      ! return events initialized

   endif ev_arg                                            ! if want events initialized

! ----------------------------------------------------------------------

!  number of events allocated

   maxev_arg: if( present( maxev) )then                    ! if want events allocated

      maxev = max_event_id                                 ! return events allocated

   endif maxev_arg                                         ! if want events allocated

! ----------------------------------------------------------------------

!  number of mutexs initialized

   m_arg: if( present( m) )then                            ! if want mutexs initialized

      m = this_mutex                                       ! return mutexs initialized

   endif m_arg                                             ! if want mutexs initialized

! ----------------------------------------------------------------------

!  number of mutexs allocated

   maxm_arg: if( present( maxm) )then                      ! if want mutexs allocated

      maxm = max_mutex_id                                  ! return mutexs allocated

   endif maxm_arg                                          ! if want mutexs allocated

! ----------------------------------------------------------------------

!  is fthreads initialized

   init_arg: if( present( init) )then                      ! if want initialized

      init = initialized                                   ! return initialized

   endif init_arg                                          ! if want initialized

! ----------------------------------------------------------------------

!  log success

   trace_status: if( present( trace_v) )then               ! if want trace

      call trace_msg( name_msg // 'query fthreads', &
                      trace_v= trace_v)

   endif trace_status                                      ! if want trace

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! fthread_status()

!  fthread_status()

! **********************************************************************

end subroutine fthread_status

! **********************************************************************
! **********************************************************************

!  ### public thread procedures

!  these procedures start, stop and query worker threads

! **********************************************************************

!  thread_create() inits a thread, gives procedure to execute

! **********************************************************************

subroutine thread_create( th, task, name, trace_v, flag)

!  thread_create() interface

type( thread_t), intent( out) :: th                        ! return thread id

external task                                              ! integer function( integer)
integer :: task                                            ! returns integer exit code

character( len= *), optional, intent( in) :: name          ! name thread

type( trace_t), optional, intent( inout) :: trace_v        ! trace actions

integer, optional, intent( out) :: flag                    ! status

! ----------------------------------------------------------------------

!  thread_create() NT system calls

interface
   integer( 4) function CreateThread( security, stack, thread_func, argument, flags, thread_id)
!DEC$ ATTRIBUTES DEFAULT :: CreateThread
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_CreateThread@24' :: CreateThread
      integer( 4) :: security
!DEC$ ATTRIBUTES VALUE :: security
      integer( 4) :: stack
!DEC$ ATTRIBUTES VALUE :: stack
      external thread_func
      integer( 4) :: argument
!DEC$ ATTRIBUTES VALUE :: argument
      integer( 4) :: flags
!DEC$ ATTRIBUTES VALUE :: flags
      integer( 4) :: thread_id
!DEC$ ATTRIBUTES REFERENCE :: thread_id
   end function CreateThread

   integer( 4) function GetLastError()
!DEC$ ATTRIBUTES DEFAULT :: GetLastError
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_GetLastError@0' :: GetLastError
   end function GetLastError
end interface

! **********************************************************************

!  thread_create() local

! ----------------------------------------------------------------------

!  return value

   integer :: win32_return                                 ! Win32 return code

!  informative and error messages

   character( len= *), parameter :: name_msg = 'thread_create(): '

   integer :: error_code                                   ! status flag
   character( len= name_length) :: error_msg               ! error text

! **********************************************************************

!  thread_create() steps:

!  1. check number of threads initialized so far
!  2. make Win32 system call
!  3. update threads array
!  4. update user's thread variable

! **********************************************************************

!  thread_create() text

! ----------------------------------------------------------------------

continue                                                   ! thread_create()

! ----------------------------------------------------------------------

!  check total number of threads made so far

   too_many: if( this_thread >= max_thread_id )then        ! if array bounds exceeded

      error_code = fthread_error_number                    ! too many threads

      error_msg = 'too many threads'

      goto 1                                               ! go process error

   endif too_many                                          ! if array bounds exceeded

! ----------------------------------------------------------------------

!  update threads pointer

   this_thread = this_thread + 1                           ! point to next thread element

! ----------------------------------------------------------------------

!  update user's thread variable

   th% id = this_thread                                    ! set up user's variable

! ----------------------------------------------------------------------

!  update threads array

   threads( this_thread)% rv = win32_still_active          ! running, not exited

!  set thread label

   name_arg: if( present( name) )then                      ! or leave default name

      threads( this_thread)% label = name                  ! use user's name

   endif name_arg                                          ! or leave default name

! ----------------------------------------------------------------------

!  finally, make Win32 system call to start thread execution

   threads( this_thread)% handle = &                       ! Win32 thread handle
                     CreateThread( &                       ! Win32 create thread sys call
                           win32_null, &                   ! default security attributes
                           0, &                            ! default stack (1 MB)
                           task, &                         ! integer function
                      loc( th), &                          ! user's thread variable
                           0, &                            ! create and run
                  threads( this_thread)% win32_id )        ! Win32 thread id

   handle_error: if( threads( this_thread)% handle == win32_null )then

      error_code = fthread_error_syscall                   ! system call failed

      error_msg = 'create system call failed'

      goto 1                                               ! go process error

   endif handle_error                                      ! null handle implies failure

! ----------------------------------------------------------------------

!  report success

   trace_create: if( present( trace_v) )then               ! log activities

      call trace_msg( name_msg // 'initialized thread ' // threads( this_thread)% label, &
                            code= this_thread, trace_v= trace_v)

   endif trace_create                                      ! log activities

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! thread_id()

! ----------------------------------------------------------------------

!  hither upon error

 1 continue

   if( present( flag) ) flag = error_code                  ! set flag if possible

   trace_error: if( present( trace_v) )then                ! log error message if possible

      syserr: if( error_code == fthread_error_syscall )then

         win32_return = GetLastError()                     ! record Win32 error code

         call trace_msg( name_msg // error_msg, &
                         code= win32_return, trace_v= trace_v)

      else syserr

         call trace_msg( name_msg // error_msg, trace_v= trace_v)

      endif syserr

   endif trace_error                                       ! log error message if possible

! ----------------------------------------------------------------------

!  error exit

return                                                     ! fthread_create()

!  thread_create()

! **********************************************************************

end subroutine thread_create

! **********************************************************************
! **********************************************************************

!  thread_wait() waits for given thread to exit

! **********************************************************************

subroutine thread_wait( th, trace_v, flag)

!  thread_wait() interface

type( thread_t), intent( in) :: th                         ! thread to wait for

type( trace_t), optional, intent( inout) :: trace_v        ! trace actions

integer, optional, intent( out) :: flag                    ! status

! ----------------------------------------------------------------------

!  thread_wait() NT system calls

interface
   integer( 4) function WaitForSingleObject( dwhandle, Mseconds)
!DEC$ ATTRIBUTES DEFAULT :: WaitForSingleObject
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_WaitForSingleObject@8' :: WaitForSingleObject
      integer( 4) :: dwhandle
!DEC$ ATTRIBUTES VALUE :: dwhandle
      integer( 4) :: Mseconds
!DEC$ ATTRIBUTES VALUE :: Mseconds
   end function WaitForSingleObject

   integer( 4) function GetExitCodeThread( hThread, lpExitCode)
!DEC$ ATTRIBUTES DEFAULT :: GetExitCodeThread
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_GetExitCodeThread@8' :: GetExitCodeThread
      integer( 4) :: hThread
!DEC$ ATTRIBUTES VALUE ::   hThread
      integer( 4) :: lpExitCode
!DEC$ ATTRIBUTES REFERENCE ::   lpExitCode
   end function GetExitCodeThread

   integer( 4) function GetThreadTimes( &
      hThread, &
      lpCreationTime, &
      lpExitTime, &
      lpKernelTime, &
      lpUserTime)
!DEC$ ATTRIBUTES DEFAULT :: GetThreadTimes
!DEC$ ATTRIBUTES STDCALL, ALIAS:'_GetThreadTimes@20' :: GetThreadTimes
      integer( 4) :: hThread                               ! HANDLE hThread
      integer( 4) :: lpCreationTime                        ! LPFILETIME lpCreationTime
      integer( 4) :: lpExitTime                            ! LPFILETIME lpExitTime
      integer( 4) :: lpKernelTime                          ! LPFILETIME lpKernelTime
      integer( 4) :: lpUserTime                            ! LPFILETIME lpUserTime
   end function GetThreadTimes

   integer( 4) function CloseHandle( dwhandle)
!DEC$ ATTRIBUTES DEFAULT :: CloseHandle
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_CloseHandle@4' :: CloseHandle
      integer( 4) :: dwhandle
!DEC$ ATTRIBUTES VALUE :: dwhandle
   end function CloseHandle

   integer( 4) function GetLastError()
!DEC$ ATTRIBUTES DEFAULT :: GetLastError
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_GetLastError@0' :: GetLastError
   end function GetLastError
end interface

! **********************************************************************

!  thread_wait() local

! ----------------------------------------------------------------------

!  return values

   integer :: win32_return                                 ! return value from Win32 system call
   integer :: value                                        ! thread return value

!  time buffers

   integer, dimension( t_size) :: u_buf                    ! user time buffer
   integer, dimension( t_size) :: k_buf                    ! kernel time buffer

   integer, parameter :: not_sb = huge( 0)                 ! all but sign bit

!  informative and error messages

   character( len= *), parameter :: name_msg = 'thread_wait(): '

   integer :: error_code                                   ! status flag
   character( len= name_length) :: error_msg               ! error text

! **********************************************************************

!  thread_wait() steps:

!  1. wait for thread to exit
!  2. get thread exit code
!  3. get thread times
!  4. close thread handle

! **********************************************************************

!  thread_wait() text

! ----------------------------------------------------------------------

continue                                                   ! thread_wait()

! ----------------------------------------------------------------------

!  can't wait for primary thread

   primary_error: if( th% id == primary_id )then           ! only primary waits

      error_code = fthread_error_state                     ! primary waits for workers

      error_msg = 'tried to wait for primary thread' // threads( th% id)% label

      goto 1                                               ! go process error

   endif primary_error                                     ! only primary waits

! ----------------------------------------------------------------------

!  check thread not already waited

   thread_error: if( threads( th% id)% win32_id == win32_null )then

      error_code = fthread_error_state                     ! already waited for this thread

      error_msg = 'already waited for thread ' // threads( th% id)% label

      goto 1                                               ! go process error

   endif thread_error                                      ! no wait if still active

!  make Win32 system call to wait for thread exit

   win32_return = WaitForSingleObject( &                   ! wait for thread to exit
                   threads( th% id)% handle, &             ! thread
                   win32_infinite)                         ! wait forever

!  check system call return status

   wait_error: if( win32_return /= win32_wait_object_0 )then

      error_code = fthread_error_syscall                   ! wait failed

      error_msg = 'wait system call failed ' // threads( th% id)% label

      goto 1                                               ! go process error

   endif wait_error                                        ! object 0 is the thread

! ----------------------------------------------------------------------

!  make Win32 system call to get thread return value

   win32_return = GetExitCodeThread( &                     ! thread exit code
                   threads( th% id)% handle, &             ! thread to query
                   value)                                  ! exit code

   code_error: if( win32_return == win32_false )then       ! no exit code

      error_code = fthread_error_syscall

      error_msg = 'exit code system call failed ' // threads( th% id)% label

      goto 1                                               ! go process error

   endif code_error                                        ! no exit code

   threads( th% id)% rv = value                            ! to user via thread_status()

! ----------------------------------------------------------------------

!  log exit code

   trace_code: if( present( trace_v) )then                 ! if tracing

      call trace_msg( name_msg // 'thread exit code ' // threads( th% id)% label, &
                       code= value, trace_v= trace_v)

   endif trace_code                                        ! if tracing

! ----------------------------------------------------------------------

!  make Win32 system call to get thread execution times

   win32_return = GetThreadTimes( &                        ! thread times
            threads( th% id)% handle, &                    ! thread to query
       loc( threads( th% id)% ctime), &                    ! creation time
       loc( threads( th% id)% etime), &                    ! end time
       loc( k_buf), &                                      ! kernel time buffer
       loc( u_buf) )                                       ! user time buffer

   time_error: if( win32_return == win32_false )then       ! no thread times

      error_code = fthread_error_syscall

      error_msg = 'times system call failed ' // threads( th% id)% label

      goto 1                                               ! go process error

   endif time_error                                        ! no thread times

!  convert Win32 filetime to real without unsigned integers

   threads( th% id)% ktime = ( real( k_buf( 2)) * (2. ** 32.) + &
                             real( ishft( k_buf( 1), -31)) * (2. ** 31.) + &
                             real( iand( k_buf( 1), not_sb))) * 1.e-7

   threads( th% id)% utime = ( real( u_buf( 2)) * (2. ** 32.) + &
                             real( ishft( u_buf( 1), -31)) * (2. ** 31.) + &
                             real( iand( u_buf( 1), not_sb))) * 1.e-7

! ----------------------------------------------------------------------

!  close Win32 thread handle

   win32_return = CloseHandle( &                           ! close handle
                     threads( th% id)% handle)             ! thread

!  check system call return status

   close_error: if( win32_return == win32_false )then      ! close should return true

      error_code = fthread_error_syscall                   ! close failed

      error_msg = 'close system call failed ' // threads( th% id)% label

      goto 1                                               ! go process error

   endif close_error                                       ! close should return true

! ----------------------------------------------------------------------

!  update threads array

   threads( th% id)% handle = win32_null                   ! handle no longer valid

   threads( th% id)% win32_id = win32_null                 ! id no longer valid

! ----------------------------------------------------------------------

!  report success

   if( present( flag) ) flag = fthread_ok                  ! set flag if possible

   trace_wait: if( present( trace_v) )then                 ! log action if possible

       call trace_msg( name_msg // 'waited for thread ' // threads( th% id)% label, &
                        code= th% id,  trace_v= trace_v)

   endif trace_wait                                        ! log action if possible

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! thread_wait()

! ----------------------------------------------------------------------

!  hither upon error

 1 continue

   if( present( flag) ) flag = error_code                  ! set flag if possible

   trace_error: if( present( trace_v) )then                ! log error message if possible

      syserr: if( error_code == fthread_error_syscall )then

         win32_return = GetLastError()                     ! record Win32 error code

         call trace_msg( name_msg // error_msg, &
                         code= win32_return, trace_v= trace_v)

      else syserr

         call trace_msg( name_msg // error_msg, trace_v= trace_v)

      endif syserr

   endif trace_error                                       ! log error message if possible

! ----------------------------------------------------------------------

!  error exit

return                                                     ! thread_wait()

!  thread_wait()

! **********************************************************************

end subroutine thread_wait

! **********************************************************************
! **********************************************************************

!  thread_waitall() waits for all threads to exit

! **********************************************************************

subroutine thread_waitall( tm, trace_v, flag)

!  thread_waitall() interface

type( team_t), optional, intent( in) :: tm                 ! wait for all threads on team

type( trace_t), optional, intent( inout) :: trace_v        ! trace actions

integer, optional, intent( out) :: flag                    ! status

! ----------------------------------------------------------------------

!  thread_waitall() NT system calls

interface
   integer( 4) function WaitForMultipleObjects( Count, LpHandles, WaitAll, Mseconds)
!DEC$ ATTRIBUTES DEFAULT :: WaitForMultipleObjects
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_WaitForMultipleObjects@16' :: WaitForMultipleObjects
      integer( 4) :: Count
!DEC$ ATTRIBUTES VALUE :: Count
      integer( 4) :: LpHandles( *)
!DEC$ ATTRIBUTES REFERENCE :: LpHandles
      integer( 4) :: WaitAll
!DEC$ ATTRIBUTES VALUE :: WaitAll
      integer( 4) :: Mseconds
!DEC$ ATTRIBUTES VALUE :: Mseconds
   end function WaitForMultipleObjects

   integer( 4) function GetExitCodeThread( hThread, lpExitCode)
!DEC$ ATTRIBUTES DEFAULT :: GetExitCodeThread
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_GetExitCodeThread@8' :: GetExitCodeThread
      integer( 4) :: hThread
!DEC$ ATTRIBUTES VALUE ::   hThread
      integer( 4) :: lpExitCode
!DEC$ ATTRIBUTES REFERENCE ::   lpExitCode
   end function GetExitCodeThread

   integer( 4) function GetThreadTimes( &
      hThread, &
      lpCreationTime, &
      lpExitTime, &
      lpKernelTime, &
      lpUserTime)
!DEC$ ATTRIBUTES DEFAULT :: GetThreadTimes
!DEC$ ATTRIBUTES STDCALL, ALIAS:'_GetThreadTimes@20' :: GetThreadTimes
      integer( 4) :: hThread                               ! HANDLE hThread
      integer( 4) :: lpCreationTime                        ! LPFILETIME lpCreationTime
      integer( 4) :: lpExitTime                            ! LPFILETIME lpExitTime
      integer( 4) :: lpKernelTime                          ! LPFILETIME lpKernelTime
      integer( 4) :: lpUserTime                            ! LPFILETIME lpUserTime
   end function GetThreadTimes

   integer( 4) function CloseHandle( dwhandle)
!DEC$ ATTRIBUTES DEFAULT :: CloseHandle
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_CloseHandle@4' :: CloseHandle
      integer( 4) :: dwhandle
!DEC$ ATTRIBUTES VALUE :: dwhandle
   end function CloseHandle

   integer( 4) function GetLastError()
!DEC$ ATTRIBUTES DEFAULT :: GetLastError
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_GetLastError@0' :: GetLastError
   end function GetLastError
end interface

! **********************************************************************

!  thread_waitall() local

! ----------------------------------------------------------------------

!  counters and indices

   integer :: ith                                          ! loop thru threads
   integer :: count_th                                     ! count threads

!  return values

   integer :: win32_return                                 ! Win32 system call return value
   integer :: value                                        ! thread return value

!  time buffers

   integer, dimension( t_size) :: u_buf                    ! user time buffer
   integer, dimension( t_size) :: k_buf                    ! kernel time buffer

   integer, parameter :: not_sb = huge( 0)                 ! all but sign bit

!  thread arrays

   integer, dimension( worker_1: this_thread) :: wait_index
   integer, dimension( max_thread_id) :: handles           ! handles of worker threads

   type( p_team_t) :: wait_team                            ! wait for these threads

!  informative and error messages

   character( len= *), parameter :: name_msg = 'thread_waitall(): '

   integer :: error_code                                   ! status flag
   character( len= name_length) :: error_msg               ! error text

! **********************************************************************

!  thread_waitall() steps:

!  1. make array of all (active) worker thread handles
!  2. wait for all threads to exit
!  3. get thread exit codes
!  4. get thread times
!  5. close thread handles

! **********************************************************************

!  thread_waitall() text

! ----------------------------------------------------------------------

continue                                                   ! thread_waitall()

! ----------------------------------------------------------------------

!  make array of team active worker thread handles

   team_arg: if( present( tm) )then                        ! wait for team

      wait_team = teams( tm% id)                           ! wait for declared team

   else team_arg                                           ! wait for team

      wait_team = teams( all_workers% id)                  ! wait for all workers

   endif team_arg                                          ! wait for team

! ----------------------------------------------------------------------

!  gather threads for waitall

   count_th = 0                                            ! count threads on team
   gather_wait: do ith = worker_1, max_thread_id           ! do all workers

      on_team: if( wait_team% list( ith) )then             ! if on team

         count_th = count_th + 1                           ! count it
         wait_index( count_th) = ith                       ! and add to waitall list
         handles( count_th) = threads( ith)% handle        ! list of handles

      endif on_team                                        ! if on team

   enddo gather_wait                                       ! do all workers

! ----------------------------------------------------------------------

!  check for no threads running

   none_running: if( count_th == 0 )then                   ! all threads exited

      error_code = fthread_ok

      error_msg = 'no threads active'

      goto 1                                               ! go process error

   endif none_running                                      ! all threads exited

! ----------------------------------------------------------------------

!  Win32 system call to wait for threads to exit

   win32_return = WaitForMultipleObjects( &                ! wait for workers
                         count_th, &                       ! wait for count_th workers
                    loc( handles), &                       ! thread handles
                         win32_true, &                     ! wait for all
                         win32_infinite)                   ! wait forever

   wait_error: if( win32_return /= win32_wait_object_0 )then

      error_code = fthread_error_syscall                   ! system call error

      error_msg = 'wait system call failed'

      goto 1                                               ! go process error

   endif wait_error                                        ! if all threads didn't exit

! ----------------------------------------------------------------------

!  loop to get thread status, thread times and close thread handles

   close_handles: do ith = 1, count_th                     ! do all threads on list

! ----------------------------------------------------------------------

!  make Win32 system call to get thread return value

      win32_return = GetExitCodeThread( &                  ! thread exit code
            threads( wait_index( ith))% handle, &          ! thread to query
            loc( value) )                                  ! exit code

      code_error: if( win32_return == win32_false )then    ! true if successful

         error_code = fthread_error_syscall

         error_msg = 'exit code system call failed ' // threads( wait_index( ith))% label

         goto 1                                            ! go process error

      endif code_error                                     ! true if successful

      threads( wait_index( ith))% rv = value               ! to user by thread_status()

! ----------------------------------------------------------------------

!  log exit code

      trace_code: if( present( trace_v) )then

         call trace_msg( name_msg // 'thread exit code ' // threads( wait_index( ith))% label, &
                         code= value, trace_v= trace_v)

      endif trace_code

! ----------------------------------------------------------------------

!  make Win32 system call to get thread execution times

      win32_return = GetThreadTimes( &                     ! thread times
            threads( wait_index( ith))% handle, &          ! thread to query
       loc( threads( wait_index( ith))% ctime), &
       loc( threads( wait_index( ith))% etime), &
       loc( k_buf), &                                      ! kernel time
       loc( u_buf) )                                       ! user time

      time_error: if( win32_return == win32_false )then

         error_code = fthread_error_syscall

         error_msg = 'times system call failed ' // threads( wait_index( ith))% label

         goto 1                                            ! go process error

      endif time_error                                     ! no thread times

!  convert Win32 filetime to real without unsigned integers

      threads( wait_index( ith))% ktime = ( real( k_buf( 2)) * (2. ** 32.) + &
                                real( ishft( k_buf( 1), -31)) * (2. ** 31.) + &
                                real( iand( k_buf( 1), not_sb))) * 1.e-7

      threads( wait_index( ith))% utime = ( real( u_buf( 2)) * (2. ** 32.) + &
                                real( ishft( u_buf( 1), -31)) * (2. ** 31.) + &
                                real( iand( u_buf( 1), not_sb))) * 1.e-7

! ----------------------------------------------------------------------

!  close NT handle

      win32_return = CloseHandle( &                        ! close handle
                            handles( ith) )                ! thread

      close_error: if( win32_return == win32_false )then

         error_code = fthread_error_syscall

         error_msg = 'close system call failed ' // threads( wait_index( ith))% label

         goto 1                                            ! go process error

      endif close_error                                    ! not successful

   enddo close_handles                                     ! do all threads on list

! ----------------------------------------------------------------------

!  mark waited workers as terminated

   threads( wait_index)% handle = win32_null               ! null handle
   threads( wait_index)% win32_id = win32_null             ! null id

! ----------------------------------------------------------------------

!  report success

   if( present( flag) ) flag = fthread_ok                  ! set flag to success

   trace_waitall: if( present( trace_v) )then              ! if tracing

      call trace_msg( name_msg // 'waited for threads', &
                      code= count_th, trace_v= trace_v)

   endif trace_waitall                                     ! if tracing

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! thread_waitall()

! ----------------------------------------------------------------------

!  hither upon error

 1 continue

   if( present( flag) ) flag = error_code                  ! set flag if possible

   trace_error: if( present( trace_v) )then                ! log error message if possible

      syserr: if( error_code == fthread_error_syscall )then

         win32_return = GetLastError()                     ! record Win32 error code

         call trace_msg( name_msg // error_msg, &
                         code= win32_return, trace_v= trace_v)

      else syserr

         call trace_msg( name_msg // error_msg, trace_v= trace_v)

      endif syserr

   endif trace_error                                       ! log error message if possible

! ----------------------------------------------------------------------

!  error exit

return                                                     ! thread_waitall()

!  thread_waitall()

! **********************************************************************

end subroutine thread_waitall

! **********************************************************************
! **********************************************************************

!  thread_return() thread exits

! **********************************************************************

subroutine thread_return( th, value, trace_v)

!  thread_return() interface

type( thread_t), intent( in) :: th                         ! thread returning

integer, optional, intent( in) :: value                    ! return value

type( trace_t), optional, intent( inout) :: trace_v        ! trace actions

! ----------------------------------------------------------------------

!  thread_return() NT system calls

interface
   subroutine ExitThread( ExitCode)
!DEC$ ATTRIBUTES DEFAULT :: ExitThread
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_ExitThread@4' :: ExitThread
      integer( 4) :: ExitCode
!DEC$ ATTRIBUTES VALUE :: ExitCode
   end subroutine ExitThread
end interface

! ----------------------------------------------------------------------

!  thread_return() local

!  This compiler has ExitThread() as a subroutine, not a function.

! **********************************************************************

!  thread_return() local

! ----------------------------------------------------------------------

!  informational and error messages

   character( len= *), parameter :: name_msg = 'thread_return(): '

   integer :: l_value

! **********************************************************************

!  thread_return() steps:

!  1. thread exits

! **********************************************************************

!  thread_return() text

! ----------------------------------------------------------------------

continue                                                   ! thread_return()

! ----------------------------------------------------------------------

!  report end of thread

   trace_wait: if( present( trace_v) )then                 ! log action if possible

       call trace_msg( name_msg // 'return from thread ' // threads( th% id)% label, &
                       code= th% id, trace_v= trace_v)

   endif trace_wait                                        ! log action if possible

! ----------------------------------------------------------------------

!  return given value or default

   got_value: if( present( value) )then                    ! value specified

      l_value = value                                      ! use it

   else got_value                                          ! value specified

      l_value = fthread_ok                                 ! return fthread_ok

   endif got_value                                         ! value specified

! ----------------------------------------------------------------------

!  make Win32 system call to exit this thread

   call ExitThread( &                                      ! end of this thread
                                 l_value)                  ! thread return value


!  should never return from ExitThread()

! ----------------------------------------------------------------------

!  normal exit (never taken)

return                                                     ! thread_return()

!  thread_return()

! **********************************************************************

end subroutine thread_return

! **********************************************************************
! **********************************************************************

!  thread_pause() suspend thread

! **********************************************************************

subroutine thread_pause( th, trace_v, flag)

!  thread_pause() interface

type( thread_t), intent( in) :: th                         ! thread to pause

type( trace_t), optional, intent( inout) :: trace_v        ! trace actions

integer, optional, intent( out) :: flag                    ! status

! ----------------------------------------------------------------------

!  thread_pause() NT system calls

interface
   integer( 4) function SuspendThread( hThread)
!DEC$ ATTRIBUTES DEFAULT :: SuspendThread
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_SuspendThread@4' :: SuspendThread
      integer( 4) :: hThread
!DEC$ ATTRIBUTES VALUE :: hThread
   end function SuspendThread

   integer( 4) function GetLastError()
!DEC$ ATTRIBUTES DEFAULT :: GetLastError
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_GetLastError@0' :: GetLastError
   end function GetLastError
end interface

! **********************************************************************

!  thread_pause() local

! ----------------------------------------------------------------------

!  return value

   integer :: win32_return                                 ! return value from Win32 system call

!  informative and error messages

   character( len= *), parameter :: name_msg = 'thread_pause(): '

   integer :: error_code                                   ! status flag
   character( len= name_length) :: error_msg               ! error text

! **********************************************************************

!  thread_pause() steps:

!  1. suspend thread

! **********************************************************************

!  thread_pause() text

! ----------------------------------------------------------------------

continue                                                   ! thread_pause()

! ----------------------------------------------------------------------

!  report suspension of thread

   trace_wait: if( present( trace_v) )then                 ! log action if possible

       call trace_msg( name_msg // 'suspend thread ' // threads( th% id)% label, &
                       code= th% id, trace_v= trace_v)

   endif trace_wait                                        ! log action if possible

! ----------------------------------------------------------------------

!  make Win32 system call to exit this thread

   win32_return = SuspendThread( &                         ! suspend thread
                     threads( th% id)% handle )            ! thread handle

!  check system call return status

   suspend_error: if( win32_return == win32_bad_suspend )then

      error_code = fthread_error_syscall                   ! close failed

      error_msg = 'suspend system call failed ' // threads( th% id)% label

      goto 1                                               ! go process error

   endif suspend_error

!  successfully suspended (and now resumed) thread

   if( present( flag) ) flag = fthread_ok                  ! mark successful return

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! thread_pause()

! ----------------------------------------------------------------------

!  hither upon error

 1 continue

   if( present( flag) ) flag = error_code                  ! set flag if possible

   trace_error: if( present( trace_v) )then                ! log error message if possible

      syserr: if( error_code == fthread_error_syscall )then

         win32_return = GetLastError()                     ! record Win32 error code

         call trace_msg( name_msg // error_msg, &
                         code= win32_return, trace_v= trace_v)

      else syserr

         call trace_msg( name_msg // error_msg, trace_v= trace_v)

      endif syserr

   endif trace_error

! ----------------------------------------------------------------------

!  error exit

return                                                     ! thread_pause()

!  thread_pause()

! **********************************************************************

end subroutine thread_pause

! **********************************************************************
! **********************************************************************

!  thread_run() resume a suspended thread

! **********************************************************************

subroutine thread_run( th, flag, trace_v)

!  thread_run() interface

type( thread_t), intent( in) :: th                         ! thread to resume

integer, optional, intent( out) :: flag                    ! status

type( trace_t), optional, intent( inout) :: trace_v        ! trace actions

! ----------------------------------------------------------------------

!  thread_run() NT system calls

interface
   integer( 4) function ResumeThread( hThread)
!DEC$ ATTRIBUTES DEFAULT :: ResumeThread
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_ResumeThread@4' :: ResumeThread
      integer( 4) :: hThread
!DEC$ ATTRIBUTES VALUE :: hThread
   end function ResumeThread

   integer( 4) function GetLastError()
!DEC$ ATTRIBUTES DEFAULT :: GetLastError
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_GetLastError@0' :: GetLastError
   end function GetLastError
end interface

! **********************************************************************

!  thread_run() local

! ----------------------------------------------------------------------

!  return values

   integer :: win32_return                                 ! return value from Win32 system call

!  informative and error messages

   character( len= *), parameter :: name_msg = 'thread_run(): '

   integer :: error_code                                   ! status flag
   character( len= name_length) :: error_msg               ! error text

! **********************************************************************

!  thread_run() steps:

!  1. resume thread

! **********************************************************************

!  thread_run() text

! ----------------------------------------------------------------------

continue                                                   ! thread_run()

! ----------------------------------------------------------------------

!  make Win32 system call to exit this thread

   win32_return = ResumeThread( &                          ! resume thread
                     threads( th% id)% handle )            ! thread handle

!  check system call return status

   resume_error: if( win32_return == win32_bad_suspend )then

      error_code = fthread_error_syscall                   ! close failed

      error_msg = 'resume system call failed ' // threads( th% id)% label

      goto 1                                               ! go process error

   endif resume_error                                      ! Win32 error

! ----------------------------------------------------------------------

!  successfully resumed (once was suspended) thread

   if( present( flag) ) flag = fthread_ok                  ! mark success

!  report end of thread

   trace_wait: if( present( trace_v) )then                 ! log action if possible

       call trace_msg( name_msg // 'resume thread ' // threads( th% id)% label, &
                       code= th% id, trace_v= trace_v)

   endif trace_wait                                        ! log action if possible

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! thread_run()

! ----------------------------------------------------------------------

!  hither upon error

 1 continue

   if( present( flag) ) flag = error_code                  ! set flag if possible

   trace_error: if( present( trace_v) )then                ! log error message if possible

      syserr: if( error_code == fthread_error_syscall )then

         win32_return = GetLastError()                     ! record Win32 error code

         call trace_msg( name_msg // error_msg, &
                         code= win32_return, trace_v= trace_v)

      else syserr

         call trace_msg( name_msg // error_msg, trace_v= trace_v)

      endif syserr

   endif trace_error                                       ! log error message if possible

! ----------------------------------------------------------------------

!  error exit

return                                                     ! thread_run()

!  thread_run()

! **********************************************************************

end subroutine thread_run

! **********************************************************************
! **********************************************************************

!  thread_id() thread id

! **********************************************************************

integer function thread_id( th)

!  thread_id() interface

type( thread_t), intent( in) :: th                         ! thread's name

! **********************************************************************

!  thread_id() steps:

!  1. return thread id

! **********************************************************************

!  thread_id() text

! ----------------------------------------------------------------------

continue                                                   ! thread_id()

! ----------------------------------------------------------------------

   thread_id = th% id                                      ! return thread id

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! thread_id()

!  thread_id()

! **********************************************************************

end function thread_id

! **********************************************************************
! **********************************************************************

!  thread_priority() get or set thread priority

! **********************************************************************

subroutine thread_priority( th, get, set, trace_v, flag)

!  thread_priority() interface

type( thread_t), intent( in) :: th                         ! which thread's priority

integer, optional, intent( out) :: get                     ! return

integer, optional, intent( in) :: set                      ! change

type( trace_t), intent( inout), optional :: trace_v        ! trace actions

integer, optional, intent( out) :: flag                    ! status

! ----------------------------------------------------------------------

!  thread_priority() NT sys calls

interface
   integer( 4) function GetThreadPriority( hThread)
!DEC$ ATTRIBUTES DEFAULT :: GetThreadPriority
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_GetThreadPriority@4' :: GetThreadPriority
      integer( 4) :: hThread
!DEC$ ATTRIBUTES VALUE ::   hThread
   end function GetThreadPriority

   integer( 4) function SetThreadPriority( hThread, nPriority)
!DEC$ ATTRIBUTES DEFAULT :: SetThreadPriority
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_SetThreadPriority@8' :: SetThreadPriority
      integer( 4) :: hThread
!DEC$ ATTRIBUTES VALUE :: hThread
      integer( 4) :: nPriority
!DEC$ ATTRIBUTES VALUE :: nPriority
   end function SetThreadPriority

   integer( 4) function GetLastError()
!DEC$ ATTRIBUTES DEFAULT :: GetLastError
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_GetLastError@0' :: GetLastError
   end function GetLastError
end interface

! **********************************************************************

!  thread_priority() local

! ----------------------------------------------------------------------

!  return values

   integer :: win32_return                                 ! return value

!  informative and error messages

   character( len= *), parameter :: name_msg = 'thread_priority(): '

   integer :: error_code                                   ! status flag
   character( len= name_length) :: error_msg               ! error text

! **********************************************************************

!  thread_priority() steps:

!  1. if get present, return thread priority
!  2. if set present, set thread priority

! **********************************************************************

!  thread_priority() text

! ----------------------------------------------------------------------

continue                                                   ! thread_priority()

! ----------------------------------------------------------------------

!  get thread priority

   get_arg: if( present( get) )then                        ! if get

      get = GetThreadPriority( &                           ! thread priority
                      threads( th% id)% handle)            ! thread

!  check return value

      win32_get_error: if( get == win32_priority_error )then

         error_code = fthread_error_syscall

         error_msg = 'get priority system call error'

         goto 1                                            ! go process error

      endif win32_get_error                                ! Win32 error code

   endif get_arg                                           ! if get

! ----------------------------------------------------------------------

!  set thread priority

   set_arg: if( present( set) )then                        ! if put

      win32_return = SetThreadPriority( &                  ! thread priority
                  threads( th% id)% handle, &              ! thread
                  set)                                     ! priority

      nt_set_error: if( win32_return /= win32_true )then   ! ok if true

         error_code = fthread_error_syscall

         error_msg = 'set priority system call error'

         goto 1                                            ! go process error

      endif nt_set_error                                   ! ok if true

   endif set_arg                                           ! if put

! ----------------------------------------------------------------------

!  report success

   if( present( flag) ) flag = fthread_ok                  ! set flag to success

   trace_priority: if( present( trace_v) )then             ! if tracing

      call trace_msg( name_msg // 'priority action ok', &
                      trace_v= trace_v)

   endif trace_priority                                    ! if tracing

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! thread_priority()

! ----------------------------------------------------------------------

!  hither upon error

 1 continue

   if( present( flag) ) flag = error_code                  ! status

   trace_error: if( present( trace_v) )then                ! log error message if possible

      syserr: if( error_code == fthread_error_syscall )then

         win32_return = GetLastError()                     ! record Win32 error code

         call trace_msg( name_msg // error_msg, &
                         code= win32_return, trace_v= trace_v)

      else syserr

         call trace_msg( name_msg // error_msg, trace_v= trace_v)

      endif syserr

   endif trace_error                                       ! log error message if possible

! ----------------------------------------------------------------------

!  error exit

return                                                     ! thread_priority()

!  thread_priority()

! **********************************************************************

end subroutine thread_priority

! **********************************************************************
! **********************************************************************

!  thread_status() inquires about a thread

subroutine thread_status( th, name, value, et, st, trace_v, flag)

!  thread_status() interface

type( thread_t), intent( in) :: th                         ! thread to query

character( len= *), optional, intent( out) :: name         ! thread name

integer, optional, intent( out) :: value                   ! return value

real, optional, intent( out) :: et                         ! user time

real, optional, intent( out) :: st                         ! system time

type( trace_t), intent( inout), optional :: trace_v        ! trace actions

integer, optional, intent( out) :: flag                    ! status

! **********************************************************************

!  thread_status() local

! ----------------------------------------------------------------------

!  informative and error messages

   character( len= *), parameter :: name_msg = 'thread_status(): '

! **********************************************************************

!  thread_status() steps:

!  1. if query present, return value

! **********************************************************************

!  thread_status() text

! ----------------------------------------------------------------------

continue                                                   ! thread_status()

! ----------------------------------------------------------------------

!  thread name

   name_arg: if( present( name) )then                      ! if want name

      name = threads( th% id)% label                       ! return name

   endif name_arg                                          ! if want name

! ----------------------------------------------------------------------

!  thread exit code

   value_arg: if( present( value) )then                    ! if want exit code

      value = threads( th% id)% rv                         ! return exit code

   endif value_arg                                         ! if want exit code

! ----------------------------------------------------------------------

!  thread execution time

   et_arg: if( present( et) )then                          ! if want user time

      et = threads( th% id)% utime                         ! return user time

   endif et_arg                                            ! if want user time

! ----------------------------------------------------------------------

!  thread kernel time

   st_arg: if( present( st) )then                          ! if want kernel time

      st = threads( th% id)% ktime                         ! return kernel time

   endif st_arg                                            ! if want kernel time

! ----------------------------------------------------------------------

!  log success

   if( present( flag) ) flag = fthread_ok                  ! status

   trace_status: if( present( trace_v) )then               ! if tracing

      call trace_msg( name_msg // 'query thread ' // threads( th% id)% label, &
                      code= th% id, trace_v= trace_v)

   endif trace_status                                      ! if tracing

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! thread_status()

!  thread_status()

! **********************************************************************

end subroutine thread_status

! **********************************************************************
! **********************************************************************

!  ### public team procedures

!  these procedures init, delete and query teams of threads

! **********************************************************************

!  team_init() initialize team variable

! **********************************************************************

subroutine team_init( tm, ths, name, trace_v, flag)

!  team_init() interface

type( team_t), intent( out) :: tm                          ! user's team variable

integer, dimension( :), intent( in) :: ths                 ! threads

character( len= *), optional, intent( in) :: name          ! team name

type( trace_t), optional, intent( inout) :: trace_v        ! trace actions

integer, optional, intent( out) :: flag                    ! status

! **********************************************************************

!  team_init() local

! ----------------------------------------------------------------------

!  informative and error messages

   character( len= *), parameter :: name_msg = 'team_init(): '

   integer :: error_code                                   ! status flag
   character( len= name_length) :: error_msg               ! error text

! **********************************************************************

!  team_init() steps:

!  1. check for too many teams
!  2. check for valid input list
!  3. set teams to true on team list

! **********************************************************************

!  team_init() text

! ----------------------------------------------------------------------

continue                                                   ! team_init()

! ----------------------------------------------------------------------

!  check if too many teams

   too_many: if( this_team >= max_team_id )then            ! if exceeding array bounds

      error_code = fthread_error_number

      error_msg = 'too many teams'

      goto 1                                               ! go process error

   endif too_many                                          ! if exceeding array bounds

! ----------------------------------------------------------------------

!  check that thread id's are all valid

   bad_ths: if( any( ths > max_thread_id) .or. any( ths < 1) )then

      error_code = fthread_error_number                    ! thread id on team list

      error_msg = 'bad thread id'

      goto 1                                               ! go process error

   endif bad_ths

! ----------------------------------------------------------------------

!  point to new team

   this_team = this_team + 1                               ! next team

! ----------------------------------------------------------------------

!  set team list

   teams( this_team)% list( ths) = .true.                  ! ths are members

! ----------------------------------------------------------------------

!  set team label

   name_arg: if( present( name) )then                      ! name specified

      teams( this_team)% label = name                      ! use it

   endif name_arg                                          ! name specified

! ----------------------------------------------------------------------

!  update user's team variable

   tm% id = this_team                                      ! user identify team

! ----------------------------------------------------------------------

!  log success

   if( present( flag) ) flag = fthread_ok                  ! mark success

   trace_init: if( present( trace_v) )then                 ! if tracing

      call trace_msg( name_msg // 'initialized team ' // teams( this_team)% label, &
                      code= this_team, trace_v= trace_v)

   endif trace_init                                        ! if tracing

! ----------------------------------------------------------------------

! normal exit

return                                                     ! team_init()

! ----------------------------------------------------------------------

!  hither upon error

 1 continue

   if( present( flag) ) flag = error_code                  ! set flag if possible

   trace_error: if( present( trace_v) )then                ! log error message if possible

      call trace_msg( name_msg // error_msg, trace_v= trace_v)

   endif trace_error                                       ! log error message if possible

! ----------------------------------------------------------------------

!  error exit

return                                                     ! thread_priority()

!  team_init()

! **********************************************************************

end subroutine team_init

! **********************************************************************
! **********************************************************************

!  team_del() delete team

! **********************************************************************

subroutine team_del( tm, trace_v, flag)

!  team_del() interface

type( team_t), intent( in) :: tm                           ! team to delete

type( trace_t), optional, intent( inout) :: trace_v        ! trace actions

integer, optional, intent( out) :: flag                    ! status

! **********************************************************************

!  team_del() local

! ----------------------------------------------------------------------

!  informative and error messages

   character( len= *), parameter :: name_msg = 'team_del(): '

! **********************************************************************

!  team_del() steps:

!  1. if barrier, event or mutex indicates this team, erase team
!  2. set team list to false

! **********************************************************************

!  team_del() text

! ----------------------------------------------------------------------

continue                                                   ! team_del()

! ----------------------------------------------------------------------

!  set team list

   teams( tm% id)% list = .false.                          ! no thread on team

! ----------------------------------------------------------------------

!  log success

   if( present( flag) ) flag = fthread_ok                  ! mark success

   trace_del: if( present( trace_v) )then                  ! if tracing

      call trace_msg( name_msg // 'deleted team ' // teams( tm% id)% label, &
                      code= tm% id, trace_v= trace_v)

   endif trace_del                                         ! if tracing

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! team_del()

!  team_del()

! **********************************************************************

end subroutine team_del

! **********************************************************************
! **********************************************************************

!  team_id() team id

! **********************************************************************

integer function team_id( tm)

!  team_id() interface

type( team_t), intent( in) :: tm                           ! team variable

! **********************************************************************

!  team_id() steps:

!  1. return team id

! **********************************************************************

!  team_id() text

! ----------------------------------------------------------------------

continue                                                   ! team_id()

! ----------------------------------------------------------------------

   team_id = tm% id                                        ! return team id

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! team_id()

!  team_id()

! **********************************************************************

end function team_id

! **********************************************************************
! **********************************************************************

!  team_member() team id

! **********************************************************************

logical function team_member( tm, th)

!  team_member() interface

type( team_t), intent( in) :: tm                           ! team to check

type( thread_t), intent( in) :: th                         ! thread to check

! **********************************************************************

!  team_member() steps:

!  1. return team id

! **********************************************************************

!  team_member() text

! ----------------------------------------------------------------------

continue                                                   ! team_member()

! ----------------------------------------------------------------------

   team_member = teams( tm% id)% list( th% id)             ! true if member of team

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! team_member()

!  team_member()

! **********************************************************************

end function team_member

! **********************************************************************
! **********************************************************************

!  team_status() inquires about a team

subroutine team_status( tm, name, members, b, ev, m, trace_v)

!  team_status() interface

type( team_t), intent( in) :: tm                           ! team to query

character( len= *), optional, intent( out) :: name         ! team name

integer, optional, intent( out) :: members                 ! number of members

integer, optional, intent( out) :: b                       ! number of barriers

integer, optional, intent( out) :: ev                      ! number of events

integer, optional, intent( out) :: m                       ! number of mutexs

type( trace_t), intent( inout), optional :: trace_v        ! trace actions

! **********************************************************************

!  team_status() local

! ----------------------------------------------------------------------

!  informative and error messages

   character( len= *), parameter :: name_msg = 'team_status(): '

! **********************************************************************

!  team_status() steps:

!  1. if query present, return value

! **********************************************************************

!  team_status() text

! ----------------------------------------------------------------------

continue                                                   ! team_status()

! ----------------------------------------------------------------------

!  name of team

   name_arg: if( present( name) )then                      ! if want name

      name = teams( tm% id)% label                         ! return name

   endif name_arg                                          ! if want name

! ----------------------------------------------------------------------

!  number of team members

   members_arg: if( present( members) )then                ! if want members

      members = count( teams( tm% id)% list)               ! return members

   endif members_arg                                       ! if want members

! ----------------------------------------------------------------------

!  number of barriers referencing team

   b_arg: if( present( b) )then                            ! if want barriers

      b = count( barriers% team == tm% id)                 ! return barriers

   endif b_arg                                             ! if want barriers

! ----------------------------------------------------------------------

!  number of events initialized

   ev_arg: if( present( ev) )then                          ! if want events

      ev = count( events% team == tm% id)                  ! return events

   endif ev_arg                                            ! if want events

! ----------------------------------------------------------------------

!  number of mutexs initialized

   m_arg: if( present( m) )then                            ! if want mutexs

      m = count( mutexs% team == tm% id)                   ! return mutexs

   endif m_arg                                             ! if want mutexs

! ----------------------------------------------------------------------

!  log success

   trace_status: if( present( trace_v) )then               ! if tracing

      call trace_msg( name_msg // 'query team ' // teams( tm% id)% label, &
                      code= tm% id, trace_v= trace_v)

   endif trace_status                                      ! if tracing

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! team_status()

!  team_status()

! **********************************************************************

end subroutine team_status

! **********************************************************************
! **********************************************************************

!  ### public barrier procedures

!  these procedures init, delete and synchronize at barriers

! **********************************************************************

!  barrier_init() initializes a barrier

! **********************************************************************

subroutine barrier_init( b, tm, name, trace_v, flag)

!  barrier_init() interface

type( barrier_t), intent( out) :: b                        ! barreir to init

type( team_t), optional, intent( in) :: tm                 ! team to use barrier

character( len= *), optional, intent( in) :: name          ! name barrier

type( trace_t), optional, intent( inout) :: trace_v        ! trace actions

integer, optional, intent( out) :: flag                    ! status

! ----------------------------------------------------------------------

! barrier_init() NT system calls

interface
   integer( 4) function CreateMutex( security, owner, string)
!DEC$ ATTRIBUTES DEFAULT :: CreateMutex
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_CreateMutexA@12' :: CreateMutex
      integer( 4) :: security
!DEC$ ATTRIBUTES VALUE :: security
      integer( 4) :: owner
!DEC$ ATTRIBUTES VALUE :: owner
      integer( 4) :: string
!DEC$ ATTRIBUTES VALUE :: string
   end function CreateMutex
   integer( 4) function CreateEvent( security, reset, init_state, string)
!DEC$ ATTRIBUTES DEFAULT :: CreateEvent
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_CreateEventA@16' :: CreateEvent
      integer( 4) :: security
!DEC$ ATTRIBUTES VALUE :: security
      integer( 4) :: reset
!DEC$ ATTRIBUTES VALUE :: reset
      integer( 4) :: init_state
!DEC$ ATTRIBUTES VALUE :: init_state
      integer( 4) :: string
!DEC$ ATTRIBUTES VALUE :: string
   end function CreateEvent

   integer( 4) function GetLastError()
!DEC$ ATTRIBUTES DEFAULT :: GetLastError
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_GetLastError@0' :: GetLastError
   end function GetLastError
end interface

! **********************************************************************

!  barrier_init() local

! ----------------------------------------------------------------------

!  return values

   integer :: win32_return                                 ! return from Win32 system call

!  informative and error messages

   character( len= *), parameter :: name_msg = 'barrier_init(): '

   integer :: error_code                                   ! status flag
   character( len= name_length) :: error_msg               ! error text

! **********************************************************************

!  barrier_init() steps:

!  1. check if too many barriers
!  2. create mutex
!  3. create event
!  4. update user's barrier variable
!  5. update barriers array
!  6. log barrier_init()

! **********************************************************************

!  barrier_init() text

! ----------------------------------------------------------------------

continue                                                   ! barrier_init()

! ----------------------------------------------------------------------

!  check if too many barriers

   too_many: if( this_barrier >= max_barrier_id )then      ! exceeds barriers array

      error_code = fthread_error_number

      error_msg = 'too many barriers'

      goto 1                                               ! go process error

   endif too_many                                          ! exceeds barriers array

! ----------------------------------------------------------------------

!  point to next barrier

   this_barrier = this_barrier + 1                         ! next

! ----------------------------------------------------------------------

!  call Win32 to get mutex handle

   barriers( this_barrier)% mutex = &                      ! barrier's mutex handle
                CreateMutex(        win32_null, &          ! default security attributes
                                    win32_false, &         ! not owned by this thread
                                    win32_null)            ! unnamed

   nt_mutex_error: if( barriers( this_barrier)% mutex == win32_null )then

      error_code = fthread_error_syscall

      error_msg = 'create system call error'

      goto 1                                               ! go process error

   endif nt_mutex_error                                    ! can't create mutex

! ----------------------------------------------------------------------

!  call Win32 to get event handle

   barriers( this_barrier)% event = &                      ! barrier's event handle
                CreateEvent(        win32_null, &          ! default security attributes
                                    win32_true, &          ! manual reset
                                    win32_false, &         ! initially clear
                                    win32_null)            ! unnamed

   nt_event_error: if( barriers( this_barrier)% event == win32_null )then

      error_code = fthread_error_syscall

      error_msg = 'create system call error'

      goto 1                                               ! go process error

   endif nt_event_error                                    ! can't create event

! ----------------------------------------------------------------------

!  check if team declared

   team_arg: if( present( tm) )then                        ! if team requested

      barriers( this_barrier)% team = tm% id               ! use specified team

   else team_arg                                           ! if team requested

      barriers( this_barrier)% team = all_workers_id       ! or default team

   endif team_arg                                          ! if team requested

! ----------------------------------------------------------------------

!  update user's variable

   b% id = this_barrier                                    ! barrier id

! ----------------------------------------------------------------------

!  update barriers array

   barriers( this_barrier)% height = count( teams( barriers( this_barrier)% team)% list)

   barriers( this_barrier)% current = 0                    ! none yet

   barriers( this_barrier)% syncs = 0                      ! none yet

! ----------------------------------------------------------------------

!  set barrier label

   name_arg: if( present( name) )then                      ! name specified

      barriers( this_barrier)% label = name                ! use it

   endif name_arg                                          ! name specified

! ----------------------------------------------------------------------

!  log success

   if( present( flag) ) flag = fthread_ok                  ! status

   trace_init: if( present( trace_v) )then                 ! if tracing

      call trace_msg( name_msg // 'initialized barrier ' // barriers( this_barrier)% label, &
                      code= this_barrier, trace_v= trace_v)

   endif trace_init                                        ! if tracing

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! barrier_init()

! ----------------------------------------------------------------------

!  hither upon error

 1 continue

   if( present( flag) ) flag = error_code                  ! set flag if possible

   trace_error: if( present( trace_v) )then                ! log error message if possible

      syserr: if( error_code == fthread_error_syscall )then

         win32_return = GetLastError()                     ! record Win32 error code

         call trace_msg( name_msg // error_msg, &
                         code= win32_return, trace_v= trace_v)

      else syserr

         call trace_msg( name_msg // error_msg, trace_v= trace_v)

      endif syserr

   endif trace_error                                       ! if tracing

! ----------------------------------------------------------------------

!  error exit

return                                                     ! barrier_init()

!  barrier_init()

! **********************************************************************

end subroutine barrier_init

! **********************************************************************
! **********************************************************************

!  barrier_del() ends a barrier

! **********************************************************************

subroutine barrier_del( b, flag, trace_v)

!  barrier_del() interface

type( barrier_t), intent( inout) :: b                      ! barrier to delete

integer, optional, intent( out) :: flag                    ! status

type( trace_t), optional, intent( inout) :: trace_v        ! trace actions

! ----------------------------------------------------------------------

! barrier_del() NT system calls

interface
   integer( 4) function CloseHandle( dwhandle)
!DEC$ ATTRIBUTES DEFAULT :: CloseHandle
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_CloseHandle@4' :: CloseHandle
      integer( 4) :: dwhandle
!DEC$ ATTRIBUTES VALUE :: dwhandle
   end function CloseHandle

   integer( 4) function GetLastError()
!DEC$ ATTRIBUTES DEFAULT :: GetLastError
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_GetLastError@0' :: GetLastError
   end function GetLastError
end interface

! **********************************************************************

!  barrier_del() local

! ----------------------------------------------------------------------

!  return values

   integer :: win32_return                                 ! Win32 return value

!  informative and error messages

   character( len= *), parameter :: name_msg = 'barrier_del(): '

   integer :: error_code                                   ! status flag
   character( len= name_length) :: error_msg               ! error text

! **********************************************************************

!  barrier_del() steps:

!  1. call Win32 to release mutex handle
!  2. call Win32 to release events handles
!  3. update barriers array

! **********************************************************************

!  barrier_del() text

! ----------------------------------------------------------------------

continue                                                   ! barrier_del()

! ----------------------------------------------------------------------

!  call Win32 to close mutex handle

   win32_return = CloseHandle( &                           ! delete handle
                     barriers( b% id)% mutex)              ! mutex handle

   nt_mutex_error: if( win32_return == win32_null )then    ! failed if not true

      error_code = fthread_error_syscall

      error_msg = 'close system call error'

      goto 1                                               ! go process error

   endif nt_mutex_error                                    ! failed if not true

! ----------------------------------------------------------------------

!  call Win32 to close event handle

   win32_return = CloseHandle( &                           ! delete handle
                     barriers( b% id)% event)              ! event handle

   nt_event_error: if( win32_return == win32_null )then    ! failed if not true

      error_code = fthread_error_syscall

      error_msg = 'close system call error'

      goto 1                                               ! go process error

   endif nt_event_error                                    ! failed if not true

! ----------------------------------------------------------------------

!  mark deleted

   barriers( b% id)% mutex = win32_null                    ! mutex gone

   barriers( b% id)% event = win32_null                    ! event gone

! ----------------------------------------------------------------------

!  log success

   if( present( flag) ) flag = fthread_ok                  ! mark success

   trace_del: if( present( trace_v) )then                  ! if tracing

      call trace_msg( name_msg // 'deleted barrier ' // barriers( b% id)% label, &
                      code= b% id, trace_v= trace_v)

   endif trace_del                                         ! if tracing

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! barrier_del()

! ----------------------------------------------------------------------

!  hither upon error

 1 continue

   if( present( flag) ) flag = error_code                  ! set flag if possible

   trace_error: if( present( trace_v) )then                ! log error message if possible

      syserr: if( error_code == fthread_error_syscall )then

         win32_return = GetLastError()                     ! record Win32 error code

         call trace_msg( name_msg // error_msg, &
                         code= win32_return, trace_v= trace_v)

      else syserr

         call trace_msg( name_msg // error_msg, trace_v= trace_v)

      endif syserr

   endif trace_error                                       ! log error message if possible

! ----------------------------------------------------------------------

!  error exit

return                                                     ! barrier_del()

!  barrier_del()

! **********************************************************************

end subroutine barrier_del

! **********************************************************************
! **********************************************************************

!  barrier_sync() mark arrival at a barrier

! **********************************************************************

subroutine barrier_sync( b, th, flag, trace_v)

!  barrier_sync() interface

type( barrier_t), intent( in) :: b                         ! sync at this barrier

type( thread_t), optional, intent( in) :: th               ! to check team membership

integer, optional, intent( out) :: flag                    ! status

type( trace_t), optional, intent( inout) :: trace_v        ! trace actions

! ----------------------------------------------------------------------

! barrier_sync() NT system calls

interface
   integer( 4) function WaitForSingleObject( dwhandle, Mseconds)
!DEC$ ATTRIBUTES DEFAULT :: WaitForSingleObject
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_WaitForSingleObject@8' :: WaitForSingleObject
      integer( 4) :: dwhandle
!DEC$ ATTRIBUTES VALUE :: dwhandle
      integer( 4) :: Mseconds
!DEC$ ATTRIBUTES VALUE :: Mseconds
   end function WaitForSingleObject

   integer( 4) function PulseEvent( hEvent)
!DEC$ ATTRIBUTES DEFAULT :: PulseEvent
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_PulseEvent@4' :: PulseEvent
      integer( 4) :: hEvent
!DEC$ ATTRIBUTES VALUE :: hEvent
   end function PulseEvent

   integer( 4) function ReleaseMutex( dwhandle)
!DEC$ ATTRIBUTES DEFAULT :: ReleaseMutex
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_ReleaseMutex@4' :: ReleaseMutex
      integer( 4) :: dwhandle
!DEC$ ATTRIBUTES VALUE ::   dwhandle
   end function ReleaseMutex

   integer( 4) function SignalObjectAndWait( &
      hObjectToSignal, &
      hObjectToWaitOn, &
      dwMilliseconds, &
      bAlertable)
!DEC$ ATTRIBUTES DEFAULT :: SignalObjectAndWait
!DEC$ ATTRIBUTES STDCALL, ALIAS:'_SignalObjectAndWait@16' :: SignalObjectAndWait
      integer( 4) :: hObjectToSignal                       ! HANDLE hObjectToSignal
      integer( 4) :: hObjectToWaitOn                       ! HANDLE hObjectToWaitOn
      integer( 4) :: dwMilliseconds                        ! DWORD dwMilliseconds
      integer( 4) :: bAlertable                            ! BOOL bAlertable
   end function SignalObjectAndWait

   integer( 4) function GetLastError()
!DEC$ ATTRIBUTES DEFAULT :: GetLastError
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_GetLastError@0' :: GetLastError
   end function GetLastError
end interface

! **********************************************************************

!  barrier_sync() local

! ----------------------------------------------------------------------

!  return values

   integer :: win32_return                                 ! Win32 return value

!  informative and error messages

   character( len= *), parameter :: name_msg = 'barrier_sync(): '

   integer :: error_code                                   ! status flag
   character( len= name_length) :: error_msg               ! error text

! **********************************************************************

!  barrier_sync() steps:

!  1. choose a, b, or c events
!  2. post this thread's event
!  3. wait for all events in a, b, or c events
!  4. clear this thread's event in the preceeding set

! **********************************************************************

!  barrier_sync() text

! ----------------------------------------------------------------------

continue                                                   ! barrier_sync()

! ----------------------------------------------------------------------

!  check team membership

   th_arg: if( present( th) )then                          ! check team if thread

      team_error: if( .not. teams( barriers( b% id)% team)% list( th% id) )then

         error_code = fthread_error_team                   ! thread not on team

         error_msg = 'not on team'

         goto 1                                            ! go process error

      endif team_error

   endif th_arg                                            ! check team if thread

! **********************************************************************

!  begin single threaded code

! ----------------------------------------------------------------------

!  wait for mutex

   win32_return = WaitForSingleObject( &                   ! wait for event
                     barriers( b% id)% mutex, &            ! mutex handle
                     win32_infinite)                       ! wait forever

   nt_wait_error: if( win32_return /= win32_wait_object_0 )then

      error_code = fthread_error_syscall

      error_msg = 'wait system call error'

      goto 1                                               ! go process error

   endif nt_wait_error

! ----------------------------------------------------------------------

!  update barrier syncs

   barriers( b% id)% syncs = barriers( b% id)% syncs + 1   ! one more sync

! ----------------------------------------------------------------------

!  increment count

   barriers( b% id)% current = barriers( b% id)% current + 1

!  check current versus height

   cur_v_hgt: if( barriers( b% id)% current == barriers( b% id)% height )then

      barriers( b% id)% current = 0                        ! reset count

      win32_return = PulseEvent( &                         ! post & clear event
                      barriers( b% id)% event)             ! event handle

      nt_pulse_error: if( win32_return /= win32_true )then ! error if not true

         error_code = fthread_error_syscall

         error_msg = 'pulse system call error'

         goto 1                                            ! go process error

      endif nt_pulse_error                                 ! error if not true

! **********************************************************************

!  end single threaded code if barrier satisfied

      win32_return = ReleaseMutex( &                       ! unlock mutex
                      barriers( b% id)% mutex)             ! mutex handle

      nt_release_error: if( win32_return /= win32_true )then

         error_code = fthread_error_syscall

         error_msg = 'release system call error'

         goto 1                                            ! go process error

      endif nt_release_error                               ! error if not true

   else cur_v_hgt                                          ! current v. height

! **********************************************************************

!  end single threaded code if waiting at barrier

      win32_return = SignalObjectAndWait( &                ! unlock mutex & wait for event
                     barriers( b% id)% mutex, &            ! mutex handle
                     barriers( b% id)% event, &            ! event handle
                     win32_infinite, &                     ! wait forever
                     win32_false)                          ! not waiting for I/O

      nt_signal_error: if( win32_return /= win32_true )then

         error_code = fthread_error_syscall

         error_msg = 'signal system call error'

         goto 1                                            ! go process error

      endif nt_signal_error                                ! error if not true

   endif cur_v_hgt                                         ! current v. height

! ----------------------------------------------------------------------

!  log success

   if( present( flag) ) flag = fthread_ok                  ! mark success

   trace_sync: if( present( trace_v) )then                 ! if tracing

      call trace_msg( name_msg // 'release thread ' // barriers( b% id)% label, &
                      code= b% id, trace_v= trace_v)

   endif trace_sync                                        ! if tracing

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! barrier_sync()

! ----------------------------------------------------------------------

!  hither upon error

 1 continue

   if( present( flag) ) flag = error_code                  ! set flag if possible

   trace_error: if( present( trace_v) )then                ! log error message if possible

      syserr: if( error_code == fthread_error_syscall )then

         win32_return = GetLastError()                     ! record Win32 error code

         call trace_msg( name_msg // error_msg, &
                         code= win32_return, trace_v= trace_v)

      else syserr

         call trace_msg( name_msg // error_msg, trace_v= trace_v)

      endif syserr

   endif trace_error                                       ! log error message if possible

! ----------------------------------------------------------------------

!  error exit

return                                                     ! barrier_sync()

!  barrier_sync()

! **********************************************************************

end subroutine barrier_sync

! **********************************************************************
! **********************************************************************

!  barrier_id() return barrier id

! **********************************************************************

integer function barrier_id( b)

!  barrier_id() interface

type( barrier_t), intent( in) :: b                         ! id of this barrier

! **********************************************************************

!  barrier_id() steps:

!  1. return barrier id

! **********************************************************************

!  barrier_id() text

! ----------------------------------------------------------------------

continue                                                   ! barrier_id()

! ----------------------------------------------------------------------

   barrier_id = b% id                                      ! return barrier id

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! barrier_id()

!  barrier_id()

! **********************************************************************

end function barrier_id

! **********************************************************************
! **********************************************************************

!  barrier_status() inquires about a barrier

! **********************************************************************

subroutine barrier_status( b, name, number, synced, trace_v, flag)

!  barrier_status() interface

type( barrier_t), intent( in) :: b                         ! status of this barrier

character( len= *), optional, intent( out) :: name         ! barrier's name
integer, optional, intent( out) :: number                  ! height of barrier
integer, optional, intent( out) :: synced                  ! number of syncs

type( trace_t), optional, intent( inout) :: trace_v        ! trace actions

integer, optional, intent( out) :: flag                    ! status

! **********************************************************************

!  barrier_status() local

! ----------------------------------------------------------------------

!  informative and error messages

   character( len= *), parameter :: name_msg = 'barrier_status(): '

! **********************************************************************

!  barrier_status() steps:

!  1. if request is present, return value

! **********************************************************************

!  barrier_status() text

! ----------------------------------------------------------------------

continue                                                   ! barrier_status()

! ----------------------------------------------------------------------

!  if barrier height requested

   number_arg: if( present( number) )then                  ! if height requested

      number = barriers( b% id)% height                    ! barrier height

   endif number_arg                                        ! if height requested

! ----------------------------------------------------------------------

!  if barrier runs requested

   sync_arg: if( present( synced) )then                    ! if syncs requested

      synced = barriers( b% id)% syncs                     ! barrier syncs

   endif sync_arg                                          ! if syncs requested

! ----------------------------------------------------------------------

!  if barrier name requested

   name_arg: if( present( name) )then                      ! if label requested

      name = barriers( b% id)% label                       ! barrier name

   endif name_arg                                          ! if label requested

! ----------------------------------------------------------------------

!  log success

   if( present( flag) ) flag = fthread_ok                  ! status

   trace_status: if( present( trace_v) )then               ! if tracing

      call trace_msg( name_msg // 'query barrier ' // barriers( b% id)% label, &
                      code= b% id, trace_v= trace_v)

   endif trace_status                                      ! if tracing

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! barrier_status()

!  barrier_status()

! **********************************************************************

end subroutine barrier_status

! **********************************************************************
! **********************************************************************

!  ### public event procedures

!  these procedures init, delete and synchronize via events

! **********************************************************************

!  event_init() init an event

! **********************************************************************

subroutine event_init( ev, tm, name, trace_v, flag)

!  event_init() interface

type( event_t), intent( out) :: ev                         ! event to init

type( team_t), optional, intent( in) :: tm                 ! event used by team

character( len= *), optional, intent( in) :: name          ! name event

type( trace_t), optional, intent( inout) :: trace_v        ! trace actions

integer, optional, intent( out) :: flag                    ! status

! ----------------------------------------------------------------------

! event_init() NT system calls

interface
   integer( 4) function CreateEvent( security, reset, init_state, string)
!DEC$ ATTRIBUTES DEFAULT :: CreateEvent
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_CreateEventA@16' :: CreateEvent
      integer( 4) :: security
!DEC$ ATTRIBUTES VALUE :: security
      integer( 4) :: reset
!DEC$ ATTRIBUTES VALUE :: reset
      integer( 4) :: init_state
!DEC$ ATTRIBUTES VALUE :: init_state
      integer( 4) :: string
!DEC$ ATTRIBUTES VALUE :: string
   end function CreateEvent

   integer( 4) function GetLastError()
!DEC$ ATTRIBUTES DEFAULT :: GetLastError
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_GetLastError@0' :: GetLastError
   end function GetLastError
end interface

! **********************************************************************

!  event_init() local

! ----------------------------------------------------------------------

!  return values

   integer :: win32_return                                 ! return from Win32 system call

!  informative and error messages

   character( len= *), parameter :: name_msg = 'event_init(): '

   integer :: error_code                                   ! status flag
   character( len= name_length) :: error_msg               ! error text

! **********************************************************************

!  event_init() steps:

!  1. check number of events
!  2. call Win32 to get event handle
!  3. update user's variable
!  4. update events array

! **********************************************************************

!  event_init() text

! ----------------------------------------------------------------------

continue                                                   ! event_init()

! ----------------------------------------------------------------------

!  check number of events

   too_many: if( this_event >= max_event_id )then          ! if exceeds events array

      error_code = fthread_error_number

      error_msg = 'too many events'

      goto 1                                               ! go process error

   endif too_many                                          ! if exceeds events array

! ----------------------------------------------------------------------

!  point to next event

   this_event = this_event + 1                             ! next

! ----------------------------------------------------------------------

!  call Win32 to get event handle

   events( this_event)% handle = &                         ! event handle
                        CreateEvent( &                     ! create event
                                  win32_null, &            ! default security attributes
                                  win32_true, &            ! manual reset
                                  win32_false, &           ! initially clear
                                  win32_null)              ! unnamed

   handle_error: if( events( this_event)% handle == win32_null )then

      error_code = fthread_error_syscall

      error_msg = 'create system call error'

      goto 1                                               ! go process error

   endif handle_error                                      ! null handle is error

! ----------------------------------------------------------------------

!  update user's event variable

   ev% id = this_event                                     ! set user's event variable

! ----------------------------------------------------------------------

!  update events array

   events( this_event)% waits = 0                          ! none yet

   events( this_event)% posts = 0                          ! none yet

   events( this_event)% clears = 0                         ! none yet

! ----------------------------------------------------------------------

!  set team

   team_arg: if( present( tm) )then                        ! if team requested

      events( this_event)% team = tm% id                   ! specified team

   else team_arg                                           ! if team requested

      events( this_event)% team = all_workers_id           ! default team

   endif team_arg                                          ! if team requested

! ----------------------------------------------------------------------

!  set event label

   name_arg: if( present( name) )then                      ! name specified

      events( this_event)% label = name                    ! use it

   endif name_arg                                          ! name specified

! ----------------------------------------------------------------------

!  log success

   if( present( flag) ) flag = fthread_ok                  ! status

   trace_init: if( present( trace_v) )then                 ! if tracing

      call trace_msg( name_msg // 'initialized event ' // events( ev% id)% label, &
                      code= ev% id, trace_v= trace_v)

   endif trace_init                                        ! if team requested

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! event_init()

! ----------------------------------------------------------------------

!  hither upon error

 1 continue

   if( present( flag) ) flag = error_code                  ! set flag if possible

   trace_error: if( present( trace_v) )then                ! log error message if possible

      syserr: if( error_code == fthread_error_syscall )then

         win32_return = GetLastError()                     ! record Win32 error code

         call trace_msg( name_msg // error_msg, &
                         code= win32_return, trace_v= trace_v)

      else syserr

         call trace_msg( name_msg // error_msg, trace_v= trace_v)

      endif syserr

   endif trace_error                                       ! log error message if possible

! ----------------------------------------------------------------------

!  error exit

return                                                     ! event_init()

!  event_init()

! **********************************************************************

end subroutine event_init

! **********************************************************************
! **********************************************************************

!  event_del() end an event

! **********************************************************************

subroutine event_del( ev, trace_v, flag)

!  event_del() interface

type( event_t), intent( inout) :: ev                       ! event to delete

type( trace_t), optional, intent( inout) :: trace_v        ! trace actions

integer, optional, intent( out) :: flag                    ! status

! ----------------------------------------------------------------------

!  event_del() NT system calls

interface
   integer( 4) function CloseHandle( dwhandle)
!DEC$ ATTRIBUTES DEFAULT :: CloseHandle
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_CloseHandle@4' :: CloseHandle
      integer( 4) :: dwhandle
!DEC$ ATTRIBUTES VALUE :: dwhandle
   end function CloseHandle

   integer( 4) function GetLastError()
!DEC$ ATTRIBUTES DEFAULT :: GetLastError
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_GetLastError@0' :: GetLastError
   end function GetLastError
end interface

! **********************************************************************

!  event_del() local

! ----------------------------------------------------------------------

!  return values

   integer :: win32_return                                 ! Win32 return value

!  informative and error messages

   character( len= *), parameter :: name_msg = 'event_del(): '

   integer :: error_code                                   ! status flag
   character( len= name_length) :: error_msg               ! error text

! **********************************************************************

!  event_del() steps:

!  1. call Win32 to release handle
!  2. log activity
!  3. update user's event variable

! **********************************************************************

!  event_del() text

! ----------------------------------------------------------------------

continue                                                   ! event_del()

! ----------------------------------------------------------------------

!  call Win32 to close handle

   win32_return = CloseHandle( &                           ! delete handle
                     events( ev% id)% handle)              ! event handle

   close_error: if( win32_return == win32_null )then       ! Win32 error

      error_code = fthread_error_syscall

      error_msg = 'close system call error'

      goto 1                                               ! go process error

   endif close_error                                       ! Win32 error

! ----------------------------------------------------------------------

!  mark event deleted

   events( ev% id)% handle = win32_null                    ! not a handle

! ----------------------------------------------------------------------

!  log success

   if( present( flag) ) flag = fthread_ok                  ! status

   trace_del: if( present( trace_v) )then                  ! if tracing

      call trace_msg( name_msg // 'deleted event ' // events( ev% id)% label, &
                      code= ev% id, trace_v= trace_v)

   endif trace_del                                         ! if tracing

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! event_del()

! ----------------------------------------------------------------------

!  hither upon error

 1 continue

   if( present( flag) ) flag = error_code                  ! set flag if possible

   trace_error: if( present( trace_v) )then                ! log error message if possible

      syserr: if( error_code == fthread_error_syscall )then

         win32_return = GetLastError()                     ! record Win32 error code

         call trace_msg( name_msg // error_msg, &
                         code= win32_return, trace_v= trace_v)

      else syserr

         call trace_msg( name_msg // error_msg, trace_v= trace_v)

      endif syserr

   endif trace_error                                       ! log error message if possible

! ----------------------------------------------------------------------

!  error exit

return                                                     ! event_del()

!  event_del()

! **********************************************************************

end subroutine event_del

! **********************************************************************
! **********************************************************************

!  event_wait() wait until an event is posted

! **********************************************************************

subroutine event_wait( ev, th, trace_v, flag)

!  event_wait() interface

type( event_t), intent( in) :: ev                          ! wait for this event

type( thread_t), optional, intent( in) :: th               ! to check team membership

type( trace_t), optional, intent( inout) :: trace_v        ! trace actions

integer, optional, intent( out) :: flag                    ! status

! ----------------------------------------------------------------------

! event_wait() NT system calls

interface
   integer( 4) function WaitForSingleObject( dwhandle, Mseconds)
!DEC$ ATTRIBUTES DEFAULT :: WaitForSingleObject
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_WaitForSingleObject@8' :: WaitForSingleObject
      integer( 4) :: dwhandle
!DEC$ ATTRIBUTES VALUE :: dwhandle
      integer( 4) :: Mseconds
!DEC$ ATTRIBUTES VALUE :: Mseconds
   end function WaitForSingleObject

   integer( 4) function GetLastError()
!DEC$ ATTRIBUTES DEFAULT :: GetLastError
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_GetLastError@0' :: GetLastError
   end function GetLastError
end interface

! **********************************************************************

!  event_wait() local

! ----------------------------------------------------------------------

!  return values

   integer :: win32_return                                 ! Win32 return value

!  informative and error messages

   character( len= *), parameter :: name_msg = 'event_wait(): '

   integer :: error_code                                   ! status flag
   character( len= name_length) :: error_msg               ! error text

! **********************************************************************

!  event_wait() text

! ----------------------------------------------------------------------

continue                                                   ! event_wait()

! ----------------------------------------------------------------------

!  check team membership

   th_arg: if( present( th) )then                          ! if team

      team_error: if( .not. teams( events( ev% id)% team)% list( th% id) )then

         error_code = fthread_error_team

         error_msg = 'not on team'

         goto 1                                            ! go process error

      endif team_error

   endif th_arg                                            ! if team

! ----------------------------------------------------------------------

!  wait for event

   win32_return = WaitForSingleObject( &                   ! wait for event
                     events( ev% id)% handle, &            ! event handle
                     win32_infinite)                       ! wait forever

   wait_error: if( win32_return /= win32_wait_object_0 )then

      error_code = fthread_error_syscall

      error_msg = 'wait system call error'

      goto 1                                               ! go process error

   endif wait_error                                        ! object 0 is event

! ----------------------------------------------------------------------

!  update events array

   events( ev% id)% waits = events( ev% id)% waits + 1     ! count

! ----------------------------------------------------------------------

!  log success

   if( present( flag) ) flag = fthread_ok                  ! mark success

   trace_wait: if( present( trace_v) )then                 ! if tracing

      call trace_msg( name_msg // 'waited for event ' // events( ev% id)% label, &
                      code= ev% id, trace_v= trace_v)

   endif trace_wait                                        ! if tracing

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! event_wait()

! ----------------------------------------------------------------------

!  hither upon error

 1 continue

   if( present( flag) ) flag = error_code                  ! set flag if possible

   trace_error: if( present( trace_v) )then                ! log error message if possible

      syserr: if( error_code == fthread_error_syscall )then

         win32_return = GetLastError()                     ! record Win32 error code

         call trace_msg( name_msg // error_msg, &
                         code= win32_return, trace_v= trace_v)

      else syserr

         call trace_msg( name_msg // error_msg, trace_v= trace_v)

      endif syserr

   endif trace_error                                       ! log error message if possible

! ----------------------------------------------------------------------

!  error exit

return                                                     ! event_wait()

!  event_wait()

! **********************************************************************

end subroutine event_wait

! **********************************************************************
! **********************************************************************

!  event_clear() clear an event

! **********************************************************************

subroutine event_clear( ev, th, trace_v, flag)

!  event_clear() interface

type( event_t), intent( in) :: ev                          ! event to clear

type( thread_t), optional, intent( in) :: th               ! to check team membership

type( trace_t), optional, intent( inout) :: trace_v        ! trace actions

integer, optional, intent( out) :: flag                    ! status

! ----------------------------------------------------------------------

! event_clear() NT system calls

interface
   integer( 4) function SetEvent( dwhandle)
!DEC$ ATTRIBUTES DEFAULT :: SetEvent
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_SetEvent@4' :: SetEvent
      integer( 4) :: dwhandle
!DEC$ ATTRIBUTES VALUE :: dwhandle
   end function SetEvent

   integer( 4) function ResetEvent( hEvent)
!DEC$ ATTRIBUTES DEFAULT :: ResetEvent
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_ResetEvent@4' :: ResetEvent
      integer( 4) :: hEvent
!DEC$ ATTRIBUTES VALUE :: hEvent
   end function ResetEvent

   integer( 4) function GetLastError()
!DEC$ ATTRIBUTES DEFAULT :: GetLastError
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_GetLastError@0' :: GetLastError
   end function GetLastError
end interface

! **********************************************************************

!  event_clear() local

! ----------------------------------------------------------------------

!  return values

   integer :: win32_return                                 ! Win32 return value

!  informative and error messages

   character( len= *), parameter :: name_msg = 'event_clear(): '

   integer :: error_code                                   ! status flag
   character( len= name_length) :: error_msg               ! error text

! **********************************************************************

!  event_clear() steps:

!  1. call Win32 to clear event
!  2. update events array

! **********************************************************************

!  event_clear() text

! ----------------------------------------------------------------------

continue                                                   ! event_clear()

! ----------------------------------------------------------------------

!  check team membership

   th_arg: if( present( th) )then                          ! if team

      team_error: if( .not. teams( events( ev% id)% team)% list( th% id) )then

         error_code = fthread_error_team

         error_msg = 'not on team'

         goto 1                                            ! go process error

      endif team_error

   endif th_arg                                            ! if team

! ----------------------------------------------------------------------

   win32_return = ResetEvent( &                            ! clear event
                     events( ev% id)% handle)              ! event handle

   reset_error: if( win32_return /= win32_true )then       ! error if not true

      error_code = fthread_error_syscall

      error_msg = 'reset system call error'

      goto 1                                               ! go process error

   endif reset_error                                       ! error if not true

! ----------------------------------------------------------------------

!  update event array

   events( ev% id)% clears = events( ev% id)% clears + 1   ! count

! ----------------------------------------------------------------------

!  log success

   if( present( flag) ) flag = fthread_ok                  ! mark success

   trace_clear: if( present( trace_v) )then                ! if tracing

      call trace_msg( name_msg // 'cleared event ' // events( ev% id)% label, &
                      code= ev% id, trace_v= trace_v)

   endif trace_clear                                       ! if tracing

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! event_clear()

! ----------------------------------------------------------------------

!  hither upon error

 1 continue

   if( present( flag) ) flag = error_code                  ! set flag if possible

   trace_error: if( present( trace_v) )then                ! log error message if possible

      syserr: if( error_code == fthread_error_syscall )then

         win32_return = GetLastError()                     ! record Win32 error code

         call trace_msg( name_msg // error_msg, &
                         code= win32_return, trace_v= trace_v)

      else syserr

         call trace_msg( name_msg // error_msg, trace_v= trace_v)

      endif syserr

   endif trace_error                                       ! log error message if possible

! ----------------------------------------------------------------------

!  error exit

return                                                     ! event_clear()

!  event_clear()

! **********************************************************************

end subroutine event_clear

! **********************************************************************
! **********************************************************************

!  event_waitclear() observe an event

! **********************************************************************

subroutine event_waitclear( ev, th, trace_v, flag)

!  event_waitclear() interface

type( event_t), intent( in) :: ev                          ! event to waitclear

type( thread_t), optional, intent( in) :: th               ! to check team membership

type( trace_t), optional, intent( inout) :: trace_v        ! trace actions

integer, optional, intent( out) :: flag                    ! status

! ----------------------------------------------------------------------

! event_waitclear() NT system calls

interface
   integer( 4) function WaitForSingleObject( dwhandle, Mseconds)
!DEC$ ATTRIBUTES DEFAULT :: WaitForSingleObject
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_WaitForSingleObject@8' :: WaitForSingleObject
      integer( 4) :: dwhandle
!DEC$ ATTRIBUTES VALUE :: dwhandle
      integer( 4) :: Mseconds
!DEC$ ATTRIBUTES VALUE :: Mseconds
   end function WaitForSingleObject

   integer( 4) function ResetEvent( hEvent)
!DEC$ ATTRIBUTES DEFAULT :: ResetEvent
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_ResetEvent@4' :: ResetEvent
      integer( 4) :: hEvent
!DEC$ ATTRIBUTES VALUE :: hEvent
   end function ResetEvent

   integer( 4) function GetLastError()
!DEC$ ATTRIBUTES DEFAULT :: GetLastError
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_GetLastError@0' :: GetLastError
   end function GetLastError
end interface

! **********************************************************************

!  event_waitclear() local

! ----------------------------------------------------------------------

!  return values

   integer :: win32_return                                 ! Win32 return value

!  informative and error messages

   character( len= *), parameter :: name_msg = 'event_waitclear(): '

   integer :: error_code                                   ! status flag
   character( len= name_length) :: error_msg               ! error text

! **********************************************************************

!  event_waitclear() steps:

!  1. call Win32 to wait for event
!  2. call Win32 to clear event
!  3. update events array

! **********************************************************************

!  event_waitclear() text

! ----------------------------------------------------------------------

continue                                                   ! event_waitclear()

! ----------------------------------------------------------------------

!  check team membership

   th_arg: if( present( th) )then                          ! if team

      team_error: if( .not. teams( events( ev% id)% team)% list( th% id) )then

         error_code = fthread_error_team

         error_msg = 'not on team'

         goto 1                                            ! go process error

      endif team_error

   endif th_arg                                            ! if team

! ----------------------------------------------------------------------

!  wait for event

   win32_return = WaitForSingleObject( &                   ! wait for event
                     events( ev% id)% handle, &            ! event handle
                     win32_infinite)                       ! wait forever

   nt_wait_error: if( win32_return /= win32_wait_object_0 )then

      error_code = fthread_error_syscall

      error_msg = 'wait system call error'

      goto 1                                               ! go process error

   endif nt_wait_error                                     ! object 0 is event

! ----------------------------------------------------------------------

!  clear event

   win32_return = ResetEvent( &                            ! clear event
                     events( ev% id)% handle)              ! event handle

   nt_reset_error: if( win32_return /= win32_true )then    ! error if not true

      error_code = fthread_error_syscall

      error_msg = 'reset system call error'

      goto 1                                               ! go process error

   endif nt_reset_error                                    ! error if not true

! ----------------------------------------------------------------------

!  update events array

   events( ev% id)% waits = events( ev% id)% waits + 1     ! count

   events( ev% id)% clears = events( ev% id)% clears + 1   ! count

! ----------------------------------------------------------------------

!  log success

   if( present( flag) ) flag = fthread_ok                  ! mark success

   trace_waitclear: if( present( trace_v) )then            ! if tracing

      call trace_msg( name_msg // 'waitclear event ' // events( ev% id)% label, &
                      code= ev% id, trace_v= trace_v)

   endif trace_waitclear                                   ! if tracing

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! event_waitclear()

! ----------------------------------------------------------------------

!  hither upon error

 1 continue

   if( present( flag) ) flag = error_code                  ! set flag if possible

   trace_error: if( present( trace_v) )then                ! log error message if possible

      syserr: if( error_code == fthread_error_syscall )then

         win32_return = GetLastError()                     ! record Win32 error code

         call trace_msg( name_msg // error_msg, &
                         code= win32_return, trace_v= trace_v)

      else syserr

         call trace_msg( name_msg // error_msg, trace_v= trace_v)

      endif syserr

   endif trace_error                                       ! log error message if possible

! ----------------------------------------------------------------------

!  error exit

return                                                     ! event_waitclear()

!  event_waitclear()

! **********************************************************************

end subroutine event_waitclear

! **********************************************************************
! **********************************************************************

!  event_post() post an event

! **********************************************************************

subroutine event_post( ev, th, trace_v, flag)

!  event_post() interface

type( event_t), intent( in) :: ev                          ! event to post

type( thread_t), optional, intent( in) :: th               ! to check team membership

type( trace_t), optional, intent( inout) :: trace_v        ! trace actions

integer, optional, intent( out) :: flag                    ! status

! ----------------------------------------------------------------------

! event_post NT system calls

interface
   integer( 4) function SetEvent( dwhandle)
!DEC$ ATTRIBUTES DEFAULT :: SetEvent
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_SetEvent@4' :: SetEvent
      integer( 4) :: dwhandle
!DEC$ ATTRIBUTES VALUE :: dwhandle
   end function SetEvent

   integer( 4) function GetLastError()
!DEC$ ATTRIBUTES DEFAULT :: GetLastError
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_GetLastError@0' :: GetLastError
   end function GetLastError
end interface

! **********************************************************************

!  event_post() local

! ----------------------------------------------------------------------

!  return values

   integer :: win32_return                                 ! Win32 return value

!  informative and error messages

   character( len= *), parameter :: name_msg = 'event_post(): '

   integer :: error_code                                   ! status flag
   character( len= name_length) :: error_msg               ! error text

! **********************************************************************

!  event_post() steps:

! **********************************************************************

!  1. call Win32 to post event
!  2. update events array

! **********************************************************************

!  event_post() text

! ----------------------------------------------------------------------

continue                                                   ! event_post()

! ----------------------------------------------------------------------

!  check team membership

   th_arg: if( present( th) )then                          ! if team

      team_error: if( .not. teams( events( ev% id)% team)% list( th% id) )then

         error_code = fthread_error_team

         error_msg = 'not on team'

         goto 1                                            ! go process error

      endif team_error

   endif th_arg                                            ! if team

! ----------------------------------------------------------------------

   win32_return = SetEvent( &                              ! post event
                     events( ev% id)% handle)              ! event handle

   set_error: if( win32_return /= win32_true )then         ! error if not true

      error_code = fthread_error_syscall

      error_msg = 'set system call error'

      goto 1                                               ! go process error

   endif set_error                                         ! error if not true

! ----------------------------------------------------------------------

!  update events array

   events( ev% id)% posts = events( ev% id)% posts + 1     ! count

! ----------------------------------------------------------------------

!  log activity

   if( present( flag) ) flag = fthread_ok                  ! mark success

   trace_post: if( present( trace_v) )then                 ! if tracing

      call trace_msg( name_msg // 'posted event ' // events( ev% id)% label, &
                      code= ev% id, trace_v= trace_v)

   endif trace_post                                        ! if tracing

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! event_post()

! ----------------------------------------------------------------------

!  hither upon error

 1 continue

   if( present( flag) ) flag = error_code                  ! set flag if possible

   trace_error: if( present( trace_v) )then                ! log error message if possible

      syserr: if( error_code == fthread_error_syscall )then

         win32_return = GetLastError()                     ! record Win32 error code

         call trace_msg( name_msg // error_msg, &
                         code= win32_return, trace_v= trace_v)

      else syserr

         call trace_msg( name_msg // error_msg, trace_v= trace_v)

      endif syserr

   endif trace_error                                       ! log error message if possible

! ----------------------------------------------------------------------

!  error exit

return                                                     ! event_post()

!  event_post()

! **********************************************************************

end subroutine event_post

! **********************************************************************
! **********************************************************************

!  event_pulse() pulse an event

! **********************************************************************

subroutine event_pulse( ev, th, trace_v, flag)

!  event_pulse() interface

type( event_t), intent( in) :: ev                          ! event to pulse

type( thread_t), optional, intent( in) :: th               ! to check team membership

type( trace_t), optional, intent( inout) :: trace_v

integer, optional, intent( out) :: flag                    ! status

! ----------------------------------------------------------------------

! event_pulse() NT system calls

interface
   integer( 4) function PulseEvent( hEvent)
!DEC$ ATTRIBUTES DEFAULT :: PulseEvent
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_PulseEvent@4' :: PulseEvent
      integer( 4) :: hEvent
!DEC$ ATTRIBUTES VALUE :: hEvent
   end function PulseEvent

   integer( 4) function GetLastError()
!DEC$ ATTRIBUTES DEFAULT :: GetLastError
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_GetLastError@0' :: GetLastError
   end function GetLastError
end interface

! **********************************************************************

!  event_pulse() local

! ----------------------------------------------------------------------

!  return values

   integer :: win32_return                                 ! Win32 return value

!  informative and error messages

   character( len= *), parameter :: name_msg = 'event_pulse(): '

   integer :: error_code                                   ! status flag
   character( len= name_length) :: error_msg               ! error text

! **********************************************************************

!  event_pulse() steps:

!  1. call Win32 to pulse the event

! **********************************************************************

!  event_pulse() text

! ----------------------------------------------------------------------

continue                                                   ! event_pulse()

! ----------------------------------------------------------------------

!  check team membership

   th_arg: if( present( th) )then                          ! if team

      team_error: if( .not. teams( events( ev% id)% team)% list( th% id) )then

         error_code = fthread_error_team

         error_msg = 'not on team'

         goto 1                                            ! go process error

      endif team_error

   endif th_arg                                            ! if team

! ----------------------------------------------------------------------

!  post then clear event

   win32_return = PulseEvent( &                            ! pulse event
                     events( ev% id)% handle)              ! event handle

   pulse_error: if( win32_return /= win32_true )then       ! error if not true

      error_code = fthread_error_syscall

      error_msg = 'pulse system call error'

      goto 1                                               ! go process error

   endif pulse_error                                       ! error if not true

! ----------------------------------------------------------------------

!  update events array

   events( ev% id)% posts = events( ev% id)% posts + 1     ! count

   events( ev% id)% clears = events( ev% id)% clears + 1   ! count

! ----------------------------------------------------------------------

!  log success

   if( present( flag) ) flag = fthread_ok                  ! mark success

   trace_pulse: if( present( trace_v) )then                ! if tracing

      call trace_msg( name_msg // 'pulsed event ' // events( ev% id)% label, &
                      code= ev% id, trace_v= trace_v)

   endif trace_pulse                                       ! if tracing

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! event_pulse()

! ----------------------------------------------------------------------

!  hither upon error

 1 continue

   if( present( flag) ) flag = error_code                  ! set flag if possible

   trace_error: if( present( trace_v) )then                ! log error message if possible

      syserr: if( error_code == fthread_error_syscall )then

         win32_return = GetLastError()                     ! record Win32 error code

         call trace_msg( name_msg // error_msg, &
                         code= win32_return, trace_v= trace_v)

      else syserr

         call trace_msg( name_msg // error_msg, trace_v= trace_v)

      endif syserr

   endif trace_error                                       ! log error message if possible

! ----------------------------------------------------------------------

!  error exit

return                                                     ! event_pulse()

!  event_pulse()

! **********************************************************************

end subroutine event_pulse

! **********************************************************************
! **********************************************************************

!  event_id() return event id

! **********************************************************************

integer function event_id( ev)

!  event_id() interface

type( event_t), intent( in) :: ev                          ! event to id

! **********************************************************************

!  event_id() steps:

!  1. return event id

! **********************************************************************

!  event_id() text

! ----------------------------------------------------------------------

continue                                                   ! event_id()

! ----------------------------------------------------------------------

   event_id = ev% id                                       ! return event id

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! event_id()

!  event_id()

! **********************************************************************

end function event_id

! **********************************************************************
! **********************************************************************

! event_status() inquires about an event

! **********************************************************************

subroutine event_status( ev, name, waited, cleared, posted, &
                         trace_v, flag)

!  event_status() interface

type( event_t), intent( in) :: ev                          ! event to query

character( len= *), optional, intent( out) :: name         ! events name
integer, optional, intent( out) :: waited                  ! number of waits
integer, optional, intent( out) :: cleared                 ! number of clears
integer, optional, intent( out) :: posted                  ! number of posts

type( trace_t), optional, intent( inout) :: trace_v        ! trace actions

integer, optional, intent( out) :: flag                    ! status

! **********************************************************************

!  event_status() local

! ----------------------------------------------------------------------

!  informative and error messages

   character( len= *), parameter :: name_msg = 'event_status(): '

! **********************************************************************

! event_status() steps:

!  1. if request is present, return value

! **********************************************************************

!  event_status() text

! ----------------------------------------------------------------------

continue                                                   ! event_status()

! ----------------------------------------------------------------------

!  get waits

   wait_arg: if( present( waited) )then                    ! if want waits

      waited = events( ev% id)% waits                      ! return waits

   endif wait_arg                                          ! if want waits

! ----------------------------------------------------------------------

!  get clears

   clear_arg: if( present( cleared) )then                  ! if want clears

      cleared = events( ev% id)% clears                    ! return clears

   endif clear_arg                                         ! if want clears

! ----------------------------------------------------------------------

!  get posts

   post_arg: if( present( posted) )then                    ! if want postings

      posted = events( ev% id)% posts                      ! return postings

   endif post_arg                                          ! if want postings

! ----------------------------------------------------------------------

!  get name

   name_arg: if( present( name) )then                      ! if want name

      name = events( ev% id)% label                        ! return creation name

   endif name_arg                                          ! if want name

! ----------------------------------------------------------------------

!  log activity

   if( present( flag) ) flag = fthread_ok                  ! requested status

   trace_status: if( present( trace_v) )then               ! requested logging

      call trace_msg( name_msg // 'query event ' // events( ev% id)% label, &
                      code= ev% id, trace_v= trace_v)

   endif trace_status                                      ! requested logging

! ----------------------------------------------------------------------

! normal exit

return                                                     ! event_status()

!  event_status()

! **********************************************************************

end subroutine event_status

! **********************************************************************
! **********************************************************************

!  ### public mutex procedures

!  these procedures init, delete and synchronize via mutexs

! **********************************************************************

!  mutex_init() initializes a mutex

! **********************************************************************

subroutine mutex_init( m, tm, name, trace_v, flag)

!  mutex_init() interface

type( mutex_t), intent( out) :: m                          ! mutex to init

type( team_t), optional, intent( in) :: tm                 ! team to use mutex

character( len= *), optional, intent( in) :: name          ! name mutex

type( trace_t), optional, intent( inout) :: trace_v        ! trace actions

integer, optional, intent( out) :: flag                    ! status

! ----------------------------------------------------------------------

! mutex_init() NT system calls

interface
   subroutine InitializeCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: InitializeCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_InitializeCriticalSection@4' ::  InitializeCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine InitializeCriticalSection
end interface

! **********************************************************************

!  mutex_init() local

! ----------------------------------------------------------------------

!  informative and error messages

   character( len= *), parameter :: name_msg = 'mutex_init(): '

   integer :: error_code                                   ! status flag
   character( len= name_length) :: error_msg               ! error text

! **********************************************************************

!  mutex_init() steps:

!  1. check number of mutexs
!  2. call Win32 to init mutex
!  3. update user's mutex variable
!  4. update mutexs array

! **********************************************************************

!  mutex_init() text

! ----------------------------------------------------------------------

continue                                                   ! mutex_init()

! ----------------------------------------------------------------------

!  check number of mutexs

   too_many: if( this_mutex >= max_mutex_id )then          ! if exceeds mutexs array

      error_code = fthread_error_number

      error_msg = 'too many mutexs'

      goto 1                                               ! go process error

   endif too_many                                          ! if exceeds mutexs array

! ----------------------------------------------------------------------

!  point to next mutex

   this_mutex = this_mutex + 1                             ! next

! ----------------------------------------------------------------------

!  call Win32 to get mutex handle

   call InitializeCriticalSection( &                       ! init mutex
                 loc( mutexs( this_mutex)% cs) )           ! mutex

! ----------------------------------------------------------------------

!  update user's mutex variable

   m% id = this_mutex                                      ! set user variable

! ----------------------------------------------------------------------

!  update mutexs array

   mutexs( this_mutex)% locks = 0                          ! none yet

   mutexs( this_mutex)% unlocks = 0                        ! none yet

! ----------------------------------------------------------------------

!  set up team

   tm_arg: if( present( tm) )then                          ! if on team

      mutexs( this_mutex)% team = tm% id                   ! use this team

   else tm_arg                                             ! if on team

      mutexs( this_mutex)% team = all_workers_id           ! use default team

   endif tm_arg                                            ! if on team

! ----------------------------------------------------------------------

!  set mutex label

   name_arg: if( present( name) )then                      ! name specified

      mutexs( this_mutex)% label = name                    ! use it

   endif name_arg                                          ! name specified

! ----------------------------------------------------------------------

!  log success

   if( present( flag) ) flag = fthread_ok                  ! mark success

   trace_init: if( present( trace_v) )then                 ! if tracing

      call trace_msg( name_msg // 'initialized mutex ' // mutexs( m% id)% label, &
                      code= m% id, trace_v= trace_v)

   endif trace_init                                        ! if tracing

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! mutex_init()

! ----------------------------------------------------------------------

!  hither upon error

 1 continue

   if( present( flag) ) flag = error_code                  ! set flag if possible

   trace_error: if( present( trace_v) )then                ! log error message if possible

      call trace_msg( name_msg // error_msg, trace_v= trace_v)

   endif trace_error                                       ! log error message if possible

! ----------------------------------------------------------------------

!  error exit

return                                                     ! mutex_init()

!  mutex_init()

! **********************************************************************

end subroutine mutex_init

! **********************************************************************
! **********************************************************************

!  mutex_del() ends a mutex

! **********************************************************************

subroutine mutex_del( m, trace_v, flag)

!  mutex_del() interface

type( mutex_t), intent( inout) :: m                        ! mutex to delete

type( trace_t), optional, intent( inout) :: trace_v        ! trace actions

integer, optional, intent( out) :: flag                    ! status

! ----------------------------------------------------------------------

!  mutex_del() NT system calls

interface
   subroutine DeleteCriticalSection (object)
!DEC$ ATTRIBUTES DEFAULT :: DeleteCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_DeleteCriticalSection@4' ::  DeleteCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine DeleteCriticalSection
end interface

! **********************************************************************

!  mutex_del() local

! ----------------------------------------------------------------------

!  informative and error messages

   character( len= *), parameter :: name_msg = 'mutex_del(): '

! **********************************************************************

!  mutex_del() steps:

!  1. call Win32 to close handle

! **********************************************************************

!  mutex_del() text

! ----------------------------------------------------------------------

continue                                                   ! mutex_del()

! ----------------------------------------------------------------------

!  call Win32 to close mutex handle

   call DeleteCriticalSection( &                           ! delete mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  zero out cs

   mutexs( m% id)% cs = 0                                  ! no more

! ----------------------------------------------------------------------

!  log success

   if( present( flag) ) flag = fthread_ok                  ! mark success

   trace_del: if( present( trace_v) )then                  ! if tracing

      call trace_msg( name_msg // 'deleted mutex', &
                      code= m% id, trace_v= trace_v)

   endif trace_del                                         ! if tracing

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! mutex_del()

!  mutex_del()

! **********************************************************************

end subroutine mutex_del

! **********************************************************************
! **********************************************************************

!  mutex_lock() lock a mutex

! **********************************************************************

subroutine mutex_lock( m, th, trace_v, flag)

!  mutex_lock() interface

type( mutex_t), intent( inout) :: m                        ! mutex to lock

type( thread_t), optional, intent( in) :: th               ! to check for team membership

type( trace_t), optional, intent( inout) :: trace_v        ! trace actions

integer, optional, intent( out) :: flag                    ! status

! ----------------------------------------------------------------------

! mutex_lock() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection
end interface

! **********************************************************************

!  mutex_lock() local

! ----------------------------------------------------------------------

!  informative and error messages

   character( len= *), parameter :: name_msg = 'mutex_lock(): '

   integer :: error_code                                   ! status flag
   character( len= name_length) :: error_msg               ! error text

! **********************************************************************

!  mutex_lock() steps:

!  1. wait for mutex
!  2. update mutexs array

! **********************************************************************

!  mutex_lock()

! ----------------------------------------------------------------------

continue                                                   ! mutex_lock()

! ----------------------------------------------------------------------

!  check team membership

   th_arg: if( present( th) )then                          ! if team

      team_error: if( .not. teams( mutexs( m% id)% team)% list( th% id) )then

         error_code = fthread_error_team

         error_msg = 'not on team'

         goto 1                                            ! go process error

      endif team_error

   endif th_arg                                            ! if team

! ----------------------------------------------------------------------

!  wait for mutex

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  update mutexs array

   mutexs( m% id)% locks = mutexs( m% id)% locks + 1       ! count

! ----------------------------------------------------------------------

!  log success

   if( present( flag) ) flag = fthread_ok                  ! mark success

   trace_lock: if( present( trace_v) )then                 ! if tracing

      call trace_msg( name_msg // 'locked mutex ' // mutexs( m% id)% label, &
                      code= m% id, trace_v= trace_v)

   endif trace_lock                                        ! if tracing

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! mutex_lock()

! ----------------------------------------------------------------------

!  hither upon error

 1 continue

   if( present( flag) ) flag = error_code                  ! set flag if possible

   trace_error: if( present( trace_v) )then                ! log error message if possible

      call trace_msg( name_msg // error_msg, trace_v= trace_v)

   endif trace_error                                       ! log error message if possible

! ----------------------------------------------------------------------

!  error exit

return                                                     ! mutex_lock()

!  mutex_lock()

! **********************************************************************

end subroutine mutex_lock

! **********************************************************************
! **********************************************************************

!  mutex_try() immediate return w/ or w/o mutex

! **********************************************************************

logical function mutex_try( m, th, trace_v, flag)

!  mutex_try() interface

type( mutex_t), intent( in) :: m                           ! mutex to try

type( thread_t), optional, intent( in) :: th               ! to check team membership

type( trace_t), optional, intent( inout) :: trace_v        ! trace actions

integer, optional, intent( out) :: flag                    ! status

! ----------------------------------------------------------------------

! mutex_try() Win32 system calls

interface
   integer( 4) function TryEnterCriticalSection( &
      lpCriticalSection)
!DEC$ ATTRIBUTES DEFAULT :: TryEnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS:'_TryEnterCriticalSection@4' :: TryEnterCriticalSection
      integer( 4) :: lpCriticalSection           ! LPCRITICAL_SECTION lpCriticalSection
   end function TryEnterCriticalSection
end interface

! **********************************************************************

!  mutex_try() local

! ----------------------------------------------------------------------

!  return values

   integer :: win32_return                                 ! Win32 return value

!  informative and error messages

   character( len= *), parameter :: name_msg = 'mutex_try(): '

   integer :: error_code                                   ! status flag
   character( len= name_length) :: error_msg               ! error text

! **********************************************************************

!  mutex_try() steps:

!  1. call Win32 to determine state of mutex
!  2. update mutexs array

! **********************************************************************

!  mutex_try() text

! ----------------------------------------------------------------------

continue                                                   ! mutex_try()

! ----------------------------------------------------------------------

!  check team membership

   th_arg: if( present( th) )then                          ! if team

      team_error: if( .not. teams( mutexs( m% id)% team)% list( th% id) )then

         error_code = fthread_error_team

         error_msg = 'not on team'

         goto 1                                            ! go process error

      endif team_error

   endif th_arg                                            ! if team

! ----------------------------------------------------------------------

   win32_return = TryEnterCriticalSection( &               ! test mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   test: if( win32_return == win32_true )then              ! got lock if true

      mutexs( m% id)% locks = mutexs( m% id)% locks + 1    ! count

      mutex_try = .true.                                   ! return

   else test                                               ! got lock if true

      mutex_try = .false.                                  ! return

   endif test                                              ! got lock if true

! ----------------------------------------------------------------------

!  log success

   if( present( flag) ) flag = fthread_ok                  ! mark success

   trace_try: if( present( trace_v) )then                  ! if tracing

      call trace_msg( name_msg // 'tried mutex ' // mutexs( m% id)% label, &
                      code= m% id, trace_v= trace_v)

   endif trace_try                                         ! if tracing

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! mutex_try()

! ----------------------------------------------------------------------

!  hither upon error

 1 continue

   mutex_try = .false.                                     ! not on team, didn't get mutex

   if( present( flag) ) flag = error_code                  ! set flag if possible

   trace_error: if( present( trace_v) )then                ! log error message if possible

      call trace_msg( name_msg // error_msg, trace_v= trace_v)

   endif trace_error                                       ! log error message if possible

! ----------------------------------------------------------------------

!  error exit

return                                                     ! mutex_try()

!  mutex_try()

! **********************************************************************

end function mutex_try

! **********************************************************************
! **********************************************************************

!  mutex_unlock() unlock a mutex

! **********************************************************************

subroutine mutex_unlock( m, th, trace_v, flag)

!  mutex_unlock() interface

type( mutex_t), intent( inout) :: m                        ! mutex to unlock

type( thread_t), optional, intent( in) :: th               ! to check team membership

type( trace_t), optional, intent( inout) :: trace_v        ! trace actions

integer, optional, intent( out) :: flag                    ! status

! ----------------------------------------------------------------------

! mutex_unlock() NT system calls

interface
   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  mutex_unlock() local

! ----------------------------------------------------------------------

!  informative and error messages

   character( len= *), parameter :: name_msg = 'mutex_unlock(): '

   integer :: error_code                                   ! status flag
   character( len= name_length) :: error_msg               ! error text

! **********************************************************************

!  mutex_unlock() steps:

!  1. call Win32 to unlock mutex
!  2. update mutexs array

! **********************************************************************

!  mutex_unlock() text

! ----------------------------------------------------------------------

continue                                                   ! mutex_unlock()

! ----------------------------------------------------------------------

!  check team membership

   th_arg: if( present( th) )then                          ! if team

      team_error: if( .not. teams( mutexs( m% id)% team)% list( th% id) )then

         error_code = fthread_error_team

         error_msg = 'not on team'

         goto 1                                            ! go process error

      endif team_error

   endif th_arg                                            ! if team

! ----------------------------------------------------------------------

!  call Win32 to unlock mutex

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  update mutexs array

   mutexs( m% id)% unlocks = mutexs( m% id)% unlocks + 1   ! count

! ----------------------------------------------------------------------

!  log success

   if( present( flag) ) flag = fthread_ok                  ! mark success

   trace_unlock: if( present( trace_v) )then               ! if tracing

      call trace_msg( name_msg // 'unlocked mutex ' // mutexs( m% id)% label, &
                      code= m% id, trace_v= trace_v)

   endif trace_unlock                                      ! if tracing

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! mutex_unlock()

! ----------------------------------------------------------------------

!  hither upon error

 1 continue

   if( present( flag) ) flag = error_code                  ! set flag if possible

   trace_error: if( present( trace_v) )then                ! log error message if possible

      call trace_msg( name_msg // error_msg, trace_v= trace_v)

   endif trace_error                                       ! log error message if possible

! ----------------------------------------------------------------------

!  error exit

return                                                     ! mutex_unlock()

!  mutex_unlock()

! **********************************************************************

end subroutine mutex_unlock

! **********************************************************************
! **********************************************************************

!  mutex_id() return mutex id

! **********************************************************************

integer function mutex_id( m)

!  mutex_id() interface

type( mutex_t), intent( in) :: m

! **********************************************************************

!  mutex_id() steps:

!  1. return mutex id

! **********************************************************************

!  mutex_id() text

! ----------------------------------------------------------------------

continue                                                   ! mutex_id()

! ----------------------------------------------------------------------

!  return mutex id

   mutex_id = m% id

! ----------------------------------------------------------------------

return                                                     ! mutex_id()

!  mutex_id()

! **********************************************************************

end function mutex_id

! **********************************************************************
! **********************************************************************

! mutex_status() inquires about an mutex

! **********************************************************************

subroutine mutex_status( m, name, locked, unlocked, &
                         trace_v, flag)

!  mutex_status() interface

type( mutex_t), intent( in) :: m                           ! mutex to query

character( len= *), optional, intent( out) :: name
integer, optional, intent( out) :: locked                  ! number of locks
integer, optional, intent( out) :: unlocked                ! number of unlocks

type( trace_t), optional, intent( inout) :: trace_v        ! trace actions

integer, optional, intent( out) :: flag                    ! status

! **********************************************************************

!  mutex_status() local

! ----------------------------------------------------------------------

   character( len= *), parameter :: name_msg = 'mutex_status(): '

! **********************************************************************

! mutex_status() steps:

!  1. if request is present, return value

! **********************************************************************

!  mutex_status() text

! ----------------------------------------------------------------------

continue                                                   ! mutex_status()

! ----------------------------------------------------------------------

!  get locks

   lock_arg: if( present( locked) )then                    ! if want waits

      locked = mutexs( m% id)% locks                       ! return waits

   endif lock_arg                                          ! if want waits

! ----------------------------------------------------------------------

!  get unlocks

   unlock_arg: if( present( unlocked) )then                ! if want unlocks

      unlocked = mutexs( m% id)% unlocks                   ! return unlocks

   endif unlock_arg                                        ! if want unlocks

! ----------------------------------------------------------------------

!  get name

   name_arg: if( present( name) )then                      ! if want name

      name = mutexs( m% id)% label                         ! return mutex name

   endif name_arg                                          ! if want name

! ----------------------------------------------------------------------

!  log success

   if( present( flag) ) flag = fthread_ok                  ! requested status

   trace_status: if( present( trace_v) )then               ! requested logging

      call trace_msg( name_msg // 'query mutex ' // mutexs( m% id)% label, &
                      code= m% id, trace_v= trace_v)

   endif trace_status                                      ! requested logging

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! mutex_status()

!  mutex_status()

! **********************************************************************

end subroutine mutex_status

! **********************************************************************
! **********************************************************************

!  ### private critical operation procedures

!  these procedures perform atomic operations, access via public generic

! **********************************************************************

!  byte_critical_add()

! **********************************************************************

subroutine byte_critical_add( acc, add, m)

!  byte_critical_add() interface

integer( kind= byte_k), intent( inout) :: acc              ! accumulator

integer( kind= byte_k), intent( in) :: add                 ! addend

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! byte_critical_add() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  byte_critical_add() steps:

!  1. lock mutex
!  2. add
!  3. unlock mutex

! **********************************************************************

!  byte_critical_add() text

! ----------------------------------------------------------------------

continue                                                   ! critical_add()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   acc = acc + add                                         ! add

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_add()

!  byte_critical_add()

! **********************************************************************

end subroutine byte_critical_add

! **********************************************************************
! **********************************************************************

!  short_critical_add()

! **********************************************************************

subroutine short_critical_add( acc, add, m)

!  short_critical_add() interface

integer( kind= short_k), intent( inout) :: acc             ! accumulator

integer( kind= short_k), intent( in) :: add                ! addend

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! short_critical_add() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  short_critical_add() steps:

!  1. lock mutex
!  2. add
!  3. unlock mutex

! **********************************************************************

!  short_critical_add() text

! ----------------------------------------------------------------------

continue                                                   ! critical_add()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   acc = acc + add                                         ! add

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_add()

!  short_critical_add()

! **********************************************************************

end subroutine short_critical_add

! **********************************************************************
! **********************************************************************

!  int_critical_add()

! **********************************************************************

subroutine int_critical_add( acc, add, m)

!  int_critical_add() interface

integer( kind= int_k), intent( inout) :: acc               ! accumulator

integer( kind= int_k), intent( in) :: add                  ! addend

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! int_critical_add() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  int_critical_add() steps:

!  1. lock mutex
!  2. add
!  3. unlock mutex

! **********************************************************************

!  int_critical_add() text

! ----------------------------------------------------------------------

continue                                                   ! critical_add()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   acc = acc + add                                         ! add

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_add()

!  int_critical_add()

! **********************************************************************

end subroutine int_critical_add

! **********************************************************************
! **********************************************************************
!  this compiler doesn't support integer kind long_k
! **********************************************************************
! **********************************************************************

!  single_critical_add()

! **********************************************************************

subroutine single_critical_add( acc, add, m)

!  single_critical_add() interface

real( kind= single_k), intent( inout) :: acc               ! accumulator

real( kind= single_k), intent( in) :: add                  ! addend

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! single_critical_add() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  single_critical_add() steps:

!  1. lock mutex
!  2. add
!  3. unlock mutex

! **********************************************************************

!  single_critical_add() text

! ----------------------------------------------------------------------

continue                                                   ! critical_add()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   acc = acc + add                                         ! add

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_add()

!  single_critical_add()

! **********************************************************************

end subroutine single_critical_add

! **********************************************************************
! **********************************************************************

!  double_critical_add()

! **********************************************************************

subroutine double_critical_add( acc, add, m)

!  double_critical_add() interface

real( kind= double_k), intent( inout) :: acc               ! accumulator

real( kind = double_k), intent( in) :: add                 ! addend

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! double_critical_add() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  double_critical_add() steps:

!  1. lock mutex
!  2. add
!  3. unlock mutex

! **********************************************************************

!  double_critical_add() text

! ----------------------------------------------------------------------

continue                                                   ! critical_add()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   acc = acc + add                                         ! add

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_add()

!  double_critical_add()

! **********************************************************************

end subroutine double_critical_add

! **********************************************************************
! **********************************************************************
!  this compiler doesn't support real kind quad_k
! **********************************************************************
! **********************************************************************

!  single_complex_critical_add()

! **********************************************************************

subroutine single_complex_critical_add( acc, add, m)

!  single_complex_critical_add() interface

complex( kind= single_k), intent( inout) :: acc            ! accumulator

complex( kind= single_k), intent( in) :: add               ! addend

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! single_complex_critical_add() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  single_complex_critical_add() steps:

!  1. lock mutex
!  2. add
!  3. unlock mutex

! **********************************************************************

!  single_complex_critical_add() text

! ----------------------------------------------------------------------

continue                                                   ! critical_add()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   acc = acc + add                                         ! add

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_add()

!  single_complex_critical_add()

! **********************************************************************

end subroutine single_complex_critical_add

! **********************************************************************
! **********************************************************************

!  double_complex_critical_add()

! **********************************************************************

subroutine double_complex_critical_add( acc, add, m)

!  double_complex_critical_add() interface

complex( kind= double_k), intent( inout) :: acc            ! accumulator

complex( kind= double_k), intent( in) :: add               ! addend

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! double_complex_critical_add() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  double_complex_critical_add() steps:

!  1. lock mutex
!  2. add
!  3. unlock mutex

! **********************************************************************

!  double_complex_critical_add() text

! ----------------------------------------------------------------------

continue                                                   ! critical_add()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   acc = acc + add                                         ! add

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_add()

!  double_complex_critical_add()

! **********************************************************************

end subroutine double_complex_critical_add

! **********************************************************************
! **********************************************************************
!  this compiler doesn't support real kind quad_k
! **********************************************************************
! **********************************************************************

!  byte_critical_mul()

! **********************************************************************

subroutine byte_critical_mul( prod, mul, m)

!  byte_critical_mul() interface

integer( kind= byte_k), intent( inout) :: prod             ! product

integer( kind= byte_k), intent( in) :: mul                 ! multiplicand

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! byte_critical_mul() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  byte_critical_mul() steps:

!  1. lock mutex
!  2. mul
!  3. unlock mutex

! **********************************************************************

!  byte_critical_mul() text

! ----------------------------------------------------------------------

continue                                                   ! critical_mul()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   prod = prod * mul                                       ! mul

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_mul()

!  byte_critical_mul()

! **********************************************************************

end subroutine byte_critical_mul

! **********************************************************************
! **********************************************************************

!  short_critical_mul()

! **********************************************************************

subroutine short_critical_mul( prod, mul, m)

!  short_critical_mul() interface

integer( kind= short_k), intent( inout) :: prod            ! product

integer( kind= short_k), intent( in) :: mul                ! multiplicand

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! short_critical_mul() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  short_critical_mul() steps:

!  1. lock mutex
!  2. mul
!  3. unlock mutex

! **********************************************************************

!  short_critical_mul() text

! ----------------------------------------------------------------------

continue                                                   ! critical_mul()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   prod = prod * mul                                       ! mul

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_mul()

!  short_critical_mul()

! **********************************************************************

end subroutine short_critical_mul

! **********************************************************************
! **********************************************************************

!  int_critical_mul()

! **********************************************************************

subroutine int_critical_mul( prod, mul, m)

!  int_critical_mul() interface

integer( kind= int_k), intent( inout) :: prod              ! product

integer( kind= int_k), intent( in) :: mul                  ! multiplicand

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! int_critical_mul() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  int_critical_mul() steps:

!  1. lock mutex
!  2. mul
!  3. unlock mutex

! **********************************************************************

!  int_critical_mul() text

! ----------------------------------------------------------------------

continue                                                   ! critical_mul()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   prod = prod * mul                                       ! mul

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_mul()

!  int_critical_mul()

! **********************************************************************

end subroutine int_critical_mul

! **********************************************************************
! **********************************************************************
!  this compiler doesn't support integer kind long_k
! **********************************************************************
! **********************************************************************

!  single_critical_mul()

! **********************************************************************

subroutine single_critical_mul( prod, mul, m)

!  single_critical_mul() interface

real( kind= single_k), intent( inout) :: prod              ! product

real( kind= single_k), intent( in) :: mul                  ! multiplicand

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! single_critical_mul() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  single_critical_mul() steps:

!  1. lock mutex
!  2. multiply
!  3. unlock mutex

! **********************************************************************

!  single_critical_mul() text

! ----------------------------------------------------------------------

continue                                                   ! critical_mul()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   prod = prod * mul                                       ! multiply

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_mul()

!  single_critical_mul()

! **********************************************************************

end subroutine single_critical_mul

! **********************************************************************
! **********************************************************************

!  double_critical_mul()

! **********************************************************************

subroutine double_critical_mul( prod, mul, m)

!  double_critical_mul() interface

real( kind= double_k), intent( inout) :: prod              ! product

real( kind= double_k), intent( in) :: mul                  ! multiplicand

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! double_critical_mul() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  double_critical_mul() steps:

!  1. lock mutex
!  2. multiply
!  3. unlock mutex

! **********************************************************************

!  double_critical_mul() text

! ----------------------------------------------------------------------

continue                                                   ! critical_mul()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   prod = prod * mul                                       ! multiply

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_mul()

!  double_critical_mul()

! **********************************************************************

end subroutine double_critical_mul

! **********************************************************************
! **********************************************************************
!  this compiler doesn't support real kind quad_k
! **********************************************************************
! **********************************************************************

!  single_complex_critical_mul()

! **********************************************************************

subroutine single_complex_critical_mul( prod, mul, m)

!  single_complex_critical_mul() interface

complex( kind= single_k), intent( inout) :: prod           ! product

complex( kind= single_k), intent( in) :: mul               ! multiplicand

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! single_complex_critical_mul() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  single_complex_critical_mul() steps:

!  1. lock mutex
!  2. multiply
!  3. unlock mutex

! **********************************************************************

!  single_complex_critical_mul() text

! ----------------------------------------------------------------------

continue                                                   ! critical_mul()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   prod = prod * mul                                       ! multiply

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_mul()

!  single_complex_critical_mul()

! **********************************************************************

end subroutine single_complex_critical_mul

! **********************************************************************
! **********************************************************************

!  double_complex_critical_mul()

! **********************************************************************

subroutine double_complex_critical_mul( prod, mul, m)

!  double_complex_critical_mul() interface

complex( kind= double_k), intent( inout) :: prod           ! product

complex( kind= double_k), intent( in) :: mul               ! multiplicand

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! double_complex_critical_mul() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  double_complex_critical_mul() steps:

!  1. lock mutex
!  2. multiply
!  3. unlock mutex

! **********************************************************************

!  double_complex_critical_mul() text

! ----------------------------------------------------------------------

continue                                                   ! critical_mul()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   prod = prod * mul                                       ! multiply

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_mul()

!  double_complex_critical_mul()

! **********************************************************************

end subroutine double_complex_critical_mul

! **********************************************************************
! **********************************************************************
!  this compiler doesn't support real kind quad_k
! **********************************************************************
! **********************************************************************

!  critical_inc()

! **********************************************************************

subroutine critical_inc( i)

!  critical_inc() interface

integer( kind= int_k), intent( inout) :: i                 ! to be incremented

! ----------------------------------------------------------------------

! critical_inc() Win32 system calls

interface                                                  !lib=kernel32.lib
   integer( 4) function  InterlockedIncrement( lpAddend)
!DEC$ ATTRIBUTES DEFAULT :: InterlockedIncrement
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_InterlockedIncrement@4' :: InterlockedIncrement
      integer( 4) :: lpAddend
   end function InterlockedIncrement
end interface

! **********************************************************************

!  critical_inc() local

! ----------------------------------------------------------------------

!  return value

   integer :: inc                                          ! meaningless

! **********************************************************************

!  critical_inc() steps:

!  1. increment

! **********************************************************************

!  critical_inc() text

! ----------------------------------------------------------------------

continue                                                   ! critical_inc()

! ----------------------------------------------------------------------

   inc = InterlockedIncrement( loc( i) )

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_inc()

!  critical_inc()

! **********************************************************************

end subroutine critical_inc

! **********************************************************************
! **********************************************************************

!  critical_dec()

! **********************************************************************

subroutine critical_dec( i)

!  critical_dec() interface

integer( kind= int_k), intent( inout) :: i                 ! to be decremented

! ----------------------------------------------------------------------

! critical_dec() Win32 system calls

interface                                                  !lib=kernel32.lib
   integer( 4) function  InterlockedDecrement( lpAddend)
!DEC$ ATTRIBUTES DEFAULT :: InterlockedDecrement
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_InterlockedDecrement@4' :: InterlockedDecrement
      integer( 4) :: lpAddend
   end function InterlockedDecrement
end interface

! **********************************************************************

!  critical_dec() local

! ----------------------------------------------------------------------

!  return value

   integer :: inc                                          ! meaningless

! **********************************************************************

!  critical_dec() steps:

!  1. decrement

! **********************************************************************

!  critical_dec() text

! ----------------------------------------------------------------------

continue                                                   ! critical_dec()

! ----------------------------------------------------------------------

   inc = InterlockedDecrement( loc( i) )

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_dec()

!  critical_dec()

! **********************************************************************

end subroutine critical_dec

! **********************************************************************
! **********************************************************************

!  byte_critical_and()

! **********************************************************************

subroutine byte_critical_and( acc, i, m)

!  byte_critical_and() interface

integer( kind= byte_k), intent( inout) :: acc              ! accumulator

integer( kind= byte_k), intent( in) :: i                   ! operand

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! byte_critical_and() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  byte_critical_and() steps:

!  1. lock mutex
!  2. and
!  3. unlock mutex

! **********************************************************************

!  byte_critical_and() text

! ----------------------------------------------------------------------

continue                                                   ! critical_and()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   acc = iand( acc, i)                                     ! and

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_and()

!  byte_critical_and()

! **********************************************************************

end subroutine byte_critical_and

! **********************************************************************
! **********************************************************************

!  short_critical_and()

! **********************************************************************

subroutine short_critical_and( acc, i, m)

!  short_critical_and() interface

integer( kind= short_k), intent( inout) :: acc             ! accumulator

integer( kind= short_k), intent( in) :: i                  ! operand

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! short_critical_and() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  short_critical_and() steps:

!  1. lock mutex
!  2. and
!  3. unlock mutex

! **********************************************************************

!  short_critical_and() text

! ----------------------------------------------------------------------

continue                                                   ! critical_and()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   acc = iand( acc, i)                                     ! and

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_and()

!  short_critical_and()

! **********************************************************************

end subroutine short_critical_and

! **********************************************************************
! **********************************************************************

!  int_critical_and()

! **********************************************************************

subroutine int_critical_and( acc, i, m)

!  int_critical_and() interface

integer( kind= int_k), intent( inout) :: acc               ! accumulator

integer( kind= int_k), intent( in) :: i                    ! operand

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! int_critical_and() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  int_critical_and() steps:

!  1. lock mutex
!  2. and
!  3. unlock mutex

! **********************************************************************

!  int_critical_and() text

! ----------------------------------------------------------------------

continue                                                   ! critical_and()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   acc = iand( acc, i)                                     ! and

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_and()

!  int_critical_and()

! **********************************************************************

end subroutine int_critical_and

! **********************************************************************
! **********************************************************************
!  this compiler doesn't support integer kind long_k
! **********************************************************************
! **********************************************************************

!  l_byte_critical_and()

! **********************************************************************

subroutine l_byte_critical_and( acc, l, m)

!  l_byte_critical_and() interface

logical( kind= l_byte_k), intent( inout) :: acc            ! accumulator

logical( kind= l_byte_k), intent( in) :: l                 ! operand

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! l_byte_critical_and() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  l_byte_critical_and() steps:

!  1. lock mutex
!  2. and
!  3. unlock mutex

! **********************************************************************

!  l_byte_critical_and() text

! ----------------------------------------------------------------------

continue                                                   ! critical_and()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   acc = acc .and. l                                       ! and

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_and()

!  l_byte_critical_and()

! **********************************************************************

end subroutine l_byte_critical_and

! **********************************************************************
! **********************************************************************

!  l_short_critical_and()

! **********************************************************************

subroutine l_short_critical_and( acc, l, m)

!  l_short_critical_and() interface

logical( kind= l_short_k), intent( inout) :: acc           ! accumulator

logical( kind= l_short_k), intent( in) :: l                ! operand

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! l_short_critical_and() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  l_short_critical_and() steps:

!  1. lock mutex
!  2. and
!  3. unlock mutex

! **********************************************************************

!  l_short_critical_and() text

! ----------------------------------------------------------------------

continue                                                   ! critical_and()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock and
                loc( mutexs( m% id)% cs) )

   acc = acc .and. l                                       ! and

   call LeaveCriticalSection( &                            ! unlock and
                loc( mutexs( m% id)% cs) )

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_and()

!  l_short_critical_and()

! **********************************************************************

end subroutine l_short_critical_and

! **********************************************************************
! **********************************************************************

!  l_int_critical_and()

! **********************************************************************

subroutine l_int_critical_and( acc, l, m)

!  l_int_critical_and() interface

logical( kind= l_int_k), intent( inout) :: acc             ! accumulator

logical( kind= l_int_k), intent( in) :: l                  ! operand

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! l_int_critical_and() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  l_int_critical_and() steps:

!  1. lock mutex
!  2. and
!  3. unlock mutex

! **********************************************************************

!  l_int_critical_and() text

! ----------------------------------------------------------------------

continue                                                   ! critical_and()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   acc = acc .and. l                                       ! and

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_and()

!  l_int_critical_and()

! **********************************************************************

end subroutine l_int_critical_and

! **********************************************************************
! **********************************************************************

!  byte_critical_or()

! **********************************************************************

subroutine byte_critical_or( acc, i, m)

!  byte_critical_or() interface

integer( kind= byte_k), intent( inout) :: acc              ! accumulator

integer( kind= byte_k), intent( in) :: i                   ! operand

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! byte_critical_or() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  byte_critical_or() steps:

!  1. lock mutex
!  2. or
!  3. unlock mutex

! **********************************************************************

!  byte_critical_or() text

! ----------------------------------------------------------------------

continue                                                   ! critical_or()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   acc = ior( acc, i)                                      ! or

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_or()

!  byte_critical_or()

! **********************************************************************

end subroutine byte_critical_or

! **********************************************************************
! **********************************************************************

!  short_critical_or()

! **********************************************************************

subroutine short_critical_or( acc, i, m)

!  short_critical_or() interface

integer( kind= short_k), intent( inout) :: acc             ! accumulator

integer( kind= short_k), intent( in) :: i                  ! operand

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! short_critical_or() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  short_critical_or() steps:

!  1. lock mutex
!  2. or
!  3. unlock mutex

! **********************************************************************

!  short_critical_or() text

! ----------------------------------------------------------------------

continue                                                   ! critical_or()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   acc = ior( acc, i)                                      ! or

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_or()

!  short_critical_or()

! **********************************************************************

end subroutine short_critical_or

! **********************************************************************
! **********************************************************************

!  int_critical_or()

! **********************************************************************

subroutine int_critical_or( acc, i, m)

!  int_critical_or() interface

integer( kind= int_k), intent( inout) :: acc               ! accumulator

integer( kind= int_k), intent( in) :: i                    ! operand

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! int_critical_or() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  int_critical_or() steps:

!  1. lock mutex
!  2. or
!  3. unlock mutex

! **********************************************************************

!  int_critical_or() text

! ----------------------------------------------------------------------

continue                                                   ! critical_or()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   acc = ior( acc, i)                                      ! or

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_or()

!  int_critical_or()

! **********************************************************************

end subroutine int_critical_or

! **********************************************************************
! **********************************************************************
!  this compiler doesn't support integer kind long_k
! **********************************************************************
! **********************************************************************

!  l_byte_critical_or()

! **********************************************************************

subroutine l_byte_critical_or( acc, l, m)

!  l_byte_critical_or() interface

logical( kind= l_byte_k), intent( inout) :: acc            ! accumulator

logical( kind= l_byte_k), intent( in) :: l                 ! operand

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! l_byte_critical_or() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  l_byte_critical_or() steps:

!  1. lock mutex
!  2. or
!  3. unlock mutex

! **********************************************************************

!  l_byte_critical_or() text

! ----------------------------------------------------------------------

continue                                                   ! critical_or()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   acc = acc .or. l                                        ! or

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_or()

!  l_byte_critical_or()

! **********************************************************************

end subroutine l_byte_critical_or

! **********************************************************************
! **********************************************************************

!  l_short_critical_or()

! **********************************************************************

subroutine l_short_critical_or( acc, l, m)

!  l_short_critical_or() l_shorterface

logical( kind= l_short_k), intent( inout) :: acc           ! accumulator

logical( kind= l_short_k), intent( in) :: l                ! operand

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! l_short_critical_or() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  l_short_critical_or() steps:

!  1. lock mutex
!  2. or
!  3. unlock mutex

! **********************************************************************

!  l_short_critical_or() text

! ----------------------------------------------------------------------

continue                                                   ! critical_or()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock or
                loc( mutexs( m% id)% cs) )

   acc = acc .or. l                                        ! or

   call LeaveCriticalSection( &                            ! unlock or
                loc( mutexs( m% id)% cs) )

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_or()

!  l_short_critical_or()

! **********************************************************************

end subroutine l_short_critical_or

! **********************************************************************
! **********************************************************************

!  l_int_critical_or()

! **********************************************************************

subroutine l_int_critical_or( acc, l, m)

!  l_int_critical_or() interface

logical( kind= l_int_k), intent( inout) :: acc             ! accumulator

logical( kind= l_int_k), intent( in) :: l                  ! operand

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! l_int_critical_or() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  l_int_critical_or() steps:

!  1. lock mutex
!  2. or
!  3. unlock mutex

! **********************************************************************

!  l_int_critical_or() text

! ----------------------------------------------------------------------

continue                                                   ! critical_or()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   acc = acc .or. l                                        ! or

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_or()

!  l_int_critical_or()

! **********************************************************************

end subroutine l_int_critical_or

! **********************************************************************
! **********************************************************************

!  byte_critical_eor()

! **********************************************************************

subroutine byte_critical_eor( acc, i, m)

!  byte_critical_eor() interface

integer( kind= byte_k), intent( inout) :: acc              ! accumulator

integer( kind= byte_k), intent( in) :: i                   ! operand

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! byte_critical_eor() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  byte_critical_eor() steps:

!  1. lock mutex
!  2. eor
!  3. unlock mutex

! **********************************************************************

!  byte_critical_eor() text

! ----------------------------------------------------------------------

continue                                                   ! critical_eor()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   acc = ieor( acc, i)                                     ! eor

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_eor()

!  byte_critical_eor()

! **********************************************************************

end subroutine byte_critical_eor

! **********************************************************************
! **********************************************************************

!  short_critical_eor()

! **********************************************************************

subroutine short_critical_eor( acc, i, m)

!  short_critical_eor() interface

integer( kind= short_k), intent( inout) :: acc             ! accumulator

integer( kind= short_k), intent( in) :: i                  ! operand

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! short_critical_eor() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  short_critical_eor() steps:

!  1. lock mutex
!  2. eor
!  3. unlock mutex

! **********************************************************************

!  short_critical_eor() text

! ----------------------------------------------------------------------

continue                                                   ! critical_eor()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   acc = ieor( acc, i)                                     ! eor

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_eor()

!  short_critical_eor()

! **********************************************************************

end subroutine short_critical_eor

! **********************************************************************
! **********************************************************************

!  int_critical_eor()

! **********************************************************************

subroutine int_critical_eor( acc, i, m)

!  int_critical_eor() interface

integer( kind= int_k), intent( inout) :: acc               ! accumulator

integer( kind= int_k), intent( in) :: i                    ! operand

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! int_critical_eor() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  int_critical_eor() steps:

!  1. lock mutex
!  2. eor
!  3. unlock mutex

! **********************************************************************

!  int_critical_eor() text

! ----------------------------------------------------------------------

continue                                                   ! critical_eor()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   acc = ieor( acc, i)                                     ! eor

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_eor()

!  int_critical_eor()

! **********************************************************************

end subroutine int_critical_eor

! **********************************************************************
! **********************************************************************
!  this compiler doesn't support integer kind long_k
! **********************************************************************
! **********************************************************************

!  l_byte_critical_eor()

! **********************************************************************

subroutine l_byte_critical_eor( acc, l, m)

!  l_byte_critical_eor() interface

logical( kind= l_byte_k), intent( inout) :: acc            ! accumulator

logical( kind= l_byte_k), intent( in) :: l                 ! operand

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! l_byte_critical_eor() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  l_byte_critical_eor() steps:

!  1. lock mutex
!  2. eor
!  3. unlock mutex

! **********************************************************************

!  l_byte_critical_eor() text

! ----------------------------------------------------------------------

continue                                                   ! critical_eor()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   acc = acc .neqv. l                                      ! eor

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_eor()

!  l_byte_critical_eor()

! **********************************************************************

end subroutine l_byte_critical_eor

! **********************************************************************
! **********************************************************************

!  l_short_critical_eor()

! **********************************************************************

subroutine l_short_critical_eor( acc, l, m)

!  l_short_critical_eor() l_shorterface

logical( kind= l_short_k), intent( inout) :: acc           ! accumulator

logical( kind= l_short_k), intent( in) :: l                ! operand

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! l_short_critical_eor() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  l_short_critical_eor() steps:

!  1. lock mutex
!  2. eor
!  3. unlock mutex

! **********************************************************************

!  l_short_critical_eor() text

! ----------------------------------------------------------------------

continue                                                   ! critical_eor()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock eor
                loc( mutexs( m% id)% cs) )

   acc = acc .neqv. l                                      ! eor

   call LeaveCriticalSection( &                            ! unlock eor
                loc( mutexs( m% id)% cs) )

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_eor()

!  l_short_critical_eor()

! **********************************************************************

end subroutine l_short_critical_eor

! **********************************************************************
! **********************************************************************

!  l_int_critical_eor()

! **********************************************************************

subroutine l_int_critical_eor( acc, l, m)

!  l_int_critical_eor() interface

logical( kind= l_int_k), intent( inout) :: acc             ! accumulator

logical( kind= l_int_k), intent( in) :: l                  ! operand

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! l_int_critical_eor() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  l_int_critical_eor() steps:

!  1. lock mutex
!  2. eor
!  3. unlock mutex

! **********************************************************************

!  l_int_critical_eor() text

! ----------------------------------------------------------------------

continue                                                   ! critical_eor()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   acc = acc .neqv. l                                      ! eor

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_eor()

!  l_int_critical_eor()

! **********************************************************************

end subroutine l_int_critical_eor

! **********************************************************************
! **********************************************************************

!  byte_critical_max()

! **********************************************************************

subroutine byte_critical_max( acc, test, m)

!  byte_critical_max() interface

integer( kind= byte_k), intent( inout) :: acc              ! accumulator

integer( kind= byte_k), intent( in) :: test                ! trial value

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! byte_critical_max() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  byte_critical_max() steps:

!  1. lock mutex
!  2. maximum
!  3. unlock mutex

! **********************************************************************

!  byte_critical_max() text

! ----------------------------------------------------------------------

continue                                                   ! critical_max()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   acc = max( acc, test)                                   ! maximum

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_max()

!  byte_critical_max()

! **********************************************************************

end subroutine byte_critical_max

! **********************************************************************
! **********************************************************************

!  short_critical_max()

! **********************************************************************

subroutine short_critical_max( acc, test, m)

!  short_critical_max() interface

integer( kind= short_k), intent( inout) :: acc             ! accumulator

integer( kind= short_k), intent( in) :: test               ! trial value

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! short_critical_max() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  short_critical_max() steps:

!  1. lock mutex
!  2. maximum
!  3. unlock mutex

! **********************************************************************

!  short_critical_max() text

! ----------------------------------------------------------------------

continue                                                   ! critical_max()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   acc = max( acc, test)                                   ! maximum

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_max()

!  short_critical_max()

! **********************************************************************

end subroutine short_critical_max

! **********************************************************************
! **********************************************************************

!  int_critical_max()

! **********************************************************************

subroutine int_critical_max( acc, test, m)

!  int_critical_max() interface

integer( kind= int_k), intent( inout) :: acc               ! accumulator

integer( kind= int_k), intent( in) :: test                 ! trial value

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! int_critical_max() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  int_critical_max() steps:

!  1. lock mutex
!  2. maximum
!  3. unlock mutex

! **********************************************************************

!  int_critical_max() text

! ----------------------------------------------------------------------

continue                                                   ! critical_max()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   acc = max( acc, test)                                   ! maximum

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_max()

!  int_critical_max()

! **********************************************************************

end subroutine int_critical_max

! **********************************************************************
! **********************************************************************
!  this compiler doesn't support integer kind long_k
! **********************************************************************
! **********************************************************************

!  single_critical_max()

! **********************************************************************

subroutine single_critical_max( acc, test, m)

!  single_critical_max() interface

real( kind= single_k), intent( inout) :: acc               ! accumulator

real( kind= single_k), intent( in) :: test                 ! trial value

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! single_critical_max() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  single_critical_max() steps:

!  1. lock mutex
!  2. maximum
!  3. unlock mutex

! **********************************************************************

!  single_critical_max() text

! ----------------------------------------------------------------------

continue                                                   ! critical_max()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   acc = max( acc, test)                                   ! maximum

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_max()

!  single_critical_max()

! **********************************************************************

end subroutine single_critical_max

! **********************************************************************
! **********************************************************************

!  double_critical_max()

! **********************************************************************

subroutine double_critical_max( acc, test, m)

!  double_critical_max() interface

real( kind= double_k), intent( inout) :: acc               ! accumulator

real( kind= double_k), intent( in) :: test                 ! trial value

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! double_critical_max() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  double_critical_max() steps:

!  1. lock mutex
!  2. maximum
!  3. unlock mutex

! **********************************************************************

!  double_critical_max() text

! ----------------------------------------------------------------------

continue                                                   ! critical_max()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   acc = max( acc, test)                                   ! maximum

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_max()

!  double_critical_max()

! **********************************************************************

end subroutine double_critical_max

! **********************************************************************
! **********************************************************************
!  this compiler doesn't support real kind quad_k
! **********************************************************************
! **********************************************************************

!  byte_critical_min()

! **********************************************************************

subroutine byte_critical_min( acc, test, m)

!  byte_critical_min() interface

integer( kind= byte_k), intent( inout) :: acc              ! accumulator

integer( kind= byte_k), intent( in) :: test                ! trial value

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! byte_critical_min() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  byte_critical_min() steps:

!  1. lock mutex
!  2. minimum
!  3. unlock mutex

! **********************************************************************

!  byte_critical_min() text

! ----------------------------------------------------------------------

continue                                                   ! critical_min()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   acc = min( acc, test)                                   ! minimum

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_min()

!  byte_critical_min()

! **********************************************************************

end subroutine byte_critical_min

! **********************************************************************
! **********************************************************************

!  short_critical_min()

! **********************************************************************

subroutine short_critical_min( acc, test, m)

!  short_critical_min() interface

integer( kind= short_k), intent( inout) :: acc             ! accumulator

integer( kind= short_k), intent( in) :: test               ! trial value

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! short_critical_min() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  short_critical_min() steps:

!  1. lock mutex
!  2. minimum
!  3. unlock mutex

! **********************************************************************

!  short_critical_min() text

! ----------------------------------------------------------------------

continue                                                   ! critical_min()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   acc = min( acc, test)                                   ! minimum

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_min()

!  short_critical_min()

! **********************************************************************

end subroutine short_critical_min

! **********************************************************************
! **********************************************************************

!  int_critical_min()

! **********************************************************************

subroutine int_critical_min( acc, test, m)

!  int_critical_min() interface

integer( kind= int_k), intent( inout) :: acc               ! accumulator

integer( kind= int_k), intent( in) :: test                 ! trial value

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! int_critical_min() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  int_critical_min() steps:

!  1. lock mutex
!  2. minimum
!  3. unlock mutex

! **********************************************************************

!  int_critical_min() text

! ----------------------------------------------------------------------

continue                                                   ! critical_min()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   acc = min( acc, test)                                   ! minimum

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_min()

!  int_critical_min()

! **********************************************************************

end subroutine int_critical_min

! **********************************************************************
! **********************************************************************
!  this compiler doesn't support integer kind long_k
! **********************************************************************
! **********************************************************************

!  single_critical_min()

! **********************************************************************

subroutine single_critical_min( acc, test, m)

!  single_critical_min() interface

real( kind= single_k), intent( inout) :: acc               ! accumulator

real( kind= single_k), intent( in) :: test                 ! trial value

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! single_critical_min() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  single_critical_min() steps:

!  1. lock mutex
!  2. minimum
!  3. unlock mutex

! **********************************************************************

!  single_critical_min() text

! ----------------------------------------------------------------------

continue                                                   ! critical_min()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   acc = min( acc, test)                                   ! minimum

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_min()

!  single_critical_min()

! **********************************************************************

end subroutine single_critical_min

! **********************************************************************
! **********************************************************************

!  double_critical_min()

! **********************************************************************

subroutine double_critical_min( acc, test, m)

!  double_critical_min() interface

real( kind= double_k), intent( inout) :: acc               ! accumulator

real( kind= double_k), intent( in) :: test                 ! trial value

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! double_critical_min() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  double_critical_min() steps:

!  1. lock mutex
!  2. minimum
!  3. unlock mutex

! **********************************************************************

!  double_critical_min() text

! ----------------------------------------------------------------------

continue                                                   ! critical_min()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   acc = min( acc, test)                                   ! minimum

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_min()

!  double_critical_min()

! **********************************************************************

end subroutine double_critical_min

! **********************************************************************
! **********************************************************************
!  this compiler doesn't support real kind quad_k
! **********************************************************************
! **********************************************************************

!  byte_critical_maxcopy()

! **********************************************************************

subroutine byte_critical_maxcopy( acc, cacc, test, ctest, m)

!  byte_critical_maxcopy() interface

integer( kind= byte_k), intent( inout) :: acc              ! max accumulator

integer( kind= int_k), intent( out) :: cacc                ! max copy

integer( kind= byte_k), intent( in) :: test                ! test operand

integer( kind= int_k), intent( in) :: ctest                ! test copy

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! byte_critical_maxcopy() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  byte_critical_maxcopy() steps:

!  1. lock mutex
!  2. maxcopyimum
!  3. unlock mutex

! **********************************************************************

!  byte_critical_maxcopy() text

! ----------------------------------------------------------------------

continue                                                   ! critical_maxcopy()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   max_copy: if( acc < test )then

      acc = test
      cacc = ctest

   endif max_copy

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_maxcopy()

!  byte_critical_maxcopy()

! **********************************************************************

end subroutine byte_critical_maxcopy

! **********************************************************************
! **********************************************************************

!  short_critical_maxcopy()

! **********************************************************************

subroutine short_critical_maxcopy( acc, cacc, test, ctest, m)

!  short_critical_maxcopy() interface

integer( kind= short_k), intent( inout) :: acc             ! max accumulator

integer( kind= int_k), intent( out) :: cacc                ! max copy

integer( kind= short_k), intent( in) :: test               ! test operand

integer( kind= int_k), intent( in) :: ctest                ! test copy

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! short_critical_maxcopy() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  short_critical_maxcopy() steps:

!  1. lock mutex
!  2. maxcopyimum
!  3. unlock mutex

! **********************************************************************

!  short_critical_maxcopy() text

! ----------------------------------------------------------------------

continue                                                   ! critical_maxcopy()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   max_copy: if( acc < test )then

      acc = test
      cacc = ctest

   endif max_copy

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_maxcopy()

!  short_critical_maxcopy()

! **********************************************************************

end subroutine short_critical_maxcopy

! **********************************************************************
! **********************************************************************

!  int_critical_maxcopy()

! **********************************************************************

subroutine int_critical_maxcopy( acc, cacc, test, ctest, m)

!  int_critical_maxcopy() interface

integer( kind= int_k), intent( inout) :: acc               ! max accumulator

integer( kind= int_k), intent( out) :: cacc                ! max copy

integer( kind= int_k), intent( in) :: test                 ! test operand

integer( kind= int_k), intent( in) :: ctest                ! test copy

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! int_critical_maxcopy() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  int_critical_maxcopy() steps:

!  1. lock mutex
!  2. maxcopyimum
!  3. unlock mutex

! **********************************************************************

!  int_critical_maxcopy() text

! ----------------------------------------------------------------------

continue                                                   ! critical_maxcopy()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   max_copy: if( acc < test )then

      acc = test
      cacc = ctest

   endif max_copy

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_maxcopy()

!  int_critical_maxcopy()

! **********************************************************************

end subroutine int_critical_maxcopy

! **********************************************************************
! **********************************************************************
!  this compiler doesn't support integer kind long_k
! **********************************************************************
! **********************************************************************

!  single_critical_maxcopy()

! **********************************************************************

subroutine single_critical_maxcopy( acc, cacc, test, ctest, m)

!  single_critical_maxcopy() interface

real( kind= single_k), intent( inout) :: acc               ! max accumulator

integer( kind= int_k), intent( out) :: cacc                ! max copy

real( kind= single_k), intent( in) :: test                 ! test operand

integer( kind= int_k), intent( in) :: ctest                ! test copy

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! single_critical_maxcopy() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  single_critical_maxcopy() steps:

!  1. lock mutex
!  2. maxcopyimum
!  3. unlock mutex

! **********************************************************************

!  single_critical_maxcopy() text

! ----------------------------------------------------------------------

continue                                                   ! critical_maxcopy()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   max_copy: if( acc < test )then

      acc = test
      cacc = ctest

   endif max_copy

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_maxcopy()

!  single_critical_maxcopy()

! **********************************************************************

end subroutine single_critical_maxcopy

! **********************************************************************
! **********************************************************************

!  double_critical_maxcopy()

! **********************************************************************

subroutine double_critical_maxcopy( acc, cacc, test, ctest, m)

!  double_critical_maxcopy() interface

real( kind= single_k), intent( inout) :: acc               ! max accumulator

integer( kind= int_k), intent( out) :: cacc                ! max copy

real( kind= double_k), intent( in) :: test                 ! test operand

integer( kind= int_k), intent( in) :: ctest                ! test copy

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! double_critical_maxcopy() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  double_critical_maxcopy() steps:

!  1. lock mutex
!  2. maxcopyimum
!  3. unlock mutex

! **********************************************************************

!  double_critical_maxcopy() text

! ----------------------------------------------------------------------

continue                                                   ! critical_maxcopy()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   max_copy: if( acc < test )then

      acc = test
      cacc = ctest

   endif max_copy

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_maxcopy()

!  double_critical_maxcopy()

! **********************************************************************

end subroutine double_critical_maxcopy

! **********************************************************************
! **********************************************************************
!  this compiler doesn't support real kind quad_k
! **********************************************************************
! **********************************************************************

!  byte_critical_mincopy()

! **********************************************************************

subroutine byte_critical_mincopy( acc, cacc, test, ctest, m)

!  byte_critical_mincopy() interface

integer( kind= byte_k), intent( inout) :: acc              ! min accumulator

integer( kind= int_k), intent( out) :: cacc                ! min copy

integer( kind= byte_k), intent( in) :: test                ! test operand

integer( kind= int_k), intent( in) :: ctest                ! test copy

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! byte_critical_mincopy() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  byte_critical_mincopy() steps:

!  1. lock mutex
!  2. mincopyimum
!  3. unlock mutex

! **********************************************************************

!  byte_critical_mincopy() text

! ----------------------------------------------------------------------

continue                                                   ! critical_mincopy()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   min_copy: if( acc > test )then

      acc = test
      cacc = ctest

   endif min_copy

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_mincopy()

!  byte_critical_mincopy()

! **********************************************************************

end subroutine byte_critical_mincopy

! **********************************************************************
! **********************************************************************

!  short_critical_mincopy()

! **********************************************************************

subroutine short_critical_mincopy( acc, cacc, test, ctest, m)

!  short_critical_mincopy() interface

integer( kind= short_k), intent( inout) :: acc             ! min accumulator

integer( kind= int_k), intent( out) :: cacc                ! min copy

integer( kind= short_k), intent( in) :: test               ! test operand

integer( kind= int_k), intent( in) :: ctest                ! test copy

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! short_critical_mincopy() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  short_critical_mincopy() steps:

!  1. lock mutex
!  2. mincopyimum
!  3. unlock mutex

! **********************************************************************

!  short_critical_mincopy() text

! ----------------------------------------------------------------------

continue                                                   ! critical_mincopy()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   min_copy: if( acc > test )then

      acc = test
      cacc = ctest

   endif min_copy

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_mincopy()

!  short_critical_mincopy()

! **********************************************************************

end subroutine short_critical_mincopy

! **********************************************************************
! **********************************************************************

!  int_critical_mincopy()

! **********************************************************************

subroutine int_critical_mincopy( acc, cacc, test, ctest, m)

!  int_critical_mincopy() interface

integer( kind= int_k), intent( inout) :: acc               ! min accumulator

integer( kind= int_k), intent( out) :: cacc                ! min copy

integer( kind= int_k), intent( in) :: test                 ! test operand

integer( kind= int_k), intent( in) :: ctest                ! test copy

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! int_critical_mincopy() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  int_critical_mincopy() steps:

!  1. lock mutex
!  2. mincopyimum
!  3. unlock mutex

! **********************************************************************

!  int_critical_mincopy() text

! ----------------------------------------------------------------------

continue                                                   ! critical_mincopy()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   min_copy: if( acc > test )then

      acc = test
      cacc = ctest

   endif min_copy

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_mincopy()

!  int_critical_mincopy()

! **********************************************************************

end subroutine int_critical_mincopy

! **********************************************************************
! **********************************************************************
!  this compiler doesn't support integer kind long_k
! **********************************************************************
! **********************************************************************

!  single_critical_mincopy()

! **********************************************************************

subroutine single_critical_mincopy( acc, cacc, test, ctest, m)

!  single_critical_mincopy() interface

real( kind= single_k), intent( inout) :: acc               ! min accumulator

integer( kind= int_k), intent( out) :: cacc                ! min copy

real( kind= single_k), intent( in) :: test                 ! test operand

integer( kind= int_k), intent( in) :: ctest                ! test copy

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! single_critical_mincopy() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  single_critical_mincopy() steps:

!  1. lock mutex
!  2. mincopyimum
!  3. unlock mutex

! **********************************************************************

!  single_critical_mincopy() text

! ----------------------------------------------------------------------

continue                                                   ! critical_mincopy()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   min_copy: if( acc > test )then

      acc = test
      cacc = ctest

   endif min_copy

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_mincopy()

!  single_critical_mincopy()

! **********************************************************************

end subroutine single_critical_mincopy

! **********************************************************************
! **********************************************************************

!  double_critical_mincopy()

! **********************************************************************

subroutine double_critical_mincopy( acc, cacc, test, ctest, m)

!  double_critical_mincopy() interface

real( kind= double_k), intent( inout) :: acc               ! min accumulator

integer( kind= int_k), intent( out) :: cacc                ! min copy

real( kind= double_k), intent( in) :: test                 ! test operand

integer( kind= int_k), intent( in) :: ctest                ! test copy

type( mutex_t), intent( in) :: m                           ! mutex

! ----------------------------------------------------------------------

! double_critical_mincopy() Win32 system calls

interface
   subroutine EnterCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: EnterCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_EnterCriticalSection@4' ::  EnterCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE ::   object
   end subroutine EnterCriticalSection

   subroutine LeaveCriticalSection( object)
!DEC$ ATTRIBUTES DEFAULT :: LeaveCriticalSection
!DEC$ ATTRIBUTES STDCALL, ALIAS: '_LeaveCriticalSection@4' ::  LeaveCriticalSection
      integer( 4) :: object
!DEC$ ATTRIBUTES VALUE :: object
   end subroutine LeaveCriticalSection
end interface

! **********************************************************************

!  double_critical_mincopy() steps:

!  1. lock mutex
!  2. mincopyimum
!  3. unlock mutex

! **********************************************************************

!  double_critical_mincopy() text

! ----------------------------------------------------------------------

continue                                                   ! critical_mincopy()

! ----------------------------------------------------------------------

   call EnterCriticalSection( &                            ! lock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

   min_copy: if( acc > test )then

      acc = test
      cacc = ctest

   endif min_copy

   call LeaveCriticalSection( &                            ! unlock mutex
                 loc( mutexs( m% id)% cs) )                ! mutex

! ----------------------------------------------------------------------

!  normal exit

return                                                     ! critical_mincopy()

!  double_critical_mincopy()

! **********************************************************************

end subroutine double_critical_mincopy

! **********************************************************************
! **********************************************************************
!  this compiler doesn't support real kind quad_k
! **********************************************************************
! **********************************************************************

!  fthreads

! $Source$
! **********************************************************************

end module fthreads                                        ! eof