OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
cfac_process_blocfacto.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 RECURSIVE SUBROUTINE cmumps_process_blocfacto(
15 & COMM_LOAD, ASS_IRECV,
16 & BUFR, LBUFR,
17 & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU,
18 & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW,
19 & A, LA, PTRIST, PTRAST, NSTK_S, PERM,
20 & COMP, STEP, PIMASTER, PAMASTER, POSFAC,
21 & MYID, COMM, IFLAG, IERROR, NBFIN,
22 &
23 & PTLUST_S, PTRFAC, root, OPASSW, OPELIW,
24 & ITLOC, RHS_MUMPS, FILS, DAD,
25 & PTRARW, PTRAIW, INTARR, DBLARR,
26 & ICNTL, KEEP,KEEP8, DKEEP,
27 & IPOOL, LPOOL, LEAF, ND, FRERE_STEPS,
28 & LPTRAR, NELT, FRTPTR, FRTELT,
29 & ISTEP_TO_INIV2, TAB_POS_IN_PERE
30 & , LRGROUPS
31 & )
32 USE cmumps_ooc, ONLY : io_block
34 USE cmumps_load
39 USE cmumps_ana_lr, ONLY : get_cut
41 USE cmumps_struc_def, ONLY : cmumps_root_struc
43!$ USE OMP_LIB
44 IMPLICIT NONE
45 include 'mumps_headers.h'
46 TYPE (cmumps_root_struc) :: root
47 INTEGER icntl( 60 ), keep( 500 )
48 INTEGER(8) keep8(150)
49 REAL dkeep(230)
50 INTEGER lbufr, lbufr_bytes
51 INTEGER comm_load, ass_irecv
52 INTEGER bufr( lbufr )
53 INTEGER n, slavef, iwpos, iwposcb, liw
54 INTEGER(8) :: iptrlu, lrlu, lrlus, la
55 INTEGER(8) :: posfac
56 INTEGER comp
57 INTEGER iflag, ierror, nbfin, msgsou
58 INTEGER procnode_steps(keep(28)), ptrist(keep(28)),
59 & nstk_s(keep(28))
60 INTEGER(8) :: pamaster(keep(28))
61 INTEGER(8) :: ptrast(keep(28))
62 INTEGER(8) :: ptrfac(keep(28))
63 INTEGER perm(n), step(n),
64 & pimaster(keep(28))
65 INTEGER iw( liw )
66 COMPLEX a( la )
67 INTEGER, intent(in) :: lrgroups(n)
68 INTEGER comm, myid
69 INTEGER nelt, lptrar
70 INTEGER frtptr( n+1 ), frtelt( nelt )
71 INTEGER ptlust_s(keep(28)),
72 & itloc(n+keep(253)), fils(n), dad(keep(28)), nd(keep(28))
73 COMPLEX :: rhs_mumps(keep(255))
74 INTEGER(8), INTENT(IN) :: ptraiw( lptrar ), ptrarw( lptrar )
75 INTEGER frere_steps(keep(28))
76 DOUBLE PRECISION opassw, opeliw
77 DOUBLE PRECISION flop1
78 INTEGER intarr( keep8(27) )
79 COMPLEX dblarr( keep8(26) )
80 INTEGER leaf, lpool
81 INTEGER ipool( lpool )
82 INTEGER istep_to_iniv2(keep(71)),
83 & tab_pos_in_pere(slavef+2,max(1,keep(56)))
84 include 'mpif.h'
85 include 'mumps_tags.h'
86 INTEGER :: status(mpi_status_size)
87 LOGICAL :: i_have_set_k117
88 INTEGER inode, position, npiv, ierr, lp
89 INTEGER ncol
90 INTEGER(8) :: POSBLOCFACTO
91 INTEGER :: ld_blocfacto
92 INTEGER(8) :: la_blocfacto
93 INTEGER(8) :: la_ptr
94 INTEGER(8) :: poselt
95 COMPLEX, DIMENSION(:), POINTER :: a_ptr
96 INTEGER ioldps, lcont1, nass1, nrow1, ncol1, npiv1
97 INTEGER nslav1, hs, isw
98 INTEGER (8) :: LPOS, upos, lpos2, IPOS, kpos
99 INTEGER ict11
100 INTEGER i, ipiv, fpere
101 LOGICAL lastbl, keep_begs_blr_l
102 LOGICAL blocking, set_irecv, message_received
103 COMPLEX one,alpha
104 parameter(one=(1.0e0,0.0e0), alpha=(-1.0e0,0.0e0))
105 INTEGER liwfac, strat, nextpivdummy
106 TYPE(io_block) :: monbloc
107 LOGICAL last_call
108 INTEGER lrelay_info
109 INTEGER :: info_tmp(2)
110 INTEGER :: idummy(1)
111 INTEGER :: nelim, npartsass_master, npartsass_master_aux,
112 & ipanel,
113 & current_blr,
114 & nb_blr_l, nb_blr_u, nb_blr_col
115 TYPE (lrb_type), POINTER, DIMENSION(:,:) :: cb_lrb
116 TYPE (lrb_type), DIMENSION(:), POINTER :: blr_u, blr_l
117 LOGICAL :: lr_activated, compress_cb, compress_panel
118 LOGICAL oocwrite_compatible_with_blr
119 INTEGER :: lr_activated_int
120 INTEGER, POINTER, DIMENSION(:) :: begs_blr_l, begs_blr_u,
121 & begs_blr_col
122 COMPLEX, ALLOCATABLE, DIMENSION(:) :: work, tau
123 INTEGER, ALLOCATABLE, DIMENSION(:) :: jpvt
124 REAL,ALLOCATABLE,DIMENSION(:) :: rwork
125 COMPLEX, ALLOCATABLE, DIMENSION(:,:) :: block
126 INTEGER :: omp_num
127 INTEGER npartsass, npartscb, maxi_cluster, lwork,
128 & maxi_cluster_l, maxi_cluster_u, maxi_cluster_col
129 INTEGER :: allocok
130 INTEGER mumps_procnode
131 EXTERNAL mumps_procnode
132 keep_begs_blr_l = .false.
133 nullify(begs_blr_l)
134 nb_blr_u = -7654321
135 NULLIFY(begs_blr_u)
136 i_have_set_k117 = .false.
137 fpere = -1
138 position = 0
139 CALL mpi_unpack( bufr, lbufr_bytes, position, inode, 1,
140 & mpi_integer, comm, ierr )
141 CALL mpi_unpack( bufr, lbufr_bytes, position, npiv, 1,
142 & mpi_integer, comm, ierr )
143 lastbl = (npiv.LE.0)
144 IF (lastbl) THEN
145 npiv = -npiv
146 CALL mpi_unpack( bufr, lbufr_bytes, position, fpere, 1,
147 & mpi_integer, comm, ierr )
148 ENDIF
149 CALL mpi_unpack( bufr, lbufr_bytes, position, ncol, 1,
150 & mpi_integer, comm, ierr )
151 CALL mpi_unpack( bufr, lbufr_bytes, position, nelim, 1,
152 & mpi_integer, comm, ierr )
153 CALL mpi_unpack( bufr, lbufr_bytes, position,
154 & npartsass_master , 1,
155 & mpi_integer, comm, ierr )
156 CALL mpi_unpack( bufr, lbufr_bytes, position, ipanel,
157 & 1, mpi_integer, comm, ierr )
158 CALL mpi_unpack( bufr, lbufr_bytes, position, lr_activated_int,
159 & 1, mpi_integer, comm, ierr )
160 lr_activated = (lr_activated_int.EQ.1)
161 IF ( lr_activated ) THEN
162 la_blocfacto = int(npiv,8) * int(npiv+nelim,8)
163 ELSE
164 la_blocfacto = int(npiv,8) * int(ncol,8)
165 ENDIF
167 & npiv, la_blocfacto, .false.,
168 & keep(1), keep8(1),
169 & n, iw, liw, a, la,
170 & lrlu, iptrlu,
171 & iwpos, iwposcb, ptrist, ptrast,
172 & step, pimaster, pamaster, lrlus,
173 & keep(ixsz),comp,dkeep(97),myid,slavef, procnode_steps,
174 & dad, iflag, ierror)
175 IF (iflag.LT.0) GOTO 700
176 lrlu = lrlu - la_blocfacto
177 lrlus = lrlus - la_blocfacto
178 keep8(67) = min(lrlus, keep8(67))
179 keep8(69) = keep8(69) + la_blocfacto
180 keep8(68) = max(keep8(69), keep8(68))
181 posblocfacto = posfac
182 posfac = posfac + la_blocfacto
183 CALL cmumps_load_mem_update(.false., .false.,
184 & la-lrlus,0_8,la_blocfacto,keep,keep8,lrlus)
185 IF ((npiv .EQ. 0)
186 & ) THEN
187 ipiv=1
188 ELSE
189 ipiv = iwpos
190 iwpos = iwpos + npiv
191 IF (npiv .GT. 0) THEN
192 CALL mpi_unpack( bufr, lbufr_bytes, position,
193 & iw( ipiv ), npiv,
194 & mpi_integer, comm, ierr )
195 ENDIF
196 IF ( lr_activated ) THEN
197 CALL mpi_unpack( bufr, lbufr_bytes, position,
198 & a(posblocfacto), npiv*(npiv+nelim),
199 & mpi_complex,
200 & comm, ierr )
201 ld_blocfacto = npiv+nelim
202 CALL mpi_unpack( bufr, lbufr_bytes, position,
203 & nb_blr_u, 1, mpi_integer,
204 & comm, ierr )
205 ALLOCATE(blr_u(max(nb_blr_u,1)), stat=allocok)
206 IF (allocok > 0 ) THEN
207 iflag = -13
208 ierror = max(nb_blr_u,1)
209 lp = icntl(1)
210 IF (icntl(4) .LE. 0) lp=-1
211 IF (lp > 0) WRITE(lp,*) myid,
212 & ': ERROR allocation during CMUMPS_PROCESS_BLOCFACTO'
213 GOTO 700
214 ENDIF
215 ALLOCATE(begs_blr_u(nb_blr_u+2), stat=allocok)
216 IF (allocok > 0 ) THEN
217 iflag = -13
218 ierror = nb_blr_u+2
219 lp = icntl(1)
220 IF (icntl(4) .LE. 0) lp=-1
221 IF (lp > 0) WRITE(lp,*) myid,
222 & ': ERROR allocation during CMUMPS_PROCESS_BLOCFACTO'
223 GOTO 700
224 ENDIF
225 CALL cmumps_mpi_unpack_lr(bufr, lbufr, lbufr_bytes,
226 & position, npiv, nelim, 'H',
227 & blr_u(1), nb_blr_u,
228 & begs_blr_u(1),
229 & keep8, comm, ierr, iflag, ierror)
230 IF (iflag.LT.0) GOTO 700
231 ELSE
232 CALL mpi_unpack( bufr, lbufr_bytes, position,
233 & a(posblocfacto), npiv*ncol,
234 & mpi_complex,
235 & comm, ierr )
236 ld_blocfacto = ncol
237 ENDIF
238 ENDIF
239 CALL mpi_unpack( bufr, lbufr_bytes, position,
240 & lrelay_info, 1,
241 & mpi_integer, comm, ierr )
242 IF (ptrist(step( inode )) .EQ. 0) THEN
243 CALL cmumps_treat_descband( inode, comm_load,
244 & ass_irecv,
245 & bufr, lbufr, lbufr_bytes, procnode_steps, posfac,
246 & iwpos, iwposcb, iptrlu,
247 & lrlu, lrlus, n, iw, liw, a, la, ptrist,
248 & ptlust_s, ptrfac,
249 & ptrast, step, pimaster, pamaster, nstk_s, comp,
250 & iflag, ierror, comm,
251 & perm, ipool, lpool, leaf, nbfin, myid, slavef,
252 &
253 & root, opassw, opeliw, itloc, rhs_mumps,
254 & fils, dad, ptrarw, ptraiw,
255 & intarr, dblarr, icntl,keep,keep8,dkeep,nd, frere_steps,
256 & lptrar, nelt, frtptr, frtelt,
257 & istep_to_iniv2, tab_pos_in_pere, .true.
258 & , lrgroups
259 & )
260 IF ( iflag .LT. 0 ) GOTO 600
261 ENDIF
262 IF ( iw( ptrist(step(inode)) + 3 +keep(ixsz)) .EQ. 0 ) THEN
263 DO WHILE ( iw(ptrist(step(inode)) + xxnbpr) .NE. 0)
264 blocking = .true.
265 set_irecv = .false.
266 message_received = .false.
267 CALL cmumps_try_recvtreat( comm_load,
268 & ass_irecv, blocking, set_irecv, message_received,
269 & mpi_any_source, contrib_type2,
270 & status,
271 & bufr, lbufr, lbufr_bytes, procnode_steps, posfac,
272 & iwpos, iwposcb, iptrlu,
273 & lrlu, lrlus, n, iw, liw, a, la, ptrist,
274 & ptlust_s, ptrfac,
275 & ptrast, step, pimaster, pamaster, nstk_s, comp,
276 & iflag, ierror, comm,
277 & perm, ipool, lpool, leaf, nbfin, myid, slavef,
278 &
279 & root, opassw, opeliw, itloc, rhs_mumps,
280 & fils, dad, ptrarw, ptraiw,
281 & intarr, dblarr, icntl,keep,keep8,dkeep,nd, frere_steps,
282 & lptrar, nelt, frtptr, frtelt,
283 & istep_to_iniv2, tab_pos_in_pere, .true.
284 & , lrgroups
285 & )
286 IF ( iflag .LT. 0 ) GOTO 600
287 END DO
288 ENDIF
289 set_irecv = .true.
290 blocking = .false.
291 message_received = .true.
292 CALL cmumps_try_recvtreat( comm_load, ass_irecv,
293 & blocking, set_irecv, message_received,
294 & mpi_any_source, mpi_any_tag,
295 & status,
296 & bufr, lbufr, lbufr_bytes, procnode_steps, posfac,
297 & iwpos, iwposcb, iptrlu,
298 & lrlu, lrlus, n, iw, liw, a, la, ptrist,
299 & ptlust_s, ptrfac,
300 & ptrast, step, pimaster, pamaster, nstk_s, comp,
301 & iflag, ierror, comm,
302 & perm, ipool, lpool, leaf, nbfin, myid, slavef,
303 &
304 & root, opassw, opeliw, itloc, rhs_mumps,
305 & fils, dad, ptrarw, ptraiw,
306 & intarr, dblarr,icntl,keep,keep8,dkeep,nd, frere_steps,
307 & lptrar, nelt, frtptr, frtelt,
308 & istep_to_iniv2, tab_pos_in_pere, .true.
309 & , lrgroups
310 & )
311 ioldps = ptrist(step(inode))
312 CALL cmumps_dm_set_dynptr( iw(ioldps+xxs), a, la,
313 & ptrast(step(inode)), iw(ioldps+xxd), iw(ioldps+xxr),
314 & a_ptr, poselt, la_ptr )
315 lcont1 = iw( ioldps + keep(ixsz))
316 nass1 = iw( ioldps + 1 + keep(ixsz))
317 compress_panel = (iw(ioldps+xxlr).GE.2)
318 oocwrite_compatible_with_blr =
319 & ( .NOT.lr_activated.OR. (.NOT.compress_panel).OR.
320 & (keep(486).NE.2)
321 & )
322 IF ( nass1 < 0 ) THEN
323 nass1 = -nass1
324 iw( ioldps + 1 + keep(ixsz)) = nass1
325 IF (keep(55) .EQ. 0) THEN
326 CALL cmumps_asm_slave_arrowheads(inode, n, iw, liw,
327 & ioldps, a_ptr(poselt), la_ptr, 1_8, keep, keep8, itloc,
328 & fils, ptraiw,
329 & ptrarw, intarr, dblarr, keep8(27), keep8(26), rhs_mumps,
330 & lrgroups)
331 ELSE
332 CALL cmumps_asm_slave_elements(inode, n, nelt, iw, liw,
333 & ioldps, a_ptr(poselt), la_ptr, 1_8, keep, keep8, itloc,
334 & fils, ptraiw,
335 & ptrarw, intarr, dblarr, keep8(27), keep8(26),
336 & frtptr, frtelt, rhs_mumps, lrgroups)
337 ENDIF
338 ENDIF
339 nrow1 = iw( ioldps + 2 +keep(ixsz))
340 npiv1 = iw( ioldps + 3 +keep(ixsz))
341 nslav1 = iw( ioldps + 5 + keep(ixsz))
342 hs = 6 + nslav1 + keep(ixsz)
343 ncol1 = lcont1 + npiv1
344 IF (npiv.GT.0) THEN
345 ict11 = ioldps+hs+nrow1+npiv1 - 1
346 DO i = 1, npiv
347 IF (iw(ipiv+i-1).EQ.i) cycle
348 isw = iw(ict11+i)
349 iw(ict11+i) = iw(ict11+iw(ipiv+i-1))
350 iw(ict11+iw(ipiv+i-1)) = isw
351 ipos = poselt + int(npiv1 + i - 1,8)
352 kpos = poselt + int(npiv1 + iw(ipiv+i-1) - 1,8)
353 CALL cswap(nrow1, a_ptr(ipos), ncol1, a_ptr(kpos), ncol1)
354 ENDDO
355 lpos2 = poselt + int(npiv1,8)
356 lpos = lpos2 + int(npiv,8)
357 IF ((.NOT. lr_activated).OR.keep(475).EQ.0) THEN
358 CALL ctrsm('L','L','N','N', npiv, nrow1, one,
359 & a(posblocfacto), ld_blocfacto,
360 & a_ptr(lpos2), ncol1)
361 ENDIF
362 ENDIF
363 compress_cb = .false.
364 IF ( lr_activated) THEN
365 compress_cb = ((iw(ioldps+xxlr).EQ.1).OR.
366 & (iw(ioldps+xxlr).EQ.3))
367 IF (compress_cb.AND.npiv.EQ.0) THEN
368 compress_cb = .false.
369 iw(ioldps+xxlr) = iw(ioldps+xxlr) -1
370 ENDIF
371 IF (npiv.NE.0) THEN
372 IF ( (npiv1.EQ.0)
373 & ) THEN
374 ioldps = ptrist(step(inode))
375 CALL get_cut(iw(ioldps+hs:ioldps+hs+nrow1-1), 0,
376 & nrow1, lrgroups, npartscb,
377 & npartsass, begs_blr_l)
378 CALL regrouping2(begs_blr_l, npartsass, 0, npartscb,
379 & nrow1-0, keep(488), .true., keep(472))
380 nb_blr_l = npartscb
381 IF (ipanel.EQ.1) THEN
382 begs_blr_col=>begs_blr_u
383 ELSE
384 ALLOCATE(begs_blr_col(size(begs_blr_u)+ipanel-1),
385 & stat=allocok)
386 IF (allocok > 0 ) THEN
387 iflag = -13
388 ierror = size(begs_blr_u)+ipanel-1
389 lp = icntl(1)
390 IF (icntl(4) .LE. 0) lp=-1
391 IF (lp > 0) WRITE(lp,*) myid,
392 & ': ERROR allocation during CMUMPS_PROCESS_BLOCFACTO'
393 GOTO 700
394 ENDIF
395 begs_blr_col(1:ipanel-1) = 1
396 DO i=1,size(begs_blr_u)
397 begs_blr_col(ipanel+i-1) = begs_blr_u(i)
398 ENDDO
399 ENDIF
400 info_tmp(1) = iflag
401 info_tmp(2) = ierror
402 IF (iflag.LT.0) GOTO 700
403 CALL cmumps_blr_save_init(iw(ioldps+xxf),
404 & .false.,
405 & .true.,
406 & .true.,
407 & npartsass_master,
408 & begs_blr_l,
409 & begs_blr_col,
410 & huge(npartsass_master),
411 & info_tmp)
412 iflag = info_tmp(1)
413 ierror = info_tmp(2)
414 IF (ipanel.NE.1) THEN
415 DEALLOCATE(begs_blr_col)
416 ENDIF
417 IF (iflag.LT.0) GOTO 700
418 ELSE
419 CALL cmumps_blr_retrieve_begs_blr_l (iw(ioldps+xxf),
420 & begs_blr_l)
421 keep_begs_blr_l = .true.
422 nb_blr_l = size(begs_blr_l) - 2
423 npartsass = 1
424 npartscb = nb_blr_l
425 ENDIF
426 ENDIF
427 ENDIF
428 IF ( (npiv .GT. 0)
429 & ) THEN
430 IF (lr_activated) THEN
431 call max_cluster(begs_blr_l,nb_blr_l+1,maxi_cluster_l)
432 call max_cluster(begs_blr_u,nb_blr_u+1,maxi_cluster_u)
433 IF (lastbl.AND.compress_cb) THEN
434 maxi_cluster=max(maxi_cluster_u+nelim,maxi_cluster_l)
435 ELSE
436 maxi_cluster=max(maxi_cluster_u,maxi_cluster_l)
437 ENDIF
438 lwork = maxi_cluster*maxi_cluster
439 omp_num = 1
440#if defined(BLR_MT)
441!$ omp_num = omp_get_max_threads()
442#endif
443 ALLOCATE(block(maxi_cluster, omp_num*maxi_cluster),
444 & rwork(2*maxi_cluster*omp_num),
445 & tau(maxi_cluster*omp_num),
446 & jpvt(maxi_cluster*omp_num),
447 & work(lwork*omp_num), stat=allocok)
448 IF (allocok > 0 ) THEN
449 iflag = -13
450 ierror = maxi_cluster*omp_num*maxi_cluster
451 & + 2*maxi_cluster*omp_num
452 & + maxi_cluster*omp_num
453 & + maxi_cluster*omp_num
454 & + lwork*omp_num
455 lp = icntl(1)
456 IF (icntl(4) .LE. 0) lp=-1
457 IF (lp > 0) WRITE(lp,*) myid,
458 & ': ERROR allocation during CMUMPS_PROCESS_BLOCFACTO'
459 GOTO 700
460 ENDIF
461 current_blr=1
462 ALLOCATE(blr_l(nb_blr_l), stat=allocok)
463 IF (allocok > 0 ) THEN
464 iflag = -13
465 ierror = nb_blr_l
466 lp = icntl(1)
467 IF (icntl(4) .LE. 0) lp=-1
468 IF (lp > 0) WRITE(lp,*) myid,
469 & ': ERROR allocation during CMUMPS_PROCESS_BLOCFACTO'
470 GOTO 700
471 ENDIF
472#if defined(BLR_MT)
473!$OMP PARALLEL
474#endif
476 & (a_ptr(poselt), la_ptr, 1_8,
477 & iflag, ierror, ncol1,
478 & begs_blr_l(1), size(begs_blr_l), nb_blr_l+1,
479 & dkeep(8), keep(466), keep(473),
480 & blr_l(1),
481 & current_blr, 'V', work, tau, jpvt, lwork, rwork,
482 & block, maxi_cluster, nelim,
483 & .true.,
484 & npiv, npiv1,
485 & 2, keep(483), keep8,
486 & omp_num )
487#if defined(BLR_MT)
488!$OMP MASTER
489#endif
490 IF ( (keep(486).EQ.2)
491 & ) THEN
493 & iw(ioldps+xxf),
494 & 0,
495 & ipanel, blr_l)
496 ENDIF
497#if defined(BLR_MT)
498!$OMP END MASTER
499!$OMP BARRIER
500#endif
501 IF (iflag.LT.0) GOTO 300
502 IF (keep(475).GE.1) THEN
503 CALL cmumps_blr_panel_lrtrsm(a, la, posblocfacto,
504 & ld_blocfacto, -6666,
505 & nb_blr_l+1,
506 & blr_l, current_blr, current_blr+1, nb_blr_l+1,
507 & 2, 0, 0,
508 & .true.)
509#if defined(BLR_MT)
510!$OMP BARRIER
511#endif
512 IF (keep(486).NE.2) THEN
514 & a_ptr(poselt), la_ptr, 1_8,
515 & ncol1, ncol1,
516 & .true.,
517 & npiv1+1,
518 & 1,
519 & nb_blr_l+1, blr_l(1), current_blr, 'V', 1)
520 ENDIF
521 ENDIF
522 300 CONTINUE
523#if defined(BLR_MT)
524!$OMP END PARALLEL
525#endif
526 IF (iflag.LT.0) GOTO 700
527 ENDIF
528 ENDIF
529 IF ( (keep(201).eq.1) .AND.
530 & (oocwrite_compatible_with_blr .OR. npiv.EQ.0) ) THEN
531 monbloc%INODE = inode
532 monbloc%MASTER = .false.
533 monbloc%Typenode = 2
534 monbloc%NROW = nrow1
535 monbloc%NCOL = ncol1
536 monbloc%NFS = nass1
537 monbloc%LastPiv = npiv1 + npiv
538 monbloc%LastPanelWritten_L = -9999
539 monbloc%LastPanelWritten_U = -9999
540 NULLIFY(monbloc%INDICES)
541 monbloc%Last = lastbl
542 strat = strat_try_write
543 nextpivdummy = -8888
544 liwfac = iw(ioldps+xxi)
545 last_call = .false.
547 & a_ptr(poselt),
548 & la_ptr, monbloc, nextpivdummy, nextpivdummy,
549 & iw(ioldps), liwfac, myid, keep8(31), iflag,last_call)
550 ENDIF
551 IF ( (npiv .GT. 0)
552 & ) THEN
553 IF (lr_activated) THEN
554 IF (nelim.GT.0) THEN
555 upos = 1_8+int(npiv,8)
557 & a(posblocfacto), la_blocfacto, upos,
558 & a_ptr(poselt), la_ptr, lpos-poselt+1_8,
559 & iflag, ierror, ld_blocfacto, ncol1,
560 & begs_blr_l(1), size(begs_blr_l),
561 & current_blr, blr_l(1), nb_blr_l+1,
562 & current_blr+1, nelim, 'N')
563 ENDIF
564#if defined(BLR_MT)
565!$OMP PARALLEL
566#endif
568 & a_ptr(poselt), la_ptr, 1_8,
569 & iflag, ierror, ncol1,
570 & begs_blr_l(1), size(begs_blr_l),
571 & begs_blr_u(1), size(begs_blr_u), current_blr,
572 & blr_l(1), nb_blr_l+1,
573 & blr_u(1), nb_blr_u+1,
574 & 0,
575 & .true.,
576 & npiv1,
577 & 2, 0,
578 & keep(481), dkeep(11), keep(466), keep(477)
579 & )
580#if defined(BLR_MT)
581!$OMP END PARALLEL
582#endif
583 IF (iflag.LT.0) GOTO 700
584 ELSE
585 upos = posblocfacto+int(npiv,8)
586 CALL cgemm('N','N', ncol-npiv, nrow1, npiv,
587 & alpha,a(upos), ncol,
588 & a_ptr(lpos2), ncol1, one, a_ptr(lpos), ncol1)
589 ENDIF
590 ENDIF
591 iw(ioldps+keep(ixsz) ) = iw(ioldps+keep(ixsz) ) - npiv
592 iw(ioldps + 3+keep(ixsz) ) = iw(ioldps+3+keep(ixsz) ) + npiv
593 IF (lastbl) THEN
594 iw(ioldps+1+keep(ixsz) ) = iw(ioldps + 3+keep(ixsz) )
595 ENDIF
596 IF ( .not. lastbl .AND.
597 & (iw(ioldps+1+keep(ixsz)) .EQ. iw(ioldps + 3+keep(ixsz))) ) THEN
598 write(*,*) 'Internal ERROR 1 **** IN BLACFACTO '
599 CALL mumps_abort()
600 ENDIF
601 IF (lr_activated) THEN
602 IF ((npiv.GT.0)
603 & ) THEN
604 CALL dealloc_blr_panel( blr_u, nb_blr_u, keep8, keep(34))
605 DEALLOCATE(blr_u)
606 IF (keep(486).EQ.3) THEN
607 CALL dealloc_blr_panel( blr_l, nb_blr_l, keep8, keep(34))
608 DEALLOCATE(blr_l)
609 ELSE
610 CALL upd_mry_lu_lrgain(blr_l, npartscb
611 & )
612 ENDIF
613 ENDIF
614 ENDIF
615 lrlu = lrlu + la_blocfacto
616 lrlus = lrlus + la_blocfacto
617 keep8(69) = keep8(69) - la_blocfacto
618 posfac = posfac - la_blocfacto
619 CALL cmumps_load_mem_update(.false.,.false.,
620 & la-lrlus,0_8,-la_blocfacto,keep,keep8,lrlus)
621 iwpos = iwpos - npiv
622 flop1 = dble( npiv1*nrow1 ) +
623 & dble(nrow1*npiv1)*dble(2*ncol1-npiv1-1)
624 & -
625 & dble((npiv1+npiv)*nrow1 ) -
626 & dble(nrow1*(npiv1+npiv))*dble(2*ncol1-npiv1-npiv-1)
627 CALL cmumps_load_update( 1, .false., flop1, keep,keep8 )
628 IF (lastbl) THEN
629 IF (keep(486).NE.0) THEN
630 IF (lr_activated) THEN
631 CALL stats_compute_flop_slave_type2(nrow1, ncol1, nass1,
632 & keep(50), inode)
633 ELSE
634 CALL upd_flop_frfront_slave(nrow1, ncol1, nass1,
635 & keep(50), inode)
636 ENDIF
637 ENDIF
638 IF (lr_activated) THEN
639 IF (compress_cb) THEN
640 CALL cmumps_blr_retrieve_begs_blr_c (iw(ioldps+xxf),
641 & begs_blr_col, npartsass_master_aux)
642 begs_blr_col(1+npartsass_master) =
643 & begs_blr_col(1+npartsass_master) - nelim
644 nb_blr_col = size(begs_blr_col) - 1
645 IF (npiv.EQ.0) THEN
646 call max_cluster(begs_blr_l,nb_blr_l+1,maxi_cluster_l)
647 call max_cluster(begs_blr_col,nb_blr_col,maxi_cluster_col)
648 IF (compress_cb) THEN
649 maxi_cluster=max(maxi_cluster_col+nelim,maxi_cluster_l)
650 ELSE
651 maxi_cluster=max(maxi_cluster_col,maxi_cluster_l)
652 ENDIF
653 lwork = maxi_cluster*maxi_cluster
654 omp_num = 1
655#if defined(BLR_MT)
656!$ omp_num = omp_get_max_threads()
657#endif
658 ALLOCATE(block(maxi_cluster, omp_num*maxi_cluster),
659 & rwork(2*maxi_cluster*omp_num),
660 & tau(maxi_cluster*omp_num),
661 & jpvt(maxi_cluster*omp_num),
662 & work(lwork*omp_num), stat=allocok)
663 IF (allocok > 0 ) THEN
664 iflag = -13
665 ierror = maxi_cluster*omp_num*maxi_cluster
666 & + 2*maxi_cluster*omp_num
667 & + maxi_cluster*omp_num
668 & + maxi_cluster*omp_num
669 & + lwork*omp_num
670 lp = icntl(1)
671 IF (icntl(4) .LE. 0) lp=-1
672 IF (lp > 0) WRITE(lp,*) myid,
673 & ': ERROR allocation during CMUMPS_PROCESS_BLOCFACTO'
674 GOTO 700
675 ENDIF
676 ENDIF
677 allocate(cb_lrb(nb_blr_l,nb_blr_col-npartsass_master),
678 & stat=allocok)
679 IF (allocok > 0) THEN
680 iflag = -13
681 ierror = nb_blr_l*(nb_blr_col-npartsass_master)
682 GOTO 700
683 ENDIF
684 CALL cmumps_blr_save_cb_lrb(iw(ioldps+xxf),cb_lrb)
685 ENDIF
686#if defined(BLR_MT)
687!$OMP PARALLEL
688#endif
689 IF (compress_cb) THEN
691 & a_ptr(poselt), la_ptr, 1_8, ncol1,
692 & begs_blr_l(1), size(begs_blr_l),
693 & begs_blr_col(1), size(begs_blr_col),
694 & nb_blr_l, nb_blr_col-npartsass_master,
695 & npartsass_master,
696 & nrow1, ncol1-npiv1-npiv, inode,
697 & iw(ioldps+xxf), 0, 2, iflag, ierror,
698 & dkeep(12), keep(466), keep(484), keep(489),
699 & cb_lrb(1,1),
700 & work, tau, jpvt, lwork, rwork, block,
701 & maxi_cluster, keep8, omp_num,
702 & -9999, -9999, -9999, keep(1),
703 & idummy, 0, -9999 )
704#if defined(BLR_MT)
705!$OMP BARRIER
706#endif
707 ENDIF
708#if defined(BLR_MT)
709!$OMP END PARALLEL
710#endif
711 IF (iflag.LT.0) GOTO 700
712 ENDIF
714 & comm_load, ass_irecv,
715 & n, inode, fpere,
716 & root,
717 & myid, comm,
718 &
719 & bufr, lbufr, lbufr_bytes, procnode_steps, posfac,
720 & iwpos, iwposcb, iptrlu, lrlu, lrlus, iw, liw, a, la,
721 & ptrist, ptlust_s, ptrfac, ptrast, step, pimaster,
722 & pamaster,
723 & nstk_s, comp, iflag, ierror, perm,
724 & ipool, lpool, leaf, nbfin, slavef,
725 & opassw, opeliw, itloc, rhs_mumps, fils, dad, ptrarw, ptraiw,
726 & intarr, dblarr,icntl,keep,keep8,dkeep,nd, frere_steps,
727 & lptrar, nelt, frtptr, frtelt,
728 & istep_to_iniv2, tab_pos_in_pere
729 & , lrgroups
730 & )
731 ENDIF
732 IF (lr_activated) THEN
733 IF (allocated(rwork)) DEALLOCATE(rwork)
734 IF (allocated(work)) DEALLOCATE(work)
735 IF (allocated(tau)) DEALLOCATE(tau)
736 IF (allocated(jpvt)) DEALLOCATE(jpvt)
737 IF (allocated(block)) DEALLOCATE(block)
738 IF (associated(begs_blr_l)) THEN
739 IF (.NOT. keep_begs_blr_l) DEALLOCATE(begs_blr_l)
740 ENDIF
741 IF ((npiv.GT.0)
742 & ) THEN
743 IF (associated(begs_blr_u)) DEALLOCATE(begs_blr_u)
744 ENDIF
745 ENDIF
746 600 CONTINUE
747 RETURN
748 700 CONTINUE
749 CALL cmumps_bdc_error( myid, slavef, comm, keep )
750 RETURN
751 END SUBROUTINE cmumps_process_blocfacto
753 & BUFR, LBUFR, LBUFR_BYTES, POSITION,
754 & NPIV, NELIM, DIR,
755 & BLR_U, NB_BLOCK_U,
756 & BEGS_BLR_U, KEEP8,
757 & COMM, IERR, IFLAG, IERROR)
758 USE cmumps_lr_core, ONLY : lrb_type, alloc_lrb
760 IMPLICIT NONE
761 INTEGER, INTENT(IN) :: LBUFR
762 INTEGER, INTENT(IN) :: LBUFR_BYTES
763 INTEGER, INTENT(IN) :: BUFR(LBUFR)
764 INTEGER, INTENT(INOUT) :: POSITION
765 INTEGER, INTENT(IN) :: NB_BLOCK_U, NELIM, NPIV
766 CHARACTER(len=1) :: DIR
767 INTEGER, INTENT(IN) :: COMM
768 INTEGER, INTENT(INOUT) :: IFLAG, IERROR
769 INTEGER, INTENT(OUT) :: IERR
770 TYPE (LRB_TYPE), INTENT(OUT),
771 & DIMENSION(max(NB_BLOCK_U,1)):: blr_u
772 INTEGER, INTENT(OUT), DIMENSION(NB_BLOCK_U+2) :: BEGS_BLR_U
773 INTEGER(8) :: KEEP8(150)
774 LOGICAL :: ISLR
775 INTEGER :: ISLR_INT, I
776 INTEGER :: K, M, N
777 INCLUDE 'mpif.h'
778 INCLUDE 'mumps_tags.h'
779 IERR = 0
780.NE. IF (size(BLR_U)
781 & MAX(NB_BLOCK_U,1) ) THEN
782 WRITE(*,*) "Internal error 1 in CMUMPS_MPI_UNPACK",
783 & NB_BLOCK_U,size(BLR_U)
784 CALL MUMPS_ABORT()
785 ENDIF
786 BEGS_BLR_U(1) = 1
787 BEGS_BLR_U(2) = NPIV+NELIM+1
788 DO I = 1, NB_BLOCK_U
789 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
790 & ISLR_INT, 1, MPI_INTEGER, COMM, IERR )
791 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
792 & K, 1,
793 & MPI_INTEGER, COMM, IERR )
794 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
795 & M, 1,
796 & MPI_INTEGER, COMM, IERR )
797 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
798 & N, 1,
799 & MPI_INTEGER, COMM, IERR )
800 BEGS_BLR_U(I+2) = BEGS_BLR_U(I+1) + M
801.eq. IF (ISLR_INT 1) THEN
802 ISLR = .TRUE.
803 ELSE
804 ISLR = .FALSE.
805 ENDIF
806 CALL ALLOC_LRB( BLR_U(I), K, M, N, ISLR,
807 & IFLAG, IERROR, KEEP8 )
808.LT. IF (IFLAG0) RETURN
809 IF (ISLR) THEN
810.GT. IF (K 0) THEN
811 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
812 & BLR_U(I)%Q(1,1), M*K, MPI_COMPLEX,
813 & COMM, IERR )
814 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
815 & BLR_U(I)%R(1,1), N*K, MPI_COMPLEX,
816 & COMM, IERR)
817 ENDIF
818 ELSE
819 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
820 & BLR_U(I)%Q(1,1), M*N, MPI_COMPLEX,
821 & COMM, IERR)
822 ENDIF
823 ENDDO
824 RETURN
825 END SUBROUTINE CMUMPS_MPI_UNPACK_LR
#define mumps_abort
Definition VE_Metis.h:25
subroutine cmumps_bdc_error(myid, slavef, comm, keep)
Definition cbcast_int.F:38
subroutine cmumps_asm_slave_arrowheads(inode, n, iw, liw, ioldps, a, la, poselt, keep, keep8, itloc, fils, ptraiw, ptrarw, intarr, dblarr, lintarr, ldblarr, rhs_mumps, lrgroups)
Definition cfac_asm.F:637
subroutine cmumps_asm_slave_elements(inode, n, nelt, iw, liw, ioldps, a, la, poselt, keep, keep8, itloc, fils, ptraiw, ptrarw, intarr, dblarr, lintarr, ldblarr, frt_ptr, frt_elt, rhs_mumps, lrgroups)
subroutine cmumps_get_size_needed(sizei_needed, sizer_needed, skip_top_stack, keep, keep8, n, iw, liw, a, la, lrlu, iptrlu, iwpos, iwposcb, ptrist, ptrast, step, pimaster, pamaster, lrlus, xsize, comp, acc_time, myid, slavef, procnode_steps, dad, iflag, ierror)
recursive subroutine cmumps_treat_descband(inode, comm_load, ass_irecv, bufr, lbufr, lbufr_bytes, procnode_steps, posfac, iwpos, iwposcb, iptrlu, lrlu, lrlus, n, iw, liw, a, la, ptrist, ptlust, ptrfac, ptrast, step, pimaster, pamaster, nstk_s, comp, iflag, ierror, comm, perm, ipool, lpool, leaf, nbfin, myid, slavef root, opassw, opeliw, itloc, rhs_mumps, fils, dad, ptrarw, ptraiw, intarr, dblarr, icntl, keep, keep8, dkeep, nd, frere, lptrar, nelt, frtptr, frtelt istep_to_iniv2, tab_pos_in_pere, stack_right_authorized, lrgroups)
recursive subroutine cmumps_process_blocfacto(comm_load, ass_irecv, bufr, lbufr, lbufr_bytes, procnode_steps, msgsou, slavef, iwpos, iwposcb, iptrlu, lrlu, lrlus, n, iw, liw, a, la, ptrist, ptrast, nstk_s, perm, comp, step, pimaster, pamaster, posfac, myid, comm, iflag, ierror, nbfin ptlust_s, ptrfac, root, opassw, opeliw, itloc, rhs_mumps, fils, dad, ptrarw, ptraiw, intarr, dblarr, icntl, keep, keep8, dkeep, ipool, lpool, leaf, nd, frere_steps, lptrar, nelt, frtptr, frtelt, istep_to_iniv2, tab_pos_in_pere, lrgroups)
subroutine cmumps_mpi_unpack_lr(bufr, lbufr, lbufr_bytes, position, npiv, nelim, dir, blr_u, nb_block_u, begs_blr_u, keep8, comm, ierr, iflag, ierror)
recursive subroutine cmumps_end_facto_slave(comm_load, ass_irecv, n, inode, fpere, root, myid, comm bufr, lbufr, lbufr_bytes, procnode_steps, posfac, iwpos, iwposcb, iptrlu, lrlu, lrlus, iw, liw, a, la, ptrist, ptlust_s, ptrfac, ptrast, step, pimaster, pamaster, nstk, comp, iflag, ierror, perm, ipool, lpool, leaf, nbfin, slavef, opassw, opeliw, itloc, rhs_mumps, fils, dad, ptrarw, ptraiw, intarr, dblarr, icntl, keep, keep8, dkeep, nd, frere, lptrar, nelt, frtptr, frtelt, istep_to_iniv2, tab_pos_in_pere, lrgroups)
recursive subroutine cmumps_try_recvtreat(comm_load, ass_irecv, blocking, set_irecv, message_received, msgsou, msgtag, status, bufr, lbufr, lbufr_bytes, procnode_steps, posfac, iwpos, iwposcb, iptrlu, lrlu, lrlus, n, iw, liw, a, la, ptrist, ptlust, ptrfac, ptrast, step, pimaster, pamaster, nstk_s, comp, iflag, ierror, comm, perm, ipool, lpool, leaf, nbfin, myid, slavef root, opassw, opeliw, itloc, rhs_mumps, fils, dad, ptrarw, ptraiw, intarr, dblarr, icntl, keep, keep8, dkeep, nd, frere, lptrar, nelt, frtptr, frtelt istep_to_iniv2, tab_pos_in_pere, stack_right_authorized, lrgroups)
subroutine cmumps_compress_cb_i(a_ptr, la_ptr, poselt, lda, begs_blr, sizebegs_blr, begs_blr_u, sizebegs_blr_u, nb_rows, nb_cols, nb_inasm, nrows, ncols, inode, iwhandler, sym, niv, iflag, ierror, toleps, tol_opt, kpercent, k489, cb_lrb, work, tau, jpvt, lwork, rwork, block, maxi_cluster, keep8, omp_num, nfs4father, npiv, nvschur_k253, keep, m_array, nelim, nbrowsinf)
Definition ctools.F:1957
subroutine cmumps_compress_panel_i_noopt(a, la, poselt, iflag, ierror, nfront, begs_blr, sizebegs_blr, nb_blr, toleps, tol_opt, k473, blr_panel, current_blr, dir, work, tau, jpvt, lwork, rwork, block, maxi_cluster, nelim, lbandslave, npiv, ishift, niv, kpercent, keep8, omp_num)
Definition ctools.F:2008
subroutine cmumps_ooc_io_lu_panel_i(strat, typefile, afac, lafac, monbloc, lnextpiv2bewritten, unextpiv2bewritten, iw, liwfac, myid, filesize, ierr, last_call)
Definition ctools.F:1854
subroutine cmumps_blr_upd_nelim_var_l_i(a_u, la_u, upos, a_l, la_l, lpos, iflag, ierror, ldu, ldl, begs_blr_l, sizebegs_blr_l, current_blr, blr_l, nb_blr_l, first_block, nelim, utrans)
Definition ctools.F:2075
subroutine cmumps_blr_update_trailing_i(a, la, poselt, iflag, ierror, nfront, begs_blr_l, sizebegs_blr_l, begs_blr_u, sizebegs_blr_u, current_blr, blr_l, nb_blr_l, blr_u, nb_blr_u, nelim, lbandslave, ishift, niv, sym, midblk_compress, toleps, tol_opt, kpercent)
Definition ctools.F:1918
subroutine cmumps_decompress_panel_i_noopt(a, la, poselt, lda11, lda21, copy_dense_blocks, begs_blr_diag, begs_blr_first_offdiag, nb_blr, blr_panel, current_blr, dir, decomp_timer)
Definition ctools.F:2050
subroutine cswap(n, cx, incx, cy, incy)
CSWAP
Definition cswap.f:81
subroutine ctrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
CTRSM
Definition ctrsm.f:180
subroutine cgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
CGEMM
Definition cgemm.f:187
#define min(a, b)
Definition macros.h:20
#define max(a, b)
Definition macros.h:21
subroutine mpi_unpack(inbuf, insize, position, outbuf, outcnt, datatype, comm, ierr)
Definition mpi.f:514
subroutine get_cut(iwr, nass, ncb, lrgroups, npartscb, npartsass, cut)
Definition cana_lr.F:25
subroutine cmumps_dm_set_dynptr(cb_state, a, la, pamaster_or_ptrast, ixxd, ixxr, son_a, iachk, recsize)
subroutine cmumps_blr_panel_lrtrsm(a, la, poselt, nfront, ibeg_block, nb_blr, blr_loru, current_blr, first_block, last_block, niv, sym, loru, lbandslave, iw, offset_iw, nass)
Definition cfac_lr.F:2437
double precision, save, private alpha
Definition cmumps_load.F:55
integer, save, private myid
Definition cmumps_load.F:57
subroutine, public cmumps_load_mem_update(ssarbr, process_bande_arg, mem_value, new_lu, inc_mem_arg, keep, keep8, lrlus)
subroutine, public cmumps_load_update(check_flops, process_bande, inc_load, keep, keep8)
subroutine max_cluster(cut, cut_size, maxi_cluster)
Definition clr_core.F:1304
subroutine alloc_lrb(lrb_out, k, m, n, islr, iflag, ierror, keep8)
Definition clr_core.F:111
subroutine regrouping2(cut, npartsass, nass, npartscb, ncb, ibcksz, onlycb, k472)
Definition clr_core.F:184
subroutine, public cmumps_blr_save_init(iwhandler, issym, ist2, isslave, nb_panels, begs_blr_l, begs_blr_col, nb_accesses_init, info)
subroutine, public cmumps_blr_retrieve_begs_blr_l(iwhandler, begs_blr_l)
subroutine, public cmumps_blr_save_cb_lrb(iwhandler, cb_lrb)
subroutine, public cmumps_blr_retrieve_begs_blr_c(iwhandler, begs_blr_col, nb_panels)
subroutine, public cmumps_blr_save_panel_loru(iwhandler, loru, ipanel, lrb_panel)
subroutine stats_compute_flop_slave_type2(nrow1, ncol1, nass1, keep50, inode)
Definition clr_stats.F:479
subroutine upd_mry_lu_lrgain(blr_panel, nbblocks)
Definition clr_stats.F:452
subroutine upd_flop_frfront_slave(nrow1, ncol1, nass1, keep50, inode)
Definition clr_stats.F:512
subroutine dealloc_blr_panel(blr_panel, iend, keep8, k34, ibeg_in)
Definition clr_type.F:56
integer, public strat_try_write
integer, public typef_l
int comp(int a, int b)
integer function mumps_procnode(procinfo_inode, k199)