35 #include "qrm_common.h" 56 real(kind(1.d0)) :: b(:,:)
59 integer :: qrm_nth, nth, thn, info, f, dones
64 type(dqrm_front_type),
pointer :: front
65 integer,
allocatable :: status(:)
66 type(qrm_adata_type),
pointer :: adata
67 type(dqrm_fdata_type),
pointer :: fdata
70 integer(kind=omp_lock_kind),
allocatable :: locks(:)
71 integer(kind=omp_lock_kind) :: dlock
76 character(len=*),
parameter :: name=
'qrm_aply_qt' 80 __qrm_prnt_dbg(
'("Applying Q^T")')
83 adata => qrm_mat%adata
84 fdata => qrm_mat%fdata
93 __qrm_check_ret(name,
'qrm_aalloc',9999)
95 allocate(locks(adata%nnodes))
96 call omp_init_lock(dlock)
99 do f = 1, adata%nnodes
101 #if defined (_OPENMP) 102 call omp_init_lock(locks(f))
104 do i=adata%childptr(f), adata%childptr(f+1)-1
106 if(adata%small(c) .eq. 0) status(f) = status(f)-1
111 do i=adata%nleaves, 1, -1
113 status(adata%leaves(i)) = qrm_ready_
116 if(adata%ncsing .gt. 0)
then 122 #if defined (_OPENMP) 123 call omp_set_num_threads(1)
124 qrm_nth=qrm_mat%icntl(qrm_nthreads_)
132 #if defined (_OPENMP) 133 nth = omp_get_num_threads()
134 thn = omp_get_thread_num()
155 if(.not. got_task) cycle taskloop
175 #if defined (_OPENMP) 204 type(dqrm_front_type),
pointer :: front
212 #if defined (_OPENMP) 213 thn = omp_get_thread_num()
225 front => fdata%front_list(f)
229 if(status(f) .eq. qrm_ready_)
then 235 status(f) = qrm_busy_
268 if(dones .eq. fdata%nfronts)
then 282 subroutine apply_qt(task, thn, ready_q)
287 type(dqrm_front_type),
pointer :: front
288 integer :: f, p, c, info
294 front => qrm_mat%fdata%front_list(task%front)
295 f = qrm_mat%adata%parent(task%front)
300 do p = adata%childptr(front%num), adata%childptr(front%num+1)-1
303 if(info .ne. 0)
goto 9997
307 if(info .ne. 0)
goto 9997
308 status(task%front) = qrm_done_
316 status(f) = status(f)+1
332 integer :: fnum, info
334 type(dqrm_front_type),
pointer :: front
343 front => fdata%front_list(node)
345 if (status(node) .eq. qrm_ready_)
then 350 if(info .ne. 0)
goto 9998
356 f = adata%parent(node)
359 status(f) = status(f)+1
363 status(node) = qrm_done_
365 if(node .eq. fnum)
exit subtree
367 node = adata%parent(node)
368 if(node .eq. 0)
exit subtree
372 node = adata%child(adata%childptr(node+1)+status(node))
396 type(dqrm_front_type) :: front
399 integer :: pv1, c, k, m, pv2, n, i, j, pk, p, cnt, jp
402 real(kind(1.d0)),
allocatable :: work(:,:), in_b(:,:), t(:,:)
405 character(len=*),
parameter :: name=
'front_qt' 407 f = adata%parent(front%num)
410 if (min(front%m, front%n) .le. 0)
goto 9999
412 #if defined (_OPENMP) 413 call omp_set_lock( locks(front%num) )
414 thn = omp_get_thread_num()
426 __qrm_check_ret(name,
'qrm_aalloc',9999)
428 in_b = b(front%rows,:)
455 outer:
do jp = 1, front%n, front%nb
456 pk = min(front%nb, front%ne-jp+1)
457 if(pk .le. 0)
exit outer
459 inner:
do j = jp, jp+pk-1, front%ib
460 k = min(front%ib, jp+pk - j)
461 if(k .le. 0)
exit inner
462 m = max(front%stair(j+k-1),j+k-1) - j+1
463 call dlarfb(
'l',
't',
'f',
'c', m, n, k, front%h(cnt), m, front%h(cnt), &
464 & m, in_b(j,1), front%m, work(1,1), n)
471 b(front%rows,:) = in_b
477 __qrm_check_ret(name,
'qrm_adelloc',9999)
480 #if defined (_OPENMP) 481 call omp_unset_lock( locks(front%num) )
subroutine qrm_clean_task_queue(h)
Destroyes a set of queues.
This module contains generic interfaces for a number of auxiliary tools.
subroutine dqrm_apply_qt(qrm_mat, b)
This function applies Q' to a vector/matrix.
Generic interface for the qrm_adealloc_i, qrm_adealloc_2i, qrm_adealloc_s, qrm_adealloc_2s, qrm_adealloc_3s, qrm_adealloc_d, qrm_adealloc_2d, qrm_adealloc_3d, qrm_adealloc_c, qrm_adealloc_2c, qrm_adealloc_3c, qrm_adealloc_z, qrm_adealloc_2z, qrm_adealloc_3z, routines.
This module contains all the facilities for front queues.
This type defines the handle for the queues attached to a family of threads.
This module contains the interfaces of all non-typed routines.
A data type meant to to define a queue.
subroutine qrm_err_push(code, sub, ied, aed)
This subroutine pushes an error on top of the stack.
subroutine qrm_par_mem_finalize()
subroutine front_qt(front, info)
subroutine qrm_par_mem_init()
This routine has to be called at the beginning of a parallel section. Afterwards, each thread will up...
subroutine qrm_err_act_save(err_act)
Saves a copy of the qrm_err_act variable.
subroutine do_subtree_qt(fnum, info)
This module contains the definition of a task type that is used for scheduling tasks during the facto...
logical function qrm_sched_task(h, tsk, pol, q)
Pushes a task on a queue.
This module contains all the error management routines and data.
subroutine fill_queue_qt(ready_q, tq_h)
This module contains the definition of the basic sparse matrix type and of the associated methods...
integer, parameter qrm_task_exit_
subroutine qrm_queue_rm(q, n)
Removes (without returning it) an element from a queue.
subroutine qrm_init_task_queue(h)
Inititalizes a set of queues attached to a family of threads referenced through the handle h...
subroutine check_applyqt_over(tq_h)
Generic interface for the qrm_aalloc_i, qrm_aalloc_2i, qrm_aalloc_s, qrm_aalloc_2s, qrm_aalloc_3s, qrm_aalloc_d, qrm_aalloc_2d, qrm_aalloc_3d, qrm_aalloc_c, qrm_aalloc_2c, qrm_aalloc_3c, qrm_aalloc_z, qrm_aalloc_2z, qrm_aalloc_3z, routines.
This module contains an implementation of some operations on triangular/trapezoidal matrices stored i...
integer, parameter qrm_abort_
Possible actions to be performed upon detection of an error.
logical function qrm_get_task(h, tsk)
Pops a task from a queue. Tasks are always popped from the head of the queue. The return value is ...
This type defines a computational task.
subroutine qrm_err_check()
This subroutine checks the errors stack. If something is found all the entries in the stack are poppe...
subroutine qrm_queue_push(q, elem)
Pushes an element on a queue.
type(qrm_err_stack_type), save qrm_err_stack
The errors stack.
integer function qrm_task_queue_card(h)
Returns the number of tasks present on a set of queues referenced by a handle.
This type defines the data structure used to store a matrix.
subroutine qrm_queue_free(q)
Frees a queue.
integer, parameter qrm_task_app_
integer, parameter qrm_lifo_
parameter to define the policy of the queue: LIFO
subroutine apply_qt(task, thn, ready_q)
This module implements the memory handling routines. Pretty mucch allocations and deallocations...
subroutine qrm_err_act_restore(err_act)
Restores the value of the qrm_err_act variable.
integer function qrm_queue_next(q, n)
Returns the element that follows n in the queue q. Very useful for sweeping through a queue...