C ALGORITHM 821, COLLECTED ALGORITHMS FROM ACM. C THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, C VOL. 28,NO. 3, September, 2002, P. 354--371. #! /bin/sh # This is a shell archive, meaning: # 1. Remove everything above the #! /bin/sh line. # 2. Save the resulting text in a file. # 3. Execute the file with /bin/sh (not csh) to create the files: # Doc/ # Doc/Man/ # Doc/Man/fpthrd_attr.3th # Doc/Man/fpthrd_attr_destroy.3th # Doc/Man/fpthrd_attr_getdetachstate.3th # Doc/Man/fpthrd_attr_getinheritsched.3th # Doc/Man/fpthrd_attr_getschedparam.3th # Doc/Man/fpthrd_attr_getschedpolicy.3th # Doc/Man/fpthrd_attr_getscope.3th # Doc/Man/fpthrd_attr_getstacksize.3th # Doc/Man/fpthrd_attr_init.3th # Doc/Man/fpthrd_attr_setdetachstate.3th # Doc/Man/fpthrd_attr_setinheritsched.3th # Doc/Man/fpthrd_attr_setschedparam.3th # Doc/Man/fpthrd_attr_setschedpolicy.3th # Doc/Man/fpthrd_attr_setscope.3th # Doc/Man/fpthrd_attr_setstacksize.3th # Doc/Man/fpthrd_cancel.3th # Doc/Man/fpthrd_cond.3th # Doc/Man/fpthrd_cond_broadcast.3th # Doc/Man/fpthrd_cond_destroy.3th # Doc/Man/fpthrd_cond_init.3th # Doc/Man/fpthrd_cond_signal.3th # Doc/Man/fpthrd_cond_timedwait.3th # Doc/Man/fpthrd_cond_wait.3th # Doc/Man/fpthrd_condattr_destroy.3th # Doc/Man/fpthrd_condattr_getpshared.3th # Doc/Man/fpthrd_condattr_init.3th # Doc/Man/fpthrd_condattr_setpshared.3th # Doc/Man/fpthrd_create.3th # Doc/Man/fpthrd_detach.3th # Doc/Man/fpthrd_equal.3th # Doc/Man/fpthrd_exit.3th # Doc/Man/fpthrd_getschedparam.3th # Doc/Man/fpthrd_join.3th # Doc/Man/fpthrd_mutex_destroy.3th # Doc/Man/fpthrd_mutex_init.3th # Doc/Man/fpthrd_mutex_lock.3th # Doc/Man/fpthrd_mutex_trylock.3th # Doc/Man/fpthrd_mutex_unlock.3th # Doc/Man/fpthrd_mutexattr_destroy.3th # Doc/Man/fpthrd_mutexattr_getprioceiling.3th # Doc/Man/fpthrd_mutexattr_getprotocol.3th # Doc/Man/fpthrd_mutexattr_getpshared.3th # Doc/Man/fpthrd_mutexattr_init.3th # Doc/Man/fpthrd_mutexattr_setprioceiling.3th # Doc/Man/fpthrd_mutexattr_setprotocol.3th # Doc/Man/fpthrd_mutexattr_setpshared.3th # Doc/Man/fpthrd_once.3th # Doc/Man/fpthrd_sched_attr.3th # Doc/Man/fpthrd_self.3th # Doc/Man/fpthrd_setcancelstate.3th # Doc/Man/fpthrd_setcanceltype.3th # Doc/Man/fpthrd_setschedparam.3th # Doc/Man/fpthrd_testcancel.3th # Doc/README # Fortran90/ # Fortran90/Sp/ # Fortran90/Sp/Drivers/ # Fortran90/Sp/Drivers/Makefile.cpq # Fortran90/Sp/Drivers/Makefile.origin # Fortran90/Sp/Drivers/Makefile.power3 # Fortran90/Sp/Drivers/Makefile.sun # Fortran90/Sp/Drivers/bench1.f # Fortran90/Sp/Drivers/make.inc # Fortran90/Sp/Drivers/test1.f # Fortran90/Sp/Drivers/test1.output # Fortran90/Sp/Drivers/test2.f # Fortran90/Sp/Drivers/test2.output # Fortran90/Sp/Drivers/test3.f # Fortran90/Sp/Drivers/test3.output # Fortran90/Sp/Drivers/test4.f # Fortran90/Sp/Drivers/test4.output # Fortran90/Sp/Src/ # Fortran90/Sp/Src/Makefile.cpq # Fortran90/Sp/Src/Makefile.origin # Fortran90/Sp/Src/Makefile.power3 # Fortran90/Sp/Src/Makefile.sun # Fortran90/Sp/Src/build # Fortran90/Sp/Src/config.c # Fortran90/Sp/Src/fpthrd.f # Fortran90/Sp/Src/make.inc # Fortran90/Sp/Src/ptf90.c # Fortran90/Sp/Src/summary.h # This archive created: Wed Oct 16 12:00:03 2002 export PATH; PATH=/bin:$PATH if test ! -d 'Doc' then mkdir 'Doc' fi cd 'Doc' if test ! -d 'Man' then mkdir 'Man' fi cd 'Man' if test -f 'fpthrd_attr.3th' then echo shar: will not over-write existing file "'fpthrd_attr.3th'" else cat << "SHAR_EOF" > 'fpthrd_attr.3th' .TH FPTHRD_ATTR 3F "" "FPTHRD API" .SH NAME fpthrd_attr_init, fpthrd_attr_destroy, fpthrd_attr_setstacksize, fpthrd_attr_getstacksize, fpthrd_attr_setdetachstate, fpthrd_attr_getdetachstate \- Thread creation attributes .SH SYNOPSIS .B USE fpthrd .BI "CALL fpthrd_attr_init(" attr " [, " ierr "])" .BI "CALL fpthrd_attr_destroy(" attr " [, " ierr "])" .BI "CALL fpthrd_attr_setstacksize(" attr ", " stacksize " [, " .IB ierr "])" .BI "CALL fpthrd_attr_getstacksize(" attr ", " stacksize " [, " .IB ierr "])" .BI "CALL fpthrd_attr_setdetachstate(" attr ", " state " [, " .IB ierr "])" .BI "CALL fpthrd_attr_getdetachstate(" attr ", " state " [, " .IB ierr "])" .BI "TYPE(FPTHRD_ATTR_T) :: " attr .br .BI "INTEGER :: " stacksize ", " state ", " .IB stackaddr ", " ierr .SH DESCRIPTION Setting attributes for threads is achieved by filling a thread attribute object .I "attr" of type .BR "FPTHRD_ATTR_T" , then passing it as the second argument to .BR "fpthrd_create" (3F). (Passing .B "NULL" as the second parameter to .B "fpthrd_create" is equivalent to passing a thread attribute object with all attributes set to their default values.) .B "fpthrd_attr_init" initializes the thread attribute object .I "attr" and fills it with default values for the attributes. (The relevant default attribute values are listed below.) Each attribute .I "attrname" (see below for a list of all attributes) can be individually set using the routine .BI "fpthrd_attr_set" "attrname" and retrieved using the routine .BI "fpthrd_attr_get" "attrname" . .B "fpthrd_attr_destroy" uninitializes a thread attribute object, which must not be reused until it is reinitialized. Attribute objects are consulted only when creating a new thread. The same attribute object can be used for creating several threads. Modifying an attribute object after a call to .B "fpthrd_create" does not change the attributes of the thread previously created. The following thread attributes .RI ( "attrname" ) are supported: .SS stacksize Control the minimum number of bytes used by a thread for its stack. The default stack size may be retrieved from an intialized attribute object. .SS detachstate Control whether the thread is created in the joinable state .RB ( "FPTHRD_CREATE_JOINABLE" ) or in the detached state .RB ( "FPTHRD_CREATE_DETACHED" ). Default value: .BR "FPTHRD_CREATE_JOINABLE" . In the joinable state, another thread can synchronize on the thread termination and recover its termination code using .BR "fpthrd_join" (3F). In the detached state, the thread resources are immediately freed when it terminates, but .BR "fpthrd_join" (3F) cannot be used to synchronize on the thread termination. A thread created in the joinable state can later be put in the detached state using .BR "fpthrd_detach" (3F). .SH "DIAGNOSTICS" All routines return 0 in the optional .I ierr on success and a non-zero error code on error. On success, the .BI "fpthrd_attr_get" "attrname" routines also return the current value of the attribute .I "attrname" in their second argument. The .B "fpthrd_attr_setstacksize" routine returns the following error code on error: .RS .TP .B "EINVAL" The stack size specified by .I "stacksize" is too small. .RE The .B "fpthrd_attr_setdetachstate" routine returns the following error code on error: .RS .TP .B "EINVAL" The specified .I "detachstate" is not one of .B "FPTHRD_CREATE_JOINABLE" or .BR "FPTHRD_CREATE_DETACHED" . .RE .SH "SEE ALSO" .BR "fpthrd_create" (3F), .BR "fpthrd_join" (3F), .BR "fpthrd_detach" (3F). SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_attr_destroy.3th' then echo shar: will not over-write existing file "'fpthrd_attr_destroy.3th'" else cat << "SHAR_EOF" > 'fpthrd_attr_destroy.3th' .so fpthrd_attr.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_attr_getdetachstate.3th' then echo shar: will not over-write existing file "'fpthrd_attr_getdetachstate.3th'" else cat << "SHAR_EOF" > 'fpthrd_attr_getdetachstate.3th' .so fpthrd_attr.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_attr_getinheritsched.3th' then echo shar: will not over-write existing file "'fpthrd_attr_getinheritsched.3th'" else cat << "SHAR_EOF" > 'fpthrd_attr_getinheritsched.3th' .so fpthrd_sched_attr.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_attr_getschedparam.3th' then echo shar: will not over-write existing file "'fpthrd_attr_getschedparam.3th'" else cat << "SHAR_EOF" > 'fpthrd_attr_getschedparam.3th' .so fpthrd_sched_attr.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_attr_getschedpolicy.3th' then echo shar: will not over-write existing file "'fpthrd_attr_getschedpolicy.3th'" else cat << "SHAR_EOF" > 'fpthrd_attr_getschedpolicy.3th' .so fpthrd_sched_attr.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_attr_getscope.3th' then echo shar: will not over-write existing file "'fpthrd_attr_getscope.3th'" else cat << "SHAR_EOF" > 'fpthrd_attr_getscope.3th' .so fpthrd_sched_attr.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_attr_getstacksize.3th' then echo shar: will not over-write existing file "'fpthrd_attr_getstacksize.3th'" else cat << "SHAR_EOF" > 'fpthrd_attr_getstacksize.3th' .so fpthrd_attr.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_attr_init.3th' then echo shar: will not over-write existing file "'fpthrd_attr_init.3th'" else cat << "SHAR_EOF" > 'fpthrd_attr_init.3th' .so fpthrd_attr.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_attr_setdetachstate.3th' then echo shar: will not over-write existing file "'fpthrd_attr_setdetachstate.3th'" else cat << "SHAR_EOF" > 'fpthrd_attr_setdetachstate.3th' .so fpthrd_attr.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_attr_setinheritsched.3th' then echo shar: will not over-write existing file "'fpthrd_attr_setinheritsched.3th'" else cat << "SHAR_EOF" > 'fpthrd_attr_setinheritsched.3th' .so fpthrd_sched_attr.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_attr_setschedparam.3th' then echo shar: will not over-write existing file "'fpthrd_attr_setschedparam.3th'" else cat << "SHAR_EOF" > 'fpthrd_attr_setschedparam.3th' .so fpthrd_sched_attr.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_attr_setschedpolicy.3th' then echo shar: will not over-write existing file "'fpthrd_attr_setschedpolicy.3th'" else cat << "SHAR_EOF" > 'fpthrd_attr_setschedpolicy.3th' .so fpthrd_sched_attr.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_attr_setscope.3th' then echo shar: will not over-write existing file "'fpthrd_attr_setscope.3th'" else cat << "SHAR_EOF" > 'fpthrd_attr_setscope.3th' .so fpthrd_sched_attr.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_attr_setstacksize.3th' then echo shar: will not over-write existing file "'fpthrd_attr_setstacksize.3th'" else cat << "SHAR_EOF" > 'fpthrd_attr_setstacksize.3th' .so fpthrd_attr.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_cancel.3th' then echo shar: will not over-write existing file "'fpthrd_cancel.3th'" else cat << "SHAR_EOF" > 'fpthrd_cancel.3th' .TH FPTHRD_CANCEL 3F "" "FPTHRD API" .SH NAME fpthrd_cancel, fpthrd_setcancelstate, fpthrd_setcanceltype, fpthrd_testcancel \- Thread cancellation .SH SYNOPSIS .B USE fpthrd .BI "CALL fpthrd_cancel(" thred " [, " ierr "])" .BI "CALL fpthrd_setcancelstate(" state ", " oldstate " [, " .IB ierr "])" .BI "CALL fpthrd_setcanceltype(" type ", " oldtype " [, " .IB ierr "])" .BI "CALL fpthrd_testcancel()" .BI "TYPE(FPTHRD_T) :: " thred .br .BI "INTEGER :: " state ", " oldstate ", " .IB type ", " oldtype ", " ierr .SH DESCRIPTION Cancellation is the mechanism by which a thread can terminate the execution of another thread. More precisely, a thread can send a cancellation request to another thread. Depending on its settings, the target thread can then either ignore the request, honor it immediately, or defer it until it reaches a cancellation point. .SS Cancel .B "fpthrd_cancel" sends a cancellation request to the thread denoted by the .I "thred" argument. When a thread eventually honors a cancellation request, it performs as if .B "fpthrd_exit(FPTHRD_CANCELED)" has been called at that point. Thus, the thread stops executing with the return value .BR "FPTHRD_CANCELED" . See .BR "fpthrd_exit" (3F) for more information. .SS State .B "fpthrd_setcancelstate" changes the cancellation state for the calling thread\-that is, whether cancellation requests are ignored or not. The .I "state" argument is the new cancellation state: either .B "FPTHRD_CANCEL_ENABLE" to enable cancellation, or .B "FPTHRD_CANCEL_DISABLE" to disable cancellation (cancellation requests are ignored). If .I "oldstate" is not .BR "NULL" , the previous cancellation state is stored in the location .IR "oldstate" , and can thus be restored later by another call to .BR "fpthrd_setcancelstate" . Threads are always created by .BR "fpthrd_create" (3F) with cancellation enabled; .IR "i.e." , the default cancellation state is .BR "FPTHRD_CANCEL_ENABLE" . .SS Type .B "fpthrd_setcanceltype" changes the type of responses to cancellation requests for the calling thread: asynchronous (immediate) or deferred. The .I "type" argument is the new cancellation type: either .B "FPTHRD_CANCEL_ASYNCHRONOUS" to cancel the calling thread as soon as the cancellation request is received, or .B "FPTHRD_CANCEL_DEFERRED" to keep the cancellation request pending until the next cancellation point. If .I "oldtype" is not .BR "NULL" , the previous cancellation state is stored in the location pointed to by .IR "oldtype" , and can thus be restored later by another call to .BR "fpthrd_setcanceltype" . Threads are always created by .BR "fpthrd_create" (3F) with cancellation deferred; .IR "i.e." , the default cancellation type is .BR "FPTHRD_CANCEL_DEFERRED" . .SS Test .B "fpthrd_testcancel" does nothing except test for pending cancellation and immediately accepting a waiting request. Its purpose is to introduce explicit checks for cancellation in long sequences of code that do not call cancellation point routines otherwise. .SH "CANCELLATION POINTS" Cancellation points are those points in the program execution where a test for pending cancellation requests is performed and cancellation is executed if positive. The following FPTHRD routines are cancellation points: .BR "fpthrd_testcancel" (3F) .br .BR "fpthrd_join" (3F) .br .BR "fpthrd_cond_wait" (3F) .br .BR "fpthrd_cond_timedwait" (3F) All other FPTHRD routines are guaranteed not to be cancellation points. That is, they never perform cancellation in deferred cancellation mode. .SH "DIAGNOSTICS" .BR "fpthrd_cancel" , .B "fpthrd_setcancelstate" and .B "fpthrd_setcanceltype" return 0 in the optional .I "ierr" on success and a non-zero error code on error. .B "fpthrd_testcancel" does not require the .I "ierr" error parameter since the thread either cancels (if a cancel request is pending) or continues execution (if no request has been generated). .B "fpthrd_cancel" returns the following error code on error: .RS .TP .B "ESRCH" No thread could be found corresponding to that specified by the .I "thred" ID. .RE .B "fpthrd_setcancelstate" returns the following error code on error: .RS .TP .B "EINVAL" The .I "state" argument is not .B "FPTHRD_CANCEL_ENABLE" nor .BR "FPTHRD_CANCEL_DISABLE" . .RE .B "fpthrd_setcanceltype" returns the following error code on error: .RS .TP .B "EINVAL" The .I "type" argument is not .B "FPTHRD_CANCEL_DEFERRED" nor .BR "FPTHRD_CANCEL_ASYNCHRONOUS" . .RE .SH "SEE ALSO" .BR "fpthrd_exit" (3F) SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_cond.3th' then echo shar: will not over-write existing file "'fpthrd_cond.3th'" else cat << "SHAR_EOF" > 'fpthrd_cond.3th' .TH FPTHRD_COND 3F "" "FPTHRD API" .SH NAME fpthrd_cond_init, fpthrd_cond_destroy, fpthrd_cond_signal, fpthrd_cond_broadcast, fpthrd_cond_wait, fpthrd_cond_timedwait \- Operations on condition variables .SH SYNOPSIS .B USE fpthrd .BI "CALL fpthrd_cond_init(" cond ", " cond_attr " [, " .IB ierr "])" .BI "CALL fpthrd_cond_signal(" cond " [, " ierr "])" .BI "CALL fpthrd_cond_broadcast(" cond " [, " ierr "])" .BI "CALL fpthrd_cond_wait(" cond ", " mutex " [, " .IB ierr "])" .BI "CALL fpthrd_cond_timedwait(" cond ", " mutex ", " .IB abstime " [, " ierr "])" .BI "CALL fpthrd_cond_destroy(" cond " [, " ierr "])" .BI "TYPE(FPTHRD_COND_T) :: " cond .br .BI "TYPE(FPTHRD_CONDATTR_T) :: " cond_attr .br .BI "TYPE(FPTHRD_MUTEX_T) :: " mutex .br .BI "TYPE(FTIMESPEC) :: " abstime .br .BI "INTEGER :: " ierr .SH DESCRIPTION A condition variable is a synchronization device that allows threads to suspend execution and relinquish the processors until some predicate on shared data is satisfied. The basic operations on condition variables are: signal the condition (when the predicate becomes true), and wait for the condition, suspending the thread execution until another thread signals the condition. A condition variable must always be associated with a mutex, to avoid the race condition where a thread prepares to wait on a condition variable and another thread signals the condition variable just before the first thread actually waits on it. .SS Initialize .B "fpthrd_cond_init" initializes the condition variable .IR "cond" , using the condition attributes specified in .IR "cond_attr" , or default attributes if .I "cond_attr" is .BR "NULL" . As with the C version of Pthreads, condition variables of type .B "FPTHRD_COND_T" can be initialized statically at definition with the parameter .B "FPTHRD_COND_INITIALIZER" . .SS "Signal and Broadcast" .B "fpthrd_cond_signal" restarts one of the threads that is waiting on the condition variable .IR "cond" . If several threads are waiting on .IR "cond" , .B "fpthrd_cond_signal" will restart exactly one, but it is not specified which. .B "fpthrd_cond_broadcast" restarts all the threads that are waiting on the condition variable .IR "cond" . In the case of either routine, if no threads are waiting on .IR "cond" , nothing happens; the signal is lost. .SS Wait .B "fpthrd_cond_wait" atomically unlocks the .I "mutex" (as per .BR "fpthrd_unlock_mutex" (3F)) and waits for the condition variable .I "cond" to be signaled. The thread execution is suspended until the condition variable is signaled. The .I "mutex" must be locked by the calling thread on entrance to .BR "fpthrd_cond_wait" . Before returning to the calling thread, .B "fpthrd_cond_wait" re-acquires .I "mutex" (as per .BR "fpthrd_lock_mutex" (3F)). Unlocking the mutex and suspending on the condition variable is done atomically. Thus, if all threads always acquire the mutex before signaling the condition variable, this guarantees that the condition variable cannot be signaled (and thus ignored) between the time a thread locks the mutex and the time it waits on the condition variable. .SS "Time Wait" .B "fpthrd_cond_timedwait" atomically unlocks .I "mutex" and waits on .IR "cond" , as .B "fpthrd_cond_wait" does, but it also limits the duration of the wait. If .I "cond" has not been signaled within the amount of time specified by .IR "abstime" , the mutex .I "mutex" is re-acquired and .B "fpthrd_cond_timedwait" returns the error .BR "ETIMEDOUT" . The .I "abstime" parameter specifies an absolute time, with the same origin as .BR "time" (2) and .BR "gettimeofday" (2): an .I "abstime" of 0 corresponds to 00:00:00 GMT, January 1, 1970. .SS Destroy .B "fpthrd_cond_destroy" destroys a condition variable. No threads must be waiting on the condition variable upon calling .BR "fpthrd_cond_destroy" . .SH CANCELLATION .B "fpthrd_cond_wait" and .B "fpthrd_cond_timedwait" are cancellation points (see .B "fpthrd_cancel" (3F)). If a thread is cancelled while suspended in one of these routines, the thread immediately resumes execution, again locks the .I "mutex" argument to .B "fpthrd_cond_wait" and .BR "fpthrd_cond_timedwait" , and finally executes the cancellation. .SH "DIAGNOSTICS" All condition variable routines return 0 in the optional .I "ierr" on success and a non-zero error code on error. The .B "fpthrd_cond_init" routine returns the following error codes on error: .RS .TP .B "EINVAL" .I "attr" is invalid. .TP .B "EFAULT" .IR "cond " or " attr" are invalid. .TP .B "ENOMEM" Insufficient memory. .TP .B "EAGAIN" Insufficient resources. .RE The .BR "fpthrd_cond_signal " and " fpthrd_cond_broadcast" routines return the following error code on error: .RS .TP .B "EINVAL" .I "cond" is invalid. .RE The .B "fpthrd_cond_wait" routine returns the following error codes on error: .RS .TP .B "EINVAL" .IR "cond " or " mutex" not valid. .TP .B "EPERM" .I "mutex" not owned by calling thread. .RE The .B "fpthrd_cond_timedwait" routine returns the following error codes on error: .RS .TP .B "EINVAL" .IR cond ", " mutex " or " abstime not valid. .TP .B "EPERM" .I "mutex" not owned by calling thread. .TP .B "ETIMEDOUT" The condition variable was not signaled before the timeout specified by .I "abstime" .TP .B "EINTR" .br .B "fpthrd_cond_timedwait" was interrupted by a signal. .RE The .B "fpthrd_cond_destroy" routine returns the following error codes on error: .RS .TP .B "EINVAL" .I "cond" is not a condition variable. .TP .B "EBUSY" Some threads are currently waiting on .IR "cond" . .RE .SH "SEE ALSO" .BR "fpthrd_condattr_init" (3F), .BR "fpthrd_mutex_lock" (3F), .BR "fpthrd_mutex_unlock" (3F), .BR "gettimeofday" (2), .BR "nanosleep" (2). SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_cond_broadcast.3th' then echo shar: will not over-write existing file "'fpthrd_cond_broadcast.3th'" else cat << "SHAR_EOF" > 'fpthrd_cond_broadcast.3th' .so fpthrd_cond.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_cond_destroy.3th' then echo shar: will not over-write existing file "'fpthrd_cond_destroy.3th'" else cat << "SHAR_EOF" > 'fpthrd_cond_destroy.3th' .so fpthrd_cond.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_cond_init.3th' then echo shar: will not over-write existing file "'fpthrd_cond_init.3th'" else cat << "SHAR_EOF" > 'fpthrd_cond_init.3th' .so fpthrd_cond.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_cond_signal.3th' then echo shar: will not over-write existing file "'fpthrd_cond_signal.3th'" else cat << "SHAR_EOF" > 'fpthrd_cond_signal.3th' .so fpthrd_cond.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_cond_timedwait.3th' then echo shar: will not over-write existing file "'fpthrd_cond_timedwait.3th'" else cat << "SHAR_EOF" > 'fpthrd_cond_timedwait.3th' .so fpthrd_cond.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_cond_wait.3th' then echo shar: will not over-write existing file "'fpthrd_cond_wait.3th'" else cat << "SHAR_EOF" > 'fpthrd_cond_wait.3th' .so fpthrd_cond.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_condattr_destroy.3th' then echo shar: will not over-write existing file "'fpthrd_condattr_destroy.3th'" else cat << "SHAR_EOF" > 'fpthrd_condattr_destroy.3th' .so fpthrd_contattr_init.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_condattr_getpshared.3th' then echo shar: will not over-write existing file "'fpthrd_condattr_getpshared.3th'" else cat << "SHAR_EOF" > 'fpthrd_condattr_getpshared.3th' .so fpthrd_condattr_init.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_condattr_init.3th' then echo shar: will not over-write existing file "'fpthrd_condattr_init.3th'" else cat << "SHAR_EOF" > 'fpthrd_condattr_init.3th' .TH FPTHRD_CONDATTR 3F "" "FPTHRD API" .SH NAME fpthrd_condattr_init, fpthrd_condattr_destroy, fpthrd_condattr_setpshared, fpthrd_condattr_getpshared \- Condition variable creation attributes .SH SYNOPSIS .B USE fpthrd .BI "CALL fpthrd_condattr_init(" attr " [, " ierr "])" .BI "CALL fpthrd_condattr_destroy(" attr " [, " ierr "])" .BI "CALL fpthrd_condattr_setpshared(" attr ", " pshared " [, " .IB ierr "])" .BI "CALL fpthrd_condattr_getpshared(" attr ", " pshared " [, " .IB ierr "])" .BI "TYPE(FPTHRD_CONDATTR_T) :: " attr .br .BI "INTEGER :: " pshared ", " ierr .SH DESCRIPTION Condition variable attributes can be specified at condition variable initialization time, by passing a condition attribute object as the second argument to .BR "fpthrd_cond_init" (3F). (Passing .B "NULL" as the second parameter to .B "fpthrd_cond_init" is equivalent to passing a condition attribute object with all attributes set to their default values.) .SS "Initialize and Destroy" .B "fpthrd_condattr_init" initializes the condition attribute object .IR "attr" , and fills it with default values for the attributes. .B "fpthrd_condattr_destroy" uninitializes a condition attribute object, which must not be reused until it is reinitialized. .SS "Set and Get" Sharing of condition variables between processes is optionally supported by the POSIX standard. If your system supports cross-process synchronization, then the following routines will be available. .B "fpthrd_condattr_setpshared" sets the shared attribute .IR "attr " to " pshared" which is either .B "FPTHRD_PROCESS_SHARED" (any condition variable initialized with this attribute may be used from different processes) or .B "FPTHRD_PROCESS_PRIVATE" (only threads in the same process can use it). The shared condition variable must be visible to both processes and initialized to be cross-process by only one of these processes. .B "fpthrd_condattr_getpshared" retrieves the process sharing parameter for the condition variable attribute .I "attr" and returns it in .IR "pshared" . .SH NOTES While POSIX specifies two modes of sharing condition variables between processes, currently only process-private .RB "(" "FPTHRD_PROCESS_PRIVATE" ")" is supported. Attempting to initialize process-shared condition variables will yield undefined results. .SH "DIAGNOSTICS" All routines return 0 in the optional .I "ierr" on success and a non-zero error code on error. On error, .B "fpthrd_condattr_init" returns the following error codes: .RS .TP .B "ENOMEM" Insufficient memory. .TP .B "EAGAIN" Insufficient resources. .RE On error, .B "fpthrd_condattr_destroy" returns the following error code: .RS .TP .B "EINVAL" .I "attr" is invalid. .RE On error, .B "fpthrd_condattr_setpshared" returns the following error codes: .RS .TP .B "EINVAL" Either .IR "attr " or " pshared" is invalid .TP .B "ENOSYS" Shared memory condition variables are not supported. .RE On error, .B "fpthrd_condattr_getpshared" returns the following error code: .RS .TP .B "ENOSYS" Shared memory condition variables are not supported. .RE .SH "SEE ALSO" .BR "fpthrd_cond_init" (3F). SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_condattr_setpshared.3th' then echo shar: will not over-write existing file "'fpthrd_condattr_setpshared.3th'" else cat << "SHAR_EOF" > 'fpthrd_condattr_setpshared.3th' .so fpthrd_condattr_init.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_create.3th' then echo shar: will not over-write existing file "'fpthrd_create.3th'" else cat << "SHAR_EOF" > 'fpthrd_create.3th' .TH FPTHRD 3F "" "FPTHRD API" .SH NAME fpthrd_create, fpthrd_join, fpthrd_detach, fpthrd_exit, fpthrd_self, fpthrd_equal, fpthrd_once \- Thread creation and control .SH SYNOPSIS .B USE fpthrd .BI "CALL fpthrd_create(" thred ", " attr ", " .IB start_routine ", " arg ", " ierr ")" .BI "CALL fpthrd_join(" thred ", " exit_code " [, " .IB ierr "])" .BI "CALL fpthrd_detach(" thred " [, " ierr "])" .BI "CALL fpthrd_exit(" exit_code ")" .BI "CALL fpthrd_self(" thred ")" .BI "CALL fpthrd_equal(" t1 ", " t2 ", " .IB ierr ")" .BI "CALL fpthrd_once(" once_control ", " init_routine " [, " .IB ierr "])" .BI "TYPE(FPTHRD_T) :: " thred ", " t1 ", " t2 .br .BI "TYPE(FPTHRD_ATTR_T) :: " attr .br .BI "TYPE(FPTHRD_ONCE_T) :: " once_control .br .BI "EXTERNAL " start_routine ", " init_routine .br .BI "INTEGER :: " ierr ", " exit_code ", " how .SH DESCRIPTION .SS Create .B "fpthrd_create" creates a new thread of control that executes concurrently with the calling thread. The new thread applies the function .I "start_routine" passing it .I "arg" as the only argument. .I "arg" may be any legal Fortran type. The .I "attr" argument specifies thread attributes to be applied to the new thread. See .BR "fpthrd_attr_init" (3F) for a complete list of thread attributes. The .I "attr" argument can also be .BR "NULL" , in which case default attributes are used. On success, the identifier of the newly created thread is returned in the .I "thred" argument. .SS Join .B "fpthrd_join" suspends the execution of the calling thread until the thread identified by .I "thred" terminates, either by calling .B "fpthrd_exit" or by being cancelled. If .I "exit_code" is not .BR "NULL" , the integer return value of .I "thred" is stored in .IR "exit_code" . The return value of .I "thred" is either the argument it gave to .BR "fpthrd_exit" , or .B "FPTHRD_CANCELED" if .I "thred" was cancelled. The joined thread .I "thred" must be in the joinable state: it must not have been detached using .BR "fpthrd_detach" or the .B "FPTHRD_CREATE_DETACHED" attribute to .BR "fpthrd_create" . When a joinable thread terminates, its memory resources (thread descriptor and stack) are not deallocated until another thread performs .B "fpthrd_join" on it. Therefore, .B "fpthrd_join" must be called once for each joinable thread to avoid memory leaks. At most one thread can wait for the termination of a given thread. Calling .B "fpthrd_join" on a thread .I "thred" on which another thread is already waiting for termination returns an error. .B "fpthrd_join" is a cancellation point. If a thread is canceled while suspended in .BR "fpthrd_join" , the thread execution resumes immediately and the cancellation is executed without waiting for the thread .I "thred" to terminate. If cancellation occurs during .BR "fpthrd_join" , the thread .I "thred" remains not joined. If a thread becomes detached after another thread is waiting for it, the waiting thread awakes and returns an error. .SS Detach .B "fpthrd_detach" places the thread .I "thred" in the detached state. This guarantees that the memory resources consumed by .I "thred" will be freed immediately when .I "thred" terminates. However, this prevents other threads from synchronizing on the termination of .I "thred" using .BR "fpthrd_join" . A thread can be created initially in the detached state, using the .I "detachstate" attribute to .BR "fpthrd_create" . In contrast, .B "fpthrd_detach" applies to threads created in the joinable state, and which need to be put in the detached state later. After .B "fpthrd_detach" completes, subsequent attempts to perform .B "fpthrd_join" on .I "thred" will fail. If another thread is already joining the thread .I "thred" at the time .B "fpthrd_detach" is called, .B "fpthrd_detach" does nothing and leaves .I "thred" in the joinable state. .SS Exit .B "fpthrd_exit" terminates the execution of the calling thread. \" All cleanup handlers that have been set for the calling thread with \" .BR "fpthrd_cleanup_push" (3F) \" are executed in reverse order (the most recently pushed handler is executed first). The .I "exit_code" argument is the return value of the thread. It can be consulted from another thread using .BR "fpthrd_join" . The .B "fpthrd_exit" function never returns. .SS Self .B "fpthrd_self" will return the thread identifier for the calling thread. No error code parameter is needed since every execution stream has an associated thread identifier. .SS Equal .B "fpthrd_equal" determines if two thread identifiers refer to the same thread. A non-zero value is returned in .I "ierr" if .I "t1" and .I "t2" refer to the same thread. Otherwise, 0 is returned. .SS Once The purpose of .B "fpthrd_once" is to ensure that a section of code is only executed once. The .I "once_control" argument is a globally available variable which must be initialized to .BR "FPTHRD_ONCE_INIT" . The first time .B "fpthrd_once" is called with a given .I "once_control" argument, it calls .I "init_routine" with no argument and changes the value of the .I "once_control" variable to record that the associated routine has been executed. Subsequent calls to .B "fpthrd_once" with the same .I "once_control" argument do nothing. .SH DIAGNOSTICS All routines, except .B "fpthrd_self" and .B "fpthrd_equal" return 0 in .I "ierr" on success and a non-zero error code on error. No .I "ierr" parameter is needed for .BR "fpthrd_self" ; " fpthrd_equal " sets .I "ierr" based on equality of the two thread ID arguments as described above. The .I ierr argument is optional in all routines except .BR "fpthrd_create " and " fpthrd_equal" . If any of the following conditions occur, the .I "ierr" parameter of the .B "fpthrd_create" routine returns the corresponding errors: .RS .TP .B "EAGAIN" Not enough system resources to create a process for the new thread. .TP .B "EAGAIN" The maximum number of threads are already active. .TP .B "EINVAL" The specified attributes are invalid. .RE If any of the following conditions occur, the .I "ierr" parameter of the .B "fpthrd_join" and .B "fpthrd_detach" routines return the corresponding error: .RS .TP .B "ESRCH" No thread could be found corresponding to that specified by .IR "thred" . .TP .B "EINVAL" The thread .I "thred" has been detached. .TP .B "EINVAL" Another thread is already waiting on termination of .IR "thred" . .TP .B "EDEADLK" The .I "thred" argument refers to the calling thread (for .BR "fpthrd_join" ). .RE .SH "SEE ALSO" .BR "fpthrd_attr_init" (3F). SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_detach.3th' then echo shar: will not over-write existing file "'fpthrd_detach.3th'" else cat << "SHAR_EOF" > 'fpthrd_detach.3th' .so fpthrd_create.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_equal.3th' then echo shar: will not over-write existing file "'fpthrd_equal.3th'" else cat << "SHAR_EOF" > 'fpthrd_equal.3th' .so fpthrd_create.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_exit.3th' then echo shar: will not over-write existing file "'fpthrd_exit.3th'" else cat << "SHAR_EOF" > 'fpthrd_exit.3th' .so fpthrd_create.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_getschedparam.3th' then echo shar: will not over-write existing file "'fpthrd_getschedparam.3th'" else cat << "SHAR_EOF" > 'fpthrd_getschedparam.3th' .so fpthrd_setschedparam.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_join.3th' then echo shar: will not over-write existing file "'fpthrd_join.3th'" else cat << "SHAR_EOF" > 'fpthrd_join.3th' .so fpthrd_create.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_mutex_destroy.3th' then echo shar: will not over-write existing file "'fpthrd_mutex_destroy.3th'" else cat << "SHAR_EOF" > 'fpthrd_mutex_destroy.3th' .so fpthrd_mutex_init.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_mutex_init.3th' then echo shar: will not over-write existing file "'fpthrd_mutex_init.3th'" else cat << "SHAR_EOF" > 'fpthrd_mutex_init.3th' .TH FPTHRD_MUTEX 3F "" "FPTHRD API" .SH NAME fpthrd_mutex_init, fpthrd_mutex_lock, fpthrd_mutex_trylock, fpthrd_mutex_unlock, fpthrd_mutex_destroy \- Mutex creation and control .SH SYNOPSIS .B USE fpthrd .BI "CALL fpthrd_mutex_init(" mutex ", " mutexattr " [, " .IB ierr "])" .BI "CALL fpthrd_mutex_lock(" mutex " [, " ierr "])" .BI "CALL fpthrd_mutex_trylock(" mutex " [, " ierr "])" .BI "CALL fpthrd_mutex_unlock(" mutex " [, " ierr "])" .BI "CALL fpthrd_mutex_destroy(" mutex " [, " ierr "])" .BI "TYPE(FPTHRD_MUTEX_T) :: " mutex .br .BI "TYPE(FPTHRD_MUTEXATTR_T) :: " mutexattr .br .BI "INTEGER :: " ierr .SH DESCRIPTION A mutex is a MUTual EXclusion device, and is useful for protecting shared data structures from concurrent modifications, and implementing critical sections and monitors. A mutex has two possible states: unlocked (not owned by any thread), and locked (owned by one thread). A mutex can never be owned by multiple threads simultaneously. A thread attempting to lock a mutex that is already locked by another thread is suspended until after the owning thread unlocks the mutex first. .SS Initialize .B "fpthrd_mutex_init" initializes the mutex object .I "mutex" according to the mutex attributes specified in .IR "mutexattr" . If .I "mutexattr" is .BR "NULL" , default attributes are used instead. As with the C version of POSIX threads, variables of type .B "FPTHRD_MUTEX_T" can be initialized statically at definition with the parameter .B "FPTHRD_MUTEX_INITIALIZER". See .BR "fpthrd_mutexattr_init" (3F) for more information on mutex attributes and their initialization. .SS Lock .B "fpthrd_mutex_lock" locks the given mutex. If the mutex is currently unlocked, it becomes locked and owned by the calling thread, and .B "fpthrd_mutex_lock" returns immediately. If the mutex is already locked by another thread, .B "fpthrd_mutex_lock" suspends the calling thread until the mutex is unlocked. .SS "Try Lock" .B "fpthrd_mutex_trylock" behaves identically to .BR "fpthrd_mutex_lock" , except that it does not block the calling thread if the mutex is already locked by another thread (or by the calling thread). Instead, .B "fpthrd_mutex_trylock" returns immediately with the error code .BR "EBUSY" . .SS Unlock .B "fpthrd_mutex_unlock" unlocks the given mutex. The mutex is assumed to be locked and owned by the calling thread on entrance to .BR "fpthrd_mutex_unlock" . Threads may not unlock a mutex held by another thread. .SS Destroy .B "fpthrd_mutex_destroy" destroys a mutex object. The mutex must be unlocked on entrance. .SH CANCELLATION None of the mutex routines is a cancellation point, not even .BR "fpthrd_mutex_lock" , in spite of the fact that it can suspend a thread for arbitrary durations. This way, the status of mutexes at cancellation points is predictable, allowing cancellation handlers to unlock precisely those mutexes that need to be unlocked before the thread stops executing. Consequently, threads using deferred cancellation should never hold a mutex for extended periods of time. .SH "DIAGNOSTICS" .B "fpthrd_mutex_init" always returns 0 in the optional .I "ierr" while the other mutex routines return 0 on success and a non-zero error code on error. The .B "fpthrd_mutex_lock" routine returns the following error codes on error: .RS .TP .B "EINVAL" The mutex has not been properly initialized or has been destroyed. .TP .B "EDEADLK" The mutex is already locked by the calling thread. .RE The .B "fpthrd_mutex_trylock" routine returns the following error codes on error: .RS .TP .B "EBUSY" The mutex could not be acquired because it was currently locked. .TP .B "EINVAL" The mutex has not been properly initialized or has been destroyed. .RE The .B "fpthrd_mutex_unlock" routine returns the following error codes on error: .RS .TP .B "EINVAL" The mutex has not been properly initialized or has been destroyed. .TP .B "EPERM" The calling thread does not own the mutex. .RE The .B "fpthrd_mutex_destroy" routine returns the following error code on error: .RS .TP .B "EBUSY" The mutex is currently locked. .RE .SH "SEE ALSO" .BR "fpthrd_mutexattr_init" (3F), .BR "fpthrd_cancel" (3F). SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_mutex_lock.3th' then echo shar: will not over-write existing file "'fpthrd_mutex_lock.3th'" else cat << "SHAR_EOF" > 'fpthrd_mutex_lock.3th' .so fpthrd_mutex_init.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_mutex_trylock.3th' then echo shar: will not over-write existing file "'fpthrd_mutex_trylock.3th'" else cat << "SHAR_EOF" > 'fpthrd_mutex_trylock.3th' .so fpthrd_mutex_init.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_mutex_unlock.3th' then echo shar: will not over-write existing file "'fpthrd_mutex_unlock.3th'" else cat << "SHAR_EOF" > 'fpthrd_mutex_unlock.3th' .so fpthrd_mutex_init.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_mutexattr_destroy.3th' then echo shar: will not over-write existing file "'fpthrd_mutexattr_destroy.3th'" else cat << "SHAR_EOF" > 'fpthrd_mutexattr_destroy.3th' .so fpthrd_mutexattr_init.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_mutexattr_getprioceiling.3th' then echo shar: will not over-write existing file "'fpthrd_mutexattr_getprioceiling.3th'" else cat << "SHAR_EOF" > 'fpthrd_mutexattr_getprioceiling.3th' .so fpthrd_mutexattr_setprioceiling.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_mutexattr_getprotocol.3th' then echo shar: will not over-write existing file "'fpthrd_mutexattr_getprotocol.3th'" else cat << "SHAR_EOF" > 'fpthrd_mutexattr_getprotocol.3th' .so fpthrd_mutexattr_setprioceiling.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_mutexattr_getpshared.3th' then echo shar: will not over-write existing file "'fpthrd_mutexattr_getpshared.3th'" else cat << "SHAR_EOF" > 'fpthrd_mutexattr_getpshared.3th' .so fpthrd_mutexattr_init.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_mutexattr_init.3th' then echo shar: will not over-write existing file "'fpthrd_mutexattr_init.3th'" else cat << "SHAR_EOF" > 'fpthrd_mutexattr_init.3th' .TH FPTHRD_MUTEXATTR 3F "" "FPTHRD API" .SH NAME fpthrd_mutexattr_init, fpthrd_mutexattr_destroy, fpthrd_mutexattr_setpshared, fpthrd_mutexattr_getpshared \- Mutex initialization attributes .SH SYNOPSIS .B USE fpthrd .BI "CALL fpthrd_mutexattr_init(" attr " [, " ierr "])" .BI "CALL fpthrd_mutexattr_destroy(" attr " [, " ierr "])" .BI "CALL fpthrd_mutexattr_setpshared(" attr ", " pshared " [, " .IB ierr "])" .BI "CALL fpthrd_mutexattr_getpshared(" attr ", " pshared " [, " .IB ierr "])" .BI "TYPE(FPTHRD_MUTEXATTR_T) :: " attr .br .BI "INTEGER :: " pshared ", " ierr .SH DESCRIPTION Mutex attributes can be specified at mutex creation time, by passing a mutex attribute object as the second argument to .BR "fpthrd_mutex_init" (3F). (Passing .B "NULL" as the second parameter to .B "fpthrd_mutex_init" is equivalent to using a mutex attribute object with all attributes set to their default values.) .SS Initialize .B "fpthrd_mutexattr_init" allocates system resources for the mutex attribute object .I "attr" which is initialized with default values for the attributes. .SS Destroy .B "fpthrd_mutexattr_destroy" destroys a mutex attribute object and returns all resources used by the mutex attribute object. This .I "attr" must not be reused until it is reinitialized. .SS "Process Sharing" Sharing of mutexes between processes is optionally supported by the POSIX standard. The following routines are available within FPTHRD, but will return .B "ENOSYS" if the operation is not supported on your system. .B "fpthrd_mutexattr_setpshared" sets the shared attribute of .I "attr" to .I "pshared" which is either .B "FPTHRD_PROCESS_SHARED" (any mutex initialized with this attribute may be used from different processes) or .B "FPTHRD_PROCESS_PRIVATE" (only threads in the same process by only one of these processes). .B "fpthrd_mutexattr_getpshared" retrieves the process sharing parameter for the mutex attribute .I "attr" and returns it in .IR "pshared" . .SH "DIAGNOSTICS" .BR "fpthrd_mutexattr_init " and .B "fpthrd_mutexattr_destroy" always return 0 in the optional .IR "ierr" . Other mutex attribute initialization routines return 0 on success and a non-zero error code on error. On error, .B "fpthrd_mutexattr_setpshared" returns the following error codes: .RS .TP .B "EINVAL" Either .IR "ierr " or " pshared" is invalid. .TP .B "ENOSYS" Shared memory mutexes are not supported. .RE On error, .B "fpthrd_mutexattr_getpshared" returns the following error code: .RS .TP .B "ENOSYS" Shared memory mutexes are not supported. .RE .SH "SEE ALSO" .BR "fpthrd_mutex_init" (3F), .BR "fpthrd_mutex_lock" (3F), .BR "fpthrd_mutex_unlock" (3F). SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_mutexattr_setprioceiling.3th' then echo shar: will not over-write existing file "'fpthrd_mutexattr_setprioceiling.3th'" else cat << "SHAR_EOF" > 'fpthrd_mutexattr_setprioceiling.3th' .TH FPTHRD_MUTEXATTR 3F .SH NAME fpthrd_mutexattr_setprotocol, fpthrd_mutexattr_getprotocol, fpthrd_mutexattr_setprioceiling, fpthrd_mutexattr_getprioceiling \- Mutex scheduling attributes .SH SYNOPSIS .B USE fpthrd .BI "CALL fpthrd_mutexattr_setprotocol(" mattr ", " protocol .BI " [, " ierr "])" .BI "CALL fpthrd_mutexattr_getprotocol(" mattr ", " protocol .BI " [, " ierr "])" .BI "CALL fpthrd_mutexattr_setprioceiling(" mattr ", " prioceiling .BI " [, " ierr "])" .BI "CALL fpthrd_mutexattr_getprioceiling(" mattr ", " prioceiling .BI " [, " ierr "])" .BI "TYPE(FPTHRD_MUTEXATTR_T) :: " mattr .br .BI "INTEGER :: " protocol ", " prioceiling ", " ierr .SH DESCRIPTION Priority mutexes are optionally supported by the POSIX standard. The following routines are available in FPTHRD, but will return .B "ENOSYS" if your systems does not support them. Mutex attributes can be specified at mutex creation time, by passing a mutex attribute object as the second argument to .BR "fpthrd_mutex_init" (3F). Passing .B "NULL" is equivalent to using a mutex attribute object with all attributes set to their default values. .SS "Scheduling Protocol" .B "fpthrd_mutexattr_setprotocol" sets the protocol attribute of .I "mattr" of priority mutexes to .I "protocol" which is either .B "FPTHRD_PRIO_NONE" (no change in priority), .B "FPTHRD_PRIO_INHERIT " (inherit the prioroty of the parent thread) or .B "FPTHRD_PRIO_PROTECT" (use the predetermined ceiling priority). .B "fpthrd_mutexattr_getprotocol" returns the protocol attribute of .I "mattr" of priority mutexes and returns it in .IR "protocol" . Default value: .BR "FPTHRD_PRIO_NONE" . .SS "Priority Ceiling" .B "fpthrd_mutexattr_setprioceiling" sets the priority ceiling attribute of .I "mattr" to .I "prioceiling" which must be within the range of acceptable priorities. .B "fpthrd_mutexattr_getprioceiling" returns the current priority ceiling attribute of .I "mattr" in .IR "prioceiling" . .SH "DIAGNOSTICS" On success, .BR "fpthrd_mutexattr_setprotocol" " and " "fpthrd_mutexattr_getprotocol" return 0 in the optional .IR "ierr" . Otherwise, the following non-zero error codes are returned on error: .RS .TP .B "ENOTSUP" The value of .I "protocol" is unsupported. .TP .B "EINVAL" Either .IR "mattr " or " protocol" is invalid. .TP .B "EPERM" No privilege to perform this operation. .TP .B "ENOSYS" Priority mutexes are not supported. .RE On success, .BR "fpthrd_mutexattr_setprioceiling" " and " "fpthrd_mutexattr_getprioceiling" return 0 in the optional .IR "ierr" . Otherwise, the following non-zero error codes are returned on error: .RS .TP .B "EINVAL" Either .IR "mattr " or " protocol" is invalid. .TP .B "EPERM" No privilege for this operation. .TP .B "ENOSYS" Priority mutexes are not supported. .RE .SH "SEE ALSO" .BR "fpthrd_mutex_setprioceiling" (3F). SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_mutexattr_setprotocol.3th' then echo shar: will not over-write existing file "'fpthrd_mutexattr_setprotocol.3th'" else cat << "SHAR_EOF" > 'fpthrd_mutexattr_setprotocol.3th' .so fpthrd_mutexattr_setprioceiling.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_mutexattr_setpshared.3th' then echo shar: will not over-write existing file "'fpthrd_mutexattr_setpshared.3th'" else cat << "SHAR_EOF" > 'fpthrd_mutexattr_setpshared.3th' .so fpthrd_mutexattr_init.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_once.3th' then echo shar: will not over-write existing file "'fpthrd_once.3th'" else cat << "SHAR_EOF" > 'fpthrd_once.3th' .so fpthrd_create.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_sched_attr.3th' then echo shar: will not over-write existing file "'fpthrd_sched_attr.3th'" else cat << "SHAR_EOF" > 'fpthrd_sched_attr.3th' .TH FPTHRD_SCHED_ATTR 3F .SH NAME fpthrd_attr_setscope, fpthrd_attr_getscope, fpthrd_attr_setinheritsched, fpthrd_attr_getinheritsched, fpthrd_attr_setschedpolicy, fpthrd_attr_getschedpolicy, fpthrd_attr_setschedparam, fpthrd_attr_getschedparam \- Thread scheduling attributes .SH SYNOPSIS .B USE fpthrd .BI "CALL fpthrd_attr_setscope(" attr ", " scope " [, " .IB ierr "])" .BI "CALL fpthrd_attr_getscope(" attr ", " scope " [, " .IB ierr "])" .BI "CALL fpthrd_attr_setinheritsched(" attr ", " inherit " [, " .IB ierr "])" .BI "CALL fpthrd_attr_getinheritsched(" attr ", " inherit " [, " .IB ierr "])" .BI "CALL fpthrd_attr_setschedpolicy(" attr ", " schedpolicy " [, " .IB ierr "])" .BI "CALL fpthrd_attr_getschedpolicy(" attr ", " schedpolicy " [, " .IB ierr "])" .BI "CALL fpthrd_attr_setschedparam(" attr ", " schedparam " [, " .IB ierr "])" .BI "CALL fpthrd_attr_getschedparam(" attr ", " schedparam " [, " .IB ierr "])" .BI "TYPE(FPTHRD_ATTR_T) :: " attr .br .BI "INTEGER :: " inherit ", " schedpolicy ", " scope .BI ", " ierr .br .BI "TYPE(FSCHED_PARAM) :: " schedparam .SH DESCRIPTION Setting attributes for threads is achieved by filling a thread attribute object .I "attr" of type .BR "FPTHRD_ATTR_T" , then passing it as the second argument to .BR "fpthrd_create" (3F). (Passing .B "NULL" as the second paramter of .B "fpthrd_create" is equivalent to using a thread attribute object with all attributes set to their default values.) .BR "fpthrd_attr_init" (3F) initializes the thread attribute object .I "attr" and fills it with default values for the attributes. (The relevant default values for attributes are listed below.) Each attribute .I "attrname" (see below for a list of scheduling attributes) can be individually set using the routine .BI "fpthrd_attr_set" "attrname" and retrieved using the routine .BI "fpthrd_attr_get" "attrname." The following thread scheduling attributes .RI ( "attrname" ) are supported: .SS scope Define the scheduling contention scope for the created thread. The only value supported in the FPTHRD API is .BR "FPTHRD_SCOPE_PROCESS" . This means that scheduling contention occurs only between the threads of the running process: thread priorities are interpreted relative to the priorities of the other threads of the process, regardless of the priorities of other processes. The other possible value, .BR "FPTHRD_SCOPE_SYSTEM" , means that the threads contend for CPU time with all processes running on the machine. In particular, thread priorities are interpreted relative to the priorities of all other processes on the machine. Default value: .BR "FPTHRD_SCOPE_PROCESS" . .SS inheritsched Define from where the scheduling policy and scheduling parameters for the newly created thread are determined. The two possible values for this attribute are .B "FPTHRD_EXPLICIT_SCHED" (the values of the .I "schedpolicy" and .I "schedparam" attributes are used for the new thread) and .BR "FPTHRD_INHERIT_SCHED" (the attributes are inherited from the parent thread). Default value: .BR "FPTHRD_EXPLICIT_SCHED" . .SS schedpolicy Define the scheduling policy for the thread. One of .RS .TP .B "FSCHED_FIFO" allows a thread to run until it blocks, it exits or there is a higher priority thread that can run. When a thread is preempted, it moves to the head of its priorty queue and when a blocked thread becomes runnable, it moves to the tail of its priority queue. .TP .B "FSCHED_RR" is the same as .B "FSCHED_FIFO" except that a thread will automatically move to the tail of its priority queue after running a fixed amount of time. .TP .B "FSCHED_OTHER" behaves exactly like .BR "FSCHED_RR" . .RE Default value: .BR "FSCHED_OTHER" . The scheduling policy of a thread can be changed after creation with .BR "fpthrd_setschedparam" (3F). .SS schedparam Define the scheduling parameters (essentially, the scheduling priority) for the thread. The scheduling parameters of a thread can be changed after creation with .BR "fpthrd_setschedparam" (3F). .SH "DIAGNOSTICS" All routines return 0 in the optional .I ierr on success and a non-zero error code on error. On success, the .BI "fpthrd_attr_get" "attrname" routines also return the current value of the attribute .I "attrname" in their second argument. The .B "fpthrd_attr_setscope" routine returns the following error codes on error: .RS .TP .B "EINVAL" The specified .I "scope" is not one of .B "FPTHRD_SCOPE_SYSTEM" or .BR "FPTHRD_SCOPE_PROCESS" . .TP .B "ENOTSUP" The specified .I "scope" is .B "FPTHRD_SCOPE_SYSTEM" (not supported). .RE The .B "fpthrd_attr_setinheritsched" routine returns the following error code on error: .RS .TP .B "EINVAL" The specified .I "inherit" is not one of .B "FPTHRD_INHERIT_SCHED" or .BR "FPTHRD_EXPLICIT_SCHED" . .RE The .B "fpthrd_attr_setschedpolicy" routine returns the following error code on error: .RS .TP .B "EINVAL" The specified .I "schedpolicy" is not one of .BR "FSCHED_OTHER" , .BR "FSCHED_FIFO" , or .BR "FSCHED_RR" . .RE The .B "fpthrd_attr_setschedparam" routine returns the following error code on error: .RS .TP .B "EINVAL" The priority specified in .I "schedparam" is outside the range of allowed priorities for the scheduling policy currently in .IR "attr" . .RE .SH "SEE ALSO" .BR "fpthrd_create" (3F), .BR "fpthrd_attr_init" (3F), .BR "fpthrd_setschedparam" (3F). SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_self.3th' then echo shar: will not over-write existing file "'fpthrd_self.3th'" else cat << "SHAR_EOF" > 'fpthrd_self.3th' .so fpthrd_create.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_setcancelstate.3th' then echo shar: will not over-write existing file "'fpthrd_setcancelstate.3th'" else cat << "SHAR_EOF" > 'fpthrd_setcancelstate.3th' .so fpthrd_cancel.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_setcanceltype.3th' then echo shar: will not over-write existing file "'fpthrd_setcanceltype.3th'" else cat << "SHAR_EOF" > 'fpthrd_setcanceltype.3th' .so fpthrd_cancel.3th SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_setschedparam.3th' then echo shar: will not over-write existing file "'fpthrd_setschedparam.3th'" else cat << "SHAR_EOF" > 'fpthrd_setschedparam.3th' .TH FPTHRD_SETSCHEDPARAM 3F "" "FPTHRD API" .SH NAME fpthrd_setschedparam, fpthrd_getschedparam \- Control thread scheduling parameters .SH SYNOPSIS .B USE fpthrd .BI "CALL fpthrd_setschedparam(" target_thread ", " policy ", " .IB param " [, " ierr "])" .BI "CALL fpthrd_getschedparam(" target_thread ", " policy ", " .IB param " [, " ierr "])" .BI "TYPE(FPTHRD_T) :: " target_thread .br .BI "INTEGER :: " policy ", " ierr .br .BI "TYPE(FSCHED_PARAM) :: " param .SH DESCRIPTION .B "fpthrd_setschedparam" sets the scheduling parameters for the thread .I "target_thread" as indicated by .I "policy" and .IR "param" . .I "policy" can be either .RS .TP .B "FSCHED_FIFO" allows a thread to run until it blocks, it exits or there is a higher priority thread that can run. When a thread is preempted, it moves to the head of its priority queue and when a blocked thread becomes runnable, it moves to the tail of its priority queue. .TP .B "FSCHED_RR" is the same as .B "FSCHED_FIFO" except that a thread will automatically move to the tail of its priority queue after running a fixed amount of time. .TP .B "FSCHED_OTHER" behaves exactly like .BR "FSCHED_RR" . .RE .B "fpthrd_getschedparam" retrieves the scheduling policy and scheduling parameters for the thread .I "target_thread" and returns them in .I "policy" and .IR "param" , respectively. .SH "DIAGNOSTICS" .B "fpthrd_setschedparam" and .B "fpthrd_getschedparam" return 0 in .IR "ierr " on success and a non-zero error code on error. On error, .B "fpthrd_setschedparam" returns the following error codes: .RS .TP .B "EINVAL" .I "policy" is not one of .BR "FSCHED_OTHER" , .BR "FSCHED_RR" , .BR "FSCHED_FIFO" . .TP .B "EINVAL" The priority value specified by .I "param" is not valid for the specified policy. .TP .B "ESRCH" The .I "target_thread" is invalid or has already terminated. .TP .B "EFAULT" .I "param" points outside the process memory space. .RE On error, .B "fpthrd_getschedparam" returns the following error code: .RS .TP .B "ESRCH" The .I "target_thread" is invalid or has already terminated. .RE .SH "SEE ALSO" .BR "fpthrd_attr_setschedpolicy" (3F), .BR "fpthrd_attr_setschedparam" (3F). SHAR_EOF fi # end of overwriting check if test -f 'fpthrd_testcancel.3th' then echo shar: will not over-write existing file "'fpthrd_testcancel.3th'" else cat << "SHAR_EOF" > 'fpthrd_testcancel.3th' .so man3/fpthread_cancel.3th SHAR_EOF fi # end of overwriting check cd .. if test -f 'README' then echo shar: will not over-write existing file "'README'" else cat << "SHAR_EOF" > 'README' In order to build the FPTHRD library files: 1. Change to the source directory % cd src 2. Build the object files % build XXXXX where XXXXX is one of the following, depending upon the execution platform CPQ -- Compaq Tru64 SUN -- SUN Solais IBM -- IBM AIX Power 3 SGI -- SGI Origin running IRIX SGI64 -- SGI Origin running IRIX with 64-bit addressing 3. Object and module files will be placed in lib subdirectory. *************** To build test and benchmark executables: 1. Build FPTHRD files (see above) 2. Change to tests directory: % cd tests 3. Build the test executable files % make -f Makefile.XXXXXX where XXXXX is one of the following, depending upon the execution platform origin -- SGI Origin 2000 power3 -- IBM Power3 SMP sun -- SUN Enterprise System cpq -- Compaq ES40 System *NOTE* Be sure the BITS make variable match those used in step 1. Also remove any old copies of object files or module output. 4. Run executables test1, test2, test3, and test4. All codes passed their tests when this work was submitted to ACM-TOMS for publication. The *critical* step in using threads on the SUN is including the -stackvar flag. Use it on the compile and linking steps. Codes won't usually work without this flag. Last edited by C. P. Breshears, 22 JAN 2002. Last edited by R. J. Hanson, 13 December 2001. SHAR_EOF fi # end of overwriting check cd .. if test ! -d 'Fortran90' then mkdir 'Fortran90' fi cd 'Fortran90' if test ! -d 'Sp' then mkdir 'Sp' fi cd 'Sp' if test ! -d 'Drivers' then mkdir 'Drivers' fi cd 'Drivers' if test -f 'Makefile.cpq' then echo shar: will not over-write existing file "'Makefile.cpq'" else cat << "SHAR_EOF" > 'Makefile.cpq' #!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! #!! !!! #!! This program is furnished by the U.S. Army Engineer Research and !!! #!! Development Center, Major Shared Resource Center (ERDC MSRC) "as is" !!! #!! and is accepted and used by the recipient with the express !!! #!! understanding that the Government makes no warranties, expressed or !!! #!! implied, concerning the accuracy, completeness, reliability, usability !!! #!! or suitability for any particular purpose of the information and data !!! #!! within this program or furnished in connection therewith, and the !!! #!! Government shall be under no liability whatsoever to any person by !!! #!! reason of any use made thereof. This program belongs to the U.S. !!! #!! Government; therefore, the recipient further agrees not to assert any !!! #!! proprietary rights therein or to represent the source code to anyone !!! #!! as other than a Government program. !!! #!! !!! #!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! # #!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! #!! Authors: !!! #!! !!! #!! Richard J. Hanson (koolhans@rice.edu) !!! #!! Rice University, Rice Center for High Performance Software Research !!! #!! !!! #!! Clay P. Breshears (clay.breshears@intel.com) !!! #!! KAI Software, a division of Intel Americas, Inc. !!! #!! !!! #!! Henry A. Gabb (henry.gabb@intel.com) !!! #!! KAI Software, a division of Intel Americas, Inc. !!! #!! !!! #!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! # Fortran compiler FC = f95 # Directory to store library files FLIBPATH = ../lib # FPTHRD library files FLIBS = $(FLIBPATH)/fpthrd.o $(FLIBPATH)/ptf90.o # Library files needed for linking to executable LIBS = $(FLIBS) -lpthread # Directory for FPTHRD modules MODULE_DIR = -I$(FLIBPATH) # Compiler optimization flags OPTS = -O3 -ansi # Compiled module file suffix MODULES = mod # This flag should always be used with code on Compaq. ALIGN = -align rec8byte # Fortran compilation flags FFLAGS = $(OPTS) $(ALIGN) $(MODULE_DIR) .f.o: cp $< $*.f90 $(FC) $(FFLAGS) -c $*.f90 -o $@ rm -f $*.f90 include make.inc SHAR_EOF fi # end of overwriting check if test -f 'Makefile.origin' then echo shar: will not over-write existing file "'Makefile.origin'" else cat << "SHAR_EOF" > 'Makefile.origin' #!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! #!! !!! #!! This program is furnished by the U.S. Army Engineer Research and !!! #!! Development Center, Major Shared Resource Center (ERDC MSRC) "as is" !!! #!! and is accepted and used by the recipient with the express !!! #!! understanding that the Government makes no warranties, expressed or !!! #!! implied, concerning the accuracy, completeness, reliability, usability !!! #!! or suitability for any particular purpose of the information and data !!! #!! within this program or furnished in connection therewith, and the !!! #!! Government shall be under no liability whatsoever to any person by !!! #!! reason of any use made thereof. This program belongs to the U.S. !!! #!! Government; therefore, the recipient further agrees not to assert any !!! #!! proprietary rights therein or to represent the source code to anyone !!! #!! as other than a Government program. !!! #!! !!! #!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! # #!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! #!! Authors: !!! #!! !!! #!! Richard J. Hanson (koolhans@rice.edu) !!! #!! Rice University, Rice Center for High Performance Software Research !!! #!! !!! #!! Clay P. Breshears (clay.breshears@intel.com) !!! #!! KAI Software, a division of Intel Americas, Inc. !!! #!! !!! #!! Henry A. Gabb (henry.gabb@intel.com) !!! #!! KAI Software, a division of Intel Americas, Inc. !!! #!! !!! #!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! # Fortran compiler FC = f90 # Application Binary Interface (ABI) compilation flag # Be sure library compilation matches chosen flag # For 64 bit version use make -f Makefile.origin BITS=-64, which overrides 32 bit version. # The module FPTHRD and wrapper C code must be compiled with BITS=-64, in this case. BITS = -n32 # Directory to store library files FLIBPATH = ../lib # FPTHRD library files FLIBS = $(FLIBPATH)/fpthrd.o $(FLIBPATH)/ptf90.o # Library files needed for linking to executable LIBS = $(FLIBS) -lpthread # Include directory for FPTHRD modules INCLUDE_DIR = -I$(FLIBPATH) # Compiler optimzation flags OPTS = -O2 # Compiled module file suffix MODULES = mod # Fortran compilation flags FFLAGS = $(BITS) $(OPTS) $(INCLUDE_DIR) # Fortran loader flags FLOADFLAGS = $(BITS) .f.o: cp $< $*.f90 $(FC) $(FFLAGS) -c $*.f90 -o $@ rm -f $*.f90 include make.inc SHAR_EOF fi # end of overwriting check if test -f 'Makefile.power3' then echo shar: will not over-write existing file "'Makefile.power3'" else cat << "SHAR_EOF" > 'Makefile.power3' #!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! #!! !!! #!! This program is furnished by the U.S. Army Engineer Research and !!! #!! Development Center, Major Shared Resource Center (ERDC MSRC) "as is" !!! #!! and is accepted and used by the recipient with the express !!! #!! understanding that the Government makes no warranties, expressed or !!! #!! implied, concerning the accuracy, completeness, reliability, usability !!! #!! or suitability for any particular purpose of the information and data !!! #!! within this program or furnished in connection therewith, and the !!! #!! Government shall be under no liability whatsoever to any person by !!! #!! reason of any use made thereof. This program belongs to the U.S. !!! #!! Government; therefore, the recipient further agrees not to assert any !!! #!! proprietary rights therein or to represent the source code to anyone !!! #!! as other than a Government program. !!! #!! !!! #!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! # #!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! #!! Authors: !!! #!! !!! #!! Richard J. Hanson (koolhans@rice.edu) !!! #!! Rice University, Rice Center for High Performance Software Research !!! #!! !!! #!! Clay P. Breshears (clay.breshears@intel.com) !!! #!! KAI Software, a division of Intel Americas, Inc. !!! #!! !!! #!! Henry A. Gabb (henry.gabb@intel.com) !!! #!! KAI Software, a division of Intel Americas, Inc. !!! #!! !!! #!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! # Fortran compiler FC = xlf90_r # Fortran Preprocessor flags #FCPP = -WF,-DIBM # Directory of FPTHRD library files FLIBPATH = ../lib # FPTHRD library files FLIBS = $(FLIBPATH)/fpthrd.o $(FLIBPATH)/ptf90.o # Library files needed for linking to executable LIBS = $(FLIBS) # Include directory for FPTHRD modules INCLUDE_DIR = -I$(FLIBPATH) # Compiler optimzation flags #OPTS = -O2 -qarch=pwr3 -qtune=pwr3 # Compiled module file suffix MODULES = mod # Fortran compilation flags FFLAGS = $(FCPP) $(OPTS) $(INCLUDE_DIR) # Fortran loader flags FLOADFLAGS = $(OPTS) $(INCLUDE_DIR) .f.o: cp $*.f $*.F $(FC) $(FFLAGS) -c -o $@ $*.F rm -f $*.F include make.inc SHAR_EOF fi # end of overwriting check if test -f 'Makefile.sun' then echo shar: will not over-write existing file "'Makefile.sun'" else cat << "SHAR_EOF" > 'Makefile.sun' #!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! #!! !!! #!! This program is furnished by the U.S. Army Engineer Research and !!! #!! Development Center, Major Shared Resource Center (ERDC MSRC) "as is" !!! #!! and is accepted and used by the recipient with the express !!! #!! understanding that the Government makes no warranties, expressed or !!! #!! implied, concerning the accuracy, completeness, reliability, usability !!! #!! or suitability for any particular purpose of the information and data !!! #!! within this program or furnished in connection therewith, and the !!! #!! Government shall be under no liability whatsoever to any person by !!! #!! reason of any use made thereof. This program belongs to the U.S. !!! #!! Government; therefore, the recipient further agrees not to assert any !!! #!! proprietary rights therein or to represent the source code to anyone !!! #!! as other than a Government program. !!! #!! !!! #!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! # #!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! #!! Authors: !!! #!! !!! #!! Richard J. Hanson (koolhans@rice.edu) !!! #!! Rice University, Rice Center for High Performance Software Research !!! #!! !!! #!! Clay P. Breshears (clay.breshears@intel.com) !!! #!! KAI Software, a division of Intel Americas, Inc. !!! #!! !!! #!! Henry A. Gabb (henry.gabb@intel.com) !!! #!! KAI Software, a division of Intel Americas, Inc. !!! #!! !!! #!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! # Fortran compiler FC = f90 # Directory to store library files FLIBPATH = ../lib # FPTHRD library files FLIBS = $(FLIBPATH)/fpthrd.o $(FLIBPATH)/ptf90.o # Library files needed for linking to executable LIBS = $(FLIBS) -lpthread # Directory for FPTHRD modules MODULE_DIR = -M$(FLIBPATH) # Compiler optimzation flags OPTS = -O3 # Compiled module file suffix MODULES = mod # Fortran will use the stack for local variables # This flag should always be used with threaded code on SUN. FLOADFLAGS = -stackvar # Fortran compilation flags FFLAGS = $(OPTS) $(MODULE_DIR) $(FLOADFLAGS) .f.o: cp $< $*.f90 $(FC) $(FFLAGS) -c $*.f90 -o $@ rm -f $*.f90 include make.inc SHAR_EOF fi # end of overwriting check if test -f 'bench1.f' then echo shar: will not over-write existing file "'bench1.f'" else cat << "SHAR_EOF" > 'bench1.f' ! Last change: CPB 22 JAN 2002 11:12 am ! Last change: RH 25 JAN 2002 2:22 pm ! Benchmarking elementary use of Pthreads. Print summary of tests. ! This code is part of the package "A Fortran Interface to Posix Threads," to be ! published in ACM-TOMS. Authors: R. Hanson, C. Breshears, and H. Gabb. ! This is bench1.f90. MODULE global_test2 USE fpthrd IMPLICIT NONE ! These are control values used in the tests. INTEGER test_number, thread_counter ! This is the number of threads launched at one time. INTEGER, PARAMETER :: NTHREADS=1023 INTEGER, PARAMETER :: NTRIES = 16 INTEGER id_no(NTHREADS) TYPE(FPTHRD_t) test_id(NTHREADS), first_id TYPE(FPTHRD_attr_t) attribute, start_attr TYPE(FPTHRD_mutex_t) cancel_mutex, recursion_mutex, sum_mutex TYPE(FPTHRD_once_t) :: testing_once=FPTHRD_ONCE_INIT TYPE(FPTHRD_cond_t) launch_done TYPE(FSCHED_PARAM) param TYPE(fsize_t) stacksize ! Declare a derived type that will carry the problem dope. ! These are the arguments of a dot product function. TYPE FUNCTION_ARGUMENTS INTEGER N REAL, DIMENSION(:,:), POINTER :: SMATRIX REAL, DIMENSION(:), POINTER :: SX INTEGER INCY REAL, dimension(:), POINTER :: SY INTEGER ROW_INDEX END TYPE TYPE(FUNCTION_ARGUMENTS) inb(NTHREADS), INA, INC interface SUBROUTINE FSGEMV (N, SMATRIX, SX, SY, ROW_START, ROW_END) IMPLICIT NONE INTEGER N, ROW_START, ROW_END REAL, POINTER, DIMENSION(:) :: SMATRIX(:,:), SX, SY END SUBROUTINE SUBROUTINE TEST6(NUMBER) INTEGER NUMBER END SUBROUTINE SUBROUTINE ONCE6() END SUBROUTINE RECURSIVE SUBROUTINE test7(LIMITS) INTEGER LIMITS(2) END SUBROUTINE RECURSIVE SUBROUTINE test8(LIMITS) INTEGER LIMITS(2) END SUBROUTINE end interface END MODULE SUBROUTINE FSGEMV (N, SMATRIX, SX, SY, COL_START, COL_END) USE global_test2, only : sum_mutex, fpthrd_mutex_unlock, fpthrd_mutex_lock IMPLICIT NONE INTEGER N, I, J, L, COL_START, COL_END, status REAL, pointer :: SMATRIX(:,:), SX(:) REAL, pointer :: SY(:) REAL T(N) IF(COL_START <= 0) RETURN IF(COL_END > N) RETURN IF(COL_END < COL_START) RETURN T=0E0 L=IAND(COL_END-COL_START+1,7) DO J=0,L-1 DO I=1,N T(I)=T(I)+smatrix(I,COL_START+J)*SX(COL_START+J) END DO END DO DO J=COL_START+L, COL_END, 8 DO I=1,N T(I)=T(I)+smatrix(I,J)*SX(J) +smatrix(I,J+1)*SX(J+1) +smatrix(I,J+2)*SX(J+2) & +smatrix(I,J+3)*SX(J+3) +smatrix(I,J+4)*SX(J+4)+smatrix(I,J+5)*SX(J+5) & +smatrix(I,J+6)*SX(J+6)+smatrix(I,J+7)*SX(J+7) END DO END DO call fpthrd_mutex_lock(sum_mutex, status) DO I=1,N SY(I)=SY(I)+T(I) END DO call fpthrd_mutex_unlock(sum_mutex, status) END SUBROUTINE SUBROUTINE FSDSDOT (N, SMATRIX, SX, INCY, SY, ROW_INDEX) IMPLICIT NONE INTEGER N, INCY, J, Q, ROW, ROW_INDEX REAL, pointer :: SMATRIX(:,:), SX(:) REAL, pointer :: SY(:) DOUBLE PRECISION T ROW=ROW_INDEX T=0D0 Q=1 DO J=1,N T=T+SMATRIX(ROW, J)*SX(Q) Q=Q+INCY END DO SY(ROW)=T END SUBROUTINE subroutine once6() use global_test2, dummy => once6 implicit none ! Use with FPTHRD_once() to initialize any data element. integer status recursion_mutex=FPTHRD_MUTEX_INITIALIZER sum_mutex =FPTHRD_MUTEX_INITIALIZER test_number=test_number+1 call ftest_comment(test_number, ". Once initializing a mutex that is used later.") end subroutine subroutine test6(arg_in) use global_test2, dummy => test6 implicit none INTERFACE SUBROUTINE FSDSDOT (N, SMATRIX, SX, INCY, SY, ROW_INDEX) INTEGER N, INCY, ROW_INDEX REAL, POINTER, DIMENSION(:) :: SMATRIX(:,:), SX, SY END SUBROUTINE END INTERFACE integer status, value, arg_in, I call FPTHRD_once (testing_once, once6, status) call ferr_abort(test_number, status, "starting once function for thread data initialization") I=arg_in ! Use the structure holding the arguments for this function. call fsdsdot (inb(I) % n, inb(I) % SMATRIX, inb(I) % SX, inb(I) % incy, inb(I) % SY, inb(I)% row_INDEX) end subroutine recursive subroutine test7(LIMITS) use global_test2, my_test=>test7 ! Symbol is reset to a dummy. Avoids conflict. implicit none INTEGER :: IDEAL, K, J, LIMITS(2), LIMITS_L(2), LIMITS_R(2), status TYPE(FPTHRD_T) THREAD_L, THREAD_R call FPTHRD_mutex_lock(recursion_mutex, status) call ferr_abort(test_number, status, " locking mutex in test7") K=LIMITS(2)-LIMITS(1)+1;J=(LIMITS(1)+LIMITS(2))/2 ! The problem limits are split into two equally sized groups. LIMITS_L=LIMITS;LIMITS_R=LIMITS LIMITS_L(2)=J;LIMITS_R(1)=J+1 call FPTHRD_mutex_unlock(recursion_mutex, status) call ferr_abort(test_number, status, " unlocking mutex in test7") IDEAL=(INA%N+7)/8 IF(K <= IDEAL) THEN ! This is where the work actually gets done. The above value of IDEAL is ! problem dependent. CALL FSGEMV (INA % N, INA % SMATRIX, INA % SX, INA % SY, LIMITS(1), LIMITS(2)) ELSE call FPTHRD_create(THREAD_L, attribute, my_test, limits_l, status) call ferr_abort(test_number, status, " recursive create-L in test7") call FPTHRD_create(THREAD_R, attribute, my_test, limits_r, status) call ferr_abort(test_number, status, " recursive create-R in test7") call FPTHRD_join(THREAD_L, NULL, status) call ferr_abort(test_number, status, " recursive join-L in test7") call FPTHRD_join(THREAD_R, NULL, status) call ferr_abort(test_number, status, " recursive join-R in test7") END IF END SUBROUTINE recursive subroutine test8(LIMITS) use global_test2, my_test=>test8 ! Symbol is reset to a dummy. Avoids conflict. implicit none INTEGER :: IDEAL, I, J, K, LIMITS(2), LIMITS_L(2), LIMITS_R(2), status TYPE(FPTHRD_T) THREAD_L, THREAD_R call FPTHRD_mutex_lock(recursion_mutex, status) call ferr_abort(test_number, status, " locking mutex in test7") K=LIMITS(2)-LIMITS(1)+1;J=(LIMITS(1)+LIMITS(2))/2 ! The problem limits are split into two equally sized groups. LIMITS_L=LIMITS;LIMITS_R=LIMITS LIMITS_L(2)=J;LIMITS_R(1)=J+1 call FPTHRD_mutex_unlock(recursion_mutex, status) call ferr_abort(test_number, status, " unlocking mutex in test7") IDEAL=(INA%N+7)/8 IF(K <= IDEAL) THEN ! This is where the work actually gets done. The above value of IDEAL is ! problem dependent. DO I=1,INA%N DO J=max(1,limits(1)),min(ina%n,limits(2)) INC % SMATRIX(I,J)=INA % smatrix(J,I) END DO END DO ELSE call FPTHRD_create(THREAD_L, attribute, my_test, limits_l, status) call ferr_abort(test_number, status, " recursive create-L in test7") call FPTHRD_create(THREAD_R, attribute, my_test, limits_r, status) call ferr_abort(test_number, status, " recursive create-R in test7") call FPTHRD_join(THREAD_L, NULL, status) call ferr_abort(test_number, status, " recursive join-L in test7") call FPTHRD_join(THREAD_R, NULL, status) call ferr_abort(test_number, status, " recursive join-R in test7") END IF END SUBROUTINE program benchmain1 USE global_test2 implicit none REAL, POINTER :: matrix_a(:,:), matrix_b(:,:), vector(:),y_serial(:),y_thread(:) REAL errnorm, norm, temp integer create_state, i, j, k, L, n, status, value, LIMITS(2), schedule_value INTEGER TIMEE(3), TIMES(3) call FPTHRD_setconcurrency(NTHREADS+1, STATUS) ! Initialize mutex and condition variable. cancel_mutex=FPTHRD_MUTEX_INITIALIZER launch_done =FPTHRD_COND_INITIALIZER ! Test 6. Start a peer function that calls a library function. Arguments ! are packed into a derived type. N=NTHREADS ! No claims of randomness are made for this sequence. It is used to generate ! a non-repeatable sequence of matrix and vector values. ALLOCATE(MATRIX_A(N,N), VECTOR(N), Y_SERIAL(N), Y_THREAD(N)) call random_number(matrix_a) call random_number(vector) DO J=1,N vector(J)=2e0*vector(J)-1e0 END DO ! This value for stacksize is used only for a test. call fpthrd_set_fsize(64000, stacksize) call FPTHRD_attr_init(attribute, status) call FPTHRD_attr_setstacksize(attribute, stacksize, status) ! Use threads to compute each row (times) vector concurrently. DO I=1,N ! This is a typical situation: Use a structure to pack all arguments into one ! object. Then pass the peer code that object. It unpacks the structure to get ! the arguments. inb(I) % n=n;inb(I) % SMATRIX=> matrix_a; inb(I) % SX=>vector;inb(I) % incy=1;inb(I) % SY=>y_thread; inb(I) % row_index=I ID_NO(I)=I ! Create the set of threads for the product. call FPTHRD_create (test_id(i), attribute, test6, ID_NO(I), status) call ferr_abort (test_number, status, " creating threads") END DO DO I=1,NTHREADS call FPTHRD_join(test_id(i), NULL, status) call ferr_abort(test_number, status, " joining a single thread") END DO ! Compute the matrix-vector product for comparison. CALL SYSTEM_CLOCK(TIMES(1)) DO L=1,NTRIES y_serial=0e0 do j=1,n do i=1,n y_serial(i)=y_serial(i)+matrix_a(I,j)*vector(j) end do end do END DO CALL SYSTEM_CLOCK(TIMEE(1)) CALL SYSTEM_CLOCK(TIMES(2)) DO J=1,NTRIES ! Time the intrinsic matrix-vector multiply, provided with Fortran 90. y_serial=matmul(matrix_a, vector) END DO CALL SYSTEM_CLOCK(TIMEE(2)) errnorm=sum((y_serial-y_thread)**2) norm=sum(y_serial**2) ! The results are correct even if they do not completely agree. ! This test will fail only with a blunder. Small relative errors will be allowed. test_number=test_number+1 if(errnorm <= EPSILON(NORM)*norm) THEN call ftest_comment (test_number, ". Matrix-vector product with each entry using a separate thread.") else status=1 call ferr_abort(test_number,status," Serial and threaded matrix-vector product gave different results") END IF call skip ! Test 6 is complete. */ ! Use threads to compute each row (times) vector concurrently. ! This exericse uses one thread to call a routine. The routine uses divide and ! conquer (recursion) to reduce the problem size to one with 'good' properties. ina % N=n;ina % SMATRIX=> matrix_a;ina % SX=>vector;ina % SY=>y_thread call FPTHRD_attr_setinheritsched(attribute, FPTHRD_EXPLICIT_SCHED, status) call ferr_abort(test_number, status, " setting inherit schedule") call FPTHRD_attr_setschedpolicy(attribute, FSCHED_FIFO, status) ! This may not be supported: IF(status /= ENOTSUP) call ferr_abort(test_number, status, " setting schedule policy") call FPTHRD_attr_setinheritsched(attribute, FPTHRD_INHERIT_SCHED, status) ! This may not be supported: IF(status /= ENOTSUP) call ferr_abort(test_number, status, " setting inherit schedule") schedule_value=50 call fpthrd_set_fsched_param(schedule_value, param) call fpthrd_attr_setschedparam(attribute, param, status) call ferr_abort(test_number, status, " setting schedule parameter") ! Create the thread for the product. CALL SYSTEM_CLOCK(TIMES(3)) DO J=1,NTRIES LIMITS=(/1,N/) y_thread=0e0 call FPTHRD_create (first_id, attribute, test7, LIMITS, status) call ferr_abort (test_number, status, " creating a recursive thread") call FPTHRD_join(first_id, NULL, status) call ferr_abort(test_number, status, " joining a single recursive thread") END DO CALL SYSTEM_CLOCK(TIMEE(3)) ! Check results for correctness: errnorm=sum((y_serial-y_thread)**2) norm=sum(y_serial**2) ! The results are correct even if they do not completely agree. ! This test will fail only with a blunder. Small relative errors will be allowed. test_number=test_number+1 if(errnorm <= EPSILON(NORM)*norm) THEN call ftest_comment (test_number, ". Matrix-vector product with recursive threads.") else status=1 call ferr_abort(test_number,status," Serial and threaded matrix-vector product gave different results") END IF call skip ! Test 7 is complete. call system_clock(count_rate=I) write(*,*) " Matrix size, repeats ", NTHREADS, NTRIES write(*,*) " 0. Clock Rate, Ticks per S. ", I write(*,*) " 1. Ordinary product time = ", TIMEE(1)-TIMES(1) write(*,*) " 2. Matmul product time = ", TIMEE(2)-TIMES(2) write(*,*) " 3. THREADED product time = ", TIMEE(3)-TIMES(3) write(*,*) "Matrix-vector Time ratios: [1.]/[3.]: ", & REAL(TIMEE(1)-TIMES(1))/REAL(TIMEE(3)-TIMES(3))," [2.]/[3.]: ", REAL(TIMEE(2)-TIMES(2))& /REAL(TIMEE(3)-TIMES(3)) ALLOCATE(matrix_b(N,N)) CALL SYSTEM_CLOCK(TIMES(1)) DO K=1,NTRIES DO J=1,N DO I=1,N matrix_b(j,i)=matrix_a(i,j) end do end do END DO CALL SYSTEM_CLOCK(TIMEE(1)) CALL SYSTEM_CLOCK(TIMES(2)) DO J=1,NTRIES matrix_b=transpose(matrix_a) END DO CALL SYSTEM_CLOCK(TIMEE(2)) inc % SMATRIX=> matrix_b CALL SYSTEM_CLOCK(TIMES(3)) DO J=1,NTRIES LIMITS=(/1,N/) y_thread=0e0 call FPTHRD_create (first_id, attribute, test8, LIMITS, status) call ferr_abort (test_number, status, " creating a recursive thread") call FPTHRD_join(first_id, NULL) call ferr_abort(test_number, status, " joining a single recursive thread") END DO CALL SYSTEM_CLOCK(TIMEE(3)) call skip write(*,*) " 1. Ordinary transpose time = ", TIMEE(1)-TIMES(1) write(*,*) " 2. Intrinsic function TRANSPOSE() time = ", TIMEE(2)-TIMES(2) write(*,*) " 3. THREADED panel transpose time = ", TIMEE(3)-TIMES(3) write(*,*) "Transpose Time ratios: [1.]/[3.]: ", REAL(TIMEE(1)-TIMES(1))& /REAL(TIMEE(3)-TIMES(3))," [2.]/[3.]: ", REAL(TIMEE(2)-TIMES(2))/REAL(TIMEE(3)-TIMES(3)) end program SHAR_EOF fi # end of overwriting check if test -f 'make.inc' then echo shar: will not over-write existing file "'make.inc'" else cat << "SHAR_EOF" > 'make.inc' #!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! #!! !!! #!! This program is furnished by the U.S. Army Engineer Research and !!! #!! Development Center, Major Shared Resource Center (ERDC MSRC) "as is" !!! #!! and is accepted and used by the recipient with the express !!! #!! understanding that the Government makes no warranties, expressed or !!! #!! implied, concerning the accuracy, completeness, reliability, usability !!! #!! or suitability for any particular purpose of the information and data !!! #!! within this program or furnished in connection therewith, and the !!! #!! Government shall be under no liability whatsoever to any person by !!! #!! reason of any use made thereof. This program belongs to the U.S. !!! #!! Government; therefore, the recipient further agrees not to assert any !!! #!! proprietary rights therein or to represent the source code to anyone !!! #!! as other than a Government program. !!! #!! !!! #!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! # #!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! #!! Authors: !!! #!! !!! #!! Richard J. Hanson (koolhans@rice.edu) !!! #!! Rice University, Rice Center for High Performance Software Research !!! #!! !!! #!! Clay P. Breshears (clay.breshears@intel.com) !!! #!! KAI Software, a division of Intel Americas, Inc. !!! #!! !!! #!! Henry A. Gabb (henry.gabb@intel.com) !!! #!! KAI Software, a division of Intel Americas, Inc. !!! #!! !!! #!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! all: test1 test2 test3 test4 bench1 test1: $(FLIBS) test1.o $(FC) $(FLOADFLAGS) -o test1 test1.o $(LIBS) test2: $(FLIBS) test2.o $(FC) $(FLOADFLAGS) -o test2 test2.o $(LIBS) test3: $(FLIBS) test3.o $(FC) $(FLOADFLAGS) -o test3 test3.o $(LIBS) test4: $(FLIBS) test4.o $(FC) $(FLOADFLAGS) -o test4 test4.o $(LIBS) bench1: $(FLIBS) bench1.o $(FC) $(FLOADFLAGS) -o bench1 bench1.o $(LIBS) clean: rm -f *.o test1 test2 test3 test4 bench1 *.$(MODULES) SHAR_EOF fi # end of overwriting check if test -f 'test1.f' then echo shar: will not over-write existing file "'test1.f'" else cat << "SHAR_EOF" > 'test1.f' ! Last change: CPB 22 JAN 2002 11:10 am ! ! Testing elementary use of Fortran 90 Pthread calls. Print summary of tests. ! Any failures print 'failed' and cause an abort. ! This code is part of the package "A Fortran Interface to Posix Threads," to be ! published in ACM-TOMS. Authors R. Hanson, C. Breshears, and H. Gabb. ! This is test1.f90. Last change on 31 May 2000. MODULE global_test1 USE FPTHRD IMPLICIT NONE ! Flag for sample output in the thread cancellation tests, TEST3(). LOGICAL :: WANT_PRINT=.FALSE. INTEGER :: TEST_FREQUENCY=50000 ! These are control values used in the tests. INTEGER :: done=0, test_number, thread_counter ! This is the number of threads launched at one time. INTEGER, PARAMETER :: NTHREADS=32 LOGICAL :: STARTED=.FALSE. INTEGER id_no(NTHREADS), COUNTER(0:NTHREADS-1) TYPE(FPTHRD_t) test_id(NTHREADS) TYPE(FPTHRD_attr_t) :: attr TYPE(FPTHRD_mutex_t) :: testing_mutex = FPTHRD_MUTEX_INITIALIZER TYPE(FPTHRD_mutex_t) :: cancel_mutex TYPE(FPTHRD_mutex_t) :: once_mutex = FPTHRD_MUTEX_INITIALIZER TYPE(FPTHRD_once_t) :: testing_once=FPTHRD_ONCE_INIT TYPE(FPTHRD_cond_t) launch_done INTERFACE SUBROUTINE TEST0() END SUBROUTINE SUBROUTINE TEST1(NUMBER) INTEGER NUMBER END SUBROUTINE SUBROUTINE TEST2(NUMBER) INTEGER NUMBER END SUBROUTINE SUBROUTINE ONCE2() END SUBROUTINE SUBROUTINE TEST3(NUMBER) INTEGER NUMBER END SUBROUTINE END INTERFACE END MODULE SUBROUTINE TEST0() USE global_test1, dummy => test0 IMPLICIT NONE TYPE(FPTHRD_t) localid INTEGER value call FPTHRD_self (localid) call FPTHRD_equal(localid, test_id(1), value) test_number=test_number+1 IF(value /= 0) THEN CALL ftest_comment(test_number,". Startup TID is TID of this thread.") return END IF CALL ferr_abort (test_number, value, " matching thread IDs.") END SUBROUTINE TEST0 SUBROUTINE TEST1(number) USE global_test1, dummy => test1 IMPLICIT NONE TYPE(FPTHRD_t) localid INTEGER i, status, value, number call FPTHRD_mutex_lock(testing_mutex, status) call ferr_abort(test_number, status, " locking mutex before ID match loop.") call FPTHRD_self (localid) DO I=1,NUMBER call FPTHRD_equal(localid, test_id(I), value) IF(value /= 0 ) THEN IF(I == NTHREADS) THEN call ftest_comment(test_number, ". Last stored TID is TID of last indexed thread.") END IF call FPTHRD_mutex_unlock(testing_mutex, status) call ferr_abort(test_number, status, " unlocking mutex during ID match loop.") RETURN END IF END DO call ferr_abort (test_number, NUMBER, "matching thread IDs.") END SUBROUTINE TEST1 SUBROUTINE once2() ! This routine used to set the counter to the number of threads. USE global_test1, dummy => once2 IMPLICIT NONE test_number=test_number+1 call ftest_comment (test_number, ". One thread is calling 'once' function.") thread_counter=NTHREADS END SUBROUTINE once2 SUBROUTINE TEST2 (ARG) USE global_test1, dummy => test2 IMPLICIT NONE INTEGER ARG, VALUE, TEMPORARY call FPTHRD_once(testing_once, once2, value) IF(value /= 0) THEN test_number=test_number+1 call ferr_abort (test_number, value, "launching a function, just once.") END IF ! An alternative to using FPTHRD_ONCE(). It is based on a mutex, ! a flag, and execution of a block of code. BLOCK: DO IF(STARTED) EXIT BLOCK ! No thread need wait after flag set. call FPTHRD_mutex_lock(once_mutex, value) call ferr_abort (test_number, value, "locking mutex for one-time code.") IF(STARTED) THEN call FPTHRD_mutex_unlock(once_mutex, value) call ferr_abort (test_number, value, " unlocking mutex for one-time code.") EXIT BLOCK ! Other threads make it through later. END IF STARTED=.TRUE. ! One thread sets the flag. Execute the one-time code. call ftest_comment (test_number, ". One thread is executing alternate one-time code.") call FPTHRD_mutex_unlock(once_mutex, value) call ferr_abort (test_number, value, " unlocking mutex for one-time code.") EXIT BLOCK END DO BLOCK ! Count down. Generally must be protected by a mutex to achieve the correct value 0. call FPTHRD_mutex_lock(testing_mutex, value) call ferr_abort (test_number, value, "locking mutex for counter.") if(arg == NTHREADS+1) THEN call ftest_comment (test_number, ". Last thread index (an argument) is correctly noted.") END IF temporary=thread_counter-1 thread_counter=temporary ! If the above and following lines are interchanged the test may fail. call FPTHRD_mutex_unlock(testing_mutex, value) call ferr_abort (test_number, value, "unlocking mutex for counter.") END SUBROUTINE TEST2 SUBROUTINE TEST3 (ARG) USE global_test1, dummy => test3 IMPLICIT NONE INTEGER arg, i, state, type, value ! The value of the argument is the natural thread number. ! Thread 0 will not cancel. It completes when it is finished. ! Threads > 0 only cancel (with testcancel) when the counter ! has multiples of test_frequency. Thread argument NTHREADS-1 will cancel ansynchonously. if(ARG == 0) THEN call FPTHRD_setcancelstate(FPTHRD_CANCEL_DISABLE, state, value) if(value /= 0)test_number=test_number+1 call ferr_abort (test_number, value, "setting cancel state") if(want_print) THEN write(*,'(" Thread index: ",I3,2x,"ACTION: ", A)')ARG, 'FPTHRD_CANCEL_DISABLE' END IF ELSE IF(ARG < NTHREADS-1) THEN call FPTHRD_setcancelstate(FPTHRD_CANCEL_ENABLE, state, value) if(value /= 0)test_number=test_number+1 call ferr_abort (test_number, value, "setting cancel state") if(want_print) THEN write(*,'(" Thread index: ",I3,2x,"ACTION: ", A)')ARG, 'FPTHRD_CANCEL_ENABLE' END IF END IF IF(ARG == NTHREADS-1) THEN call FPTHRD_setcanceltype (FPTHRD_CANCEL_ASYNCHRONOUS, type, value) if(value /= 0)test_number=test_number+1 call ferr_abort (test_number, value, "setting cancel type") if(want_print) THEN write(*,'(" Thread index: ",I3,2x,"ACTION: ", A)')ARG, 'FPTHRD_CANCEL_ASYNCHRONOUS' END IF END IF ! Alert main thread after states and type have all been set. call FPTHRD_mutex_lock(cancel_mutex, value) call ferr_abort (test_number,value, " locking mutex") thread_counter=thread_counter+1 if(thread_counter == NTHREADS) THEN call FPTHRD_cond_signal(launch_done, value) call ferr_abort(test_number,value," signalling condition") if(want_print) THEN write(*,'(" A-Thread index: ",I3,2x,"ACTION: ", A)')ARG, 'Signalling MAIN Thread' END IF END IF call FPTHRD_mutex_unlock(cancel_mutex, value) call ferr_abort (test_number, value, " unlocking mutex") ! Wait for cancellation to be sent or otherwise complete. DO IF(ARG == 0) EXIT counter(arg)=min(huge(1)-1,counter(arg)+1) if(MOD(counter(arg),test_frequency) == 0 .or. counter(arg) == huge(1)-1) THEN call FPTHRD_testcancel() if(want_print) THEN write(*,'(" B3-Thread index: ",I3,2x,"ACTION: ", A)')ARG, 'Tested CANCEL and did not' END IF END IF END DO ! Show that disabled threads will not cancel. They do not loop forever. DO IF(DONE > 0) THEN if(want_print) THEN write(*,'(" B-Thread index: ",I3,2x,"ACTION: ", A)')ARG, 'SAW DONE; Exited LOOP' END IF EXIT END IF counter(arg)=min(huge(1)-1,counter(arg)+1) if(MOD(counter(arg),test_frequency) == 0 .or. counter(arg) == huge(1)-1) THEN call FPTHRD_testcancel() if(want_print) THEN write(*,'(" B-Thread index: ",I3,2x,"ACTION: ", A)')ARG, 'Waiting for DONE; Tested CANCEL and did not' END IF END IF END DO IF(ARG == 0) THEN call FPTHRD_mutex_lock(cancel_mutex, value) call ferr_abort(test_number,value," locking mutex") counter(arg)=0 thread_counter=0 call FPTHRD_cond_signal(launch_done, value) call ferr_abort(test_number,value," condition signalling") call FPTHRD_mutex_unlock(cancel_mutex, value) call ferr_abort(test_number,value," unlocking mutex") call FPTHRD_setcancelstate(FPTHRD_CANCEL_ENABLE, state, value) call ferr_abort(test_number,value," re-enabling cancel state.") ! This loop spends a little time and should result in eventual cancellation. DO counter(arg)=min(huge(1)-1,counter(arg)+1) if(MOD(counter(arg),test_frequency) == 0 .or. counter(arg) == huge(1)-1) THEN call FPTHRD_testcancel() if(want_print) THEN write(*,'(" E-Thread index: ",I3,2x,"ACTION: ", A)')ARG, 'Waiting for testcancel' END IF END IF END DO END IF END SUBROUTINE TEST3 Program fmain1 USE global_test1 IMPLICIT NONE INTEGER STATUS, VALUE, I, START_CONCURRENCY TYPE(FPTHRD_t) localid TYPE(C_NULL) RESULT, VALUE_RETURNED test_number=0 call FPTHRD_getconcurrency(START_CONCURRENCY) call FPTHRD_setconcurrency(NTHREADS+1, STATUS) ! Test 0 use _create, _join, _equal, and _self to show basic activity. ! This tests launches a single thread, joins up with it, and the thread ! itself testing that its ID matches the ID obtained after launch. call ftest_comment (test_number, ". An FPTHRD group of _create, _join, _equal and _self, starting.") test_number=test_number+1 call ftest_comment (test_number, ". Start launching a thread.") call FPTHRD_attr_init(attr, status) call ferr_abort(test_number, status," initializing thread attribute") call fpthrd_attr_setscope(attr,FPTHRD_SCOPE_SYSTEM, status) print *,"fpthrd_attr_setscope status is ",status if(status /= ENOSYS .and. status /= EPERM)call ferr_abort(test_number, status, " setting system scope") call FPTHRD_create (test_id(1), attr, test0, NULL, status) call ftest_comment (test_number, ". Create a thread.") call ferr_abort (test_number, status, "creating thread") call FPTHRD_join (test_id(1), NULL, status) test_number=test_number+1 call ftest_comment (test_number, ". Wait joining a thread.") call ferr_abort (test_number, status, "joining thread") ! Test 0 is complete. call skip ! Test 1 use _create, _join, _equal, and _self to show concurrent activity. ! This tests launches several threads, joins up with them, and the thread ! itself tests that its ID matches the last ID obtained after launch. test_number=test_number+1 call ftest_comment (test_number,". A concurrent FPTHRD group of _create, _join, _equal and _self, starting.") test_number=test_number+1 call ftest_comment (test_number, ". Start launching threads.") call FPTHRD_mutex_init(testing_mutex, NULL, status) ! testing_mutex=FPTHRD_MUTEX_INITIALIZER if(status /= 0) test_number=test_number+1 call ferr_abort (test_number, status, "initializing mutex") ! This is equivalent to: ! testing_mutex = FPTHRD_MUTEX_INITIALIZER ! once_mutex = FPTHRD_MUTEX_INITIALIZER call FPTHRD_mutex_lock(testing_mutex, status) call ferr_abort(test_number, status,"locking mutex") DO I=1,NTHREADS id_no(i)=i call FPTHRD_create (test_id(i), attr, test1, id_no(i), status) if(status == EAGAIN) call ftest_comment (test_number, "insufficient resources") call ferr_abort (test_number, status, "creating thread") END DO call FPTHRD_mutex_unlock(testing_mutex, status) DO I=1,NTHREADS call FPTHRD_join (test_id(i), NULL, status) call ferr_abort (test_number, status, "joining thread") END DO test_number=test_number+1 call ftest_comment (test_number, ". Wait joining threads.") ! Try to join a thread already completed. This should give a clear error. call FPTHRD_join(test_id(1), NULL, status) if(status /= ESRCH) THEN call ferr_abort (test_number, status, "joining thread") else test_number=test_number+1 call ftest_comment (test_number, ". Tried to join a completed thread. Noted appropriate error.") end if ! Test 1 is complete. call skip ! Test 2 use _mutex_init, _create, _once, _join, _mutex_lock, and _mutex_unlock ! to test well-scheduled activity. This tests launches several threads, joins ! up with them, and the main thread tests that a counter was protected against ! "race" conditions. test_number=test_number+1 call ftest_comment (test_number,". A concurrent FPTHRD group including _once, _mutex_init, _mutex_lock, _mutex_unlock, and & &_mutex_destroy.") ! This cannot be done in a Fortran declaration, so an assignment must be used. DO I=1,NTHREADS id_no(i)=i+1 call FPTHRD_create (test_id(i), attr, test2, id_no(i), status) if(status == EAGAIN) call ftest_comment (test_number, " insufficient resources") call ferr_abort (test_number, status, " creating thread") END DO DO I=1,NTHREADS call FPTHRD_join (test_id(i), NULL, status) if(status /= 0) test_number=test_number+1 call ferr_abort (test_number, status, "joining thread") END DO call FPTHRD_mutex_destroy(testing_mutex,status) test_number=test_number+1 if(thread_counter == 0) THEN call ftest_comment (test_number, ". As threads join, a mutex-protected counter was cooperatively decremented to zero.") else call ferr_abort (test_number, thread_counter, "counter was not decremented to zero") END IF ! Test 2 is complete. call skip ! Test 3: use _mutex_init, _create, _join, _mutex_lock, _mutex_unlock, ! _cond_wait, _cond_signal, _setcancelstate, _setcanceltype, and _cancel to test ! well-scheduled activity. This tests launches several threads, cancels ! them, and joins up. Some threads are temporarily left for a short time so they ! cannot be cancelled. After this time the thread changes its state and allows ! cancellation. test_number=test_number+1 call ftest_comment (test_number, ". A concurrent FPTHRD group including _mutex_init, _mutex_lock, _mutex_unlock, _cancel, a& &nd _cond_wait.") call ftest_comment (test_number, ". The group also includes _cond_signal,_setcancelstate, _setcanceltype, and _testcancel.") call FPTHRD_mutex_init(cancel_mutex, NULL, status) if(status /= 0) test_number=test_number+1 call ferr_abort (test_number, status, " initializing mutex") call FPTHRD_cond_init(launch_done, NULL, status) if(status /= 0) test_number=test_number+1 call ferr_abort (test_number, status, "initializing condition variable") ! This is equivalent to: launch_done = FPTHRD_COND_INITIALIZER thread_counter=0 counter=0 DO I=1,NTHREADS id_no(I)=I-1 call FPTHRD_create (test_id(I), attr, test3, id_no(I), status) if(status == EAGAIN) call ftest_comment (test_number, "insufficient resources") call ferr_abort (test_number, status, " creating thread") END DO call FPTHRD_mutex_lock(cancel_mutex, status) call ferr_abort(test_number, status, " locking cancel mutex") DO WHILE(thread_counter /= NTHREADS) call FPTHRD_cond_wait(launch_done, cancel_mutex, status) call ferr_abort(test_number, status, " waiting on condition with cancel mutex") END DO call FPTHRD_mutex_unlock(cancel_mutex, status) call ferr_abort(test_number, status, " unlocking cancel mutex") test_number=test_number+1 call ftest_comment (test_number,". Select threads are prepared for cancellation.") ! Cancel all threads. They are waiting to be cancelled or will soon be. DO I=2,NTHREADS call FPTHRD_cancel(test_id(i), status) if(status /= ESRCH) call ferr_abort (test_number, status, "canceling threads") END DO if(want_print) THEN write(*,'(" MAIN THREAD: Cancelled all threads")') END IF ! This global flag results in thread 1 eventually changing to a state where it is canceled. DONE=1 DO I=2,NTHREADS call FPTHRD_join (test_id(i), value_returned, status) VALUE=VALUE_RETURNED ! Expect that only the threads that could be canceled will signal with FPTHRD_CANCELED. ! Thread NTHREADS will be canceled but is not required to return with FPTHRD_CANCELED set. if(I < NTHREADS .and. value /= FPTHRD_CANCELED) THEN if(status /= 0) THEN test_number=test_number+1 call ferr_abort (test_number, value, "joining thread but not cancelled") END IF END IF END DO ! Cancel first thread that was placed in a cannot cancel state, then changed to cancel. call FPTHRD_cancel(test_id(1), status) if(status /= ESRCH) call ferr_abort (test_number, status, "canceling first thread") call FPTHRD_mutex_lock(cancel_mutex, status) call ferr_abort(test_number, status, " starting second wait") DO WHILE (THREAD_COUNTER /= 0) call FPTHRD_cond_wait(launch_done, cancel_mutex, status) call ferr_abort(test_number, status, " at second wait") END DO call FPTHRD_mutex_unlock(cancel_mutex, status) call ferr_abort(test_number, status, "after second wait") ! Special treatment for select threads. call FPTHRD_join(test_id(1), value_returned, status) value=VALUE_RETURNED if(value /= FPTHRD_CANCELED) THEN if(status /= 0) test_number=test_number+1 call ferr_abort (test_number, value, "joining thread 1 but not cancelled") END IF test_number=test_number+1 call ftest_comment (test_number,". All elgible threads successfully cancelled.") ! Clean up the mutex and condition variables: call FPTHRD_mutex_destroy(cancel_mutex, status) call ferr_abort(test_number, status, " destroying a mutex") call FPTHRD_cond_destroy(launch_done, status) call ferr_abort(test_number, status, " destroying a conditional") ! Reset the concurrency level to the value at the start. call FPTHRD_setconcurrency(START_CONCURRENCY, STATUS) ! Test 4 is a call to _detach and _exit. The main thread exits, with no ! further execution. It is an error if code executes past _exit(). call FPTHRD_self(localid) call FPTHRD_detach(localid, status) test_number=test_number+1 call ftest_comment (test_number,". The main thread calls _detach(itself) then _exit.") call skip call FPTHRD_exit(value) call ferr_abort (test_number, value, ", calling _exit, should not be here") ! Test 4 is complete. END program SHAR_EOF fi # end of overwriting check if test -f 'test1.output' then echo shar: will not over-write existing file "'test1.output'" else cat << "SHAR_EOF" > 'test1.output' Testing 0. An FPTHRD group of _create, _join, _equal and _self, starting. Testing 1. Start launching a thread. Testing 2. Startup TID is TID of this thread. Testing 2. Create a thread. Testing 3. Wait joining a thread. Testing 4. A concurrent FPTHRD group of _create, _join, _equal and _self, starting. Testing 5. Start launching threads. Testing 5. Last stored TID is TID of last indexed thread. Testing 6. Wait joining threads. Testing 7. Tried to join a completed thread. Noted appropriate error. Testing 8. A concurrent FPTHRD group including _once, _mutex_init, _mutex_lock, _mutex_unlock, and _mutex_destroy. Testing 9. One thread is calling 'once' function. Testing 9. One thread is executing alternate one-time code. Testing 9. Last thread index (an argument) is correctly noted. Testing 10. As threads join, a mutex-protected counter was cooperatively decremented to zero. Testing 11. A concurrent FPTHRD group including _mutex_init, _mutex_lock, _mutex_unlock, _cancel, and _cond_wait. Testing 11. The group also includes _cond_signal,_setcancelstate, _setcanceltype, and _testcancel. Testing 12. Select threads are prepared for cancellation. Testing 13. All elgible threads successfully cancelled. Testing 14. The main thread calls _detach(itself) then _exit. SHAR_EOF fi # end of overwriting check if test -f 'test2.f' then echo shar: will not over-write existing file "'test2.f'" else cat << "SHAR_EOF" > 'test2.f' ! Last change: CPB 22 JAN 2002 11:10 am ! Last change: RH 25 JAN 2002 12:00 pm ! Testing elementary use of Pthreads. Print summary of tests. ! Any failures print 'failed' and cause an abort. ! This code is part of the package "A Fortran Interface to Posix Threads," to be ! published in ACM-TOMS. Authors: R. Hanson, C. Breshears, and H. Gabb. ! This is test2.f90. MODULE global_test2 USE fpthrd IMPLICIT NONE ! These are control values used in the tests. INTEGER test_number, thread_counter ! This is the number of threads launched at one time. INTEGER, PARAMETER :: NTHREADS=32 INTEGER id_no(NTHREADS) TYPE(FPTHRD_t) test_id(NTHREADS), first_id, detach_id TYPE(FPTHRD_attr_t) attribute, start_attr TYPE(FPTHRD_mutex_t) cancel_mutex, recursion_mutex TYPE(FPTHRD_once_t) testing_once TYPE(FPTHRD_cond_t) launch_done TYPE(FSCHED_PARAM) param TYPE(fTIMESPEC) waittime TYPE(fsize_t) stacksize ! Declare a derived type that will carry the problem dope. ! These are the arguments of a dot product function. TYPE FUNCTION_ARGUMENTS INTEGER N REAL, DIMENSION(:,:), POINTER :: SMATRIX REAL, DIMENSION(:), POINTER :: SX INTEGER INCY REAL, dimension(:), POINTER :: SY INTEGER ROW_INDEX END TYPE TYPE(FUNCTION_ARGUMENTS) inb(NTHREADS), INA Interface SUBROUTINE TEST5() END SUBROUTINE SUBROUTINE TEST6(NUMBER) INTEGER NUMBER END SUBROUTINE SUBROUTINE ONCE6() END SUBROUTINE RECURSIVE SUBROUTINE test7(LIMITS) INTEGER LIMITS(2) END SUBROUTINE end interface END MODULE SUBROUTINE FSGEMV (N, SMATRIX, SX, SY, ROW_START, ROW_END) IMPLICIT NONE INTEGER N, I, J, ROW_START, ROW_END REAL, pointer :: SMATRIX(:,:), SX(:) REAL, pointer :: SY(:) IF(ROW_START <= 0) RETURN IF(ROW_END > N) RETURN IF(ROW_END < ROW_START) RETURN SY(ROW_START:ROW_END)=0E0 DO J=1,N DO I=ROW_START, ROW_END SY(I)=SY(I)+SMATRIX(I,J)*SX(J) END DO END DO END SUBROUTINE SUBROUTINE FSDSDOT (N, SMATRIX, SX, INCY, SY, ROW_INDEX) IMPLICIT NONE INTEGER N, INCY, J, Q, ROW, ROW_INDEX REAL, pointer :: SMATRIX(:,:), SX(:) REAL, pointer :: SY(:) DOUBLE PRECISION T ROW=ROW_INDEX T=0D0 Q=1 DO J=1,N T=T+SMATRIX(ROW, J)*SX(Q) Q=Q+INCY END DO SY(ROW)=T END SUBROUTINE subroutine once6() use global_test2, dummy => once6 implicit none ! Use with FPTHRD_once() to initialize any data element. integer status recursion_mutex=FPTHRD_MUTEX_INITIALIZER test_number=test_number+1 call ftest_comment(test_number, ". Once initializing a mutex that is used later.") end subroutine SUBROUTINE TEST5() USE global_test2, dummy => test5 IMPLICIT NONE integer value, TIMES, TIMEE, RATE ! Not even a cancellation request can break out of this spin loop. ! The thread does its work, then signals the main thread it is finished. CALL SYSTEM_CLOCK(TIMES, COUNT_RATE=RATE) DO CALL SYSTEM_CLOCK(TIMEE) IF(TIMEE <= TIMES) EXIT ! Avoid a clock roll-over. IF((TIMEE-TIMES)/2 >= RATE) EXIT ! Loop about two seconds with this test. END DO ! After this thread has done its work it unlocks and signals. call FPTHRD_mutex_unlock(cancel_mutex, value) call ferr_abort(test_number, value, " unlocking mutex.") call FPTHRD_cond_signal(launch_done, value) call ferr_abort(test_number, value, " condition signal.") END SUBROUTINE subroutine test6(arg_in) use global_test2, dummy => test6 implicit none INTERFACE SUBROUTINE FSDSDOT (N, SMATRIX, SX, INCY, SY, ROW_INDEX) INTEGER N, INCY, ROW_INDEX REAL, POINTER, DIMENSION(:) :: SMATRIX(:,:), SX, SY END SUBROUTINE END INTERFACE integer status, value, arg_in, I call FPTHRD_once (testing_once, once6, status) call ferr_abort(test_number, status, "starting once function for thread data key") I=arg_in ! Use the structure holding the arguments for this function. call fsdsdot (inb(I) % n, inb(I) % SMATRIX, inb(I) % SX, inb(I) % incy, inb(I) % SY, inb(I)% row_INDEX) end subroutine recursive subroutine test7(LIMITS) use global_test2, my_test=>test7 ! Symbol is reset to a dummy. Avoids conflict. implicit none INTERFACE SUBROUTINE FSGEMV (N, SMATRIX, SX, SY, ROW_START, ROW_END) IMPLICIT NONE INTEGER N, ROW_START, ROW_END REAL, POINTER, DIMENSION(:) :: SMATRIX(:,:), SX, SY END SUBROUTINE END INTERFACE INTEGER :: IDEAL, K, J, LIMITS(2), LIMITS_L(2), LIMITS_R(2), status TYPE(FPTHRD_T) THREAD_L, THREAD_R call FPTHRD_mutex_lock(recursion_mutex, status) call ferr_abort(test_number, status, " locking mutex in test7") K=LIMITS(2)-LIMITS(1)+1;J=(LIMITS(1)+LIMITS(2))/2 ! The problem limits are split into two equally sized groups. LIMITS_L=LIMITS;LIMITS_R=LIMITS LIMITS_L(2)=J;LIMITS_R(1)=J+1 call FPTHRD_mutex_unlock(recursion_mutex, status) call ferr_abort(test_number, status, " unlocking mutex in test7") IDEAL=(INA%N + 7)/8 IF(K <= IDEAL ) THEN ! This is where the work actually gets done. The above value of IDEAL is arbitrary. CALL FSGEMV (INA % N, INA % SMATRIX, INA % SX, INA % SY, LIMITS(1), LIMITS(2)) ELSE call FPTHRD_create(THREAD_L, attribute, my_test, limits_l, status) call ferr_abort(test_number, status, " recursive create-L in test7") call FPTHRD_create(THREAD_R, attribute, my_test, limits_r, status) call ferr_abort(test_number, status, " recursive create-R in test7") call FPTHRD_join(THREAD_L, NULL, status) call ferr_abort(test_number, status, " recursive join-L in test7") call FPTHRD_join(THREAD_R, NULL, status) call ferr_abort(test_number, status, " recursive join-R in test7") END IF END SUBROUTINE program fmain2 USE global_test2 implicit none REAL, POINTER :: matrix_a(:,:),vector(:),y_serial(:),y_thread(:) REAL errnorm, norm, temp integer create_state, i, j, n, status, value, LIMITS(2), & change_sec, change_nanosec, schedule_value, new_value test_number=14 call FPTHRD_setconcurrency(NTHREADS+1) ! Optional argument not used. ! Test 5: Examine thread attributes. Reset values and qualities of the threads. ! This tests launches a single detached thread, and waits for it. test_number=test_number+1 call ftest_comment (test_number, ". An FPTHRD group examining and changing attributes.") call FPTHRD_attr_init(attribute, status) call ferr_abort(test_number, status, " initializing attribute") call FPTHRD_attr_getstacksize(attribute, stacksize, status) call ferr_abort(test_number, status, " getting default stack size") call FPTHRD_attr_getstacksize(attribute, stacksize, status) call fpthrd_get_fsize(value, stacksize) ! The value FPTHRD_STACK_MIN may be set to a flag value (-1,0, etc) ! that indicates that it is at some unspecified default. IF(FPTHRD_STACK_MIN <= 0) THEN value = value+32000 ELSE value = 3*FPTHRD_STACK_MIN/2 END IF ! Reset stack size to average of the minimum and the default. call fpthrd_set_fsize(value, stacksize) call FPTHRD_attr_setstacksize(attribute, stacksize, status) call ferr_abort (test_number, status, "setting stack size") call FPTHRD_attr_getstacksize(attribute, stacksize, status) call fpthrd_get_fsize(new_value, stacksize) if(value /= new_value)& call ferr_abort(test_number, 1,& " stacksize is not equal to 3*FPTHRD_STACK_MIN/2 or initial value.") ! Initialize mutex and condition variable. cancel_mutex=FPTHRD_MUTEX_INITIALIZER launch_done =FPTHRD_COND_INITIALIZER ! Create a detached thread. call FPTHRD_attr_init(start_attr, status) call ferr_abort(test_number, status," initializing attribute") call FPTHRD_attr_getdetachstate(start_attr, create_state, status) if(status == EINVAL)call ferr_abort (test_number, status, "getting default detached state") if(create_state /= FPTHRD_CREATE_DETACHED) THEN call FPTHRD_attr_setdetachstate(start_attr, FPTHRD_CREATE_DETACHED, status) call ferr_abort (test_number, status, "setting detached state") END IF ! The thread to be created unlocks the mutex so that the signal occurs. call FPTHRD_mutex_lock(cancel_mutex, status) call ferr_abort (test_number, status, "locking mutex") test_number=test_number+1 call ftest_comment (test_number, ". Launch a detached thread.") call FPTHRD_create (detach_id, start_attr, test5, NULL, status) call ferr_abort (test_number, status, "creating thread") ! Wait for the detached thread to signal that it has completed. ! A little more time is allowed than what is expected. ! Assigns the current epoch plus the value on the right side. change_sec=3; change_nanosec=0 Call fpthrd_set_ftimespec(change_sec, change_nanosec, waittime) ! Equivalent C code: ! waittime.tv_sec=time(NULL)+3; ! waittime.tv_nsec=0; call ftest_comment (test_number, ". Entering timed wait.") call FPTHRD_cond_timedwait(launch_done, cancel_mutex, waittime, status) if(status /= ETIMEDOUT) call ferr_abort (test_number, status, " timed wait") call ftest_comment (test_number, ". Left timed wait.") call FPTHRD_mutex_unlock(cancel_mutex, status) call ferr_abort (test_number, status, " unlocking mutex") test_number=test_number+1 call ftest_comment (test_number, ". Meeting a detached thread after it completes.") if(status == 0) call ferr_abort (test_number, status, "meeting a detached thread") call FPTHRD_attr_destroy(start_attr, status) ! Test 5 is complete. call skip ! Test 6. Start a peer function that calls a library function. Arguments ! are packed into a derived type. N=NTHREADS ! No claims of randomness are made for this sequence. It is used to generate ! a non-repeatable sequence of matrix and vector values. ALLOCATE(MATRIX_A(N,N), VECTOR(N), Y_SERIAL(N), Y_THREAD(N), STAT=status) call ferr_abort (test_number, status, "allocating array memory") call random_number(matrix_a) call random_number(vector) DO J=1,N vector(J)=2e0*vector(J)-1e0 END DO testing_once=FPTHRD_ONCE_INIT ! The value FPTHRD_STACK_MIN may be set to a flag value (-1,0, etc) ! that indicates that it is at some unspecified default. IF(FPTHRD_STACK_MIN <= 0) THEN call FPTHRD_attr_getstacksize(attribute, stacksize, status) call fpthrd_get_fsize(value, stacksize) value=value*2 ELSE value = 2*FPTHRD_STACK_MIN END IF call fpthrd_set_fsize(value, stacksize) call FPTHRD_attr_setstacksize(attribute, stacksize, status) call ferr_abort (test_number, status, " setting stack size") ! Use threads to compute each row (times) vector concurrently. DO I=1,N ! This is a typical situation: Use a structure to pack all arguments into one ! object. Then pass the peer code that object. It unpacks the structure to get ! the arguments. inb(I) % n=n;inb(I) % SMATRIX=> matrix_a; inb(I) % SX=>vector;inb(I) % incy=1;inb(I) % SY=>y_thread; inb(I) % row_index=I ID_NO(I)=I ! Create the set of threads for the product. call FPTHRD_create (test_id(i), attribute, test6, ID_NO(I), status) call ferr_abort (test_number, status, " creating threads") END DO ! Compute the matrix-vector product for comparison. ! This computation may overlap the thread computation. y_serial=matmul(matrix_a, vector) DO I=1,NTHREADS call FPTHRD_join(test_id(i), NULL, status) call ferr_abort(test_number, status, " joining a single thread") END DO errnorm=sum((y_serial-y_thread)**2) norm=sum(y_serial**2) ! The results are correct even if they do not completely agree. ! This test will fail only with a blunder. Small relative errors will be allowed. test_number=test_number+1 if(errnorm <= EPSILON(NORM)*norm) THEN call ftest_comment (test_number, ". Matrix-vector product with each entry using a separate thread.") else status=1 call ferr_abort(test_number,status," Serial and threaded matrix-vector product gave different results") END IF call skip ! Test 6 is complete. */ y_thread=0e0 ! Use threads to compute each row (times) vector concurrently. ! This exericse uses one thread to call a routine. The routine uses divide and ! conquer (recursion) to reduce the problem size to one with good properties: ! (The matrix dimension K by N, where K <= N/8). ina % N=n;ina % SMATRIX=> matrix_a;ina % SX=>vector;ina % SY=>y_thread call FPTHRD_attr_setinheritsched(attribute, FPTHRD_EXPLICIT_SCHED, status) call ferr_abort(test_number, status, " setting inherit schedule") call FPTHRD_attr_setschedpolicy(attribute, FSCHED_RR, status) ! This may not be supported: IF(status /= ENOTSUP) call ferr_abort(test_number, status, " setting schedule policy") call FPTHRD_attr_setinheritsched(attribute, FPTHRD_INHERIT_SCHED, status) ! This may not be supported: IF(status /= ENOTSUP) call ferr_abort(test_number, status, " setting inherit schedule") schedule_value=1 call fpthrd_set_fsched_param (schedule_value, param) call fpthrd_attr_setschedparam(attribute, param, status) call ferr_abort(test_number, status, " setting schedule parameter") ! Create the thread for the product. LIMITS=(/1,N/) call FPTHRD_create (first_id, attribute, test7, LIMITS, status) call ferr_abort (test_number, status, " creating a recursive thread") call FPTHRD_join(first_id, NULL, status) call ferr_abort(test_number, status, " joining a single recursive thread") call fpthrd_get_fsched_param (status, param) ! Check that schedule parameter component was communicated. call ferr_abort(test_number, status-schedule_value,& " schedule value changed and then was not recovered") ! Check results for correctness: errnorm=sum((y_serial-y_thread)**2) norm=sum(y_serial**2) ! The results are correct even if they do not completely agree. ! This test will fail only with a blunder. Small relative errors will be allowed. test_number=test_number+1 if(errnorm <= EPSILON(NORM)*norm) THEN call ftest_comment (test_number, ". Matrix-vector product with recursive threads.") else status=1 call ferr_abort(test_number,status," Serial and threaded matrix-vector product gave different results") END IF call skip ! Test 7 is complete. */ end program SHAR_EOF fi # end of overwriting check if test -f 'test2.output' then echo shar: will not over-write existing file "'test2.output'" else cat << "SHAR_EOF" > 'test2.output' Testing 15. An FPTHRD group examining and changing attributes. Testing 16. Launch a detached thread. Testing 16. Entering timed wait. Testing 16. Left timed wait. Testing 17. Meeting a detached thread after it completes. Testing 18. Once initializing a mutex that is used later. Testing 19. Matrix-vector product with each entry using a separate thread. Testing 20. Matrix-vector product with recursive threads. SHAR_EOF fi # end of overwriting check if test -f 'test3.f' then echo shar: will not over-write existing file "'test3.f'" else cat << "SHAR_EOF" > 'test3.f' ! Last change: RH 22 JAN 2002 11:10 am ! Last change: RH 25 Apr 2001 1:37 pm ! Last change: RH 7 Dec 2000 1:33 pm ! Testing elementary use of Pthreads. Print summary of tests. ! Any failures print 'failed' and cause an abort. ! This code is part of the package "A Fortran Interface to Posix Threads," to be ! published in ACM-TOMS. Authors: R. Hanson, C. Breshears, and H. Gabb. ! This is test3.f90. MODULE global_test3A USE fpthrd IMPLICIT NONE INTEGER test_number, thread_counter LOGICAL chunk_next, ready, finished ! This is the number of working threads launched at one time. INTEGER, PARAMETER :: NTHREADS = 7 ! This is the problem size, for a matrix-vector product example. ! The entries in the product are computed using an unrolled loop model. ! Each thread computes some of the entries of the product. INTEGER, PARAMETER :: MATRIX_SIZE = 127 ! This is the chunk size, wherein each thread does this much of the loop. INTEGER, PARAMETER :: CHUNK_SIZE = 8 TYPE(fpthrd_t) loop_thread, test_id(NTHREADS) TYPE(fpthrd_mutex_t) signal_mutex TYPE(fpthrd_cond_t) signal_unroller, signal_worker TYPE(fpthrd_mutexattr_t) sma, smb TYPE(fpthrd_attr_t) attribute ! These are the loop limits and arguments of a matrix-vector loop. ! It is part of a work crew. TYPE FUNCTION_ARGUMENTS INTEGER loop_dope(4) INTEGER N REAL, DIMENSION(:,:), POINTER :: SMATRIX REAL, DIMENSION(:), POINTER :: SX, SY END TYPE TYPE(function_arguments) inb(NTHREADS), inc END MODULE Module global_test3 USE global_test3A INTERFACE SUBROUTINE TEST7(ina) USE global_test3A, only : function_arguments IMPLICIT NONE TYPE(function_arguments) ina END SUBROUTINE SUBROUTINE CHUNK7(INA) USE global_test3A, only : function_arguments IMPLICIT NONE TYPE(function_arguments), target :: INA END SUBROUTINE END INTERFACE ! call fpthrd_create(test_id(i), NULL, chunk7, ina, status) ! call fpthrd_create (loop_thread, NULL, test7, INC, status) END MODULE SUBROUTINE sdsdot (N, SM, SX, SY, I) IMPLICIT NONE REAL, DIMENSION(:,:), POINTER :: SM REAL, DIMENSION(:), POINTER :: SX, SY INTEGER, INTENT(IN) :: N, I INTEGER J DOUBLE PRECISION t ! Compute the dot product of two vectors. Accumulate the results