OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
ctype3_root.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 SUBROUTINE cmumps_ass_root( root, KEEP50,
15 & NROW_SON, NCOL_SON, INDROW_SON,
16 & INDCOL_SON, NSUPCOL, VAL_SON, VAL_ROOT,
17 & LOCAL_M, LOCAL_N,
18 & RHS_ROOT, NLOC_ROOT, CBP )
19 USE cmumps_struc_def, ONLY : cmumps_root_struc
20 IMPLICIT NONE
21 TYPE (CMUMPS_ROOT_STRUC) :: root
22 INTEGER, INTENT(IN) :: KEEP50
23 INTEGER NCOL_SON, NROW_SON, NSUPCOL
24 INTEGER, intent(in) :: CBP
25 INTEGER INDROW_SON( NROW_SON ), INDCOL_SON( NCOL_SON )
26 INTEGER LOCAL_M, LOCAL_N
27 COMPLEX VAL_SON( NCOL_SON, NROW_SON )
28 COMPLEX VAL_ROOT( LOCAL_M, LOCAL_N )
29 INTEGER NLOC_ROOT
30 COMPLEX RHS_ROOT( LOCAL_M, NLOC_ROOT )
31 INTEGER I, J, INDROW, INDCOL, IPOSROOT, JPOSROOT
32 IF (cbp .EQ. 0) THEN
33 DO i = 1, nrow_son
34 indrow = indrow_son(i)
35 iposroot = (root%NPROW*((indrow-1)/root%MBLOCK)+root%MYROW)
36 & * root%MBLOCK + mod(indrow-1,root%MBLOCK) + 1
37 DO j = 1, ncol_son-nsupcol
38 indcol = indcol_son(j)
39 IF (keep50.NE.0) THEN
40 jposroot = (root%NPCOL*((indcol-1)/root%NBLOCK)+root%MYCOL)
41 & * root%NBLOCK + mod(indcol-1,root%NBLOCK) + 1
42 IF (iposroot < jposroot) THEN
43 cycle
44 ENDIF
45 ENDIF
46 val_root( indrow, indcol ) =
47 & val_root( indrow, indcol ) + val_son(j,i)
48 END DO
49 DO j = ncol_son-nsupcol+1, ncol_son
50 indcol = indcol_son(j)
51 rhs_root( indrow, indcol ) =
52 & rhs_root( indrow, indcol ) + val_son(j,i)
53 ENDDO
54 END DO
55 ELSE
56 DO i=1, nrow_son
57 DO j = 1, ncol_son
58 rhs_root( indrow_son( i ), indcol_son(j)) =
59 & rhs_root(indrow_son(i),indcol_son(j)) + val_son(j,i)
60 ENDDO
61 ENDDO
62 ENDIF
63 RETURN
64 END SUBROUTINE cmumps_ass_root
65 RECURSIVE SUBROUTINE cmumps_build_and_send_cb_root
66 & ( comm_load, ass_irecv, n, ison, iroot,
67 & ptri, ptrr,
68 & root, nbrow, nbcol, shift_list_row_son,
69 & shift_list_col_son, shift_val_son_arg, lda_arg, tag,
70 & myid, comm, bufr, lbufr, lbufr_bytes, procnode_steps, posfac,
71 & iwpos, iwposcb, iptrlu, lrlu, lrlus, iw, liw, a, la,
72 & ptrist, ptlust_s, ptrfac,
73 & ptrast, step, pimaster, pamaster,
74 & nstk, comp, iflag, ierror, perm,
75 & ipool, lpool, leaf, nbfin, slavef,
76 & opassw, opeliw, itloc, rhs_mumps,
77 & fils, dad, ptrarw, ptraiw,
78 & intarr,dblarr,icntl,keep,keep8,dkeep,transpose_asm,
79 & nd, frere,
80 & lptrar, nelt, frtptr, frtelt,
81 & istep_to_iniv2, tab_pos_in_pere
82 & , lrgroups
83 & )
84 USE cmumps_ooc
85 USE cmumps_buf
86 USE cmumps_load
87 USE cmumps_struc_def, ONLY : cmumps_root_struc
88 USE cmumps_dynamic_memory_m, ONLY : cmumps_dm_set_dynptr
89 IMPLICIT NONE
90 INTEGER keep(500), icntl(60)
91 INTEGER(8) keep8(150)
92 REAL dkeep(230)
93 TYPE (cmumps_root_struc) :: root
94 INTEGER comm_load, ass_irecv
95 INTEGER n, ison, iroot, tag
96 INTEGER ptri( keep(28) )
97 INTEGER(8) :: ptrr( keep(28) )
98 INTEGER NBROW, nbcol
99 INTEGER, INTENT(IN):: lda_arg
100 INTEGER(8), INTENT(IN) :: shift_val_son_arg
101 INTEGER shift_list_row_son, SHIFT_LIST_COL_SON
102 INTEGER myid, comm
103 LOGICAL transpose_asm
104 include 'mpif.h'
105 INTEGER lbufr, lbufr_bytes
106 INTEGER bufr( lbufr )
107 INTEGER(8) :: posfac, iptrlu, lrlu, LRLUS, la
108 INTEGER IWPOS, iwposcb
109 INTEGER liw
110 INTEGER iw( liw )
111 COMPLEX a( la )
112 INTEGER, intent(in) :: lrgroups(n)
113 INTEGER lptrar, nelt
114 INTEGER frtptr( n+1 ), frtelt( nelt )
115 INTEGER(8) :: PTRAST(keep(28))
116 INTEGER(8) :: ptrfac(keep(28))
117 INTEGER(8) :: pamaster(keep(28))
118 INTEGER ptrist( keep(28) ), ptlust_s(KEEP(28))
119 INTEGER step(n), pimaster(keep(28)), nstk( n )
120 INTEGER comp, iflag, ierror
121 INTEGER perm(n)
122 INTEGER lpool, leaf
123 INTEGER ipool( lpool )
124 INTEGER nbfin, slavef
125 DOUBLE PRECISION opassw, opeliw
126 INTEGER procnode_steps( keep(28) )
127 INTEGER itloc( n + keep(253) ), FILS( n ), dad(keep(28))
128 COMPLEX :: rhs_mumps(keep(255))
129 INTEGER nd( keep(28) ), frere( keep(28) )
130 INTEGER(8), INTENT(IN) :: ptrarw( lptrar ), ptraiw( lptrar )
131 INTEGER intarr( keep8(27) )
132 COMPLEX dblarr( keep8(26) )
133 INTEGER istep_to_iniv2(keep(71)),
134 & tab_pos_in_pere(slavef+2,max(1,keep(56)))
135 COMPLEX, DIMENSION(:), POINTER :: sona_ptr
136 INTEGER(8) :: lsona_ptr, POSSONA_PTR
137 INTEGER allocok
138 INTEGER, ALLOCATABLE, DIMENSION(:) :: ptrrow, ptrcol
139 INTEGER, ALLOCATABLE, DIMENSION(:) :: nsuprow, NSUPCOL
140 INTEGER, ALLOCATABLE, DIMENSION(:) :: row_index_list
141 INTEGER, ALLOCATABLE, DIMENSION(:) :: col_index_list
142 INTEGER :: status(mpi_status_size)
143 INTEGER i, pos_in_root, irow, jcol, iglob, jglob
144 INTEGER pdest, ierr
145 INTEGER local_m, local_n
146 INTEGER(8) :: posroot
147 INTEGER nsubset_row, nsubset_col
148 INTEGER nrlocal, nclocal
149 INTEGER :: lda
150 INTEGER(8) :: shift_val_son
151 LOGICAL set_irecv, blocking, message_received
152 INTEGER nbrows_already_sent
153 INTEGER size_msg
154 INTEGER lp
155 include 'mumps_headers.h'
156 LOGICAL skiplast_rhs_rows, bcp_sym_nonempty
157 INTEGER bbpcbp
158 INTEGER mumps_procnode
159 EXTERNAL mumps_procnode
160 bbpcbp = 0
161 lp = icntl(1)
162 IF ( icntl(4) .LE. 0 ) lp = -1
163 IF (lda_arg < 0) THEN
164 CALL cmumps_set_lda_shift_val_son(iw, liw, ptri(step(ison)),
165 & lda, shift_val_son)
166 ELSE
167 lda = lda_arg
168 shift_val_son = shift_val_son_arg
169 ENDIF
170 ALLOCATE(ptrrow(root%NPROW + 1 ), stat=allocok)
171 if (allocok .GT. 0) THEN
172 iflag =-13
173 ierror = root%NPROW + 1
174 endif
175 ALLOCATE(ptrcol(root%NPCOL + 1 ), stat=allocok)
176 if (allocok .GT. 0) THEN
177 iflag =-13
178 ierror = root%NPCOL + 1
179 endif
180 ALLOCATE(nsuprow(root%NPROW + 1 ), stat=allocok)
181 if (allocok .GT. 0) THEN
182 iflag =-13
183 ierror = root%NPROW + 1
184 endif
185 ALLOCATE(nsupcol(root%NPCOL + 1 ), stat=allocok)
186 if (allocok .GT. 0) THEN
187 iflag =-13
188 ierror = root%NPCOL + 1
189 endif
190 IF (iflag.LT.0) THEN
191 IF (lp > 0) write(6,*) myid, ' : MEMORY ALLOCATION ',
192 & 'FAILURE in CMUMPS_BUILD_AND_SEND_CB_ROOT'
193 CALL cmumps_bdc_error( myid, slavef, comm, keep )
194 RETURN
195 ENDIF
196 skiplast_rhs_rows = ((keep(253).GT.0).AND.(keep(50).EQ.0))
197 bcp_sym_nonempty = .false.
198 ptrrow = 0
199 ptrcol = 0
200 nsuprow = 0
201 nsupcol = 0
202 DO i = 1, nbrow
203 iglob = iw( ptri(step(ison)) +
204 & shift_list_row_son + i - 1 )
205 IF (skiplast_rhs_rows.AND.(iglob.GT.n)) cycle
206 IF ( .NOT. transpose_asm ) THEN
207 IF (iglob.GT.n) THEN
208 bcp_sym_nonempty = .true.
209 pos_in_root = iglob - n
210 jcol = mod((pos_in_root-1)/root%NBLOCK,root%NPCOL)
211 nsupcol(jcol+1) = nsupcol(jcol+1) + 1
212 ptrcol( jcol + 2 ) = ptrcol( jcol + 2 ) + 1
213 ELSE
214 pos_in_root = root%RG2L_ROW( iglob )
215 irow = mod((pos_in_root-1)/root%MBLOCK,root%NPROW)
216 ptrrow( irow + 2 ) = ptrrow( irow + 2 ) + 1
217 ENDIF
218 ELSE
219 IF (iglob .GT. n) THEN
220 pos_in_root = iglob - n
221 ELSE
222 pos_in_root = root%RG2L_COL( iglob )
223 ENDIF
224 jcol = mod( ( pos_in_root - 1 ) / root%NBLOCK, root%NPCOL )
225 IF (iglob.GT.n)
226 & nsupcol(jcol+1) = nsupcol(jcol+1) + 1
227 ptrcol( jcol + 2 ) = ptrcol( jcol + 2 ) + 1
228 END IF
229 END DO
230 IF (keep(50).NE.0 .AND.(.NOT.transpose_asm).AND.bcp_sym_nonempty)
231 & bbpcbp = 1
232 DO i = 1, nbcol
233 jglob = iw( ptri(step(ison)) +
234 & shift_list_col_son + i - 1 )
235 IF ((keep(50).GT.0) .AND. (jglob.GT.n)) cycle
236 IF ( .NOT. transpose_asm ) THEN
237 IF (keep(50).EQ.0) THEN
238 IF (jglob.LE.n) THEN
239 pos_in_root = root%RG2L_COL(jglob)
240 ELSE
241 pos_in_root = jglob-n
242 ENDIF
243 jcol = mod((pos_in_root-1) / root%NBLOCK, root%NPCOL )
244 IF (jglob.GT.n) THEN
245 nsupcol(jcol+1) = nsupcol(jcol+1) + 1
246 ENDIF
247 ptrcol( jcol + 2 ) = ptrcol( jcol + 2 ) + 1
248 ELSE
249 pos_in_root = root%RG2L_COL(jglob)
250 jcol = mod((pos_in_root-1) / root%NBLOCK, root%NPCOL )
251 ptrcol( jcol + 2 ) = ptrcol( jcol + 2 ) + 1
252 IF (bcp_sym_nonempty) THEN
253 pos_in_root = root%RG2L_ROW(jglob)
254 irow = mod((pos_in_root-1)/root%MBLOCK,root%NPROW)
255 nsuprow(irow+1) = nsuprow(irow+1)+1
256 ptrrow( irow + 2 ) = ptrrow( irow + 2 ) + 1
257 ENDIF
258 ENDIF
259 ELSE
260 IF (jglob.LE.n) THEN
261 pos_in_root = root%RG2L_ROW( jglob )
262 ELSE
263 pos_in_root = jglob-n
264 ENDIF
265 irow = mod( ( pos_in_root - 1 ) /
266 & root%MBLOCK, root%NPROW )
267 ptrrow( irow + 2 ) = ptrrow( irow + 2 ) + 1
268 END IF
269 END DO
270 ptrrow( 1 ) = 1
271 DO irow = 2, root%NPROW + 1
272 ptrrow( irow ) = ptrrow( irow ) + ptrrow( irow - 1 )
273 END DO
274 ptrcol( 1 ) = 1
275 DO jcol = 2, root%NPCOL + 1
276 ptrcol( jcol ) = ptrcol( jcol ) + ptrcol( jcol - 1 )
277 END DO
278 ALLOCATE(row_index_list(ptrrow(root%NPROW+1)-1+1),
279 & stat=allocok)
280 if (allocok .GT. 0) THEN
281 iflag =-13
282 ierror = ptrrow(root%NPROW+1)-1+1
283 endif
284 ALLOCATE(col_index_list(ptrcol(root%NPCOL+1)-1+1),
285 & stat=allocok)
286 if (allocok .GT. 0) THEN
287 iflag =-13
288 ierror = ptrcol(root%NPCOL+1)-1+1
289 endif
290 DO i = 1, nbrow
291 iglob = iw( ptri(step(ison)) +
292 & shift_list_row_son + i - 1 )
293 IF (skiplast_rhs_rows.AND.(iglob.GT.n)) cycle
294 IF ( .NOT. transpose_asm ) THEN
295 IF (iglob.GT.n) cycle
296 pos_in_root = root%RG2L_ROW( iglob )
297 irow = mod( ( pos_in_root - 1 ) / root%MBLOCK,
298 & root%NPROW )
299 row_index_list( ptrrow( irow + 1 ) ) = i
300 ptrrow( irow + 1 ) = ptrrow( irow + 1 ) + 1
301 ELSE
302 IF (iglob.LE.n) THEN
303 pos_in_root = root%RG2L_COL( iglob )
304 ELSE
305 pos_in_root = iglob - n
306 ENDIF
307 jcol = mod( ( pos_in_root - 1 ) / root%NBLOCK,
308 & root%NPCOL )
309 col_index_list( ptrcol( jcol + 1 ) ) = i
310 ptrcol( jcol + 1 ) = ptrcol( jcol + 1 ) + 1
311 END IF
312 END DO
313 DO i = 1, nbcol
314 jglob = iw( ptri(step(ison))+shift_list_col_son+i - 1 )
315 IF ((keep(50).GT.0) .AND. (jglob.GT.n)) cycle
316 IF ( .NOT. transpose_asm ) THEN
317 IF ( jglob.LE.n ) THEN
318 pos_in_root = root%RG2L_COL( jglob )
319 ELSE
320 pos_in_root = jglob - n
321 ENDIF
322 jcol = mod( ( pos_in_root - 1 ) /
323 & root%NBLOCK, root%NPCOL )
324 col_index_list( ptrcol( jcol + 1 ) ) = i
325 ptrcol( jcol + 1 ) = ptrcol( jcol + 1 ) + 1
326 ELSE
327 IF ( jglob.LE.n ) THEN
328 pos_in_root = root%RG2L_ROW( jglob )
329 ELSE
330 pos_in_root = jglob - n
331 ENDIF
332 irow = mod( ( pos_in_root - 1 ) /
333 & root%MBLOCK, root%NPROW )
334 row_index_list( ptrrow( irow + 1 ) ) = i
335 ptrrow( irow + 1 ) = ptrrow( irow + 1 ) + 1
336 END IF
337 END DO
338 IF (bcp_sym_nonempty) THEN
339 DO i = 1, nbrow
340 iglob = iw( ptri(step(ison)) +
341 & shift_list_row_son + i - 1 )
342 IF (iglob.LE.n) cycle
343 pos_in_root = iglob - n
344 jcol = mod((pos_in_root-1)/root%NBLOCK,root%NPCOL)
345 col_index_list( ptrcol( jcol + 1 ) ) = i
346 ptrcol( jcol + 1 ) = ptrcol( jcol + 1 ) + 1
347 ENDDO
348 DO i=1, nbcol
349 jglob = iw( ptri(step(ison))+shift_list_col_son+i - 1 )
350 IF (jglob.GT.n) THEN
351 EXIT
352 ELSE
353 pos_in_root = root%RG2L_ROW(jglob)
354 ENDIF
355 irow = mod((pos_in_root-1)/root%MBLOCK,root%NPROW)
356 row_index_list( ptrrow( irow + 1 ) ) = i
357 ptrrow( irow + 1 ) = ptrrow( irow + 1 ) + 1
358 ENDDO
359 ENDIF
360 DO irow = root%NPROW, 2, -1
361 ptrrow( irow ) = ptrrow( irow - 1 )
362 END DO
363 ptrrow( 1 ) = 1
364 DO jcol = root%NPCOL, 2, -1
365 ptrcol( jcol ) = ptrcol( jcol - 1 )
366 END DO
367 ptrcol( 1 ) = 1
368 jcol = root%MYCOL
369 irow = root%MYROW
370 IF ( root%yes ) THEN
371 if (irow .ne. root%MYROW .or. jcol.ne.root%MYCOL) then
372 write(*,*) ' error in grid position buildandsendcbroot'
373 CALL mumps_abort()
374 end if
375 IF ( ptrist(step(iroot)).EQ.0.AND.
376 & ptlust_s(step(iroot)).EQ.0) THEN
377 CALL cmumps_root_alloc_static(root, iroot, n, iw, liw,
378 & a, la,
379 & fils, dad, myid, slavef, procnode_steps,
380 & lptrar, nelt, frtptr, frtelt,
381 & ptraiw, ptrarw, intarr, dblarr,
382 & lrlu, iptrlu,
383 & iwpos, iwposcb, ptrist, ptrast,
384 & step, pimaster, pamaster, itloc, rhs_mumps,
385 & comp, lrlus, iflag, keep,keep8,dkeep, ierror )
386 keep(121) = -1
387 IF (iflag.LT.0) THEN
388 CALL cmumps_bdc_error( myid, slavef, comm, keep )
389 RETURN
390 ENDIF
391 ELSE
392 keep(121) = keep(121) - 1
393 IF ( keep(121) .eq. 0 ) THEN
394 IF (keep(201).EQ.1) THEN
395 CALL cmumps_ooc_force_wrt_buf_panel(ierr)
396 ELSE IF (keep(201).EQ.2) THEN
397 CALL cmumps_force_write_buf(ierr)
398 ENDIF
399 CALL cmumps_insert_pool_n(n, ipool, lpool, procnode_steps,
400 & slavef, keep(199), keep(28), keep(76), keep(80), keep(47),
401 & step, iroot+n )
402 IF (keep(47) .GE. 3) THEN
403 CALL cmumps_load_pool_upd_new_pool(
404 & ipool, lpool,
405 & procnode_steps, keep,keep8, slavef, comm_load,
406 & myid, step, n, nd, fils )
407 ENDIF
408 END IF
409 END IF
410 CALL cmumps_dm_set_dynptr( iw(ptri(step(ison))+xxs), a, la,
411 & ptrr(step(ison)), iw(ptri(step(ison))+xxd),
412 & iw(ptri(step(ison))+xxr),
413 & sona_ptr, possona_ptr, lsona_ptr )
414 IF (keep(60) .NE. 0 ) THEN
415 local_m = root%SCHUR_LLD
416 local_n = root%SCHUR_NLOC
417 nrlocal = ptrrow( irow + 2 ) - ptrrow( irow + 1 )
418 nclocal = ptrcol( jcol + 2 ) - ptrcol( jcol + 1 )
419 CALL cmumps_root_local_assembly( n,
420 & root%SCHUR_POINTER(1),
421 & local_m, local_n,
422 & root%NPCOL, root%NPROW, root%MBLOCK, root%NBLOCK,
423 & nbcol, nbrow,
424 & iw( ptri(step(ison)) + shift_list_col_son ),
425 & iw( ptri(step(ison)) + shift_list_row_son ),
426 & lda, sona_ptr( possona_ptr + shift_val_son ),
427 & row_index_list( ptrrow( irow + 1 ) ),
428 & col_index_list( ptrcol( jcol + 1 ) ),
429 & nrlocal,
430 & nclocal,
431 & nsuprow(irow+1), nsupcol(jcol+1),
432 & root%RG2L_ROW(1), root%RG2L_COL(1), transpose_asm,
433 & keep,
434 & root%RHS_ROOT(1,1), root%RHS_NLOC )
435 ELSE
436 IF ( ptrist(step( iroot )) .GE. 0 ) THEN
437 IF ( ptrist(step( iroot )) .EQ. 0 ) THEN
438 local_n = iw( ptlust_s(step(iroot)) + 1 + keep(ixsz))
439 local_m = iw( ptlust_s(step(iroot)) + 2 + keep(ixsz))
440 posroot = ptrfac(iw( ptlust_s(step(iroot)) +4+keep(ixsz) ))
441 ELSE
442 local_n = - iw( ptrist(step(iroot)) +keep(ixsz))
443 local_m = iw( ptrist(step(iroot)) + 1 +keep(ixsz))
444 posroot = pamaster(step( iroot ))
445 ENDIF
446 nclocal = ptrcol( jcol + 2 ) - ptrcol( jcol + 1 )
447 nrlocal = ptrrow( irow + 2 ) - ptrrow( irow + 1 )
448 CALL cmumps_root_local_assembly( n, a( posroot ),
449 & local_m, local_n,
450 & root%NPCOL, root%NPROW, root%MBLOCK, root%NBLOCK,
451 & nbcol, nbrow,
452 & iw( ptri(step(ison)) + shift_list_col_son ),
453 & iw( ptri(step(ison)) + shift_list_row_son ),
454 & lda, sona_ptr( possona_ptr + shift_val_son ),
455 & row_index_list( ptrrow( irow + 1 ) ),
456 & col_index_list( ptrcol( jcol + 1 ) ),
457 & nrlocal,
458 & nclocal,
459 & nsuprow(irow+1), nsupcol(jcol+1),
460 & root%RG2L_ROW(1), root%RG2L_COL(1), transpose_asm,
461 & keep,
462 & root%RHS_ROOT(1,1), root%RHS_NLOC )
463 END IF
464 ENDIF
465 END IF
466 DO irow = 0, root%NPROW - 1
467 DO jcol = 0, root%NPCOL - 1
468 pdest = irow * root%NPCOL + jcol
469 IF ( (root%MYROW.eq.irow.and.root%MYCOL.eq.jcol) .and.
470 & myid.ne.pdest) THEN
471 write(*,*) 'error: myrow,mycol=',root%MYROW,root%MYCOL
472 write(*,*) ' MYID,PDEST=',myid,pdest
473 CALL mumps_abort()
474 END IF
475 IF ( root%MYROW .NE. irow .OR. root%MYCOL .NE. jcol) THEN
476 nbrows_already_sent = 0
477 ierr = -1
478 DO WHILE ( ierr .EQ. -1 )
479 nsubset_row = ptrrow( irow + 2 ) - ptrrow( irow + 1 )
480 nsubset_col = ptrcol( jcol + 2 ) - ptrcol( jcol + 1 )
481 IF ( lrlu .LT. int(nsubset_row,8) * int(nsubset_col,8)
482 & .AND. lrlus .GT. int(nsubset_row,8) * int(nsubset_col,8) )
483 & THEN
484 CALL cmumps_compre_new(n, keep,
485 & iw, liw, a, la,
486 & lrlu, iptrlu,
487 & iwpos, iwposcb, ptrist, ptrast,
488 & step, pimaster, pamaster, lrlus,
489 & keep(ixsz), comp, dkeep(97),
490 & myid, slavef, procnode_steps, dad)
491 IF ( lrlu .NE. lrlus ) THEN
492 WRITE(*,*) myid,": pb compress in",
493 & "CMUMPS_BUILD_AND_SEND_CB_ROOT"
494 WRITE(*,*) myid,': LRLU, LRLUS=',lrlu,lrlus
495 CALL mumps_abort()
496 END IF
497 END IF
498 CALL cmumps_dm_set_dynptr(
499 & iw(ptri(step(ison))+xxs), a, la,
500 & ptrr(step(ison)), iw(ptri(step(ison))+xxd),
501 & iw(ptri(step(ison))+xxr),
502 & sona_ptr, possona_ptr, lsona_ptr )
503 CALL cmumps_buf_send_contrib_type3_i( n, ison,
504 & nbcol, nbrow,
505 & iw( ptri(step(ison)) + shift_list_col_son ),
506 & iw( ptri(step(ison)) + shift_list_row_son ),
507 & lda, sona_ptr( possona_ptr + shift_val_son ),
508 & tag,
509 & row_index_list( ptrrow( irow + 1 ) ),
510 & col_index_list( ptrcol( jcol + 1 ) ),
511 & nsubset_row, nsubset_col,
512 & nsuprow(irow+1), nsupcol(jcol+1),
513 & root%NPROW, root%NPCOL, root%MBLOCK,
514 & root%RG2L_ROW(1), root%RG2L_COL(1),
515 & root%NBLOCK, pdest,
516 & comm, ierr, a( posfac ), lrlu, transpose_asm,
517 & size_msg, nbrows_already_sent, keep, bbpcbp )
518 IF ( ierr .EQ. -1 ) THEN
519 blocking = .false.
520 set_irecv = .true.
521 message_received = .false.
522 CALL cmumps_try_recvtreat( comm_load, ass_irecv,
523 & blocking, set_irecv, message_received,
524 & mpi_any_source, mpi_any_tag,
525 & status, bufr, lbufr,
526 & lbufr_bytes, procnode_steps, posfac, iwpos, iwposcb,
527 & iptrlu, lrlu, lrlus, n, iw, liw, a, la,
528 & ptrist, ptlust_s, ptrfac, ptrast, step,
529 & pimaster, pamaster, nstk,
530 & comp, iflag, ierror, comm, perm, ipool, lpool,
531 & leaf, nbfin, myid, slavef, root,
532 & opassw, opeliw, itloc, rhs_mumps, fils, dad,
533 & ptrarw,ptraiw,intarr,dblarr,icntl,keep,keep8,dkeep,
534 & nd, frere, lptrar, nelt, frtptr, frtelt,
535 & istep_to_iniv2, tab_pos_in_pere, .true.
536 & , lrgroups
537 & )
538 IF ( iflag .LT. 0 ) GOTO 500
539 IF (lda_arg < 0) THEN
540 CALL cmumps_set_lda_shift_val_son(
541 & iw, liw, ptri(step(ison)),
542 & lda, shift_val_son)
543 ENDIF
544 END IF
545 END DO
546 IF ( ierr == -2 ) THEN
547 iflag = -17
548 ierror = size_msg
549 IF (lp > 0) WRITE(lp, *) "FAILURE, SEND BUFFER TOO
550 & SMALL DURING CMUMPS_BUILD_AND_SEND_CB_ROOT"
551 CALL cmumps_bdc_error( myid, slavef, comm, keep )
552 GOTO 500
553 ENDIF
554 IF ( ierr == -3 ) THEN
555 IF (lp > 0) WRITE(lp, *) "FAILURE, RECV BUFFER TOO
556 & SMALL DURING CMUMPS_BUILD_AND_SEND_CB_ROOT"
557 iflag = -20
558 ierror = size_msg
559 CALL cmumps_bdc_error( myid, slavef, comm, keep )
560 GOTO 500
561 ENDIF
562 END IF
563 END DO
564 END DO
565 500 CONTINUE
566 DEALLOCATE(ptrrow)
567 DEALLOCATE(ptrcol)
568 DEALLOCATE(row_index_list)
569 DEALLOCATE(col_index_list)
570 RETURN
571 CONTAINS
572 SUBROUTINE cmumps_set_lda_shift_val_son(IW, LIW, IOLDPS,
573 & LDA, SHIFT_VAL_SON)
574 INTEGER, INTENT(IN) :: LIW, IOLDPS
575 INTEGER, INTENT(IN) :: IW(LIW)
576 INTEGER, INTENT(OUT) :: LDA
577 INTEGER(8), INTENT(OUT) :: SHIFT_VAL_SON
578 INCLUDE 'mumps_headers.h'
579 INTEGER :: LCONT, NROW, NPIV, NASS, NELIM
580 lcont = iw(ioldps+keep(ixsz))
581 nrow = iw(ioldps+2+keep(ixsz))
582 npiv = iw(ioldps+3+keep(ixsz))
583 nass = iw(ioldps+4+keep(ixsz))
584 nelim = nass-npiv
585 IF (iw(ioldps+xxs).EQ.s_nolcbnocontig38.OR.
586 & iw(ioldps+xxs).EQ.s_all) THEN
587 shift_val_son = int(npiv,8)
588 lda = lcont + npiv
589 ELSE IF (iw(ioldps+xxs).EQ.s_nolcbcontig38) THEN
590 shift_val_son = int(nrow,8)*int(lcont+npiv-nelim,8)
591 lda = nelim
592 ELSE IF (iw(ioldps+xxs).EQ.s_nolcleaned38) THEN
593 shift_val_son=0_8
594 lda = nelim
595 ELSE
596 WRITE(*,*) myid,
597 & ": internal error in cmumps_set_lda_shift_val_son",
598 & IW(IOLDPS+XXS), "ison=",ISON
599 CALL MUMPS_ABORT()
600 ENDIF
601 RETURN
602 END SUBROUTINE CMUMPS_SET_LDA_SHIFT_VAL_SON
603 END SUBROUTINE CMUMPS_BUILD_AND_SEND_CB_ROOT
604 SUBROUTINE CMUMPS_ROOT_LOCAL_ASSEMBLY( N, VAL_ROOT,
605 & LOCAL_M, LOCAL_N,
606 & NPCOL, NPROW, MBLOCK, NBLOCK, NBCOL_SON, NBROW_SON, INDCOL_SON,
607 & INDROW_SON, LD_SON, VAL_SON, SUBSET_ROW, SUBSET_COL,
608 & NSUBSET_ROW, NSUBSET_COL, NSUPROW, NSUPCOL,
609 & RG2L_ROW, RG2L_COL, TRANSPOSE_ASM,
610 & KEEP, RHS_ROOT, NLOC )
611 USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC
612 IMPLICIT NONE
613 INTEGER N, LOCAL_M, LOCAL_N
614 COMPLEX VAL_ROOT( LOCAL_M, LOCAL_N )
615 INTEGER NPCOL, NPROW, MBLOCK, NBLOCK
616 INTEGER NBCOL_SON, NBROW_SON
617 INTEGER INDCOL_SON( NBCOL_SON ), INDROW_SON( NBROW_SON )
618 INTEGER LD_SON
619 INTEGER NSUPROW, NSUPCOL
620 COMPLEX VAL_SON( LD_SON, NBROW_SON )
621 INTEGER KEEP(500)
622 INTEGER NSUBSET_ROW, NSUBSET_COL
623 INTEGER SUBSET_ROW( NSUBSET_ROW ), SUBSET_COL( NSUBSET_COL )
624 INTEGER RG2L_ROW( N ), RG2L_COL( N )
625 LOGICAL TRANSPOSE_ASM
626 INTEGER NLOC
627 COMPLEX RHS_ROOT( LOCAL_M, NLOC)
628 INTEGER ISUB, JSUB, I, J, IPOS_ROOT, JPOS_ROOT
629 INTEGER ILOC_ROOT, JLOC_ROOT, IGLOB, JGLOB
630.EQ. IF (KEEP(50)0) THEN
631 DO ISUB = 1, NSUBSET_ROW
632 I = SUBSET_ROW( ISUB )
633 IGLOB = INDROW_SON( I )
634 IPOS_ROOT = RG2L_ROW( IGLOB )
635 ILOC_ROOT = MBLOCK
636 & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) )
637 & + mod( IPOS_ROOT - 1, MBLOCK ) + 1
638 DO JSUB = 1, NSUBSET_COL-NSUPCOL
639 J = SUBSET_COL( JSUB )
640 JGLOB = INDCOL_SON( J )
641 JPOS_ROOT = RG2L_COL( JGLOB )
642 JLOC_ROOT = NBLOCK
643 & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) )
644 & + mod( JPOS_ROOT - 1, NBLOCK ) + 1
645 VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) =
646 & VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) + VAL_SON( J, I )
647 END DO
648 DO JSUB = NSUBSET_COL-NSUPCOL+1, NSUBSET_COL
649 J = SUBSET_COL( JSUB )
650 JGLOB = INDCOL_SON( J )
651 JPOS_ROOT = JGLOB - N
652 JLOC_ROOT = NBLOCK
653 & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) )
654 & + mod( JPOS_ROOT - 1, NBLOCK ) + 1
655 RHS_ROOT(ILOC_ROOT, JLOC_ROOT) =
656 & RHS_ROOT(ILOC_ROOT, JLOC_ROOT) + VAL_SON( J, I )
657 ENDDO
658 END DO
659 ELSE
660.NOT. IF ( TRANSPOSE_ASM ) THEN
661 DO ISUB = 1, NSUBSET_ROW - NSUPROW
662 I = SUBSET_ROW( ISUB )
663 IGLOB = INDROW_SON( I )
664 IPOS_ROOT = RG2L_ROW( IGLOB )
665 ILOC_ROOT = MBLOCK
666 & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) )
667 & + mod( IPOS_ROOT - 1, MBLOCK ) + 1
668 DO JSUB = 1, NSUBSET_COL -NSUPCOL
669 J = SUBSET_COL( JSUB )
670 JGLOB = INDCOL_SON( J )
671 JPOS_ROOT = RG2L_COL( JGLOB )
672.NE..GT. IF (KEEP(50)0. AND. JPOS_ROOT IPOS_ROOT) CYCLE
673 JLOC_ROOT = NBLOCK
674 & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) )
675 & + mod( JPOS_ROOT - 1, NBLOCK ) + 1
676 VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) =
677 & VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) + VAL_SON( J, I )
678 END DO
679 END DO
680 DO JSUB = NSUBSET_COL -NSUPCOL+1, NSUBSET_COL
681 J = SUBSET_COL( JSUB )
682 JGLOB = INDROW_SON( J )
683 JPOS_ROOT = JGLOB - N
684 JLOC_ROOT = NBLOCK
685 & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) )
686 & + mod( JPOS_ROOT - 1, NBLOCK ) + 1
687 DO ISUB = NSUBSET_ROW - NSUPROW +1, NSUBSET_ROW
688 I = SUBSET_ROW( ISUB )
689 IGLOB = INDCOL_SON( I )
690 IPOS_ROOT = RG2L_ROW(IGLOB)
691 ILOC_ROOT = MBLOCK
692 & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) )
693 & + mod( IPOS_ROOT - 1, MBLOCK ) + 1
694 RHS_ROOT(ILOC_ROOT, JLOC_ROOT) =
695 & RHS_ROOT(ILOC_ROOT, JLOC_ROOT) + VAL_SON( I, J )
696 END DO
697 END DO
698 ELSE
699 DO ISUB = 1, NSUBSET_COL-NSUPCOL
700 I = SUBSET_COL( ISUB )
701 IGLOB = INDROW_SON( I )
702 JPOS_ROOT = RG2L_COL( IGLOB )
703 JLOC_ROOT = NBLOCK
704 & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) )
705 & + mod( JPOS_ROOT - 1, NBLOCK ) + 1
706 DO JSUB = 1, NSUBSET_ROW
707 J = SUBSET_ROW( JSUB )
708 JGLOB = INDCOL_SON( J )
709 IPOS_ROOT = RG2L_ROW( JGLOB )
710 ILOC_ROOT = MBLOCK
711 & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) )
712 & + mod( IPOS_ROOT - 1, MBLOCK ) + 1
713 VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) =
714 & VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) + VAL_SON( J, I )
715 END DO
716 ENDDO
717 DO ISUB = NSUBSET_COL-NSUPCOL+1, NSUBSET_COL
718 I = SUBSET_COL( ISUB )
719 IGLOB = INDROW_SON( I )
720 JPOS_ROOT = IGLOB - N
721 JLOC_ROOT = NBLOCK
722 & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) )
723 & + mod( JPOS_ROOT - 1, NBLOCK ) + 1
724 DO JSUB = 1, NSUBSET_ROW
725 J = SUBSET_ROW( JSUB )
726 JGLOB = INDCOL_SON( J )
727 IPOS_ROOT = RG2L_ROW( JGLOB )
728 ILOC_ROOT = MBLOCK
729 & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) )
730 & + mod( IPOS_ROOT - 1, MBLOCK ) + 1
731 RHS_ROOT( ILOC_ROOT, JLOC_ROOT ) =
732 & RHS_ROOT( ILOC_ROOT, JLOC_ROOT ) + VAL_SON( J, I )
733 END DO
734 ENDDO
735 END IF
736 END IF
737 RETURN
738 END SUBROUTINE CMUMPS_ROOT_LOCAL_ASSEMBLY
739 SUBROUTINE CMUMPS_INIT_ROOT_ANA
740 &( MYID, NPROCS, N, root, COMM_ROOT, IROOT, FILS,
741 & K50, K46, K51
742 & , K60, IDNPROW, IDNPCOL, IDMBLOCK, IDNBLOCK
743 & )
744 USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC
745 IMPLICIT NONE
746 INTEGER MYID, MYID_ROOT
747 TYPE (CMUMPS_ROOT_STRUC)::root
748 INTEGER COMM_ROOT
749 INTEGER N, IROOT, NPROCS, K50, K46, K51
750 INTEGER FILS( N )
751 INTEGER K60, IDNPROW, IDNPCOL, IDMBLOCK, IDNBLOCK
752 INTEGER INODE, NPROWtemp, NPCOLtemp
753 LOGICAL SLAVE
754 root%ROOT_SIZE = 0
755 root%TOT_ROOT_SIZE = 0
756.ne..or. SLAVE = ( MYID 0
757.eq..and..eq. & ( MYID 0 K46 1 ) )
758 INODE = IROOT
759.GT. DO WHILE ( INODE 0 )
760 INODE = FILS( INODE )
761 root%ROOT_SIZE = root%ROOT_SIZE + 1
762 END DO
763.NE..AND..NE..OR. IF ( ( K60 2 K60 3 )
764.LE..OR..LE. & IDNPROW 0 IDNPCOL 0
765.OR..LE..OR..LE. & IDMBLOCK 0 IDNBLOCK0
766.OR..GT. & IDNPROW * IDNPCOL NPROCS ) THEN
767 root%MBLOCK = K51
768 root%NBLOCK = K51
769 CALL CMUMPS_DEF_GRID( NPROCS, root%NPROW, root%NPCOL,
770 & root%ROOT_SIZE, K50 )
771.EQ..OR..EQ. IF ( K60 2 K60 3 ) THEN
772 IDNPROW = root%NPROW
773 IDNPCOL = root%NPCOL
774 IDMBLOCK = root%MBLOCK
775 IDNBLOCK = root%NBLOCK
776 ENDIF
777.EQ..OR..EQ. ELSE IF ( K60 2 K60 3 ) THEN
778 root%NPROW = IDNPROW
779 root%NPCOL = IDNPCOL
780 root%MBLOCK = IDMBLOCK
781 root%NBLOCK = IDNBLOCK
782 ENDIF
783.EQ..OR..EQ. IF ( K60 2 K60 3 ) THEN
784 IF (SLAVE) THEN
785 root%LPIV = 0
786.EQ. IF (K460) THEN
787 MYID_ROOT=MYID-1
788 ELSE
789 MYID_ROOT=MYID
790 ENDIF
791 IF (MYID_ROOT < root%NPROW*root%NPCOL) THEN
792 root%MYROW = MYID_ROOT / root%NPCOL
793 root%MYCOL = mod(MYID_ROOT, root%NPCOL)
794 root%yes = .true.
795 ELSE
796 root%MYROW = -1
797 root%MYCOL = -1
798 root%yes = .FALSE.
799 ENDIF
800 ELSE
801 root%yes = .FALSE.
802 ENDIF
803 ELSE IF ( SLAVE ) THEN
804 IF ( root%gridinit_done) THEN
805 IF (root%yes) THEN
806 CALL blacs_gridexit( root%CNTXT_BLACS )
807 root%gridinit_done = .FALSE.
808 ENDIF
809 END IF
810 root%CNTXT_BLACS = COMM_ROOT
811 CALL blacs_gridinit( root%CNTXT_BLACS, 'R',
812 & root%NPROW, root%NPCOL )
813 root%gridinit_done = .TRUE.
814 CALL blacs_gridinfo( root%CNTXT_BLACS,
815 & NPROWtemp, NPCOLtemp,
816 & root%MYROW, root%MYCOL )
817.NE. IF ( root%MYROW -1 ) THEN
818 root%yes = .true.
819 ELSE
820 root%yes = .false.
821 END IF
822 root%LPIV = 0
823 ELSE
824 root%yes = .FALSE.
825 ENDIF
826 RETURN
827 END SUBROUTINE CMUMPS_INIT_ROOT_ANA
828 SUBROUTINE CMUMPS_INIT_ROOT_FAC( N, root, FILS, IROOT,
829 & KEEP, INFO )
830 USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC
831 IMPLICIT NONE
832 TYPE ( CMUMPS_ROOT_STRUC ):: root
833 INTEGER N, IROOT, INFO(80), KEEP(500)
834 INTEGER FILS( N )
835 INTEGER INODE, I, allocok
836 IF ( associated( root%RG2L_ROW ) ) THEN
837 DEALLOCATE( root%RG2L_ROW )
838 NULLIFY( root%RG2L_ROW )
839 ENDIF
840 IF ( associated( root%RG2L_COL ) ) THEN
841 DEALLOCATE( root%RG2L_COL )
842 NULLIFY( root%RG2L_COL )
843 ENDIF
844 ALLOCATE( root%RG2L_ROW( N ), stat = allocok )
845.GT. IF ( allocok 0 ) THEN
846 INFO(1)=-13
847 INFO(2)=N
848 RETURN
849 ENDIF
850 ALLOCATE( root%RG2L_COL( N ), stat = allocok )
851.GT. IF ( allocok 0 ) THEN
852 DEALLOCATE( root%RG2L_ROW ); NULLIFY( root%RG2L_ROW )
853 INFO(1)=-13
854 INFO(2)=N
855 RETURN
856 ENDIF
857 INODE = IROOT
858 I = 1
859.GT. DO WHILE ( INODE 0 )
860 root%RG2L_ROW( INODE ) = I
861 root%RG2L_COL( INODE ) = I
862 I = I + 1
863 INODE = FILS( INODE )
864 END DO
865 root%TOT_ROOT_SIZE=0
866 RETURN
867 END SUBROUTINE CMUMPS_INIT_ROOT_FAC
868 SUBROUTINE CMUMPS_DEF_GRID( NPROCS, NPROW, NPCOL, SIZE, K50 )
869 IMPLICIT NONE
870 INTEGER NPROCS, NPROW, NPCOL, SIZE, K50
871 INTEGER NPROWtemp, NPCOLtemp, NPROCSused, FLATNESS
872 LOGICAL KEEPIT
873.EQ. IF ( K50 1 ) THEN
874 FLATNESS = 2
875 ELSE
876 FLATNESS = 3
877 ENDIF
878 NPROW = int(sqrt(real(NPROCS)))
879 NPROWtemp = NPROW
880 NPCOL = int(NPROCS / NPROW)
881 NPCOLtemp = NPCOL
882 NPROCSused = NPROWtemp * NPCOLtemp
883 10 CONTINUE
884.AND. IF ( NPROWtemp >= NPCOLtemp/FLATNESS NPROWtemp > 1) THEN
885 NPROWtemp = NPROWtemp - 1
886 NPCOLtemp = int(NPROCS / NPROWtemp)
887 KEEPIT=.FALSE.
888.GE. IF ( NPROWtemp * NPCOLtemp NPROCSused ) THEN
889.NE..AND. IF ( ( K50 1 NPROWtemp >= NPCOLtemp/FLATNESS)
890.OR..GT. & NPROWtemp * NPCOLtemp NPROCSused )
891 & KEEPIT=.TRUE.
892 END IF
893 IF ( KEEPIT ) THEN
894 NPROW = NPROWtemp
895 NPCOL = NPCOLtemp
896 NPROCSused = NPROW * NPCOL
897 END IF
898 GO TO 10
899 END IF
900 RETURN
901 END SUBROUTINE CMUMPS_DEF_GRID
902 SUBROUTINE CMUMPS_SCATTER_ROOT(MYID, M, N, ASEQ,
903 & LOCAL_M, LOCAL_N,
904 & MBLOCK, NBLOCK,
905 & APAR,
906 & MASTER_ROOT,
907 & NPROW, NPCOL,
908 & COMM)
909 IMPLICIT NONE
910 INTEGER MYID, MASTER_ROOT, COMM
911 INTEGER M, N
912 INTEGER NPROW, NPCOL
913 INTEGER LOCAL_M, LOCAL_N
914 INTEGER MBLOCK, NBLOCK
915 COMPLEX APAR( LOCAL_M, LOCAL_N )
916 COMPLEX ASEQ( M, N )
917 INCLUDE 'mpif.h'
918 INTEGER I, J, SIZE_IBLOCK, SIZE_JBLOCK, IDEST, IROW, ICOL
919 INTEGER IBLOCK, JBLOCK, II, JJ, KK
920 INTEGER IAPAR, JAPAR, IERR, allocok
921 INTEGER :: STATUS(MPI_STATUS_SIZE)
922 COMPLEX, DIMENSION(:), ALLOCATABLE :: WK
923 LOGICAL JUPDATE
924 ALLOCATE(WK( MBLOCK * NBLOCK ), stat=allocok)
925.ne. if(allocok0) then
926 WRITE(6,*) ' Allocation error of WK in '
927 & // 'routine CMUMPS_SCATTER_ROOT '
928 CALL MUMPS_ABORT()
929 endif
930 IAPAR = 1
931 JAPAR = 1
932 DO J = 1, N, NBLOCK
933 SIZE_JBLOCK = NBLOCK
934 IF ( J + NBLOCK > N ) THEN
935 SIZE_JBLOCK = N - J + 1
936 END IF
937 JUPDATE = .FALSE.
938 DO I = 1, M, MBLOCK
939 SIZE_IBLOCK = MBLOCK
940 IF ( I + MBLOCK > M ) THEN
941 SIZE_IBLOCK = M - I + 1
942 END IF
943 IBLOCK = I / MBLOCK
944 JBLOCK = J / NBLOCK
945 IROW = mod ( IBLOCK, NPROW )
946 ICOL = mod ( JBLOCK, NPCOL )
947 IDEST = IROW * NPCOL + ICOL
948.NE. IF ( IDEST MASTER_ROOT ) THEN
949.EQ. IF ( MYID MASTER_ROOT ) THEN
950 KK=1
951 DO JJ=J,J+SIZE_JBLOCK-1
952 DO II=I,I+SIZE_IBLOCK-1
953 WK(KK)=ASEQ(II,JJ)
954 KK=KK+1
955 END DO
956 END DO
957 CALL MPI_SSEND( WK, SIZE_IBLOCK*SIZE_JBLOCK,
958 & MPI_COMPLEX,
959 & IDEST, 128, COMM, IERR )
960.EQ. ELSE IF ( MYID IDEST ) THEN
961 CALL MPI_RECV( WK(1),
962 & SIZE_IBLOCK*SIZE_JBLOCK,
963 & MPI_COMPLEX,
964 & MASTER_ROOT,128,COMM,STATUS,IERR)
965 KK=1
966 DO JJ=JAPAR,JAPAR+SIZE_JBLOCK-1
967 DO II=IAPAR,IAPAR+SIZE_IBLOCK-1
968 APAR(II,JJ)=WK(KK)
969 KK=KK+1
970 END DO
971 END DO
972 JUPDATE = .TRUE.
973 IAPAR = IAPAR + SIZE_IBLOCK
974 END IF
975.EQ. ELSE IF ( MYID MASTER_ROOT ) THEN
976 APAR( IAPAR:IAPAR+SIZE_IBLOCK-1,
977 & JAPAR:JAPAR+SIZE_JBLOCK-1 )
978 & = ASEQ(I:I+SIZE_IBLOCK-1,J:J+SIZE_JBLOCK-1)
979 JUPDATE = .TRUE.
980 IAPAR = IAPAR + SIZE_IBLOCK
981 END IF
982 END DO
983 IF ( JUPDATE ) THEN
984 IAPAR = 1
985 JAPAR = JAPAR + SIZE_JBLOCK
986 END IF
987 END DO
988 DEALLOCATE(WK)
989 RETURN
990 END SUBROUTINE CMUMPS_SCATTER_ROOT
991 SUBROUTINE CMUMPS_GATHER_ROOT(MYID, M, N, ASEQ,
992 & LOCAL_M, LOCAL_N,
993 & MBLOCK, NBLOCK,
994 & APAR,
995 & MASTER_ROOT,
996 & NPROW, NPCOL,
997 & COMM)
998 IMPLICIT NONE
999 INTEGER MYID, MASTER_ROOT, COMM
1000 INTEGER M, N
1001 INTEGER NPROW, NPCOL
1002 INTEGER LOCAL_M, LOCAL_N
1003 INTEGER MBLOCK, NBLOCK
1004 COMPLEX APAR( LOCAL_M, LOCAL_N )
1005 COMPLEX ASEQ( M, N )
1006 INCLUDE 'mpif.h'
1007 INTEGER I, J, SIZE_IBLOCK, SIZE_JBLOCK, ISOUR, IROW, ICOL
1008 INTEGER IBLOCK, JBLOCK, II, JJ, KK
1009 INTEGER IAPAR, JAPAR, IERR, allocok
1010 INTEGER :: STATUS(MPI_STATUS_SIZE)
1011 COMPLEX,DIMENSION(:), ALLOCATABLE :: WK
1012 LOGICAL JUPDATE
1013 ALLOCATE(WK( MBLOCK * NBLOCK ), stat=allocok)
1014.ne. if(allocok0) then
1015 WRITE(6,*) ' Allocation error of WK in '
1016 & // 'routine CMUMPS_GATHER_ROOT '
1017 CALL MUMPS_ABORT()
1018 endif
1019 IAPAR = 1
1020 JAPAR = 1
1021 DO J = 1, N, NBLOCK
1022 SIZE_JBLOCK = NBLOCK
1023 IF ( J + NBLOCK > N ) THEN
1024 SIZE_JBLOCK = N - J + 1
1025 END IF
1026 JUPDATE = .FALSE.
1027 DO I = 1, M, MBLOCK
1028 SIZE_IBLOCK = MBLOCK
1029 IF ( I + MBLOCK > M ) THEN
1030 SIZE_IBLOCK = M - I + 1
1031 END IF
1032 IBLOCK = I / MBLOCK
1033 JBLOCK = J / NBLOCK
1034 IROW = mod ( IBLOCK, NPROW )
1035 ICOL = mod ( JBLOCK, NPCOL )
1036 ISOUR = IROW * NPCOL + ICOL
1037.NE. IF ( ISOUR MASTER_ROOT ) THEN
1038.EQ. IF ( MYID MASTER_ROOT ) THEN
1039 CALL MPI_RECV( WK(1), SIZE_IBLOCK*SIZE_JBLOCK,
1040 & MPI_COMPLEX,
1041 & ISOUR, 128, COMM, STATUS, IERR )
1042 KK=1
1043 DO JJ=J,J+SIZE_JBLOCK-1
1044 DO II=I,I+SIZE_IBLOCK-1
1045 ASEQ(II,JJ)=WK(KK)
1046 KK=KK+1
1047 END DO
1048 END DO
1049.EQ. ELSE IF ( MYID ISOUR ) THEN
1050 KK=1
1051 DO JJ=JAPAR,JAPAR+SIZE_JBLOCK-1
1052 DO II=IAPAR,IAPAR+SIZE_IBLOCK-1
1053 WK(KK)=APAR(II,JJ)
1054 KK=KK+1
1055 END DO
1056 END DO
1057 CALL MPI_SSEND( WK( 1 ),
1058 & SIZE_IBLOCK*SIZE_JBLOCK,
1059 & MPI_COMPLEX,
1060 & MASTER_ROOT,128,COMM,IERR)
1061 JUPDATE = .TRUE.
1062 IAPAR = IAPAR + SIZE_IBLOCK
1063 END IF
1064.EQ. ELSE IF ( MYID MASTER_ROOT ) THEN
1065 ASEQ(I:I+SIZE_IBLOCK-1,J:J+SIZE_JBLOCK-1)
1066 & = APAR( IAPAR:IAPAR+SIZE_IBLOCK-1,
1067 & JAPAR:JAPAR+SIZE_JBLOCK-1 )
1068 JUPDATE = .TRUE.
1069 IAPAR = IAPAR + SIZE_IBLOCK
1070 END IF
1071 END DO
1072 IF ( JUPDATE ) THEN
1073 IAPAR = 1
1074 JAPAR = JAPAR + SIZE_JBLOCK
1075 END IF
1076 END DO
1077 DEALLOCATE(WK)
1078 RETURN
1079 END SUBROUTINE CMUMPS_GATHER_ROOT
1080 SUBROUTINE CMUMPS_ROOT_ALLOC_STATIC(root, IROOT, N,
1081 & IW, LIW, A, LA,
1082 & FILS, DAD, MYID, SLAVEF, PROCNODE_STEPS,
1083 & LPTRAR, NELT, FRTPTR, FRTELT,
1084 & PTRAIW, PTRARW, INTARR, DBLARR,
1085 & LRLU, IPTRLU,
1086 & IWPOS, IWPOSCB, PTRIST, PTRAST,
1087 & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS,
1088 & COMP, LRLUS, IFLAG, KEEP,KEEP8,DKEEP,IERROR )
1089 USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC
1090 IMPLICIT NONE
1091 INTEGER MYID
1092 INTEGER KEEP(500)
1093 INTEGER(8) KEEP8(150)
1094 REAL DKEEP(230)
1095 TYPE (CMUMPS_ROOT_STRUC ) :: root
1096 INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS
1097 INTEGER IROOT, LIW, N, IWPOS, IWPOSCB
1098 INTEGER IW( LIW )
1099 COMPLEX A( LA )
1100 INTEGER, INTENT(IN) :: SLAVEF
1101 INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28))
1102 INTEGER PTRIST(KEEP(28)), STEP(N)
1103 INTEGER(8) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28))
1104 INTEGER PIMASTER(KEEP(28))
1105 INTEGER ITLOC( N + KEEP(253) )
1106 COMPLEX :: RHS_MUMPS(KEEP(255))
1107 INTEGER COMP, IFLAG, IERROR
1108 INCLUDE 'mumps_headers.h'
1109 INTEGER FILS( N ), DAD(KEEP(28))
1110 INTEGER LPTRAR, NELT
1111 INTEGER FRTPTR( N+1), FRTELT( NELT )
1112 INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR )
1113 INTEGER INTARR(KEEP8(27))
1114 COMPLEX DBLARR(KEEP8(26))
1115 INTEGER numroc
1116 EXTERNAL numroc
1117 COMPLEX ZERO
1118 PARAMETER( ZERO = (0.0E0,0.0E0) )
1119 INTEGER(8) :: LREQA_ROOT
1120 INTEGER LREQI_ROOT, LOCAL_M, LOCAL_N, allocok
1121 LOGICAL :: EARLYT3ROOTINS
1122 LOCAL_M = numroc( root%ROOT_SIZE, root%MBLOCK,
1123 & root%MYROW, 0, root%NPROW )
1124 LOCAL_M = max( 1, LOCAL_M )
1125 LOCAL_N = numroc( root%ROOT_SIZE, root%NBLOCK,
1126 & root%MYCOL, 0, root%NPCOL )
1127.GT. IF (KEEP(253)0) THEN
1128 root%RHS_NLOC = numroc( KEEP(253), root%NBLOCK,
1129 & root%MYCOL, 0, root%NPCOL )
1130 root%RHS_NLOC = max(1, root%RHS_NLOC)
1131 ELSE
1132 root%RHS_NLOC = 1
1133 ENDIF
1134 IF (associated( root%RHS_ROOT) )
1135 & DEALLOCATE (root%RHS_ROOT)
1136 ALLOCATE(root%RHS_ROOT(LOCAL_M,root%RHS_NLOC),
1137 & stat=allocok)
1138.GT. IF ( allocok0) THEN
1139 IFLAG=-13
1140 IERROR = LOCAL_M*root%RHS_NLOC
1141 RETURN
1142 ENDIF
1143.NE. IF (KEEP(253)0) THEN
1144 root%RHS_ROOT = ZERO
1145 CALL CMUMPS_ASM_RHS_ROOT ( N, FILS,
1146 & root, KEEP, RHS_MUMPS,
1147 & IFLAG, IERROR )
1148.LT. IF ( IFLAG 0 ) RETURN
1149 ENDIF
1150.NE. IF (KEEP(60) 0) THEN
1151 PTRIST(STEP(IROOT)) = -6666666
1152 ELSE
1153 LREQI_ROOT = 2 + KEEP(IXSZ)
1154 LREQA_ROOT = int(LOCAL_M,8) * int(LOCAL_N,8)
1155.EQ. IF (LREQA_ROOT0_8) THEN
1156 PTRIST(STEP(IROOT)) = -9999999
1157 RETURN
1158 ENDIF
1159 CALL CMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE.,
1160 & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW,A,LA,
1161 & LRLU, IPTRLU,
1162 & IWPOS, IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD,
1163 & PTRIST, PTRAST,
1164 & STEP, PIMASTER, PAMASTER, LREQI_ROOT,
1165 & LREQA_ROOT, IROOT, S_NOTFREE, .TRUE., COMP,
1166 & LRLUS, KEEP8(67), IFLAG, IERROR
1167 & )
1168.LT. IF ( IFLAG 0 ) RETURN
1169 PTRIST ( STEP(IROOT) ) = IWPOSCB + 1
1170 PAMASTER( STEP(IROOT) ) = IPTRLU + 1_8
1171 IW( IWPOSCB + 1 + KEEP(IXSZ)) = - LOCAL_N
1172 IW( IWPOSCB + 2 + KEEP(IXSZ)) = LOCAL_M
1173 ENDIF
1174.EQ. EARLYT3ROOTINS = KEEP(200) 0
1175.OR..LT..AND..EQ. & ( KEEP(200) 0 KEEP(400) 0 )
1176.AND..NOT. IF (LOCAL_N > 0 EARLYT3ROOTINS ) THEN
1177.EQ. IF (KEEP(60) 0) THEN
1178 CALL CMUMPS_SET_TO_ZERO(A(IPTRLU+1_8), LOCAL_M,
1179 & LOCAL_M, LOCAL_N, KEEP)
1180 ELSE
1181 CALL CMUMPS_SET_TO_ZERO(root%SCHUR_POINTER(1),
1182 & root%SCHUR_LLD, LOCAL_M, LOCAL_N, KEEP)
1183 ENDIF
1184.eq. IF (KEEP(55) 0) THEN
1185.EQ. IF (KEEP(60) 0) THEN
1186 CALL CMUMPS_ASM_ARR_ROOT( N, root, IROOT,
1187 & A(IPTRLU+1_8), LOCAL_M, LOCAL_M, LOCAL_N,
1188 & FILS, PTRAIW, PTRARW, INTARR, DBLARR,
1189 & KEEP8(27), KEEP8(26), MYID )
1190 ELSE
1191 CALL CMUMPS_ASM_ARR_ROOT( N, root, IROOT,
1192 & root%SCHUR_POINTER(1), root%SCHUR_LLD, LOCAL_M, LOCAL_N,
1193 & FILS, PTRAIW, PTRARW, INTARR, DBLARR,
1194 & KEEP8(27), KEEP8(26), MYID )
1195 ENDIF
1196 ELSE
1197.EQ. IF (KEEP(60) 0) THEN
1198 CALL CMUMPS_ASM_ELT_ROOT( N, root,
1199 & A(IPTRLU+1_8), LOCAL_M, LOCAL_M, LOCAL_N,
1200 & LPTRAR, NELT, FRTPTR, FRTELT,
1201 & PTRAIW, PTRARW, INTARR, DBLARR,
1202 & KEEP8(27), KEEP8(26), KEEP, KEEP8, MYID )
1203 ELSE
1204 CALL CMUMPS_ASM_ELT_ROOT( N, root,
1205 & root%SCHUR_POINTER(1), root%SCHUR_LLD,
1206 & root%SCHUR_MLOC, root%SCHUR_NLOC,
1207 & LPTRAR, NELT, FRTPTR, FRTELT,
1208 & PTRAIW, PTRARW, INTARR, DBLARR,
1209 & KEEP8(27), KEEP8(26), KEEP, KEEP8, MYID )
1210 ENDIF
1211 ENDIF
1212 ENDIF
1213 RETURN
1214 END SUBROUTINE CMUMPS_ROOT_ALLOC_STATIC
1215 SUBROUTINE CMUMPS_ASM_ELT_ROOT( N, root,
1216 & VALROOT, LOCAL_M_LLD, LOCAL_M, LOCAL_N,
1217 & LPTRAR, NELT, FRTPTR, FRTELT,
1218 & PTRAIW, PTRARW,
1219 & INTARR, DBLARR, LINTARR, LDBLARR,
1220 & KEEP, KEEP8,
1221 & MYID)
1222 USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC
1223 IMPLICIT NONE
1224 TYPE (CMUMPS_ROOT_STRUC) :: root
1225 INTEGER :: N, MYID, LOCAL_M, LOCAL_N, KEEP(500)
1226 INTEGER :: LOCAL_M_LLD
1227 INTEGER(8) KEEP8(150)
1228 COMPLEX VALROOT(LOCAL_M_LLD,LOCAL_N)
1229 INTEGER LPTRAR, NELT
1230 INTEGER FRTPTR( N+1), FRTELT( NELT )
1231 INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR )
1232 INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR
1233 INTEGER, INTENT(INOUT) :: INTARR(LINTARR)
1234 COMPLEX DBLARR(LDBLARR)
1235 INTEGER(8) :: J1, J2, K8, IPTR
1236 INTEGER :: IELT, I, J, IGLOB, JGLOB, SIZEI, IBEG
1237 INTEGER :: ARROW_ROOT
1238 INTEGER :: IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID
1239 INTEGER :: ILOCROOT, JLOCROOT
1240 ARROW_ROOT = 0
1241 DO IPTR = FRTPTR(KEEP(38)), FRTPTR(KEEP(38)+1) - 1
1242 IELT = FRTELT( IPTR )
1243 J1 = PTRAIW(IELT)
1244 J2 = PTRAIW(IELT+1)-1
1245 K8 = PTRARW(IELT)
1246 SIZEI=int(J2-J1)+1
1247 DO J=1, SIZEI
1248 JGLOB = INTARR(J1+J-1)
1249 INTARR(J1+J-1) = root%RG2L_ROW(JGLOB)
1250 ENDDO
1251 DO J = 1, SIZEI
1252 JGLOB = INTARR(J1+J-1)
1253.eq. IF ( KEEP(50) 0 ) THEN
1254 IBEG = 1
1255 ELSE
1256 IBEG = J
1257 END IF
1258 DO I = IBEG, SIZEI
1259 IGLOB = INTARR(J1+I-1)
1260.eq. IF ( KEEP(50)0 ) THEN
1261 IPOSROOT = INTARR(J1+I-1)
1262 JPOSROOT = INTARR(J1+J-1)
1263 ELSE
1264.GT. IF ( INTARR(J1+I-1) INTARR(J1+J-1) ) THEN
1265 IPOSROOT = INTARR(J1+I-1)
1266 JPOSROOT = INTARR(J1+J-1)
1267 ELSE
1268 IPOSROOT = INTARR(J1+J-1)
1269 JPOSROOT = INTARR(J1+I-1)
1270 END IF
1271 END IF
1272 IROW_GRID = mod( ( IPOSROOT - 1 )/root%MBLOCK,
1273 & root%NPROW )
1274 JCOL_GRID = mod( ( JPOSROOT - 1 )/root%NBLOCK,
1275 & root%NPCOL )
1276.EQ..AND. IF ( IROW_GRIDroot%MYROW
1277.EQ. & JCOL_GRIDroot%MYCOL ) THEN
1278 ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) /
1279 & ( root%MBLOCK * root%NPROW ) )
1280 & + mod( IPOSROOT - 1, root%MBLOCK ) + 1
1281 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) /
1282 & ( root%NBLOCK * root%NPCOL ) )
1283 & + mod( JPOSROOT - 1, root%NBLOCK ) + 1
1284 VALROOT( ILOCROOT, JLOCROOT ) =
1285 & VALROOT( ILOCROOT, JLOCROOT ) + DBLARR(K8)
1286 ENDIF
1287 K8 = K8 + 1_8
1288 END DO
1289 END DO
1290 ARROW_ROOT = ARROW_ROOT + int(PTRARW(IELT+1_8)-PTRARW(IELT))
1291 END DO
1292 KEEP(49) = ARROW_ROOT
1293 RETURN
1294 END SUBROUTINE CMUMPS_ASM_ELT_ROOT
1295 SUBROUTINE CMUMPS_ASM_RHS_ROOT
1296 & ( N, FILS, root, KEEP, RHS_MUMPS,
1297 & IFLAG, IERROR )
1298 USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC
1299 IMPLICIT NONE
1300 INTEGER N, KEEP(500), IFLAG, IERROR
1301 INTEGER FILS(N)
1302 TYPE (CMUMPS_ROOT_STRUC ) :: root
1303 COMPLEX :: RHS_MUMPS(KEEP(255))
1304 INTEGER JCOL, IPOS_ROOT, JPOS_ROOT,
1305 & IROW_GRID, JCOL_GRID, ILOCRHS, JLOCRHS,
1306 & INODE
1307 INODE = KEEP(38)
1308.GT. DO WHILE (INODE0)
1309 IPOS_ROOT = root%RG2L_ROW( INODE )
1310 IROW_GRID = mod( ( IPOS_ROOT - 1 ) / root%MBLOCK, root%NPROW )
1311.NE. IF ( IROW_GRID root%MYROW ) GOTO 100
1312 ILOCRHS = root%MBLOCK * ( ( IPOS_ROOT - 1 ) /
1313 & ( root%MBLOCK * root%NPROW ) )
1314 & + mod( IPOS_ROOT - 1, root%MBLOCK ) + 1
1315 DO JCOL = 1, KEEP(253)
1316 JPOS_ROOT = JCOL
1317 JCOL_GRID = mod((JPOS_ROOT-1)/root%NBLOCK, root%NPCOL)
1318.NE. IF (JCOL_GRIDroot%MYCOL ) CYCLE
1319 JLOCRHS = root%NBLOCK * ( ( JPOS_ROOT - 1 ) /
1320 & ( root%NBLOCK * root%NPCOL ) )
1321 & + mod( JPOS_ROOT - 1, root%NBLOCK ) + 1
1322 root%RHS_ROOT(ILOCRHS, JLOCRHS) =
1323 & RHS_MUMPS(INODE+(JCOL-1)*KEEP(254))
1324 ENDDO
1325 100 CONTINUE
1326 INODE=FILS(INODE)
1327 ENDDO
1328 RETURN
1329 END SUBROUTINE CMUMPS_ASM_RHS_ROOT
1330 SUBROUTINE CMUMPS_ASM_ARR_ROOT( N, root, IROOT,
1331 & VALROOT, LOCAL_M_LLD, LOCAL_M, LOCAL_N, FILS,
1332 & PTRAIW, PTRARW,
1333 & INTARR, DBLARR, LINTARR, LDBLARR,
1334 & MYID)
1335 USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC
1336 IMPLICIT NONE
1337 TYPE (CMUMPS_ROOT_STRUC) :: root
1338 INTEGER :: N, MYID, IROOT, LOCAL_M, LOCAL_N
1339 INTEGER :: LOCAL_M_LLD
1340 INTEGER FILS( N )
1341 INTEGER(8), INTENT(IN) :: PTRARW( N ), PTRAIW( N )
1342 COMPLEX VALROOT(LOCAL_M_LLD,LOCAL_N)
1343 INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR
1344 INTEGER INTARR(LINTARR)
1345 COMPLEX DBLARR(LDBLARR)
1346 COMPLEX VAL
1347 INTEGER(8) :: JJ, J1,JK, J2,J3, J4, AINPUT
1348 INTEGER IORG, IBROT, NUMORG,
1349 & IROW, JCOL
1350 INTEGER IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID
1351 INTEGER ILOCROOT, JLOCROOT
1352 NUMORG = root%ROOT_SIZE
1353 IBROT = IROOT
1354 DO IORG = 1, NUMORG
1355 JK = PTRAIW(IBROT)
1356 AINPUT = PTRARW(IBROT)
1357 IBROT = FILS(IBROT)
1358 JJ = JK + 1
1359 J1 = JJ + 1
1360 J2 = J1 + INTARR(JK)
1361 J3 = J2 + 1
1362 J4 = J2 - INTARR(JJ)
1363 JCOL = INTARR(J1)
1364 DO JJ = J1, J2
1365 IROW = INTARR(JJ)
1366 VAL = DBLARR(AINPUT)
1367 AINPUT = AINPUT + 1
1368 IPOSROOT = root%RG2L_ROW( IROW )
1369 JPOSROOT = root%RG2L_COL( JCOL )
1370 IROW_GRID = mod( ( IPOSROOT - 1 ) / root%MBLOCK, root%NPROW )
1371 JCOL_GRID = mod( ( JPOSROOT - 1 ) / root%NBLOCK, root%NPCOL )
1372.EQ..AND. IF ( IROW_GRID root%MYROW
1373.EQ. & JCOL_GRID root%MYCOL ) THEN
1374 ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) /
1375 & ( root%MBLOCK * root%NPROW ) )
1376 & + mod( IPOSROOT - 1, root%MBLOCK ) + 1
1377 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) /
1378 & ( root%NBLOCK * root%NPCOL ) )
1379 & + mod( JPOSROOT - 1, root%NBLOCK ) + 1
1380 VALROOT( ILOCROOT, JLOCROOT ) =
1381 & VALROOT( ILOCROOT, JLOCROOT ) + VAL
1382 END IF
1383 END DO
1384.LE. IF (J3 J4) THEN
1385 IROW = INTARR(J1)
1386 DO JJ= J3,J4
1387 JCOL = INTARR(JJ)
1388 VAL = DBLARR(AINPUT)
1389 AINPUT = AINPUT + 1
1390 IPOSROOT = root%RG2L_ROW( IROW )
1391 JPOSROOT = root%RG2L_COL( JCOL )
1392 IROW_GRID= mod( ( IPOSROOT - 1 )/root%MBLOCK, root%NPROW)
1393 JCOL_GRID= mod( ( JPOSROOT - 1 )/root%NBLOCK, root%NPCOL)
1394.EQ..AND. IF ( IROW_GRID root%MYROW
1395.EQ. & JCOL_GRID root%MYCOL ) THEN
1396 ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) /
1397 & ( root%MBLOCK * root%NPROW ) )
1398 & + mod( IPOSROOT - 1, root%MBLOCK ) + 1
1399 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) /
1400 & ( root%NBLOCK * root%NPCOL ) )
1401 & + mod( JPOSROOT - 1, root%NBLOCK ) + 1
1402 VALROOT( ILOCROOT, JLOCROOT ) =
1403 & VALROOT( ILOCROOT, JLOCROOT ) + VAL
1404 END IF
1405 END DO
1406 ENDIF
1407 ENDDO
1408 RETURN
1409 END SUBROUTINE CMUMPS_ASM_ARR_ROOT
mumps_abort
#define mumps_abort
Definition VE_Metis.h:25
cmumps_bdc_error
subroutine cmumps_bdc_error(myid, slavef, comm, keep)
Definition cbcast_int.F:38
cmumps_compre_new
subroutine cmumps_compre_new(n, keep, iw, liw, a, la, lrlu, iptrlu, iwpos, iwposcb, ptrist, ptrast, step, pimaster, pamaster, lrlus, xsize, comp, acc_time, myid, slavef, procnode_steps, dad)
Definition cfac_mem_compress_cb.F:120
cmumps_try_recvtreat
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)
Definition cfac_process_message.F:560
cmumps_insert_pool_n
subroutine cmumps_insert_pool_n(n, pool, lpool, procnode, slavef, keep199, k28, k76, k80, k47, step, inode)
Definition cfac_sol_pool.F:27
cmumps_buf_send_contrib_type3_i
subroutine cmumps_buf_send_contrib_type3_i(n, ison, nbcol_son, nbrow_son, indcol_son, indrow_son, ld_son, val_son, tag, subset_row, subset_col, nsubset_row, nsubset_col, nsuprow, nsupcol, nprow, npcol, mblock, rg2l_row, rg2l_col, nblock, pdest, comm, ierr, tab, tabsize, transp, size_pack, n_already_sent, keep, bbpcbp)
Definition ctools.F:1883
cmumps_build_and_send_cb_root
recursive subroutine cmumps_build_and_send_cb_root(comm_load, ass_irecv, n, ison, iroot, ptri, ptrr, root, nbrow, nbcol, shift_list_row_son, shift_list_col_son, shift_val_son_arg, lda_arg, tag, 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, transpose_asm, nd, frere, lptrar, nelt, frtptr, frtelt, istep_to_iniv2, tab_pos_in_pere, lrgroups)
Definition ctype3_root.F:84
cmumps_ass_root
subroutine cmumps_ass_root(root, keep50, nrow_son, ncol_son, indrow_son, indcol_son, nsupcol, val_son, val_root, local_m, local_n, rhs_root, nloc_root, cbp)
Definition ctype3_root.F:19
cmumps_set_lda_shift_val_son
subroutine cmumps_set_lda_shift_val_son(iw, liw, ioldps, lda, shift_val_son)
Definition ctype3_root.F:574
cmumps_root_local_assembly
subroutine cmumps_root_local_assembly(n, val_root, local_m, local_n, npcol, nprow, mblock, nblock, nbcol_son, nbrow_son, indcol_son, indrow_son, ld_son, val_son, subset_row, subset_col, nsubset_row, nsubset_col, nsuprow, nsupcol, rg2l_row, rg2l_col, transpose_asm, keep, rhs_root, nloc)
Definition ctype3_root.F:611
cmumps_root_alloc_static
subroutine cmumps_root_alloc_static(root, iroot, n, iw, liw, a, la, fils, dad, myid, slavef, procnode_steps, lptrar, nelt, frtptr, frtelt, ptraiw, ptrarw, intarr, dblarr, lrlu, iptrlu, iwpos, iwposcb, ptrist, ptrast, step, pimaster, pamaster, itloc, rhs_mumps, comp, lrlus, iflag, keep, keep8, dkeep, ierror)
Definition ctype3_root.F:1089
max
#define max(a, b)
Definition macros.h:21
cmumps_buf
Definition cmumps_comm_buffer.F:14
cmumps_dynamic_memory_m
Definition cfac_mem_dynamic.F:14
cmumps_dynamic_memory_m::cmumps_dm_set_dynptr
subroutine cmumps_dm_set_dynptr(cb_state, a, la, pamaster_or_ptrast, ixxd, ixxr, son_a, iachk, recsize)
Definition cfac_mem_dynamic.F:19
cmumps_load
Definition cmumps_load.F:14
cmumps_load::cmumps_load_pool_upd_new_pool
subroutine, public cmumps_load_pool_upd_new_pool(pool, lpool, procnode, keep, keep8, slavef, comm, myid, step, n, nd, fils)
Definition cmumps_load.F:1820
cmumps_load::myid
integer, save, private myid
Definition cmumps_load.F:57
cmumps_ooc
Definition cmumps_ooc.F:14
cmumps_ooc::cmumps_force_write_buf
subroutine cmumps_force_write_buf(ierr)
Definition cmumps_ooc.F:2951
cmumps_ooc::cmumps_ooc_force_wrt_buf_panel
subroutine cmumps_ooc_force_wrt_buf_panel(ierr)
Definition cmumps_ooc.F:2965
cmumps_struc_def
Definition cmumps_struc_def.F:14
comp
int comp(int a, int b)
Definition set_surface_lines.cpp:102
mumps_procnode
integer function mumps_procnode(procinfo_inode, k199)
Definition tools_common.F:151