35 #include "qrm_common.h" 82 integer :: i, j, f, p, pp, ppp, root, node, roff, ne, np
83 integer :: first, c, ib, nlz, nth, leaves, totleaves
84 integer :: m, n, k, cyc, nb, fm, fn, fk
85 real(kind(1.d0)),
allocatable :: n_weight(:), t_weight(:), lzero_w(:), proc_w(:)
86 real(kind(1.d0)) :: rm, rk, rn, totflops, smallth
87 integer,
allocatable :: col_map(:), mark(:), stair(:), lzero(:), aux(:)
88 integer,
pointer :: porder(:), rc(:), parent(:), fcol(:), fcol_ptr(:)
92 integer(kind=8) :: hsize, rsize
95 character(len=*),
parameter :: name=
'qrm_symbolic' 101 porder => adata%cperm
103 parent => adata%parent
106 call qrm_aalloc(adata%fcol_ptr, adata%nnodes+1)
107 call qrm_aalloc(adata%fcol, sum(rc))
108 __qrm_check_ret(name,
'qrm_aalloc',9999)
112 fcol_ptr => adata%fcol_ptr
119 call qrm_aalloc(col_map, graph%n)
120 call qrm_aalloc(mark, adata%nnodes)
121 __qrm_check_ret(name,
'qrm_aalloc2',9999)
129 do p=adata%cp_ptr(f), adata%cp_ptr(f+1)-1
135 fcol_ptr(f+1) = fcol_ptr(f)+max(rc(f-1),0)
136 do p=adata%cp_ptr(f), adata%cp_ptr(f+1)-1
143 if(p .ne. graph%n+1)
then 144 __qrm_prnt_dbg(.ne.
'("Error in symbolic. i n ",i5,2x,i5)')p, graph%n
151 __qrm_check_ret(name,
'qrm_spmat_convert',9999)
154 g_csr%jcn(i) = adata%icperm(g_csr%jcn(i))
160 g_csr%jcn(i) = adata%cperm(g_csr%jcn(i))
168 do p=adata%cp_ptr(f), adata%cp_ptr(f+1)-1
174 fcol(fcol_ptr(f+1)) = i
175 fcol_ptr(f+1) = fcol_ptr(f+1)+1
177 do pp = graph%jptr(i), graph%jptr(i+1)-1
182 do ppp=g_csr%iptr(k), g_csr%iptr(k+1)-1
184 if(adata%icperm(j) .ge. adata%icperm(i))
exit 192 if((mark(node) .eq. i) .or. (node .eq. f))
exit 194 fcol(fcol_ptr(node+1)) = i
195 fcol_ptr(node+1) = fcol_ptr(node+1)+1
205 call qrm_adealloc(mark)
206 call qrm_aalloc(adata%nfrows, adata%nnodes)
207 __qrm_check_ret(name,
'qrm_aalloc2.5',9999)
212 call qrm_aalloc(n_weight, adata%nnodes)
213 call qrm_aalloc(t_weight, adata%nnodes)
218 call qrm_aalloc(stair, maxval(rc)+1)
219 __qrm_check_ret(name,
'qrm_aalloc',9999)
221 call qrm_get(graph,
'qrm_ib', ib)
222 call qrm_get(graph,
'qrm_nb', nb)
240 k = fcol(fcol_ptr(f)+j-1)
247 roff = adata%stair(f-1)+1
252 do p=roff, adata%stair(f)
256 first = col_map(g_csr%jcn(g_csr%iptr(i)))
263 stair(first) = stair(first)+1
267 do ppp=adata%childptr(f), adata%childptr(f+1)-1
272 ne = min(rc(c), adata%nfrows(c))
273 np = adata%cp_ptr(c+1)-adata%cp_ptr(c)
277 j = fcol(fcol_ptr(c)+i-1)
279 stair(first) = stair(first)+1
285 stair(i) = stair(i)+stair(i-1)
288 adata%nfrows(f) = stair(rc(f))
292 ne = min(rc(f),adata%nfrows(f))
294 n_weight(f) = n_weight(f)+
qrm_count_flops(max(stair(i)-i+1,0),rc(f)-i,1,
'panel')
295 n_weight(f) = n_weight(f)+
qrm_count_flops(max(stair(i)-i+1,0),rc(f)-i,1,
'update')
296 hsize = hsize+max(stair(i)-i+1,0)
300 np = adata%cp_ptr(f+1)-adata%cp_ptr(f)
301 rsize = rsize + np*(np+1)/2 + np*(rc(f)-np)
303 t_weight(f) = t_weight(f)+n_weight(f)
305 if(p .ne. 0) t_weight(p) = t_weight(p)+t_weight(f)
309 totflops = sum(n_weight)
316 __qrm_prnt_dbg(
'("Total estimated number of MFLOPS: ",i10)')floor(totflops)
321 __qrm_check_ret(name,
'qrm_spmat_destroy',9999)
324 call qrm_adealloc(col_map)
325 call qrm_adealloc(stair)
326 call qrm_aalloc(lzero, adata%nnodes)
327 call qrm_aalloc(adata%small, adata%nnodes)
334 call qrm_aalloc(lzero_w, adata%nnodes)
335 call qrm_aalloc(aux, adata%nnodes+2, lbnd=0)
336 call qrm_get(graph,
'qrm_nthreads', nth)
338 if(nth .gt. adata%nnodes) nth = adata%nnodes
340 call qrm_aalloc(proc_w, nth)
353 if(parent(i) .eq. 0)
then 354 if(t_weight(i) .gt. smallth*totflops)
then 357 lzero_w(nlz) = t_weight(i)
362 if(adata%childptr(i+1) .eq. adata%childptr(i)) totleaves = totleaves+1
370 if(nlz .gt. nth*max(2.d0,(log(
real(nth,kind(1.d0)))/log(2.d0))**2)) exit
374 call qrm_mergesort(nlz, lzero_w(1:nlz), aux(0:nlz+1), order=-1)
375 call qrm_mergeswap(nlz, aux(0:nlz+1), lzero(1:nlz), lzero_w(1:nlz))
381 proc_w(p) = proc_w(p) + lzero_w(i)
385 rm = minval(proc_w)/maxval(proc_w)
388 if((rm .gt. 0.9) .and. (nlz .ge. 1*nth))
exit 393 if(leaves .eq. totleaves)
exit godown
395 if(leaves .eq. nlz)
then 396 if(nlz .ge. nth*max(2.d0,(log(
real(nth,kind(1.d0)))/log(2.d0))**2)) then
399 smallth = smallth/2.d0
400 if(smallth .lt. 0.0001)
then 410 do p=adata%childptr(n), adata%childptr(n+1)-1
412 if(t_weight(c) .gt. smallth*totflops)
then 417 lzero_w(nlz) = t_weight(c)
427 lzero(leaves+1) = lzero(nlz)
428 lzero_w(leaves+1) = lzero_w(nlz)
436 do p=adata%childptr(n), adata%childptr(n+1)-1
444 t_weight = t_weight/totflops * 100
448 call qrm_adealloc(lzero)
449 call qrm_adealloc(lzero_w)
450 call qrm_adealloc(proc_w)
451 call qrm_adealloc(aux)
452 call qrm_adealloc(n_weight)
453 call qrm_adealloc(t_weight)
474 integer,
allocatable :: aux(:)
475 integer :: i, n, k1, k2
479 allocate(aux(0:mat%n+1))
subroutine dqrm_symbolic(graph)
This subroutine computes the symbolic QR factorization of a matrix.
This module contains routines for sorting.
This module contains the interfaces of all non-typed routines.
Generif interface for the ::dqrm_pgeti, ::dqrm_pgetr and.
This module contains the definition of the analysis data type.
subroutine qrm_err_act_save(err_act)
Saves a copy of the qrm_err_act variable.
This module contains all the error management routines and data.
This module contains the definition of the basic sparse matrix type and of the associated methods...
The main data type for the analysis phase.
integer, parameter qrm_abort_
Possible actions to be performed upon detection of an error.
subroutine dqrm_spmat_destroy(qrm_spmat, all)
This subroutine destroyes a qrm_spmat instance.
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_count_realflops ::qrm_count_pureflops.
This type defines the data structure used to store a matrix.
subroutine qrm_err_act_restore(err_act)
Restores the value of the qrm_err_act variable.
subroutine dqrm_spmat_convert(in_mat, out_mat, fmt, values)
This subroutine converts an input matrix into a different storage format. Optionally the values may b...