OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
sana_driver.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
14C
15 SUBROUTINE smumps_ana_driver(id)
16 USE smumps_load
17 USE mumps_static_mapping
18 USE smumps_struc_def
19 USE mumps_memory_mod
20 USE smumps_parallel_analysis
21 USE smumps_ana_lr
22 USE smumps_lr_core
23 USE smumps_lr_stats
24 USE mumps_lr_common
25 USE smumps_ana_aux_m
26 USE mumps_ana_blk_m, ONLY: compact_graph_t, lmatrix_t
27 USE mumps_ana_omp_m
28 USE smumps_facsol_l0omp_m, ONLY: smumps_free_l0_omp_factors
29 IMPLICIT NONE
30C
31 include 'mpif.h'
32 include 'mumps_tags.h'
33 INTEGER IERR, MASTER
34 parameter( master = 0 )
35C
36C Purpose
37C =======
38C
39C Performs analysis and (if required) Max-trans on the master, then
40C broadcasts information to the slaves. Also includes mapping.
41C
42C
43C Parameters
44C ==========
45C
46 TYPE(smumps_struc), TARGET :: id
47C
48C Local variables
49C ===============
50C
51C
52C Pointers inside integer array, various data
53 INTEGER IKEEP, NE, NA
54 INTEGER I, allocok
55C Other locals
56 INTEGER NB_NIV2, IDEST
57 INTEGER :: STATUS(MPI_STATUS_SIZE)
58 INTEGER LOCAL_M, LOCAL_N
59 INTEGER numroc
60 EXTERNAL numroc
61 INTEGER IRANK
62 INTEGER MP, LP, MPG
63 LOGICAL PROK, PROKG, LISTVAR_SCHUR_2BE_FREED, LPOK
64 INTEGER SIZE_SCHUR_PASSED
65 INTEGER SBUF_SEND_FR, SBUF_REC_FR
66 INTEGER SBUF_SEND_LR, SBUF_REC_LR
67 INTEGER TOTAL_MBYTES
68 INTEGER(8) SUM_KEEP811_THIS_NODE, MAX_SUM_KEEP811_THIS_NODE
69 INTEGER SUM_INFO15_THIS_NODE, MAX_SUM_INFO15_THIS_NODE
70 INTEGER SUM_INFO17_THIS_NODE, MAX_SUM_INFO17_THIS_NODE
71 INTEGER(8) SBUF_RECOLD8, MIN_BUF_SIZE8
72 LOGICAL UPDATE_BUFFER
73 INTEGER MIN_BUF_SIZE
74 INTEGER(8) MAX_SIZE_FACTOR_TMP
75 INTEGER LEAF, INODE, ISTEP, INN, LPTRAR
76 INTEGER NBLEAF, NBROOT, MYROW_CHECK, INIV2
77 DOUBLE PRECISION TIMEG
78 INTEGER :: TOTAL_MBYTES_UNDER_L0
79 INTEGER(8) :: TOTAL_BYTES_UNDER_L0
80 INTEGER :: NBSTATS_I4, NBSTATS_I8
81 parameter(nbstats_i4=4, nbstats_i8=24)
82 INTEGER, ALLOCATABLE, TARGET, DIMENSION(:) :: TNSTK_afterL0
83 INTEGER, ALLOCATABLE, DIMENSION(:) :: FLAGGED_LEAVES
84 INTEGER(8) :: PEAK_UNDER_L0, PEAK_ABOVE_L0
85 INTEGER(8) :: SUM_NRLADU, MAX_NRLADU, MIN_NRLADU,
86 & SUM_NRLADU_if_LR_LU,
87 & SUM_NRLADULR_UD, SUM_NRLADULR_WC,
88 & SUM_NRLNEC, SUM_NRLNEC_ACTIVE,
89 & MIN_NRLNEC
90 INTEGER :: SUM_NIRADU,
91 & SUM_NIRADU_OOC,
92 & SUM_NIRNEC, SUM_NIRNEC_OOC
93 INTEGER :: LIPOOL_local
94 INTEGER(8) :: MAX_FRONT_SURFACE_LOCAL_L0,
95 & MAX_SIZE_FACTOR_L0,
96 & ENTRIES_IN_FACTORS_UNDER_L0,
97 & ENTRIES_IN_FACTORS_MASTERS_LO
98 INTEGER :: MAXFR_UNDER_L0
99 DOUBLE PRECISION :: COST_SUBTREES_UNDER_L0, OPSA_UNDER_L0
100C to store the size of the sequencial peak of stack
101C (or an estimation for not calling REORDER_TREE_N )
102 REAL :: PEAK
103 INTEGER(8):: SIZECB_UNDER_L0, SIZECB_UNDER_L0_IF_LRCB
104 LOGICAL :: ABOVE_L0
105C
106C INTEGER WORKSPACE
107C
108 INTEGER, ALLOCATABLE, DIMENSION(:):: IPOOL
109 INTEGER :: LIPOOL
110 INTEGER, ALLOCATABLE, TARGET, DIMENSION(:) :: PAR2_NODES
111 INTEGER, DIMENSION(:), POINTER :: PAR2_NODESPTR
112 INTEGER, ALLOCATABLE, DIMENSION(:) :: PROCNODE
113 INTEGER, DIMENSION(:), ALLOCATABLE :: IWtemp
114 INTEGER, DIMENSION(:), ALLOCATABLE :: XNODEL, NODEL
115 INTEGER, DIMENSION(:), POINTER :: SSARBR
116C Element matrix entry
117 INTEGER, POINTER :: NELT, LELTVAR
118 INTEGER, DIMENSION(:), POINTER :: KEEP, INFO, INFOG
119 INTEGER(8), DIMENSION(:), POINTER :: KEEP8
120 INTEGER(8) :: ENTRIES_IN_FACTORS_LOC_MASTERS
121 REAL, DIMENSION(:), POINTER :: RINFO
122 REAL, DIMENSION(:), POINTER :: RINFOG
123 INTEGER, DIMENSION(:), POINTER :: ICNTL
124 LOGICAL :: I_AM_SLAVE, PERLU_ON, COND
125 INTEGER :: OOC_STRAT, BLR_STRAT
126 INTEGER :: IDUMMY
127 INTEGER, TARGET :: IDUMMY_ARRAY(1)
128 INTEGER, POINTER, DIMENSION(:) :: IRN_loc_PTR
129 INTEGER, POINTER, DIMENSION(:) :: JCN_loc_PTR
130 INTEGER, POINTER, DIMENSION(:) :: IRN_PTR
131 INTEGER, POINTER, DIMENSION(:) :: JCN_PTR
132 INTEGER, POINTER, DIMENSION(:) :: SIZEOFBLOCKS_PTR
133 INTEGER, POINTER, DIMENSION(:) :: UNS_PERM_PTR
134 LOGICAL :: BDUMMY
135 INTEGER(8) :: K8_33relaxed, K8_34relaxed, K8_35relaxed,
136 & K8_50relaxed
137 LOGICAL :: SUM_OF_PEAKS
138 INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE
139 EXTERNAL mumps_typenode, mumps_procnode
140 INTEGER, EXTERNAL :: MUMPS_ENCODE_TPN_IPROC
141 INTEGER :: PROCNODE_VALUE
142 INTEGER K,J, IFS
143 INTEGER SIZE_TEMP_MEM,SIZE_DEPTH_FIRST,SIZE_COST_TRAV
144 LOGICAL IS_BUILD_LOAD_MEM_CALLED
145 LOGICAL PRINT_MAXAVG, PRINT_NODEINFO
146 DOUBLE PRECISION, DIMENSION (:,:), ALLOCATABLE :: TEMP_MEM
147 INTEGER, DIMENSION (:,:), ALLOCATABLE :: TEMP_ROOT
148 INTEGER, DIMENSION (:,:), ALLOCATABLE :: TEMP_LEAF
149 INTEGER, DIMENSION (:,:), ALLOCATABLE :: TEMP_SIZE
150 INTEGER, DIMENSION (:), ALLOCATABLE :: DEPTH_FIRST
151 INTEGER, DIMENSION (:), ALLOCATABLE :: DEPTH_FIRST_SEQ
152 INTEGER, DIMENSION (:), ALLOCATABLE :: SBTR_ID
153 REAL, DIMENSION (:), ALLOCATABLE :: COST_TRAV_TMP
154 INTEGER(8) :: TOTAL_BYTES, ITMP8
155 INTEGER :: SIZE_PAR2_NODESPTR
156 INTEGER :: LSIZEOFBLOCKS_PTR
157 LOGICAL :: READY_FOR_ANA_F
158 INTEGER, ALLOCATABLE, DIMENSION(:) :: MAPCOL
159 LOGICAL :: BLKPTR_ALLOCATED, BLKVAR_ALLOCATED
160 INTEGER :: IB, BLKSIZE
161 INTEGER :: IBcurrent, IPOS, IPOSB, II
162C Internal work arrays:
163C DOF2BLOCK(idof)=inode, idof in [1,N], inode in [1,NBLK]
164C SIZEBLOCK(1:NBLK) (for node valuation)
165 INTEGER, TARGET, DIMENSION(:), allocatable:: SIZEOFBLOCKS
166 INTEGER, DIMENSION(:), allocatable:: DOF2BLOCK
167 INTEGER :: NBRECORDS
168 INTEGER(8) :: NSEND8, NLOCAL8
169C LMAT_BLOCK: in case of centralized matrix,
170C to store on MASTER the cleaned Lmatrix
171C used to compute GCOMP
172C LMAT_BLOCK might also be saved to
173C be used during grouping
174C LUMAT : in case of distributed matrix
175C to store distributed the cleaned LU matrix
176C LUMAT might also be saved to
177C be used for MPI based grouping
178C LUMAT_REMAP : in case of distributed matrix
179C it is used to remap LUMAT
180C
181C GCOMP : Graph "ready" to be called by orderings
182C
183 TYPE(lmatrix_t) :: LMAT_BLOCK, LUMAT, LUMAT_REMAP
184 LOGICAL :: GCOMP_PROVIDED
185 TYPE(compact_graph_t) :: GCOMP
186 TYPE(compact_graph_t) :: GCOMP_DIST
187 INTEGER(4) :: I4
188 INTEGER, POINTER, DIMENSION(:) ::
189 & NFSIZPTR,
190 & FILSPTR,
191 & FREREPTR, NE_STEPSPTR,
192 & IKEEP1, IKEEP2, IKEEP3,
193 & STEPPTR, LRGROUPSPTR
194 INTEGER, ALLOCATABLE, DIMENSION(:), TARGET :: IKEEPALLOC
195 INTEGER, ALLOCATABLE, DIMENSION(:) :: WORK2ALLOC
196 ! Used because of multithreaded SIM_NP_
197 INTEGER :: locMYID, locMYID_NODES
198 LOGICAL, POINTER :: locI_AM_CAND(:)
199 INTEGER(kind=8) :: NZ8, LIW8
200C NBLK : id%N or order of blocked matrix
201 INTEGER :: NBLK
202 INTEGER :: LIW_ELT
203C GATHER_MATRIX_ALLOCATED:
204C To be sure that id%IRN and id%JCN are
205C deallocated only when SMUMPS_GATHER_MATRIX was called
206 LOGICAL :: GATHER_MATRIX_ALLOCATED
207C
208 INTERFACE
209 SUBROUTINE smumps_free_onentry_ana_driver(id)
210 USE smumps_struc_def
211 TYPE (SMUMPS_STRUC), TARGET :: id
212 END SUBROUTINE smumps_free_onentry_ana_driver
213C Explicit interface because of pointer arguments:
214 SUBROUTINE smumps_free_id_data_modules(id_FDM_F_ENCODING,
215 & id_BLRARRAY_ENCODING, KEEP8, K34)
216# if defined(MUMPS_F2003)
217 CHARACTER, DIMENSION(:), POINTER, intent(inout) ::
218 & id_blrarray_encoding
219 CHARACTER, DIMENSION(:), POINTER, intent(inout) ::
220 & id_fdm_f_encoding
221# else
222 CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING
223 CHARACTER, DIMENSION(:), POINTER :: id_FDM_F_ENCODING
224# endif
225 INTEGER(8), intent(inout) :: KEEP8(150)
226 INTEGER, intent(in) :: K34
227 END SUBROUTINE smumps_free_id_data_modules
228 END INTERFACE
229C
230C Beginning of executable statements
231C
232C Free data that might have been computed during
233C a previous analysis step for factorization and
234C that will be recomputed
235 CALL smumps_free_onentry_ana_driver (id)
236 is_build_load_mem_called=.false.
237 keep => id%KEEP
238 keep8 => id%KEEP8
239 info => id%INFO
240 rinfo => id%RINFO
241 infog => id%INFOG
242 rinfog => id%RINFOG
243 icntl => id%ICNTL
244 nelt => id%NELT
245 leltvar => id%LELTVAR
246 keep(264) = 0 ! reinitialise out-of-range status (0=yes)
247 keep(265) = 0 ! reinitialise dupplicates (0=yes)
248 print_maxavg = .NOT.(id%NSLAVES.EQ.1 .AND. keep(46).EQ.1)
249C Print per node information only in case there are several
250C compute nodes (id%KEEP(412): #MPI procs on compute node)
251 print_nodeinfo = print_maxavg .AND. id%NPROCS .NE. id%KEEP(412)
252 gather_matrix_allocated = .false.
253 NULLIFY ( nfsizptr,
254 & filsptr,
255 & frereptr, ne_stepsptr,
256 & ikeep1, ikeep2, ikeep3, stepptr, lrgroupsptr,
257 & ssarbr, sizeofblocks_ptr, irn_loc_ptr, jcn_loc_ptr,
258 & irn_ptr, jcn_ptr,
259 & par2_nodesptr )
260 IF (associated(id%UNS_PERM)) DEALLOCATE(id%UNS_PERM)
261 nullify(id%UNS_PERM)
262 idummy = 1
263 bdummy = .false.
264C Set default value that witl be reset in
265C case of blocked format matrices
266 nblk = id%N
267 gcomp_provided = .false.
268 blkptr_allocated = .false.
269 blkvar_allocated = .false.
270C -------------------------------------
271C Depending on the type of parallelism,
272C the master can now (soon) potentially
273C have the role of a slave
274C -------------------------------------
275 i_am_slave = ( id%MYID .ne. master .OR.
276 & ( id%MYID .eq. master .AND.
277 & id%KEEP(46) .eq. 1 ) )
278 lp = icntl( 1 )
279 mp = icntl( 2 )
280 mpg = icntl( 3 )
281C LP : errors
282C MP : INFO
283 lpok = ((lp.GT.0).AND.(id%ICNTL(4).GE.1))
284 prok = (( mp .GT. 0 ).AND.(icntl(4).GE.2))
285 prokg = ( mpg .GT. 0 .and. id%MYID .eq. master )
286 prokg = (prokg.AND.(icntl(4).GE.2))
287 IF ( prok ) THEN
288 IF ( keep(50) .eq. 0 ) THEN
289 WRITE(mp, '(A)') 'L U Solver for unsymmetric matrices'
290 ELSE IF ( keep(50) .eq. 1 ) THEN
291 WRITE(mp, '(A)')
292 & 'L D L^T Solver for symmetric positive definite matrices'
293 ELSE
294 WRITE(mp, '(A)')
295 & 'L D L^T Solver for general symmetric matrices'
296 END IF
297 IF ( keep(46) .eq. 1 ) THEN
298 WRITE(mp, '(A)') 'Type of parallelism: Working host'
299 ELSE
300 WRITE(mp, '(A)') 'Type of parallelism: Host not working'
301 END IF
302 END IF
303 IF ( prokg .AND. (mp.NE.mpg)) THEN
304 IF ( keep(50) .eq. 0 ) THEN
305 WRITE(mpg, '(A)') 'L U Solver for unsymmetric matrices'
306 ELSE IF ( keep(50) .eq. 1 ) THEN
307 WRITE(mpg, '(A)')
308 & 'L D L^T Solver for symmetric positive definite matrices'
309 ELSE
310 WRITE(mpg, '(A)')
311 & 'L D L^T Solver for general symmetric matrices'
312 END IF
313 IF ( keep(46) .eq. 1 ) THEN
314 WRITE(mpg, '(A)') 'Type of parallelism: Working host'
315 ELSE
316 WRITE(mpg, '(A)') 'Type of parallelism: Host not working'
317 END IF
318 END IF
319 IF (prok) WRITE( mp, 110 )
320 IF (prokg .AND. (mpg.NE.mp)) WRITE( mpg, 110 )
321C
322C BEGIN CASE OF ALLOCATED DATA FROM PREVIOUS CALLS
323C ----------------------------------------
324C Free some memory from factorization,
325C if allocated, at least large arrays.
326C This will also limit the amount of useless
327C data saved to disk in case of save-restore
328C ----------------------------------------
329 IF (id%KEEP8(24).EQ.0_8) THEN
330C -- deallocate only when not provided/allocated by the user
331 IF (associated(id%S)) THEN
332 DEALLOCATE(id%S)
333 id%KEEP8(23)=0_8
334 ENDIF
335 ENDIF
336 NULLIFY(id%S)
337 keep8(24) = 0_8 ! reinitialize last used size of WK_USER
338 IF (associated(id%IS)) THEN
339 DEALLOCATE(id%IS)
340 NULLIFY(id%IS)
341 ENDIF
342C also avoid keeping BLR factors allocated if analysis
343C called after a previous BLR factorization without
344C an intermediate JOB=-2 call.
345 CALL smumps_free_id_data_modules(id%FDM_F_ENCODING,
346 & id%BLRARRAY_ENCODING, id%KEEP8(1), id%KEEP(34))
347 IF (associated(id%root%RG2L_ROW))THEN
348 DEALLOCATE(id%root%RG2L_ROW)
349 NULLIFY(id%root%RG2L_ROW)
350 ENDIF
351 IF (associated(id%root%RG2L_COL))THEN
352 DEALLOCATE(id%root%RG2L_COL)
353 NULLIFY(id%root%RG2L_COL)
354 ENDIF
355 IF (associated( id%PTLUST_S )) THEN
356 DEALLOCATE(id%PTLUST_S)
357 NULLIFY(id%PTLUST_S)
358 ENDIF
359 IF (associated(id%PTRFAC)) THEN
360 DEALLOCATE(id%PTRFAC)
361 NULLIFY(id%PTRFAC)
362 END IF
363 IF (associated(id%RHSCOMP)) THEN
364 DEALLOCATE(id%RHSCOMP)
365 NULLIFY(id%RHSCOMP)
366 id%KEEP8(25)=0_8
367 ENDIF
368 IF (associated(id%POSINRHSCOMP_ROW)) THEN
369 DEALLOCATE(id%POSINRHSCOMP_ROW)
370 NULLIFY(id%POSINRHSCOMP_ROW)
371 ENDIF
372 IF (id%POSINRHSCOMP_COL_ALLOC) THEN
373 DEALLOCATE(id%POSINRHSCOMP_COL)
374 NULLIFY(id%POSINRHSCOMP_COL)
375 id%POSINRHSCOMP_COL_ALLOC = .false.
376 ENDIF
377C --------------------------------------------
378C If analysis redone, suppress old,
379C meaningless, Step2node array.
380C This is necessary since we could otherwise
381C end up having a wrong Step2node during solve
382C --------------------------------------------
383 IF (associated(id%Step2node)) THEN
384 DEALLOCATE(id%Step2node)
385 NULLIFY(id%Step2node)
386 ENDIF
387 IF (associated(id%IPOOL_B_L0_OMP)) THEN
388 DEALLOCATE(id%IPOOL_B_L0_OMP)
389 NULLIFY(id%IPOOL_B_L0_OMP)
390 ENDIF
391 IF (associated(id%IPOOL_A_L0_OMP)) THEN
392 DEALLOCATE(id%IPOOL_A_L0_OMP)
393 NULLIFY(id%IPOOL_A_L0_OMP)
394 ENDIF
395 IF (associated(id%PHYS_L0_OMP)) THEN
396 DEALLOCATE(id%PHYS_L0_OMP)
397 NULLIFY(id%PHYS_L0_OMP)
398 ENDIF
399 IF (associated(id%VIRT_L0_OMP)) THEN
400 DEALLOCATE(id%VIRT_L0_OMP)
401 NULLIFY(id%VIRT_L0_OMP)
402 ENDIF
403 IF (associated(id%VIRT_L0_OMP_MAPPING)) THEN
404 DEALLOCATE(id%VIRT_L0_OMP_MAPPING)
405 NULLIFY(id%VIRT_L0_OMP_MAPPING)
406 ENDIF
407 IF (associated(id%PERM_L0_OMP)) THEN
408 DEALLOCATE(id%PERM_L0_OMP)
409 NULLIFY(id%PERM_L0_OMP)
410 ENDIF
411 IF (associated(id%PTR_LEAFS_L0_OMP)) THEN
412 DEALLOCATE(id%PTR_LEAFS_L0_OMP )
413 NULLIFY(id%PTR_LEAFS_L0_OMP)
414 ENDIF
415 IF (associated(id%I4_L0_OMP)) THEN
416 DEALLOCATE(id%I4_L0_OMP)
417 NULLIFY(id%I4_L0_OMP)
418 ENDIF
419 IF (associated(id%I8_L0_OMP)) THEN
420 DEALLOCATE(id%I8_L0_OMP)
421 NULLIFY(id%I8_L0_OMP)
422 ENDIF
423 IF (.NOT.i_am_slave) THEN
424 ALLOCATE(id%I4_L0_OMP(1,1), id%I8_L0_OMP(1,1), stat=allocok)
425 IF (allocok.gt.0) THEN
426 info(1)= -7
427 info(2)= 2
428 ENDIF
429 ENDIF
430 IF (associated(id%L0_OMP_MAPPING)) THEN
431 DEALLOCATE(id%L0_OMP_MAPPING)
432 NULLIFY(id%L0_OMP_MAPPING)
433 ENDIF
434 IF (associated(id%L0_OMP_FACTORS)) THEN
435 CALL smumps_free_l0_omp_factors(id%L0_OMP_FACTORS)
436 END IF
437C END CASE OF ALLOCATED DATA FROM PREVIOUS CALLS
438C
439C Decode API (ICNTL parameters, mainly)
440C and check consistency of the KEEP array.
441C Note: SMUMPS_ANA_CHECK_KEEP also sets
442C some INFOG parameters
443 CALL smumps_ana_check_keep(id, i_am_slave)
444 CALL mumps_propinfo( icntl(1), info(1),
445 & id%COMM, id%MYID )
446 IF ( info(1) .LT. 0 ) GOTO 500
447C -------------------------------------------
448C Broadcast KEEP(60) since we need to broadcast
449C related information
450C ------------------------------------------
451 CALL mpi_bcast( keep(60), 1, mpi_integer, master, id%COMM, ierr )
452C broadcast also size of schur
453 IF (id%KEEP(60) .NE. 0 ) THEN
454 CALL mpi_bcast( keep(116), 1, mpi_integer, master,
455 & id%COMM, ierr )
456 ENDIF
457 IF (id%KEEP(60) .EQ. 2 .or. id%KEEP(60). eq. 3) THEN
458 CALL mpi_bcast( id%NPROW, 1,
459 & mpi_integer, master, id%COMM, ierr )
460 CALL mpi_bcast( id%NPCOL, 1,
461 & mpi_integer, master, id%COMM, ierr )
462 CALL mpi_bcast( id%MBLOCK, 1,
463 & mpi_integer, master, id%COMM, ierr )
464 CALL mpi_bcast( id%NBLOCK, 1,
465 & mpi_integer, master, id%COMM, ierr )
466C Note that SMUMPS_INIT_ROOT_ANA will
467C then use that information.
468 ENDIF
469C ----------------------------------------------
470C Broadcast KEEP(54) now to know if the
471C structure of the graph is intially distributed
472C and should be assembled on the master
473C Broadcast KEEP(55) now to know if the
474C matrix is in assembled or elemental format
475C ----------------------------------------------
476 CALL mpi_bcast( keep(54), 2, mpi_integer, master, id%COMM, ierr )
477C ----------------------------------------------
478C Broadcast KEEP(69) now to know if
479C we will need to communicate during analysis
480C ----------------------------------------------
481 CALL mpi_bcast( keep(69), 1, mpi_integer, master, id%COMM, ierr )
482C ----------------------------------------------
483C Broadcast Out of core strategy (used only on master so far)
484C ----------------------------------------------
485 CALL mpi_bcast( keep(201), 1, mpi_integer, master, id%COMM, ierr )
486C ----------------------------------------------
487C Broadcast analysis strategy (used only on master so far)
488C ----------------------------------------------
489 CALL mpi_bcast( keep(244), 1, mpi_integer, master, id%COMM, ierr )
490C ---------------------------
491C Fwd in facto
492C Broadcast KEEP(251,252,253) defined on master so far
493 CALL mpi_bcast( keep(251), 3, mpi_integer,master,id%COMM,ierr)
494C
495 CALL mpi_bcast( keep(400), 1, mpi_integer,master,id%COMM,ierr)
496 CALL mpi_bcast( id%KEEP(490), 5, mpi_integer, master,
497 & id%COMM, ierr )
498C ----------------------------------------------
499C Broadcast N
500C ----------------------------------------------
501 CALL mpi_bcast( id%N, 1, mpi_integer, master, id%COMM, ierr )
502C ----------------------------------------------
503C Broadcast NZ for assembled entry
504C ----------------------------------------------
505 IF ( keep(55) .EQ. 0) THEN
506 IF ( keep(54) .eq. 3 ) THEN
507C Compute total number of non-zeros
508 CALL mpi_allreduce( id%KEEP8(29), id%KEEP8(28), 1,
509 & mpi_integer8,
510 & mpi_sum, id%COMM, ierr )
511 ELSE
512C Broadcast NZ from the master node
513 CALL mpi_bcast( id%KEEP8(28), 1, mpi_integer8, master,
514 & id%COMM, ierr )
515 END IF
516 ELSE
517C Broadcast NA_ELT <=> KEEP8(30) for elemental entry
518 CALL mpi_bcast( id%KEEP8(30), 1, mpi_integer8, master,
519 & id%COMM, ierr )
520 ENDIF
521 IF( id%KEEP(54).EQ.3) THEN
522C test IRN_loc and JCN_loc allocated on working procs
523 IF (i_am_slave .AND. id%KEEP8(29).GT.0 .AND.
524 & ( (.NOT. associated(id%IRN_loc)) .OR.
525 & (.NOT. associated(id%JCN_loc)) )
526 & ) THEN
527 id%INFO(1) = -22
528 id%INFO(2) = 16
529 ENDIF
530 ENDIF
531 IF ( associated(id%MEM_DIST) ) THEN
532 DEALLOCATE( id%MEM_DIST )
533 ENDIF
534 allocate( id%MEM_DIST( 0:id%NSLAVES-1 ), stat=ierr )
535 IF ( ierr .GT. 0 ) THEN
536 info(1) = -7
537 info(2) = id%NSLAVES
538 IF ( lpok ) THEN
539 WRITE(lp, 150) 'MEM_DIST'
540 END IF
541 END IF
542 CALL mumps_propinfo( icntl(1), info(1),
543 & id%COMM, id%MYID )
544 IF ( info(1) .LT. 0 ) GOTO 500
545 id%MEM_DIST(0:id%NSLAVES-1) = 0
546 CALL mumps_init_arch_parameters(
547 & id%COMM,id%COMM_NODES,keep(69),keep(46),
548 & id%NSLAVES,id%MEM_DIST,info)
549C ========================
550C Write problem to a file,
551C if requested by the user
552C ========================
553 CALL smumps_dump_problem(id)
554 IF ( id%INFO(1) .LT. 0 ) GOTO 500
555C =================
556C ANALYSIS BY BLOCK
557C =================
558 IF ( id%MYID .EQ. master ) THEN
559 IF (keep(13).NE.0) THEN
560C Analysis by block with block data provided by user
561C
562C Check if block structure is centralized or distributed
563 IF (.NOT.associated(id%BLKVAR)) THEN
564C BLKVAR is identity and implicitly centralized
565 keep(14) = 0
566 ELSE
567 IF (size(id%BLKVAR).EQ.id%N) THEN
568C Centralized block stucture
569 keep(14) = 0
570 ELSE
571C Distributed block stucture
572 keep(14) = 1
573 IF ( lpok ) THEN
574 WRITE(lp,'(A,A,I8)')
575 & " ERROR with centralized matrix. Size of id%BLKVAR ",
576 & "should be equal to id%N instead of ",
577 & size(id%BLKVAR)
578 ENDIF
579 id%INFO(1) = -57
580 id%INFO(2) = 3
581 ENDIF
582 ENDIF
583 IF (keep(13).GE.1) THEN
584C BLKPTR provided by user
585C check input data
586 IF ( .NOT.associated(id%BLKPTR)) THEN
587 IF ( lpok ) THEN
588 WRITE(lp,'(A,I8)')
589 & " id%BLKPTR should be provided by user on host "
590 ENDIF
591 id%INFO(1) = -57
592 id%INFO(2) = 2
593 ENDIF
594 IF ( (id%NBLK.LE.0).OR.(id%NBLK.GT.id%N)
595 & .OR. (id%NBLK+1.NE.size(id%BLKPTR))
596 & ) THEN
597 IF ( lpok ) THEN
598 WRITE(lp,'(A,I8)')
599 & " ERROR incorrect value of id%NBLK:", id%NBLK
600 ENDIF
601 id%INFO(1) = -57
602 id%INFO(2) = 1
603 ENDIF
604 nblk=id%NBLK
605 IF (id%BLKPTR(id%NBLK+1)-1.NE.id%N) THEN
606 IF ( lpok ) THEN
607 WRITE(lp,'(A,A,I8)')
608 & " ERROR id%BLKPTR(id%NBLK+1)-1 ",
609 & "should be equal to id%N instead of ",
610 & id%BLKPTR(id%NBLK+1)-1
611 ENDIF
612 id%INFO(1) = -57
613 id%INFO(2) = 2
614 ENDIF
615 IF (id%BLKPTR(1).NE.1) THEN
616 IF ( lpok ) THEN
617 WRITE(lp,'(A,A,I8)')
618 & " ERROR id%BLKPTR(1)",
619 & "should be equal to 1 instead of ",
620 & id%BLKPTR(1)
621 ENDIF
622 id%INFO(1) = -57
623 id%INFO(2) = 2
624 ENDIF
625 ELSE IF (keep(13).LT.0) THEN
626C regular blocks in BLKVAR of size -KEEP(13)
627C mod(id%N,-KEEP(13)) has already been checked
628 nblk = id%N/(-keep(13))
629 ENDIF
630C end of KEEP(13).NE.0
631 ENDIF
632C end of id%MYID .EQ. MASTER
633 ENDIF
634 CALL mumps_propinfo( id%ICNTL(1), id%INFO(1),
635 & id%COMM, id%MYID )
636 IF ( id%INFO(1) .LT. 0 ) GOTO 500
637C
638C Broadcast KEEP(13-14), NBLK
639 CALL mpi_bcast( keep(13), 2, mpi_integer, master, id%COMM, ierr )
640 CALL mpi_bcast( nblk, 1, mpi_integer, master, id%COMM, ierr )
641C
642C ===========================
643 IF (keep(13).NE.0) THEN
644C { BEGIN preparation ANA_BLK
645C ===========================
646 IF ( ( (keep(54).NE.3).AND.(id%MYID.EQ.master) )
647 & .OR. (keep(54).EQ.3) ) THEN
648C ----------------------------------------
649C Allocate SIZEOFBLOCKS, DOF2BLOCK
650C ----------------------------------------
651 IF (allocated(sizeofblocks)) DEALLOCATE(sizeofblocks)
652 IF (allocated(dof2block)) DEALLOCATE(dof2block)
653 allocate(sizeofblocks(nblk), dof2block(id%N),
654 & stat=allocok)
655C
656 IF (allocok.NE.0) THEN
657 id%INFO( 1 ) = -7
658 id%INFO( 2 ) = id%N+nblk
659 IF ( lpok ) WRITE(lp, 150) ' SIZEOFBLOCKS, DOF2BLOCK'
660 ENDIF
661C
662 IF (id%MYID.EQ.master.AND.allocok.EQ.0) THEN
663C BLKPTR and BLKVAR needed for SMUMPS_EXPAND_TREE
664C allocate then if not associated
665 IF (.NOT.associated(id%BLKPTR)) THEN
666 blkptr_allocated = .true.
667 allocate(id%BLKPTR(nblk+1), stat=allocok)
668 IF (allocok.NE.0) THEN
669 blkptr_allocated = .true.
670 id%INFO( 1 ) = -7
671 id%INFO( 2 ) = nblk+1
672 IF ( lpok ) WRITE(lp, 150) ' id%BLKPTR '
673 ENDIF
674 ENDIF
675 IF (.NOT.associated(id%BLKVAR).AND.allocok.EQ.0) THEN
676 allocate(id%BLKVAR(id%N), stat=allocok)
677 blkvar_allocated = .true.
678 IF (allocok.NE.0) THEN
679 blkvar_allocated = .false.
680 id%INFO( 1 ) = -7
681 id%INFO( 2 ) = id%N
682 IF ( lpok ) WRITE(lp, 150) ' id%BLKVAR '
683 ENDIF
684 ENDIF
685 ENDIF
686 ENDIF
687 CALL mumps_propinfo( icntl(1), info(1),
688 & id%COMM, id%MYID )
689 IF (info(1).LT.0) GOTO 500
690 IF ( id%MYID .EQ. master ) THEN
691C -----------------------------------------
692C Compute SIZEOFBLOCKS, DOF2BLOCK on MASTER
693C based on id%BLKPTR and id%BLKVAR
694C and compute id%BLKPTR and id%BLKVAR if not
695C provided by user
696C -----------------------------------------
697 IF (blkvar_allocated) THEN
698C implicitly id%BLKVAR(I)=I
699 DO i=1, id%N
700 id%BLKVAR(i)=i
701 ENDDO
702 ENDIF
703 IF (blkptr_allocated) THEN
704 ib=0
705 blksize=-keep(13)
706 DO i=1, id%N, blksize
707 ib=ib+1
708 id%BLKPTR(ib) = i
709 ENDDO
710 id%BLKPTR(nblk+1) = id%N+1
711 ENDIF
712C
713 CALL mumps_ab_compute_sizeofblock (
714 & nblk, id%N, id%BLKPTR(1), id%BLKVAR(1),
715 & sizeofblocks, dof2block)
716 ENDIF
717C =======================
718 IF (keep(54).NE.3) THEN
719C =======================
720C{
721C ---------------------
722C Matrix structure available on host
723C ---------------------
724 keep(14) = 0
725 IF (id%MYID.EQ.master) THEN
726C Store input matrix (IRN/JCN) as a cleaned blocked Lmatrix
727C of nodes (indices \in [1,NBLK])
728 IF (id%KEEP8(28) .EQ. 0_8) THEN
729 irn_ptr => idummy_array
730 jcn_ptr => idummy_array
731 ELSE
732 irn_ptr => id%IRN
733 jcn_ptr => id%JCN
734 ENDIF
735 CALL mumps_ab_coord_to_lmat ( id%MYID,
736 & nblk, id%N, id%KEEP8(28), irn_ptr(1), jcn_ptr(1),
737 & dof2block,
738 & info(1), info(2), lp, lpok,
739 & lmat_block )
740 ENDIF
741 CALL mumps_propinfo( icntl(1), info(1),
742 & id%COMM, id%MYID )
743 IF ( info(1) .LT. 0 ) GOTO 500
744C
745 IF (id%MYID.EQ.master) THEN
746C From LMAT_BLOCK build GCOMP format wich requires
747C symmetrizing the Lmatrix
748 CALL mumps_ab_lmat_to_clean_g ( id%MYID, .true.,
749 & .true., ! not relevant because unfold is true
750 & lmat_block, gcomp,
751 & info(1), icntl(1))
752 gcomp_provided = .true.
753 IF (keep(494).EQ.0) THEN
754 CALL mumps_ab_free_lmat(lmat_block)
755 ENDIF
756 ENDIF
757 CALL mumps_propinfo( icntl(1), info(1),
758 & id%COMM, id%MYID )
759 IF ( info(1) .LT. 0 ) GOTO 500
760C}
761C ====
762 ELSE
763C ====
764C{
765C -------------------------------
766C Matrix structure is distributed
767C -------------------------------
768C
769 IF (.NOT. i_am_slave .OR. ! non-working master
770 & id%KEEP8(29) .EQ. 0_8) THEN ! NNZ_loc or NZ_loc
771C Master non-working
772 irn_loc_ptr => idummy_array
773 jcn_loc_ptr => idummy_array
774 id%KEEP8(29) = 0_8
775 ELSE
776 irn_loc_ptr => id%IRN_loc
777 jcn_loc_ptr => id%JCN_loc
778 ENDIF
779C
780C Given distributed matrix IRN_loc_PTR, JCN_loc_PTR
781C build distributed cleaned graph GCOMP and
782C save distributed LUMAT in case of grouping
783C
784 IF (id%NPROCS.EQ.1) THEN
785C Build GCOMP, the centralized final cleaned graph
786 ready_for_ana_f = .true.
787 CALL mumps_ab_dcoord_to_dcompg (
788 & id%MYID, id%NPROCS, id%COMM,
789 & nblk, id%N,
790 & id%KEEP8(29), ! => NNZ_loc or NZ_loc
791 & irn_loc_ptr(1), jcn_loc_ptr(1),
792 & dof2block(1),
793 & id%ICNTL(1), id%INFO(1), id%KEEP(1),
794 & lumat, gcomp, ready_for_ana_f)
795 gcomp_provided = .true.
796 ELSE
797 ready_for_ana_f = .false.
798 CALL mumps_ab_dcoord_to_dcompg (
799 & id%MYID, id%NPROCS, id%COMM,
800 & nblk, id%N,
801 & id%KEEP8(29), ! => NNZ_loc or NZ_loc
802 & irn_loc_ptr(1), jcn_loc_ptr(1),
803 & dof2block(1),
804 & id%ICNTL(1), id%INFO(1), id%KEEP(1),
805 & lumat, gcomp_dist, ready_for_ana_f)
806 ENDIF
807C
808C
809 CALL mumps_propinfo( icntl(1), info(1),
810 & id%COMM, id%MYID )
811 IF ( info(1) .LT. 0 ) GOTO 500
812C}
813C =====
814 ENDIF
815C =====
816 IF (allocated(dof2block)) THEN
817C DOF2BLOCK reused on master if pivot order given by user
818 IF ( (id%MYID.EQ.master).AND. (keep(256) .NE. 1)) THEN
819 DEALLOCATE(dof2block)
820 ENDIF
821 ENDIF
822C ========================
823 ENDIF
824C } END preparation ANA_BLK
825C =========================
826C ====================================================
827C TEST FOR SEQUENTIAL OR PARALLEL ANALYSIS (KEEP(244))
828C ====================================================
829 IF ( (keep(244).EQ.1) .AND. (keep(54) .eq. 3) ) THEN
830C -----------------------------------------------
831C Sequential analysis:
832C Collect on the host -- if matrix is distributed
833C at analysis -- all integer information needed
834C to perform ordering
835C -----------------------------------------------
836 IF (keep(13).NE.0) THEN
837 IF (id%NPROCS.NE.1) THEN
838 CALL mumps_ab_gather_graph(
839 & id%ICNTL(1), keep(1), id%COMM, id%MYID, id%NPROCS,
840 & id%INFO(1),
841 & gcomp_dist, gcomp)
842 gcomp_provided = .true.
843C
844 CALL mumps_ab_free_gcomp(gcomp_dist)
845 ENDIF
846 ELSE
847 CALL smumps_gather_matrix(id)
848 gather_matrix_allocated = .true.
849 CALL mumps_propinfo( icntl(1), info(1),
850 & id%COMM, id%MYID )
851 ENDIF
852 IF ( info(1) .LT. 0 ) GOTO 500
853 ENDIF
854 1234 CONTINUE
855 IF (keep(244) .EQ. 1) THEN
856C Sequential analysis : Schur
857 IF ( id%MYID .eq. master ) THEN
858C Prepare arguments for call to SMUMPS_ANA_F and
859C SMUMPS_ANA_F_ELT in case id%SCHUR was not allocated
860C by user. The objective is to avoid passing a null
861C pointer.
862C FIXME Block fomat for Schur
863 IF ( .NOT. associated( id%LISTVAR_SCHUR ) ) THEN
864 size_schur_passed = 1
865 listvar_schur_2be_freed=.true.
866 allocate( id%LISTVAR_SCHUR( 1 ), stat=allocok )
867 IF ( allocok .GT. 0 ) THEN
868 WRITE(*,*)
869 & 'PB allocating an array of size 1 for Schur!! '
870 info(1)=-7
871 info(2)=1
872 END IF
873 ELSE
874 size_schur_passed=id%SIZE_SCHUR
875 listvar_schur_2be_freed = .false.
876 END IF
877 ENDIF
878 CALL mumps_propinfo( icntl(1), info(1),
879 & id%COMM, id%MYID )
880 IF ( info(1) < 0 ) GOTO 500
881 ENDIF
882C
883 IF ((id%MYID.EQ.master).AND.(keep(244) .EQ. 1)
884 & .AND. (id%N.EQ.nblk)
885 & ) THEN
886C Sequential analysis : maximum transversal on master
887 IF ((keep(50).NE.1).AND.
888 & .NOT.((keep(23).EQ.7).AND.keep(50).EQ.0)
889 & ) THEN
890C (KEEP(23).EQ.7).AND.KEEP(50).EQ.0) :
891C For unsymmetric matrix, if automatic setting is requested
892C default setting of Maximum Transversal is decided during
893C SMUMPS_ANA_F and is based on matrix unsymmetry.
894C Thus in this case we skip SMUMPS_ANA_O
895 IF ( ( keep(23) .NE. 0 ) .OR.
896C Automatic choice for scaling does not force Maxtrans
897C Only when scaling is explicitly asked during analysis
898C (KEEP(52)=-2) SMUMPS_ANA_O is called
899 & keep(52) .EQ. -2 ) THEN
900C
901C Maximum Trans. algorithm called on original matrix.
902C We compute a permutation of the original matrix to
903C have a zero free diagonal
904C KEEP(23)=7 means that automatic choice
905C of max trans value will be done during analysis
906C Permutation is held in UNS_PERM(1, ...,N).
907C Maximum transversal is not available for element
908C entry format
909C UNS_PERM that might be set to
910C to permutation computed during Max transversal
911 ALLOCATE(id%UNS_PERM(id%N),ikeepalloc(3*id%N),
912 & work2alloc(id%N), stat=ierr)
913 IF (ierr.GT.0) THEN
914 info(1)=-7
915 info(2)=5*id%N
916 ELSE
917 CALL smumps_ana_o(id%N, id%KEEP8(28), keep(23),
918 & id%UNS_PERM, ikeepalloc, id%IRN, id%JCN, id%A,
919 & id%ROWSCA, id%COLSCA,
920 & work2alloc, id%KEEP, id%ICNTL, id%INFO, id%INFOG)
921 IF (allocated(work2alloc)) DEALLOCATE(work2alloc)
922 IF (keep(23).EQ.0) THEN
923C Maximum tranversal did not produce a permutation
924 IF (associated( id%UNS_PERM ))
925 & DEALLOCATE(id%UNS_PERM)
926 NULLIFY(id%UNS_PERM)
927 ENDIF
928C Check if IKEEPALLOC needed for ANA_F
929 IF (keep(23).EQ.0.AND.(keep(95).EQ.1)) THEN
930 IF (allocated(ikeepalloc)) DEALLOCATE(ikeepalloc)
931 ENDIF
932 ENDIF
933 IF (info(1) .LT. 0) THEN
934C Fatal error
935C Permutation was not computed; reset keep(23)
936 keep(23) = 0
937 ELSE
938 ENDIF
939 ELSE
940 keep(23) = 0
941C Switch off
942C compressed/contrained ordering
943 id%KEEP(95) = 1
944 END IF
945 ENDIF
946C END OF MAX-TRANS ON THE MASTER
947 ENDIF
948 CALL mumps_propinfo( icntl(1), info(1), id%COMM, id%MYID )
949 IF ( info(1) < 0 ) GOTO 500
950C
951 IF ( keep(244) .EQ. 1) THEN
952C Sequential analysis: allocate data for ordering on MASTER
953 IF (id%MYID.EQ.master) THEN
954C allocate IKEEPALLOC and TREE related pointers
955C IKEEPALLOC might have been allocated in SMUMPS_ANA_O
956C and IKEEPALLOC(1:N) might hold information to
957C be given to ANA_F.
958 IF (allocated(ikeepalloc)) THEN
959 ALLOCATE( filsptr(nblk), frereptr(nblk),
960 & nfsizptr(nblk), stat=ierr)
961 IF (ierr.GT.0) THEN
962 info(1)=-7
963 info(2)=3*nblk
964 ENDIF
965 ELSE
966 ALLOCATE(ikeepalloc(nblk+2*id%N),
967 & filsptr(nblk), frereptr(nblk),
968 & nfsizptr(nblk), stat=ierr)
969 IF (ierr.GT.0) THEN
970 info(1)=-7
971 info(2)=4*nblk+2*id%N
972 ENDIF
973 ENDIF
974 ENDIF
975 CALL mumps_propinfo( icntl(1), info(1), id%COMM, id%MYID )
976 IF ( info(1) < 0 ) GOTO 500
977 ENDIF
978C
979 IF (keep(244) .EQ. 1) THEN
980C Sequential analysis
981 IF ( id%MYID .eq. master ) THEN
982C BEGINNING OF ANALYSIS ON THE MASTER
983C ------------------------------------------------------
984C For element entry (KEEP(55).ne.0), we do not know NZ,
985C and so the whole allocation of IW cannot be done at this
986C point and more workspace is declared/allocated/used
987C inside SMUMPS_ANA_F_ELT.
988C ------------------------------------------------------
989C
990 IF (keep(55) .EQ. 0) THEN
991C ----------------
992C Assembled format
993C ----------------
994 nz8=id%KEEP8(28)
995C Compute LIW8:
996C For local orderings a contiguous space IW
997C of size LIW8 must be provided.
998C IW must hold the graph (with double adjacency
999C list) and and extra space of size the number of
1000C nodes in the graph:
1001C ==> LIW8 = 2_8 * NZ8 + int(NBLK,8) + 1_8
1002C In case of analysis by block and
1003C However, when GCOMP is provided directly then
1004C IW is not allocated
1005C ==> LIW8 = 0
1006C In this case
1007C size(LCOMP%ADJ)>= 2_8*NZ8+int(NBLK,8)+1_8
1008C should hold
1009 IF (keep(13).NE.0) THEN
1010C Compact graph is provided on entry to SMUMPS_ANA_F
1011 nz8=0_8 ! GCOMP is provided on entry
1012 ENDIF
1013 IF (nz8.EQ.0_8) THEN
1014 liw8 = 0_8
1015 ELSE
1016 liw8 = 2_8 * nz8 + int(nblk,8) + 1_8
1017 ENDIF
1018C
1019 ELSE
1020C ----------------
1021C Elemental format
1022C ----------------
1023C Only available for AMD, METIS, and given ordering
1024#if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3)
1025 cond = (keep(60) .NE. 0) .OR. (keep(256) .EQ. 5)
1026#else
1027 cond = (keep(60) .NE. 0)
1028#endif
1029 IF( cond ) THEN
1030C
1031C
1032C we suppress supervariable detection when Schur
1033C is active or when METIS is applied
1034C Workspaces for FLAG(N), and either LEN(N) or some pointers(N+1)
1035 liw_elt = id%N + id%N + 1
1036 ELSE
1037C Spaces FLAG(N), LEN(N), N+3, SVAR(0:N),
1038 liw_elt = id%N + id%N + id%N + 3 + id%N + 1
1039 ENDIF
1040C
1041 ENDIF
1042C We must ensure that an array of order
1043C 3*N is available for SMUMPS_ANA_LNEW
1044 IF (keep(55) .EQ. 0) THEN
1045 IF (liw8.LT.3_8*int(nblk,8)) liw8 = 3_8*int(nblk,8)
1046 ELSE
1047 IF (liw_elt.LT.3*id%N) liw_elt = 3*id%N
1048 ENDIF
1049C
1050 IF ( keep(256) .EQ. 1 ) THEN
1051C It has been checked that id%PERM_IN is associated but
1052C values of pivot order will be checked later and
1053C should be checked here too
1054C PERM_IN( I ) = position of I in the pivot order
1055 ikeep2 => ikeepalloc(nblk+1:nblk+id%N)
1056C Build inverse permutation and check PERM_IN
1057 DO i = 1, id%N
1058 ikeep2(i) = 0
1059 ENDDO
1060 DO i = 1, id%N
1061 IF ( id%PERM_IN(i) .LT.1 .OR.
1062 & id%PERM_IN(i) .GT. id%N ) THEN
1063C PERM_IN entry is out-of-range
1064 info(1) = -4
1065 info(2) = i
1066 GOTO 10
1067 ELSE IF ( ikeep2(id%PERM_IN(i)) .NE. 0 ) THEN
1068C Duplicate entry in PERM_IN was found
1069 info(1) = -4
1070 info(2) = i
1071 GOTO 10
1072 ELSE
1073C Store entry in inverse permutation
1074 ikeep2(id%PERM_IN( i )) = i
1075 ENDIF
1076 ENDDO
1077 IF ((keep(55) .EQ. 0).AND.(keep(13).NE.0)
1078 & .AND.(keep(13).NE.-1)
1079 & ) THEN
1080C Build blocked permutation:
1081C IKEEPALLOC(IB)= IBPos where IB, IBPos \in [1:NBLK]
1082C IKEEP2 holds inverse permutation
1083 iposb = 0
1084 ipos = 1
1085 DO WHILE (ipos.LE.id%N)
1086 iposb = iposb+1
1087 i = ikeep2(ipos)
1088 ibcurrent = dof2block(i)
1089 blksize = sizeofblocks(ibcurrent)
1090 ikeepalloc(ibcurrent) = iposb
1091 IF (blksize.GT.1) THEN
1092 DO ii = 1, blksize-1
1093 ipos = ipos+1
1094 i = ikeep2(ipos)
1095 ib = dof2block(i)
1096 IF (ib.NE.ibcurrent) THEN
1097 info(1)= -4
1098 info(2)= i
1099 GOTO 10
1100 ENDIF
1101 ENDDO
1102 ENDIF
1103 ipos = ipos+1
1104 ENDDO
1105C IF PERM_IN is correct then
1106C on exit last position should be NBLK
1107 IF (iposb.NE.nblk) THEN
1108 info(1)= -4
1109C N+1 to indicate "global" error
1110 info(2)= id%N+1
1111 GOTO 10
1112 ENDIF
1113 ELSE
1114 DO i = 1, id%N
1115 ikeepalloc( i ) = id%PERM_IN( i )
1116 END DO
1117 ENDIF
1118 IF (allocated(dof2block)) DEALLOCATE(dof2block)
1119 END IF
1120 infog(1) = 0
1121 infog(2) = 0
1122C Initialize structural symmetry value to not yet computed.
1123 infog(8) = -1
1124 IF (keep(55) .EQ. 0) THEN
1125 ikeep1 => ikeepalloc(1:nblk)
1126 ikeep2 => ikeepalloc(nblk+1:nblk+id%N)
1127 ikeep3 => ikeepalloc(nblk+id%N+1:nblk+2*id%N)
1128C id%UNS_PERM corresponds to argument PIV
1129C in SMUMPS_ANA_F, it should be an assumed-shape
1130C array rather than a possibly null pointer:
1131 IF (associated(id%UNS_PERM)) THEN
1132 uns_perm_ptr => id%UNS_PERM
1133 ELSE
1134 uns_perm_ptr => idummy_array
1135 ENDIF
1136 IF (keep(13).EQ.0) THEN
1137 CALL smumps_ana_f(id%N, nz8,
1138 & id%IRN, id%JCN,
1139 & liw8, ikeep1, ikeep2, ikeep3,
1140 & keep(256), nfsizptr,
1141 & filsptr, frereptr,
1142 & id%LISTVAR_SCHUR, size_schur_passed,
1143 & id%ICNTL, id%INFOG, id%KEEP,id%KEEP8,id%NSLAVES,
1144 & uns_perm_ptr,
1145 & id%CNTL(4), id%COLSCA, id%ROWSCA
1146#if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3)
1147 & , id%METIS_OPTIONS(1)
1148#endif
1149 & )
1150 ELSE
1151 irn_loc_ptr => idummy_array
1152 jcn_loc_ptr => idummy_array
1153 CALL smumps_ana_f(nblk, nz8,
1154 & irn_loc_ptr, jcn_loc_ptr,
1155 & liw8, ikeep1, ikeep2, ikeep3,
1156 & keep(256), nfsizptr,
1157 & filsptr, frereptr,
1158 & id%LISTVAR_SCHUR, size_schur_passed,
1159 & id%ICNTL, id%INFOG, id%KEEP,id%KEEP8,id%NSLAVES,
1160 & uns_perm_ptr,
1161 & id%CNTL(4), id%COLSCA, id%ROWSCA
1162#if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3)
1163 & , id%METIS_OPTIONS(1)
1164#endif
1165 & , id%N, sizeofblocks, gcomp_provided, gcomp
1166 & )
1167 IF (gcomp_provided) CALL mumps_ab_free_gcomp(gcomp)
1168C
1169 ENDIF
1170 infog(7) = keep(256)
1171C UNS_PERM_PTR was only used locally
1172C for the call to SMUMPS_ANA_F
1173 NULLIFY(uns_perm_ptr)
1174 ELSE
1175 allocate( xnodel( id%N+1 ), stat = ierr )
1176 IF ( ierr .GT. 0 ) THEN
1177 info( 1 ) = -7
1178 info( 2 ) = id%N + 1
1179 IF ( lpok ) THEN
1180 WRITE(lp, 150) 'XNODEL'
1181 END IF
1182 GOTO 10
1183 ENDIF
1184 IF (leltvar.ne.id%ELTPTR(nelt+1)-1) THEN
1185C -- internal error
1186 info(1) = -2002
1187 info(2) = id%ELTPTR(nelt+1)-1
1188 GOTO 10
1189 ENDIF
1190 allocate( nodel( leltvar ), stat = ierr )
1191 IF ( ierr .GT. 0 ) THEN
1192 info( 1 ) = -7
1193 info( 2 ) = leltvar
1194 IF ( lpok ) THEN
1195 WRITE(lp, 150) 'NODEL'
1196 END IF
1197 GOTO 10
1198 ENDIF
1199 CALL smumps_ana_f_elt(id%N, nelt,
1200 & id%ELTPTR(1), id%ELTVAR(1), liw_elt,
1201 & ikeepalloc(1),
1202 & keep(256), nfsizptr(1), filsptr(1),
1203 & frereptr(1), id%LISTVAR_SCHUR(1),
1204 & size_schur_passed,
1205 & icntl(1), infog(1), keep(1),keep8(1),
1206 & id%NSLAVES,
1207 & xnodel(1), nodel(1)
1208#if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3)
1209 & , id%METIS_OPTIONS(1)
1210#endif
1211 & )
1212 infog(7)=keep(256)
1213C
1214C XNODEL and NODEL as output to SMUMPS_ANA_F_ELT
1215C be used in SMUMPS_FRTELT and thus
1216C cannot be deallocated at this point
1217C
1218 ENDIF
1219 IF ( listvar_schur_2be_freed ) THEN
1220C We do not want to have LISTVAR_SCHUR
1221C allocated of size 1 if Schur is off.
1222 DEALLOCATE( id%LISTVAR_SCHUR )
1223 NULLIFY ( id%LISTVAR_SCHUR )
1224 listvar_schur_2be_freed = .true.
1225 ENDIF
1226C ------------------------------
1227C Significant error codes should
1228C always be in INFO(1/2)
1229C ------------------------------
1230 info(1)=infog(1)
1231 info(2)=infog(2)
1232C save statistics in KEEP array.
1233 keep(28) = infog(6)
1234 ikeep = 1
1235 na = ikeep + id%N
1236 ne = ikeep + 2 * id%N
1237C -- if (id%myid.eq.master)
1238 ENDIF
1239C -- if sequential analysis
1240 ENDIF
1241C
1242 10 CONTINUE
1243 IF (keep(244).EQ.1) THEN
1244 CALL mumps_propinfo( icntl(1), info(1), id%COMM, id%MYID )
1245 IF ( info(1) < 0 ) GOTO 500
1246 ENDIF
1247 IF ((keep(244).EQ.1).AND.(keep(55).EQ.0)) THEN
1248C Sequential analysis on assembled matrix
1249C check if max transversal should be called
1250 CALL mpi_bcast(keep(23),1,mpi_integer,master,id%COMM,ierr)
1251 IF ( (keep(23).LE.-1).AND.(keep(23).GE.-6) ) THEN
1252C -- Perform max transversal
1253 keep(23) = -keep(23)
1254 IF (id%MYID.EQ.master) THEN
1255 IF (.NOT. associated(id%A)) keep(23) = 1
1256 IF (associated(id%UNS_PERM)) DEALLOCATE(id%UNS_PERM)
1257 NULLIFY(id%UNS_PERM)
1258 IF (allocated(ikeepalloc)) DEALLOCATE(ikeepalloc)
1259 IF (associated(filsptr) ) THEN
1260 DEALLOCATE(filsptr)
1261 NULLIFY(filsptr)
1262 ENDIF
1263 IF (associated(frereptr) ) THEN
1264 DEALLOCATE(frereptr)
1265 NULLIFY(frereptr)
1266 ENDIF
1267 IF (associated(nfsizptr) ) THEN
1268 DEALLOCATE(nfsizptr)
1269 NULLIFY(nfsizptr)
1270 ENDIF
1271 ENDIF
1272 GOTO 1234
1273 ENDIF
1274 ENDIF
1275 IF (id%MYID.EQ.master) THEN
1276 IF ((keep(244).EQ.1).AND. (keep(55).EQ.0)) THEN
1277C Sequential ordering on assembled matrix
1278 IF ((keep(54).EQ.3).AND.keep(494).EQ.0) THEN
1279 IF (gather_matrix_allocated) THEN
1280 IF (associated(id%IRN)) THEN
1281 DEALLOCATE(id%IRN)
1282 NULLIFY(id%IRN)
1283 ENDIF
1284 IF (associated(id%JCN)) THEN
1285 DEALLOCATE(id%JCN)
1286 NULLIFY(id%JCN)
1287 ENDIF
1288 gather_matrix_allocated= .false.
1289 ENDIF
1290 ENDIF
1291 ENDIF
1292 ENDIF
1293 IF (keep(244).NE.1) THEN
1294C Parallel analysis
1295 ikeep = 1
1296 na = ikeep + id%N
1297 ne = ikeep + 2 * id%N
1298 IF (id%MYID .EQ. master) THEN
1299 ALLOCATE( ikeepalloc(3*id%N), work2alloc(4*id%N),
1300 & filsptr(id%N), frereptr(id%N), nfsizptr(id%N),
1301 & stat=ierr)
1302 ELSE
1303C Because our purpose is to minimize the peak memory consumption,
1304C we can afford to allocate on processes other than host
1305 ALLOCATE(ikeepalloc(3*id%N),work2alloc(4*id%N), stat=ierr )
1306 ENDIF
1307 IF (ierr.GT.0) THEN
1308 info(1) = -7
1309 IF (id%MYID .EQ. master) THEN
1310 info( 2 ) = 10*id%N
1311 ELSE
1312 info( 2 ) = 7*id%N
1313 ENDIF
1314 ENDIF
1315 CALL mumps_propinfo( icntl(1), info(1), id%COMM, id%MYID )
1316 IF ( info(1) < 0 ) GOTO 500
1317 CALL smumps_ana_f_par(id,
1318 & ikeepalloc,
1319 & work2alloc,
1320 & nfsizptr,
1321 & filsptr,
1322 & frereptr)
1323 DEALLOCATE(work2alloc)
1324 IF(id%MYID .NE. master) THEN
1325 DEALLOCATE(ikeepalloc)
1326 ENDIF
1327 keep(28) = infog(6)
1328 END IF
1329C Allocated PROCNODE on MASTER
1330 IF (id%MYID.EQ.master) THEN
1331 allocok = 0
1332 allocate(procnode(nblk), stat=allocok)
1333 IF (allocok .ne. 0) THEN
1334 info(1) = -7
1335 info(2) = nblk
1336 ENDIF
1337 ENDIF
1338 CALL mumps_propinfo( icntl(1), info(1), id%COMM, id%MYID )
1339 IF ( info(1) < 0 ) GOTO 500
1340 IF(id%MYID .EQ. master) THEN
1341C Save ICNTL(14) value into KEEP(12)
1342 CALL mumps_get_perlu(keep(12),icntl(14),
1343 & keep(50),keep(54),icntl(6),keep(52))
1344 CALL smumps_ana_r(nblk, filsptr(1), frereptr(1),
1345 & ikeepalloc(ne), ikeepalloc(na))
1346C **********************************************************
1347C Continue with CALL to MAPPING routine
1348C *********************
1349C BEGIN SEQUENTIAL CODE
1350C No mapping computed
1351C *********************
1352C
1353C In sequential, if no special root
1354C reset KEEP(20) and KEEP(38) to 0
1355C
1356 IF (id%NSLAVES .EQ. 1
1357 & ) THEN
1358 id%NBSA = 0
1359 IF ( (id%KEEP(60).EQ.0).
1360 & and.(id%KEEP(53).EQ.0)) THEN
1361C If Schur is on (keep(60).ne.0)
1362C or if RR is on (keep (53) > 0
1363C then we keep root numbers
1364C root node number in seq
1365 id%KEEP(20)=0
1366C root node number in paral
1367 id%KEEP(38)=0
1368 ENDIF
1369C No type 2 nodes:
1370 id%KEEP(56)=0
1371C All mapped on MPI process 0, and of type TPN=0
1372C (treated as if they were all root of subtree)
1373 procnode_value = mumps_encode_tpn_iproc(0, 0, keep(199))
1374 DO i = 1, nblk
1375 procnode(i) = procnode_value
1376 END DO
1377C It may also happen that KEEP(38) has already been set,
1378C in the case of a distributed Schur complement (KEEP(60)=2 or 3).
1379C In that case, PROCNODE should be set accordingly and KEEP(38) is
1380C not modified.
1381 IF (id%KEEP(60) .EQ. 2 .OR. id%KEEP(60).EQ.3) THEN
1382 procnode_value = mumps_encode_tpn_iproc(3, 0, keep(199))
1383 CALL smumps_set_procnode(id%KEEP(38), procnode(1),
1384 & procnode_value, filsptr(1), nblk)
1385 ENDIF
1386C *******************
1387C END SEQUENTIAL CODE
1388C *******************
1389 ELSE
1390C *****************************
1391C BEGIN MAPPING WITH CANDIDATES
1392C (NSLAVES > 1)
1393C *****************************
1394C
1395C
1396C peak is set by default to 1 largest front + One largest CB
1397 peak = real(id%INFOG(5))*real(id%INFOG(5)) + ! front matrix
1398 & real(id%KEEP(2))*real(id%KEEP(2)) ! cb bloc
1399C IKEEP(1:N,1) can be used as a work space since it is set
1400C to its final state by the SORT_PERM subroutine below.
1401 ssarbr => ikeepalloc(ikeep:ikeep+nblk-1)
1402C ======================================================
1403C Map nodes and assign candidates for dynamic scheduling
1404C ======================================================
1405 IF ((keep(13).NE.0).AND.(nblk.NE.id%N)) THEN
1406 sizeofblocks_ptr => sizeofblocks(1:nblk)
1407 lsizeofblocks_ptr = nblk
1408 ELSE
1409 sizeofblocks_ptr => idummy_array
1410 lsizeofblocks_ptr = 1
1411 idummy_array(1) = -1
1412 ENDIF
1413 CALL smumps_dist_avoid_copies(
1414 & nblk,id%NSLAVES,icntl(1),
1415 & infog(1),
1416 & ikeepalloc(ne),
1417 & nfsizptr(1),
1418 & frereptr(1),
1419 & filsptr(1),
1420 & keep(1),keep8(1),procnode(1),
1421 & ssarbr(1),id%NBSA,peak,ierr
1422 & , sizeofblocks_ptr(1), lsizeofblocks_ptr
1423 & )
1424 NULLIFY(ssarbr)
1425 if(ierr.eq.-999) then
1426 write(6,*) ' Internal error during static mapping '
1427 info(1) = ierr
1428 GOTO 11
1429 ENDIF
1430 IF(ierr.NE.0) THEN
1431 info(1) = -135
1432 info(2) = ierr
1433 GOTO 11
1434 ENDIF
1435 CALL smumps_ana_r(nblk, filsptr(1),
1436 & frereptr(1), ikeepalloc(ne),
1437 & ikeepalloc(na))
1438 ENDIF
1439 11 CONTINUE
1440 ENDIF
1441 CALL mumps_propinfo( icntl(1), info(1), id%COMM, id%MYID )
1442 IF ( info(1) < 0 ) GOTO 500
1443C The following part is done in parallel
1444 CALL mpi_bcast( id%NELT, 1, mpi_integer, master,
1445 & id%COMM, ierr )
1446 IF (keep(55) .EQ. 0) THEN
1447C Assembled matrix format. Fill up the id%PTRAR array
1448C Broadcast id%SYM_PERM needed to fill up id%PTRAR
1449C postpone to after computation of id%SYM_PERM
1450C computed after id%DAD_STEPS
1451 if (associated(id%FRTPTR)) DEALLOCATE(id%FRTPTR)
1452 if (associated(id%FRTELT)) DEALLOCATE(id%FRTELT)
1453 allocate( id%FRTPTR(1), id%FRTELT(1) ,stat=allocok)
1454 IF (allocok .GT. 0) THEN
1455 IF ( lpok ) THEN
1456 WRITE(lp, 150) 'FRTPTR,FRTELT'
1457 END IF
1458 info(1)= -7
1459 info(2)= 2
1460 END IF
1461 ELSE
1462C Element Entry:
1463C -------------------------------
1464C COMPUTE THE LIST OF ELEMENTS THAT WILL BE ASSEMBLED
1465C AT EACH NODE OF THE ELIMINATION TREE. ALSO COMPUTE
1466C FOR EACH ELEMENT THE TREE NODE TO WHICH IT IS ASSIGNED.
1467C
1468C FRTPTR is an INTEGER array of length N+1 which need not be set by
1469C the user. On output, FRTPTR(I) points in FRTELT to first element
1470C in the list of elements assigned to node I in the elimination tree.
1471C
1472C FRTELT is an INTEGER array of length NELT which need not be set by
1473C the user. On output, positions FRTELT(FRTPTR(I)) to
1474C FRTELT(FRTPTR(I+1)-1) contain the list of elements assigned to
1475C node I in the elimination tree.
1476C
1477 lptrar = id%NELT+id%NELT+2
1478 CALL mumps_i8realloc(id%PTRAR, lptrar, id%INFO, lp,
1479 & force=.true., string='id%PTRAR (Analysis)', errcode=-7)
1480 CALL mumps_realloc(id%FRTPTR, id%N+1, id%INFO, lp,
1481 & force=.true., string='id%FRTPTR (Analysis)', errcode=-7)
1482 CALL mumps_realloc(id%FRTELT, id%NELT, id%INFO, lp,
1483 & force=.true., string='id%FRTELT (Analysis)', errcode=-7)
1484 CALL mumps_propinfo( icntl(1), info(1), id%COMM, id%MYID )
1485 IF ( info(1) < 0 ) GOTO 500
1486 IF(id%MYID .EQ. master) THEN
1487C In the elemental format case, PTRAR&friends are still
1488C computed sequentially and then broadcasted
1489 CALL smumps_frtelt(
1490 & id%N, nelt, id%ELTPTR(nelt+1)-1, frereptr(1),
1491 & filsptr(1),
1492 & ikeepalloc(na), ikeepalloc(ne), xnodel,
1493 & nodel, id%FRTPTR(1), id%FRTELT(1), id%ELTPROC(1))
1494 DO i=1, id%NELT+1
1495C PTRAR declared 64-bit
1496 id%PTRAR(id%NELT+i+1)=int(id%ELTPTR(i),8)
1497 ENDDO
1498 DEALLOCATE(xnodel)
1499 DEALLOCATE(nodel)
1500 END IF
1501 CALL mpi_bcast( id%PTRAR(id%NELT+2), id%NELT+1, mpi_integer8,
1502 & master, id%COMM, ierr )
1503 CALL mpi_bcast( id%FRTPTR(1), id%N+1, mpi_integer,
1504 & master, id%COMM, ierr )
1505 CALL mpi_bcast( id%FRTELT(1), id%NELT, mpi_integer,
1506 & master, id%COMM, ierr )
1507 ENDIF
1508 CALL mumps_propinfo( icntl(1), info(1), id%COMM, id%MYID )
1509 IF ( info(1) < 0 ) GOTO 500
1510C We switch again to sequential computations on the master node
1511 IF(id%MYID .EQ. master) THEN
1512 IF ( info( 1 ) .LT. 0 ) GOTO 12
1513 IF ( keep(55) .ne. 0 ) THEN
1514C ---------------------------------------
1515C Build ELTPROC: correspondance between elements and slave ranks
1516C in COMM_NODES with special values -1 (all procs) and -2 and -3
1517C (no procs). This is used later to distribute the elements on
1518C the processes at the beginning of the factorisation phase
1519C ---------------------------------------
1520 CALL smumps_eltproc(nblk, nelt, id%ELTPROC(1),id%NSLAVES,
1521 & procnode(1), id%KEEP(1))
1522 END IF
1523 nb_niv2 = keep(56)
1524 IF ( nb_niv2.GT.0 ) THEN
1525C
1526 allocate(par2_nodes(nb_niv2),
1527 & stat=allocok)
1528 IF (allocok .GT.0) then
1529 info(1)= -7
1530 info(2)= nb_niv2
1531 IF ( lpok ) THEN
1532 WRITE(lp, 150) 'PAR2_NODES'
1533 END IF
1534 GOTO 12
1535 END IF
1536 ENDIF
1537 IF ((nb_niv2.GT.0) .AND. (keep(24).EQ.0)) THEN
1538 iniv2 = 0
1539 DO 777 inode = 1, nblk
1540 IF ( ( frereptr(inode) .NE. nblk ) .AND.
1541 & ( mumps_typenode(procnode(inode),id%KEEP(199))
1542 & .eq. 2) ) THEN
1543 iniv2 = iniv2 + 1
1544 par2_nodes(iniv2) = inode
1545 END IF
1546 777 CONTINUE
1547 IF ( iniv2 .NE. nb_niv2 ) THEN
1548 WRITE(*,*) "Internal Error 2 in SMUMPS_ANA_DRIVER",
1549 & iniv2, nb_niv2
1550 CALL mumps_abort()
1551 ENDIF
1552 ENDIF
1553 IF ( (keep(24) .NE. 0) .AND. (nb_niv2.GT.0) ) THEN
1554C allocate array to store cadidates stategy
1555C for each level two nodes
1556 IF ( associated(id%CANDIDATES)) DEALLOCATE(id%CANDIDATES)
1557 allocate( id%CANDIDATES(id%NSLAVES+1,nb_niv2),
1558 & stat=allocok)
1559 if (allocok .gt.0) then
1560 info(1)= -7
1561 info(2)= nb_niv2*(id%NSLAVES+1)
1562 IF ( lpok ) THEN
1563 WRITE(lp, 150) 'CANDIDATES'
1564 END IF
1565 GOTO 12
1566 END IF
1567 CALL mumps_return_candidates
1568 & (par2_nodes,id%CANDIDATES,
1569 & ierr)
1570 IF(ierr.NE.0) THEN
1571 info(1) = -2002
1572 GOTO 12
1573 ENDIF
1574C deallocation of variables of module mumps_static_mapping
1575 CALL mumps_end_arch_cv()
1576 IF(ierr.NE.0) THEN
1577 info(1) = -2002
1578 GOTO 12
1579 ENDIF
1580 ELSE
1581 IF (associated(id%CANDIDATES)) DEALLOCATE(id%CANDIDATES)
1582 allocate(id%CANDIDATES(1,1), stat=allocok)
1583 IF (allocok .NE. 0) THEN
1584 info(1)= -7
1585 info(2)= 1
1586 IF ( lpok ) THEN
1587 WRITE(lp, 150) 'CANDIDATES'
1588 END IF
1589 GOTO 12
1590 ENDIF
1591 ENDIF
1592C*******************************************************************
1593C ---------------
1594 12 CONTINUE
1595C ---------------
1596*
1597* ===============================
1598* End of analysis phase on master
1599* ===============================
1600*
1601 END IF
1602 CALL mumps_propinfo( icntl(1), info(1), id%COMM, id%MYID )
1603 IF ( info(1) < 0 ) GOTO 500
1604C
1605C We now allocate and compute arrays in NSTEPS
1606C on the master, as this makes more sense.
1607C
1608C Broadcast KEEP8(101) to be used in MUMPS_ANA_L0_OMP
1609 CALL mpi_bcast( id%KEEP8(101), 1, mpi_integer8, master,
1610 & id%COMM, ierr )
1611C
1612C ==============================
1613C PREPARE DATA FOR FACTORIZATION
1614C ==============================
1615C ------------------
1616 CALL mpi_bcast( id%KEEP(1), 110, mpi_integer, master,
1617 & id%COMM, ierr )
1618C We also need to broadcast KEEP8(21)
1619 CALL mpi_bcast( id%KEEP8(21), 1, mpi_integer8, master,
1620 & id%COMM, ierr )
1621C --------------------------------------------------
1622C Broadcast KEEP(205) which is outside the first 110
1623C KEEP entries but is needed for factorization.
1624C --------------------------------------------------
1625 CALL mpi_bcast( id%KEEP(205), 1, mpi_integer, master,
1626 & id%COMM, ierr )
1627C --------------
1628C Broadcast NBSA
1629 CALL mpi_bcast( id%NBSA, 1, mpi_integer, master,
1630 & id%COMM, ierr )
1631C -----------------
1632C Global MAXFRT (computed in SMUMPS_ANA_M)
1633C is needed on all the procs during SMUMPS_ANA_DISTM
1634C to evaluate workspace for solve.
1635C We could also recompute it in SMUMPS_ANA_DISTM
1636 IF (id%MYID==master) keep(127)=infog(5)
1637 CALL mpi_bcast( id%KEEP(127), 1, mpi_integer, master,
1638 & id%COMM, ierr )
1639C -----------------
1640C Global max panel size KEEP(226)
1641 CALL mpi_bcast( id%KEEP(226), 1, mpi_integer, master,
1642 & id%COMM, ierr )
1643C -----------------
1644 CALL mpi_bcast( id%KEEP(464), 2, mpi_integer, master,
1645 & id%COMM, ierr )
1646 CALL mpi_bcast( id%KEEP(471), 2, mpi_integer, master,
1647 & id%COMM, ierr )
1648 CALL mpi_bcast( id%KEEP(475), 1, mpi_integer, master,
1649 & id%COMM, ierr )
1650 CALL mpi_bcast( id%KEEP(482), 1, mpi_integer, master,
1651 & id%COMM, ierr )
1652 CALL mpi_bcast( id%KEEP(487), 2, mpi_integer, master,
1653 & id%COMM, ierr )
1654C Number of leaves not belonging to L0 KEEP(262)
1655C and KEEP(263) : inner or outer sends for blocked facto
1656 CALL mpi_bcast( id%KEEP(262), 2, mpi_integer, master,
1657 & id%COMM, ierr )
1658C ----------------------------------------
1659C Allocate new workspace on all processors
1660C ----------------------------------------
1661 IF (id%MYID.EQ.master) THEN
1662C id%STEP is of size NBLK because it
1663C is computed on compressed graph and then extended
1664C and broadcasted on all procs
1665 CALL mumps_realloc(id%STEP, nblk, id%INFO, lp, force=.true.,
1666 & string='id%STEP (Analysis)', errcode=-7)
1667 ELSE
1668C id%STEP is of size id%N because it
1669C is received in extended form
1670 CALL mumps_realloc(id%STEP, id%N, id%INFO, lp, force=.true.,
1671 & string='id%STEP (Analysis)', errcode=-7)
1672 ENDIF
1673 IF(info(1).LT.0) GOTO 94
1674 CALL mumps_realloc(id%PROCNODE_STEPS, id%KEEP(28), id%INFO, lp,
1675 & force=.true.,
1676 & string='id%PROCNODE_STEPS (Analysis)', errcode=-7)
1677 IF(info(1).LT.0) GOTO 94
1678 CALL mumps_realloc(id%NE_STEPS, id%KEEP(28), id%INFO, lp,
1679 & force=.true.,
1680 & string='id%NE_STEPS (Analysis)', errcode=-7)
1681 IF(info(1).LT.0) GOTO 94
1682 CALL mumps_realloc(id%ND_STEPS, id%KEEP(28), id%INFO, lp,
1683 & force=.true.,
1684 & string='id%ND_STEPS (Analysis)', errcode=-7)
1685 IF(info(1).LT.0) GOTO 94
1686 CALL mumps_realloc(id%FRERE_STEPS, id%KEEP(28), id%INFO, lp,
1687 & force=.true.,
1688 & string='id%FRERE_STEPS (Analysis)', errcode=-7)
1689 IF(info(1).LT.0) GOTO 94
1690 CALL mumps_realloc(id%DAD_STEPS, id%KEEP(28), id%INFO, lp,
1691 & force=.true.,
1692 & string='id%DAD_STEPS (Analysis)', errcode=-7)
1693 IF(info(1).LT.0) GOTO 94
1694C id%FILS is allocated before expand tree
1695 IF (keep(55) .EQ. 0) THEN
1696 lptrar = id%N+id%N
1697 CALL mumps_i8realloc(id%PTRAR, lptrar, id%INFO, lp,
1698 & force=.true., string='id%PTRAR (Analysis)', errcode=-7)
1699 IF(info(1).LT.0) GOTO 94
1700 ENDIF
1701 IF (id%MYID.EQ.master) THEN
1702 CALL mumps_realloc(id%LRGROUPS, nblk, id%INFO, lp,
1703 & force=.true.
1704 & ,string='id%LRGROUPS (Analysis)', errcode=-7)
1705 ELSE
1706 CALL mumps_realloc(id%LRGROUPS, id%N, id%INFO, lp,
1707 & force=.true.
1708 & ,string='id%LRGROUPS (Analysis)', errcode=-7)
1709 ENDIF
1710 IF(info(1).LT.0) GOTO 94
1711C Copy data for factorization and/or solve.
1712C ================================
1713C COMPUTE ON THE MASTER, BROADCAST
1714C TO OTHER PROCESSES
1715C ================================
1716 IF ( id%MYID .NE. master .OR. id%KEEP(23) .EQ. 0 ) THEN
1717 IF ( associated( id%UNS_PERM ) ) THEN
1718 DEALLOCATE(id%UNS_PERM)
1719 ENDIF
1720 ENDIF
1721 94 CONTINUE
1722 CALL mumps_propinfo( icntl(1), info(1),
1723 & id%COMM, id%MYID )
1724 IF ( id%MYID .EQ. master ) THEN
1725C NA -> compressed NA containing only list
1726C of leaves of the elimination tree and list of roots
1727C (the two useful informations for factorization/solve).
1728 IF (nblk.eq.1) THEN
1729 nbroot = 1
1730 nbleaf = 1
1731 ELSE IF (ikeepalloc(na+nblk-1) .LT.0) THEN
1732 nbleaf= nblk
1733 nbroot= nblk
1734 ELSE IF (ikeepalloc(na+nblk-2) .LT.0) THEN
1735 nbleaf = nblk-1
1736 nbroot = ikeepalloc(na+nblk-1)
1737 ELSE
1738 nbleaf = ikeepalloc(na+nblk-2)
1739 nbroot = ikeepalloc(na+nblk-1)
1740 ENDIF
1741 id%LNA = 2+nbleaf+nbroot
1742 ENDIF
1743 CALL mpi_bcast( id%LNA, 1, mpi_integer,
1744 & master, id%COMM, ierr )
1745 CALL mumps_realloc(id%NA, id%LNA, id%INFO, lp, force=.true.,
1746 & string='id%NA (Analysis)', errcode=-7)
1747 CALL mumps_propinfo( icntl(1), info(1),
1748 & id%COMM, id%MYID )
1749 IF ( info(1).LT.0 ) GOTO 500
1750 IF (id%MYID .EQ.master ) THEN
1751C{ The structure of NA is the following:
1752C NA(1) is the number of leaves.
1753C NA(2) is the number of roots.
1754C NA(3:2+NA(1)) are the leaves.
1755C NA(3+NA(1):2+NA(1)+NA(2)) are the roots.
1756 id%NA(1) = nbleaf
1757 id%NA(2) = nbroot
1758C
1759C Initialize NA with the leaves and roots
1760 leaf = 3
1761 IF ( nblk == 1 ) THEN
1762 id%NA(leaf) = 1
1763 leaf = leaf + 1
1764 ELSE IF (ikeepalloc(na+nblk-1) < 0) THEN
1765 id%NA(leaf) = - ikeepalloc(na+nblk-1)-1
1766 leaf = leaf + 1
1767 DO i = 1, nbleaf - 1
1768 id%NA(leaf) = ikeepalloc(na+i-1)
1769 leaf = leaf + 1
1770 ENDDO
1771 ELSE IF (ikeepalloc(na+nblk-2) < 0 ) THEN
1772 inode = - ikeepalloc(na+nblk-2) - 1
1773 id%NA(leaf) = inode
1774 leaf =leaf + 1
1775 IF ( nbleaf > 1 ) THEN
1776 DO i = 1, nbleaf - 1
1777 id%NA(leaf) = ikeepalloc(na+i-1)
1778 leaf = leaf + 1
1779 ENDDO
1780 ENDIF
1781 ELSE
1782 DO i = 1, nbleaf
1783 id%NA(leaf) = ikeepalloc(na+i-1)
1784 leaf = leaf + 1
1785 ENDDO
1786 END IF
1787C
1788C Build array STEP(1:id%N) to hold step numbers in
1789C range 1..id%KEEP(28), allowing compression of
1790C other arrays from id%N to id%KEEP(28)
1791C (the number of nodes/steps in the assembly tree)
1792 istep = 0
1793 DO i = 1, nblk
1794 IF ( frereptr(i) .ne. nblk + 1 ) THEN
1795C New node in the tree.
1796c (Set step( inode_n ) = inode_nsteps for principal
1797C variables and -inode_nsteps for internal variables
1798C of the node)
1799 istep = istep + 1
1800 id%STEP(i)=istep
1801 inn = filsptr(i)
1802 DO WHILE ( inn .GT. 0 )
1803 id%STEP(inn) = - istep
1804 inn = filsptr(inn)
1805 END DO
1806 IF (frereptr(i) .eq. 0) THEN
1807C Keep root nodes list in NA
1808 id%NA(leaf) = i
1809 leaf = leaf + 1
1810 ENDIF
1811 ENDIF
1812 END DO
1813 IF ( leaf - 1 .NE. 2+nbroot + nbleaf ) THEN
1814 WRITE(*,*) 'Internal error 2 in SMUMPS_ANA_DRIVER'
1815 CALL mumps_abort()
1816 ENDIF
1817 IF ( istep .NE. id%KEEP(28) ) THEN
1818 write(*,*) 'Internal error 3 in SMUMPS_ANA_DRIVER',
1819 & istep, id%KEEP(28)
1820 CALL mumps_abort()
1821 ENDIF
1822C ============
1823C SET PROCNODE, FRERE, NE
1824C ============
1825C copies to NSTEP array should be ok
1826 DO i = 1, nblk
1827 IF (frereptr(i) .NE. nblk+1) THEN
1828 id%PROCNODE_STEPS(id%STEP(i)) = procnode( i )
1829 id%FRERE_STEPS(id%STEP(i)) = frereptr(i)
1830 id%NE_STEPS(id%STEP(i)) = ikeepalloc(ne+i-1)
1831 id%ND_STEPS(id%STEP(i)) = nfsizptr(i)
1832 ENDIF
1833 ENDDO
1834C ===============================
1835C Algorithm to compute array DAD_STEPS:
1836C ----
1837C For each node set dad for all of its sons
1838C plus, for root nodes set dad to zero.
1839C
1840C ===============================
1841 DO i = 1, nblk
1842C -- skip non principal nodes
1843 IF ( id%STEP(i) .LE. 0) cycle
1844C -- (I) is a principal node
1845 IF (frereptr(i) .eq. 0) THEN
1846C -- I is a root node and has no father
1847 id%DAD_STEPS(id%STEP(i)) = 0
1848 ENDIF
1849C -- Find first son node (IFS)
1850 ifs = filsptr(i)
1851 DO WHILE ( ifs .GT. 0 )
1852 ifs= filsptr(ifs)
1853 END DO
1854C -- IFS > 0 if I is not a leave node
1855C -- Go through list of brothers of IFS if any
1856 ifs = -ifs
1857 DO WHILE (ifs.GT.0)
1858C -- I is not a leave node and has a son node IFS
1859 id%DAD_STEPS(id%STEP(ifs)) = i
1860 ifs = frereptr(ifs)
1861 ENDDO
1862 END DO
1863C
1864C
1865C Following arrays (PROCNODE and IKEEPALLOC) not used anymore
1866C during analysis
1867 IF (allocated(procnode)) DEALLOCATE(procnode)
1868 IF (allocated(ikeepalloc)) DEALLOCATE(ikeepalloc)
1869 IF (associated(frereptr)) DEALLOCATE(frereptr)
1870 NULLIFY(frereptr)
1871 IF (associated(nfsizptr)) DEALLOCATE(nfsizptr)
1872 NULLIFY(nfsizptr)
1873 ENDIF
1874 IF (keep(494).NE.0) THEN
1875C{
1876 IF (id%MYID.EQ.master) THEN
1877 IF (prokg) THEN
1878 CALL mumps_secdeb(timeg)
1879 END IF
1880 ENDIF
1881C =======================================================
1882C Compute a grouping of variables for LR approximations.
1883C Grouping may be performed on a distributed matrix
1884C =======================================================
1885C
1886C I/ Prepare data before call to grouping
1887 IF ((keep(54).EQ.3).AND.(keep(13).NE.0)) THEN
1888C Matrix is distributed on entry and compression computed
1889 IF (keep(487).NE.1) CALL mumps_abort()
1890 ALLOCATE(mapcol(id%KEEP(28)), stat=allocok)
1891 IF (allocok .ne.0) then
1892 info(1)= -7
1893 info(2)= id%KEEP(28)
1894 ENDIF
1895C Broadcast errors
1896 CALL mumps_propinfo( icntl(1), info(1),
1897 & id%COMM, id%MYID )
1898 IF ( info(1).LT.0 ) GOTO 500
1899C
1900 CALL mumps_inialize_redist_lumat (
1901 & id%INFO, id%ICNTL, id%KEEP, id%COMM, id%MYID, nblk,
1902 & lumat, id%PROCNODE_STEPS(1), id%KEEP(28), mapcol,
1903 & lumat_remap, nbrecords, id%STEP(1))
1904C INFO(1) has been broadcasted already in routine
1905 IF ( id%INFO(1).LT.0 ) GOTO 500
1906C
1907C -- Redistribute LUMAT into LU_REMAP relying on procnode
1908 CALL mumps_ab_dist_lmat_to_lumat (
1909 & .false., ! do not UNFOLD
1910 & .true., ! MAPCOL in NSTEPS=> STEP array needed
1911 & id%INFO, id%ICNTL, id%COMM, id%MYID, nblk, id%NPROCS,
1912 & lumat, mapcol, id%KEEP(28), id%STEP(1), nblk,
1913 & lumat_remap, nbrecords, nsend8, nlocal8
1914 & )
1915 CALL mumps_ab_free_lmat(lumat)
1916C Distribute SIZEOFBLOCKS that was defined only on master
1917 CALL mpi_bcast( sizeofblocks, nblk, mpi_integer, master,
1918 & id%COMM, ierr )
1919C
1920 ELSE IF ((keep(54).NE.3).AND.(keep(13).NE.0)
1921 & .AND. (keep(487).EQ.1) ) THEN
1922C Centralized matrix and LMAT_BLOCK available
1923C ---> build LUMAT_REMAP on MASTER
1924 IF (id%MYID.EQ.master) THEN
1925 CALL mumps_ab_lmat_to_lumat (
1926 & lmat_block, lumat_remap,
1927 & info(1), icntl(1))
1928C --- LMAT_BLOCK not needed anymore
1929 CALL mumps_ab_free_lmat(lmat_block)
1930 ENDIF
1931C Broadcast errors
1932 CALL mumps_propinfo( icntl(1), info(1),
1933 & id%COMM, id%MYID )
1934 IF ( info(1).LT.0 ) GOTO 500
1935C
1936 ELSE IF ((keep(54).EQ.3).AND.(keep(13).EQ.0)
1937 & .AND. keep(487).EQ.1) THEN
1938C Matrix is distributed on entry and compression not requested
1939C (this will be the case when ICNTL(15).EQ.0 and
1940C // analysis, or Schur, etc...)
1941C note that with distributed matrix and centralized ordering
1942C compression is forced to limit memory peak)
1943C Free centralized matrix before grouping to
1944C limit memory peak
1945 IF (gather_matrix_allocated) THEN
1946 IF (associated(id%IRN)) THEN
1947 DEALLOCATE(id%IRN)
1948 NULLIFY(id%IRN)
1949 ENDIF
1950 IF (associated(id%JCN)) THEN
1951 DEALLOCATE(id%JCN)
1952 NULLIFY(id%JCN)
1953 ENDIF
1954 gather_matrix_allocated= .false.
1955 ENDIF
1956 IF (.NOT. i_am_slave .OR. ! non-working master
1957 & id%KEEP8(29) .EQ. 0_8) THEN ! NNZ_loc or NZ_loc
1958C Master non-working
1959 irn_loc_ptr => idummy_array
1960 jcn_loc_ptr => idummy_array
1961 ELSE
1962 irn_loc_ptr => id%IRN_loc
1963 jcn_loc_ptr => id%JCN_loc
1964 ENDIF
1965 ALLOCATE(mapcol(id%KEEP(28)), stat=allocok)
1966 IF (allocok .ne.0) then
1967 info(1)= -7
1968 info(2)= id%KEEP(28)
1969 ENDIF
1970C Broadcast errors
1971 CALL mumps_propinfo( icntl(1), info(1),
1972 & id%COMM, id%MYID )
1973 IF ( info(1).LT.0 ) GOTO 500
1974C
1975C Build MAPCOL and LUMAT_REMAP mapped according
1976C to MAPCOL (outputs available on all MPI procs).
1977 CALL mumps_ab_dcoord_to_dtree_lumat (
1978 & id%MYID, id%NPROCS, id%COMM,
1979 & nblk, id%N,
1980 & id%KEEP8(29), ! => NNZ_loc or NZ_loc
1981 & irn_loc_ptr(1), jcn_loc_ptr(1),
1982 & id%PROCNODE_STEPS(1), id%KEEP(28), id%STEP(1),
1983 & id%ICNTL(1), id%INFO(1), id%KEEP(1),
1984 & mapcol, lumat_remap )
1985 IF (info(1).GE.0) THEN
1986C SIZEOFBLOCKS needed on all procs during MPI grouping
1987 ALLOCATE(sizeofblocks(nblk), stat=allocok)
1988 IF (allocok .ne.0) then
1989 info(1)= -7
1990 info(2)= nblk
1991 ENDIF
1992 DO i=1, nblk
1993 sizeofblocks(i) = 1
1994 ENDDO
1995 ENDIF
1996C Broadcast errors
1997 CALL mumps_propinfo( icntl(1), info(1),
1998 & id%COMM, id%MYID )
1999 IF ( info(1).LT.0 ) GOTO 500
2000 ELSE IF ((keep(54).EQ.3) .AND. (keep(244).EQ.2)
2001 & .AND. (keep(487).NE.1)
2002 & ) THEN
2003C Grouping preparation on slaves:
2004C If the input matrix is distributed and the parallel analysis is
2005C chosen, the graph used to be centralized in order to compute the
2006C clustering.
2007C
2008 CALL smumps_gather_matrix(id)
2009 gather_matrix_allocated = .true.
2010 ENDIF
2011C ============
2012C ============
2013C II/ GROUPING
2014C ============
2015 IF ((keep(54).EQ.3).AND.(keep(487).EQ.1)) THEN
2016C Matrix is distributed on entry and halo of size 1
2017C Distributed memory based grouping is used
2018 IF (id%MYID.NE.master) THEN
2019 ALLOCATE(filsptr(nblk), stat=ierr)
2020 IF (ierr.GT.0) THEN
2021 info(1)=-7
2022 info(2)=nblk
2023 ENDIF
2024 ENDIF
2025C Broadcast errors
2026 CALL mumps_propinfo( icntl(1), info(1),
2027 & id%COMM, id%MYID )
2028 IF ( info(1).LT.0 ) GOTO 500
2029C Distribute SIZEOFBLOCKS that was defined only on master
2030C CALL MPI_BCAST( SIZEOFBLOCKS, NBLK, MPI_INTEGER, MASTER,
2031C & id%COMM, IERR )
2032 CALL smumps_ab_lr_mpi_grouping(nblk,
2033 & mapcol, id%KEEP(28),
2034 & id%KEEP(28), lumat_remap, filsptr,
2035 & id%FRERE_STEPS,
2036 & id%DAD_STEPS, id%STEP, id%NA,
2037 & id%LNA, id%LRGROUPS, sizeofblocks(1), id%KEEP(50),
2038 & id%ICNTL(1), id%KEEP(487), id%KEEP(488),
2039 & id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60),
2040 & id%INFO(1), id%INFO(2),
2041 & id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472),
2042 & id%KEEP(127), id%KEEP(469), id%KEEP(10),
2043 & id%KEEP(54), id%KEEP(142),
2044 & lpok, lp, id%COMM, id%MYID, id%NPROCS)
2045 IF (allocated(mapcol)) DEALLOCATE(mapcol)
2046 IF (id%MYID.NE.master) THEN
2047 DEALLOCATE(filsptr)
2048 NULLIFY(filsptr)
2049 ENDIF
2050C
2051 ELSE IF (id%MYID.EQ.master) THEN
2052 IF ((keep(54).NE.3).AND.(keep(13).NE.0)
2053 & .AND. (keep(487).EQ.1) ) THEN
2054C Centralized matrix and LMAT_BLOCK available
2055C --- build LUMAT
2056C -- LR grouping exploiting LUMAT
2057C -- centralized => MAPCOL not needed
2058C
2059 idummy_array(1) = -1
2060 CALL smumps_ab_lr_grouping(nblk,
2061 & idummy_array, 1,
2062 & id%KEEP(28), lumat_remap, filsptr,
2063 & id%FRERE_STEPS,
2064 & id%DAD_STEPS, id%STEP, id%NA,
2065 & id%LNA, id%LRGROUPS, sizeofblocks(1), id%KEEP(50),
2066 & id%ICNTL(1), id%KEEP(487), id%KEEP(488),
2067 & id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60),
2068 & id%INFO(1), id%INFO(2),
2069 & id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472),
2070 & id%KEEP(127), id%KEEP(469), id%KEEP(10),
2071 & id%KEEP(54), id%KEEP(142),
2072 & lpok, lp, id%MYID, id%COMM)
2073 ELSE
2074C grouping based on centralized matrix
2075 IF (keep(469).EQ.0) THEN
2076 CALL smumps_lr_grouping(id%N, id%KEEP8(28), id%KEEP(28),
2077 & id%IRN,
2078 & id%JCN, filsptr, id%FRERE_STEPS,
2079 & id%DAD_STEPS, id%NE_STEPS, id%STEP, id%NA,
2080 & id%LNA, id%LRGROUPS,
2081 & id%KEEP(50),
2082 & id%ICNTL(1), id%KEEP(487), id%KEEP(488),
2083 & id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60),
2084 & id%INFO(1), id%INFO(2),
2085 & id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472),
2086 & id%KEEP(127), id%KEEP(10),
2087 & id%KEEP(54), id%KEEP(142),
2088 & lpok, lp, gather_matrix_allocated)
2089 ELSE
2090 CALL smumps_lr_grouping_new(id%N, id%KEEP8(28),
2091 & id%KEEP(28), id%IRN,
2092 & id%JCN, filsptr, id%FRERE_STEPS,
2093 & id%DAD_STEPS, id%STEP, id%NA,
2094 & id%LNA, id%LRGROUPS, id%KEEP(50),
2095 & id%ICNTL(1), id%KEEP(487), id%KEEP(488),
2096 & id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60),
2097 & id%INFO(1), id%INFO(2),
2098 & id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472),
2099 & id%KEEP(127), id%KEEP(469), id%KEEP(10),
2100 & id%KEEP(54), id%KEEP(142),
2101 & lpok, lp, gather_matrix_allocated)
2102 ENDIF
2103 ENDIF
2104 ENDIF
2105 CALL mpi_bcast( keep(142), 1, mpi_integer, master,
2106 & id%COMM, ierr )
2107C ============
2108C III/ CLEANUP
2109C ============
2110C Free LUMAT_REMAP is allocated
2111 CALL mumps_ab_free_lmat(lumat_remap)
2112 IF (allocated(mapcol)) DEALLOCATE(mapcol)
2113 IF (allocated(sizeofblocks)) DEALLOCATE(sizeofblocks)
2114 IF ( (keep(54).EQ.3) .AND. (keep(244).EQ.2).AND.
2115 & (keep(487).NE.1) ) THEN
2116C Cleanup the irn and jcn arrays filled up by the
2117C cmumps_gather_matrix above. It might have been done
2118C during grouping
2119 IF (gather_matrix_allocated) THEN
2120 IF (associated(id%IRN)) THEN
2121 DEALLOCATE(id%IRN)
2122 NULLIFY(id%IRN)
2123 ENDIF
2124 IF (associated(id%JCN)) THEN
2125 DEALLOCATE(id%JCN)
2126 NULLIFY(id%JCN)
2127 ENDIF
2128 gather_matrix_allocated= .false.
2129 ENDIF
2130 END IF
2131 IF (prokg) THEN
2132 CALL mumps_secfin(timeg)
2133 WRITE(mpg,145) timeg
2134 END IF
2135C} Grouping: KEEP(494) .NE. 0
2136 ENDIF
2137 IF (id%MYID.NE. master) THEN
2138 CALL mumps_realloc(id%FILS, id%N, id%INFO, lp, force=.true.,
2139 & string='id%FILS (Analysis)', errcode=-7)
2140 IF(info(1).LT.0) GOTO 97
2141 ENDIF
2142C
2143 IF ((id%MYID.EQ.master) .AND.(keep(13).NE.0)) THEN
2144C{ ===========
2145C Expand tree
2146C ===========
2147C Current tree is relative to the analysis by block.
2148C Expand the tree on the master if compression is effective
2149C (in all cases, grouping done or not)
2150 IF (nblk.LT.id%N.OR.(.NOT.blkvar_allocated)) THEN
2151C even if NBLK.EQ.N BLKVAR provided by user might hold
2152C a permutation of the variables and this expand_tree_steps
2153C should also be called
2154C Expand FILSPTR, id%STEP into id%FILS, STEPPTR
2155C and update arrays of size NSTEPS
2156 ALLOCATE(stepptr(id%N), lrgroupsptr(id%N), stat=ierr)
2157 IF (ierr.GT.0) THEN
2158 info(1)=-7
2159 info(2)=id%N
2160 GOTO 97
2161 ENDIF
2162 IF (nb_niv2.EQ.0) THEN
2163 idummy_array(1) = -9999
2164 par2_nodesptr => idummy_array(1:1)
2165 size_par2_nodesptr=1
2166 ELSE
2167 par2_nodesptr => par2_nodes(1:nb_niv2)
2168 size_par2_nodesptr=nb_niv2
2169 ENDIF
2170 CALL mumps_realloc(id%FILS, id%N, id%INFO, lp,
2171 & force=.true.,
2172 & string='id%FILS (Analysis)', errcode=-7)
2173 IF(info(1).LT.0) GOTO 97
2174 CALL smumps_expand_tree_steps (id%ICNTL,
2175 & id%N, nblk, id%BLKPTR(1), id%BLKVAR(1),
2176 & filsptr(1), id%FILS(1), id%KEEP(28),
2177 & id%STEP(1), stepptr(1),
2178 & par2_nodesptr(1), size_par2_nodesptr,
2179 & id%DAD_STEPS(1), id%FRERE_STEPS(1),
2180 & id%NA(1), id%LNA, id%LRGROUPS(1), lrgroupsptr(1),
2181 & id%KEEP(20), id%KEEP(38)
2182 & )
2183 NULLIFY(par2_nodesptr)
2184 DEALLOCATE(id%STEP)
2185 id%STEP=>stepptr
2186 NULLIFY(stepptr)
2187 DEALLOCATE(id%LRGROUPS)
2188 id%LRGROUPS=>lrgroupsptr
2189 NULLIFY(lrgroupsptr)
2190 DEALLOCATE(filsptr)
2191 NULLIFY(filsptr)
2192 ELSE
2193 if (associated(id%FILS)) DEALLOCATE(id%FILS)
2194 id%FILS=>filsptr
2195 NULLIFY(filsptr)
2196 ENDIF
2197C}
2198 ENDIF
2199 IF ((id%N.EQ.nblk).AND.associated(filsptr)) THEN
2200C id%FILS has not been initialized
2201 if (associated(id%FILS)) DEALLOCATE(id%FILS)
2202 id%FILS=>filsptr
2203 NULLIFY(filsptr)
2204 ENDIF
2205 97 CONTINUE
2206 CALL mumps_realloc(id%SYM_PERM, id%N, id%INFO, lp,
2207 & force=.true.,
2208 & string='id%SYM_PERM (Analysis)', errcode=-7)
2209 CALL mumps_propinfo( icntl(1), info(1), id%COMM, id%MYID )
2210 IF ( info(1) < 0 ) GOTO 500
2211 IF (id%MYID.EQ.master) THEN
2212C =================================================================
2213C Reorder the tree using a variant of Liu's algorithm. Note that
2214C REORDER_TREE MUST always be called since it sorts NA (the list of
2215C leaves) in a valid order in the sense of a depth-first traversal.
2216C =================================================================
2217 CALL smumps_reorder_tree(id%N, id%FRERE_STEPS(1),
2218 & id%STEP(1),id%FILS(1), id%NA(1), id%LNA,
2219 & id%NE_STEPS(1), id%ND_STEPS(1), id%DAD_STEPS(1),
2220 & id%KEEP(28), .true., id%KEEP(28), id%KEEP(70),
2221 & id%KEEP(50), id%INFO(1), id%ICNTL(1),id%KEEP(215),
2222 & id%KEEP(234), id%KEEP(55), id%KEEP(199),
2223 & id%PROCNODE_STEPS(1),id%NSLAVES,peak,id%KEEP(90)
2224 & )
2225 IF(id%KEEP(261).EQ.1)THEN
2226 CALL mumps_sort_step(id%N, id%FRERE_STEPS(1),
2227 & id%STEP(1),id%FILS(1), id%NA(1), id%LNA,
2228 & id%NE_STEPS(1), id%ND_STEPS(1), id%DAD_STEPS(1),
2229 & id%KEEP(28), .true., id%KEEP(28), id%INFO(1),
2230 & id%ICNTL(1),id%PROCNODE_STEPS(1),id%NSLAVES
2231 & )
2232 ENDIF
2233C Compute and export some global information on the tree needed by
2234C dynamic schedulers during the factorization. The type of
2235C information depends on the selected strategy.
2236 IF ((id%KEEP(76).GE.4).OR.(id%KEEP(76).GE.6).OR.
2237 & (id%KEEP(47).EQ.4).OR.((id%KEEP(81).GT.0)
2238 & .AND.(id%KEEP(47).GE.2)))THEN
2239 is_build_load_mem_called=.true.
2240 IF ((id%KEEP(47) .EQ. 4).OR.
2241 & (( id%KEEP(81) .GT. 0).AND.(id%KEEP(47).GE.2))) THEN
2242 IF(id%NSLAVES.GT.1) THEN
2243C NBSA is the total number of subtrees and
2244C is an upperbound of the local number of
2245C subtrees
2246 size_temp_mem = id%NBSA
2247 ELSE
2248C Only one processor, NA(2) is the number of leaves
2249 size_temp_mem = id%NA(2)
2250 ENDIF
2251 ELSE
2252 size_temp_mem = 1
2253 ENDIF
2254 IF((id%KEEP(76).EQ.4).OR.(id%KEEP(76).EQ.6))THEN
2255 size_depth_first=id%KEEP(28)
2256 ELSE
2257 size_depth_first=1
2258 ENDIF
2259 allocate(temp_mem(size_temp_mem,id%NSLAVES),stat=allocok)
2260 IF (allocok .NE.0) THEN
2261 info(1)= -7
2262 info(2)= size_temp_mem*id%NSLAVES
2263 IF ( lpok ) THEN
2264 WRITE(lp, 150) 'TEMP_MEM'
2265 END IF
2266 GOTO 80 !! FIXME propagate error
2267 END IF
2268 allocate(temp_leaf(size_temp_mem,id%NSLAVES),
2269 & stat=allocok)
2270 IF (allocok .ne.0) then
2271 IF ( lpok ) THEN
2272 WRITE(lp, 150) 'TEMP_LEAF'
2273 END IF
2274 info(1)= -7
2275 info(2)= size_temp_mem*id%NSLAVES
2276 GOTO 80 !! FIXME propagate error
2277 end if
2278 allocate(temp_size(size_temp_mem,id%NSLAVES),
2279 & stat=allocok)
2280 IF (allocok .ne.0) then
2281 IF ( lpok ) THEN
2282 WRITE(lp, 150) 'TEMP_SIZE'
2283 END IF
2284 info(1)= -7
2285 info(2)= size_temp_mem*id%NSLAVES
2286 GOTO 80
2287 end if
2288 allocate(temp_root(size_temp_mem,id%NSLAVES),
2289 & stat=allocok)
2290 IF (allocok .ne.0) then
2291 IF ( lpok ) THEN
2292 WRITE(lp, 150) 'TEMP_ROOT'
2293 END IF
2294 info(1)= -7
2295 info(2)= size_temp_mem*id%NSLAVES
2296 GOTO 80
2297 end if
2298 allocate(depth_first(size_depth_first),stat=allocok)
2299 IF (allocok .ne.0) then
2300 IF ( lpok ) THEN
2301 WRITE(lp, 150) 'DEPTH_FIRST'
2302 END IF
2303 info(1)= -7
2304 info(2)= size_depth_first
2305 GOTO 80
2306 end if
2307 ALLOCATE(depth_first_seq(size_depth_first),stat=allocok)
2308 IF (allocok .ne.0) then
2309 IF ( lpok ) THEN
2310 WRITE(lp, 150) 'DEPTH_FIRST_SEQ'
2311 END IF
2312 info(1)= -7
2313 info(2)= size_depth_first
2314 GOTO 80
2315 end if
2316 ALLOCATE(sbtr_id(size_depth_first),stat=allocok)
2317 IF (allocok .ne.0) then
2318 IF ( lpok ) THEN
2319 WRITE(lp, 150) 'SBTR_ID'
2320 END IF
2321 info(1)= -7
2322 info(2)= size_depth_first
2323 GOTO 80
2324 end if
2325 IF(id%KEEP(76).EQ.5)THEN
2326C We reuse the same variable as before
2327 size_cost_trav=id%KEEP(28)
2328 ELSE
2329 size_cost_trav=1
2330 ENDIF
2331 allocate(cost_trav_tmp(size_cost_trav),stat=allocok)
2332 IF (allocok .ne.0) then
2333 IF ( lpok ) THEN
2334 WRITE(lp, 150) 'COST_TRAV_TMP'
2335 END IF
2336 info(1)= -7
2337 info(2)= size_cost_trav
2338 GOTO 80
2339 END IF
2340 IF(id%KEEP(76).EQ.5)THEN
2341 IF(id%KEEP(70).EQ.0)THEN
2342 id%KEEP(70)=5
2343 ENDIF
2344 IF(id%KEEP(70).EQ.1)THEN
2345 id%KEEP(70)=6
2346 ENDIF
2347 ENDIF
2348 IF(id%KEEP(76).EQ.4)THEN
2349 IF(id%KEEP(70).EQ.0)THEN
2350 id%KEEP(70)=3
2351 ENDIF
2352 IF(id%KEEP(70).EQ.1)THEN
2353 id%KEEP(70)=4
2354 ENDIF
2355 ENDIF
2356 CALL smumps_build_load_mem_info(id%N, id%FRERE_STEPS(1),
2357 & id%STEP(1),id%FILS(1), id%NA(1), id%LNA,
2358 & id%NE_STEPS(1), id%ND_STEPS(1), id%DAD_STEPS(1),
2359 & id%KEEP(28), .true., id%KEEP(28), id%KEEP(70),
2360 & id%KEEP(50), id%INFO(1), id%ICNTL(1),id%KEEP(47),
2361 & id%KEEP(81),id%KEEP(76),id%KEEP(215),
2362 & id%KEEP(234), id%KEEP(55), id%KEEP(199),
2363 & id%PROCNODE_STEPS(1),temp_mem,id%NSLAVES,
2364 & size_temp_mem, peak,id%KEEP(90),size_depth_first,
2365 & size_cost_trav,depth_first(1),depth_first_seq(1),
2366 & cost_trav_tmp(1),
2367 & temp_leaf,temp_size,temp_root,sbtr_id(1)
2368 & )
2369 END IF
2370 ENDIF
2371 IF (id%MYID.EQ.master) THEN
2372 CALL smumps_sort_perm(id%N, id%NA(1), id%LNA,
2373 & id%NE_STEPS(1), id%SYM_PERM(1),
2374 & id%FILS(1), id%DAD_STEPS(1),
2375 & id%STEP(1), id%KEEP(28),
2376 & id%KEEP(60), id%KEEP(20), id%KEEP(38),
2377 & id%INFO(1) )
2378 ENDIF
2379C Root principal variable
2380C for scalapack (KEEP(38)) or special serial root (KEEP(20))
2381C might have been updated
2382C since root variables might have been permuted
2383C and/or expanded (MUMPS_EXPAND_TREE) in case of compressed graph
2384C It should thus be redistributed to all procs
2385 IF ( keep(494).NE.0 .OR. keep(13).NE.0 ) THEN
2386C Value of KEEP(20) and KEEP(38) on master is always correct
2387C + non-zero status is identical on all procs since 110 first
2388C KEEP entries have been broadcasted
2389 IF (keep(38) .NE. 0) THEN
2390 CALL mpi_bcast( id%KEEP(38), 1, mpi_integer, master,
2391 & id%COMM, ierr )
2392 ENDIF
2393 IF (keep(20) .NE. 0) THEN
2394 CALL mpi_bcast( id%KEEP(20), 1, mpi_integer, master,
2395 & id%COMM, ierr )
2396 ENDIF
2397 ENDIF
2398 80 CONTINUE
2399C Broadcast errors
2400 CALL mumps_propinfo( icntl(1), info(1),
2401 & id%COMM, id%MYID )
2402 IF ( info(1).LT.0 ) GOTO 500
2403C ---------------------------------------------------
2404C Broadcast information computed on the master to
2405C the slaves.
2406C The matrix itself with numerical values and
2407C integer data for the arrowhead/element description
2408C will be received at the beginning of FACTO.
2409C ---------------------------------------------------
2410 CALL mpi_bcast( id%FILS(1), id%N, mpi_integer,
2411 & master, id%COMM, ierr )
2412 CALL mpi_bcast( id%NA(1), id%LNA, mpi_integer,
2413 & master, id%COMM, ierr )
2414 CALL mpi_bcast( id%STEP(1), id%N, mpi_integer,
2415 & master, id%COMM, ierr )
2416 CALL mpi_bcast( id%PROCNODE_STEPS(1), id%KEEP(28), mpi_integer,
2417 & master, id%COMM, ierr )
2418 CALL mpi_bcast( id%DAD_STEPS(1), id%KEEP(28), mpi_integer,
2419 & master, id%COMM, ierr )
2420 CALL mpi_bcast( id%FRERE_STEPS(1), id%KEEP(28), mpi_integer,
2421 & master, id%COMM, ierr)
2422 CALL mpi_bcast( id%NE_STEPS(1), id%KEEP(28), mpi_integer,
2423 & master, id%COMM, ierr )
2424 CALL mpi_bcast( id%ND_STEPS(1), id%KEEP(28), mpi_integer,
2425 & master, id%COMM, ierr )
2426 CALL mpi_bcast( id%SYM_PERM(1), id%N, mpi_integer,
2427 & master, id%COMM, ierr )
2428 IF(keep(494).NE.0) THEN
2429 CALL mpi_bcast( id%LRGROUPS(1), id%N, mpi_integer,
2430 & master, id%COMM, ierr )
2431 END IF
2432 IF (keep(55) .EQ. 0) THEN
2433C Assembled matrix format. Fill up the id%PTRAR array
2434C Broadcast id%SYM_PERM needed to fill up id%PTRAR
2435C At the end of ANA_N_DIST, id%PTRAR is already on every processor
2436C because it is computed in a distributed way.
2437C No need to broadcast it again
2438 CALL smumps_ana_n_dist(id, id%PTRAR)
2439 IF(id%MYID .EQ. master) THEN
2440C -----------------------------------
2441C For distributed structure on entry,
2442C we can now deallocate the complete
2443C structure IRN / JCN.
2444C -----------------------------------
2445 IF ( (keep(244) .EQ. 1) .AND. (keep(54) .EQ. 3) ) THEN
2446C IRN and JCN might have already been deallocated
2447 IF (gather_matrix_allocated) THEN
2448 IF (associated(id%IRN)) THEN
2449 DEALLOCATE(id%IRN)
2450 NULLIFY(id%IRN)
2451 ENDIF
2452 IF (associated(id%JCN)) THEN
2453 DEALLOCATE(id%JCN)
2454 NULLIFY(id%JCN)
2455 ENDIF
2456 gather_matrix_allocated= .false.
2457 ENDIF
2458 END IF
2459 END IF
2460 ENDIF
2461C
2462C Store size of the stack memory for each
2463C of the sequential subtree.
2464 IF((id%KEEP(76).EQ.4).OR.(id%KEEP(76).EQ.6))THEN
2465 IF(associated(id%DEPTH_FIRST)) THEN
2466 DEALLOCATE(id%DEPTH_FIRST)
2467 ENDIF
2468 allocate(id%DEPTH_FIRST(id%KEEP(28)),stat=allocok)
2469 IF (allocok .ne.0) then
2470 info(1)= -7
2471 info(2)= id%KEEP(28)
2472 IF ( lpok ) THEN
2473 WRITE(lp, 150) 'id%DEPTH_FIRST'
2474 END IF
2475 GOTO 87
2476 END IF
2477 IF(associated(id%DEPTH_FIRST_SEQ)) THEN
2478 DEALLOCATE(id%DEPTH_FIRST_SEQ)
2479 ENDIF
2480 ALLOCATE(id%DEPTH_FIRST_SEQ(id%KEEP(28)),stat=allocok)
2481 IF (allocok .ne.0) then
2482 info(1)= -7
2483 info(2)= id%KEEP(28)
2484 IF ( lpok ) THEN
2485 WRITE(lp, 150) 'id%DEPTH_FIRST_SEQ'
2486 END IF
2487 GOTO 87
2488 END IF
2489 IF(associated(id%SBTR_ID)) THEN
2490 DEALLOCATE(id%SBTR_ID)
2491 ENDIF
2492 ALLOCATE(id%SBTR_ID(id%KEEP(28)),stat=allocok)
2493 IF (allocok .ne.0) then
2494 info(1)= -7
2495 info(2)= id%KEEP(28)
2496 IF ( lpok ) THEN
2497 WRITE(lp, 150) 'id%DEPTH_FIRST_SEQ'
2498 END IF
2499 GOTO 87
2500 END IF
2501 IF(id%MYID.EQ.master)THEN
2502 id%DEPTH_FIRST(1:id%KEEP(28))=depth_first(1:id%KEEP(28))
2503 id%DEPTH_FIRST_SEQ(1:id%KEEP(28))=
2504 & depth_first_seq(1:id%KEEP(28))
2505 id%SBTR_ID(1:keep(28))=sbtr_id(1:keep(28))
2506 ENDIF
2507 CALL mpi_bcast( id%DEPTH_FIRST(1), id%KEEP(28), mpi_integer,
2508 & master, id%COMM, ierr )
2509 CALL mpi_bcast( id%DEPTH_FIRST_SEQ(1), id%KEEP(28),
2510 & mpi_integer,master, id%COMM, ierr )
2511 CALL mpi_bcast( id%SBTR_ID(1), id%KEEP(28),
2512 & mpi_integer,master, id%COMM, ierr )
2513 ELSE
2514 IF(associated(id%DEPTH_FIRST)) THEN
2515 DEALLOCATE(id%DEPTH_FIRST)
2516 ENDIF
2517 allocate(id%DEPTH_FIRST(1),stat=allocok)
2518 IF (allocok .ne.0) then
2519 info(1)= -7
2520 info(2)= 1
2521 IF ( lpok ) THEN
2522 WRITE(lp, 150) 'id%DEPTH_FIRST'
2523 END IF
2524 GOTO 87
2525 END IF
2526 IF(associated(id%DEPTH_FIRST_SEQ)) THEN
2527 DEALLOCATE(id%DEPTH_FIRST_SEQ)
2528 ENDIF
2529 ALLOCATE(id%DEPTH_FIRST_SEQ(1),stat=allocok)
2530 IF (allocok .ne.0) then
2531 info(1)= -7
2532 info(2)= 1
2533 IF ( lpok ) THEN
2534 WRITE(lp, 150) 'id%DEPTH_FIRST_SEQ'
2535 END IF
2536 GOTO 87
2537 END IF
2538 IF(associated(id%SBTR_ID)) THEN
2539 DEALLOCATE(id%SBTR_ID)
2540 ENDIF
2541 ALLOCATE(id%SBTR_ID(1),stat=allocok)
2542 IF (allocok .ne.0) then
2543 info(1)= -7
2544 info(2)= 1
2545 IF ( lpok ) THEN
2546 WRITE(lp, 150) 'id%DEPTH_FIRST_SEQ'
2547 END IF
2548 GOTO 87
2549 END IF
2550 id%SBTR_ID(1)=0
2551 id%DEPTH_FIRST(1)=0
2552 id%DEPTH_FIRST_SEQ(1)=0
2553 ENDIF
2554 IF(id%KEEP(76).EQ.5)THEN
2555 IF(associated(id%COST_TRAV)) THEN
2556 DEALLOCATE(id%COST_TRAV)
2557 ENDIF
2558 allocate(id%COST_TRAV(id%KEEP(28)),stat=allocok)
2559 IF (allocok .ne.0) then
2560 IF ( lpok ) THEN
2561 WRITE(lp, 150) 'id%COST_TRAV'
2562 END IF
2563 info(1)= -7
2564 info(2)= id%KEEP(28)
2565 GOTO 87
2566 END IF
2567 IF(id%MYID.EQ.master)THEN
2568 id%COST_TRAV(1:id%KEEP(28))=
2569 & dble(cost_trav_tmp(1:id%KEEP(28)))
2570 ENDIF
2571 CALL mpi_bcast( id%COST_TRAV(1), id%KEEP(28),
2572 & mpi_double_precision,master, id%COMM, ierr )
2573 ELSE
2574 IF(associated(id%COST_TRAV)) THEN
2575 DEALLOCATE(id%COST_TRAV)
2576 ENDIF
2577 allocate(id%COST_TRAV(1),stat=allocok)
2578 IF (allocok .ne.0) then
2579 IF ( lpok ) THEN
2580 WRITE(lp, 150) 'id%COST_TRAV(1)'
2581 END IF
2582 info(1)= -7
2583 info(2)= 1
2584 GOTO 87
2585 END IF
2586 id%COST_TRAV(1)=0.0d0
2587 ENDIF
2588 IF (id%KEEP(47) .EQ. 4 .OR.
2589 & ((id%KEEP(81) .GT. 0).AND.(id%KEEP(47).GE.2))) THEN
2590 IF(id%MYID .EQ. master)THEN
2591 DO k=1,id%NSLAVES
2592 DO j=1,size_temp_mem
2593 IF(temp_mem(j,k) < 0.0d0) GOTO 666
2594 ENDDO
2595 666 CONTINUE
2596 j=j-1
2597 IF (id%KEEP(46) == 1) THEN
2598 idest = k - 1
2599 ELSE
2600 idest = k
2601 ENDIF
2602 IF (idest .NE. master) THEN
2603 CALL mpi_send(j,1,mpi_integer,idest,0,
2604 & id%COMM,ierr)
2605 CALL mpi_send(temp_mem(1,k),j,mpi_double_precision,
2606 & idest, 0, id%COMM,ierr)
2607 CALL mpi_send(temp_leaf(1,k),j,mpi_integer,
2608 & idest, 0, id%COMM,ierr)
2609 CALL mpi_send(temp_size(1,k),j,mpi_integer,
2610 & idest, 0, id%COMM,ierr)
2611 CALL mpi_send(temp_root(1,k),j,mpi_integer,
2612 & idest, 0, id%COMM,ierr)
2613 ELSE
2614 IF(associated(id%MEM_SUBTREE)) THEN
2615 DEALLOCATE(id%MEM_SUBTREE)
2616 ENDIF
2617 allocate(id%MEM_SUBTREE(j),stat=allocok)
2618 IF (allocok .ne.0) then
2619 IF ( lpok ) THEN
2620 WRITE(lp, 150) 'id%MEM_SUBTREE'
2621 END IF
2622 info(1)= -7
2623 info(2)= j
2624 GOTO 87
2625 END IF
2626 id%NBSA_LOCAL = j
2627 id%MEM_SUBTREE(1:j)=temp_mem(1:j,1)
2628 IF(associated(id%MY_ROOT_SBTR)) THEN
2629 DEALLOCATE(id%MY_ROOT_SBTR)
2630 ENDIF
2631 allocate(id%MY_ROOT_SBTR(j),stat=allocok)
2632 IF (allocok .ne.0) then
2633 IF ( lpok ) THEN
2634 WRITE(lp, 150) 'id%MY_ROOT_SBTR'
2635 END IF
2636 info(1)= -7
2637 info(2)= j
2638 GOTO 87
2639 END IF
2640 id%MY_ROOT_SBTR(1:j)=temp_root(1:j,1)
2641 IF(associated(id%MY_FIRST_LEAF)) THEN
2642 DEALLOCATE(id%MY_FIRST_LEAF)
2643 ENDIF
2644 allocate(id%MY_FIRST_LEAF(j),stat=allocok)
2645 IF (allocok .ne.0) then
2646 IF ( lpok ) THEN
2647 WRITE(lp, 150) 'id%MY_FIRST_LEAF'
2648 END IF
2649 info(1)= -7
2650 info(2)= j
2651 GOTO 87
2652 END IF
2653 id%MY_FIRST_LEAF(1:j)=temp_leaf(1:j,1)
2654 IF(associated(id%MY_NB_LEAF)) THEN
2655 DEALLOCATE(id%MY_NB_LEAF)
2656 ENDIF
2657 allocate(id%MY_NB_LEAF(j),stat=allocok)
2658 IF (allocok .ne.0) then
2659 IF ( lpok ) THEN
2660 WRITE(lp, 150) 'id%MY_NB_LEAF'
2661 END IF
2662 info(1)= -7
2663 info(2)= j
2664 GOTO 87
2665 END IF
2666 id%MY_NB_LEAF(1:j)=temp_size(1:j,1)
2667 ENDIF
2668 ENDDO
2669 ELSE
2670 CALL mpi_recv(id%NBSA_LOCAL,1,mpi_integer,
2671 & master,0,id%COMM,status, ierr)
2672 IF(associated(id%MEM_SUBTREE)) THEN
2673 DEALLOCATE(id%MEM_SUBTREE)
2674 ENDIF
2675 allocate(id%MEM_SUBTREE(id%NBSA_LOCAL),stat=allocok)
2676 IF (allocok .ne.0) then
2677 IF ( lpok ) THEN
2678 WRITE(lp, 150) 'id%MEM_SUBTREE'
2679 END IF
2680 info(1)= -7
2681 info(2)= id%NBSA_LOCAL
2682 GOTO 87
2683 END IF
2684 IF(associated(id%MY_ROOT_SBTR)) THEN
2685 DEALLOCATE(id%MY_ROOT_SBTR)
2686 ENDIF
2687 allocate(id%MY_ROOT_SBTR(id%NBSA_LOCAL),stat=allocok)
2688 IF (allocok .ne.0) then
2689 IF ( lpok ) THEN
2690 WRITE(lp, 150) 'id%MY_ROOT_SBTR'
2691 END IF
2692 info(1)= -7
2693 info(2)= id%NBSA_LOCAL
2694 GOTO 87
2695 END IF
2696 IF(associated(id%MY_FIRST_LEAF)) THEN
2697 DEALLOCATE(id%MY_FIRST_LEAF)
2698 ENDIF
2699 allocate(id%MY_FIRST_LEAF(id%NBSA_LOCAL),stat=allocok)
2700 IF (allocok .ne.0) then
2701 IF ( lpok ) THEN
2702 WRITE(lp, 150) 'MY_FIRST_LEAF'
2703 END IF
2704 info(1)= -7
2705 info(2)= id%NBSA_LOCAL
2706 GOTO 87
2707 END IF
2708 IF(associated(id%MY_NB_LEAF)) THEN
2709 DEALLOCATE(id%MY_NB_LEAF)
2710 ENDIF
2711 allocate(id%MY_NB_LEAF(id%NBSA_LOCAL),stat=allocok)
2712 IF (allocok .ne.0) then
2713 IF ( lpok ) THEN
2714 WRITE(lp, 150) 'MY_NB_LEAF'
2715 END IF
2716 info(1)= -7
2717 info(2)= id%NBSA_LOCAL
2718 GOTO 87
2719 END IF
2720 CALL mpi_recv(id%MEM_SUBTREE(1),id%NBSA_LOCAL,
2721 & mpi_double_precision,master,0,
2722 & id%COMM,status,ierr)
2723 CALL mpi_recv(id%MY_FIRST_LEAF(1),id%NBSA_LOCAL,
2724 & mpi_integer,master,0,
2725 & id%COMM,status,ierr)
2726 CALL mpi_recv(id%MY_NB_LEAF(1),id%NBSA_LOCAL,
2727 & mpi_integer,master,0,
2728 & id%COMM,status,ierr)
2729 CALL mpi_recv(id%MY_ROOT_SBTR(1),id%NBSA_LOCAL,
2730 & mpi_integer,master,0,
2731 & id%COMM,status,ierr)
2732 ENDIF
2733 ELSE
2734 id%NBSA_LOCAL = -999999
2735 IF(associated(id%MEM_SUBTREE)) THEN
2736 DEALLOCATE(id%MEM_SUBTREE)
2737 ENDIF
2738 allocate(id%MEM_SUBTREE(1),stat=allocok)
2739 IF (allocok .ne.0) then
2740 IF ( lpok ) THEN
2741 WRITE(lp, 150) 'id%MEM_SUBTREE(1)'
2742 END IF
2743 info(1)= -7
2744 info(2)= 1
2745 GOTO 87
2746 END IF
2747 IF(associated(id%MY_ROOT_SBTR)) THEN
2748 DEALLOCATE(id%MY_ROOT_SBTR)
2749 ENDIF
2750 allocate(id%MY_ROOT_SBTR(1),stat=allocok)
2751 IF (allocok .ne.0) then
2752 IF ( lpok ) THEN
2753 WRITE(lp, 150) 'id%MY_ROOT_SBTR(1)'
2754 END IF
2755 info(1)= -7
2756 info(2)= 1
2757 GOTO 87
2758 END IF
2759 IF(associated(id%MY_FIRST_LEAF)) THEN
2760 DEALLOCATE(id%MY_FIRST_LEAF)
2761 ENDIF
2762 allocate(id%MY_FIRST_LEAF(1),stat=allocok)
2763 IF (allocok .ne.0) then
2764 IF ( lpok ) THEN
2765 WRITE(lp, 150) 'id%MY_FIRST_LEAF(1)'
2766 END IF
2767 info(1)= -7
2768 info(2)= 1
2769 GOTO 87
2770 END IF
2771 IF(associated(id%MY_NB_LEAF)) THEN
2772 DEALLOCATE(id%MY_NB_LEAF)
2773 ENDIF
2774 allocate(id%MY_NB_LEAF(1),stat=allocok)
2775 IF (allocok .ne.0) then
2776 IF ( lpok ) THEN
2777 WRITE(lp, 150) 'id%MY_NB_LEAF(1)'
2778 END IF
2779 info(1)= -7
2780 info(2)= 1
2781 GOTO 87
2782 END IF
2783 ENDIF
2784 IF(id%MYID.EQ.master)THEN
2785 IF(is_build_load_mem_called)THEN
2786 DEALLOCATE(temp_mem)
2787 DEALLOCATE(temp_size)
2788 DEALLOCATE(temp_root)
2789 DEALLOCATE(temp_leaf)
2790 DEALLOCATE(cost_trav_tmp)
2791 DEALLOCATE(depth_first)
2792 DEALLOCATE(depth_first_seq)
2793 DEALLOCATE(sbtr_id)
2794 ENDIF
2795 ENDIF
2796 87 CONTINUE
2797 CALL mumps_propinfo( icntl(1), info(1),
2798 & id%COMM, id%MYID )
2799 IF ( info(1).LT.0 ) GOTO 500
2800C
2801 nb_niv2 = keep(56) ! KEEP(1:110) was broadcast earlier
2802C NB_NIV2 is now available on all processors.
2803 IF ( nb_niv2.GT.0 ) THEN
2804C Allocate arrays on slaves
2805 if (id%MYID.ne.master) then
2806 IF (associated(id%CANDIDATES)) THEN
2807 DEALLOCATE(id%CANDIDATES)
2808 ENDIF
2809 allocate(par2_nodes(nb_niv2),
2810 & id%CANDIDATES(id%NSLAVES+1,nb_niv2),
2811 & stat=allocok)
2812 IF (allocok .ne.0) then
2813 info(1)= -7
2814 info(2)= nb_niv2*(id%NSLAVES+1)
2815 IF ( lpok ) THEN
2816 WRITE(lp, 150) 'PAR2_NODES/id%CANDIDATES'
2817 END IF
2818 end if
2819 end if
2820 CALL mumps_propinfo( icntl(1), info(1),
2821 & id%COMM, id%MYID )
2822 IF ( info(1).LT.0 ) GOTO 500
2823 CALL mpi_bcast(par2_nodes(1),nb_niv2,
2824 & mpi_integer, master, id%COMM, ierr )
2825 IF (keep(24) .NE.0 ) THEN
2826 CALL mpi_bcast(id%CANDIDATES(1,1),
2827 & (nb_niv2*(id%NSLAVES+1)),
2828 & mpi_integer, master, id%COMM, ierr )
2829 ENDIF
2830 ENDIF
2831 IF ( associated(id%ISTEP_TO_INIV2)) THEN
2832 DEALLOCATE(id%ISTEP_TO_INIV2)
2833 NULLIFY(id%ISTEP_TO_INIV2)
2834 ENDIF
2835 IF ( associated(id%I_AM_CAND)) THEN
2836 DEALLOCATE(id%I_AM_CAND)
2837 NULLIFY(id%I_AM_CAND)
2838 ENDIF
2839 IF (nb_niv2.EQ.0) THEN
2840C allocate dummy arrays
2841C ISTEP_TO_INIV2 will never be used
2842C Add a parameter SIZE_ISTEP_TO_INIV2 and make
2843C it always available in a keep(71)
2844 id%KEEP(71) = 1
2845 ELSE
2846 id%KEEP(71) = id%KEEP(28)
2847 ENDIF
2848 allocate(id%ISTEP_TO_INIV2(id%KEEP(71)),
2849 & id%I_AM_CAND(max(nb_niv2,1)),
2850 & stat=allocok)
2851 IF (allocok .gt.0) THEN
2852 IF ( lpok ) THEN
2853 WRITE(lp, 150) 'id%ISTEP_TO_INIV2'
2854 WRITE(lp, 150) 'id%TAB_POS_IN_PERE'
2855 END IF
2856 info(1)= -7
2857 IF (nb_niv2.EQ.0) THEN
2858 info(2)= 2
2859 ELSE
2860 info(2)= id%KEEP(28)+nb_niv2*(id%NSLAVES+2)
2861 END IF
2862 GOTO 321
2863 ENDIF
2864 IF ( nb_niv2 .GT.0 ) THEN
2865C If BLR grouping was performed then PAR2_NODES(INIV2)
2866C might then point to a non principal variable
2867C for which STEP might be negative
2868C
2869 id%ISTEP_TO_INIV2 = -9999
2870 DO iniv2 = 1, nb_niv2
2871 inn = par2_nodes(iniv2)
2872 id%ISTEP_TO_INIV2(abs(id%STEP(inn))) = iniv2
2873 END DO
2874 CALL smumps_build_i_am_cand( id%NSLAVES, keep(79),
2875 & nb_niv2, id%MYID_NODES,
2876 & id%CANDIDATES(1,1), id%I_AM_CAND(1) )
2877 ENDIF
2878 IF ( i_am_slave ) THEN
2879 IF (associated(id%FUTURE_NIV2)) THEN
2880 DEALLOCATE(id%FUTURE_NIV2)
2881 NULLIFY(id%FUTURE_NIV2)
2882 ENDIF
2883 allocate(id%FUTURE_NIV2(id%NSLAVES), stat=allocok)
2884 IF (allocok .gt.0) THEN
2885 IF ( lpok ) THEN
2886 WRITE(lp, 150) 'FUTURE_NIV2'
2887 END IF
2888 info(1)= -7
2889 info(2)= id%NSLAVES
2890 GOTO 321
2891 ENDIF
2892 id%FUTURE_NIV2=0
2893 DO iniv2 = 1, nb_niv2
2894 idest = mumps_procnode(
2895 & id%PROCNODE_STEPS(abs(id%STEP(par2_nodes(iniv2)))),
2896 & id%KEEP(199))
2897 id%FUTURE_NIV2(idest+1)=id%FUTURE_NIV2(idest+1)+1
2898 ENDDO
2899C Allocate id%TAB_POS_IN_PERE,
2900C TAB_POS_IN_PERE is an array of size (id%NSLAVES+2,NB_NIV2)
2901C where NB_NIV2 is the number of type 2 nodes in the tree.
2902 IF ( associated(id%TAB_POS_IN_PERE)) THEN
2903 DEALLOCATE(id%TAB_POS_IN_PERE)
2904 NULLIFY(id%TAB_POS_IN_PERE)
2905 ENDIF
2906 allocate(id%TAB_POS_IN_PERE(id%NSLAVES+2,max(nb_niv2,1)),
2907 & stat=allocok)
2908 IF (allocok .gt.0) THEN
2909 IF ( lpok ) THEN
2910 WRITE(lp, 150) 'id%ISTEP_TO_INIV2'
2911 WRITE(lp, 150) 'id%TAB_POS_IN_PERE'
2912 END IF
2913 info(1)= -7
2914 IF (nb_niv2.EQ.0) THEN
2915 info(2)= 2
2916 ELSE
2917 info(2)= id%KEEP(28)+nb_niv2*(id%NSLAVES+2)
2918 END IF
2919 GOTO 321
2920 ENDIF
2921 END IF
2922C deallocate PAR2_NODES that was computed
2923C on master and broadcasted on all slaves
2924 IF (nb_niv2.GT.0) DEALLOCATE (par2_nodes)
2925 321 CONTINUE
2926C ----------------
2927C Check for errors
2928C ----------------
2929 CALL mumps_propinfo( icntl(1), info(1),
2930 & id%COMM, id%MYID )
2931 IF ( info(1).LT.0 ) GOTO 500
2932C
2933 IF ( keep(38) .NE. 0 ) THEN
2934C -------------------------
2935C Initialize root structure
2936C -------------------------
2937 CALL smumps_init_root_ana( id%MYID,
2938 & id%NSLAVES, id%N, id%root,
2939 & id%COMM_NODES, keep( 38 ), id%FILS(1),
2940 & id%KEEP(50), id%KEEP(46),
2941 & id%KEEP(51)
2942 & , id%KEEP(60), id%NPROW, id%NPCOL, id%MBLOCK, id%NBLOCK
2943 & )
2944 ELSE
2945 id%root%yes = .false.
2946 END IF
2947 IF ( keep(38) .NE. 0 .and. i_am_slave ) THEN
2948C -----------------------------------------------
2949C Check if at least one processor belongs to the
2950C root. In the case where all of them have MYROW
2951C equal to -1, this could be a problem due to the
2952C BLACS. (mpxlf90_r and IBM BLACS).
2953C -----------------------------------------------
2954 CALL mpi_allreduce(id%root%MYROW, myrow_check, 1,
2955 & mpi_integer, mpi_max, id%COMM_NODES, ierr)
2956 IF ( myrow_check .eq. -1) THEN
2957 info(1) = -25
2958 info(2) = 0
2959 END IF
2960 IF ( id%root%MYROW .LT. -1 .OR.
2961 & id%root%MYCOL .LT. -1 ) THEN
2962 info(1) = -25
2963 info(2) = 0
2964 END IF
2965 IF ( lpok .AND. info(1) == -25 ) THEN
2966 WRITE(lp, '(A)')
2967 & 'Problem with your version of the BLACS.'
2968 WRITE(lp, '(A)') 'Try using a BLACS version from netlib.'
2969 ENDIF
2970 END IF
2971C ----------------
2972C Check for errors
2973C ----------------
2974 CALL mumps_propinfo( icntl(1), info(1),
2975 & id%COMM, id%MYID )
2976 IF ( info(1).LT.0 ) GOTO 500
2977 IF ( i_am_slave ) THEN
2978C{
2979C
2980C
2981 IF (keep(55) .EQ. 0) THEN
2982 CALL smumps_ana_dist_arrowheads( id%MYID,
2983 & id%NSLAVES, id%N, id%PROCNODE_STEPS(1),
2984 & id%STEP(1), id%PTRAR(1),
2985 & id%PTRAR(id%N +1),
2986 & id%ISTEP_TO_INIV2(1), id%I_AM_CAND(1),
2987 & keep(1),keep8(1), icntl(1), id )
2988 ELSE
2989 CALL smumps_ana_dist_elements( id%MYID,
2990 & id%NSLAVES, id%N, id%PROCNODE_STEPS(1),
2991 & id%STEP(1),
2992 & id%PTRAR(1),
2993 & id%PTRAR(id%NELT+2 ),
2994 & id%NELT,
2995 & id%FRTPTR(1), id%FRTELT(1),
2996 & keep(1), keep8(1), icntl(1), id%KEEP(50) )
2997 ENDIF
2998C}
2999 ENDIF
3000C -----------------------------------------
3001C Perform some local analysis on the slaves
3002C to estimate the size of the working space
3003C for factorization
3004C -----------------------------------------
3005 IF ( i_am_slave ) THEN
3006C{
3007 loci_am_cand => id%I_AM_CAND
3008 locmyid_nodes = id%MYID_NODES
3009 locmyid = id%MYID
3010C ===================================================
3011C Precompute estimates of local_m,local_n
3012C (number of rows/columns mapped on each processor)
3013C in case of parallel root node.
3014C and allocate CANDIDATES
3015C ===================================================
3016C
3017 IF ( id%root%yes ) THEN
3018 local_m = numroc( id%ND_STEPS(id%STEP(keep(38))),
3019 & id%root%MBLOCK, id%root%MYROW, 0,
3020 & id%root%NPROW )
3021 local_m = max(1, local_m)
3022 local_n = numroc( id%ND_STEPS(id%STEP(keep(38))),
3023 & id%root%NBLOCK, id%root%MYCOL, 0,
3024 & id%root%NPCOL )
3025 ELSE
3026 local_m = 0
3027 local_n = 0
3028 END IF
3029 IF ( keep(60) .EQ. 2 .OR. keep(60) .EQ. 3 ) THEN
3030C Return minimum nb rows/cols to user
3031 id%SCHUR_MLOC=local_m
3032 id%SCHUR_NLOC=local_n
3033C Also store them in root structure for convenience
3034 id%root%SCHUR_MLOC=local_m
3035 id%root%SCHUR_NLOC=local_n
3036 ENDIF
3037 IF ( .NOT. associated(id%CANDIDATES)) THEN
3038 ALLOCATE(id%CANDIDATES(id%NSLAVES+1,1), stat=allocok)
3039 IF (allocok .gt.0) THEN
3040 IF ( lpok ) THEN
3041 WRITE(lp, 150) 'CANDIDATES'
3042 END IF
3043 info(1)= -7
3044 info(2)= id%NSLAVES+1
3045 ENDIF
3046 ENDIF
3047C}
3048 ENDIF
3049 CALL mumps_propinfo( icntl(1), info(1),
3050 & id%COMM, id%MYID )
3051 IF ( info(1).LT.0 ) GOTO 500
3052 IF (keep(400) .GT. 0 ) THEN ! L0 activated
3053C{
3054 IF ( i_am_slave ) THEN
3055C{
3056C =================================================
3057C Build L0_OMP layer and compute memory estimations
3058C under L0_OMP and data needed to estimate memory
3059C above L0_OMP
3060C =================================================
3061C
3062 CALL mumps_ana_l0_omp(
3063 & keep(400), id%N, keep(28),
3064 & keep(50), id%NSLAVES, id%DAD_STEPS, id%FRERE_STEPS,
3065 & id%FILS, id%NE_STEPS, id%ND_STEPS, id%STEP,
3066 & id%PROCNODE_STEPS, keep, keep8, locmyid_nodes,
3067 & id%NA, id%LNA, "SMUMPS"(1:1),
3068 & id%LPOOL_B_L0_OMP, id%IPOOL_B_L0_OMP,
3069 & id%LPOOL_A_L0_OMP, id%IPOOL_A_L0_OMP,
3070 & id%L_VIRT_L0_OMP,id%VIRT_L0_OMP, id%VIRT_L0_OMP_MAPPING,
3071 & id%L_PHYS_L0_OMP,id%PHYS_L0_OMP, id%PERM_L0_OMP,
3072 & id%PTR_LEAFS_L0_OMP, id%THREAD_LA, id%INFO, id%ICNTL)
3073 IF (id%INFO(1) .GE. 0) THEN
3074 ALLOCATE(
3075 & id%I4_L0_OMP(nbstats_i4, keep(400)),
3076 & id%I8_L0_OMP(nbstats_i8, keep(400)),
3077 & tnstk_afterl0(keep(28)),
3078 & stat=allocok)
3079 IF (allocok .gt.0) THEN
3080 IF ( lpok ) THEN
3081 WRITE(lp, 150) 'l0_omp stats'
3082 END IF
3083 INFO(1)= -7
3084 INFO(2)= NBSTATS_I4* KEEP(400) +
3085 & NBSTATS_I8* KEEP(400)*KEEP(10)
3086 & + KEEP(28)
3087 ENDIF
3088 ENDIF
3089C}
3090 ENDIF
3091 CALL MUMPS_PROPINFO( ICNTL(1), INFO(1),
3092 & id%COMM, id%MYID )
3093.LT. IF ( INFO(1)0 ) GOTO 500
3094 IF ( I_AM_SLAVE ) THEN
3095 CALL SMUMPS_ANA_DISTM_UNDERL0OMP(
3096 & id%LPOOL_B_L0_OMP, id%IPOOL_B_L0_OMP(1),
3097 & id%L_VIRT_L0_OMP,
3098 & id%VIRT_L0_OMP(1), id%VIRT_L0_OMP_MAPPING(1),
3099 & id%L_PHYS_L0_OMP, id%PHYS_L0_OMP(1), id%PERM_L0_OMP(1),
3100 & id%PTR_LEAFS_L0_OMP(1),
3101 & id%KEEP(1), id%N, id%NE_STEPS(1), id%STEP(1),
3102 & id%FRERE_STEPS(1), id%FILS(1), id%DAD_STEPS(1),
3103 & id%ND_STEPS(1),
3104 & locMYID_NODES, id%PROCNODE_STEPS(1),
3105 & id%I4_L0_OMP(1,1), NBSTATS_I4,
3106 & id%I8_L0_OMP(1,1), NBSTATS_I8, KEEP(400),
3107C To be used to adjust outputs ABOVE_L0OMP
3108 & SIZECB_UNDER_L0, SIZECB_UNDER_L0_IF_LRCB,
3109 & TNSTK_afterL0, MAXFR_UNDER_L0,
3110 & MAX_FRONT_SURFACE_LOCAL_L0, MAX_SIZE_FACTOR_L0,
3111 & ENTRIES_IN_FACTORS_UNDER_L0,
3112 & ENTRIES_IN_FACTORS_MASTERS_LO,
3113 & COST_SUBTREES_UNDER_L0, OPSA_UNDER_L0,
3114C
3115 & INFO(1), INFO(2)
3116 & )
3117 ENDIF
3118C} else of L0 activated
3119 ELSE
3120C{
3121 IF ( I_AM_SLAVE ) THEN
3122 id%LPOOL_B_L0_OMP = 1
3123 id%LPOOL_A_L0_OMP = 1
3124 id%L_VIRT_L0_OMP = 1
3125 id%L_PHYS_L0_OMP = 1
3126 id%THREAD_LA = -1_8
3127 ALLOCATE ( id%VIRT_L0_OMP ( id%L_VIRT_L0_OMP ),
3128 & id%VIRT_L0_OMP_MAPPING ( id%L_VIRT_L0_OMP ),
3129 & id%PERM_L0_OMP ( id%L_PHYS_L0_OMP ),
3130 & id%PTR_LEAFS_L0_OMP ( id%L_PHYS_L0_OMP + 1 ),
3131 & id%IPOOL_B_L0_OMP ( id%LPOOL_B_L0_OMP ),
3132 & id%IPOOL_A_L0_OMP ( id%LPOOL_A_L0_OMP ),
3133 & id%PHYS_L0_OMP( id%L_PHYS_L0_OMP ),
3134 & id%I4_L0_OMP(1,1), id%I8_L0_OMP(1,1), stat=allocok)
3135.gt. IF (allocok 0) THEN
3136 IF ( LPOK ) THEN
3137 WRITE(LP, 150) 'allocation error in multicore'
3138 END IF
3139 INFO(1)= -7
3140 INFO(2)= id%L_VIRT_L0_OMP
3141 & + id%L_PHYS_L0_OMP
3142 & + id%L_PHYS_L0_OMP + 1
3143 & + id%LPOOL_B_L0_OMP
3144 & + id%LPOOL_A_L0_OMP
3145 & + id%L_PHYS_L0_OMP + 1 + KEEP(10)
3146 ENDIF
3147 ENDIF
3148C}
3149 ENDIF
3150 CALL MUMPS_PROPINFO( ICNTL(1), INFO(1),
3151 & id%COMM, id%MYID )
3152.LT. IF ( INFO(1)0 ) GOTO 500
3153C -- Allocate and initialise IPOOL with leaves
3154C -- on which stats are performed
3155 IF ( I_AM_SLAVE ) THEN
3156C{
3157.GT. IF (KEEP(400)0) THEN
3158C{
3159.GT. IF (id%NSLAVES 1) THEN
3160C FLAGGED_LEVAES will be used during
3161C SMUMPS_PREP_ANA_DISTM_ABOVEL0
3162 ALLOCATE (FLAGGED_LEAVES(KEEP(28)),
3163 & stat=allocok)
3164.gt. IF (allocok 0) THEN
3165 IF ( LPOK ) THEN
3166 WRITE(LP, 150) 'l0_omp flagged leaves'
3167 END IF
3168 INFO(1)= -7
3169 INFO(2)= KEEP(28)
3170 ENDIF
3171 ENDIF
3172C}
3173 ENDIF
3174C}
3175 ENDIF
3176 CALL MUMPS_PROPINFO( ICNTL(1), INFO(1),
3177 & id%COMM, id%MYID )
3178.LT. IF ( INFO(1)0 ) GOTO 500
3179 IF ( I_AM_SLAVE ) THEN
3180C{
3181.GT. IF (KEEP(400)0) THEN
3182C{
3183.GT. IF (id%NSLAVES 1) THEN
3184 ! LIPOOL_local can be 0
3185 LIPOOL_local=
3186 & id%IPOOL_A_L0_OMP(id%LPOOL_A_L0_OMP)
3187C ---------------------------------------------
3188C Pool information from other MPI proc neeeded
3189C (union of IPOOL_A_L0_OMP of all MPI procs)
3190C ---------------------------------------------
3191 CALL SMUMPS_PREP_ANA_DISTM_ABOVEL0(
3192 & id%N, id%NSLAVES, id%COMM_NODES, id%MYID_NODES,
3193 & id%STEP(1), id%DAD_STEPS(1),id%ICNTL,LP,LPOK,
3194 & id%INFO,
3195 & id%PHYS_L0_OMP(1), id%L_PHYS_L0_OMP,
3196 & id%IPOOL_A_L0_OMP(1), LIPOOL_local,
3197 & id%KEEP, TNSTK_afterL0,
3198 & FLAGGED_LEAVES
3199 & )
3200C
3201.LT. IF ( INFO(1)0 ) GOTO 75
3202C
3203 LIPOOL= 0
3204 DO ISTEP=1,KEEP(28)
3205C Non zero entries are leaf nodes
3206.GT. IF (FLAGGED_LEAVES(ISTEP)0) LIPOOL=LIPOOL+1
3207 ENDDO
3208 ELSE
3209C last entry in pool is its size
3210 LIPOOL = id%IPOOL_A_L0_OMP(id%LPOOL_A_L0_OMP)
3211 ENDIF
3212C}
3213 ELSE
3214 LIPOOL = id%NA(1)
3215 ENDIF
3216C LIPOOL is number of leaf nodes and can be 0
3217C (for ex AboveL0 with nbthreads is 1)
3218 ALLOCATE( IPOOL(max(LIPOOL,1)),
3219 & stat=allocok)
3220.gt. IF (allocok 0) THEN
3221 IF ( LPOK ) THEN
3222 WRITE(LP, 150) 'allocation ipool'
3223 END IF
3224 INFO(1)= -7
3225 INFO(2)= LIPOOL
3226 ENDIF
3227C}
3228 ENDIF
3229 75 CONTINUE
3230 CALL MUMPS_PROPINFO( ICNTL(1), INFO(1),
3231 & id%COMM, id%MYID )
3232.LT. IF ( INFO(1)0 ) GOTO 500
3233C
3234 IF ( I_AM_SLAVE ) THEN
3235C{
3236.GT. IF (KEEP(400) 0 ) THEN ! L0 activated
3237C{
3238.GT. IF (LIPOOL0) THEN
3239.GT. IF (id%NSLAVES 1) THEN
3240C first leaf in postorder is at the top of the pool
3241 I =LIPOOL
3242 DO ISTEP=1, KEEP(28)
3243.GT. IF (FLAGGED_LEAVES(ISTEP)0) THEN
3244C FLAGGED_LEAVES(ISTEP) hold inode
3245C that is a leaf of tree above L0_OMP
3246C Entries are stored in order with respect
3247C to STEP
3248 IPOOL(I) = FLAGGED_LEAVES(ISTEP)
3249 I=I-1
3250 ENDIF
3251C -- all leaves found and added
3252.EQ. IF (I0) CYCLE
3253 ENDDO
3254 DEALLOCATE(FLAGGED_LEAVES)
3255 ELSE
3256 DO I=1, LIPOOL
3257 IPOOL(I) = id%IPOOL_A_L0_OMP(I)
3258 ENDDO
3259 ENDIF
3260 ENDIF
3261C
3262 ABOVE_L0 =.TRUE.
3263 NE_STEPSPTR => TNSTK_afterL0(1:KEEP(28))
3264C}
3265 ELSE
3266C Initialize IPOOL with leaves of complete tree
3267 DO I=1, LIPOOL
3268 IPOOL(I) = id%NA(3+I-1)
3269 ENDDO
3270 ABOVE_L0 =.FALSE.
3271 SIZECB_UNDER_L0 = 0_8
3272 SIZECB_UNDER_L0_IF_LRCB = 0_8
3273 MAX_FRONT_SURFACE_LOCAL_L0 = 0_8
3274 MAX_SIZE_FACTOR_L0 = 0_8
3275 ENTRIES_IN_FACTORS_UNDER_L0= 0_8
3276 ENTRIES_IN_FACTORS_MASTERS_LO = 0_8
3277 MAXFR_UNDER_L0 = 0
3278 COST_SUBTREES_UNDER_L0 = 0.0D0
3279 OPSA_UNDER_L0 = 0.0D0
3280C
3281 NE_STEPSPTR => id%NE_STEPS
3282 ENDIF
3283 KEEP(139) = MAXFR_UNDER_L0
3284C
3285 CALL SMUMPS_ANA_DISTM( locMYID_NODES, id%N, id%STEP(1),
3286 & id%FRERE_STEPS(1), id%FILS(1), IPOOL, LIPOOL, NE_STEPSPTR(1),
3287 & id%DAD_STEPS(1), id%ND_STEPS(1), id%PROCNODE_STEPS(1),
3288 & id%NSLAVES, ABOVE_L0,SIZECB_UNDER_L0,SIZECB_UNDER_L0_IF_LRCB,
3289 & MAXFR_UNDER_L0, MAX_FRONT_SURFACE_LOCAL_L0, MAX_SIZE_FACTOR_L0,
3290 & ENTRIES_IN_FACTORS_UNDER_L0, ENTRIES_IN_FACTORS_MASTERS_LO,
3291 & COST_SUBTREES_UNDER_L0, OPSA_UNDER_L0, KEEP8(53), KEEP8(54),
3292 & KEEP8(11), KEEP(26), KEEP(15), KEEP8(12), KEEP8(14),
3293 & KEEP8(32), KEEP8(33), KEEP8(34), KEEP8(35), KEEP8(50),
3294 & KEEP8(36), KEEP8(47), KEEP8(37), KEEP8(38), KEEP8(39),
3295 & KEEP8(40), KEEP8(41), KEEP8(42), KEEP8(43), KEEP8(44), KEEP8(45),
3296 & KEEP8(46), KEEP8(51), KEEP8(52), KEEP(224),KEEP(225),KEEP(27),
3297 & RINFO(1),id%CNTL(1), KEEP(1), KEEP8(1), LOCAL_M, LOCAL_N,
3298 & SBUF_RECOLD8, SBUF_SEND_FR, SBUF_REC_FR, SBUF_SEND_LR,
3299 & SBUF_REC_LR, id%COST_SUBTREES, KEEP(28), locI_AM_CAND(1),
3300 & max(KEEP(56),1), id%ISTEP_TO_INIV2(1), id%CANDIDATES(1,1),
3301 & INFO(1), INFO(2), KEEP8(15),MAX_SIZE_FACTOR_TMP,
3302 & KEEP8(9), ENTRIES_IN_FACTORS_LOC_MASTERS,
3303 & id%root%yes, id%root%NPROW, id%root%NPCOL
3304 & )
3305 IF (ALLOCATED(IPOOL)) DEALLOCATE(IPOOL)
3306 NULLIFY(NE_STEPSPTR)
3307.GT. IF (KEEP(400) 0) THEN ! L0 activated
3308C{
3309 DEALLOCATE (TNSTK_afterL0)
3310C =============================================
3311C Postprocess statistics with data below L0_OMP
3312C =============================================
3313C compute sums under L0
3314 SUM_NIRNEC = 0
3315 SUM_NIRADU = 0
3316 SUM_NIRADU_OOC = 0
3317 SUM_NIRNEC_OOC = 0
3318 DO I=1, KEEP(400)
3319 SUM_NIRADU = SUM_NIRADU + id%I4_L0_OMP(1,I)
3320 SUM_NIRNEC = SUM_NIRNEC + id%I4_L0_OMP(2,I)
3321 SUM_NIRADU_OOC = SUM_NIRADU_OOC+ id%I4_L0_OMP(3,I)
3322 SUM_NIRNEC_OOC = SUM_NIRNEC_OOC+ id%I4_L0_OMP(4,I)
3323 ENDDO
3324C Update NIRADU above L0
3325 KEEP(26) = KEEP(26) + SUM_NIRADU
3326C Update NIRADU_OOC above L0
3327 KEEP(224) = KEEP(224) + SUM_NIRADU_OOC
3328C Update NIRNEC aboveL0= max(NIRNEC, NIRADU+SUM_NIRADU)
3329 KEEP(15) = max(KEEP(15),KEEP(26))
3330C Update NIRNEC_OOC aboveL0= max(NIRNEC,
3331C NIRADU_OOC+SUM_NIRADU_OOC)
3332 KEEP(225) = max(KEEP(225),KEEP(224))
3333C save SUM_NIRNEC underL0 to be used in SMUMPS_MAX_MEM
3334 KEEP(137) = SUM_NIRNEC
3335C save SUM_NIRNEC_OOC underL0 to be used in SMUMPS_MAX_MEM
3336 KEEP(138) = SUM_NIRNEC_OOC
3337C
3338 SUM_NIRNEC = int(
3339 & (REAL(SUM_NIRNEC)*REAL(KEEP(34)))/REAL(KEEP(35))
3340 & )
3341 SUM_NIRNEC_OOC = int(
3342 & (REAL(SUM_NIRNEC_OOC)*REAL(KEEP(34)))/REAL(KEEP(35))
3343 & )
3344C
3345C Memory peaks to be updated to take
3346C into account factors under L0_OMP
3347 MAX_NRLADU = 0_8
3348 MIN_NRLADU = id%I8_L0_OMP(1,1)
3349 SUM_NRLADU = 0_8
3350 SUM_NRLNEC = 0_8
3351 MIN_NRLNEC = huge(MIN_NRLNEC)
3352 SUM_NRLNEC_ACTIVE = 0_8
3353 SUM_NRLADU_if_LR_LU = 0_8
3354 SUM_NRLADULR_UD = 0_8
3355 SUM_NRLADULR_WC = 0_8
3356 DO I=1, KEEP(400)
3357 MIN_NRLADU = min(MIN_NRLADU, id%I8_L0_OMP(1,I))
3358 MAX_NRLADU = max(MAX_NRLADU, id%I8_L0_OMP(1,I))
3359 SUM_NRLADU = SUM_NRLADU + id%I8_L0_OMP(1,I)
3360 SUM_NRLNEC = SUM_NRLNEC + id%I8_L0_OMP(2,I)
3361 MIN_NRLNEC = min(MIN_NRLNEC, id%I8_L0_OMP(2,I))
3362 SUM_NRLNEC_ACTIVE = SUM_NRLNEC_ACTIVE +
3363 & id%I8_L0_OMP(3,I)
3364 SUM_NRLADU_if_LR_LU = SUM_NRLADU_if_LR_LU +
3365 & id%I8_L0_OMP(4,I)
3366 SUM_NRLADULR_UD = SUM_NRLADULR_UD +
3367 & id%I8_L0_OMP(9,I)
3368 SUM_NRLADULR_WC = SUM_NRLADULR_WC +
3369 & id%I8_L0_OMP(10,I)
3370 ENDDO
3371C Save NRLADU above L0 (KEEP8(11)) in KEEP8(81)
3372C and then update KEEP8(11) (NRLADU) taking into account
3373C factors above and under L0 layer
3374 KEEP8(81) = KEEP8(11)
3375 KEEP8(11) = KEEP8(11) + SUM_NRLADU
3376C Save SUM_NRLADU_if_LR_LU above L0 (KEEP8(32)) in KEEP8(82)
3377C and then update KEEP8(32) (NRLADU_if_LR_LU) taking into account
3378C factors above and under L0 layer
3379 KEEP8(82) = KEEP8(32)
3380 KEEP8(32) = KEEP8(32) + SUM_NRLADU_if_LR_LU
3381C
3382C Note that RECV buffer should have been added
3383C to both PEAK_UNDER_L0 and PEAK_ABOVE_L0
3384 PEAK_UNDER_L0 = SUM_NRLNEC + MIN_NRLNEC +
3385 & int(
3386 & (REAL(id%N*KEEP(400))*REAL(KEEP(34)))/REAL(KEEP(35)),
3387 & 8)
3388C Estimate send buffer size
3389C and convert it in nb of reals
3390C (KEEP(43) and KEEP(44) not yet set)
3391C
3392C Convert SUM_NIRNEC SUM_NIRNEC_OOC into nb of reals
3393 PEAK_ABOVE_L0 = KEEP8(53)+ SUM_NRLADU +
3394 & ! SEND buffer
3395 & max ( int(
3396 & (REAL(SBUF_SEND_FR)*REAL(KEEP(34)))/REAL(KEEP(35))
3397 & , 8), 100000_8 ) +
3398 & ! MAXIS_above :
3399 & int(
3400 & (REAL(KEEP(15))*REAL(KEEP(34)))/REAL(KEEP(35)),
3401 & 8)
3402C FIXME PEAK_ABOVE_L0 replaced PEAK_WITHOUT_L0
3403C ===============================================
3404C Update memory peaks:
3405C - adding factors computed underL0
3406C - sum of peaks underL0 taking into account
3407C received buffer preallocated
3408C ===============================================
3409 KEEP8(53) = KEEP8(53)+ SUM_NRLADU
3410 KEEP8(40) = KEEP8(40)+
3411 & SUM_NRLADU_if_LR_LU + SUM_NRLADULR_UD
3412 KEEP8(41) = KEEP8(41)+ SUM_NRLADULR_UD
3413 KEEP8(42) = KEEP8(42)+ SUM_NRLADULR_WC
3414 KEEP8(43) = KEEP8(43)+
3415 & SUM_NRLADU_if_LR_LU + SUM_NRLADULR_UD
3416 KEEP8(44) = KEEP8(44)+
3417 & SUM_NRLADU_if_LR_LU + SUM_NRLADULR_WC
3418 KEEP8(45) = KEEP8(45)+ SUM_NRLADULR_UD
3419 KEEP8(46) = KEEP8(46)+ SUM_NRLADULR_WC
3420 KEEP8(51) = KEEP8(51)+ SUM_NRLADU
3421 KEEP8(52) = KEEP8(52)+ SUM_NRLADULR_UD
3422C}
3423 ELSE
3424C SUM_NIRNEC under L0 OMP
3425 KEEP(137)=0
3426C SUM_NIRNEC_OOC under L0 OMP
3427 KEEP(138)=0
3428 ENDIF
3429C DKEEP(15) is used for dynamic load balancing only
3430C it corresponds to the number of local operations
3431C (in Millions)
3432 id%DKEEP(15) = RINFO(1)/1000000.0
3433 IF(ASSOCIATED(locI_AM_CAND)) NULLIFY(locI_AM_CAND)
3434 id%MAX_SURF_MASTER = KEEP8(15)
3435C
3436 KEEP8(19)=MAX_SIZE_FACTOR_TMP
3437 KEEP( 29 ) = KEEP(15) + 3* max(KEEP(12),10)
3438 & * ( KEEP(15) / 100 + 1)
3439C Relaxed value of size of IS is not needed internally;
3440C we save it directly in INFO(19)
3441 INFO( 19 ) = KEEP(225) + 3* max(KEEP(12),10)
3442 & * ( KEEP(225) / 100 + 1)
3443C =================================
3444C Size of S (relaxed with ICNTL(14)
3445C ===========================
3446C size of S relaxed (FR, IC)
3447C ===========================
3448 KEEP8(13) = KEEP8(12) + int(KEEP(12),8) *
3449 & ( KEEP8(12) / 100_8 + 1_8 )
3450C size of S relaxed (FR or LR LU, OOC)
3451 KEEP8(17) = KEEP8(14) + int(KEEP(12),8) *
3452 & ( KEEP8(14) /100_8 +1_8)
3453C size of S relaxed (LR LU, IC)
3454 K8_33relaxed = KEEP8(33) + int(KEEP(12),8) *
3455 & ( KEEP8(33) /100_8 +1_8)
3456C size of S relaxed (LR LU+CB, OOC)
3457 K8_34relaxed = KEEP8(34) + int(KEEP(12),8) *
3458 & ( KEEP8(34) /100_8 +1_8)
3459C size of S relaxed (LR LU+CB, OOC)
3460 K8_35relaxed = KEEP8(35) + int(KEEP(12),8) *
3461 & ( KEEP8(35) /100_8 +1_8)
3462C size of S relaxed (LR CB, IC)
3463 K8_50relaxed = KEEP8(50) + int(KEEP(12),8) *
3464 & ( KEEP8(50) /100_8 +1_8)
3465C KEEP8( 22 ) is the OLD maximum size of receive buffer
3466C that includes CB related communications.
3467C KEEP( 43 ) : min size for send buffer
3468C KEEP( 44 ) : min size for receive buffer
3469C KEEP(43-44) kept for allocating buffers during
3470C factorization phase
3471 CALL MUMPS_ALLREDUCEI8 ( SBUF_RECOLD8, KEEP8(22), MPI_MAX,
3472 & id%COMM_NODES )
3473C We do a max with KEEP(27)=maxfront because for small
3474C buffers, we need at least one row of cb to be sent/
3475C received.
3476 SBUF_SEND_FR = max(SBUF_SEND_FR,KEEP(27))
3477 SBUF_SEND_LR = max(SBUF_SEND_LR,KEEP(27))
3478 SBUF_REC_FR = max(SBUF_REC_FR ,KEEP(27))
3479 SBUF_REC_LR = max(SBUF_REC_LR ,KEEP(27))
3480 CALL MPI_ALLREDUCE (SBUF_REC_FR, KEEP(44), 1,
3481 & MPI_INTEGER, MPI_MAX,
3482 & id%COMM_NODES, IERR)
3483 CALL MPI_ALLREDUCE (SBUF_REC_LR, KEEP(380), 1,
3484 & MPI_INTEGER, MPI_MAX,
3485 & id%COMM_NODES, IERR)
3486 IF (KEEP(48)==5) THEN
3487 KEEP(43) = KEEP(44)
3488 KEEP(379) = KEEP(380)
3489 ELSE
3490 KEEP(43)=SBUF_SEND_FR
3491 KEEP(379)=SBUF_SEND_LR
3492 ENDIF
3493C
3494 UPDATE_BUFFER = .TRUE.
3495C
3496 MIN_BUF_SIZE8 = KEEP8(22) / int(KEEP(238),8)
3497 MIN_BUF_SIZE8 = min(MIN_BUF_SIZE8,int(huge(I4),8))
3498 MIN_BUF_SIZE = int( MIN_BUF_SIZE8 )
3499 IF (UPDATE_BUFFER) THEN
3500C Send buffer
3501 KEEP(43) = max(KEEP(43), MIN_BUF_SIZE)
3502 KEEP(379) = max(KEEP(379), MIN_BUF_SIZE)
3503 ENDIF
3504.NE..OR. IF ( (KEEP(38)0) UPDATE_BUFFER) THEN
3505C Received buffer need be the same on all procs because of
3506C scalapack root
3507 KEEP(380) = max(KEEP(380), MIN_BUF_SIZE)
3508 KEEP(44) = max(KEEP(44), MIN_BUF_SIZE)
3509 ENDIF
3510 IF ( PROK ) THEN
3511 WRITE(MP,'(a,i16) ')
3512 & ' estimated INTEGER space for factors :',
3513 & KEEP(26)
3514 WRITE(MP,'(A,I16) ')
3515 & ' INFO(3), est. real space to store factors :',
3516 & keep8(11)
3517 WRITE(mp,'(A,I16) ')
3518 & ' Estimated number of entries in factors :',
3519 & keep8(9)
3520 WRITE(mp,'(A,I16) ')
3521 & ' Current value of space relaxation parameter :',
3522 & keep(12)
3523 WRITE(mp,'(A,I16) ')
3524 & ' estimated size of is(in core factorization):',
3525 & KEEP(29)
3526 WRITE(MP,'(a,i16) ')
3527 & ' estimated size of s(in core factorization):',
3528 & KEEP8(13)
3529 WRITE(MP,'(a,i16) ')
3530 & ' estimated size of s(ooc factorization) :',
3531 & KEEP8(17)
3532 END IF
3533C}
3534 ELSE
3535C ---------------------
3536C Master is not working
3537C ---------------------
3538 ENTRIES_IN_FACTORS_LOC_MASTERS = 0_8
3539 KEEP8(13) = 0_8
3540 KEEP(29) = 0
3541 KEEP8(17)= 0_8
3542 INFO(19) = 0
3543 KEEP8(11) = 0_8
3544 KEEP8(81) = 0_8
3545 KEEP8(82) = 0_8
3546 KEEP(26) = 0
3547 KEEP(27) = 0
3548 RINFO(1) = 0.0E0
3549 K8_33relaxed = 0_8
3550 K8_34relaxed = 0_8
3551 K8_35relaxed = 0_8
3552 K8_50relaxed = 0_8
3553.GT. IF (KEEP(400) 0) THEN
3554 SUM_NIRNEC = 0
3555 SUM_NIRADU = 0
3556 SUM_NIRADU_OOC = 0
3557 SUM_NIRNEC_OOC = 0
3558 MAX_NRLADU = 0_8
3559 MIN_NRLADU = 0_8
3560 SUM_NRLADU = 0_8
3561 SUM_NRLNEC = 0_8
3562 SUM_NRLNEC_ACTIVE = 0_8
3563 SUM_NRLADU_if_LR_LU = 0_8
3564 SUM_NRLADULR_UD = 0_8
3565 SUM_NRLADULR_WC = 0_8
3566 ENDIF
3567 END IF
3568 CALL MUMPS_PROPINFO( ICNTL(1), INFO(1),
3569 & id%COMM, id%MYID )
3570.LT. IF ( INFO(1) 0 ) GOTO 500
3571C --------------------------------------
3572C KEEP8( 26 ) : Real arrowhead size
3573C KEEP8( 27 ) : Integer arrowhead size
3574C INFO(3)/KEEP8( 11 ) : Estimated real space needed for factors
3575C INFO(4)/KEEP( 26 ) : Estimated integer space needed for factors
3576C INFO(5)/KEEP( 27 ) : Estimated max front size
3577C KEEP8(109) : Estimated number of entries in factor
3578C (based on ENTRIES_IN_FACTORS_LOC_MASTERS computed
3579C during SMUMPS_ANA_DISTM, where we assume
3580C that each master of a node computes
3581C the complete factor size.
3582C --------------------------------------
3583C note that summing ENTRIES_IN_FACTORS_LOC_MASTERS or
3584C ENTRIES_IN_FACTORS_LOC_MASTERS should lead to the same result
3585 CALL MUMPS_ALLREDUCEI8( ENTRIES_IN_FACTORS_LOC_MASTERS,
3586 & KEEP8(109), MPI_SUM, id%COMM)
3587 CALL MUMPS_ALLREDUCEI8( KEEP8(19), KEEP8(119),
3588 & MPI_MAX, id%COMM)
3589 CALL MPI_ALLREDUCE( KEEP(27), KEEP(127), 1,
3590 & MPI_INTEGER, MPI_MAX,
3591 & id%COMM, IERR)
3592 CALL MPI_ALLREDUCE( KEEP(26), KEEP(126), 1,
3593 & MPI_INTEGER, MPI_SUM,
3594 & id%COMM, IERR)
3595C NRLADU related: KEEP8(11) holds factors above and under L0
3596 CALL MUMPS_REDUCEI8( KEEP8(11),
3597 & KEEP8(111), MPI_SUM,
3598 & MASTER, id%COMM )
3599 CALL MUMPS_SETI8TOI4( KEEP8(111), INFOG(3) )
3600C NRLADU_if_LR_LU related: KEEP8(32) holds factors above
3601C and under L0
3602C convert it in Megabytes
3603 RINFO(5) = real(KEEP8(32)
3604 & *int(KEEP(35),8))/1E6
3605 CALL MUMPS_REDUCEI8( KEEP8(32),
3606 & ITMP8, MPI_SUM,
3607 & MASTER, id%COMM )
3608C in Megabytes
3609.EQ. IF (id%MYIDMASTER) THEN
3610 RINFOG(15) = real(ITMP8*int(KEEP(35),8))/1E6
3611 ENDIF
3612C --------------
3613C Flops estimate
3614C --------------
3615 CALL MPI_ALLREDUCE( RINFO(1), RINFOG(1), 1,
3616 & MPI_REAL, MPI_SUM,
3617 & id%COMM, IERR)
3618C
3619 CALL MUMPS_SETI8TOI4( KEEP8(11), INFO(3) )
3620 INFO ( 4 ) = KEEP( 26 )
3621 INFO ( 5 ) = KEEP( 27 )
3622 INFO ( 7 ) = KEEP( 29 )
3623 CALL MUMPS_SETI8TOI4( KEEP8(13), INFO(8) )
3624 CALL MUMPS_SETI8TOI4( KEEP8(17), INFO(20) )
3625 CALL MUMPS_SETI8TOI4( KEEP8(9), INFO(24) )
3626C
3627 CALL MUMPS_SETI8TOI4( K8_33relaxed, INFO(29) )
3628 CALL MUMPS_SETI8TOI4( K8_34relaxed, INFO(32) )
3629 CALL MUMPS_SETI8TOI4( K8_35relaxed, INFO(33) )
3630 CALL MUMPS_SETI8TOI4( K8_50relaxed, INFO(36) )
3631 INFOG( 4 ) = KEEP( 126 )
3632 INFOG( 5 ) = KEEP( 127 )
3633 CALL MUMPS_SETI8TOI4( KEEP8(109), INFOG(20) )
3634 CALL SMUMPS_DIAG_ANA(id%MYID, id%COMM, KEEP(1), KEEP8(1),
3635 & INFO(1), INFOG(1), RINFO(1), RINFOG(1), ICNTL(1),
3636 & id%SIZE_SCHUR )
3637C --------------------------
3638C COMPUTE MEMORY ESTIMATIONS
3639 IF (PROK) WRITE( MP, 112 )
3640.AND..NE. IF (PROKG (MPGMP)) WRITE( MPG, 112 )
3641C --------------------------
3642C =========================
3643C IN-CORE MEMORY STATISTICS
3644C =========================
3645C Per compute node factor real space for factors informtation
3646 SUM_KEEP811_THIS_NODE=0_8
3647 CALL MPI_REDUCE( KEEP8(11), SUM_KEEP811_THIS_NODE, 1,
3648 & MPI_INTEGER8,
3649 & MPI_SUM, 0, id%KEEP(411), IERR )
3650 CALL MPI_REDUCE( SUM_KEEP811_THIS_NODE, MAX_SUM_KEEP811_THIS_NODE,
3651 & 1, MPI_INTEGER8, MPI_MAX, 0, id%COMM, IERR )
3652.AND. IF (PROKG PRINT_NODEINFO) THEN
3653 WRITE(MPG,'(a,i12)')
3654 & ' max. estimated space for factors per compute node :',
3655 & MAX_SUM_KEEP811_THIS_NODE ! * KEEP(35)/1000000_8
3656 ENDIF
3657C
3658 OOC_STRAT = KEEP(201)
3659 BLR_STRAT = 0 ! no BLR compression
3660.NE. IF (KEEP(201) -1) OOC_STRAT=0 ! We want in-core statistics
3661 PERLU_ON = .FALSE. ! switch off PERLU to compute KEEP8(2)
3662 CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1),
3663 & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28),
3664 & id%KEEP8(30),
3665 & id%NSLAVES, TOTAL_MBYTES, .FALSE.,
3666 & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES,
3667 & IDUMMY, BDUMMY, .FALSE.,
3668 & .FALSE. ! UNDER_L0_OMP
3669 & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1),
3670 & size(id%I8_L0_OMP,2)
3671 & )
3672.GT. IF (KEEP(400) 0 ) THEN ! L0 activated
3673 CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1),
3674 & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28),
3675 & id%KEEP8(30),
3676 & id%NSLAVES, TOTAL_MBYTES_UNDER_L0, .FALSE.,
3677 & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0,
3678 & IDUMMY, BDUMMY, .FALSE.,
3679 & .TRUE. ! UNDER_L0_OMP
3680 & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1),
3681 & size(id%I8_L0_OMP,2)
3682 & )
3683 TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0)
3684 TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0)
3685 ENDIF
3686 KEEP8(2) = TOTAL_BYTES
3687C
3688C
3689 PERLU_ON = .TRUE.
3690 CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1),
3691 & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28),
3692 & id%KEEP8(30),
3693 & id%NSLAVES, TOTAL_MBYTES, .FALSE.,
3694 & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES,
3695 & IDUMMY, BDUMMY, .FALSE.,
3696 & .FALSE. ! UNDER_L0_OMP
3697 & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1),
3698 & size(id%I8_L0_OMP,2)
3699 & )
3700.GT. IF (KEEP(400) 0 ) THEN ! L0 activated
3701 CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1),
3702 & id%MYID, id%N, id%NELT, id%NA(1), id%LNA,
3703 & id%KEEP8(28),
3704 & id%KEEP8(30),
3705 & id%NSLAVES, TOTAL_MBYTES_UNDER_L0, .FALSE.,
3706 & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0,
3707 & IDUMMY, BDUMMY, .FALSE.,
3708 & .TRUE. ! UNDER_L0_OMP
3709 & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1),
3710 & size(id%I8_L0_OMP,2)
3711 & )
3712 TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0)
3713 TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0)
3714 ENDIF
3715 IF ( PROK ) THEN
3716 WRITE(MP,'(a,i12) ')
3717 & ' estimated space in mbytes for ic factorization(info(15)):',
3718 & TOTAL_MBYTES
3719 END IF
3720 id%INFO(15) = TOTAL_MBYTES
3721C
3722C Centralize memory statistics on the host
3723C
3724C INFOG(16) = after analysis, est. mem size in Mbytes for facto,
3725C for the processor using largest memory
3726C INFOG(17) = after analysis, est. mem size in Mbytes for facto,
3727C sum over all processors
3728C INFOG(18/19) = idem at facto.
3729C
3730 CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM,
3731 & id%INFO(15), id%INFOG(16), IRANK )
3732 IF ( PROKG ) THEN
3733 IF (PRINT_MAXAVG) THEN
3734 WRITE( MPG,'(a,i12) ')
3735 & ' maximum estim. space in mbytes, ic facto. (infog(16)):',
3736 & id%INFOG(16)
3737 ENDIF
3738 WRITE(MPG,'(a,i12) ')
3739 & ' total space in mbytes, ic factorization(infog(17)):'
3740 & ,id%INFOG(17)
3741 END IF
3742C Per compute node memory information, IC factorization
3743 SUM_INFO15_THIS_NODE=0
3744 CALL MPI_REDUCE( INFO(15), SUM_INFO15_THIS_NODE, 1, MPI_INTEGER,
3745 & MPI_SUM, 0, id%KEEP(411), IERR )
3746 CALL MPI_REDUCE( SUM_INFO15_THIS_NODE, MAX_SUM_INFO15_THIS_NODE,
3747 & 1, MPI_INTEGER, MPI_MAX, 0, id%COMM, IERR )
3748.AND. IF ( PROKG PRINT_NODEINFO ) THEN
3749 WRITE(MPG,'(a,i12)')
3750 & ' max. estim. space per compute node, in mbytes, ic fact :',
3751 & MAX_SUM_INFO15_THIS_NODE
3752 ENDIF
3753C
3754C =========================================
3755C NOW COMPUTE OUT-OF-CORE MEMORY STATISTICS
3756C (except when OOC_STRAT is equal to -1 in
3757C which case IC and OOC statistics are
3758C identical)
3759C =========================================
3760 OOC_STRAT = KEEP(201)
3761 BLR_STRAT = 0 ! no BLR compression
3762#if defined(OLD_OOC_NOPANEL)
3763.NE. IF (OOC_STRAT -1) OOC_STRAT=2
3764#else
3765.NE. IF (OOC_STRAT -1) OOC_STRAT=1
3766#endif
3767 PERLU_ON = .FALSE. ! PERLU NOT taken into account
3768C Used to compute KEEP8(3) (minimum number of bytes for OOC)
3769 CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1),
3770 & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28),
3771 & id%KEEP8(30),
3772 & id%NSLAVES, TOTAL_MBYTES, .FALSE.,
3773 & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES,
3774 & IDUMMY, BDUMMY, .FALSE.,
3775 & .FALSE. ! UNDER_L0_OMP
3776 & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1),
3777 & size(id%I8_L0_OMP,2)
3778 & )
3779.GT. IF (KEEP(400) 0 ) THEN ! L0 activated
3780 CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1),
3781 & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28),
3782 & id%KEEP8(30),
3783 & id%NSLAVES, TOTAL_MBYTES_UNDER_L0, .FALSE.,
3784 & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0,
3785 & IDUMMY, BDUMMY, .FALSE.,
3786 & .TRUE. ! UNDER_L0_OMP
3787 & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1),
3788 & size(id%I8_L0_OMP,2)
3789 & )
3790 TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0)
3791 TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0)
3792 ENDIF
3793 KEEP8(3) = TOTAL_BYTES
3794C
3795 PERLU_ON = .TRUE. ! PERLU taken into account
3796 CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1),
3797 & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28),
3798 & id%KEEP8(30),
3799 & id%NSLAVES, TOTAL_MBYTES, .FALSE.,
3800 & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES,
3801 & IDUMMY, BDUMMY, .FALSE.,
3802 & .FALSE. ! UNDER_L0_OMP
3803 & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1),
3804 & size(id%I8_L0_OMP,2)
3805 & )
3806.GT. IF (KEEP(400) 0 ) THEN ! L0 activated
3807 CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1),
3808 & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28),
3809 & id%KEEP8(30),
3810 & id%NSLAVES, TOTAL_MBYTES_UNDER_L0, .FALSE.,
3811 & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES_UNDER_L0,
3812 & IDUMMY, BDUMMY, .FALSE.,
3813 & .TRUE. ! UNDER_L0_OMP
3814 & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1),
3815 & size(id%I8_L0_OMP,2)
3816 & )
3817 TOTAL_MBYTES = max (TOTAL_MBYTES,TOTAL_MBYTES_UNDER_L0)
3818 TOTAL_BYTES = max (TOTAL_BYTES, TOTAL_BYTES_UNDER_L0)
3819 ENDIF
3820 id%INFO(17) = TOTAL_MBYTES
3821C
3822 CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM,
3823 & id%INFO(17), id%INFOG(26), IRANK )
3824 IF ( PROKG ) THEN
3825 IF (PRINT_MAXAVG) THEN
3826 WRITE( MPG,'(a,i12) ')
3827 & ' maximum estim. space in mbytes, ooc facto. (infog(26)):',
3828 & id%INFOG(26)
3829 ENDIF
3830 WRITE(MPG,'(a,i12) ')
3831 & ' total space in mbytes, ooc factorization(infog(27)):'
3832 & ,id%INFOG(27)
3833 END IF
3834 SUM_INFO17_THIS_NODE=0
3835 CALL MPI_REDUCE( INFO(17), SUM_INFO17_THIS_NODE, 1, MPI_INTEGER,
3836 & MPI_SUM, 0, id%KEEP(411), IERR )
3837 CALL MPI_REDUCE( SUM_INFO17_THIS_NODE, MAX_SUM_INFO17_THIS_NODE,
3838 & 1, MPI_INTEGER, MPI_MAX, 0, id%COMM, IERR )
3839.AND. IF (PROKG PRINT_NODEINFO) THEN
3840 WRITE(MPG,'(a,i12)')
3841 & ' max. estim. space per compute node, in mbytes, ooc fact :',
3842 & MAX_SUM_INFO17_THIS_NODE
3843 ENDIF
3844.NE. IF (KEEP(494)0) THEN
3845C =========================================
3846C NOW COMPUTE BLR statistics
3847C =========================================
3848 SUM_OF_PEAKS = .TRUE.
3849 CALL SMUMPS_MEM_ESTIM_BLR_ALL( SUM_OF_PEAKS,
3850 & KEEP(1), KEEP8(1),
3851 & id%MYID, id%COMM,
3852 & id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28),
3853 & id%KEEP8(30), id%NSLAVES,
3854 & id%INFO, id%INFOG, PROK, MP, PROKG, MPG
3855 & , id%I8_L0_OMP(1,1), size(id%I8_L0_OMP,1),
3856 & size(id%I8_L0_OMP,2)
3857 & )
3858C
3859 END IF
3860C -------------------------
3861C Define a specific mapping
3862C for the user
3863C -------------------------
3864.AND..eq. IF ( id%MYID. eq. MASTER KEEP(54) 1 ) THEN
3865 IF (associated( id%MAPPING)) THEN
3866 DEALLOCATE( id%MAPPING)
3867 ENDIF
3868 allocate( id%MAPPING(id%KEEP8(28)), stat=allocok)
3869.GT. IF ( allocok 0 ) THEN
3870 INFO(1) = -7
3871 CALL MUMPS_SETI8TOI4(id%KEEP8(28), INFO(2))
3872 IF ( LPOK ) THEN
3873 WRITE(LP, 150) 'id%MAPPING'
3874 END IF
3875 GOTO 92
3876 END IF
3877 allocate(IWtemp( id%N ), stat=allocok)
3878.GT. IF ( allocok 0 ) THEN
3879 INFO(1)=-7
3880 INFO(2)=id%N
3881 IF ( LPOK ) THEN
3882 WRITE(LP, 150) 'iwtemp(n)'
3883 END IF
3884 GOTO 92
3885 END IF
3886.EQ. IF ( id%KEEP8(28) 0_8 ) THEN
3887 IRN_PTR => IDUMMY_ARRAY
3888 JCN_PTR => IDUMMY_ARRAY
3889 ELSE
3890 IRN_PTR => id%IRN
3891 JCN_PTR => id%JCN
3892 ENDIF
3893 CALL SMUMPS_BUILD_MAPPING(
3894 & id%N, id%MAPPING(1), id%KEEP8(28),
3895 & IRN_PTR(1),JCN_PTR(1), id%PROCNODE_STEPS(1),
3896 & id%STEP(1),
3897 & id%NSLAVES, id%SYM_PERM(1),
3898 & id%FILS(1), IWtemp, id%KEEP(1),id%KEEP8(1),
3899 & id%root%MBLOCK, id%root%NBLOCK,
3900 & id%root%NPROW, id%root%NPCOL )
3901 DEALLOCATE( IWtemp )
3902 92 CONTINUE
3903 END IF
3904 CALL MUMPS_PROPINFO( ICNTL(1), INFO(1),
3905 & id%COMM, id%MYID )
3906.LT. IF ( INFO(1) 0 ) GOTO 500
3907C
3908 500 CONTINUE
3909C Deallocate allocated working space
3910 IF (allocated(PROCNODE)) DEALLOCATE(PROCNODE)
3911 IF (allocated(XNODEL)) DEALLOCATE(XNODEL)
3912 IF (allocated(NODEL)) DEALLOCATE(NODEL)
3913 IF (allocated(IPOOL)) DEALLOCATE(IPOOL)
3914 IF (allocated(TNSTK_afterL0)) DEALLOCATE(TNSTK_afterL0)
3915 IF (allocated(FLAGGED_LEAVES)) DEALLOCATE(FLAGGED_LEAVES)
3916 IF (allocated(SIZEOFBLOCKS)) DEALLOCATE(SIZEOFBLOCKS)
3917 IF (allocated(DOF2BLOCK)) DEALLOCATE(DOF2BLOCK)
3918 CALL MUMPS_AB_FREE_LMAT(LMAT_BLOCK)
3919 CALL MUMPS_AB_FREE_LMAT(LUMAT)
3920 CALL MUMPS_AB_FREE_LMAT(LUMAT_REMAP)
3921 CALL MUMPS_AB_FREE_GCOMP(GCOMP)
3922 CALL MUMPS_AB_FREE_GCOMP(GCOMP_DIST)
3923.LT. IF (INFO(1) 0) THEN
3924C Free l0omp data for factorization only
3925C in case of error during analysis
3926 IF (associated(id%IPOOL_B_L0_OMP)) THEN
3927 DEALLOCATE(id%IPOOL_B_L0_OMP)
3928 NULLIFY(id%IPOOL_B_L0_OMP)
3929 ENDIF
3930 IF (associated(id%IPOOL_A_L0_OMP)) THEN
3931 DEALLOCATE(id%IPOOL_A_L0_OMP)
3932 NULLIFY(id%IPOOL_A_L0_OMP)
3933 ENDIF
3934 IF (associated(id%VIRT_L0_OMP)) THEN
3935 DEALLOCATE(id%VIRT_L0_OMP)
3936 NULLIFY(id%VIRT_L0_OMP)
3937 ENDIF
3938 IF (associated(id%VIRT_L0_OMP_MAPPING)) THEN
3939 DEALLOCATE(id%VIRT_L0_OMP_MAPPING)
3940 NULLIFY(id%VIRT_L0_OMP_MAPPING)
3941 ENDIF
3942 IF (associated(id%PERM_L0_OMP)) THEN
3943 DEALLOCATE(id%PERM_L0_OMP)
3944 NULLIFY(id%PERM_L0_OMP)
3945 ENDIF
3946 IF (associated(id%PTR_LEAFS_L0_OMP)) THEN
3947 DEALLOCATE(id%PTR_LEAFS_L0_OMP)
3948 NULLIFY(id%PTR_LEAFS_L0_OMP)
3949 ENDIF
3950 ENDIF
3951C Standard deallocations (error or not)
3952 IF (associated(NFSIZPTR)) DEALLOCATE(NFSIZPTR)
3953 IF (associated(FREREPTR)) DEALLOCATE(FREREPTR)
3954 IF (associated(FILSPTR)) DEALLOCATE(FILSPTR)
3955.AND. IF (associated(id%BLKPTR)BLKPTR_ALLOCATED) THEN
3956 DEALLOCATE(id%BLKPTR)
3957 nullify(id%BLKPTR)
3958 ENDIF
3959.AND. IF (associated(id%BLKVAR)BLKVAR_ALLOCATED) THEN
3960 DEALLOCATE(id%BLKVAR)
3961 nullify(id%BLKVAR)
3962 ENDIF
3963 KEEP8(26)=max(1_8,KEEP8(26))
3964 KEEP8(27)=max(1_8,KEEP8(27))
3965 RETURN
3966 110 FORMAT(/' ****** analysis step ********'/)
3967 112 FORMAT(/' memory estimations ... '/
3968 & ' estimations with standard full-rank(fr) factorization:')
3969 145 FORMAT(' elapsed time spent in blr clustering =',F12.4)
3970 150 FORMAT(
3971 & /' ** failure during smumps_ana_driver, dynamic allocation of',
3972 & A30)
3973 END SUBROUTINE SMUMPS_ANA_DRIVER
3974 SUBROUTINE SMUMPS_ANA_CHECK_KEEP(id, I_AM_SLAVE)
3975!$ USE OMP_LIB, ONLY : omp_get_max_threads
3976C This subroutine decodes the control parameters,
3977C stores them in the KEEP array, and performs a
3978C consistency check on the KEEP array.
3979 USE SMUMPS_STRUC_DEF
3980 IMPLICIT NONE
3981 TYPE(SMUMPS_STRUC) :: id
3982 LOGICAL :: I_AM_SLAVE
3983C internal variables
3984 INTEGER :: LP, MP, MPG, I
3985 INTEGER :: MASTER
3986 LOGICAL :: PROK, PROKG, LPOK
3987 PARAMETER( MASTER = 0 )
3988C
3989 LP = id%ICNTL( 1 )
3990 MP = id%ICNTL( 2 )
3991 MPG = id%ICNTL( 3 )
3992C LP : errors
3993C MP : INFO
3994.GT..AND..GE. LPOK = ((LP0)(id%ICNTL(4)1))
3995.GT..AND..GE. PROK = (( MP 0 )(id%ICNTL(4)2))
3996.GT..and..eq. PROKG = ( MPG 0 id%MYID MASTER )
3997.AND..GE. PROKG = (PROKG(id%ICNTL(4)2))
3998C Re-intialize few KEEPs entries corresponding
3999C to stat that are incremented such
4000C the number of split nodes:
4001 id%KEEP(61)=0
4002.eq. IF (id%MYIDMASTER) THEN
4003 id%KEEP(400) = 0
4004.GT. IF (id%KEEP(401) 0) THEN
4005!$ id%KEEP(400)=omp_get_max_threads()
4006.EQ. IF ( id%KEEP(400) 0 ) THEN
4007C Compilation without OMP!
4008 id%INFO(1)=-58
4009 id%INFO(2)=0
4010 IF (LPOK) WRITE(LP,'(a)')
4011 & " FAILURE DETECTED IN ANALYSIS: KEEP(401) requires OpenMP"
4012 RETURN
4013 ELSE
4014 IF ( PROKG ) THEN
4015 WRITE(MPG, '(a,i5,a)')
4016 & 'keep(401) config at analysis:', id%KEEP(400),
4017 & ' threads expected for multithreaded tree parallelism'
4018 END IF
4019.EQ. IF (id%KEEP(400)1) THEN
4020 id%KEEP(400) = 0
4021 ENDIF
4022 ENDIF
4023 ENDIF
4024 id%KEEP(256) = id%ICNTL(7) ! copy ordering option
4025 id%KEEP(252) = id%ICNTL(32)
4026.OR. IF (id%KEEP(252) < 0 id%KEEP(252) > 1 ) THEN
4027 id%KEEP(252) = 0
4028 ENDIF
4029C Which factors to store
4030 id%KEEP(251) = id%ICNTL(31)
4031.OR. IF (id%KEEP(251) < 0 id%KEEP(251) > 2 ) THEN
4032 id%KEEP(251)=0
4033 ENDIF
4034C For unsymmetric matrices, if forward solve
4035C performed during facto,
4036C no reason to store L factors at all. Reset
4037C KEEP(251) accordingly... except if the user
4038C tells that no solve is needed.
4039.EQ..AND..EQ. IF (id%KEEP(50) 0 id%KEEP(252)1) THEN
4040.NE. IF (id%KEEP(251) 1) id%KEEP(251) = 2
4041 ENDIF
4042C Symmetric case, even if no backward needed,
4043C store all factors
4044.NE..AND..EQ. IF (id%KEEP(50) 0 id%KEEP(251) 2) THEN
4045 id%KEEP(251) = 0
4046 ENDIF
4047C Case of solve not needed:
4048.EQ. IF (id%KEEP(251) 1) THEN
4049 id%KEEP(201) = -1
4050C In that case, id%ICNTL(22) will
4051C be ignored in future phases
4052 ELSE
4053C Reset id%KEEP(201) -- typically for the case
4054C of a previous analysis with KEEP(201)=-1
4055 id%KEEP(201) = 0
4056 ENDIF
4057.EQ. IF (id%KEEP(252)1) THEN
4058 id%KEEP(253) = id%NRHS
4059.LE. IF (id%KEEP(253) 0) THEN
4060 id%INFO(1)=-42
4061 id%INFO(2)=id%NRHS
4062 RETURN
4063 ENDIF
4064 ELSE
4065 id%KEEP(253) = 0
4066 ENDIF
4067 ENDIF
4068.NE..AND. IF ( (id%KEEP(24)0)
4069.eq. & id%NSLAVES1 ) THEN
4070 id%KEEP(24) = 0
4071 END IF
4072.EQ..AND. IF ( (id%KEEP(24)0)
4073.GT. & id%NSLAVES1 ) THEN
4074 id%KEEP(24) = 8
4075 ENDIF
4076.NE..AND..NE..AND. IF ( (id%KEEP(24)0) (id%KEEP(24)1)
4077.NE..AND..NE..AND. & (id%KEEP(24)8) (id%KEEP(24)10)
4078.NE..AND..NE..AND. & (id%KEEP(24)12) (id%KEEP(24)14)
4079.NE..AND..NE. & (id%KEEP(24)16) (id%KEEP(24)18)) THEN
4080 id%KEEP(24) = 8
4081 END IF
4082C****************************************************
4083C
4084C The master is doing most of the work
4085C
4086C NOTE: Treatment of the errors on the master=
4087C Go to the next SPMD part of the code in which
4088C the first statement must be a call to PROPINFO
4089C
4090C****************************************************
4091C =========================================
4092C Check (raise error or modify) some input
4093C parameters or KEEP values on the master.
4094C =========================================
4095 id%KEEP8(21) = int(id%KEEP(85),8)
4096.EQ. IF ( id%MYID MASTER ) THEN
4097C -- OOC/Incore strategy
4098.NE. IF (id%KEEP(201)-1) THEN
4099 id%KEEP(201)=id%ICNTL(22)
4100.GT. IF (id%KEEP(201) 0) THEN
4101#if defined(OLD_OOC_NOPANEL)
4102 id%KEEP(201)=2
4103#else
4104 id%KEEP(201)=1
4105#endif
4106 ENDIF
4107 ENDIF
4108C ----------------------------
4109C Save id%ICNTL(18) (distributed
4110C matrix on entry) in id%KEEP(54)
4111C ----------------------------
4112 id%KEEP(54) = id%ICNTL(18)
4113.LT..or..GT. IF ( id%KEEP(54) 0 id%KEEP(54)3 ) THEN
4114 IF ( PROKG ) THEN
4115 WRITE(MPG, *) ' out-of-range value for id%ICNTL(18).'
4116 WRITE(MPG, *) ' used 0 ie matrix not distributed'
4117 END IF
4118 id%KEEP(54) = 0
4119 END IF
4120.EQ. IF ( id%KEEP(54) 1 ) THEN
4121 IF ( PROKG ) THEN
4122 WRITE(MPG, *) ' option id%ICNTL(18)=1 is obsolete.'
4123 WRITE(MPG, *) ' we recommend not to use it.'
4124 WRITE(MPG, *) ' it will disappear in a future release'
4125 END IF
4126 END IF
4127C -----------------------------------------
4128C Save id%ICNTL(5) (matrix format) in id%KEEP(55)
4129C -----------------------------------------
4130 id%KEEP(55) = id%ICNTL(5)
4131.LT..OR..GT. IF ( id%KEEP(55) 0 id%KEEP(55) 1 ) THEN
4132 IF ( PROKG ) THEN
4133 WRITE(MPG, *) ' out-of-range value for id%icntl(5).'
4134 WRITE(MPG, *) ' used 0 ie matrix is assembled'
4135 END IF
4136 id%KEEP(55) = 0
4137 END IF
4138 id%KEEP(60) = id%ICNTL(19)
4139.LE. IF ( id%KEEP( 60 ) 0 ) id%KEEP( 60 ) = 0
4140.GT. IF ( id%KEEP( 60 ) 3 ) id%KEEP( 60 ) = 0
4141.NE..AND. IF (id%KEEP(60) 0 id%SIZE_SCHUR == 0 ) THEN
4142 IF (PROKG) THEN
4143 WRITE(MPG,'(a)')
4144 & ' ** schur option ignored because size_schur=0'
4145 ENDIF
4146 id%KEEP(60)=0
4147 END IF
4148C ---------------------------------------
4149C Save SIZE_SCHUR in a KEEP, for possible
4150C check at factorization and solve phases
4151C ---------------------------------------
4152.NE. IF ( id%KEEP(60) 0 ) THEN
4153 id%KEEP(116) = id%SIZE_SCHUR
4154.LT..OR..GE. IF (id%SIZE_SCHUR 0 id%SIZE_SCHUR id%N) THEN
4155 id%INFO(1)=-49
4156 id%INFO(2)=id%SIZE_SCHUR
4157 RETURN
4158 ENDIF
4159C List of Schur variables provided by user.
4160.NOT. IF ( associated( id%LISTVAR_SCHUR ) ) THEN
4161 id%INFO(1) = -22
4162 id%INFO(2) = 8
4163 RETURN
4164 ELSE IF (size(id%LISTVAR_SCHUR)<id%SIZE_SCHUR) THEN
4165 id%INFO(1) = -22
4166 id%INFO(2) = 8
4167 RETURN
4168 END IF
4169 ENDIF
4170.EQ..AND..NE. IF (id%KEEP(60) 3 id%KEEP(50)0) THEN
4171.AND..AND. IF (id%MBLOCK > 0 id%NBLOCK > 0
4172.AND. & id%NPROW > 0 id%NPCOL > 0 ) THEN
4173.LE. IF (id%NPROW *id%NPCOL id%NSLAVES) THEN
4174C We will eventually have to "symmetrize the
4175C Schur complement. For that NBLOCK and MBLOCK
4176C must be equal.
4177.NE. IF (id%MBLOCK id%NBLOCK ) THEN
4178 id%INFO(1)=-31
4179 id%INFO(2)=id%MBLOCK - id%NBLOCK
4180 RETURN
4181 ENDIF
4182 ENDIF
4183 ENDIF
4184 ENDIF
4185C Check the ordering strategy and compatibility with
4186C other control parameters
4187 id%KEEP(244) = id%ICNTL(28)
4188 id%KEEP(245) = id%ICNTL(29)
4189#if ! defined(parmetis) && ! defined(parmetis3)
4190.EQ..AND..EQ. IF ((id%KEEP(244) 2) (id%KEEP(245) 2)) THEN
4191 id%INFO(1) = -38
4192 IF ( LPOK ) THEN
4193 WRITE(LP,'("ParMETIS not available.")')
4194 END IF
4195 RETURN
4196 END IF
4197#endif
4198#if ! defined(ptscotch)
4199.EQ..AND..EQ. IF ((id%KEEP(244) 2) (id%KEEP(245) 1)) THEN
4200 id%INFO(1) = -38
4201 IF ( LPOK ) THEN
4202 WRITE(LP,'("PT-SCOTCH not available.")')
4203 END IF
4204 RETURN
4205 END IF
4206#endif
4207C Analysis strategy is set to automatic in case of out-of-range values.
4208.GT..OR. IF((id%KEEP(244) 2)
4209.LT. & (id%KEEP(244) 0)) id%KEEP(244)=0
4210.EQ. IF(id%KEEP(244) 0) THEN ! Automatic
4211C One could check for availability of parallel ordering
4212C tools, or for possible options incompatible with //
4213C analysis to decide (e.g. avoid returning an error if
4214C // analysis not compatible with some option but user
4215C lets MUMPS decide to choose sequential or paralllel
4216C analysis)
4217C Current strategy for automatic is sequential analysis
4218 id%KEEP(244) = 1
4219.EQ. ELSE IF (id%KEEP(244) 2) THEN
4220.NE. IF(id%KEEP(55) 0) THEN
4221 id%INFO(1) = -39
4222 IF (LPOK) THEN
4223 WRITE(LP,
4224 & '("Incompatible values for ICNTL(5), ICNTL(28)")')
4225 WRITE(LP,
4226 & '("Parallel analysis is not possible if the")')
4227 WRITE(LP,
4228 & '("matrix is not assembled")')
4229 ENDIF
4230 RETURN
4231.NE. ELSE IF(id%KEEP(60) 0) THEN
4232 id%INFO(1) = -39
4233 IF (LPOK) THEN
4234 WRITE(LP,
4235 & '("Incompatible values for ICNTL(19), ICNTL(28)")')
4236 WRITE(LP,
4237 & '("Parallel analysis is not possible if SCHUR")')
4238 WRITE(lp,
4239 & '("complement must be returned")')
4240 ENDIF
4241 RETURN
4242 END IF
4243C In the case where there are too few processes to do
4244C the parallel analysis we simply revert to sequential version
4245 IF(id%NSLAVES .LT. 2) THEN
4246 id%KEEP(244) = 1
4247 IF(prokg) WRITE(mpg,
4248 & '("Too few processes.
4249 & Reverting to sequential analysis")',advance='no')
4250 IF(id%KEEP(245) .EQ. 1) THEN
4251C Scotch necessarily available because pt-scotch
4252C is, otherwise an error would have occurred
4253 IF(prokg) WRITE(mpg, '(" with SCOTCH.")')
4254 id%KEEP(256) = 3
4255 ELSE IF(id%KEEP(245) .EQ. 2) THEN
4256C Metis necessarily available because parmetis
4257C is, otherwise an error would have occurred
4258 IF(prokg) WRITE(mpg, '(" with Metis.")')
4259 id%KEEP(256) = 5
4260 ELSE
4261 IF(prokg) WRITE(mpg, '(".")')
4262 id%KEEP(256) = 7
4263 END IF
4264 END IF
4265C In the case where there the input matrix is too small to do
4266C the parallel analysis we simply revert to sequential version
4267 IF(id%N .LE. 50) THEN
4268 id%KEEP(244) = 1
4269 IF(prokg) WRITE(mpg,
4270 & '("Input matrix is too small for the parallel
4271 & analysis. Reverting to sequential analysis")',advance='no')
4272 IF(id%KEEP(245) .EQ. 1) THEN
4273 IF(prokg) WRITE(mpg, '(" with SCOTCH.")')
4274 id%KEEP(256) = 3
4275 ELSE IF(id%KEEP(245) .EQ. 2) THEN
4276 IF(prokg) WRITE(mpg, '(" with Metis.")')
4277 id%KEEP(256) = 5
4278 ELSE
4279 IF(prokg) WRITE(mpg, '(".")')
4280 id%KEEP(256) = 7
4281 END IF
4282 END IF
4283 END IF
4284 id%INFOG(32) = id%KEEP(244)
4285 IF ( (id%KEEP(244) .EQ. 1) .AND.
4286 & (id%KEEP(256) .EQ. 1) ) THEN
4287C ordering given, PERM_IN must be of size N
4288 IF ( .NOT. associated( id%PERM_IN ) ) THEN
4289 id%INFO(1) = -22
4290 id%INFO(2) = 3
4291 RETURN
4292 ELSE IF ( size( id%PERM_IN ) < id%N ) THEN
4293 id%INFO(1) = -22
4294 id%INFO(2) = 3
4295 RETURN
4296 END IF
4297 ENDIF
4298C Check KEEP(9-10) for level 2
4299 IF (id%KEEP(9) .LE. 1 ) id%KEEP(9) = 500
4300 IF ( id%KEEP8(21) .GT. 0_8 ) THEN
4301 IF ((id%KEEP8(21).LE.1_8) .OR.
4302 & (id%KEEP8(21).GT.int(id%KEEP(9),8)))
4303 & id%KEEP8(21) = int(min(id%KEEP(9),100),8)
4304 ENDIF
4305C
4306 IF (id%KEEP(48). eq. 1 ) id%KEEP(48) = -12345
4307C
4308 IF ( (id%KEEP(48).LT.0) .OR. (id%KEEP(48).GT.5) ) THEN
4309 id%KEEP(48)=5
4310 ENDIF
4311C Schur
4312C Given ordering must be compatible with Schur variables.
4313 IF ( (id%KEEP(60) .NE. 0) .AND. (id%KEEP(256) .EQ. 1) ) THEN
4314 DO i = 1, id%SIZE_SCHUR
4315 IF (id%PERM_IN(id%LISTVAR_SCHUR(i))
4316 & .EQ. id%N-id%SIZE_SCHUR+i)
4317 & cycle
4318C -------------------------------
4319C Problem with PERM_IN: -22/3
4320C Above constrained explained in
4321C doc of PERM_IN in user guide.
4322C -------------------------------
4323 id%INFO(1) = -4
4324 id%INFO(2) = id%LISTVAR_SCHUR(i)
4325 RETURN
4326 IF (prokg) THEN
4327 WRITE(mpg,'(A)')
4328 & ' ** Ignoring user-ordering, because incompatible with Schur.'
4329 WRITE(mpg,'(A)') ' ** id%ICNTL(7) treated as 0.'
4330 END IF
4331 EXIT
4332 ENDDO
4333 END IF
4334C
4335C Note that schur is not compatible with
4336C
4337C 1/Max-trans DONE
4338C 2/Null space
4339C 3/Ordering given DONE
4340C 4/Scaling
4341C 5/Iterative Refinement
4342C 6/Error analysis
4343C 7/Parallel Analysis
4344C
4345C Graph modification prior to ordering (id%ICNTL(12) option)
4346C id%KEEP (95) will hold the eventually modified value of id%ICNTL(12)
4347C
4348 id%KEEP(95) = id%ICNTL(12)
4349C reset to usual ordering (KEEP(95)=1)
4350C - when matrix is not general symmetric
4351C - for out-of-range values
4352 IF (id%KEEP(50).NE.2) id%KEEP(95) = 1
4353 IF ((id%KEEP(95).GT.3).OR.(id%KEEP(95).LT.0)) id%KEEP(95) = 1
4354C MAX-TRANS
4355C
4356C id%KEEP (23) will hold the eventually modified value of id%ICNTL(6)
4357C (maximum transversal if >= 1)
4358C
4359 id%KEEP(23) = id%ICNTL(6)
4360C
4361C
4362C --------------------------------------------
4363C Avoid max-trans unsymmetric permutation in case of
4364C matrix is symmetric with SYM=1 or
4365C ordering is given,
4366C or matrix is in element form, or Schur is asked
4367C or initial matrix is distributed
4368C --------------------------------------------
4369 IF (id%KEEP(23).LT.0.OR.id%KEEP(23).GT.7) id%KEEP(23) = 0
4370C still forbid max trans for SYM=1 case
4371 IF ( id%KEEP(50) .EQ. 1 ) THEN
4372 IF (id%KEEP(23) .NE. 0) THEN
4373 IF (prokg) THEN
4374 WRITE(mpg,'(a)')
4375 & ' ** max-trans not needed with sym=1 factorization'
4376 END IF
4377 id%KEEP(23) = 0
4378 ENDIF
4379.GT. IF (id%KEEP(95) 1) THEN
4380 IF (PROKG) THEN
4381 WRITE(MPG,'(a)')
4382 & ' ** icntl(12) ignored: not needed with sym=1 factorization'
4383 END IF
4384 ENDIF
4385 id%KEEP(95) = 1
4386 END IF
4387C
4388.GT. IF (id%KEEP(60) 0) THEN
4389.NE. IF (id%KEEP(23) 0) THEN
4390 IF (PROKG) THEN
4391 WRITE(MPG,'(a)')
4392 & ' ** max-trans not allowed because of schur'
4393 END IF
4394 id%KEEP(23) = 0
4395 ENDIF
4396.EQ. IF (id%KEEP(52)-2) THEN
4397 IF (PROKG) THEN
4398 WRITE(MPG,'(a)')
4399 & ' ** scaling during analysis not allowed because of schur'
4400 ENDIF
4401 id%KEEP(52) = 0
4402 ENDIF
4403C also forbid compressed/constrained ordering...
4404.GT. IF (id%KEEP(95) 1) THEN
4405 IF (PROKG) THEN
4406 WRITE(MPG,'(a)')
4407 & ' ** icntl(12) option not allowed because of schur'
4408 END IF
4409 ENDIF
4410 id%KEEP(95) = 1
4411 END IF
4412.NE..AND..EQ. IF ( (id%KEEP(23) 0) (id%KEEP(256)1)) THEN
4413 id%KEEP(23) = 0
4414 IF (PROKG) THEN
4415 WRITE(MPG,'(a,a)')
4416 & ' ** maximum transversal(icntl(6)) not allowed ',
4417 & 'because ordering is given'
4418 END IF
4419 END IF
4420.EQ. IF ( id%KEEP(256) 1 ) THEN
4421.AND. IF (id%KEEP(95) > 1 PROKG) THEN
4422 WRITE(MPG,'(a)')
4423 & ' ** icntl(12) option incompatible with given ordering'
4424 END IF
4425 id%KEEP(95) = 1
4426 END IF
4427.NE. IF (id%KEEP(54) 0) THEN
4428.NE. IF( id%KEEP(23) 0 ) THEN
4429 IF (PROKG) THEN
4430 WRITE(MPG,'(a,a)')
4431 & ' ** maximum transversal(icntl(6)) not allowed ',
4432 & 'because matrix is distributed'
4433 END IF
4434 id%KEEP(23) = 0
4435 ENDIF
4436 IF (id%KEEP(52).EQ.-2) THEN
4437 IF (prokg) THEN
4438 WRITE(mpg,'(A,A)')
4439 & ' ** Scaling (ICNTL(8)) during analysis not ',
4440 & 'allowed because matrix is distributed)'
4441 ENDIF
4442 ENDIF
4443 id%KEEP(52) = 0
4444 IF (id%KEEP(95) .GT. 1 .AND. mpg.GT.0) THEN
4445 WRITE(mpg,'(A,A)')
4446 & ' ** ICNTL(12) option not allowed because matrix is ',
4447 & 'distributed'
4448 ENDIF
4449 id%KEEP(95) = 1
4450 END IF
4451 IF ( id%KEEP(55) .NE. 0 ) THEN
4452 IF( id%KEEP(23) .NE. 0 ) THEN
4453 IF (prokg) THEN
4454 WRITE(mpg,'(A,A)')
4455 & ' ** Maximum transversal (ICNTL(6)) not allowed ',
4456 & 'for matrices in elemental format'
4457 END IF
4458 id%KEEP(23) = 0
4459 ENDIF
4460 IF (prokg .AND. id%KEEP(52).EQ.-2) THEN
4461 WRITE(mpg,'(A)')
4462 & ' ** Scaling (ICNTL(8)) not allowed ',
4463 & 'for matrices in elemental format'
4464 ENDIF
4465 id%KEEP(52) = 0
4466 id%KEEP(95) = 1
4467 ENDIF
4468C In the case where parallel analysis is done, column permutation
4469C is not allowed
4470 IF(id%KEEP(244) .EQ. 2) THEN
4471 IF(id%KEEP(23) .EQ. 7) THEN
4472C Automatic hoice: set it to 0
4473 id%KEEP(23) = 0
4474 ELSE IF (id%KEEP(23) .GT. 0) THEN
4475 id%INFO(1) = -39
4476 id%KEEP(23) = 0
4477 IF (lpok) THEN
4478 WRITE(lp,
4479 & '("Incompatible values for ICNTL(6), ICNTL(28)")')
4480 WRITE(lp,
4481 & '("Maximum transversal not allowed
4482 & in parallel analysis")')
4483 ENDIF
4484 RETURN
4485 END IF
4486 END IF
4487C --------------------------------------------
4488C Avoid distributed entry for element matrix.
4489C --------------------------------------------
4490 IF ( id%KEEP(54) .NE. 0 .AND. id%KEEP(55) .NE. 0 ) THEN
4491 id%KEEP(54) = 0
4492 IF (prokg) THEN
4493 WRITE(mpg,'(A)')
4494 & ' ** Distributed entry not available for element matrix'
4495 END IF
4496 ENDIF
4497C ----------------------------------
4498C Choice of symbolic analysis option
4499C ----------------------------------
4500 IF (id%ICNTL(58).NE.1 .and. id%ICNTL(58).NE.2
4501 & .and. id%ICNTL(58).NE.3 .and. id%ICNTL(58).NE.4 ) THEN
4502C out of range values leads to symbolic based on SYMBQAMD
4503 id%KEEP(106)=1
4504 ELSE
4505 id%KEEP(106)=id%ICNTL(58)
4506 IF (id%KEEP(106).GE.4) THEN
4507C option not available
4508 id%KEEP(106)=1
4509 ENDIF
4510 ENDIF
4511C modify input parameters to avoid incompatible
4512C input data between ordering, scaling and maxtrans
4513C note that if id%ICNTL(12)/id%KEEP(95) = 0 then
4514C the automatic choice will be done in ANA_O
4515 IF(id%KEEP(50) .EQ. 2) THEN
4516C LDLT case
4517 IF( .NOT. associated(id%A) ) THEN
4518C constraint ordering can be computed only if values are
4519C given to analysis
4520 IF(id%KEEP(95) .EQ. 3) THEN
4521 id%KEEP(95) = 2
4522 ENDIF
4523 ENDIF
4524 IF(id%KEEP(95) .EQ. 3 .AND. id%KEEP(256) .NE. 2) THEN
4525C if constraint and ordering is not AMF then use compress
4526 IF (prok) WRITE(mp,*)
4527 & 'WARNING: SMUMPS_ANA_O constrained ordering not ',
4528 & 'available with selected ordering'
4529 id%KEEP(95) = 2
4530 ENDIF
4531 IF(id%KEEP(95) .EQ. 3) THEN
4532C if constraint ordering required then we need to compute scaling
4533C and max trans
4534C NOTE that if we enter this condition then
4535C id%A is associated because of the test above:
4536C (IF( .NOT. associated(id%A) ) THEN)
4537 id%KEEP(23) = 5
4538 id%KEEP(52) = -2
4539 ELSE IF(id%KEEP(95) .EQ. 2 .AND.
4540 & (id%KEEP(23) .EQ. 0 .OR. id%KEEP(23) .EQ. 7) ) THEN
4541C compressed ordering requires max trans but not necessary scaling
4542 IF( associated(id%A) ) THEN
4543 id%KEEP(23) = 5
4544 ELSE
4545C we can do compressed ordering without
4546C information on the numerical values:
4547C a maximum transversal already provides
4548C information on the location of off-diagonal
4549C nonzeros which can be candidates for 2x2
4550C pivots
4551 id%KEEP(23) = 1
4552 ENDIF
4553 ELSE IF(id%KEEP(95) .EQ. 1) THEN
4554 id%KEEP(23) = 0
4555 ELSE IF(id%KEEP(95) .EQ. 0 .AND. id%KEEP(23) .EQ. 0) THEN
4556C if max trans desactivated then the automatic choice for type of ord
4557C is set to 1, which means that we will use usual ordering
4558C (no constraints or compression)
4559 id%KEEP(95) = 1
4560 ENDIF
4561 ELSE
4562 id%KEEP(95) = 1
4563 ENDIF
4564C --------------------------------
4565C Save ICNTL(56) (QR) in KEEP(53)
4566C Will be broadcasted to all other
4567C nodes in routine SMUMPS_BDCAST
4568C --------------------------------
4569 id%KEEP(53)=0
4570 IF(id%KEEP(86).EQ.1)THEN
4571C Force the exchange of both the memory and flops information during
4572C the factorization
4573 IF(id%KEEP(47).LT.2) id%KEEP(47)=2
4574 ENDIF
4575 IF(id%KEEP(48).EQ.5)THEN
4576 IF(id%KEEP(50).EQ.0)THEN
4577 id%KEEP(87)=50
4578 id%KEEP(88)=50
4579 ELSE
4580 id%KEEP(87)=70
4581 id%KEEP(88)=70
4582 ENDIF
4583 ENDIF
4584 IF((id%NSLAVES.EQ.1).AND.(id%KEEP(76).GT.3))THEN
4585 id%KEEP(76)=2
4586 ENDIF
4587 IF(id%KEEP(81).GT.0)THEN
4588 IF(id%KEEP(47).LT.2) id%KEEP(47)=2
4589 ENDIF
4590C
4591C -- Save Block Low Rank input parameter
4592 id%KEEP(494) = id%ICNTL(35)
4593 IF (id%KEEP(494).EQ.1) THEN
4594C -- Automatic BLR option setting
4595 id%KEEP(494)= 2
4596 ENDIF
4597 IF ( id%KEEP(494).EQ.4) id%KEEP(494)=0
4598 IF ((id%KEEP(494).LT.0).OR.(id%KEEP(494).GT.4)) THEN
4599C Out of range values treated as 0
4600 id%KEEP(494) = 0
4601 ENDIF
4602 IF(id%KEEP(494).NE.0) THEN
4603C test BLR incompatibilities
4604C
4605 id%KEEP(464) = id%ICNTL(38)
4606 IF (id%KEEP(464).LT.0.OR.(id%KEEP(464).GT.1000)) THEN
4607C Out of range values treated as 0
4608 id%KEEP(464) = 0
4609 ENDIF
4610 id%KEEP(465) = id%ICNTL(39)
4611 IF (id%KEEP(465).LT.0.OR.(id%KEEP(465).GT.1000)) THEN
4612C Out of range values treated as 0
4613 id%KEEP(465) = 0
4614 ENDIF
4615C LR is incompatible with elemental matrices, forbid it at analysis
4616 IF (id%KEEP(55).NE.0) THEN
4617 IF (lpok) WRITE(lp,*)
4618 & " *** BLR feature currently incompatible "
4619 & ,"with elemental matrices"
4620C BLR for elt entry might be developed in the future
4621 id%INFO(1)=-800
4622 id%INFO(2)=5
4623 RETURN
4624 ENDIF
4625C
4626C LR incompatible with forward in facto
4627 IF (id%KEEP(252).NE.0) THEN
4628 IF (lpok) WRITE(lp,*)
4629 & " *** BLR feature currently incompatible"
4630 & ," with forward during factorization"
4631 id%INFO(1) = -43
4632 id%INFO(2) = 35
4633 RETURN
4634 ENDIF
4635C
4636 ENDIF
4637C
4638 IF(id%KEEP(494).NE.0) THEN
4639C id%KEEP(469)=0,1,2,3,4
4640 IF ((id%KEEP(469).GT.4).OR.(id%KEEP(469).LT.0)) THEN
4641 id%KEEP(469)=0
4642 ENDIF
4643C Not implemented yet
4644 IF (id%KEEP(469).EQ.4) id%KEEP(469)=0
4645C id%KEEP(471)=-1,0,1
4646 IF ((id%KEEP(471).LT.-1).AND.(id%KEEP(471).GT.1)) THEN
4647 id%KEEP(471)=-1
4648 ENDIF
4649C id%KEEP(472)=0 or 1
4650 IF ((id%KEEP(472).NE.0).AND.(id%KEEP(472).NE.1)) THEN
4651 id%KEEP(472)=1
4652 ENDIF
4653C id%KEEP(475)=0,1,2,3
4654 IF ((id%KEEP(475).GT.3).OR.(id%KEEP(475).LT.0)) THEN
4655 id%KEEP(475)=0
4656 ENDIF
4657C id%KEEP(482)=0,1,2,3
4658 IF ((id%KEEP(482).GT.3).OR.(id%KEEP(482).LT.0)) THEN
4659 id%KEEP(482)=0
4660 ENDIF
4661 IF((id%KEEP(487).LT.0)) THEN
4662 id%KEEP(487)= 2 ! default value
4663 ENDIF
4664C id%KEEP(488)>0
4665 IF((id%KEEP(488).LE.0)) THEN
4666 id%KEEP(488)= 8*id%KEEP(6)
4667 ENDIF
4668C id%KEEP(490)>0
4669 IF((id%KEEP(490).LE.0)) THEN
4670 id%KEEP(490) = 128
4671 ENDIF
4672C KEEP(491)>0
4673 IF((id%KEEP(491).LE.0)) THEN
4674 id%KEEP(491) = 1000
4675 ENDIF
4676 ENDIF
4677C
4678 id%KEEP(13) = 0
4679C Analysis by Blocks
4680 id%KEEP(13) = id%ICNTL(15)
4681 IF (id%KEEP(13).GT.1) THEN
4682CV0 out-of range values
4683 id%KEEP(13) = 0
4684 ENDIF
4685 IF (id%KEEP(13).LT.0) THEN
4686 IF (mod(id%N,-id%KEEP(13)) .NE.0) THEN
4687 IF ( lpok ) THEN
4688 WRITE(lp,'(A,I8)')
4689 & " ICNTL(15)=", id%ICNTL(15),
4690 & " is incompatible with N=", id%N
4691 ENDIF
4692 id%INFO(1) = -57
4693 id%INFO(2) = 1
4694 ENDIF
4695 IF (associated(id%BLKPTR)) THEN
4696 IF ( lpok ) THEN
4697 WRITE(lp,'(A,I8)')
4698 & " ICNTL(15)=", id%ICNTL(15),
4699 & " is incompatible with BLKPTR provided by user"
4700 ENDIF
4701 id%INFO(1) = -57
4702 id%INFO(2) = 4
4703 ENDIF
4704 ENDIF
4705 IF ( (id%KEEP(13).EQ.0) .AND.
4706 & (.NOT. associated(id%BLKPTR)) .AND.
4707 & (.NOT. associated(id%BLKVAR))
4708 & )
4709 & THEN
4710 IF ((id%KEEP(54).EQ.3).AND.(id%KEEP(244).NE.2)) THEN
4711 id%KEEP(13)=-1
4712 ENDIF
4713 ENDIF
4714 IF ( (id%KEEP(13).EQ.0 ) .AND.
4715 & (.NOT. associated(id%BLKPTR)) .AND.
4716 & (.NOT. associated(id%BLKVAR)) .AND.
4717 & (id%KEEP(244).NE.2)
4718 & )
4719 & THEN
4720C unsymmetic assembled matrices with or without BLR,
4721C also in case of centralized matrix (if
4722C matrix is distributed, then KEEP(13) has
4723C been set to -1 in the block above)
4724 IF (id%KEEP(50).EQ.0.AND. id%KEEP(55).EQ.0) THEN
4725C Respect decision taken for Maxtrans
4726C since it will be switch off
4727C if one activates the analysis by block
4728 IF ( (id%KEEP(23).LE.0) .OR. (id%KEEP(23).GT.7)
4729 & ) THEN
4730 id%KEEP(13)=-1
4731 ENDIF
4732 ENDIF
4733 ENDIF
4734 IF ( (id%KEEP(13).EQ.0) .AND.
4735 & (id%KEEP(55).NE.0)
4736 & ) THEN
4737 IF (prokg.AND.(id%KEEP(13).NE.-1)) WRITE(mpg,'(A,A)')
4738 & " ** Analysis by block is incompatible ",
4739 & "with elemental matrices"
4740C switch off analysis by block
4741 id%KEEP(13)= 0
4742 ENDIF
4743 IF ( (id%KEEP(13).NE.0) .AND.
4744 & (id%KEEP(106).NE.1).AND. (id%KEEP(106).NE.2)
4745 & ) THEN
4746 IF (prokg.AND.(id%KEEP(13).NE.-1)) WRITE(mpg,'(A,A,I4)')
4747 & " ** Analysis by block not compatible ",
4748 & "with symbolic factorization option ",
4749 & id%KEEP(106)
4750C switch off analysis by block
4751 id%KEEP(13)= 0
4752 ENDIF
4753 IF ( (id%KEEP(13).NE.0) .AND.
4754 & (id%KEEP(244).EQ.2)
4755 & ) THEN
4756 IF (prokg.AND.(id%KEEP(13).NE.-1)) WRITE(mpg,'(A,A)')
4757 & " ** Analysis by block is incompatible ",
4758 & "with parallel ordering "
4759C switch off analysis by block
4760 id%KEEP(13)= 0
4761 ENDIF
4762 IF ( (id%KEEP(13).NE.0) .AND.
4763 & (id%KEEP(60).NE.0)
4764 & ) THEN
4765 IF (prokg.AND.(id%KEEP(13).NE.-1)) WRITE(mpg,'(A,A)')
4766 & " ** Analysis by block is incompatible ",
4767 & "with Schur "
4768C switch off analysis by block
4769 id%KEEP(13)= 0
4770 ENDIF
4771 IF (id%KEEP(13).NE.0) THEN
4772C Maximum transversal not compatible with analysis by block
4773 IF (id%KEEP(23).NE.0) THEN
4774C in case of automatic choice (id%KEEP(27).EQ.7)
4775C do not print message
4776 IF (prokg.AND.id%KEEP(23).NE.7) WRITE(mpg,'(A,A)')
4777 & " ** maximum transversal (icntl(6)) ",
4778 & "not compatible with analysis by block"
4779C switch off max transversal
4780 id%KEEP(23)= 0
4781 ENDIF
4782C - compression for LDLT
4783.NE. IF (id%KEEP(95)1) THEN
4784C in case of automatic choice (id%KEEP(95).EQ.0)
4785C do not print message
4786.AND..NE. IF (PROKGid%KEEP(95)0) WRITE(MPG,'(A,A)')
4787 & " ** icntl(12) not compatible with ",
4788 & " analysis by block"
4789C switch off 2x2 preprocessing for symmetric matrices
4790 id%KEEP(95) = 1
4791 ENDIF
4792 ENDIF
4793C
4794C end id%MYID.EQ.MASTER
4795 END IF
4796 RETURN
4797 END SUBROUTINE SMUMPS_ANA_CHECK_KEEP
4798 SUBROUTINE SMUMPS_GATHER_MATRIX(id)
4799C This subroutine gathers a distributed matrix
4800C on the host node
4801 USE SMUMPS_STRUC_DEF
4802 IMPLICIT NONE
4803 INCLUDE 'mpif.h'
4804 INCLUDE 'mumps_tags.h'
4805 INTEGER IERR, MASTER
4806 PARAMETER( MASTER = 0 )
4807 INTEGER :: STATUS(MPI_STATUS_SIZE)
4808 TYPE(SMUMPS_STRUC) :: id
4809C local variables
4810 INTEGER, ALLOCATABLE :: REQPTR(:,:)
4811 INTEGER(8), ALLOCATABLE :: MATPTR(:)
4812 INTEGER(8), ALLOCATABLE :: MATPTR_cp(:)
4813 INTEGER(8) :: IBEG8, IEND8
4814 INTEGER :: INDX
4815 INTEGER :: LP, MP, MPG, I, K
4816 INTEGER(8) :: I8
4817 LOGICAL :: PROK, PROKG
4818C
4819C messages are split into blocks of size BLOCKSIZE
4820C (smaller than IOVFLO (=2^31-1))
4821C on all processors
4822 INTEGER(4) :: IOVFLO
4823 INTEGER :: BLOCKSIZE
4824 INTEGER :: MAX_NBBLOCK_loc, NBBLOCK_loc
4825 INTEGER :: SIZE_SENT, NRECV
4826 LOGICAL :: OMP_FLAG, I_AM_SLAVE
4827 INTEGER(8) :: NZ_loc8
4828C for validation only:
4829 INTEGER :: NB_BLOCKS, NB_BLOCK_SENT
4830 LP = id%ICNTL( 1 )
4831 MP = id%ICNTL( 2 )
4832 MPG = id%ICNTL( 3 )
4833C LP : errors
4834C MP : INFO
4835.GT..AND..GE. PROK = (( MP 0 )(id%ICNTL(4)2))
4836.GT..and..eq. PROKG = ( MPG 0 id%MYID MASTER )
4837.AND..GE. PROKG = (PROKG(id%ICNTL(4)2))
4838.ne..OR. I_AM_SLAVE = ( id%MYID MASTER
4839.eq..AND. & ( id%MYID MASTER
4840.eq. & id%KEEP(46) 1 ) )
4841C iovflo = huge(INTEGER, kind=4)
4842 IOVFLO = huge(IOVFLO)
4843C we do not want too large messages
4844 BLOCKSIZE = int(max(100000_8,int(IOVFLO,8)/200_8))
4845.EQ..AND..EQ. IF ( id%KEEP(46) 0 id%MYID MASTER ) THEN
4846C host-node mode: master has no entries.
4847 id%KEEP8(29) = 0_8
4848 END IF
4849.eq. IF ( id%MYID MASTER ) THEN
4850C -----------------------------------
4851C Allocate small arrays for pointers
4852C into arrays IRN/JCN
4853C -----------------------------------
4854 ALLOCATE( MATPTR( id%NPROCS ), STAT = IERR )
4855.GT. IF ( IERR 0 ) THEN
4856 id%INFO(1) = -7
4857 id%INFO(2) = id%NPROCS
4858.GT. IF ( LP 0 ) THEN
4859 WRITE(LP, 150) ' array MATPTR'
4860 END IF
4861 GOTO 13
4862 END IF
4863 ALLOCATE( MATPTR_cp( id%NPROCS ), STAT = IERR )
4864.GT. IF ( IERR 0 ) THEN
4865 id%INFO(1) = -7
4866 id%INFO(2) = id%NPROCS
4867.GT. IF ( LP 0 ) THEN
4868 WRITE(LP, 150) ' array MATPTR'
4869 END IF
4870 GOTO 13
4871 END IF
4872C -----------------------------------
4873C Allocate a small array for requests
4874C -----------------------------------
4875 ALLOCATE( REQPTR( id%NPROCS-1, 2 ), STAT = IERR )
4876.GT. IF ( IERR 0 ) THEN
4877 id%INFO(1) = -7
4878 id%INFO(2) = 2 * (id%NPROCS-1)
4879.GT. IF ( LP 0 ) THEN
4880 WRITE(LP, 150) 'array REQPTR'
4881 END IF
4882 GOTO 13
4883 END IF
4884C --------------------
4885C Allocate now IRN/JCN
4886C --------------------
4887 ALLOCATE( id%IRN( id%KEEP8(28) ), STAT = IERR )
4888.GT. IF ( IERR 0 ) THEN
4889 id%INFO(1) = -7
4890 CALL MUMPS_SETI8TOI4(id%KEEP8(28),id%INFO(2))
4891.GT. IF ( LP 0 ) THEN
4892 WRITE(LP, 150) 'array IRN'
4893 END IF
4894 GOTO 13
4895 END IF
4896 ALLOCATE( id%JCN( id%KEEP8(28) ), STAT = IERR )
4897.GT. IF ( IERR 0 ) THEN
4898 id%INFO(1) = -7
4899 CALL MUMPS_SETI8TOI4(id%KEEP8(28),id%INFO(2))
4900.GT. IF ( LP 0 ) THEN
4901 WRITE(LP, 150) 'array JCN'
4902 END IF
4903 GOTO 13
4904 END IF
4905 END IF
4906 13 CONTINUE
4907C Propagate errors
4908 CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1),
4909 & id%COMM, id%MYID )
4910 IF ( id%INFO(1) < 0 ) RETURN
4911C -------------------------------------
4912C Get numbers of non-zeros for everyone
4913C and count total and maximum
4914C nb of blocks of size BLOCKSIZE
4915C that slaves will sent
4916C -------------------------------------
4917.EQ. IF ( id%MYID MASTER ) THEN
4918C each block will correspond to 2 messages (IRN_LOC,JCN_LOC)
4919 NB_BLOCK_SENT = 0
4920 MAX_NBBLOCK_loc = 0
4921 DO I = 1, id%NPROCS - 1
4922 CALL MPI_RECV( MATPTR( I+1 ), 1,
4923 & MPI_INTEGER8, I,
4924 & COLLECT_NZ, id%COMM, STATUS, IERR )
4925 NBBLOCK_loc = ceiling(dble(MATPTR(I+1))/dble(BLOCKSIZE))
4926 MAX_NBBLOCK_loc = max(MAX_NBBLOCK_loc, NBBLOCK_loc)
4927 NB_BLOCK_SENT = NB_BLOCK_SENT + NBBLOCK_loc
4928 END DO
4929.eq. IF ( id%KEEP(46) 0 ) THEN
4930 MATPTR( 1 ) = 1_8
4931 ELSE
4932 NZ_loc8=id%KEEP8(29)
4933 MATPTR( 1 ) = NZ_loc8 + 1_8
4934 END IF
4935C --------------
4936C Build pointers
4937C --------------
4938 DO I = 2, id%NPROCS
4939 MATPTR( I ) = MATPTR( I ) + MATPTR( I-1 )
4940 END DO
4941 ELSE
4942 NZ_loc8=id%KEEP8(29)
4943 CALL MPI_SEND( NZ_loc8, 1, MPI_INTEGER8, MASTER,
4944 & COLLECT_NZ, id%COMM, IERR )
4945 END IF
4946.eq. IF ( id%MYID MASTER ) THEN
4947C -----------------------------------------------
4948C Bottleneck is here master; use synchronous send
4949C for slaves, but asynchronous receives on master
4950C Then while master receives indices do the local
4951C copies for better overlap.
4952C (If master has other things to do, he could try
4953C to do them here.)
4954C ------------------------------------
4955C copy pointers to position in IRN/JCN
4956 MATPTR_cp = MATPTR
4957.NE. IF ( id%KEEP8(29) 0_8 ) THEN
4958.GE. OMP_FLAG = ( id%KEEP8(29)50000_8 )
4959!$OMP PARALLEL DO PRIVATE(I8)
4960!$OMP& IF(OMP_FLAG)
4961 DO I8=1,id%KEEP8(29)
4962 id%IRN(I8) = id%IRN_loc(I8)
4963 id%JCN(I8) = id%JCN_loc(I8)
4964 ENDDO
4965!$OMP END PARALLEL DO
4966 ENDIF
4967C
4968C Compute position for each block to be received
4969C and store it.
4970 NB_BLOCKS = 0
4971C at least one slave will send MAX_NBBLOCK_loc
4972C couple of messages (IRN_loc/JCN_loc)
4973 DO K = 1, MAX_NBBLOCK_loc
4974C Post irecv for all messages from proc I
4975C that have been sent
4976 NRECV = 0
4977 DO I = 1, id%NPROCS - 1
4978C Check if message was sent
4979 IBEG8 = MATPTR_cp( I )
4980.LT. IF ( IBEG8 MATPTR(I+1)) THEN
4981C Count number of request in NRECV
4982 NRECV = NRECV + 2
4983 IEND8 = min(IBEG8+int(BLOCKSIZE,8)-1_8,
4984 & MATPTR(I+1)-1_8)
4985C update pointer for receiving messages
4986C from proc I in MATPTR_cp:
4987 MATPTR_cp( I ) = IEND8 + 1_8
4988 SIZE_SENT = int(IEND8 - IBEG8 + 1_8)
4989 NB_BLOCKS = NB_BLOCKS + 1
4990C
4991 CALL MPI_IRECV( id%IRN(IBEG8), SIZE_SENT, MPI_INTEGER,
4992 & I, COLLECT_IRN, id%COMM, REQPTR(I,1), IERR )
4993C
4994 CALL MPI_IRECV( id%JCN(IBEG8), SIZE_SENT, MPI_INTEGER,
4995 & I, COLLECT_JCN, id%COMM, REQPTR(I,2), IERR )
4996 ELSE
4997 REQPTR( I,1 ) = MPI_REQUEST_NULL
4998 REQPTR( I,2 ) = MPI_REQUEST_NULL
4999 ENDIF
5000 END DO
5001C Wait set of messages corresponding to current block
5002C ( we dont exploit the fact that
5003C messages are not overtaking
5004C (if sent by one source to the same destination) )
5005C
5006C Loop on only non MPI_REQUEST_NULL requests
5007 DO I = 1, NRECV
5008 CALL MPI_WAITANY
5009 & ( 2 * (id%NPROCS-1), REQPTR( 1, 1 ), INDX,
5010 & STATUS, IERR )
5011 ENDDO
5012C
5013C process next block
5014 END DO
5015 DEALLOCATE( REQPTR )
5016 DEALLOCATE( MATPTR )
5017 DEALLOCATE( MATPTR_cp )
5018C end of reception by master
5019 ELSE
5020C -----------------------------
5021C Send only if size is not zero
5022C -----------------------------
5023.NE. IF ( id%KEEP8(29) 0_8 ) THEN
5024 NZ_loc8=id%KEEP8(29)
5025C send by blocks of size BLOCKSIZE
5026 DO I8=1_8, NZ_loc8, int(BLOCKSIZE,8)
5027 SIZE_SENT = BLOCKSIZE
5028.LT. IF (NZ_loc8-I8+1_8int(BLOCKSIZE,8)) THEN
5029 SIZE_SENT = int(NZ_loc8-I8+1_8)
5030 ENDIF
5031 CALL MPI_SEND( id%IRN_loc(I8), SIZE_SENT,
5032 & MPI_INTEGER, MASTER,
5033 & COLLECT_IRN, id%COMM, IERR )
5034 CALL MPI_SEND( id%JCN_loc(I8), SIZE_SENT,
5035 & MPI_INTEGER, MASTER,
5036 & COLLECT_JCN, id%COMM, IERR )
5037 END DO
5038 END IF
5039 END IF
5040 RETURN
5041 150 FORMAT(
5042 &/' ** FAILURE DURING SMUMPS_GATHER_MATRIX, DYNAMIC ALLOCATION OF',
5043 & A30)
5044 END SUBROUTINE SMUMPS_GATHER_MATRIX
5045 SUBROUTINE SMUMPS_DUMP_PROBLEM(id)
5046 USE SMUMPS_STRUC_DEF
5047 IMPLICIT NONE
5048C
5049C Purpose:
5050C =======
5051C
5052C If id%WRITE_PROBLEM has been set by the user,
5053C possibly on all processors in case of distributed
5054C matrix, open a file and dumps the matrix and/or
5055C the right hand side. In case the last characters
5056C of id.WRITE_PROBLEM are "bin" (uppercase letters
5057C are also accepted), then the matrix is written
5058C in binary stream format (a C routine is called to
5059C avoid depending on the access='stream' mode that
5060C is only available since Fortran 2003). In that case,
5061C a small header file is also written.
5062C Otherwise, this subroutine calls
5063C SMUMPS_DUMP_MATRIX (to write the matrix in
5064C matrix-market format) and SMUMPS_DUMP_RHS.
5065C The routine should be called on all MPI processes.
5066C
5067C Examples:
5068C 1/ WRITE_PROBLEM='mymatrix.txt', centralized matrix
5069C mymatrix.txt contains the matrix in matrix-market format
5070C 2/ WRITE_PROBLEM='mymatrix.txt', distributed matrix
5071C mymatrix.txt<i> contains the portion of the matrix
5072C on process <i>, in matrix-market format
5073C 3/ WRITE_PROBLEM='mymatrix.bin', centralized matrix
5074C mymatrix.bin contains the matrix in binary format
5075C mymatrix.header contains a short description in text format,
5076C with the first line identical to the one of
5077C a matrix-market format
5078C 4/ WRITE_PROBLEM='mymatrix.bin', distributed matrix
5079C mymatrix.bin<i> contains the portion of the matrix
5080C on process <i>, in binary format
5081C
5082C mymatrix.header contains a short description in text format,
5083C with the first line identical to matrix-market format
5084C
5085C If a centralized, dense, RHS is available, it is also written,
5086C either in matrix-market or binary format (if WRITE_PROBLEM
5087C has a .bin extension). In that case the filename for the RHS
5088C is WRITE_PROBLEM//".rhs". If written in binary form, information
5089C on the RHS is also provided in the header file.
5090C
5091 INCLUDE 'mpif.h'
5092C
5093C Arguments
5094C =========
5095C
5096 TYPE(SMUMPS_STRUC) :: id
5097C
5098C Local variables
5099C ===============
5100C
5101 INTEGER :: MASTER, IERR, I
5102 INTEGER :: IUNIT
5103 LOGICAL :: IS_ELEMENTAL
5104 LOGICAL :: IS_DISTRIBUTED
5105 LOGICAL :: NAME_INITIALIZED
5106 INTEGER :: DO_WRITE, DO_WRITE_CHECK
5107 CHARACTER(LEN=20) :: IDSTR
5108 LOGICAL :: I_AM_SLAVE, I_AM_MASTER
5109 INTEGER :: L
5110 LOGICAL :: BINARY_FORMAT, DUMP_RHS,
5111 & DUMP_BLKPTR, DUMP_BLKVAR
5112 INTEGER :: IS_A_PROVIDED, IS_A_PROVIDED_GLOB
5113 REAL, TARGET :: A_DUMMY(1)
5114 INTEGER, TARGET :: IRN_DUMMY(1), JCN_DUMMY(1)
5115 INTEGER, POINTER, DIMENSION(:) :: IRN_PASSED, JCN_PASSED
5116 REAL, POINTER, DIMENSION(:) :: A_PASSED
5117 PARAMETER( MASTER = 0 )
5118.NE..OR. I_AM_SLAVE = ( id%MYID MASTER
5119.EQ..AND. & ( id%MYID MASTER
5120.EQ. & id%KEEP(46) 1 ) )
5121.EQ. I_AM_MASTER = (id%MYIDMASTER)
5122 NAME_INITIALIZED = id%WRITE_PROBLEM(1:20)
5123.NE. & "name_not_initialized"
5124 BINARY_FORMAT = .FALSE.
5125 L=len_trim(id%WRITE_PROBLEM)
5126.GT. IF (L4) THEN
5127.EQ..AND. IF ( id%WRITE_PROBLEM(L-3:L-3) '.'
5128.EQ..OR. & ( id%WRITE_PROBLEM(L-2:L-2) 'b'
5129.EQ..AND. & id%WRITE_PROBLEM(L-2:L-2) 'B' )
5130.EQ..OR. & ( id%WRITE_PROBLEM(L-1:L-1) 'i'
5131.EQ..AND. & id%WRITE_PROBLEM(L-1:L-1) 'I' )
5132.EQ..OR. & ( id%WRITE_PROBLEM(L:L) 'n'
5133.EQ. & id%WRITE_PROBLEM(L:L) 'N' ) ) THEN
5134 BINARY_FORMAT = .TRUE.
5135 ENDIF
5136 ENDIF
5137C Check if RHS should also be dumped
5138.EQ..AND. DUMP_RHS = id%MYIDMASTER
5139.AND. & associated(id%RHS) NAME_INITIALIZED
5140.AND..GE. DUMP_RHS = DUMP_RHS id%NRHS 1
5141.AND..GE. DUMP_RHS = DUMP_RHS id%N 1
5142.AND..EQ. DUMP_RHS = DUMP_RHS id%ICNTL(20) 0
5143C Check if BLKPTR and/or BLKVAR should also be dumped
5144 DUMP_BLKPTR = .FALSE.
5145 DUMP_BLKVAR = .FALSE.
5146.EQ..AND. IF ( id%MYIDMASTER NAME_INITIALIZED ) THEN
5147.EQ. IF ( id%ICNTL(15) 1
5148.AND..GT. & id%NBLK 0 ) THEN
5149 IF (associated(id%BLKPTR)) THEN
5150 DUMP_BLKPTR = .TRUE.
5151 IF (associated(id%BLKVAR)) THEN
5152C Dump also BLKVAR, except if allocated by MUMPS
5153 DUMP_BLKVAR = .TRUE.
5154 ENDIF
5155 ENDIF
5156.LT. ELSE IF ( id%ICNTL(15) 0 ) THEN
5157 IF (associated(id%BLKVAR)) THEN
5158C Dump also BLKVAR, except if allocated by MUMPS
5159 DUMP_BLKVAR = .TRUE.
5160 ENDIF
5161 ENDIF
5162 ENDIF
5163C Remark: if id%KEEP(54) = 1 or 2, the structure
5164C is centralized at analysis. Since SMUMPS_DUMP_PROBLEM
5165C is called at analysis phase, we define IS_DISTRIBUTED
5166C as below, which implies that the structure of the problem
5167C is distributed in IRN_loc/JCN_loc at analysis.
5168.EQ. IS_DISTRIBUTED = (id%KEEP(54) 3)
5169.NE. IS_ELEMENTAL = (id%KEEP(55) 0)
5170 IF (NAME_INITIALIZED) THEN
5171.OR. IF (I_AM_MASTER IS_DISTRIBUTED) THEN
5172C Try to find a free Fortran unit
5173 CALL MUMPS_FIND_UNIT(IUNIT)
5174.EQ. IF ( IUNIT -1 ) THEN
5175 id%INFO(1) = -79
5176 id%INFO(2) = 1
5177 ENDIF
5178 ENDIF
5179 ENDIF
5180 CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1),
5181 & id%COMM, id%MYID )
5182.LT. IF (id%INFO(1) 0) GOTO 500
5183.AND..NOT. IF (I_AM_MASTER IS_DISTRIBUTED) THEN
5184C ====================
5185C Matrix is assembled
5186C and centralized
5187C ====================
5188 IF (NAME_INITIALIZED) THEN
5189 IF ( BINARY_FORMAT ) THEN
5190.EQ. IF (id%KEEP8(28) 0_8) THEN
5191C Special case of empty matrix
5192 A_PASSED => A_DUMMY
5193 IRN_PASSED => IRN_DUMMY
5194 JCN_PASSED => JCN_DUMMY
5195 IS_A_PROVIDED = 1
5196 ELSE IF (associated(id%A)) THEN
5197 A_PASSED=>id%A
5198 IRN_PASSED => id%IRN
5199 JCN_PASSED => id%JCN
5200 IS_A_PROVIDED = 1
5201 ELSE
5202 A_PASSED => A_DUMMY
5203 IRN_PASSED => id%IRN
5204 JCN_PASSED => id%JCN
5205 IS_A_PROVIDED = 0
5206 ENDIF
5207 OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.header' )
5208 CALL SMUMPS_DUMP_HEADER( IUNIT, id%N,
5209 & IS_A_PROVIDED, id%KEEP(50), IS_DISTRIBUTED,
5210 & id%NSLAVES, id%KEEP8(28), DUMP_RHS, id%NRHS,
5211 & DUMP_BLKPTR, DUMP_BLKVAR, id%NBLK, id%ICNTL(15) )
5212 CLOSE( IUNIT )
5213 CALL MUMPS_DUMPMATBINARY_C( id%N, id%KEEP8(28),
5214 & id%KEEP(35),
5215 & IRN_PASSED(1), JCN_PASSED(1), A_PASSED(1),
5216 & IS_A_PROVIDED,
5217 & trim(id%WRITE_PROBLEM)//char(0) )
5218 ELSE
5219 OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM))
5220 CALL SMUMPS_DUMP_MATRIX( id, IUNIT, I_AM_SLAVE, I_AM_MASTER,
5221 & IS_DISTRIBUTED, ! = .FALSE., centralized
5222 & IS_ELEMENTAL, ! Elemental or not
5223 & .FALSE.)
5224 CLOSE(IUNIT)
5225 ENDIF
5226 ENDIF
5227 ELSE IF ( IS_DISTRIBUTED ) THEN
5228C =====================
5229C Matrix is distributed
5230C =====================
5231.NOT. IF ( NAME_INITIALIZED
5232.OR..NOT. & I_AM_SLAVE )THEN
5233 DO_WRITE = 0
5234 ELSE
5235 DO_WRITE = 1
5236 ENDIF
5237 CALL MPI_ALLREDUCE(DO_WRITE, DO_WRITE_CHECK, 1,
5238 & MPI_INTEGER, MPI_SUM, id%COMM, IERR)
5239C -----------------------------------------
5240C If yes, each processor writes its share
5241C of the matrix in a file in matrix market
5242C format (otherwise nothing written). We
5243C append the process id to the filename.
5244C Safer in case all filenames are the
5245C same if all processors share the same
5246C file system.
5247C -----------------------------------------
5248.EQ..AND. IF (DO_WRITE_CHECKid%NSLAVES I_AM_SLAVE) THEN
5249 WRITE(IDSTR,'(I9)') id%MYID_NODES
5250 IF (BINARY_FORMAT) THEN
5251.EQ. IF (id%KEEP8(29) 0_8) THEN
5252C Special case of empty matrix
5253 A_PASSED => A_DUMMY
5254 IRN_PASSED => IRN_DUMMY
5255 JCN_PASSED => JCN_DUMMY
5256C (consider that A is provided when NNZ_loc=0)
5257 IS_A_PROVIDED = 1
5258 ELSE IF (associated(id%A_loc)) THEN
5259 A_PASSED=>id%A_loc
5260 IRN_PASSED => id%IRN_loc
5261 JCN_PASSED => id%JCN_loc
5262 IS_A_PROVIDED = 1
5263 ELSE
5264 A_PASSED => A_DUMMY
5265 IRN_PASSED => id%IRN_loc
5266 JCN_PASSED => id%JCN_loc
5267 IS_A_PROVIDED = 0
5268 ENDIF
5269 CALL MPI_ALLREDUCE( IS_A_PROVIDED,
5270 & IS_A_PROVIDED_GLOB, 1,
5271 & MPI_INTEGER, MPI_PROD, id%COMM_NODES, IERR )
5272C IS_A_PROVIDED_GLOB = 1 => dump numerical values
5273C IS_A_PROVIDED_GLOB = 0 => some processes did not provide
5274C numerical values, dump only pattern,
5275C and indicate this in the header
5276.EQ. IF ( id%MYID_NODES0) THEN
5277C Print header on first MPI worker (only one global header
5278C file in case of distributed matrix), replacing the .bin
5279C extension by a .header extension
5280 OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.header' )
5281 CALL SMUMPS_DUMP_HEADER( IUNIT, id%N,
5282 & IS_A_PROVIDED_GLOB, id%KEEP(50), IS_DISTRIBUTED,
5283 & id%NSLAVES, id%KEEP8(28), DUMP_RHS, id%NRHS,
5284 & DUMP_BLKPTR, DUMP_BLKVAR, id%NBLK, id%ICNTL(15) )
5285 CLOSE( IUNIT )
5286 ENDIF
5287 CALL MUMPS_DUMPMATBINARY_C( id%N, id%KEEP8(29),
5288 & id%KEEP(35),
5289 & IRN_PASSED(1), JCN_PASSED(1), A_PASSED(1),
5290 & IS_A_PROVIDED_GLOB,
5291 & trim(id%WRITE_PROBLEM)//trim(adjustl(IDSTR))//char(0) )
5292 ELSE
5293 OPEN(IUNIT,
5294 & FILE=trim(id%WRITE_PROBLEM)//trim(adjustl(IDSTR)))
5295 CALL SMUMPS_DUMP_MATRIX(id,
5296 & IUNIT, I_AM_SLAVE, I_AM_MASTER,
5297 & IS_DISTRIBUTED, ! =.TRUE., distributed
5298 & IS_ELEMENTAL, ! Elemental or not
5299 & .FALSE.)
5300 CLOSE(IUNIT)
5301 ENDIF
5302 ENDIF
5303C ELSE ...
5304C Nothing written in other cases.
5305 ENDIF
5306C ===============
5307C Right-hand side
5308C ===============
5309 IF ( DUMP_RHS ) THEN
5310 IF (BINARY_FORMAT) THEN
5311C dump RHS in binary format
5312 CALL MUMPS_DUMPRHSBINARY_C( id%N, id%NRHS, id%LRHS, id%RHS(1),
5313 & id%KEEP(35),
5314 & trim(id%WRITE_PROBLEM)//'.rhs'//char(0) )
5315 ELSE
5316C dump RHS in matrix-market format
5317 OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM) //".rhs")
5318 CALL SMUMPS_DUMP_RHS(IUNIT, id)
5319 CLOSE(IUNIT)
5320 ENDIF
5321 ENDIF
5322 IF ( DUMP_BLKPTR ) THEN
5323 IF (BINARY_FORMAT) THEN
5324! suppress trailing '.bin' and use '.blkptr'
5325 OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.blkptr' )
5326 ELSE
5327! just append '.blkptr'
5328 OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM)//".blkptr")
5329 ENDIF
5330 WRITE(IUNIT,'(I9)') id%NBLK
5331 DO I=1,id%NBLK+1
5332 WRITE(IUNIT,'(I9)') id%BLKPTR(I)
5333 ENDDO
5334 CLOSE(IUNIT)
5335 ENDIF
5336 IF ( DUMP_BLKVAR ) THEN
5337 IF (BINARY_FORMAT) THEN
5338! suppress trailing '.bin' and use '.blkvar'
5339 OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.blkvar' )
5340 ELSE
5341! just append '.blkvar'
5342 OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM)//".blkvar")
5343 ENDIF
5344 DO I=1,id%N
5345 WRITE(IUNIT,'(I9)') id%BLKVAR(I)
5346 ENDDO
5347 CLOSE(IUNIT)
5348 ENDIF
5349 500 CONTINUE
5350 RETURN
5351 END SUBROUTINE SMUMPS_DUMP_PROBLEM
5352 SUBROUTINE SMUMPS_DUMP_HEADER( IUNIT, N, IS_A_PROVIDED_GLOB,
5353 & SYM, IS_DISTRIBUTED, NSLAVES, NNZTOT, DUMP_RHS, NRHS,
5354 & DUMP_BLKPTR, DUMP_BLKVAR, NBLK, ICNTL15 )
5355C
5356C Purpose:
5357C =======
5358C
5359C Write a small header file, similar to matrix-market headers,
5360C to accompany a matrix written in binary format.
5361C
5362 INTEGER, INTENT(IN) :: IUNIT, N, IS_A_PROVIDED_GLOB , SYM, NSLAVES
5363 INTEGER(8), INTENT(IN) :: NNZTOT
5364 LOGICAL, INTENT(IN) :: IS_DISTRIBUTED, DUMP_RHS
5365 INTEGER, INTENT(IN) :: NRHS
5366 LOGICAL, INTENT(IN) :: DUMP_BLKPTR, DUMP_BLKVAR
5367 INTEGER, INTENT(IN) :: NBLK
5368 INTEGER, INTENT(IN) :: ICNTL15
5369C
5370C Local declarations:
5371C ==================
5372C
5373 CHARACTER (LEN=10) :: SYMM
5374 CHARACTER (LEN=8) :: ARITH
5375C 1/ write a line identical to first line of matrix-market header
5376.EQ. IF ( IS_A_PROVIDED_GLOB 1 ) THEN
5377 ARITH='real'
5378 ELSE
5379 ARITH='pattern'
5380 ENDIF
5381.eq. IF (SYM 0) THEN
5382 SYMM="general"
5383 ELSE
5384 SYMM="symmetric"
5385 END IF
5386 WRITE(IUNIT,'(A,A,A,A)') '%%MatrixMarket matrix coordinate ',
5387 & trim(ARITH)," ",trim(SYMM)
5388C 2/ indicate if matrix is distributed or centralized,
5389C then describe binary file content and format
5390 IF ( IS_DISTRIBUTED ) THEN
5391 WRITE(IUNIT,FMT='(A,I5,A)')
5392 & '% Matrix is distributed (MPI ranks=',NSLAVES,')'
5393 ELSE
5394 WRITE(IUNIT,FMT='(A)')
5395 & '% Matrix is centralized'
5396 ENDIF
5397 WRITE(IUNIT,FMT='(A)')
5398 & '% Unformatted stream IO (no record boundaries):'
5399.EQ. IF (ARITH(1:7)'pattern') THEN
5400 IF (IS_DISTRIBUTED) THEN
5401 WRITE(IUNIT,'(A)')
5402 & '% N,NNZ_loc,IRN_loc(1:NNZ_loc),JCN_loc(1:NNZ_loc)'
5403 ELSE
5404 WRITE(IUNIT,'(A)')
5405 & '% N,NNZ,IRN(1:NNZ),JCN(1:NNZ)'
5406 ENDIF
5407 WRITE(IUNIT,'(A)') '% (numerical values not provided)'
5408 ELSE
5409 IF (IS_DISTRIBUTED) THEN
5410 WRITE(IUNIT,'(A)')
5411 & '% N,NNZ_loc,IRN_loc(1:NNZ_loc),JCN_loc(1:NNZ_loc),'//
5412 & 'A_loc(1:NNZ_loc)'
5413 ELSE
5414 WRITE(IUNIT,'(A)') '% N/NNZ/IRN(1:NNZ),JCN(1:NNZ),A(1:NNZ)'
5415 ENDIF
5416 WRITE(IUNIT,'(A)') '% Single precision storage'
5417 ENDIF
5418 IF ( IS_DISTRIBUTED ) THEN
5419 WRITE(IUNIT,'(A,/,A)')
5420 & '% N,IRN_loc(i),JCN_loc(i): 32 bits',
5421 & '% NNZ_loc: 64 bits'
5422 ELSE
5423 WRITE(IUNIT,'(A,/,A)')
5424 & '% N,IRN(i),JCN(i): 32 bits',
5425 & '% NNZ: 64 bits'
5426 ENDIF
5427 WRITE(IUNIT,FMT='(A,I12)') '% Matrix order: N=',N
5428 WRITE(IUNIT,FMT='(A,I12)') '% Matrix nonzeros: NNZ=',NNZTOT
5429 IF (DUMP_RHS) THEN
5430 WRITE(IUNIT,FMT='(A)') '%'
5431 WRITE(IUNIT,FMT='(A,/,A,I10,A,I5)')
5432 & '% A RHS was also written to disk by columns in binary form.',
5433 & '% Size: N rows x NRHS columns with N=',N,' NRHS=',NRHS
5434 WRITE(IUNIT,FMT='(A,I12,A)')
5435 & '% Total:',int(N,8)*int(NRHS,8),' scalar values.'
5436 WRITE(IUNIT,'(A)') '% Single precision storage'
5437 ENDIF
5438 IF (DUMP_BLKPTR) THEN
5439 WRITE(IUNIT,FMT='(A)') '%'
5440 WRITE(IUNIT,'(A,I9,A)') '% Matrix has a block format with',
5441 & NBLK,' blocks'
5442 WRITE(IUNIT,'(A)')
5443 & '% File <matrix>.blkptr contains NBLK and BLKPTR(1:NBLK+1)'
5444.LT. ELSE IF (ICNTL15 0) THEN
5445 WRITE(IUNIT,FMT='(A)') '%'
5446 WRITE(IUNIT,'(A,I9,A)')
5447 & '% Matrix has a block format with ICNTL15=',ICNTL15
5448 ENDIF
5449 IF (DUMP_BLKVAR) THEN
5450 WRITE(IUNIT,'(A)')
5451 & '% File <matrix>.blkvar contains BLKVAR (N integers)'
5452.NE. ELSE IF (ICNTL15 0) THEN
5453 WRITE(IUNIT,'(A)')
5454 & '% (BLKVAR considered to be identity is not written)'
5455 ENDIF
5456 RETURN
5457 END SUBROUTINE SMUMPS_DUMP_HEADER
5458 SUBROUTINE SMUMPS_DUMP_MATRIX
5459 & (id, IUNIT, I_AM_SLAVE, I_AM_MASTER,
5460 & IS_DISTRIBUTED, IS_ELEMENTAL, PATTERN_ONLY )
5461 USE SMUMPS_STRUC_DEF
5462 IMPLICIT NONE
5463C
5464C Purpose:
5465C =======
5466C This subroutine dumps a routine in matrix-market format
5467C if the matrix is assembled, and in "MUMPS" format (see
5468C example in the MUMPS users'guide, if the matrix is
5469C centralized and elemental).
5470C The routine can be called on all processors. In case of
5471C distributed assembled matrix, each processor writes its
5472C share as a matrix market file on IUNIT (IUNIT may have
5473C different values on different processors).
5474C
5475C
5476C
5477C Arguments (input parameters)
5478C ============================
5479C
5480C IUNIT: should be set to the Fortran unit where
5481C data should be written.
5482C I_AM_SLAVE: .TRUE. except on a non working master
5483C IS_DISTRIBUTED: .TRUE. if matrix is distributed,
5484C i.e., if IRN_loc/JCN_loc are provided.
5485C IS_ELEMENTAL : .TRUE. if matrix is elemental
5486C id : main MUMPS structure
5487C
5488 LOGICAL, intent(in) :: I_AM_SLAVE,
5489 & I_AM_MASTER,
5490 & IS_DISTRIBUTED,
5491 & IS_ELEMENTAL,
5492 & PATTERN_ONLY
5493 INTEGER, intent(in) :: IUNIT
5494 TYPE(SMUMPS_STRUC), intent(in) :: id
5495C
5496C Local variables:
5497C ===============
5498C
5499 CHARACTER (LEN=10) :: SYMM
5500 CHARACTER (LEN=8) :: ARITH
5501 INTEGER(8) :: I8, NNZ_i
5502C
5503C Executable statements:
5504C =====================
5505.AND..NOT..AND. IF (I_AM_MASTER IS_DISTRIBUTED
5506.NOT. & IS_ELEMENTAL) THEN
5507C ==================
5508C CENTRALIZED MATRIX
5509C ==================
5510.EQ. IF (id%KEEP8(28) 0_8) THEN
5511 CALL MUMPS_GET_NNZ_INTERNAL(id%NNZ, id%NZ, NNZ_i)
5512 ELSE
5513 NNZ_i=id%KEEP8(28)
5514 ENDIF
5515.AND..NOT. IF ((associated(id%A))(PATTERN_ONLY)) THEN
5516C Write header line:
5517 ARITH='real'
5518 ELSE
5519 ARITH='pattern '
5520 ENDIF
5521.eq. IF (id%KEEP(50) 0) THEN
5522 SYMM="general"
5523 ELSE
5524 SYMM="symmetric"
5525 END IF
5526 WRITE(IUNIT,FMT=*)'%%MatrixMarket matrix coordinate ',
5527 & trim(ARITH)," ",trim(SYMM)
5528 WRITE(IUNIT,*) id%N, id%N, NNZ_i
5529.AND..NOT. IF ((associated(id%A))(PATTERN_ONLY)) THEN
5530 DO I8=1_8,NNZ_i
5531.NE..AND..LT. IF (id%KEEP(50)0 id%IRN(I8)id%JCN(I8)) THEN
5532C permute upper diag entry
5533 WRITE(IUNIT,*) id%JCN(I8), id%IRN(I8), id%A(I8)
5534 ELSE
5535 WRITE(IUNIT,*) id%IRN(I8), id%JCN(I8), id%A(I8)
5536 ENDIF
5537 ENDDO
5538 ELSE
5539C pattern only
5540 DO I8=1_8,id%KEEP8(28)
5541.NE..AND..LT. IF (id%KEEP(50)0 id%IRN(I8)id%JCN(I8)) THEN
5542C permute upper diag entry
5543 WRITE(IUNIT,*) id%JCN(I8), id%IRN(I8)
5544 ELSE
5545 WRITE(IUNIT,*) id%IRN(I8), id%JCN(I8)
5546 ENDIF
5547 ENDDO
5548 ENDIF
5549.AND. ELSE IF ( IS_DISTRIBUTED I_AM_SLAVE ) THEN
5550C ==================
5551C DISTRIBUTED MATRIX
5552C ==================
5553.EQ. IF (id%KEEP8(29) 0_8) THEN
5554 CALL MUMPS_GET_NNZ_INTERNAL(id%NNZ_loc, id%NZ_loc, NNZ_i)
5555 ELSE
5556 NNZ_i=id%KEEP8(29)
5557 ENDIF
5558.AND..NOT. IF ((associated(id%A_loc))(PATTERN_ONLY)) THEN
5559 ARITH='real'
5560 ELSE
5561 ARITH='pattern '
5562 ENDIF
5563.eq. IF (id%KEEP(50) 0) THEN
5564 SYMM="general"
5565 ELSE
5566 SYMM="symmetric"
5567 END IF
5568 WRITE(IUNIT,FMT=*)'%%MatrixMarket matrix coordinate ',
5569 & trim(ARITH)," ",trim(SYMM)
5570 WRITE(IUNIT,*) id%N, id%N, NNZ_i
5571.AND..NOT. IF ((associated(id%A_loc))(PATTERN_ONLY)) THEN
5572 DO I8=1_8,NNZ_i
5573.NE..AND. IF (id%KEEP(50)0
5574.LT. & id%IRN_loc(I8)id%JCN_loc(I8)) THEN
5575 WRITE(IUNIT,*) id%JCN_loc(I8), id%IRN_loc(I8),
5576 & id%A_loc(I8)
5577 ELSE
5578 WRITE(IUNIT,*) id%IRN_loc(I8), id%JCN_loc(I8),
5579 & id%A_loc(I8)
5580 ENDIF
5581 ENDDO
5582 ELSE
5583 DO I8=1_8,NNZ_i
5584.NE..AND. IF (id%KEEP(50)0
5585.LT. & id%IRN_loc(I8)id%JCN_loc(I8)) THEN
5586C permute upper diag entry
5587 WRITE(IUNIT,*) id%JCN_loc(I8), id%IRN_loc(I8)
5588 ELSE
5589 WRITE(IUNIT,*) id%IRN_loc(I8), id%JCN_loc(I8)
5590 ENDIF
5591 ENDDO
5592 ENDIF
5593.AND. ELSE IF (IS_ELEMENTAL I_AM_MASTER) THEN
5594C ==================
5595C ELEMENTAL MATRIX
5596C ==================
5597 WRITE(IUNIT,*) id%N," :: n"
5598 WRITE(IUNIT,*) id%NELT," :: nelt"
5599 WRITE(IUNIT,*) size(id%ELTVAR)," :: neltvar"
5600 WRITE(IUNIT,*) size(id%A_ELT)," :: neltvl"
5601 WRITE(IUNIT,*) id%ELTPTR(:)," ::eltptr"
5602 WRITE(IUNIT,*) id%ELTVAR(:)," ::eltvar"
5603.NOT. IF(PATTERN_ONLY) THEN
5604 WRITE(IUNIT,*) id%A_ELT(:)
5605 ENDIF
5606 ENDIF
5607 RETURN
5608 END SUBROUTINE SMUMPS_DUMP_MATRIX
5609 SUBROUTINE SMUMPS_DUMP_RHS(IUNIT, id)
5610C
5611C Purpose:
5612C =======
5613C Dumps a dense, centralized,
5614C right-hand side in matrix market format on unit
5615C IUNIT. Should be called on the host only.
5616C
5617 USE SMUMPS_STRUC_DEF
5618 IMPLICIT NONE
5619C Arguments
5620C =========
5621 TYPE(SMUMPS_STRUC), intent(in) :: id
5622 INTEGER, intent(in) :: IUNIT
5623C
5624C Local variables
5625C ===============
5626C
5627 CHARACTER (LEN=8) :: ARITH
5628 INTEGER :: I, J
5629 INTEGER(8) :: LD_RHS8, K8
5630C
5631C Executable statements
5632C =====================
5633C
5634 IF (associated(id%RHS)) THEN
5635 ARITH='real'
5636 WRITE(IUNIT,FMT=*)'%%MatrixMarket matrix array ',
5637 & trim(ARITH),
5638 & ' general'
5639 WRITE(IUNIT,*) id%N, id%NRHS
5640.EQ. IF ( id%NRHS 1 ) THEN
5641 LD_RHS8 = int(id%N,8)
5642 ELSE
5643 LD_RHS8 = int(id%LRHS,8)
5644 ENDIF
5645 DO J = 1, id%NRHS
5646 DO I = 1, id%N
5647 K8=int(J-1,8)*LD_RHS8+int(I,8)
5648 WRITE(IUNIT,*) id%RHS(K8)
5649 ENDDO
5650 ENDDO
5651 ENDIF
5652 RETURN
5653 END SUBROUTINE SMUMPS_DUMP_RHS
5654 SUBROUTINE SMUMPS_BUILD_I_AM_CAND( NSLAVES, K79,
5655 & NB_NIV2, MYID_NODES,
5656 & CANDIDATES, I_AM_CAND )
5657 IMPLICIT NONE
5658C
5659C Purpose:
5660C =======
5661C Given a list of candidate processors per node,
5662C returns an array of booleans telling whether the
5663C processor is candidate or not for a given node.
5664C
5665C K79 holds splitting strategy (KEEP(79)). If K79>1 then
5666C TPYE4,5,6 nodes might have been introduced and
5667C in this case "hidden" slaves should be taken
5668C into account to enable dynamic redistribution
5669C of the hidden slaves while climbing the chain of
5670C split nodes. The master of the first node in the
5671C chain requires a special treatment and is thus here
5672C not considered as a slave.
5673C
5674 INTEGER, intent(in) :: NSLAVES, NB_NIV2, MYID_NODES, K79
5675 INTEGER, intent(in) :: CANDIDATES( NSLAVES+1, NB_NIV2 )
5676 LOGICAL, intent(out):: I_AM_CAND( NB_NIV2 )
5677 INTEGER I, INIV2, NCAND
5678.GT. IF (K790) THEN
5679C Because of potential restarting the number of
5680C candidates that will be used to distribute
5681C arrowheads have to include all possible candidates.
5682 DO INIV2=1, NB_NIV2
5683 I_AM_CAND(INIV2)=.FALSE.
5684 NCAND = CANDIDATES(NSLAVES+1,INIV2)
5685C check if some hidden slaves are there
5686C Note that if hidden candidates exists (type 5 or 6 nodes) then
5687C in position CANDIDATES (NCAND+1,INIV2) must be the master
5688C of the first node in the chain (type 4) that we skip here because
5689C a special treatment (it has to be "considered as a master" for all
5690C nodes in the list) is needed.
5691 DO I=1, NSLAVES
5692.LT. IF (CANDIDATES(I,INIV2)0) EXIT ! end of extra slaves
5693.EQ. IF (INCAND+1) CYCLE
5694! skip master of associated TYPE 4 node
5695.EQ. IF (CANDIDATES(I,INIV2)MYID_NODES) THEN
5696 I_AM_CAND(INIV2)=.TRUE.
5697 EXIT
5698 ENDIF
5699 ENDDO
5700 END DO
5701 ELSE
5702 DO INIV2=1, NB_NIV2
5703 I_AM_CAND(INIV2)=.FALSE.
5704 NCAND = CANDIDATES(NSLAVES+1,INIV2)
5705 DO I=1, NCAND
5706.EQ. IF (CANDIDATES(I,INIV2)MYID_NODES) THEN
5707 I_AM_CAND(INIV2)=.TRUE.
5708 EXIT
5709 ENDIF
5710 ENDDO
5711 END DO
5712 ENDIF
5713 RETURN
5714 END SUBROUTINE SMUMPS_BUILD_I_AM_CAND
5715 SUBROUTINE SMUMPS_FREE_ONENTRY_ANA_DRIVER (id)
5716C Purpose:
5717C =======
5718C When the analysis step is called twice
5719C free arrays that might have been computed
5720C during previous analysis step (to be passed to
5721C the factorization phase)
5722C
5723 USE SMUMPS_STRUC_DEF
5724 TYPE (SMUMPS_STRUC), TARGET :: id
5725C
5726 IF (associated(id%STEP)) THEN
5727 DEALLOCATE(id%STEP)
5728 NULLIFY (id%STEP)
5729 ENDIF
5730 IF (associated(id%NE_STEPS)) THEN
5731 DEALLOCATE(id%NE_STEPS)
5732 NULLIFY (id%NE_STEPS)
5733 ENDIF
5734 IF (associated(id%ND_STEPS)) THEN
5735 DEALLOCATE(id%ND_STEPS)
5736 NULLIFY (id%ND_STEPS)
5737 ENDIF
5738 IF (associated(id%FRERE_STEPS)) THEN
5739 DEALLOCATE(id%FRERE_STEPS)
5740 NULLIFY (id%FRERE_STEPS)
5741 ENDIF
5742 IF (associated(id%DAD_STEPS)) THEN
5743 DEALLOCATE(id%DAD_STEPS)
5744 NULLIFY (id%DAD_STEPS)
5745 ENDIF
5746 IF (associated(id%PTRAR)) THEN
5747 DEALLOCATE(id%PTRAR)
5748 NULLIFY (id%PTRAR)
5749 ENDIF
5750 IF (associated(id%UNS_PERM)) THEN
5751 DEALLOCATE(id%UNS_PERM)
5752 NULLIFY (id%UNS_PERM)
5753 ENDIF
5754 IF (associated(id%LRGROUPS)) THEN
5755 DEALLOCATE(id%LRGROUPS)
5756 NULLIFY (id%UNS_PERM)
5757 ENDIF
5758 IF (associated(id%FILS)) THEN
5759 DEALLOCATE(id%FILS)
5760 NULLIFY (id%FILS)
5761 ENDIF
5762 IF (associated(id%FRTPTR)) THEN
5763 DEALLOCATE(id%FRTPTR)
5764 NULLIFY (id%FRTPTR)
5765 ENDIF
5766 IF (associated(id%PROCNODE_STEPS)) THEN
5767 DEALLOCATE(id%PROCNODE_STEPS)
5768 NULLIFY (id%PROCNODE_STEPS)
5769 ENDIF
5770 IF (associated(id%NA)) THEN
5771 DEALLOCATE(id%NA)
5772 NULLIFY (id%NA)
5773 ENDIF
5774 IF (associated(id%Step2node)) THEN
5775 DEALLOCATE(id%Step2node)
5776 NULLIFY (id%Step2node)
5777 ENDIF
5778 IF (associated(id%CANDIDATES)) THEN
5779 DEALLOCATE(id%CANDIDATES)
5780 NULLIFY (id%CANDIDATES)
5781 ENDIF
5782 IF (associated(id%ISTEP_TO_INIV2)) THEN
5783 DEALLOCATE(id%ISTEP_TO_INIV2)
5784 NULLIFY (id%ISTEP_TO_INIV2)
5785 ENDIF
5786 IF (associated(id%FUTURE_NIV2)) THEN
5787 DEALLOCATE(id%FUTURE_NIV2)
5788 NULLIFY (id%FUTURE_NIV2)
5789 ENDIF
5790 IF (associated(id%TAB_POS_IN_PERE)) THEN
5791 DEALLOCATE(id%TAB_POS_IN_PERE)
5792 NULLIFY (id%TAB_POS_IN_PERE)
5793 ENDIF
5794 IF (associated(id%I_AM_CAND)) THEN
5795 DEALLOCATE(id%I_AM_CAND)
5796 NULLIFY (id%I_AM_CAND)
5797 ENDIF
5798 RETURN
5799 END SUBROUTINE SMUMPS_FREE_ONENTRY_ANA_DRIVER
mumps_abort
#define mumps_abort
Definition VE_Metis.h:25
mumps_ab_dcoord_to_dtree_lumat
subroutine mumps_ab_dcoord_to_dtree_lumat(myid, nprocs, comm, nblk, ndof, nnz, irn, jcn, procnode_steps, nsteps, step, icntl, info, keep, mapcol, lumat)
Definition ana_blk.F:993
mumps_ab_lmat_to_clean_g
subroutine mumps_ab_lmat_to_clean_g(myid, unfold, ready_for_ana_f, lmat, gcomp, info, icntl)
Definition ana_blk.F:291
mumps_ab_compute_sizeofblock
subroutine mumps_ab_compute_sizeofblock(nblk, ndof, blkptr, blkvar, sizeofblocks, dof2block)
Definition ana_blk.F:48
mumps_inialize_redist_lumat
subroutine mumps_inialize_redist_lumat(info, icntl, keep, comm, myid, nblk, lumat, procnode_steps, nsteps, mapcol, lumat_remap, nbrecords, step)
Definition ana_blk.F:789
mumps_ab_lmat_to_lumat
subroutine mumps_ab_lmat_to_lumat(lmat, lumat, info, icntl)
Definition ana_blk.F:210
mumps_ab_gather_graph
subroutine mumps_ab_gather_graph(icntl, keep, comm, myid, nprocs, info, gcomp_dist, gcomp)
Definition ana_blk.F:1395
mumps_ab_free_gcomp
subroutine mumps_ab_free_gcomp(gcomp)
Definition ana_blk.F:32
mumps_ab_dist_lmat_to_lumat
subroutine mumps_ab_dist_lmat_to_lumat(unfold, mapcol_in_nsteps, info, icntl, comm, myid, nblk, slavef, lmat, mapcol, sizemapcol, step, sizestep, lumat, nbrecords, nsend8, nlocal8)
Definition ana_blk.F:1082
mumps_ab_coord_to_lmat
subroutine mumps_ab_coord_to_lmat(myid, nblk, ndof, nnz, irn, jcn, dof2block, iflag, ierror, lp, lpok, lmat)
Definition ana_blk.F:67
mumps_ab_dcoord_to_dcompg
subroutine mumps_ab_dcoord_to_dcompg(myid, nprocs, comm, nblk, ndof, nnz, irn, jcn, dof2block, icntl, info, keep, lumat, gcomp, ready_for_ana_f)
Definition ana_blk.F:894
mumps_ab_free_lmat
subroutine mumps_ab_free_lmat(lmat)
Definition ana_blk.F:15
mumps_propinfo
subroutine mumps_propinfo(icntl, info, comm, id)
Definition bcast_errors.F:15
mumps_memory_mod::mumps_realloc
Definition mumps_memory_mod.F:18
smumps_parallel_analysis::smumps_ana_f_par
Definition sana_aux_par.F:20
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
mpi_recv
subroutine mpi_recv(buf, cnt, datatype, source, tag, comm, status, ierr)
Definition mpi.f:461
mpi_send
subroutine mpi_send(buf, cnt, datatype, dest, tag, comm, ierr)
Definition mpi.f:480
mpi_allreduce
subroutine mpi_allreduce(sendbuf, recvbuf, cnt, datatype, operation, comm, ierr)
Definition mpi.f:103
mpi_bcast
subroutine mpi_bcast(buffer, cnt, datatype, root, comm, ierr)
Definition mpi.f:205
mumps_ana_blk_m
Definition ana_blk_m.F:14
mumps_ana_omp_m
Definition ana_omp_m.F:14
mumps_ana_omp_m::mumps_ana_l0_omp
subroutine mumps_ana_l0_omp(nb_threads, n, nsteps, sym, slavef, dad, frere, fils, nstk_steps, nd, step, procnode_steps, keep, keep8, myid_nodes, na, lna, arith, lpool_b_l0_omp, ipool_b_l0_omp, lpool_a_l0_omp, ipool_a_l0_omp, l_virt_l0_omp, virt_l0_omp, virt_l0_omp_mapping, l_phys_l0_omp, phys_l0_omp, perm_l0_omp, ptr_leafs_l0_omp, thread_la, info, icntl)
Definition ana_omp_m.F:23
mumps_lr_common
Definition lr_common.F:14
mumps_memory_mod
Definition mumps_memory_mod.F:14
mumps_memory_mod::mumps_i8realloc
subroutine mumps_i8realloc(array, minsize, info, lp, force, copy, string, memcnt, errcode)
Definition mumps_memory_mod.F:141
mumps_static_mapping
Definition mumps_static_mapping.F:14
mumps_static_mapping::mumps_end_arch_cv
subroutine, public mumps_end_arch_cv()
Definition mumps_static_mapping.F:4598
mumps_static_mapping::mumps_init_arch_parameters
subroutine, public mumps_init_arch_parameters(total_comm, working_comm, keep69, par, nbslaves, mem_distrib, informerr)
Definition mumps_static_mapping.F:4339
mumps_static_mapping::mumps_return_candidates
subroutine, public mumps_return_candidates(par2_nodes, cand, istat)
Definition mumps_static_mapping.F:4316
smumps_ana_aux_m
Definition sana_aux.F:19
smumps_ana_aux_m::smumps_ana_o
subroutine smumps_ana_o(n, nz, mtrans, perm, ikeepalloc, idirn, idjcn, ida, idrowsca, idcolsca, work2, keep, icntl, info, infog)
Definition sana_aux.F:1273
smumps_ana_aux_m::smumps_ana_f
subroutine smumps_ana_f(n, nz8, irn, icn, liwalloc, ikeep1, ikeep2, ikeep3, iord, nfsiz, fils, frere, listvar_schur, size_schur, icntl, info, keep, keep8, nslaves, piv, cntl4, colsca, rowsca, norig_arg, sizeofblocks, gcomp_provided_in, gcomp)
Definition sana_aux.F:32
smumps_ana_aux_m::smumps_ana_n_dist
subroutine smumps_ana_n_dist(id, ptrar)
Definition sana_aux.F:1198
smumps_ana_lr
Definition sana_lr.F:14
smumps_ana_lr::smumps_ab_lr_mpi_grouping
subroutine smumps_ab_lr_mpi_grouping(n, mapcol, sizemapcol, nsteps, lumat, fils, frere_steps, dad_steps, step, na, lna, lrgroups, sizeofblocks, sym, icntl, halo_depth, group_size, sep_size, k38, k20, k60, iflag, ierror, k264, k265, k482, k472, maxfront, k469, k10, k54, k142, lpok, lp, comm, myid, nprocs)
Definition sana_lr.F:1608
smumps_ana_lr::smumps_lr_grouping
subroutine smumps_lr_grouping(n, nz8, nsteps, irn, jcn, fils, frere_steps, dad_steps, ne_steps, step, na, lna, lrgroups, sym, icntl, halo_depth, group_size, sep_size, k38, k20, k60, iflag, ierror, k264, k265, k482, k472, maxfront, k10, k54, k142, lpok, lp, gather_matrix_allocated)
Definition sana_lr.F:779
smumps_ana_lr::smumps_ab_lr_grouping
subroutine smumps_ab_lr_grouping(n, mapcol, sizemapcol, nsteps, lumat, fils, frere_steps, dad_steps, step, na, lna, lrgroups, sizeofblocks, sym, icntl, halo_depth, group_size, sep_size, k38, k20, k60, iflag, ierror, k264, k265, k482, k472, maxfront, k469, k10, k54, k142, lpok, lp, myid, comm)
Definition sana_lr.F:1296
smumps_ana_lr::smumps_lr_grouping_new
subroutine smumps_lr_grouping_new(n, nz8, nsteps, irn, jcn, fils, frere_steps, dad_steps, step, na, lna, lrgroups, sym, icntl, halo_depth, group_size, sep_size, k38, k20, k60, iflag, ierror, k264, k265, k482, k472, maxfront, k469, k10, k54, k142, lpok, lp, gather_matrix_allocated)
Definition sana_lr.F:978
smumps_facsol_l0omp_m
Definition sfac_sol_l0omp_m.F:14
smumps_facsol_l0omp_m::smumps_free_l0_omp_factors
subroutine, public smumps_free_l0_omp_factors(id_l0_omp_factors)
Definition sfac_sol_l0omp_m.F:34
smumps_load
Definition smumps_load.F:14
smumps_lr_core
Definition slr_core.F:18
smumps_lr_stats
Definition slr_stats.F:14
smumps_parallel_analysis
Definition sana_aux_par.F:14
smumps_struc_def
Definition smumps_struc_def.F:14
smumps_dist_avoid_copies
subroutine smumps_dist_avoid_copies(n, nslaves, icntl, infog, ne, nfsiz, frere, fils, keep, keep8, procnode, ssarbr, nbsa, peak, ierr, sizeofblocks, lsizeofblocks)
Definition sana_aux.F:4205
smumps_set_procnode
subroutine smumps_set_procnode(inode, procnode, value, fils, n)
Definition sana_aux.F:4225
smumps_sort_perm
subroutine smumps_sort_perm(n, na, lna, ne_steps, perm, fils, dad_steps, step, nsteps, keep60, keep20, keep38, info)
Definition sana_aux.F:4039
smumps_expand_tree_steps
subroutine smumps_expand_tree_steps(icntl, n, nblk, blkptr, blkvar, fils_old, fils_new, nsteps, step_old, step_new, par2_nodes, nb_niv2, dad_steps, frere_steps, na, lna, lrgroups_old, lrgroups_new, k20, k38)
Definition sana_aux.F:4107
smumps_ana_r
subroutine smumps_ana_r(n, fils, frere, nstk, na)
Definition sana_aux.F:2817
smumps_frtelt
subroutine smumps_frtelt(n, nelt, nelnod, frere, fils, na, ne, xnodel, nodel, frtptr, frtelt, eltnod)
Definition sana_aux_ELT.F:841
smumps_ana_dist_elements
subroutine smumps_ana_dist_elements(myid, slavef, n, procnode, step, ptraiw, ptrarw, nelt, frtptr, frtelt, keep, keep8, icntl, sym)
Definition sana_aux_ELT.F:727
smumps_ana_f_elt
subroutine smumps_ana_f_elt(n, nelt, eltptr, eltvar, liw, ikeep, iord, nfsiz, fils, frere, listvar_schur, size_schur, icntl, info, keep, keep8, nslaves, xnodel, nodel)
Definition sana_aux_ELT.F:25
smumps_eltproc
subroutine smumps_eltproc(n, nelt, eltproc, slavef, procnode, keep)
Definition sana_aux_ELT.F:812
smumps_ana_driver
subroutine smumps_ana_driver(id)
Definition sana_driver.F:16
smumps_ana_check_keep
subroutine smumps_ana_check_keep(id, i_am_slave)
Definition sana_driver.F:3975
smumps_build_i_am_cand
subroutine smumps_build_i_am_cand(nslaves, k79, nb_niv2, myid_nodes, candidates, i_am_cand)
Definition sana_driver.F:5657
smumps_gather_matrix
subroutine smumps_gather_matrix(id)
Definition sana_driver.F:4799
smumps_free_onentry_ana_driver
subroutine smumps_free_onentry_ana_driver(id)
Definition sana_driver.F:5716
smumps_dump_problem
subroutine smumps_dump_problem(id)
Definition sana_driver.F:5046
smumps_reorder_tree
subroutine smumps_reorder_tree(n, frere, step, fils, na, lna, ne, nd, dad, ldad, use_dad, nsteps, perm, sym, info, lp, k215, k234, k55, k199, procnode, slavef, peak, sbtr_which_m)
Definition sana_reordertree.F:19
smumps_build_load_mem_info
subroutine smumps_build_load_mem_info(n, frere, step, fils, na, lna, ne, nd, dad, ldad, use_dad, nsteps, perm, sym, info, lp, k47, k81, k76, k215, k234, k55, keep199, procnode, mem_subtree, slavef, size_mem_sbtr, peak, sbtr_which_m, size_depth_first, size_cost_trav, depth_first_trav, depth_first_seq, cost_trav, my_first_leaf, my_nb_leaf, my_root_sbtr, sbtr_id)
Definition sana_reordertree.F:738
smumps_ana_dist_arrowheads
subroutine smumps_ana_dist_arrowheads(myid, slavef, n, procnode, step, ptraiw, ptrarw, istep_to_iniv2, i_am_cand, keep, keep8, icntl, id)
Definition sarrowheads.F:18
smumps_free_id_data_modules
subroutine smumps_free_id_data_modules(id_fdm_f_encoding, id_blrarray_encoding, keep8, k34)
Definition send_driver.F:448
mumps_ana_blk_m::compact_graph_t
Definition ana_blk_m.F:24
mumps_ana_blk_m::lmatrix_t
Definition ana_blk_m.F:19
smumps_init_root_ana
subroutine smumps_init_root_ana(myid, nprocs, n, root, comm_root, iroot, fils, k50, k46, k51, k60, idnprow, idnpcol, idmblock, idnblock)
Definition stype3_root.F:744
mumps_secfin
subroutine mumps_secfin(t)
Definition tools_common.F:277
mumps_get_perlu
subroutine mumps_get_perlu(keep12, icntl14, keep50, keep54, icntl6, icntl8)
Definition tools_common.F:808
mumps_sort_step
subroutine mumps_sort_step(n, frere, step, fils, na, lna, ne, nd, dad, ldad, use_dad, nsteps, info, lp, procnode, slavef)
Definition tools_common.F:971
mumps_secdeb
subroutine mumps_secdeb(t)
Definition tools_common.F:270