35 #include "qrm_common.h"
58 real(kind(1.d0)),
intent(inout) :: b(:,:)
59 real(kind(1.d0)),
intent(out) :: x(:,:)
61 integer :: qrm_nth, nth, thn, info, f, dones
66 type(dqrm_front_type
),
pointer :: front
67 integer,
allocatable :: status(:)
68 type(qrm_adata_type
),
pointer :: adata
69 type(dqrm_fdata_type
),
pointer :: fdata
72 integer(kind=omp_lock_kind),
allocatable :: locks(:)
73 integer(kind=omp_lock_kind) :: dlock
78 character(len=*),
parameter :: name=
'qrm_aply_rt'
82 __qrm_prnt_dbg(
'("Solving for R^T")')
85 adata => qrm_mat%adata
86 fdata => qrm_mat%fdata
89 if (qrm_mat%adata%ncsing .gt. 0)
then
91 __qrm_check_ret(name,
'qrm_solve_sing_front',9999)
101 __qrm_check_ret(name,
'qrm_aalloc',9999)
104 do f = 1, adata%nnodes
107 do i=adata%childptr(f), adata%childptr(f+1)-1
109 if(adata%small(c) .eq. 0) status(f) = status(f)-1
114 do i=adata%nleaves, 1, -1
116 status(adata%leaves(
i)) = qrm_ready_
120 if(adata%ncsing .gt. 0)
then
126 #if defined (_OPENMP)
127 call omp_set_num_threads(1)
128 qrm_nth = qrm_mat%icntl(qrm_nthreads_)
136 #if defined (_OPENMP)
137 nth = omp_get_num_threads()
138 thn = omp_get_thread_num()
149 if(qrm_err_stack%nelem .gt. 0) goto 9998
157 if(.not. got_task) cycle taskloop
180 if(qrm_err_stack%nelem .gt. 0)
then
190 if(err_act .eq. qrm_abort_)
then
206 type(dqrm_front_type
),
pointer :: front
212 #if defined (_OPENMP)
213 thn=omp_get_thread_num()
226 front => fdata%front_list(f)
229 if(status(f) .eq. qrm_ready_)
then
234 status(f) = qrm_busy_
264 if(dones .eq. fdata%nfronts)
then
282 type(dqrm_front_type
),
pointer :: front
283 integer :: f, p, c, info
288 front => qrm_mat%fdata%front_list(task%front)
289 f = qrm_mat%adata%parent(task%front)
294 do p = adata%childptr(front%num), adata%childptr(front%num+1)-1
297 if(info .ne. 0) goto 9997
301 status(task%front) = qrm_done_
309 status(f) = status(f)+1
326 integer :: fnum, info
328 type(dqrm_front_type
),
pointer :: front
337 front => fdata%front_list(node)
339 if (status(node) .eq. qrm_ready_)
then
344 if(info .ne. 0) goto 9998
350 f = adata%parent(node)
353 status(f) = status(f)+1
357 status(node) = qrm_done_
359 if(node .eq. fnum)
exit subtree
361 node = adata%parent(node)
362 if(node .eq. 0)
exit subtree
366 node = adata%child(adata%childptr(node+1)+status(node))
390 type(dqrm_front_type
) :: front
396 #if defined (sprec) || defined (dprec)
397 character,
parameter :: tr=
't', notr=
'n'
398 #elif defined (cprec) || defined (zprec)
399 character,
parameter :: tr=
'c', notr=
'n'
402 integer :: pv1, c, k, m, pv2, n, r,
i, cnt, jp, pk, j
403 real(kind(1.d0)),
allocatable :: in_b(:,:)
405 character(len=*),
parameter :: name=
'solve_rt'
407 #if defined (_OPENMP)
408 thn=omp_get_thread_num()
414 if (min(front%m, front%n) .le. 0) goto 10
415 if (front%npiv .le. 0) goto 10
422 __qrm_check_ret(name,
'qrm_aalloc',9999)
425 in_b(1:front%npiv,:) = b(front%cols(1:front%npiv),:)
426 in_b(front%npiv+1:front%n,:) = 0.d0
457 outer:
do jp = 1, front%npiv, front%nb
458 pk = min(front%nb, front%npiv-jp+1)
459 if(pk .le. 0)
exit outer
461 inner:
do j = jp, jp+pk-1, front%ib
462 m = min(front%ib, jp+pk - j)
463 if(m .le. 0)
exit inner
467 call dtrsm(
'l',
'u', tr,
'n', m, n, 1.d0, front%r(cnt), m, &
468 & in_b(j,1), front%n)
469 if(k.gt.0) call dgemm(tr, notr, k, n, m, -1.d0, front%r(cnt+m*m), m, &
470 & in_b(j,1), front%n, 1.d0, in_b(j+m,1), front%n)
471 cnt = cnt+m*(front%n-j+1)
479 x(front%rows(1:front%npiv),:) = in_b(1:front%npiv,:)
480 b(front%cols(front%npiv+1:front%n),:) = b(front%cols(front%npiv+1:front%n),:)+in_b(front%npiv+1:front%n,:)
484 __qrm_check_ret(name,
'qrm_adealloc',9999)
This module contains all the error management routines and data.
subroutine qrm_init_task_queue(h)
Inititalizes a set of queues attached to a family of threads referenced through the handle h...
subroutine check_solvert_over()
integer function qrm_queue_next(q, n)
Returns the element that follows n in the queue q. Very useful for sweeping through a queue...
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.
subroutine qrm_clean_task_queue(h)
Destroyes a set of queues.
This type defines the handle for the queues attached to a family of threads.
subroutine dqrm_solve_sing_front(qrm_mat, b, x, trans)
This function handles the front containing the singletons during the solve for R or R'...
This module contains all the interfaces for the typed routines in the solve phase.
A data type meant to to define a queue.
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 ...
subroutine qrm_queue_rm(q, n)
Removes (without returning it) an element from a queue.
This module contains the interfaces of all non-typed routines.
subroutine qrm_err_act_restore(err_act)
Restores the value of the qrm_err_act variable.
subroutine qrm_queue_push(q, elem)
Pushes an element on a queue.
subroutine dqrm_solve_rt(qrm_mat, b, x)
This function solves for R' against multiple vectors.
This module contains all the facilities for front queues.
subroutine front_rt(front, info)
subroutine solve_rt(task, thn)
This module contains the definition of the basic sparse matrix type and of the associated methods...
This module contains generic interfaces for a number of auxiliary tools.
subroutine qrm_err_check()
This subroutine checks the errors stack. If something is found all the entries in the stack are poppe...
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 type defines a computational task.
subroutine qrm_par_mem_init()
This routine has to be called at the beginning of a parallel section. Afterwards, each thread will up...
subroutine do_subtree_rt(fnum, info)
This type defines the data structure used to store a matrix.
integer function qrm_task_queue_card(h)
Returns the number of tasks present on a set of queues referenced by a handle.
subroutine qrm_par_mem_finalize()
This module implements the memory handling routines. Pretty mucch allocations and deallocations...
This module contains an implementation of some operations on triangular/trapezoidal matrices stored i...
logical function qrm_sched_task(h, tsk, pol, q)
Pushes a task on a queue.
This module contains the definition of a task type that is used for scheduling tasks during the facto...
subroutine qrm_err_push(code, sub, ied, aed)
This subroutine pushes an error on top of the stack.
subroutine qrm_queue_free(q)
Frees a queue.
subroutine qrm_err_act_save(err_act)
Saves a copy of the qrm_err_act variable.
subroutine fill_queue_rt()