! 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), &