OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
zmumps_sol_es.F
Go to the documentation of this file.
1C
2C This file is part of MUMPS 5.5.1, released
3C on Tue Jul 12 13:17:24 UTC 2022
4C
5C
6C Copyright 1991-2022 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria,
7C Mumps Technologies, University of Bordeaux.
8C
9C This version of MUMPS is provided to you free of charge. It is
10C released under the CeCILL-C license
11C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and
12C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html)
13C
14 MODULE zmumps_sol_es
15 PRIVATE
16 PUBLIC:: pruned_size_loaded
17 PUBLIC:: zmumps_chain_prun_nodes
18 PUBLIC:: zmumps_chain_prun_nodes_stats
19 PUBLIC:: zmumps_initialize_rhs_bounds
20 PUBLIC:: zmumps_propagate_rhs_bounds
21 PUBLIC:: zmumps_tree_prun_nodes
22 PUBLIC:: zmumps_tree_prun_nodes_stats
23 PUBLIC:: zmumps_sol_es_init
24 INTEGER(8), POINTER, DIMENSION(:,:) :: size_of_block
25 INTEGER(8) :: pruned_size_loaded
26 include 'mumps_headers.h'
27 CONTAINS
28 SUBROUTINE zmumps_sol_es_init(SIZE_OF_BLOCK_ARG, KEEP201)
29 IMPLICIT NONE
30 INTEGER, INTENT(IN) :: keep201
31 INTEGER(8), POINTER, DIMENSION(:,:) :: size_of_block_arg
32 IF (keep201 > 0) THEN
33 size_of_block => size_of_block_arg
34 ELSE
35 NULLIFY(size_of_block)
36 ENDIF
37 RETURN
38 END SUBROUTINE zmumps_sol_es_init
39 SUBROUTINE zmumps_tree_prun_nodes(
40 & fill,
41 & DAD, NE_STEPS, FRERE, KEEP28,
42 & FILS, STEP, N,
43 & nodes_RHS, nb_nodes_RHS,
44 & TO_PROCESS,
45 & nb_prun_nodes, nb_prun_roots, nb_prun_leaves,
46 & Pruned_List, Pruned_Roots, Pruned_Leaves
47 & )
48 IMPLICIT NONE
49 LOGICAL, INTENT(IN) :: fill
50 INTEGER, INTENT(IN) :: n, keep28
51 INTEGER, INTENT(IN) :: dad(keep28),ne_steps(keep28),frere(keep28)
52 INTEGER, INTENT(IN) :: fils(n), step(n)
53 INTEGER, INTENT(IN) :: nodes_rhs(keep28), nb_nodes_rhs
54 INTEGER :: nb_prun_nodes
55 INTEGER, OPTIONAL, INTENT(INOUT):: pruned_list(nb_prun_nodes)
56 INTEGER :: nb_prun_roots
57 INTEGER, OPTIONAL, INTENT(INOUT):: pruned_roots(nb_prun_roots)
58 INTEGER :: nb_prun_leaves
59 INTEGER, OPTIONAL, INTENT(INOUT):: pruned_leaves(nb_prun_leaves)
60 LOGICAL :: to_process(keep28)
61 INTEGER :: in, i, istep, tmp, tmpsave
62 LOGICAL :: fils_visited
63 nb_prun_nodes = 0
64 nb_prun_leaves = 0
65 to_process(:) = .false.
66 DO i = 1, nb_nodes_rhs
67 tmp = nodes_rhs(i)
68 tmpsave = tmp
69 istep = step(tmp)
70 DO WHILE(.NOT.to_process(istep))
71 to_process(istep) = .true.
72 nb_prun_nodes = nb_prun_nodes + 1
73 IF(fill) THEN
74 pruned_list(nb_prun_nodes) = tmp
75 END IF
76 in = fils(tmp)
77 DO WHILE(in.GT.0)
78 in = fils(in)
79 END DO
80 fils_visited = .false.
81 IF (in.LT.0) THEN
82 fils_visited = to_process(step(-in))
83 ENDIF
84 IF ( in.LT.0.and..NOT.fils_visited)
85 & THEN
86 tmp = -in
87 istep = step(tmp)
88 ELSE
89 IF (in.EQ.0) THEN
90 nb_prun_leaves = nb_prun_leaves + 1
91 IF (fill) THEN
92 pruned_leaves(nb_prun_leaves) = tmp
93 END IF
94 ELSE
95 tmp = -in
96 istep = step(tmp)
97 ENDIF
98 DO WHILE (tmp.NE.tmpsave)
99 tmp = abs(frere(istep))
100 IF(tmp.NE.0) THEN
101 istep = step(tmp)
102 ELSE
103 exit
104 END IF
105 IF (.NOT.to_process(istep)) exit
106 END DO
107 END IF
108 END DO
109 END DO
110 nb_prun_roots = 0
111 DO i=1,nb_nodes_rhs
112 tmp = nodes_rhs(i)
113 istep = step(tmp)
114 IF(dad(istep).NE.0) THEN
115 IF(.NOT.to_process(step(dad(istep)))) THEN
116 nb_prun_roots = nb_prun_roots + 1
117 IF(fill) THEN
118 pruned_roots(nb_prun_roots) = tmp
119 END IF
120 END IF
121 ELSE
122 nb_prun_roots = nb_prun_roots + 1
123 IF(fill) THEN
124 pruned_roots(nb_prun_roots) = tmp
125 END IF
126 END IF
127 END DO
128 RETURN
129 END SUBROUTINE zmumps_tree_prun_nodes
130 SUBROUTINE zmumps_chain_prun_nodes(
131 & fill,
132 & DAD, KEEP28,
133 & STEP, N,
134 & nodes_RHS, nb_nodes_RHS,
135 & Pruned_SONS, TO_PROCESS,
136 & nb_prun_nodes,nb_prun_roots, nb_prun_leaves,
137 & Pruned_List, Pruned_Roots, Pruned_Leaves
138 & )
139 IMPLICIT NONE
140 LOGICAL, INTENT(IN) :: fill
141 INTEGER, INTENT(IN) :: n
142 INTEGER, INTENT(IN) :: step(N)
143 INTEGER, INTENT(IN) :: keep28
144 INTEGER, INTENT(IN) :: dad(keep28)
145 INTEGER, INTENT(IN) :: nb_nodes_rhs
146 INTEGER, INTENT(IN) :: nodes_rhs(nb_nodes_rhs)
147 INTEGER :: nb_prun_nodes
148 INTEGER, OPTIONAL, INTENT(INOUT):: pruned_list(nb_prun_nodes)
149 INTEGER :: nb_prun_roots
150 INTEGER, OPTIONAL, INTENT(INOUT):: pruned_roots(nb_prun_roots)
151 INTEGER :: nb_prun_leaves
152 INTEGER, OPTIONAL, INTENT(INOUT):: pruned_leaves(nb_prun_leaves)
153 INTEGER :: pruned_sons(keep28)
154 LOGICAL :: to_process(keep28)
155 INTEGER :: in, i, istep, tmp
156 nb_prun_nodes = 0
157 nb_prun_roots = 0
158 to_process(:) = .false.
159 pruned_sons(:) = -1
160 DO i = 1, nb_nodes_rhs
161 tmp = nodes_rhs(i)
162 istep = step(tmp)
163 to_process(istep) = .true.
164 IF (pruned_sons(istep) .eq. -1) THEN
165 pruned_sons(istep) = 0
166 nb_prun_nodes = nb_prun_nodes + 1
167 IF(fill) THEN
168 pruned_list(nb_prun_nodes) = nodes_rhs(i)
169 END IF
170 in = nodes_rhs(i)
171 in = dad(step(in))
172 DO WHILE (in.NE.0)
173 to_process(step(in)) = .true.
174 IF (pruned_sons(step(in)).eq.-1) THEN
175 nb_prun_nodes = nb_prun_nodes + 1
176 IF(fill) THEN
177 pruned_list(nb_prun_nodes) = in
178 END IF
179 pruned_sons(step(in)) = 1
180 tmp = in
181 in = dad(step(in))
182 ELSE
183 pruned_sons(step(in)) = pruned_sons(step(in)) + 1
184 GOTO 201
185 ENDIF
186 ENDDO
187 nb_prun_roots = nb_prun_roots +1
188 IF(fill) THEN
189 pruned_roots(nb_prun_roots) = tmp
190 END IF
191 ENDIF
192 201 CONTINUE
193 ENDDO
194 nb_prun_leaves = 0
195 DO i = 1, nb_nodes_rhs
196 tmp = nodes_rhs(i)
197 istep = step(tmp)
198 IF (pruned_sons(istep).EQ.0) THEN
199 nb_prun_leaves = nb_prun_leaves +1
200 IF(fill) THEN
201 pruned_leaves(nb_prun_leaves) = tmp
202 END IF
203 END IF
204 ENDDO
205 RETURN
206 END SUBROUTINE zmumps_chain_prun_nodes
207 SUBROUTINE zmumps_initialize_rhs_bounds(
208 & STEP, N,
209 & IRHS_PTR, NBCOL, IRHS_SPARSE, NZ_RHS,
210 & JBEG_RHS, PERM_RHS, SIZE_PERM_RHS, K242, K243,
211 & UNS_PERM_INV, SIZE_UNS_PERM_INV, K23,
212 & RHS_BOUNDS, NSTEPS,
213 & nb_sparse, MYID,
214 & mode)
215 IMPLICIT NONE
216 INTEGER, INTENT(IN) :: myid, n, nsteps, k242, k243, k23
217 INTEGER, INTENT(IN) :: jbeg_rhs, size_perm_rhs, nb_sparse
218 INTEGER, INTENT(IN) :: nbcol, nz_rhs, size_uns_perm_inv
219 INTEGER, INTENT(IN) :: step(n), perm_rhs(size_perm_rhs)
220 INTEGER, INTENT(IN) :: irhs_ptr(nbcol+1),IRHS_SPARSE(nz_rhs)
221 INTEGER, INTENT(IN) :: uns_perm_inv(size_uns_perm_inv)
222 INTEGER, INTENT(INOUT):: rhs_bounds(2*nsteps)
223 INTEGER, INTENT(IN) :: mode
224 INTEGER :: i, icol, jptr, j, jam1, node, bound
225 rhs_bounds = 0
226 icol = 0
227 DO i = 1, nbcol
228 IF ( (irhs_ptr(i+1)-irhs_ptr(i)).EQ.0) cycle
229 icol = icol + 1
230 bound = icol - mod(icol, nb_sparse) + 1
231 IF(mod(icol, nb_sparse).EQ.0) bound = bound - nb_sparse
232 IF(mode.EQ.0) THEN
233 IF ((k242.NE.0).OR.(k243.NE.0)) THEN
234 jam1 = perm_rhs(jbeg_rhs+i-1)
235 ELSE
236 jam1 = jbeg_rhs+i-1
237 ENDIF
238 node = abs(step(jam1))
239 IF(rhs_bounds(2*node - 1).EQ.0) THEN
240 rhs_bounds(2*node - 1) = bound
241 rhs_bounds(2*node) = bound + nb_sparse - 1
242 ELSE
243 rhs_bounds(2*node) = bound + nb_sparse - 1
244 END IF
245 ELSE
246 DO jptr = irhs_ptr(i), irhs_ptr(i+1)-1
247 j = irhs_sparse(jptr)
248 IF ( mode .EQ. 1 ) THEN
249 IF (k23.NE.0) j = uns_perm_inv(j)
250 ENDIF
251 node = abs(step(j))
252 IF(rhs_bounds(2*node - 1).EQ.0) THEN
253 rhs_bounds(2*node - 1) = bound
254 rhs_bounds(2*node) = bound + nb_sparse - 1
255 ELSE
256 rhs_bounds(2*node) = bound + nb_sparse - 1
257 END IF
258 END DO
259 END IF
260 END DO
261 RETURN
262 END SUBROUTINE zmumps_initialize_rhs_bounds
263 SUBROUTINE zmumps_propagate_rhs_bounds(
264 & pruned_leaves, nb_pruned_leaves,
265 & STEP, N, Pruned_SONS,
266 & DAD, RHS_BOUNDS, NSTEPS,
267 & MYID, COMM, KEEP485,
268 & IW, LIW, PTRIST, KIXSZ,OOC_FCT_LOC, PHASE, LDLT, K38)
269 IMPLICIT NONE
270 include 'mpif.h'
271 include 'mumps_headers.h'
272 INTEGER, INTENT(IN) :: nb_pruned_leaves, n, nsteps
273 INTEGER, INTENT(IN) :: step(n), dad(nsteps), pruned_sons(nsteps)
274 INTEGER, INTENT(IN) :: myid, comm, keep485
275 INTEGER, INTENT(IN) :: pruned_leaves(nb_pruned_leaves)
276 INTEGER, INTENT(IN) :: liw, iw(liw), ptrist(nsteps)
277 INTEGER, INTENT(IN) :: kixsz, ooc_fct_loc, phase, ldlt, k38
278 INTEGER, INTENT(INOUT):: rhs_bounds(2*nsteps)
279 INTEGER :: i, node, father, size_pool, next_size_pool
280 INTEGER :: ierr
281 INTEGER, ALLOCATABLE, DIMENSION(:) :: pool, nbsons
282 ALLOCATE(pool(nb_pruned_leaves),
283 & nbsons(nsteps),
284 & stat=ierr)
285 IF (ierr.NE.0) THEN
286 WRITE(6,*)'Allocation problem in ZMUMPS_PROPAGATE_RHS_BOUNDS'
287 CALL mumps_abort()
288 END IF
289 size_pool = nb_pruned_leaves
290 pool = pruned_leaves
291 nbsons = pruned_sons
292 DO WHILE (size_pool.ne.0)
293 next_size_pool =0
294 DO i=1, size_pool
295 node = step(pool(i))
296 IF (dad(node).NE.0) THEN
297 father = step(dad(node))
298 nbsons(father) = nbsons(father)-1
299 IF (rhs_bounds(2*father-1).EQ.0) THEN
300 rhs_bounds(2*father-1) = rhs_bounds(2*node-1)
301 rhs_bounds(2*father) = rhs_bounds(2*node)
302 ELSE
303 rhs_bounds(2*father-1) = min(rhs_bounds(2*father-1),
304 & rhs_bounds(2*node-1))
305 rhs_bounds(2*father) = max(rhs_bounds(2*father),
306 & rhs_bounds(2*node))
307 END IF
308 IF(nbsons(father).EQ.0) THEN
309 next_size_pool = next_size_pool+1
310 pool(next_size_pool) = dad(node)
311 END IF
312 END IF
313 END DO
314 size_pool = next_size_pool
315 END DO
316 DEALLOCATE(pool, nbsons)
317 RETURN
318 END SUBROUTINE zmumps_propagate_rhs_bounds
319 INTEGER(8) FUNCTION zmumps_local_factor_size(IW,LIW,PTR,
320 & PHASE, LDLT, IS_ROOT)
321 INTEGER, INTENT(IN) :: liw, ptr, phase, ldlt
322 INTEGER, INTENT(IN) :: iw(liw)
323 LOGICAL, INTENT(IN) :: is_root
324 INTEGER(8) :: ncb, nelim, liell, npiv, nrow
325 ncb = int(iw(ptr),8)
326 nelim = int(iw(ptr+1),8)
327 nrow = int(iw(ptr+2),8)
328 npiv = int(iw(ptr+3),8)
329 liell = npiv + ncb
330 IF (is_root) THEN
331 zmumps_local_factor_size = int(iw(ptr+1),8) *
332 & int(iw(ptr+2),8) / 2_8
333 RETURN
334 ENDIF
335 IF (ncb.GE.0_8) THEN
336 IF (phase.EQ.0
337 & .OR. (phase.EQ.1.AND.ldlt.NE.0)
338 & ) THEN
339 zmumps_local_factor_size =
340 & npiv*(npiv-1_8)/2_8 + (nrow-npiv)*npiv
341 ELSE
342 zmumps_local_factor_size =
343 & npiv*(npiv+1_8)/2_8 + (liell-npiv)*npiv
344 ENDIF
345 ELSE
346 zmumps_local_factor_size =
347 & -ncb*nelim
348 END IF
349 RETURN
350 END FUNCTION zmumps_local_factor_size
351 INTEGER(8) FUNCTION zmumps_local_factor_size_blr(IW,LIW,PTR,
352 & LRSTATUS, IWHANDLER,
353 & PHASE, LDLT, IS_ROOT)
354 USE zmumps_lr_data_m
355 USE zmumps_lr_type
356 INTEGER, INTENT(IN) :: liw, ptr, phase, ldlt
357 INTEGER, INTENT(IN) :: lrstatus, iwhandler
358 INTEGER, INTENT(IN) :: iw(liw)
359 LOGICAL, INTENT(IN) :: is_root
360 INTEGER(8) :: ncb, nelim, liell, npiv, nrow, factor_size
361 INTEGER :: nb_panels, ipanel, loru, iblock
362 LOGICAL :: lr_activated
363 TYPE(lrb_type), POINTER, DIMENSION(:) :: lrb_panel
364 ncb = int(iw(ptr),8)
365 nelim = int(iw(ptr+1),8)
366 nrow = int(iw(ptr+2),8)
367 npiv = int(iw(ptr+3),8)
368 liell = npiv + ncb
369 lr_activated=(lrstatus.GE.2)
370 IF (lr_activated) THEN
371 factor_size = 0_8
372 CALL zmumps_blr_retrieve_nb_panels(iwhandler, nb_panels)
373 IF (ldlt.EQ.0) THEN
374 loru = phase
375 ELSE
376 loru = 0
377 ENDIF
378 DO ipanel=1,nb_panels
379 IF (is_root.AND.ipanel.EQ.nb_panels) THEN
380 cycle
381 ENDIF
382 IF (zmumps_blr_empty_panel_loru(iwhandler, loru, ipanel))
383 & THEN
384 cycle
385 ENDIF
386 CALL zmumps_blr_retrieve_panel_loru(iwhandler, loru,
387 & ipanel, lrb_panel)
388 IF (size(lrb_panel).GT.0) THEN
389 IF (phase.EQ.0) THEN
390 factor_size = factor_size +
391 & int(lrb_panel(1)%N,8)*(int(lrb_panel(1)%N,8)-1_8)/2_8
392 ELSE
393 factor_size = factor_size +
394 & int(lrb_panel(1)%N,8)*(int(lrb_panel(1)%N,8)+1_8)/2_8
395 ENDIF
396 ENDIF
397 DO iblock=1,size(lrb_panel)
398 IF (lrb_panel(iblock)%ISLR) THEN
399 factor_size = factor_size + int(lrb_panel(iblock)%K,8)*
400 & int(lrb_panel(iblock)%M+lrb_panel(iblock)%M,8)
401 ELSE
402 factor_size = factor_size +
403 & int(lrb_panel(iblock)%M*lrb_panel(iblock)%N,8)
404 ENDIF
405 ENDDO
406 ENDDO
407 zmumps_local_factor_size_blr = factor_size
408 ELSE
409 zmumps_local_factor_size_blr =
410 & zmumps_local_factor_size(iw, liw, ptr, phase, ldlt, is_root)
411 ENDIF
412 RETURN
413 END FUNCTION zmumps_local_factor_size_blr
414 SUBROUTINE zmumps_tree_prun_nodes_stats(MYID, N, KEEP28, KEEP201,
415 & FR_FACT,
416 & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_LOC)
417 INTEGER, intent(in) :: keep28, keep201, ooc_fct_type_loc, myid, n
418 INTEGER(8), intent(in) :: fr_fact
419 INTEGER, intent(in) :: nb_prun_nodes
420 INTEGER, intent(in) :: pruned_list(nb_prun_nodes)
421 INTEGER, intent(in) :: step(n)
422 INTEGER i, istep
423 INTEGER(8) :: pruned_size
424 if (keep201 .GT. 0) then
425 pruned_size = 0_8
426 DO i = 1, nb_prun_nodes
427 istep = step(pruned_list(i))
428 pruned_size = pruned_size + size_of_block
429 & (istep, ooc_fct_type_loc)
430 ENDDO
431 pruned_size_loaded = pruned_size_loaded +pruned_size
432 ENDIF
433 RETURN
434 END SUBROUTINE zmumps_tree_prun_nodes_stats
435 SUBROUTINE zmumps_chain_prun_nodes_stats
436 & (myid, n, keep28, keep201, keep485, fr_fact,
437 & step, pruned_list, nb_prun_nodes, ooc_fct_type_loc
438 & )
439 IMPLICIT NONE
440 INTEGER, intent(in) :: keep28, keep201, ooc_fct_type_loc, n,
441 & keep485
442 INTEGER(8), intent(in) :: fr_fact
443 INTEGER, intent(in) :: nb_prun_nodes, myid
444 INTEGER, intent(in) :: pruned_list(nb_prun_nodes)
445 INTEGER, intent(in) :: step(n)
446 include 'mpif.h'
447 INTEGER i, istep
448 INTEGER(8) :: pruned_size
449 pruned_size = 0_8
450 DO i = 1, nb_prun_nodes
451 istep = step(pruned_list(i))
452 IF (keep201 .GT. 0) THEN
453 pruned_size = pruned_size + size_of_block
454 & (istep, ooc_fct_type_loc)
455 ENDIF
456 ENDDO
457 IF (keep201.GT.0) THEN
458 IF (fr_fact .NE. 0_8) THEN
459 pruned_size_loaded = pruned_size_loaded +pruned_size
460 ENDIF
461 ENDIF
462 RETURN
463 END SUBROUTINE zmumps_chain_prun_nodes_stats
464 END MODULE zmumps_sol_es
465 SUBROUTINE zmumps_permute_rhs_gs
466 & (lp, lpok, prokg, mpg, perm_strat,
467 & sym_perm, n, nrhs,
468 & irhs_ptr, size_irhs_ptr,
469 & irhs_sparse, nzrhs,
470 & perm_rhs, ierr
471 & )
472 IMPLICIT NONE
473 INTEGER, INTENT(IN) :: LP, MPG, PERM_STRAT, N, NRHS,
474 & SIZE_IRHS_PTR,
475 & nzrhs
476 LOGICAL, INTENT(IN) :: LPOK, PROKG
477 INTEGER, INTENT(IN) :: SYM_PERM(N)
478 INTEGER, INTENT(IN) :: IRHS_PTR(SIZE_IRHS_PTR)
479 INTEGER, INTENT(IN) :: IRHS_SPARSE(NZRHS)
480 INTEGER, INTENT(OUT) :: PERM_RHS(NRHS)
481 INTEGER, INTENT(OUT) :: IERR
482 INTEGER :: I,J,K, POSINPERMRHS, JJ,
483 & kpos
484 INTEGER, ALLOCATABLE :: ROW_REFINDEX(:)
485 ierr = 0
486 IF ((perm_strat.NE.-1).AND.(perm_strat.NE.1)) THEN
487 ierr=-1
488 IF (lpok)
489 & WRITE(lp,*) " INTERNAL ERROR -1 in ",
490 & " ZMUMPS_PERMUTE_RHS_GS, PERM_STRAT =", perm_strat,
491 & " is out of range "
492 RETURN
493 ENDIF
494 IF (perm_strat.EQ.-1) THEN
495 DO i=1,nrhs
496 perm_rhs(i) = i
497 END DO
498 GOTO 490
499 ENDIF
500 ALLOCATE(row_refindex(nrhs), stat=ierr)
501 IF (ierr.GT.0) THEN
502 ierr=-1
503 IF (lpok) THEN
504 WRITE(lp,*) " ERROR -2 : ",
505 & " ALLOCATE IN ZMUMPS_PERMUTE_RHS_GS OF SIZE :",
506 & nrhs
507 ENDIF
508 RETURN
509 ENDIF
510 DO i=1,nrhs
511 IF (irhs_ptr(i+1)-irhs_ptr(i).LE.0) THEN
512 ierr = 1
513 IF (i.EQ.1) THEN
514 row_refindex(i) = irhs_sparse(irhs_ptr(i))
515 ELSE
516 row_refindex(i) = row_refindex(i-1)
517 ENDIF
518 ELSE
519 row_refindex(i) = irhs_sparse(irhs_ptr(i))
520 ENDIF
521 END DO
522 posinpermrhs = 0
523 DO i=1,nrhs
524 kpos = n+1
525 jj = 0
526 DO j=1,nrhs
527 k = row_refindex(j)
528 IF (k.LE.0) cycle
529 IF (sym_perm(k).LT.kpos) THEN
530 kpos = sym_perm(k)
531 jj = j
532 ENDIF
533 END DO
534 IF (jj.EQ.0) THEN
535 ierr = -3
536 IF (lpok)
537 & WRITE(lp,*) " INTERNAL ERROR -3 in ",
538 & " ZMUMPS_PERMUTE_RHS_GS "
539 GOTO 500
540 ENDIF
541 posinpermrhs = posinpermrhs + 1
542 perm_rhs(posinpermrhs) = jj
543 row_refindex(jj) = -row_refindex(jj)
544 END DO
545 IF (posinpermrhs.NE.nrhs) THEN
546 IF (lpok)
547 & WRITE(lp,*) " INTERNAL ERROR -4 in ",
548 & " ZMUMPS_PERMUTE_RHS_GS ", maxval(row_refindex)
549 ierr = -4
550 GOTO 500
551 ENDIF
552 490 CONTINUE
553 500 CONTINUE
554 IF (allocated(row_refindex)) DEALLOCATE(row_refindex)
555 END SUBROUTINE zmumps_permute_rhs_gs
556 SUBROUTINE zmumps_permute_rhs_am1
557 & (perm_strat, sym_perm,
558 & irhs_ptr, nhrs,
559 & perm_rhs, sizeperm, ierr
560 & )
561 IMPLICIT NONE
562 INTEGER, INTENT(IN) :: PERM_STRAT, NHRS, SIZEPERM
563 INTEGER, INTENT(IN) :: SYM_PERM(SIZEPERM)
564 INTEGER, INTENT(IN) :: IRHS_PTR(NHRS)
565 INTEGER, INTENT(OUT):: IERR
566 INTEGER, INTENT(OUT):: PERM_RHS(SIZEPERM)
567 DOUBLE PRECISION :: RAND_NUM
568 INTEGER I, J, STRAT
569 ierr = 0
570 strat = perm_strat
571 IF( (strat.NE.-3).AND.
572 & (strat.NE.-2).AND.
573 & (strat.NE.-1).AND.
574 & (strat.NE. 1).AND.
575 & (strat.NE. 2).AND.
576 & (strat.NE. 6) ) THEN
577 WRITE(*,*)"Warning: incorrect value for the RHS permutation; ",
578 & "defaulting to post-order"
579 strat = 1
580 END IF
581 IF (strat .EQ. -3) THEN
582 perm_rhs(1:sizeperm)=0
583 DO i=1, sizeperm
584 CALL random_number(rand_num)
585 rand_num = rand_num*dble(sizeperm)
586 j = ceiling(rand_num)
587 DO WHILE (perm_rhs(j).NE.0)
588 CALL random_number(rand_num)
589 rand_num = rand_num*dble(sizeperm)
590 j = ceiling(rand_num)
591 ENDDO
592 perm_rhs(j)=i
593 ENDDO
594 ELSEIF (strat .EQ. -2) THEN
595 DO i=1, sizeperm
596 perm_rhs(sizeperm -i +1) = i
597 ENDDO
598 ELSEIF (strat .EQ. -1) THEN
599 DO i=1, sizeperm
600 perm_rhs(i) = i
601 ENDDO
602 ELSEIF (strat .EQ. 1) THEN
603 DO i=1, sizeperm
604 perm_rhs(sym_perm(i)) = i
605 ENDDO
606 ELSEIF (strat .EQ. 2) THEN
607 DO i=1, sizeperm
608 perm_rhs(sizeperm-sym_perm(i)+1) = i
609 ENDDO
610 ENDIF
611 END SUBROUTINE zmumps_permute_rhs_am1
612 SUBROUTINE zmumps_interleave_rhs_am1(
613 & PERM_RHS, SIZE_PERM,
614 & IPTR_WORKING, SIZE_IPTR_WORKING, WORKING, SIZE_WORKING,
615 & IRHS_PTR,
616 & STEP, SYM_PERM, N, NBRHS,
617 & PROCNODE, NSTEPS, SLAVEF, KEEP199,
618 & behaviour_L0, reorder, n_select, PROKG, MPG
619 & )
620 IMPLICIT NONE
621 INTEGER, INTENT(IN) :: SIZE_PERM,
622 & size_iptr_working,
623 & iptr_working(size_iptr_working),
624 & size_working,
625 & working(size_working),
626 & n,
627 & irhs_ptr(n+1),
628 & step(n),
629 & sym_perm(n),
630 & nbrhs,
631 & nsteps,
632 & procnode(nsteps),
633 & slavef, keep199,
634 & n_select, mpg
635 LOGICAL, INTENT(IN) :: behaviour_L0,
636 & reorder, prokg
637 INTEGER, INTENT(INOUT) :: PERM_RHS(SIZE_PERM)
638 INTEGER :: I, J, K,
639 & entry,
640 & node,
641 & size_perm_working,
642 & nb_non_empty,
643 & to_be_found,
644 & posintmprhs,
645 & selected,
646 & local_selected,
647 & current_proc,
648 & nprocs,
649 & n_pass,
650 & pass,
651 & nblocks,
652 & n_select_loc,
653 & ierr
654 INTEGER, ALLOCATABLE, DIMENSION(:) :: TMP_RHS,
655 & PTR_PROCS,
656 & LOAD_PROCS,
657 & IPTR_PERM_WORKING,
658 & PERM_WORKING,
659 & MYTYPENODE,
660 & perm_po
661 LOGICAL, ALLOCATABLE, DIMENSION(:) :: USED
662 LOGICAL :: allow_above_L0
663 INTEGER, EXTERNAL :: MUMPS_TYPENODE_ROUGH
664 NPROCS = size_iptr_working - 1
665 ALLOCATE(tmp_rhs(size_perm),
666 & ptr_procs(nprocs),
667 & load_procs(nprocs),
668 & used(size_perm),
669 & iptr_perm_working(nprocs+1),
670 & mytypenode(nsteps),
671 & stat=ierr)
672 IF(ierr.GT.0) THEN
673 WRITE(*,*)'Allocation error in ZMUMPS_INTERLEAVE_RHS_AM1'
674 CALL mumps_abort()
675 END IF
676 DO i=1, nsteps
677 mytypenode(i) = mumps_typenode_rough( procnode(i), keep199 )
678 ENDDO
679 nb_non_empty = 0
680 DO i=1,size_perm
681 IF(irhs_ptr(i+1)-irhs_ptr(i).NE.0) THEN
682 nb_non_empty = nb_non_empty + 1
683 END IF
684 END DO
685 k = 0
686 iptr_perm_working(1)=1
687 DO i=1,nprocs
688 used = .false.
689 DO j=iptr_working(i),iptr_working(i+1)-1
690 used(working(j)) = .true.
691 END DO
692 DO j=1,n
693 IF (used(abs(step(perm_rhs(j)))).AND.
694 & ((irhs_ptr(perm_rhs(j)+1)-irhs_ptr(perm_rhs(j))).NE.0))
695 & THEN
696 k = k + 1
697 END IF
698 END DO
699 iptr_perm_working(i+1) = k+1
700 END DO
701 size_perm_working = k
702 ALLOCATE(perm_working(size_perm_working),
703 & stat=ierr)
704 IF(ierr.GT.0) THEN
705 WRITE(*,*)'Allocation error in ZMUMPS_INTERLEAVE_RHS_AM1'
706 CALL mumps_abort()
707 END IF
708 k = 0
709 DO i=1,nprocs
710 used = .false.
711 DO j=iptr_working(i),iptr_working(i+1)-1
712 used(working(j)) = .true.
713 END DO
714 DO j=1,n
715 IF (used(abs(step(perm_rhs(j)))).AND.
716 & ((irhs_ptr(perm_rhs(j)+1)-irhs_ptr(perm_rhs(j))).NE.0))
717 & THEN
718 k = k + 1
719 perm_working(k) = perm_rhs(j)
720 END IF
721 END DO
722 END DO
723 IF(behaviour_l0) THEN
724 n_pass = 2
725 allow_above_l0 = .false.
726 to_be_found = 0
727 DO i=1,size_perm
728 IF((mytypenode(abs(step(i))).LE.1).AND.
729 & (irhs_ptr(i+1)-irhs_ptr(i).NE.0))
730 & THEN
731 to_be_found = to_be_found + 1
732 END IF
733 END DO
734 ELSE
735 n_pass = 1
736 allow_above_l0 = .true.
737 to_be_found = nb_non_empty
738 END IF
739 ptr_procs(1:nprocs) = iptr_perm_working(1:nprocs)
740 load_procs = 0
741 used = .false.
742 current_proc = 1
743 n_select_loc = n_select
744 IF (n_select_loc.LE.0) THEN
745 n_select_loc = 1
746 ENDIF
747 posintmprhs = 0
748 DO pass=1,n_pass
749 selected = 0
750 DO WHILE(selected.LT.to_be_found)
751 local_selected = 0
752 DO WHILE(local_selected.LT.n_select_loc)
753 IF(ptr_procs(current_proc).EQ.
754 & iptr_perm_working(current_proc+1))
755 & THEN
756 EXIT
757 ELSE
758 entry = perm_working(ptr_procs(current_proc))
759 node = abs(step(entry))
760 IF(.NOT.used(entry)) THEN
761 IF(allow_above_l0.OR.(mytypenode(node).LE.1)) THEN
762 used(entry) = .true.
763 selected = selected + 1
764 local_selected = local_selected + 1
765 posintmprhs = posintmprhs + 1
766 tmp_rhs(posintmprhs) = entry
767 IF(selected.EQ.to_be_found) EXIT
768 END IF
769 END IF
770 ptr_procs(current_proc) = ptr_procs(current_proc) + 1
771 END IF
772 END DO
773 current_proc = mod(current_proc,nprocs)+1
774 END DO
775 to_be_found = nb_non_empty - to_be_found
776 allow_above_l0 = .true.
777 ptr_procs(1:nprocs) = iptr_perm_working(1:nprocs)
778 END DO
779 DO i=1,size_perm
780 IF(irhs_ptr(perm_rhs(i)+1)-irhs_ptr(perm_rhs(i)).EQ.0) THEN
781 posintmprhs = posintmprhs+1
782 tmp_rhs(posintmprhs) = perm_rhs(i)
783 IF(posintmprhs.EQ.size_perm) EXIT
784 END IF
785 END DO
786 IF(reorder) THEN
787 posintmprhs = 0
788 ALLOCATE(perm_po(n),stat=ierr)
789 IF(ierr.GT.0) THEN
790 WRITE(*,*)'Allocation error in INTERLEAVE_RHS_AM1'
791 CALL mumps_abort()
792 END IF
793 DO j=1,n
794 perm_po(sym_perm(j))=j
795 END DO
796 nblocks = n/nbrhs
797 DO i = 1, nblocks
798 used = .false.
799 DO j=1, nbrhs
800 used(tmp_rhs(nbrhs*(i-1)+j))=.true.
801 END DO
802 DO j=1,n
803 IF(used(perm_po(j))) THEN
804 posintmprhs = posintmprhs + 1
805 perm_rhs(posintmprhs) = perm_po(j)
806 END IF
807 END DO
808 END DO
809 IF(mod(n,nbrhs).NE.0) THEN
810 used = .false.
811 DO j=1, mod(n,nbrhs)
812 used(tmp_rhs(nbrhs*nblocks+j))=.true.
813 END DO
814 DO j=1,n
815 IF(used(perm_po(j))) THEN
816 posintmprhs = posintmprhs + 1
817 perm_rhs(posintmprhs) = perm_po(j)
818 END IF
819 END DO
820 END IF
821 DEALLOCATE(perm_po)
822 ELSE
823 perm_rhs = tmp_rhs
824 END IF
825 DEALLOCATE(tmp_rhs,
826 & ptr_procs,
827 & load_procs,
828 & used,
829 & iptr_perm_working,
830 & perm_working,
831 & mytypenode)
832 RETURN
833 END SUBROUTINE zmumps_interleave_rhs_am1
mumps_abort
#define mumps_abort
Definition VE_Metis.h:25
father
integer function father(nn, ixc, ipartc, ipart, sontype)
Definition build_admesh.F:29
if
if(complex_arithmetic) id
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
zmumps_lr_data_m
Definition zmumps_lr_data_m.F:14
zmumps_lr_data_m::zmumps_blr_retrieve_panel_loru
subroutine, public zmumps_blr_retrieve_panel_loru(iwhandler, loru, ipanel, thelrbpanel)
Definition zmumps_lr_data_m.F:750
zmumps_lr_data_m::zmumps_blr_empty_panel_loru
logical function, public zmumps_blr_empty_panel_loru(iwhandler, loru, ipanel)
Definition zmumps_lr_data_m.F:719
zmumps_lr_data_m::zmumps_blr_retrieve_nb_panels
subroutine, public zmumps_blr_retrieve_nb_panels(iwhandler, nb_panels)
Definition zmumps_lr_data_m.F:672
zmumps_lr_type
Definition zlr_type.F:14
zmumps_sol_es
Definition zmumps_sol_es.F:14
zmumps_sol_es::zmumps_chain_prun_nodes
subroutine, public zmumps_chain_prun_nodes(fill, dad, keep28, step, n, nodes_rhs, nb_nodes_rhs, pruned_sons, to_process, nb_prun_nodes, nb_prun_roots, nb_prun_leaves, pruned_list, pruned_roots, pruned_leaves)
Definition zmumps_sol_es.F:139
zmumps_sol_es::zmumps_local_factor_size_blr
integer(8) function zmumps_local_factor_size_blr(iw, liw, ptr, lrstatus, iwhandler, phase, ldlt, is_root)
Definition zmumps_sol_es.F:354
zmumps_sol_es::size_of_block
integer(8), dimension(:,:), pointer size_of_block
Definition zmumps_sol_es.F:24
zmumps_sol_es::zmumps_chain_prun_nodes_stats
subroutine, public zmumps_chain_prun_nodes_stats(myid, n, keep28, keep201, keep485, fr_fact, step, pruned_list, nb_prun_nodes, ooc_fct_type_loc)
Definition zmumps_sol_es.F:439
zmumps_sol_es::zmumps_local_factor_size
integer(8) function zmumps_local_factor_size(iw, liw, ptr, phase, ldlt, is_root)
Definition zmumps_sol_es.F:321
zmumps_sol_es::zmumps_propagate_rhs_bounds
subroutine, public zmumps_propagate_rhs_bounds(pruned_leaves, nb_pruned_leaves, step, n, pruned_sons, dad, rhs_bounds, nsteps, myid, comm, keep485, iw, liw, ptrist, kixsz, ooc_fct_loc, phase, ldlt, k38)
Definition zmumps_sol_es.F:269
zmumps_sol_es::zmumps_tree_prun_nodes
subroutine, public zmumps_tree_prun_nodes(fill, dad, ne_steps, frere, keep28, fils, step, n, nodes_rhs, nb_nodes_rhs, to_process, nb_prun_nodes, nb_prun_roots, nb_prun_leaves, pruned_list, pruned_roots, pruned_leaves)
Definition zmumps_sol_es.F:48
zmumps_sol_es::zmumps_initialize_rhs_bounds
subroutine, public zmumps_initialize_rhs_bounds(step, n, irhs_ptr, nbcol, irhs_sparse, nz_rhs, jbeg_rhs, perm_rhs, size_perm_rhs, k242, k243, uns_perm_inv, size_uns_perm_inv, k23, rhs_bounds, nsteps, nb_sparse, myid, mode)
Definition zmumps_sol_es.F:215
zmumps_sol_es::pruned_size_loaded
integer(8), public pruned_size_loaded
Definition zmumps_sol_es.F:25
zmumps_sol_es::zmumps_tree_prun_nodes_stats
subroutine, public zmumps_tree_prun_nodes_stats(myid, n, keep28, keep201, fr_fact, step, pruned_list, nb_prun_nodes, ooc_fct_type_loc)
Definition zmumps_sol_es.F:417
zmumps_sol_es::zmumps_sol_es_init
subroutine, public zmumps_sol_es_init(size_of_block_arg, keep201)
Definition zmumps_sol_es.F:29
zmumps_lr_type::lrb_type
Definition zlr_type.F:16
zmumps_permute_rhs_gs
subroutine zmumps_permute_rhs_gs(lp, lpok, prokg, mpg, perm_strat, sym_perm, n, nrhs, irhs_ptr, size_irhs_ptr, irhs_sparse, nzrhs, perm_rhs, ierr)
Definition zmumps_sol_es.F:472
zmumps_interleave_rhs_am1
subroutine zmumps_interleave_rhs_am1(perm_rhs, size_perm, iptr_working, size_iptr_working, working, size_working, irhs_ptr, step, sym_perm, n, nbrhs, procnode, nsteps, slavef, keep199, behaviour_l0, reorder, n_select, prokg, mpg)
Definition zmumps_sol_es.F:620
zmumps_permute_rhs_am1
subroutine zmumps_permute_rhs_am1(perm_strat, sym_perm, irhs_ptr, nhrs, perm_rhs, sizeperm, ierr)
Definition zmumps_sol_es.F:561