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 in double ! precision. Assign the final result in single precision. t=0D0 DO J=1,N t=t+SM(I,J)*SX(J); END DO sy(I)=t END SUBROUTINE SUBROUTINE CHUNK7(ARG_IN) USE global_test3, dummy => chunk7 IMPLICIT NONE INTEGER :: i, local_loops, local_loope, status, summary=0 TYPE(function_arguments), target :: arg_in TYPE(function_arguments), pointer :: ina Interface SUBROUTINE sdsdot (N, SM, SX, SY, I) IMPLICIT NONE REAL, DIMENSION(:,:), POINTER :: SM REAL, DIMENSION(:), POINTER :: SX, SY INTEGER, INTENT(IN) :: N, I END SUBROUTINE end interface ! Get the structure holding the arguments for this function. ina=>arg_in ! The variable on the left "becomes" the one on the right. LOOP1: DO call fpthrd_mutex_lock(signal_mutex, status) summary=summary+status DO while(.NOT. READY) call fpthrd_cond_wait(signal_worker, signal_mutex, status) summary=summary+status if(summary > 0) EXIT LOOP1 END DO if(finished) THEN call fpthrd_mutex_unlock(signal_mutex, status) summary=summary+status EXIT LOOP1 END IF local_loops=ina%loop_dope(1);local_loope=ina%loop_dope(2) READY=.FALSE. chunk_next=.TRUE. call fpthrd_cond_signal (signal_unroller, status) summary=summary+status call fpthrd_mutex_unlock(signal_mutex, status) summary=summary+status call ferr_abort(test_number, summary, " error with signal, lock or unlock") ! -------------------------------------------------------------------- ! This is the local chunk of the loop performed by an individual worker. DO I=LOCAL_LOOPS, LOCAL_LOOPE call sdsdot(ina % n, ina%smatrix, ina % sx, ina%SY, I) END DO ! -------------------------------------------------------------------- END DO LOOP1 call ferr_abort(test_number, summary, " loop ending error with signal, lock or unlock") END SUBROUTINE SUBROUTINE TEST7(ina) USE global_test3, dummy => test7 IMPLICIT NONE INTEGER :: nthread, chunksize, i, loops, loope, p, q, process, status, summary=0 TYPE(function_arguments) ina TYPE(C_NULL) result ! Start up the working threads. call fpthrd_cond_init (signal_unroller, NULL, status) summary=summary+status call fpthrd_cond_init (signal_worker, NULL, status) summary=summary+status call ferr_abort(test_number, summary, " error with condition init") call ftest_comment (test_number, ". Initialized condition variables.") ! Start exercising mutex attribute manipulation functions. call fpthrd_mutexattr_init(sma, status) call ferr_abort(test_number, STATUS, " error with mutexattr init") call ftest_comment (test_number, ". Initialized mutex attribute.") call fpthrd_mutexattr_setpshared(sma, FPTHRD_PROCESS_PRIVATE, status) call ferr_abort(test_number, status, " error with mutexattr setpshared") call fpthrd_mutexattr_getpshared(sma, process, status) call ferr_abort(test_number, status, " error with mutexattr getpshared") call ftest_comment (test_number, ". Got process sharing thread.") if(process == FPTHRD_PROCESS_PRIVATE) THEN call fpthrd_mutexattr_setpshared(sma, FPTHRD_PROCESS_PRIVATE, status) call ferr_abort(test_number, status, " error with mutexattr setpshared") END IF call ftest_comment (test_number, ". End of mutex attribute exercises.") ! End of mutex attribute exercises. ! May be needed in order to allow FPTHRD_mutex_setprioceiling() function to ! operate correctly, that is, allow thread the privilege of setting ! the priority ceiling, avoiding an EPERM error. smb=sma call fpthrd_mutexattr_setprotocol(sma, FPTHRD_PRIO_PROTECT, status) IF(status == ENOTSUP .or. status == ENOSYS) THEN sma=smb ELSE call ferr_abort(test_number, status, " error with mutexattr setprotocol") END IF call ftest_comment(test_number,". Start creating for chunk7 routine") call fpthrd_mutex_init(signal_mutex, sma, status) call ferr_abort(test_number, STATUS, " error with mutex initialization") ina=inc loops =ina % loop_dope(1);loope =ina %loop_dope(2) nthread=ina % loop_dope(3);chunksize=ina %loop_dope(4) p=loops;q=chunksize+p-1;if(q > loope)q=loope READY=.TRUE. chunk_next=.FALSE. finished=.FALSE. ina % loop_dope(1)=p;ina % loop_dope(2)=q DO I=1,NTHREAD call fpthrd_create(test_id(i), NULL, chunk7, ina, status) call ferr_abort(test_number, status, " creating loop worker threads") END DO test_number=test_number+1 call ftest_comment(test_number,". Started loop worker threads and entered chunking phase") ! Chop loop into pieces of size CHUNKSIZE. Allocate tasks to working threads. LOOP2: DO call fpthrd_mutex_lock(signal_mutex, status) summary=summary+status DO while(.NOT. chunk_next) call fpthrd_cond_wait(signal_unroller, signal_mutex, status) summary=summary+status if(summary > 0) EXIT LOOP2 END DO if(q >= loope) EXIT LOOP2 p=q+1;q=chunksize+p-1;if(q > loope)q=loope;READY=.TRUE.;chunk_next=.FALSE. ina % loop_dope(1)=p;ina % loop_dope(2)=q call fpthrd_cond_signal(signal_worker, status) summary=summary+status call fpthrd_mutex_unlock(signal_mutex, status) summary=summary+status END DO LOOP2 READY=.TRUE. finished=.TRUE. call fpthrd_cond_broadcast(signal_worker, status) summary=summary+status call fpthrd_mutex_unlock(signal_mutex, status) summary=summary+status call ferr_abort (test_number, summary," lock, unlock, signal or broadcast") call fpthrd_mutexattr_destroy(sma, status) summary=summary+status call ferr_abort (test_number, summary," destroying mutex attribute") DO I=1,NTHREADS call fpthrd_join(test_id(i), result, status) summary=summary+status END DO call ferr_abort (test_number, summary," joining worker threads") test_number=test_number+1 call ftest_comment(test_number,". Broadcast shutdown to worker threads and joined them.") END SUBROUTINE program fmain3 USE global_test3 implicit none REAL, POINTER :: matrix_a(:,:),vector(:),y_serial(:),y_thread(:) REAL errnorm, norm, temp integer i, j, n, status, value, priceiling TYPE(C_NULL) result Interface SUBROUTINE sdsdot (N, SM, SX, SY, I) IMPLICIT NONE REAL, DIMENSION(:,:), POINTER :: SM REAL, DIMENSION(:), POINTER :: SX, SY INTEGER, INTENT(IN) :: N, I END SUBROUTINE end interface call FPTHRD_setconcurrency(NTHREADS+1, status) test_number=21 ! Test 7. Start a peer function that chops up a loop into threads. ! Arguments are passed by reference and are packed into a structure. ! 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 and unrolls the loop. n=MATRIX_SIZE ALLOCATE(MATRIX_A(N,N), VECTOR(N), Y_THREAD(N), Y_SERIAL(N),STAT=status) call ferr_abort (test_number, status, " allocating array memory") inc % loop_dope(1)=1;inc%loop_dope(2)=n inc % loop_dope(3)=NTHREADS;inc%loop_dope(4)=CHUNK_SIZE inc % n=n;inc % smatrix=>matrix_a inc % sx=>vector;inc % sy=>y_thread call random_number(matrix_a) call random_number(vector) call ftest_comment (test_number, ". Launched a single startup thread.") ! Use threads to compute each row (times) vector concurrently. call fpthrd_create (loop_thread, NULL, test7, INC, status) call ferr_abort (test_number, status, "creating loop thread") ! Compute the matrix-vector product for comparison. DO I=1,N call sdsdot(n, matrix_a, vector, y_serial, I) END DO ! Wait for thread that unrolled and computed the loop. call fpthrd_join(loop_thread, result, status) call ferr_abort (test_number, status, "joining loop thread") ! Lock mutex to test mutex_trylock. call fpthrd_mutex_lock(signal_mutex, status); call ferr_abort (test_number, status, "locking before trymutex_lock") ! This mutex should be locked (busy) and return immediately. call fpthrd_mutex_trylock(signal_mutex, status) if(status /= EBUSY) call ferr_abort (test_number, status, "trying mutex lock when it is locked") ! Unlock mutex to clear. This may not be required. call fpthrd_mutex_unlock(signal_mutex, status) call ferr_abort (test_number, status, "unlocking after trymutex_lock") ! This mutex should be unlocked and return immediately. status = EBUSY do while (status == EBUSY) call fpthrd_mutex_trylock(signal_mutex, status) end do call ferr_abort (test_number, status, "trying mutex lock") ! Thread must have gotten lock. It is unlocked for mutex_prioceiling tests. call fpthrd_mutex_unlock(signal_mutex, status) call ferr_abort (test_number, status, "unlocking mutex lock after try") ! Get this mutex's priority ceiling. call fpthrd_mutex_getprioceiling(signal_mutex, priceiling, status) if(status /= ENOSYS .and. status /= ENOTSUP)& call ferr_abort(test_number,status," getting priority ceiling for mutex") ! Try to set the new priority to the old one. This may gracefully fail. call fpthrd_mutex_setprioceiling(signal_mutex, priceiling, value, status) if(status /= ENOSYS .and. status /= ENOTSUP)& call ferr_abort(test_number,status," setting priority ceiling for mutex") 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. Relative norm errors up to about ! SQRT(EPSILON()) are allowed. test_number=test_number+1 if(errnorm <= EPSILON(NORM)*norm)THEN call ftest_comment (test_number, ". Matrix-vector product completed; each chunk used 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 END PROGRAM SHAR_EOF fi # end of overwriting check if test -f 'test3.output' then echo shar: will not over-write existing file "'test3.output'" else cat << "SHAR_EOF" > 'test3.output' Testing 21. Launched a single startup thread. Testing 21. Initialized condition variables. Testing 21. Initialized mutex attribute. Testing 21. Got process sharing thread. Testing 21. End of mutex attribute exercises. Testing 21. Start creating for chunk7 routine Testing 22. Started loop worker threads and entered chunking phase Testing 23. Broadcast shutdown to worker threads and joined them. Testing 24. Matrix-vector product completed; each chunk used a separate thread. SHAR_EOF fi # end of overwriting check if test -f 'test4.f' then echo shar: will not over-write existing file "'test4.f'" else cat << "SHAR_EOF" > 'test4.f' ! Last change: CPB 22 JAN 2002 11:10 am ! Last change: RH 25 Apr 2001 2:18 pm ! Last change: RH 6 Dec 2000 4:23 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 test4.f90. MODULE global_test4 USE fpthrd IMPLICIT NONE INTEGER test_number Type(fpthrd_t) base_thread, test_thread Type(fpthrd_attr_t) saa, sab Type(fpthrd_condattr_t) sca, scb Type(fpthrd_mutexattr_t) sma Type(fsched_param) param END MODULE program fmain4 USE global_test4 implicit none integer inheritsched, policy, prioceiling, result, scope, status test_number=24 ! Test 8. Exercise various attributes fetches and settings. call fpthrd_condattr_init(sca, status) test_number=test_number+1 ! Initizalize, destroy and initialize once again. call ferr_abort(test_number, status, " initializing condition attribute structure") call fpthrd_condattr_destroy(sca, status) call ferr_abort(test_number, status, " destroying condition attribute structure") call fpthrd_condattr_init(sca, status) call ferr_abort(test_number, status, " re-initializing condition attribute structure") call ftest_comment(test_number, ". Initialized, destroyed and re-initialized condition attribute structure.") ! Set condition attribute to process-private. Fetched and checked for consistency. call fpthrd_condattr_setpshared(sca, FPTHRD_PROCESS_PRIVATE, status) call ferr_abort(test_number, status, " setting condition attribute structure") scb=sca call fpthrd_condattr_getpshared(scb, result, status) test_number=test_number+1 if(result /= FPTHRD_PROCESS_PRIVATE)call ferr_abort(test_number, 1, " wrong condition attribute result") call ftest_comment(test_number, ". Set attribute, fetched it and checked for correctness.") ! Get the main thread's ID. Use it to fetch various settings. Call fpthrd_self(base_thread) call fpthrd_getschedparam(base_thread, policy, param, status) call ferr_abort(test_number, status, " getting default schedule parameters") call fpthrd_setschedparam(base_thread, policy, param, status) call ferr_abort(test_number, status, " setting default schedule parameters") test_number=test_number+1 call ftest_comment(test_number, ". Retrieved and then set default schedule parameters.") ! Attempt to reset the scheduling scope of a thread to have the highest system-wide ! priority. Then return it to the initial setting. test_number=test_number+1 call fpthrd_attr_init(saa, status) call ferr_abort(test_number, status, " initializing thread attribute") call fpthrd_attr_getscope(saa, scope, status) call ferr_abort(test_number, status, " getting thread scope") ! This gives this thread highest priority, system wide. call fpthrd_attr_setscope(saa, FPTHRD_SCOPE_SYSTEM, status) ! See if there is permission to set the thread scope. If not, just quit. if(status /= EPERM)THEN if(status /= ENOSYS) call ferr_abort(test_number, status, " setting thread scope, system wide") ! Immediately return scope to its default. call fpthrd_attr_setscope(saa, scope, status) if(status /= ENOSYS)call ferr_abort(test_number, status, " returning thread scope to default setting") END IF call ftest_comment(test_number, ". Attempted to retrieve, set and reset thread scope.") ! Exercise various schedule and policy routines. test_number=test_number+1 call fpthrd_attr_getinheritsched(saa, inheritsched, status) call ferr_abort(test_number, status, " getting inherited schedule") call fpthrd_attr_setinheritsched(saa, inheritsched, status) call ferr_abort(test_number, status, " setting inherited schedule") call ftest_comment(test_number,". Retrieved and then set inherited schedule.") test_number=test_number+1 call fpthrd_attr_getschedparam(saa, param, status) call ferr_abort(test_number, status, " getting schedule parameters") call fpthrd_attr_getschedparam(saa, param, status) call ferr_abort(test_number, status, " setting schedule parameters") call ftest_comment(test_number,". Retrieved and then set schedule parameters.") test_number=test_number+1 call fpthrd_attr_getschedpolicy(saa, policy, status) call ferr_abort(test_number, status, " getting schedule policy") call fpthrd_attr_setschedpolicy(saa, policy, status) call ferr_abort(test_number, status, " setting schedule policy") call ftest_comment(test_number,". Retrieved and then set schedule policy.") test_number=test_number+1 call fpthrd_mutexattr_getprioceiling(sma, prioceiling, status) if(status /= ENOSYS .and. status /= ENOTSUP)& call ferr_abort(test_number, status, " getting mutex priority ceiling") call fpthrd_mutexattr_setprioceiling(sma, prioceiling, status) if(status /= ENOSYS .and. status /= ENOTSUP)& call ferr_abort(test_number, status, " setting mutex priority ceiling") call ftest_comment(test_number,". Attempted to retrieve and then set mutex priority ceiling.") call skip END PROGRAM SHAR_EOF fi # end of overwriting check if test -f 'test4.output' then echo shar: will not over-write existing file "'test4.output'" else cat << "SHAR_EOF" > 'test4.output' Testing 25. Initialized, destroyed and re-initialized condition attribute structure. Testing 26. Set attribute, fetched it and checked for correctness. Testing 27. Retrieved and then set default schedule parameters. Testing 28. Attempted to retrieve, set and reset thread scope. Testing 29. Retrieved and then set inherited schedule. Testing 30. Retrieved and then set schedule parameters. Testing 31. Retrieved and then set schedule policy. Testing 32. Attempted to retrieve and then set mutex priority ceiling. SHAR_EOF fi # end of overwriting check cd .. if test ! -d 'Src' then mkdir 'Src' fi cd 'Src' 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 and C compilers FC = f95 CC = cc # Format of C names for calling from Fortran NAMEFORM = -DAPPEND_UNDERSCORE # Preprocessor flags CPP = -DCPQ $(NAMEFORM) FPP = -DCPQ # Directory to store library files FLIBPATH = ../lib # Libraries needed for compilation LIBS = -lpthread # Compiler optimzation flags OPTS = -O3 -ansi COPTS = -O # Compiled module file suffix MODULES = mod # Fortran alignment flags ALIGN = -align rec8byte # Fortran compilation flags FFLAGS = $(OPTS) $(ALIGN) # C compilation flags CFLAGS = -w $(CPP) $(COPTS) 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 and C compilers FC = f90 CC = cc # Format of C names for calling from Fortran NAMEFORM = -DAPPEND_UNDERSCORE #################################################################### # Be sure application compilation matches chosen flags # # BITS specifies the Application Binary Interface (ABI) # CPP gives preprocessor flags # # 32-bit compilation, default integer/real size # For 64 bit version use make -f Makefile.origin BITS=-64, which overrides # 32 bit version. BITS = -n32 CPP = -DSGI $(NAMEFORM) -DADDR=$(BITS) FPP = -DSGI -DADDR=$(BITS) #################################################################### # Directory to store library files FLIBPATH = ../lib # Libraries needed for compilation LIBS = -lpthread # Compiler optimzation flags OPTS = -O2 -mips4 -r10000 # Compiled module file suffix MODULES = mod # Fortran compilation flags FFLAGS = -freeform $(BITS) $(OPTS) -cpp $(CPP) # Fortran loader flags FLOADFLAGS = $(BITS) # C compilation flags CFLAGS = -w $(BITS) $(OPTS) -cpp $(CPP) 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 and C compilers FC = xlf90_r CC = cc_r # Format of C names for calling from Fortran NAMEFORM =-DNO_CHANGE # C and Fortran Preprocessor flags CCPP = -DIBM $(NAMEFORM) FCPP = -WF,-DIBM,$(NAMEFORM) # Directory to store library files FLIBPATH = ../lib # Libraries needed for compilation LIBS = # Compiler optimzation flags #OPTS = -O2 -qarch=pwr3 -qtune=pwr3 # Compiled module file suffix MODULES = mod # Fortran compilation flags FFLAGS = $(FCPP) $(OPTS) # Fortran loader flags FLOADFLAGS = # C compilation flags CFLAGS = -w -cpp $(CCPP) $(OPTS) 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 and C compilers FC = f90 CC = cc # Format of C names for calling from Fortran NAMEFORM = -DAPPEND_UNDERSCORE # Preprocessor flags CPP = -DSUN $(NAMEFORM) FPP =-DSUN # Directory to store library files FLIBPATH = ../lib # Libraries needed for compilation LIBS = -lpthread # Compiler optimzation flags OPTS = -O3 COPTS = -O # Compiled module file suffix MODULES = mod # Fortran compilation flags FFLAGS = -stackvar $(OPTS) # Fortran loader flags FLOADFLAGS = -stackvar # C compilation flags CFLAGS = -w $(CPP) $(COPTS) include make.inc SHAR_EOF fi # end of overwriting check if test -f 'build' then echo shar: will not over-write existing file "'build'" else cat << "SHAR_EOF" > 'build' #/bin/csh -f if ($1 =~ "CPQ") then echo "" echo "Building FPTHRD package for Compaq Tru64" echo "" set sys = "cpq" else if ($1 =~ "SUN") then echo "" echo "Building FPTHRD package for SUN Solaris" echo "" set sys = "sun" else if ($1 =~ "IBM") then echo "" echo "Building FPTHRD package for IBM AIX" echo "" set sys = "power3" else if ($1 =~ "SGI") then echo "" echo "Building FPTHRD package for SGI IRIX" echo "" set sys = "origin" else if ($1 =~ "SGI64") then echo "" echo "Building FPTHRD package for SGI IRIX with 64-bit addressing" echo "" else echo "" echo "usage: build " echo "" echo " where is one of the following: " echo "" echo " CPQ -- Compaq Tru64" echo " SUN -- SUN Solais" echo " IBM -- IBM AIX Power 3" echo " SGI -- SGI Origin running IRIX" echo " SGI64 -- SGI Origin running IRIX with 64-bit addressing" echo "" exit 1 endif rm -f constants.inc fpthrd_config if ($1 =~ "SGI64") then cc -64 config.c -o fpthrd_config else cc config.c -o fpthrd_config endif fpthrd_config $1 rm -f fpthrd_config echo "" echo "Using make to build FPTHRD library in ../lib" echo "" if ($1 =~ "SGI64") then make -f Makefile.origin clean make -f Makefile.origin BITS=-64 else make -f Makefile.$sys clean make -f Makefile.$sys endif SHAR_EOF fi # end of overwriting check if test -f 'config.c' then echo shar: will not over-write existing file "'config.c'" else cat << "SHAR_EOF" > 'config.c' /* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!! Authors: !!! 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. !!! !!! Richard J. Hanson (koolhans@rice.edu) !!! Rice University, Rice Center for High Performance Software Research !!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! */ #include #include #include #include #include #include /* Estimates of integer array sizes needed to hold data from C structures. Configuration will use maximum of this value and actual system size to ensure enough room is available. #define ISIZE_OF_C_INT 1 #define ISIZE_OF_fpthrd_T 2 #define ISIZE_OF_fpthrd_ATTR_T 44 #define ISIZE_OF_fpthrd_MUTEX_T 16 #define ISIZE_OF_fpthrd_MUTEXATTR_T 32 #define ISIZE_OF_fpthrd_COND_T 16 #define ISIZE_OF_fpthrd_CONDATTR_T 28 #define ISIZE_OF_FSCHED_PARAM 9 #define ISIZE_OF_FTIMESPEC 4 #define ISIZE_OF_FSIGSET_T 4 #define ISIZE_OF_FSIZE_T 2 #define max(x,y) (x>y)?x:y */ void usage() { printf("\nPrint Usage example here.\n\n"); } void fpthrd_type_decl(FILE *fp, char fsize_name[], int fsize, char ftype_name[], char in_name[]) { char int_param[30] = " INTEGER, PARAMETER :: "; fprintf(fp,"%s %s = %d\n",int_param, fsize_name, fsize); fprintf(fp," TYPE %s\n", ftype_name); fprintf(fp," PRIVATE\n"); fprintf(fp," INTEGER(KIND=IADDR) :: %s(%s)\n", in_name, fsize_name); fprintf(fp," END TYPE %s\n\n", ftype_name); } void fpthrd_stype_decl(FILE *fp, char fsize_name[], int fsize, char ftype_name[], char in_name[]) { char int_param[30] = " INTEGER, PARAMETER :: "; fprintf(fp,"%s %s = %d\n",int_param, fsize_name, fsize); fprintf(fp," TYPE %s\n", ftype_name); fprintf(fp," INTEGER :: %s(%s)\n", in_name, fsize_name); fprintf(fp," END TYPE %s\n\n", ftype_name); } void get_init_values(FILE *fp, void *t, int n, const char *what) { int *i; int j; fprintf(fp," INTEGER (KIND=IADDR), DIMENSION(%d), PARAMETER ::",n); fprintf(fp," %s_I = &\n",what); fprintf(fp," (/ "); printf("fpthrd_config: Size of %s INIT is %d x 4 bytes\n",what,n); i = (int *)t; fprintf(fp, "%d",*i++); for (j = 1; j < n; j++) { fprintf(fp, ", %d",*i++); } fprintf(fp," /)\n\n"); } void get_long_init_values(FILE *fp, void *t, int n, const char *what) { long *i; int j; fprintf(fp," INTEGER (KIND=IADDR), DIMENSION(%d), PARAMETER ::",n); fprintf(fp," %s_I = &\n",what); fprintf(fp," (/ "); printf("fpthrd_config: Size of %s INIT is %d x 8 bytes\n",what,n); i = (long *)t; fprintf(fp, "%ld",*i++); for (j = 1; j < n; j++) { fprintf(fp, ", %ld",*i++); } fprintf(fp," /)\n\n"); } int findSize(int s, int n) { if (s%n == 0) return(s/n); else return((s/n)+1); } main(int argc, char *argv[]) { FILE *fp; char int_param[30] = " INTEGER, PARAMETER :: "; int bit64 = 0; /* Is this a 64-bit addressin platform? */ int numbytes = 4; pthread_mutex_t m = PTHREAD_MUTEX_INITIALIZER; pthread_cond_t c = PTHREAD_COND_INITIALIZER; if (argc!=2) { printf("fpthrd_config: Incorrect number of command line arguments.\n"); usage(); return 1; } if ((fp = fopen("constants.inc", "w")) == NULL) { printf("fpthrd_config: Unable to open file 'constants.inc'\n"); return 1; } /* FPTHRD Internal data and address sizes */ if (strcmp(argv[1],"SUN") == 0){ fprintf(fp,"%s RR=6\n",int_param); } else if (strcmp(argv[1],"IBM") == 0) { fprintf(fp,"%s RR=6\n",int_param); } else if (strcmp(argv[1],"SGI") == 0) { fprintf(fp,"%s RR=6\n",int_param); } else if (strcmp(argv[1],"SGI64") == 0) { bit64 = 1; numbytes = 8; fprintf(fp,"%s RR=12\n",int_param); } else if (strcmp(argv[1],"CPQ") == 0) { bit64 = 1; numbytes = 8; fprintf(fp,"%s RR=12\n",int_param); } else { printf("fpthrd_config: Invalid command line argument.\n"); fclose(fp); usage(); return 1; } fprintf(fp,"%s IADDR = SELECTED_INT_KIND(R=RR)\n",int_param); fprintf(fp," INTEGER (KIND=IADDR) gauge_IADDR\n\n"); if (sizeof(int) == 8) { printf("fpthrd_config: C integer size is 8 bytes.\n"); fprintf(fp,"%s CINT = SELECTED_INT_KIND(R=12)\n",int_param); } else { if (sizeof(int) == 4) printf("fpthrd_config: C integer size is 4 bytes.\n"); else { printf("fpthrd_config: C integer size is %ld bytes.\n",sizeof(int)); printf("fpthrd_config: *Setting size to be 4 bytes in FPTHRD.*\n"); } fprintf(fp,"%s CINT = SELECTED_INT_KIND(R=6)\n",int_param); } fprintf(fp," INTEGER (KIND=CINT) gauge_CINT\n\n"); /* POSIX thread constants */ fprintf(fp,"%s FPTHRD_CREATE_DETACHED = ",int_param); fprintf(fp,"%d\n",PTHREAD_CREATE_DETACHED); fprintf(fp,"%s FPTHRD_CREATE_JOINABLE = ",int_param); fprintf(fp,"%d\n\n",PTHREAD_CREATE_JOINABLE); #ifdef _POSIX_THREAD_PROCESS_SHARED fprintf(fp,"%s FPTHRD_PROCESS_PRIVATE = ",int_param); fprintf(fp,"%d\n",PTHREAD_PROCESS_PRIVATE); fprintf(fp,"%s FPTHRD_PROCESS_SHARED = ",int_param); fprintf(fp,"%d\n\n",PTHREAD_PROCESS_SHARED); #else fprintf(fp,"%s FPTHRD_PROCESS_PRIVATE = 0\n",int_param); fprintf(fp,"%s FPTHRD_PROCESS_SHARED = 0\n\n",int_param); #endif #ifdef _POSIX_THREAD_PRIO_PROTECT fprintf(fp,"%s FPTHRD_PRIO_PROTECT = ",int_param); fprintf(fp,"%d\n",PTHREAD_PRIO_PROTECT); fprintf(fp,"%s FPTHRD_PRIO_INHERIT = ",int_param); fprintf(fp,"%d\n",PTHREAD_PRIO_INHERIT); fprintf(fp,"%s FPTHRD_PRIO_NONE = ",int_param); fprintf(fp,"%d\n\n",PTHREAD_PRIO_NONE); #else fprintf(fp,"%s FPTHRD_PRIO_PROTECT = 0\n",int_param); fprintf(fp,"%s FPTHRD_PRIO_INHERIT = 0\n",int_param); fprintf(fp,"%s FPTHRD_PRIO_NONE = 0\n\n",int_param); #endif fprintf(fp,"%s FPTHRD_CANCEL_ENABLE = ",int_param); fprintf(fp,"%d\n",PTHREAD_CANCEL_ENABLE); fprintf(fp,"%s FPTHRD_CANCEL_DISABLE = ",int_param); fprintf(fp,"%d\n\n",PTHREAD_CANCEL_DISABLE); fprintf(fp,"%s FPTHRD_CANCEL_DEFERRED = ",int_param); fprintf(fp,"%d\n",PTHREAD_CANCEL_DEFERRED); fprintf(fp,"%s FPTHRD_CANCEL_ASYNCHRONOUS = ",int_param); fprintf(fp,"%d\n\n",PTHREAD_CANCEL_ASYNCHRONOUS); fprintf(fp," INTEGER (KIND=CINT), PARAMETER :: "); fprintf(fp,"FPTHRD_CANCELED = huge(1)-1\n\n"); #ifdef _POSIX_THREAD_PRIORITY_SCHEDULING fprintf(fp,"%s FPTHRD_SCOPE_SYSTEM = ",int_param); fprintf(fp,"%d\n",PTHREAD_SCOPE_SYSTEM); fprintf(fp,"%s FPTHRD_SCOPE_PROCESS = ",int_param); fprintf(fp,"%d\n\n",PTHREAD_SCOPE_PROCESS); #else fprintf(fp,"%s FPTHRD_SCOPE_SYSTEM = 0\n",int_param); fprintf(fp,"%s FPTHRD_SCOPE_PROCESS = 0\n\n",int_param); #endif #ifdef _POSIX_THREAD_PRIORITY_SCHEDULING fprintf(fp,"%s FPTHRD_INHERIT_SCHED = ",int_param); fprintf(fp,"%d\n",PTHREAD_INHERIT_SCHED); fprintf(fp,"%s FPTHRD_EXPLICIT_SCHED = ",int_param); fprintf(fp,"%d\n\n",PTHREAD_EXPLICIT_SCHED); #else fprintf(fp,"%s FPTHRD_INHERIT_SCHED = 0\n",int_param); fprintf(fp,"%s FPTHRD_EXPLICIT_SCHED = 0\n\n",int_param); #endif #ifdef PTHREAD_KEYS_MAX fprintf(fp,"%s FPTHRD_KEYS_MAX = ",int_param); fprintf(fp,"%d\n",PTHREAD_KEYS_MAX); #else printf("fpthrd_config: Using sysconf() value for FPTHRD_KEYS_MAX\n"); fprintf(fp,"%s FPTHRD_KEYS_MAX = ",int_param); fprintf(fp,"%d\n",(int)sysconf(_SC_THREAD_KEYS_MAX)); #endif #ifdef PTHREAD_STACK_MIN fprintf(fp,"%s FPTHRD_STACK_MIN = ",int_param); fprintf(fp,"%d\n",PTHREAD_STACK_MIN); #else printf("fpthrd_config: Using sysconf() value for FPTHRD_STACK_MIN\n"); fprintf(fp,"%s FPTHRD_STACK_MIN = ",int_param); fprintf(fp,"%d\n",(int)sysconf(_SC_THREAD_STACK_MIN)); #endif #ifdef PTHREAD_THREADS_MAX fprintf(fp,"%s FPTHRD_THREADS_MAX = ",int_param); fprintf(fp,"%d\n",PTHREAD_THREADS_MAX); #else printf("fpthrd_config: Using sysconf() value for FPTHRD_THREADS_MAX\n"); fprintf(fp,"%s FPTHRD_THREADS_MAX = ",int_param); fprintf(fp,"%d\n",(int)sysconf(_SC_THREAD_THREADS_MAX)); #endif #ifdef PTHREAD_DESTRUCTOR_ITERATIONS fprintf(fp,"%s FPTHRD_DESTRUCTOR_ITERATIONS = ",int_param); fprintf(fp,"%d\n\n",PTHREAD_DESTRUCTOR_ITERATIONS); #else printf("fpthrd_config: Using sysconf() value for FPTHRD_DESTURCTOR_ITERATIONS\n"); fprintf(fp,"%s FPTHRD_DESTRUCTOR_ITERATIONS = ",int_param); fprintf(fp,"%d\n\n",(int)sysconf(_SC_THREAD_DESTRUCTOR_ITERATIONS)); #endif #ifdef _POSIX_THREAD_PRIORITY_SCHEDULING fprintf(fp,"%s FSCHED_FIFO = %d\n",int_param,SCHED_FIFO); fprintf(fp,"%s FSCHED_RR = %d\n",int_param,SCHED_RR); fprintf(fp,"%s FSCHED_OTHER = %d\n\n",int_param,SCHED_OTHER); #else fprintf(fp,"%s FSCHED_FIFO = 0\n",int_param); fprintf(fp,"%s FSCHED_RR = 0\n",int_param); fprintf(fp,"%s FSCHED_OTHER = 0\n\n",int_param); #endif /* POSIX thread error codes */ fprintf(fp,"%s ESRCH = %d\n",int_param, ESRCH); fprintf(fp,"%s EINVAL = %d\n",int_param, EINVAL); fprintf(fp,"%s EFAULT = %d\n",int_param, EFAULT); fprintf(fp,"%s ENOTSUP = %d\n",int_param, ENOTSUP); fprintf(fp,"%s EAGAIN = %d\n",int_param, EAGAIN); fprintf(fp,"%s EDEADLK = %d\n",int_param, EDEADLK); fprintf(fp,"%s ENOSYS = %d\n",int_param, ENOSYS); fprintf(fp,"%s EPERM = %d\n",int_param, EPERM); fprintf(fp,"%s EBUSY = %d\n",int_param, EBUSY); fprintf(fp,"%s ENOMEM = %d\n",int_param, ENOMEM); fprintf(fp,"%s ETIMEDOUT = %d\n",int_param, ETIMEDOUT); fprintf(fp,"%s EINTR = %d\n",int_param, EINTR); fprintf(fp,"%s ENOSPC = %d\n",int_param, ENOSPC); fprintf(fp,"\n%s NUMBER_OF_ERRORS = 13\n",int_param); fprintf(fp," integer(KIND=CINT), private ::"); fprintf(fp," fpthrd_errors(NUMBER_OF_ERRORS) = &\n"); fprintf(fp," (/ %d, ",ESRCH); fprintf(fp,"%d, ",EINVAL); fprintf(fp,"%d, ",EFAULT); fprintf(fp,"%d, ",ENOTSUP); fprintf(fp,"%d, ",EAGAIN); fprintf(fp,"%d, ",EDEADLK); fprintf(fp,"%d, ",ENOSYS); fprintf(fp,"%d, ",EPERM); fprintf(fp,"%d, ",EBUSY); fprintf(fp,"%d, ",ENOMEM); fprintf(fp,"%d, ",ETIMEDOUT); fprintf(fp,"%d, ",EINTR); fprintf(fp,"%d /)\n\n",ENOSPC); fprintf(fp,"%s ISIZE_OF_C_INT = %d\n\n",int_param,1); /* INTEGER ISIZE_OF_ADDRESS */ /* POSIX thread data types. Some contain pointers to C structures. */ fpthrd_type_decl( fp, "ISIZE_OF_fpthrd_T", findSize(sizeof(pthread_t),numbytes), "fpthrd_t", "thread"); fpthrd_type_decl( fp, "ISIZE_OF_fpthrd_ATTR_T", findSize(sizeof(pthread_attr_t),numbytes), "fpthrd_attr_t", "threadattr"); fpthrd_type_decl( fp, "ISIZE_OF_fpthrd_MUTEX_T", findSize(sizeof(pthread_mutex_t),numbytes), "fpthrd_mutex_t", "mutex"); if (!bit64) get_init_values(fp,&m,sizeof(m)/4,"MUTEX"); else get_long_init_values(fp,&m,sizeof(m)/8,"MUTEX"); fpthrd_type_decl( fp, "ISIZE_OF_fpthrd_MUTEXATTR_T", findSize(sizeof(pthread_mutexattr_t),numbytes), "fpthrd_mutexattr_t", "mutexattr"); fpthrd_type_decl( fp, "ISIZE_OF_fpthrd_COND_T", findSize(sizeof(pthread_cond_t),numbytes), "fpthrd_cond_t", "conditional"); if (!bit64) get_init_values(fp,&c,sizeof(c)/4,"COND"); else get_long_init_values(fp,&c,sizeof(c)/8,"COND"); fpthrd_type_decl( fp, "ISIZE_OF_fpthrd_CONDATTR_T", findSize(sizeof(pthread_condattr_t),numbytes), "fpthrd_condattr_t", "condattr"); fpthrd_stype_decl( fp, "ISIZE_OF_FSCHED_PARAM", findSize(sizeof(struct sched_param),numbytes), "fsched_param", "sched_priority"); fpthrd_stype_decl( fp, "ISIZE_OF_FTIMESPEC", findSize(sizeof(struct timespec),numbytes), "ftimespec", "timespec"); fpthrd_stype_decl( fp, "ISIZE_OF_FSIGSET_T", findSize(sizeof(sigset_t),numbytes), "fsigset_t", "mask"); fprintf(fp," INTEGER, PARAMETER :: ISIZE_OF_FSIZE_T = "); fprintf(fp,"%d\n",findSize(sizeof(size_t),numbytes)); fprintf(fp," TYPE fsize_t\n"); fprintf(fp," INTEGER (kind=IADDR) :: size(ISIZE_OF_FSIZE_T)\n"); fprintf(fp," END TYPE\n"); /* Close file */ fclose(fp); printf("FPTHRD Configuration complete\n"); } SHAR_EOF fi # end of overwriting check if test -f 'fpthrd.f' then echo shar: will not over-write existing file "'fpthrd.f'" else cat << "SHAR_EOF" > 'fpthrd.f' !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!! 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 Labs, a division of Intel Americas, Inc. !!! !!! Henry A. Gabb (henry.gabb@intel.com) !!! KAI Software Labs, a division of Intel Americas, Inc. !!! !!! Last change: CPB Tue Jan 22 11:40:46 CST 2002 !!! Last change: RJH 21 Dec 2001 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! module fpthrdA implicit none include "constants.inc" type C_NULL INTEGER POINTER_VALUE end type TYPE fpthrd_once_t private TYPE(FPTHRD_MUTEX_T) MUTEX LOGICAL :: FLAG END TYPE fpthrd_once_t !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! These routines define overloaded assignment for a derived type. ! I=TYPE(C_NULL)(= value of) INTERFACE ASSIGNMENT (=) MODULE PROCEDURE INTEQCPTR, CPTREQINT END INTERFACE !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! INTERFACE fpthrd_join MODULE PROCEDURE fpthrd1_join, fpthrd2_join END INTERFACE INTERFACE fpthrd_mutex_init ! Second argument can be of two types: MODULE PROCEDURE fpthrd1_mutex_init, fpthrd2_mutex_init END INTERFACE INTERFACE fpthrd_cond_init ! Second argument can be of two types: MODULE PROCEDURE fpthrd1_cond_init, fpthrd2_cond_init END INTERFACE !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! This gets the initialization for the condition variable. TYPE(fpthrd_cond_t),PARAMETER :: FPTHRD_COND_INITIALIZER=fpthrd_cond_t(cond_I) ! This gets the initialization for the mutex variable. TYPE(fpthrd_mutex_t),PARAMETER :: FPTHRD_MUTEX_INITIALIZER=fpthrd_mutex_t(mutex_I) ! This gets the initialization structure for the 'once' functionality. TYPE(fpthrd_once_t), PARAMETER :: & FPTHRD_ONCE_INIT=fpthrd_once_t(fpthrd_mutex_t(mutex_I), .FALSE.) ! This is the reserved value that denotes a NULL on the C side. TYPE(C_NULL) :: NULL = C_NULL(huge(1)) ! NULL%POINTER_VALUE=huge(1) ! This is a table of descriptors for Pthreads error codes. character(LEN=12), private :: desc_pterrors(13) = & (/ 'ESRCH ', 'EINVAL ', 'EFAULT ', 'ENOTSUP ', & 'EAGAIN ', 'EDEADLK ', 'ENOSYS ', 'EPERM ', & 'EBUSY ', 'ENOMEM ', 'ETIMEDOUT ', 'EINTR ', & 'ENOSPC ' /) ! This is a brief meaning clause for each error code. character(LEN=32), private :: desc_meanings(13) = & (/ 'No such thread exists. ',& 'Invalid argument ',& 'Illegal address ',& 'Unsupported option - ignore? ',& 'Resource temporarily unavailable',& 'Program would otherwise deadlock',& 'Unsupported function ',& 'No permission for the operation ',& 'A "try" function failed ',& 'Not enough memory ',& 'A time limit was reached. ',& 'Interrupted by a signal ',& 'No space on a device '/) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CONTAINS SUBROUTINE ftest_comment (test_number, text) IMPLICIT NONE INTEGER test_number, status, I, J INTEGER(kind=CINT), PARAMETER :: MESSAGE_SIZE=256 !force 4-bit INTEGER(kind=CINT) MESSAGE(MESSAGE_SIZE) !integer for !C code CHARACTER(LEN=*)text CHARACTER(LEN=MESSAGE_SIZE+20) message_text WRITE(*,"('Testing',I3,A)") test_number,trim(text) RETURN ENTRY ferr_abort (test_number, status, text) IF(status == 0) RETURN ! This routine gives integer values of the separate characters in the message. ! The ensuing message may be in a language other than English. message=32 call fpthrd_strerror(status, message, message_size) message_text='Unix error summary: ' If(message(1) == 0) message_text=trim(message_text)//' None available.' J=23 do I=1,MESSAGE_SIZE if(message(i) == 0) exit ! C character strings end with 0. message_text(J:J)=char(message(i)) J=J+1 end do WRITE(*,"('Failed ',I3,' with value',I3,2x,A)") test_number,status,trim(text) DO I=1,13 ! Write out a matched error message corresponding to the value of status. if(fpthrd_errors(I) /= status) CYCLE WRITE(*,'(I6,2x,A,1x,A))')& fpthrd_errors(I), desc_pterrors(I),trim(desc_meanings(I)) EXIT END DO WRITE(*,'(2x,A)') trim(message_text) STOP "Abort" ENTRY SKIP WRITE(*,"(/)") RETURN END SUBROUTINE ! These subroutines support overloaded assignment used with some of the derived types. SUBROUTINE INTEQCPTR (I, S) IMPLICIT NONE TYPE(C_NULL), INTENT(IN) :: S INTEGER, INTENT(INOUT) :: I I = s % POINTER_VALUE END SUBROUTINE SUBROUTINE CPTREQINT (S, I) IMPLICIT NONE TYPE(C_NULL), INTENT(INOUT) :: S INTEGER, INTENT(IN) :: I s % POINTER_VALUE=I END SUBROUTINE !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Some routines have arguments that can be of type C_NULL or another choice. ! These are implemented as GENERIC interfaces. SUBROUTINE fpthrd1_join(THREAD, EXITCODE, status) TYPE(FPTHRD_T) THREAD INTEGER EXITCODE INTEGER, OPTIONAL :: status INTEGER Lstatus call fpthr_join(THREAD, EXITCODE, Lstatus) if(present(status)) status=Lstatus END SUBROUTINE SUBROUTINE fpthrd2_join(THREAD, EXITCODE, status) TYPE(FPTHRD_T) THREAD TYPE(C_NULL) EXITCODE INTEGER, OPTIONAL :: status INTEGER Lstatus call fpthr_join(THREAD, EXITCODE, Lstatus) if(present(status)) status=Lstatus END SUBROUTINE SUBROUTINE FPTHRD1_MUTEX_INIT(MUTEX, ATTR, STATUS) TYPE(FPTHRD_MUTEX_T) MUTEX TYPE(FPTHRD_MUTEXATTR_T) ATTR INTEGER, OPTIONAL :: STATUS INTEGER Lstatus CALL FPTHR_MUTEX_INIT(MUTEX, ATTR, Lstatus) IF(PRESENT(status)) STATUS=Lstatus END SUBROUTINE SUBROUTINE FPTHRD2_MUTEX_INIT(MUTEX, ATTR, STATUS) TYPE(FPTHRD_MUTEX_T) MUTEX TYPE(C_NULL) ATTR INTEGER, OPTIONAL :: STATUS INTEGER Lstatus CALL FPTHR_MUTEX_INIT(MUTEX, ATTR, Lstatus) IF(PRESENT(status)) STATUS=Lstatus END SUBROUTINE SUBROUTINE FPTHRD1_COND_INIT(COND, ATTR, STATUS) TYPE(FPTHRD_COND_T) COND TYPE(FPTHRD_CONDATTR_T) ATTR INTEGER, OPTIONAL :: STATUS INTEGER Lstatus CALL FPTHR_COND_INIT(COND, ATTR, Lstatus) IF(PRESENT(status)) STATUS=Lstatus END SUBROUTINE SUBROUTINE FPTHRD2_COND_INIT(COND, ATTR, STATUS) TYPE(FPTHRD_COND_T) COND TYPE(C_NULL) ATTR INTEGER, OPTIONAL :: STATUS INTEGER Lstatus CALL FPTHR_COND_INIT(COND, ATTR, Lstatus) IF(PRESENT(status)) STATUS=Lstatus END SUBROUTINE SUBROUTINE fpthrd_attr_destroy(ATTR, STATUS) TYPE(FPTHRD_ATTR_T), INTENT(INOUT) :: ATTR INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_attr_destroy(ATTR, Lstatus) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_attr_getdetachstate(ATTR, CREATESTATE, STATUS) TYPE(FPTHRD_ATTR_T), INTENT(IN) :: ATTR INTEGER, INTENT(OUT) :: CREATESTATE INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_attr_getdetachstate(ATTR, CREATESTATE, Lstatus) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_attr_getinheritsched(ATTR, INHERITSCHED, STATUS) TYPE(FPTHRD_ATTR_T), INTENT(IN) :: ATTR INTEGER, INTENT(OUT) :: INHERITSCHED INTEGER,OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_attr_getinheritsched(ATTR, INHERITSCHED, Lstatus) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_attr_getschedparam(ATTR, PARAM, STATUS) TYPE(FPTHRD_ATTR_T), INTENT(IN) :: ATTR TYPE(FSCHED_PARAM), INTENT(INOUT) :: PARAM INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_attr_getschedparam(ATTR, PARAM, LSTATUS) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_attr_getschedpolicy(ATTR, POLICY, STATUS) TYPE(FPTHRD_ATTR_T), INTENT(IN) :: ATTR INTEGER, INTENT(OUT) :: POLICY INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_attr_getschedpolicy(ATTR, POLICY, LSTATUS) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_attr_getscope(ATTR, SCOPE, STATUS) TYPE(FPTHRD_ATTR_T), INTENT(IN) :: ATTR INTEGER, INTENT(OUT) :: SCOPE INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_attr_getscope(ATTR, SCOPE, LSTATUS) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_attr_getstacksize(ATTR, STACKSIZE, STATUS) TYPE(FPTHRD_ATTR_T), INTENT(IN) :: ATTR TYPE(FSIZE_T), INTENT(OUT) :: STACKSIZE INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_attr_getstacksize(ATTR, STACKSIZE, LSTATUS) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_attr_init(ATTR, STATUS) TYPE(FPTHRD_ATTR_T), INTENT(INOUT) :: ATTR INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_attr_init(ATTR, LSTATUS) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_attr_setdetachstate(ATTR, DETACHSTATE, STATUS) TYPE(FPTHRD_ATTR_T), INTENT(INOUT) :: ATTR INTEGER, INTENT(IN) :: DETACHSTATE INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_attr_setdetachstate(ATTR, DETACHSTATE, LSTATUS) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_attr_setinheritsched(ATTR, INHERIT, STATUS) TYPE(FPTHRD_ATTR_T), INTENT(INOUT) :: ATTR INTEGER, INTENT(IN) :: INHERIT INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_attr_setinheritsched(ATTR, INHERIT, LSTATUS) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_attr_setschedparam(ATTR, PARAM, STATUS) TYPE(FPTHRD_ATTR_T), INTENT(INOUT) :: ATTR TYPE(FSCHED_PARAM), INTENT(IN) :: PARAM INTEGER, OPTIONAL :: STATUS INTEGER Lstatus call fpthr_attr_setschedparam(ATTR, PARAM, LSTATUS) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_attr_setschedpolicy(ATTR, POLICY, STATUS) TYPE(FPTHRD_ATTR_T), INTENT(INOUT) :: ATTR INTEGER, INTENT(IN) :: POLICY INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_attr_setschedpolicy(ATTR, POLICY, LSTATUS) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_attr_setscope(ATTR, SCOPE, STATUS) TYPE(FPTHRD_ATTR_T), INTENT(INOUT) :: ATTR INTEGER, INTENT(IN) :: SCOPE INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_attr_setscope(ATTR, SCOPE, LSTATUS) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_attr_setstacksize(ATTR, STACKSIZE, STATUS) TYPE(FPTHRD_ATTR_T), INTENT(INOUT) :: ATTR TYPE(FSIZE_T), INTENT(IN) :: STACKSIZE INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_attr_setstacksize(ATTR, STACKSIZE, LSTATUS) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_cancel(THREAD, STATUS) TYPE(FPTHRD_T) THREAD INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_cancel(THREAD, LSTATUS) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_condattr_destroy(ATTR, STATUS) TYPE(FPTHRD_CONDATTR_T), INTENT(INOUT) :: ATTR INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_condattr_destroy(ATTR, LSTATUS) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_condattr_getpshared(ATTR, PSHARED, STATUS) TYPE(FPTHRD_CONDATTR_T), INTENT(INOUT) :: ATTR INTEGER, INTENT(OUT) :: PSHARED INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_condattr_getpshared(ATTR, PSHARED, LSTATUS) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_condattr_init(ATTR, STATUS) TYPE(FPTHRD_CONDATTR_T), INTENT(INOUT) :: ATTR INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_condattr_init(ATTR, LSTATUS) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_condattr_setpshared(ATTR, PSHARED, STATUS) TYPE(FPTHRD_CONDATTR_T), INTENT(INOUT) :: ATTR INTEGER, INTENT(IN) :: PSHARED INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_condattr_setpshared(ATTR, PSHARED, LSTATUS) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_cond_broadcast(COND, STATUS) TYPE(FPTHRD_COND_T), INTENT(INOUT) :: COND INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_cond_broadcast(COND, LSTATUS) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_cond_destroy(COND, STATUS) TYPE(FPTHRD_COND_T), INTENT(INOUT) :: COND INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_cond_destroy(COND, LSTATUS) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_cond_signal(COND, STATUS) TYPE(FPTHRD_COND_T), INTENT(INOUT) :: COND INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_cond_signal(COND, LSTATUS) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_cond_timedwait(COND, MUTEX, TIMESPEC, STATUS) TYPE(FPTHRD_COND_T), INTENT(INOUT) :: COND TYPE(FPTHRD_MUTEX_T), INTENT(INOUT) :: MUTEX TYPE(FTIMESPEC), INTENT(IN) :: TIMESPEC INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_cond_timedwait(COND, MUTEX, TIMESPEC, LSTATUS) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_cond_wait(COND, MUTEX, STATUS) TYPE(FPTHRD_COND_T), INTENT(INOUT) :: COND TYPE(FPTHRD_MUTEX_T), INTENT(INOUT) :: MUTEX INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_cond_wait(COND, MUTEX, LSTATUS) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_detach(THREAD, STATUS) TYPE(FPTHRD_T), INTENT(IN) :: THREAD INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_detach(THREAD, LSTATUS) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_getschedparam(THREAD, POLICY, PARAM, STATUS) TYPE(FPTHRD_T), INTENT(IN) :: THREAD TYPE(FSCHED_PARAM), INTENT(INOUT) :: PARAM INTEGER, INTENT(OUT) :: POLICY INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_getschedparam(THREAD, POLICY, PARAM, LSTATUS) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_mutexattr_destroy(ATTR, STATUS) TYPE(FPTHRD_MUTEXATTR_T), INTENT(INOUT) :: ATTR INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_mutexattr_destroy(ATTR, LSTATUS) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_mutexattr_getprioceiling(ATTR, PRIOCEILING, STATUS) TYPE(FPTHRD_MUTEXATTR_T), INTENT(INOUT) :: ATTR INTEGER, INTENT(OUT) :: PRIOCEILING INTEGER, OPTIONAL :: STATUS INTEGER Lstatus call fpthr_mutexattr_getprioceiling(ATTR, PRIOCEILING, LSTATUS) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_mutexattr_getprotocol(ATTR, PROTOCOL, STATUS) TYPE(FPTHRD_MUTEXATTR_T), INTENT(INOUT) :: ATTR INTEGER, INTENT(OUT) :: PROTOCOL INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_mutexattr_getprotocol(ATTR, PROTOCOL, LSTATUS) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_mutexattr_getpshared(ATTR, PSHARED, STATUS) TYPE(FPTHRD_MUTEXATTR_T), INTENT(INOUT) :: ATTR INTEGER, INTENT(OUT) :: PSHARED INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_mutexattr_getpshared(ATTR, PSHARED, LSTATUS) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_mutexattr_init(ATTR, STATUS) TYPE(FPTHRD_MUTEXATTR_T), INTENT(INOUT) :: ATTR INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_mutexattr_init(ATTR, LSTATUS) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_mutexattr_setprioceiling(ATTR, PRIOCEILING, STATUS) TYPE(FPTHRD_MUTEXATTR_T), INTENT(INOUT) :: ATTR INTEGER, INTENT(IN) :: PRIOCEILING INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_mutexattr_setprioceiling(ATTR, PRIOCEILING, LSTATUS) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_mutexattr_setprotocol(ATTR, PROTOCOL, STATUS) TYPE(FPTHRD_MUTEXATTR_T), INTENT(INOUT) :: ATTR INTEGER, INTENT(IN) :: PROTOCOL INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_mutexattr_setprotocol(ATTR, PROTOCOL, LSTATUS) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_mutexattr_setpshared(ATTR, PSHARED, STATUS) TYPE(FPTHRD_MUTEXATTR_T), INTENT(INOUT) :: ATTR INTEGER, INTENT(IN) :: PSHARED INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_mutexattr_setpshared(ATTR, PSHARED, LSTATUS) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_mutex_destroy(MUTEX, STATUS) TYPE(FPTHRD_MUTEX_T), INTENT(INOUT) :: MUTEX INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_mutex_destroy(MUTEX, LSTATUS) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_mutex_getprioceiling(mutex, priceiling, status) TYPE(FPTHRD_MUTEX_T), INTENT(IN) :: mutex INTEGER, intent(OUT) :: priceiling INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_mutex_getprioceiling(mutex, priceiling, Lstatus) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_mutex_lock(MUTEX, STATUS) TYPE(FPTHRD_MUTEX_T), INTENT(INOUT) :: MUTEX INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_mutex_lock(MUTEX, LSTATUS) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_mutex_setprioceiling & (mutex, priceiling, oldceiling, status) TYPE(FPTHRD_MUTEX_T), INTENT(INOUT) :: mutex INTEGER, intent(IN) :: priceiling INTEGER, intent(INOUT) :: oldceiling INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_mutex_setprioceiling & (mutex, priceiling, oldceiling, Lstatus) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_mutex_trylock(MUTEX, STATUS) TYPE(FPTHRD_MUTEX_T), INTENT(INOUT) :: MUTEX INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_mutex_trylock(MUTEX, LSTATUS) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_mutex_unlock(MUTEX, STATUS) TYPE(FPTHRD_MUTEX_T), INTENT(INOUT) :: MUTEX INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_mutex_unlock(MUTEX, LSTATUS) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE FPTHRD_ONCE(once_block, once_routine, status) ! Alternative code for the pthread_once() function. (This version bypasses ! the copy of the compile-time initialization structure to module FPTHRDA.) TYPE(FPTHRD_ONCE_T), INTENT(INOUT) :: once_block ! The variable once_block must be set with an assignment statement- ! once_block = FPTHRD_ONCE_INIT ! before FPTHRD_ONCE() is entered. Derived type variables FPTHRD_ONCE_T ! consist of (FPTHRD_MUTEX_T, LOGICAL). This is defined in module FPTHRDA. ! This use of FPTHRD_ONCE_INIT must be made after the call to ! fpthrd_data_exchange(), so that the mutex and LOGICAL of ! FPTHRD_ONCE_INIT are initialized. ! This is the routine that a single thread will call. INTERFACE subroutine once_routine() end subroutine END INTERFACE INTEGER, OPTIONAL, INTENT(OUT) :: STATUS INTEGER local_status local_status=0 LOOP: DO ! An alternate thread already called once_routine(). So exit immediately. ! No need to acquire the mutex. IF(VOLATILE_L(once_block % flag)) THEN IF(PRESENT(STATUS)) STATUS=local_status RETURN END IF ! Acquire the mutex and check again. call fpthrd_mutex_lock(once_block % mutex, local_status) ! If there is an exception in locking the mutex, exit. IF(local_status /= 0) EXIT LOOP ! A thread may have missed the first check and then acquire the mutex. ! But the call to once_routine was already made. ! The mutex will then be unlocked after the loop is exited. IF(VOLATILE_L(once_block % flag)) EXIT LOOP ! Make the call to once_routine(), set the flag. call once_routine() once_block % flag=.TRUE. ! Exit the loop, which unlocks the mutex. EXIT LOOP END DO LOOP ! Release the mutex. Only threads that had it locked will release. ! The value of local_status (exception flag) will be optionally returned to ! the calling routine as status. An exception in locking or unlocking ! the mutex will cause local_status to have a non-zero value. IF(local_status == 0) & call fpthrd_mutex_unlock(once_block % mutex, local_status) IF(PRESENT(STATUS)) STATUS=local_status RETURN END SUBROUTINE FUNCTION VOLATILE_L(FLAG) IMPLICIT NONE ! This function avoides code optimization that may result in errors ! with multiple threads. The routine is called from FPTHRD_ONCE(). LOGICAL VOLATILE_L LOGICAL, INTENT(INOUT) :: FLAG FLAG=.NOT. (.NOT. FLAG) VOLATILE_L=FLAG END FUNCTION SUBROUTINE fpthrd_setcancelstate(STATE, OLDSTATE, STATUS) INTEGER, INTENT(IN) :: STATE INTEGER, INTENT(OUT) :: OLDSTATE INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_setcancelstate(STATE, OLDSTATE, LSTATUS) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_setcanceltype(TYPE, OLDTYPE, STATUS) INTEGER, INTENT(IN) :: TYPE INTEGER, INTENT(OUT) :: OLDTYPE INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_setcanceltype(TYPE, OLDTYPE, LSTATUS) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE fpthrd_setschedparam(THREAD, POLICY, PARAM, STATUS) TYPE(FPTHRD_T), INTENT(INOUT) :: THREAD TYPE(FSCHED_PARAM), INTENT(IN):: PARAM INTEGER, INTENT(IN) :: POLICY INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_setschedparam(THREAD, POLICY, PARAM, LSTATUS) If(present(status))status=Lstatus END SUBROUTINE SUBROUTINE FPTHRD_setconcurrency(NTHREADS, STATUS) INTEGER, INTENT(IN) :: NTHREADS INTEGER, OPTIONAL :: STATUS INTEGER Lstatus Call fpthr_setconcurrency(NTHREADS, Lstatus) If(present(status)) status=Lstatus END SUBROUTINE end module MODULE FPTHRD USE fpthrdA INTERFACE SUBROUTINE fpthrd_equal(THREAD1, THREAD2, FLAG) USE fpthrdA, ONLY : FPTHRD_T TYPE(FPTHRD_T), INTENT(IN) :: THREAD1, THREAD2 INTEGER, INTENT(OUT) :: FLAG END SUBROUTINE SUBROUTINE fpthrd_self(THREAD) USE fpthrdA, ONLY : FPTHRD_T TYPE(FPTHRD_T), INTENT(OUT) :: THREAD END SUBROUTINE SUBROUTINE fpthrd_testcancel() END SUBROUTINE SUBROUTINE fpthrd_getconcurrency(NTHREADS) INTEGER, INTENT(OUT) :: NTHREADS END SUBROUTINE SUBROUTINE fpthrd_set_ftimespec(change_sec, & Change_nanosec, waittime) USE fpthrdA, ONLY : FTIMESPEC INTEGER, INTENT(IN) :: change_sec, change_nanosec TYPE(FTIMESPEC), INTENT(INOUT) :: waittime END SUBROUTINE SUBROUTINE fpthrd_set_fsched_param(schedule_value, param) USE fpthrdA, ONLY: FSCHED_PARAM INTEGER, INTENT(IN) :: schedule_value TYPE(FSCHED_PARAM), INTENT(INOUT) :: param END SUBROUTINE SUBROUTINE fpthrd_get_fsched_param(schedule_value, param) USE fpthrdA, ONLY: FSCHED_PARAM INTEGER, INTENT(OUT) :: schedule_value TYPE(FSCHED_PARAM), INTENT(IN) :: param END SUBROUTINE SUBROUTINE fpthrd_set_fsize(size_value, size) USE fpthrdA, ONLY: FSIZE_T INTEGER, INTENT(IN) :: size_value TYPE(FSIZE_T), INTENT(INOUT) :: size END SUBROUTINE SUBROUTINE fpthrd_get_fsize(size_value, size) USE fpthrdA, ONLY: FSIZE_T INTEGER, INTENT(OUT) :: size_value TYPE(FSIZE_T), INTENT(IN) :: size END SUBROUTINE END INTERFACE end module 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. !!! #!! !!! #!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! OBJS = fpthrd.o ptf90.o all: $(OBJS) fpthrd.o: fpthrd.f rm -f fpthrd.f90 # cpp $(FPP) fpthrd.f fpthrd.f90 cp fpthrd.f fpthrd.f90 $(FC) $(FFLAGS) -c fpthrd.f90 mv *.o *.$(MODULES) $(FLIBPATH) ptf90.o: ptf90.c $(CC) $(CFLAGS) -c ptf90.c mv *.o $(FLIBPATH) clean: (cd $(FLIBPATH); rm -f $(OBJS) *.$(MODULES) core) SHAR_EOF fi # end of overwriting check if test -f 'ptf90.c' then echo shar: will not over-write existing file "'ptf90.c'" else cat << "SHAR_EOF" > 'ptf90.c' /* ****************************************************************************** *** *** *** 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, 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. | \*---------------------------------------------------------------------------*/ /* 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 ptf90.c. Last change: CPB Tue Jan 22 11:40:46 CST 2002 */ #ifdef LINUX # define _REENTRANT # define _POSIX_SOURCE #endif #include #include #include #include #include #include "summary.h" /* Long integers are required for 64-bit memory addresses: */ #ifdef SGI #if BIT64 == SGI #define INT_CAST long long #else #define INT_CAST int #endif #else #define INT_CAST int #endif #define PTHRD_INT int /* 8-byte integer paramters are required for -i8 compilation */ #ifdef SGI #if SGI == I8 #define PARAM_INT long long #else #define PARAM_INT int #endif #else #define PARAM_INT int #endif /* This value forces an abort if the Fortran code has not called fpthrd_data_exchange(). */ #define FORTRAN_NULL 0x7FFFFFFF #define FPTHREAD_CANCELED 0x7FFFFFFE /* IBM : The IBM Fortran compiler folds symbol names to lower case and does not add extra characters to the end. */ #ifdef NO_CHANGE #define fpthrd_attr_init fpthr_attr_init #define fpthrd_attr_destroy fpthr_attr_destroy #define fpthrd_attr_setstacksize fpthr_attr_setstacksize #define fpthrd_attr_getstacksize fpthr_attr_getstacksize #define fpthrd_attr_setdetachstate fpthr_attr_setdetachstate #define fpthrd_attr_getdetachstate fpthr_attr_getdetachstate #define fpthrd_attr_setscope fpthr_attr_setscope #define fpthrd_attr_getscope fpthr_attr_getscope #define fpthrd_attr_setinheritsched fpthr_attr_setinheritsched #define fpthrd_attr_getinheritsched fpthr_attr_getinheritsched #define fpthrd_attr_setschedpolicy fpthr_attr_setschedpolicy #define fpthrd_attr_getschedpolicy fpthr_attr_getschedpolicy #define fpthrd_attr_setschedparam fpthr_attr_setschedparam #define fpthrd_attr_getschedparam fpthr_attr_getschedparam #define fpthrd_create fpthrd_create #define fpthrd_join fpthr_join #define fpthrd_exit fpthrd_exit #define fpthrd_detach fpthr_detach #define fpthr_self fpthr_self #define fpthrd_self fpthrd_self #define fpthr_equal fpthr_equal #define fpthrd_equal fpthrd_equal #define fpthrd_getschedparam fpthr_getschedparam #define fpthrd_setschedparam fpthr_setschedparam #define fpthrd_cancel fpthr_cancel #define fpthrd_setcancelstate fpthr_setcancelstate #define fpthrd_setcanceltype fpthr_setcanceltype #define fpthr_testcancel fpthr_testcancel #define fpthrd_testcancel fpthrd_testcancel #define fpthrd_cleanup_push fpthrd_cleanup_push #define fpthrd_cleanup_pop fpthrd_cleanup_pop #define fpthrd_mutexattr_init fpthr_mutexattr_init #define fpthrd_mutexattr_destroy fpthr_mutexattr_destroy #define fpthrd_mutexattr_getpshared fpthr_mutexattr_getpshared #define fpthrd_mutexattr_setpshared fpthr_mutexattr_setpshared #define fpthrd_mutexattr_setprotocol fpthr_mutexattr_setprotocol #define fpthrd_mutexattr_getprotocol fpthr_mutexattr_getprotocol #define fpthrd_mutexattr_setprioceiling fpthr_mutexattr_setprioceiling #define fpthrd_mutexattr_getprioceiling fpthr_mutexattr_getprioceiling #define fpthrd_mutex_init fpthr_mutex_init #define fpthrd_mutex_destroy fpthr_mutex_destroy #define fpthrd_mutex_lock fpthr_mutex_lock #define fpthrd_mutex_trylock fpthr_mutex_trylock #define fpthrd_mutex_unlock fpthr_mutex_unlock #define fpthrd_mutex_setprioceiling fpthr_mutex_setprioceiling #define fpthrd_mutex_getprioceiling fpthr_mutex_getprioceiling #define fpthrd_condattr_init fpthr_condattr_init #define fpthrd_condattr_destroy fpthr_condattr_destroy #define fpthrd_condattr_getpshared fpthr_condattr_getpshared #define fpthrd_condattr_setpshared fpthr_condattr_setpshared #define fpthrd_cond_init fpthr_cond_init #define fpthrd_cond_destroy fpthr_cond_destroy #define fpthrd_cond_signal fpthr_cond_signal #define fpthrd_cond_broadcast fpthr_cond_broadcast #define fpthrd_cond_wait fpthr_cond_wait #define fpthrd_cond_timedwait fpthr_cond_timedwait #define fpthrd_setconcurrency fpthr_setconcurrency #define fpthrd_getconcurrency fpthrd_getconcurrency #define fpthrd_strerror fpthrd_strerror #define fpthrd_set_ftimespec fpthrd_set_ftimespec #define fpthrd_get_fsched_param fpthrd_get_fsched_param #define fpthrd_set_fsched_param fpthrd_set_fsched_param #define fpthrd_get_fsize fpthrd_get_fsize #define fpthrd_set_fsize fpthrd_set_fsize #endif #ifdef APPEND_UNDERSCORE #define fpthrd_attr_init fpthr_attr_init_ #define fpthrd_attr_destroy fpthr_attr_destroy_ #define fpthrd_attr_setstacksize fpthr_attr_setstacksize_ #define fpthrd_attr_getstacksize fpthr_attr_getstacksize_ #define fpthrd_attr_setdetachstate fpthr_attr_setdetachstate_ #define fpthrd_attr_getdetachstate fpthr_attr_getdetachstate_ #define fpthrd_attr_setscope fpthr_attr_setscope_ #define fpthrd_attr_getscope fpthr_attr_getscope_ #define fpthrd_attr_setinheritsched fpthr_attr_setinheritsched_ #define fpthrd_attr_getinheritsched fpthr_attr_getinheritsched_ #define fpthrd_attr_setschedpolicy fpthr_attr_setschedpolicy_ #define fpthrd_attr_getschedpolicy fpthr_attr_getschedpolicy_ #define fpthrd_attr_setschedparam fpthr_attr_setschedparam_ #define fpthrd_attr_getschedparam fpthr_attr_getschedparam_ #define fpthrd_create fpthrd_create_ #define fpthrd_join fpthr_join_ #define fpthrd_exit fpthrd_exit_ #define fpthrd_detach fpthr_detach_ #define fpthr_self fpthr_self_ #define fpthrd_self fpthrd_self_ #define fpthr_equal fpthr_equal_ #define fpthrd_equal fpthrd_equal_ #define fpthrd_getschedparam fpthr_getschedparam_ #define fpthrd_setschedparam fpthr_setschedparam_ #define fpthrd_cancel fpthr_cancel_ #define fpthrd_setcancelstate fpthr_setcancelstate_ #define fpthrd_setcanceltype fpthr_setcanceltype_ #define fpthr_testcancel fpthr_testcancel_ #define fpthrd_testcancel fpthrd_testcancel_ #define fpthrd_cleanup_push fpthrd_cleanup_push_ #define fpthrd_cleanup_pop fpthrd_cleanup_pop_ #define fpthrd_mutexattr_init fpthr_mutexattr_init_ #define fpthrd_mutexattr_destroy fpthr_mutexattr_destroy_ #define fpthrd_mutexattr_getpshared fpthr_mutexattr_getpshared_ #define fpthrd_mutexattr_setpshared fpthr_mutexattr_setpshared_ #define fpthrd_mutexattr_setprotocol fpthr_mutexattr_setprotocol_ #define fpthrd_mutexattr_getprotocol fpthr_mutexattr_getprotocol_ #define fpthrd_mutexattr_setprioceiling fpthr_mutexattr_setprioceiling_ #define fpthrd_mutexattr_getprioceiling fpthr_mutexattr_getprioceiling_ #define fpthrd_mutex_init fpthr_mutex_init_ #define fpthrd_mutex_destroy fpthr_mutex_destroy_ #define fpthrd_mutex_lock fpthr_mutex_lock_ #define fpthrd_mutex_trylock fpthr_mutex_trylock_ #define fpthrd_mutex_unlock fpthr_mutex_unlock_ #define fpthrd_mutex_setprioceiling fpthr_mutex_setprioceiling_ #define fpthrd_mutex_getprioceiling fpthr_mutex_getprioceiling_ #define fpthrd_condattr_init fpthr_condattr_init_ #define fpthrd_condattr_destroy fpthr_condattr_destroy_ #define fpthrd_condattr_getpshared fpthr_condattr_getpshared_ #define fpthrd_condattr_setpshared fpthr_condattr_setpshared_ #define fpthrd_cond_init fpthr_cond_init_ #define fpthrd_cond_destroy fpthr_cond_destroy_ #define fpthrd_cond_signal fpthr_cond_signal_ #define fpthrd_cond_broadcast fpthr_cond_broadcast_ #define fpthrd_cond_wait fpthr_cond_wait_ #define fpthrd_cond_timedwait fpthr_cond_timedwait_ #define fpthrd_setconcurrency fpthr_setconcurrency_ #define fpthrd_getconcurrency fpthrd_getconcurrency_ #define fpthrd_strerror fpthrd_strerror_ #define fpthrd_set_ftimespec fpthrd_set_ftimespec_ #define fpthrd_get_fsched_param fpthrd_get_fsched_param_ #define fpthrd_set_fsched_param fpthrd_set_fsched_param_ #define fpthrd_get_fsize fpthrd_get_fsize_ #define fpthrd_set_fsize fpthrd_set_fsize_ #endif #ifdef APPEND_TWO_UNDERSCORES #define fpthrd_attr_init fpthr_attr_init__ #define fpthrd_attr_destroy fpthr_attr_destroy__ #define fpthrd_attr_setstacksize fpthr_attr_setstacksize__ #define fpthrd_attr_getstacksize fpthr_attr_getstacksize__ #define fpthrd_attr_setdetachstate fpthr_attr_setdetachstate__ #define fpthrd_attr_getdetachstate fpthr_attr_getdetachstate__ #define fpthrd_attr_setscope fpthr_attr_setscope__ #define fpthrd_attr_getscope fpthr_attr_getscope__ #define fpthrd_attr_setinheritsched fpthr_attr_setinheritsched__ #define fpthrd_attr_getinheritsched fpthr_attr_getinheritsched__ #define fpthrd_attr_setschedpolicy fpthr_attr_setschedpolicy__ #define fpthrd_attr_getschedpolicy fpthr_attr_getschedpolicy__ #define fpthrd_attr_setschedparam fpthr_attr_setschedparam__ #define fpthrd_attr_getschedparam fpthr_attr_getschedparam__ #define fpthrd_create fpthrd_create__ #define fpthrd_join fpthr_join__ #define fpthrd_exit fpthrd_exit__ #define fpthrd_detach fpthr_detach__ #define fpthr_self fpthr_self__ #define fpthrd_self fpthrd_self__ #define fpthr_equal fpthr_equal__ #define fpthrd_equal fpthrd_equal__ #define fpthrd_getschedparam fpthr_getschedparam__ #define fpthrd_setschedparam fpthr_setschedparam__ #define fpthrd_cancel fpthr_cancel__ #define fpthrd_setcancelstate fpthr_setcancelstate__ #define fpthrd_setcanceltype fpthr_setcanceltype__ #define fpthr_testcancel fpthr_testcancel__ #define fpthrd_testcancel fpthrd_testcancel__ #define fpthrd_cleanup_push fpthrd_cleanup_push__ #define fpthrd_cleanup_pop fpthrd_cleanup_pop__ #define fpthrd_mutexattr_init fpthr_mutexattr_init__ #define fpthrd_mutexattr_destroy fpthr_mutexattr_destroy__ #define fpthrd_mutexattr_getpshared fpthr_mutexattr_getpshared__ #define fpthrd_mutexattr_setpshared fpthr_mutexattr_setpshared__ #define fpthrd_mutexattr_setprotocol fpthr_mutexattr_setprotocol__ #define fpthrd_mutexattr_getprotocol fpthr_mutexattr_getprotocol__ #define fpthrd_mutexattr_setprioceiling fpthr_mutexattr_setprioceiling__ #define fpthrd_mutexattr_getprioceiling fpthr_mutexattr_getprioceiling__ #define fpthrd_mutex_init fpthr_mutex_init__ #define fpthrd_mutex_destroy fpthr_mutex_destroy__ #define fpthrd_mutex_lock fpthr_mutex_lock__ #define fpthrd_mutex_trylock fpthr_mutex_trylock__ #define fpthrd_mutex_unlock fpthr_mutex_unlock__ #define fpthrd_mutex_setprioceiling fpthr_mutex_setprioceiling__ #define fpthrd_mutex_getprioceiling fpthr_mutex_getprioceiling__ #define fpthrd_condattr_init fpthr_condattr_init__ #define fpthrd_condattr_destroy fpthr_condattr_destroy__ #define fpthrd_condattr_getpshared fpthr_condattr_getpshared__ #define fpthrd_condattr_setpshared fpthr_condattr_setpshared__ #define fpthrd_cond_init fpthr_cond_init__ #define fpthrd_cond_destroy fpthr_cond_destroy__ #define fpthrd_cond_signal fpthr_cond_signal__ #define fpthrd_cond_broadcast fpthr_cond_broadcast__ #define fpthrd_cond_wait fpthr_cond_wait__ #define fpthrd_cond_timedwait fpthr_cond_timedwait__ #define fpthrd_setconcurrency fpthr_setconcurrency__ #define fpthrd_getconcurrency fpthrd_getconcurrency__ #define fpthrd_strerror fpthrd_strerror__ #define fpthrd_set_ftimespec fpthrd_set_ftimespec__ #define fpthrd_get_fsched_param fpthrd_get_fsched_param__ #define fpthrd_set_fsched_param fpthrd_set_fsched_param__ #define fpthrd_get_fsize fpthrd_get_fsize__ #define fpthrd_set_fsize fpthrd_set_fsize__ #endif /******************************************************************************* *********** *********** *********** *********** *********** Bindings to Pthreads library functions *********** *********** *********** *********** *********** *******************************************************************************/ /*----------------------------------------------------------------------------*\ | | | Dope passed from C to Fortran | | | \*----------------------------------------------------------------------------*/ void fpthrd_set_ftimespec(PARAM_INT *change_sec, PARAM_INT *change_nanosec, struct timespec *waittime) { struct timespec t; t.tv_sec=time(NULL)+ (int)*change_sec; t.tv_nsec=(int)*change_nanosec; *waittime=t; } void fpthrd_set_fsched_param(PARAM_INT *schedule_value, struct sched_param *sched) { struct sched_param Lsched; Lsched=*sched; Lsched.sched_priority=(int)*schedule_value; *sched=Lsched; } void fpthrd_get_fsched_param(PARAM_INT *schedule_value, struct sched_param *sched) { struct sched_param Lsched; Lsched=*sched; *schedule_value=(PARAM_INT) Lsched.sched_priority; } void fpthrd_set_fsize(PARAM_INT *size_value, size_t *size) { size_t Lsize; Lsize=(size_t) *size_value; *size=Lsize; } void fpthrd_get_fsize(PARAM_INT *size_value, size_t *size) { size_t Lsize; Lsize=*size; *size_value=(PARAM_INT)Lsize; } void fpthrd_strerror(PARAM_INT *errnum, int *MESSAGE, int* MESSAGE_SIZE) { char *message; int i; int message_size; int status; status = (int) *errnum; message=strerror(status); if(message == NULL) { MESSAGE[0]=0; return; } /* The error message is moved as integers (ASCII sequence) to Fortran. Fortran will pack the integers into a character string. */ message_size=*MESSAGE_SIZE; for(i=0;i < message_size;i++) { /* Copy until a zero byte is passed. */ MESSAGE[i]=message[i]; if(message[i] == 0) break; } } /*----------------------------------------------------------------------------*\ | | | Thread creation attributes | | | \*----------------------------------------------------------------------------*/ void fpthrd_attr_init(pthread_attr_t *attr, PARAM_INT *ierr) { *ierr = (PARAM_INT)pthread_attr_init(attr); return; } void fpthrd_attr_destroy(pthread_attr_t *attr, PARAM_INT *ierr) { *ierr = (PARAM_INT)pthread_attr_destroy(attr); return; } void fpthrd_attr_setstacksize(pthread_attr_t *attr, size_t *stacksize, PARAM_INT *ierr) { size_t temp; temp= *stacksize; *ierr = (PARAM_INT)pthread_attr_setstacksize(attr, temp); return; } void fpthrd_attr_getstacksize(const pthread_attr_t *attr, size_t *stacksize, PARAM_INT *ierr) { size_t temp; *ierr = (PARAM_INT)pthread_attr_getstacksize(attr, &temp); *stacksize= temp; return; } void fpthrd_attr_setdetachstate(pthread_attr_t *attr, PARAM_INT *detachstate, PARAM_INT *ierr) { int ldetachstate; ldetachstate = (int) *detachstate; *ierr = (PARAM_INT)pthread_attr_setdetachstate(attr, ldetachstate); return; } void fpthrd_attr_getdetachstate(const pthread_attr_t *attr, PARAM_INT *detachstate, PARAM_INT *ierr) { int ldetachstate; *ierr = (PARAM_INT)pthread_attr_getdetachstate(attr, &ldetachstate); *detachstate = (PARAM_INT) ldetachstate; return; } /*----------------------------------------------------------------------------*\ | | | Thread scheduling attributes | | | \*----------------------------------------------------------------------------*/ void fpthrd_attr_setscope(pthread_attr_t *attr, PARAM_INT *scope, PARAM_INT *ierr) { int lscope; lscope = (int) *scope; *ierr = (PARAM_INT)pthread_attr_setscope(attr, lscope); return; } void fpthrd_attr_getscope(const pthread_attr_t *attr, PARAM_INT *scope, PARAM_INT *ierr) { int lscope; *ierr = (PARAM_INT)pthread_attr_getscope(attr, &lscope); *scope = (PARAM_INT)lscope; return; } void fpthrd_attr_setinheritsched(pthread_attr_t *attr, PARAM_INT *inherit, PARAM_INT *ierr) { int linherit; linherit = (int) *inherit; *ierr = (PARAM_INT)pthread_attr_setinheritsched(attr, linherit); return; } void fpthrd_attr_getinheritsched(pthread_attr_t *attr, PARAM_INT *inheritsched, PARAM_INT *ierr) { int linherit; *ierr = (PARAM_INT)pthread_attr_getinheritsched(attr, &linherit); *inheritsched = (PARAM_INT)linherit; return; } void fpthrd_attr_setschedpolicy(pthread_attr_t *attr, PARAM_INT *policy, PARAM_INT *ierr) { int lpolicy; lpolicy = (int) *policy; *ierr = (PARAM_INT)pthread_attr_setschedpolicy(attr, lpolicy); return; } void fpthrd_attr_getschedpolicy(pthread_attr_t *attr, PARAM_INT *policy, PARAM_INT *ierr) { int lpolicy; *ierr = (PARAM_INT)pthread_attr_getschedpolicy(attr, &lpolicy); *policy = (PARAM_INT)lpolicy; return; } void fpthrd_attr_setschedparam(pthread_attr_t *attr, const struct sched_param *param, PARAM_INT *ierr) { *ierr = (PARAM_INT)pthread_attr_setschedparam(attr, param); return; } void fpthrd_attr_getschedparam(pthread_attr_t *attr, struct sched_param *param, PARAM_INT *ierr) { *ierr = (PARAM_INT)pthread_attr_getschedparam(attr, param); return; } /*----------------------------------------------------------------------------*\ | | | Thread creation and control | | | \*----------------------------------------------------------------------------*/ void fpthrd_create(pthread_t *thread_id, pthread_attr_t *attr, void *(*start_routine)(void *), void *arg, PARAM_INT *ierr) { pthread_t *tid; pthread_attr_t *lattr; PARAM_INT arg_in; /* This argument should never be NULL.*/ /* Butenhof uses NULL in one of the examples in his book. */ /* if(*(PARAM_INT *) thread_id == FORTRAN_NULL) */ if(*(int *)thread_id == FORTRAN_NULL) { tid=NULL; printf("Thread id is NULL\n"); } else { tid=thread_id; printf("Thread id is not empty\n"); } tid=thread_id; if(*(int *)attr == FORTRAN_NULL) { lattr=NULL; printf("Thread attributes is NULL\n"); } else { lattr=attr; printf("Thread attributes is non-empty\n"); } arg_in = *(PARAM_INT *)arg; if(arg_in == FORTRAN_NULL) { printf("Function argument is NULL\n"); *ierr = (PARAM_INT)pthread_create(tid, lattr, start_routine, NULL); } else { printf("Function argument is not empty\n"); *ierr = (PARAM_INT)pthread_create(tid, lattr, start_routine, arg); } return; } void fpthrd_join(pthread_t *thread_id, PARAM_INT *exitcode, PARAM_INT *ierr) { void *exit; exit =exitcode; if(*exitcode == (PARAM_INT)FORTRAN_NULL) /* if(*(int *)exitcode == FORTRAN_NULL) */ { exit=NULL; } *ierr = (PARAM_INT)pthread_join(*thread_id, &exit); /* #if SGI == I8 */ #ifdef SGI /* * If exitcode is long long, examine high bytes for cancel code. */ if ( exit == PTHREAD_CANCELED) { *exitcode=(PARAM_INT)FPTHREAD_CANCELED; } /*#endif*/ /* Use a reserved value to signal Fortran that a thread was cancelled. */ /*#ifdef SUN*/ #else if(exit == PTHREAD_CANCELED) *exitcode=FPTHREAD_CANCELED; else { if(*exitcode == FORTRAN_NULL) return; *exitcode = (INT_CAST *)exit; } #endif } void fpthrd_exit(PARAM_INT *val) { void *lval; lval = (int *)(*val); /* exit codes restricted to integer type */ pthread_exit(lval); } void fpthrd_detach(pthread_t *thread_id, PARAM_INT *ierr) { *ierr = (PARAM_INT)pthread_detach(*thread_id); } void fpthrd_self(pthread_t *self) { *self = pthread_self(); /* always succeeds, no error code */ } void fpthr_self(pthread_t *self) { fpthrd_self(self); } void fpthrd_equal(pthread_t *thread_id1, pthread_t *thread_id2, PARAM_INT *flag) { *flag = (PARAM_INT)pthread_equal(*thread_id1, *thread_id2); /* non-zero if equal */ } void fpthr_equal(pthread_t *thread_id1, pthread_t *thread_id2, int *flag) { fpthrd_equal(thread_id1, thread_id2, flag); } /* void fpthrd_once(pthread_once_t *once_block, void (*init_routine)(void), PARAM_INT *ierr) { *ierr = (PARAM_INT)pthread_once(once_block, init_routine); } */ /*----------------------------------------------------------------------------*\ | | | Thread scheduling control | | | \*----------------------------------------------------------------------------*/ void fpthrd_getschedparam(pthread_t *thread_id, PARAM_INT *policy, struct sched_param *param, PARAM_INT *ierr) { int lpolicy; *ierr = (PARAM_INT)pthread_getschedparam(*thread_id, &lpolicy, param); *policy = (PARAM_INT)lpolicy; return; } void fpthrd_setschedparam(pthread_t *thread_id, int *policy, const struct sched_param *param, int *ierr) { int lpolicy; lpolicy = *(int *)policy; *ierr = pthread_setschedparam(*thread_id, lpolicy, param); return; } /*----------------------------------------------------------------------------*\ | | | Thread cancellation | | | \*----------------------------------------------------------------------------*/ void fpthrd_cancel(pthread_t *thread_id, PARAM_INT *ierr) { *ierr = (PARAM_INT)pthread_cancel(*thread_id); } void fpthrd_setcancelstate(PARAM_INT *state, PARAM_INT *oldstate, PARAM_INT *ierr) { int lstate, loldstate; lstate = (int) *state; *ierr = (PARAM_INT)pthread_setcancelstate(lstate, &loldstate); *oldstate = (PARAM_INT)loldstate; } void fpthrd_setcanceltype(PARAM_INT *type, PARAM_INT *oldtype, PARAM_INT *ierr) { int ltype, loldtype; ltype = (int) *type; *ierr = (PARAM_INT)pthread_setcanceltype(ltype, &loldtype); *oldtype = (PARAM_INT)loldtype; } void fpthrd_testcancel() { pthread_testcancel(); /* always succeeds; no error code */ } void fpthr_testcancel() { pthread_testcancel(); /* always succeeds; no error code */ } /*----------------------------------------------------------------------------*\ | | | Mutex attribute manipulation and initialization | | | \*----------------------------------------------------------------------------*/ void fpthrd_mutexattr_init(pthread_mutexattr_t *attr, PARAM_INT *ierr) { *ierr = (PARAM_INT)pthread_mutexattr_init(attr); return; } void fpthrd_mutexattr_destroy(pthread_mutexattr_t *attr, PARAM_INT *ierr) { *ierr = (PARAM_INT)pthread_mutexattr_destroy(attr); return; } void fpthrd_mutexattr_getpshared(pthread_mutexattr_t *attr, PARAM_INT *pshared, PARAM_INT *ierr) #ifdef LINUX { *ierr=ENOTSUP; return; } #else { int lpshared; *ierr = (PARAM_INT)pthread_mutexattr_getpshared(attr, &lpshared); *pshared = (PARAM_INT)lpshared; return; } #endif void fpthrd_mutexattr_setpshared(pthread_mutexattr_t *attr, PARAM_INT *pshared, PARAM_INT *ierr) #ifdef LINUX { *ierr=ENOTSUP; return; } #else { int lpshared; lpshared = (int) *pshared; *ierr = (PARAM_INT)pthread_mutexattr_setpshared(attr, lpshared); return; } #endif void fpthrd_mutex_getprioceiling(pthread_mutex_t *mutex, PARAM_INT *ceiling, PARAM_INT *ierr) #ifdef LINUX { *ierr=ENOTSUP; return; } #elif CPQ { *ierr=ENOTSUP; return; } #else { int lceiling; *ierr = (PARAM_INT)pthread_mutex_getprioceiling(mutex, &lceiling); *ceiling = (PARAM_INT)lceiling; return; } #endif void fpthrd_mutex_setprioceiling(pthread_mutex_t *mutex, PARAM_INT *ceiling, PARAM_INT *old_ceiling, PARAM_INT *ierr) #ifdef LINUX { *ierr=ENOTSUP; return; } #elif CPQ { *ierr=ENOTSUP; return; } #else { int lceiling, loldceiling; lceiling = (int) *ceiling; *ierr = (PARAM_INT)pthread_mutex_setprioceiling(mutex, lceiling, &loldceiling); *old_ceiling = (PARAM_INT)loldceiling; return; } #endif /*----------------------------------------------------------------------------*\ | | | Mutex scheduling attributes | | | \*----------------------------------------------------------------------------*/ void fpthrd_mutexattr_setprotocol(pthread_mutexattr_t *attr, PARAM_INT *protocol, PARAM_INT *ierr) #ifdef LINUX { *ierr=ENOTSUP; return; } #elif CPQ { *ierr=ENOTSUP; return; } #else { int lprotocol; lprotocol = (int) *protocol; *ierr = (PARAM_INT)pthread_mutexattr_setprotocol(attr, lprotocol); return; } #endif void fpthrd_mutexattr_getprotocol(pthread_mutexattr_t *attr, PARAM_INT *protocol, PARAM_INT *ierr) #ifdef LINUX { *ierr=ENOTSUP; return; } #elif CPQ { *ierr=ENOTSUP; return; } #else { int lprotocol; *ierr = (PARAM_INT)pthread_mutexattr_getprotocol(attr, &lprotocol); *protocol = (PARAM_INT)lprotocol; return; } #endif /*----------------------------------------------------------------------------*\ | | | Mutex creation and control | | | \*----------------------------------------------------------------------------*/ void fpthrd_mutex_init(pthread_mutex_t *mutex, pthread_mutexattr_t *attr, PARAM_INT *ierr) { pthread_mutexattr_t *lattr; if(*(PARAM_INT *) attr == FORTRAN_NULL) { lattr=NULL; } else { lattr = attr; } *ierr = (PARAM_INT)pthread_mutex_init(mutex, lattr); return; } void fpthrd_mutex_destroy(pthread_mutex_t *mutex, PARAM_INT *ierr) { *ierr = (PARAM_INT)pthread_mutex_destroy(mutex); return; } void fpthrd_mutex_lock(pthread_mutex_t *mutex, PARAM_INT *ierr) { *ierr = (PARAM_INT)pthread_mutex_lock(mutex); return; } void fpthrd_mutex_trylock(pthread_mutex_t *mutex, PARAM_INT *ierr) { *ierr = (PARAM_INT)pthread_mutex_trylock(mutex); return; } void fpthrd_mutex_unlock(pthread_mutex_t *mutex, PARAM_INT *ierr) { *ierr = (PARAM_INT)pthread_mutex_unlock(mutex); return; } /*----------------------------------------------------------------------------*\ | | | Mutex scheduling control | | | \*----------------------------------------------------------------------------*/ void fpthrd_mutexattr_setprioceiling(pthread_mutexattr_t *attr, PARAM_INT *prioceiling, PARAM_INT *ierr) #ifdef LINUX { *ierr=ENOTSUP; return; } #elif CPQ { *ierr=ENOTSUP; return; } #else { int lprioceiling; lprioceiling = (int) *prioceiling; *ierr = (PARAM_INT)pthread_mutexattr_setprioceiling(attr, lprioceiling); return; } #endif void fpthrd_mutexattr_getprioceiling(pthread_mutexattr_t *attr, PARAM_INT *prioceiling, PARAM_INT *ierr) #ifdef LINUX { *ierr=ENOTSUP; return; } #elif CPQ { *ierr=ENOTSUP; return; } #else { int lprioceiling; *ierr = (PARAM_INT)pthread_mutexattr_getprioceiling(attr, &lprioceiling); *prioceiling = (PARAM_INT)lprioceiling; return; } #endif /*----------------------------------------------------------------------------*\ | | | Condition variable initialization attributes | | | \*----------------------------------------------------------------------------*/ void fpthrd_condattr_init(pthread_condattr_t *attr, PARAM_INT *ierr) { *ierr = (PARAM_INT)pthread_condattr_init(attr); return; } void fpthrd_condattr_destroy(pthread_condattr_t *attr, PARAM_INT *ierr) { *ierr = (PARAM_INT)pthread_condattr_destroy(attr); return; } void fpthrd_condattr_getpshared(pthread_condattr_t *attr, PARAM_INT *pshared, PARAM_INT *ierr) #ifndef LINUX { int lpshared; *ierr = (PARAM_INT)pthread_condattr_getpshared(attr, &lpshared); *pshared = (PARAM_INT)lpshared; return; } #else { *ierr=ENOTSUP; return; } #endif void fpthrd_condattr_setpshared(pthread_condattr_t *attr, PARAM_INT *pshared, PARAM_INT *ierr) #ifndef LINUX { int lpshared; lpshared = (int) *pshared; *ierr = (PARAM_INT)pthread_condattr_setpshared(attr, lpshared); return; } #else { *ierr=ENOTSUP; return; } #endif /*----------------------------------------------------------------------------*\ | | | Condition variable operations | | | \*----------------------------------------------------------------------------*/ void fpthrd_cond_init(pthread_cond_t *cond, pthread_condattr_t *attr, PARAM_INT *ierr) { pthread_condattr_t *lattr; if(*(PARAM_INT *)attr == FORTRAN_NULL) { lattr=NULL; } else { lattr = attr; } *ierr = (PARAM_INT)pthread_cond_init(cond, lattr); return; } void fpthrd_cond_destroy(pthread_cond_t *cond, PARAM_INT *ierr) { *ierr = (PARAM_INT)pthread_cond_destroy(cond); return; } void fpthrd_cond_signal(pthread_cond_t *cond, PARAM_INT *ierr) { *ierr = (PARAM_INT)pthread_cond_signal(cond); return; } void fpthrd_cond_broadcast(pthread_cond_t *cond, PARAM_INT *ierr) { *ierr = (PARAM_INT)pthread_cond_broadcast(cond); return; } void fpthrd_cond_wait(pthread_cond_t *cond, pthread_mutex_t *mutex, PARAM_INT *ierr) { *ierr = (PARAM_INT)pthread_cond_wait(cond, mutex); return; } void fpthrd_cond_timedwait(pthread_cond_t *cond, pthread_mutex_t *mutex, const struct timespec *abstime, PARAM_INT *ierr) { *ierr = (PARAM_INT)pthread_cond_timedwait(cond, mutex, abstime); return; } /*----------------------------------------------------------------------------*\ | | | Bindings to nonportable functions | | | \*----------------------------------------------------------------------------*/ void fpthrd_setconcurrency(PARAM_INT *level, PARAM_INT *ierr) { #ifdef SGI int llevel; llevel = (int) *level; *ierr = (PARAM_INT)pthread_setconcurrency(llevel); #endif #ifdef LINUX int llevel; llevel = (int) *level; *ierr = (PARAM_INT)pthread_setconcurrency(llevel); #endif #ifdef SUN int llevel; llevel = *(int *)level; if(llevel > 0) {thr_setconcurrency(llevel); *ierr = 0; return;} *ierr=EINVAL; #endif #ifdef IBM *ierr=ENOTSUP; #endif } void fpthrd_getconcurrency(PARAM_INT *level) { #ifdef SGI *level = (PARAM_INT)pthread_getconcurrency(); #endif #ifdef LINUX *level = (PARAM_INT)pthread_getconcurrency(); #endif #ifdef SUN *level = (PARAM_INT)thr_getconcurrency(); #endif #ifdef IBM *level = 0; #endif } SHAR_EOF fi # end of overwriting check if test -f 'summary.h' then echo shar: will not over-write existing file "'summary.h'" else cat << "SHAR_EOF" > 'summary.h' /******************************************************************************* *** *** *** 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, 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. | \*---------------------------------------------------------------------------*/ #include #include #include #include #include /* 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 summary.h. Last change on 4 December 2000. */ #ifdef SGI #define PTHREAD_STACK_MIN _sysconf(_SC_THREAD_STACK_MIN) #define PTHREAD_THREADS_MAX 1024 /*_sysconf(_SC_THREADS_MAX)*/ #endif #ifdef SUN /* #include /* Needed to get defn of sigset_t */ #include /* Needed to get defn of sigset_t */ #define PTHREAD_STACK_MIN _sysconf(_SC_THREAD_STACK_MIN) #define PTHREAD_THREADS_MAX _POSIX_THREAD_THREADS_MAX #define PTHREAD_KEYS_MAX _POSIX_THREAD_KEYS_MAX #define PTHREAD_PRIO_INHERIT 2 #define PTHREAD_PRIO_PROTECT 1 #define PTHREAD_PRIO_NONE 0 #define PTHREAD_DESTRUCTOR_ITERATIONS 4 #endif #ifdef IBM #define PTHREAD_CREATE_JOINABLE 0 #define PTHREAD_PROCESS_PRIVATE 0 #define PTHREAD_PROCESS_SHARED 0 #define PTHREAD_PRIO_INHERIT 2 #define PTHREAD_PRIO_PROTECT 1 #define PTHREAD_PRIO_NONE 0 #define PTHREAD_DESTRUCTOR_ITERATIONS 4 #endif #ifdef CPQ #define PTHREAD_THREADS_MAX _POSIX_THREAD_THREADS_MAX #define PTHREAD_PRIO_INHERIT 2 #define PTHREAD_PRIO_PROTECT 1 #define PTHREAD_PRIO_NONE 0 #endif #ifdef LINUX #define PTHREAD_PRIO_INHERIT 2 #define PTHREAD_PRIO_PROTECT 1 #define PTHREAD_PRIO_NONE 0 #endif /* * NOTE: the "do {" ... "} while (0);" bracketing around the macros * allows the various printing and abort macros to be used as if they * were function calls, even in contexts where a trailing ";" would * generate a null statement. For example, * * if (status != 0) * err_abort (status, "message"); * else * return status; * * will not compile if err_abort is a macro ending with "}", because * C does not expect a ";" to follow the "}". Because C does expect * a ";" following the ")" in the do...while construct, err_abort and * errno_abort can be used as if they were function calls. */ #define test_comment(test_number,text)\ do {fprintf (stdout, "Testing %3d%s at \"%s\", line %d\n",test_number, text, __FILE__, __LINE__);} while(0) #define err_abort(test_number,code,text) do { \ if(code != 0)fprintf (stdout, "Failed %4d %s at \"%s\":%d: Status= %3d\n", \ test_number, text, __FILE__, __LINE__, code); \ if(code != 0) abort ();\ } while (0) #define skip do{fprintf (stdout,"\n");} while(0) SHAR_EOF fi # end of overwriting check cd .. cd .. cd .. # End of shell archive exit 0