OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
tools_common.F
Go to the documentation of this file.
1C
2C This file is part of MUMPS 5.5.1, released
3C on Tue Jul 12 13:17:24 UTC 2022
4C
5C
6C Copyright 1991-2022 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria,
7C Mumps Technologies, University of Bordeaux.
8C
9C This version of MUMPS is provided to you free of charge. It is
10C released under the CeCILL-C license
11C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and
12C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html)
13C
14 SUBROUTINE mumps_find_unit(IUNIT)
15 IMPLICIT NONE
16 INTEGER :: IUNIT
17 INTEGER, PARAMETER :: UNIT_MIN = 10
18 INTEGER, PARAMETER :: UNIT_MAX = 500
19 INTEGER :: I
20 LOGICAL :: BUSY
21 iunit = -1
22 DO i = unit_min, unit_max
23 INQUIRE(unit=i, opened=busy)
24 IF ( .NOT. busy ) THEN
25 iunit = i
26 RETURN
27 END IF
28 ENDDO
29 RETURN
30 END SUBROUTINE mumps_find_unit
31 SUBROUTINE mumps_make1root( N, FRERE, FILS, NFSIZ, THEROOT )
32 IMPLICIT NONE
33 INTEGER, intent( in ) :: N
34 INTEGER, intent( in ) :: NFSIZ( N )
35 INTEGER, intent( inout ) :: FRERE( N ), FILS( N )
36 INTEGER, intent( out ) :: THEROOT
37 INTEGER INODE, IROOT, IFILS, IN, IROOTLAST, SIZE
38 iroot = -9999
39 SIZE = 0
40 DO inode = 1, n
41 IF ( frere( inode ) .EQ. 0 ) THEN
42 IF ( nfsiz( inode ) .GT. SIZE ) THEN
43 SIZE = nfsiz( inode )
44 iroot = inode
45 END IF
46 ENDIF
47 END DO
48 in = iroot
49 DO WHILE ( fils( in ) .GT. 0 )
50 in = fils( in )
51 END DO
52 irootlast = in
53 ifils = - fils( in )
54 DO inode = 1, n
55 IF ( frere( inode ) .eq. 0 .and. inode .ne. iroot ) THEN
56 IF ( ifils .eq. 0 ) THEN
57 fils( irootlast ) = - inode
58 frere( inode ) = -iroot
59 ifils = inode
60 ELSE
61 frere( inode ) = -fils( irootlast )
62 fils( irootlast ) = - inode
63 END IF
64 END IF
65 END DO
66 theroot = iroot
67 RETURN
68 END SUBROUTINE mumps_make1root
69 INTEGER FUNCTION mumps_encode_tpn_iproc(TPN,IPROC,K199)
70 INTEGER, INTENT(IN) :: tpn, iproc, k199
71 IF (k199 < 0) THEN
72 mumps_encode_tpn_iproc = iproc + ishft(tpn+1, 24)
73 ELSE
74 mumps_encode_tpn_iproc = (tpn-1)*k199+iproc+1
75 ENDIF
76 RETURN
77 END FUNCTION mumps_encode_tpn_iproc
78 INTEGER FUNCTION mumps_typenode_rough(PROCINFO_INODE, K199)
79 IMPLICIT NONE
80 INTEGER k199
81 INTEGER procinfo_inode
82 IF (k199 < 0) THEN
83 mumps_typenode_rough = ishft(procinfo_inode,-24) - 1
84 ELSE
85 mumps_typenode_rough = (procinfo_inode-1+2*k199)/k199 - 1
86 ENDIF
87 RETURN
88 END FUNCTION mumps_typenode_rough
89 INTEGER FUNCTION mumps_typenode(PROCINFO_INODE, K199)
90 IMPLICIT NONE
91 INTEGER k199
92 INTEGER procinfo_inode, tpn
93 IF (k199 < 0) THEN
94 tpn = ishft(procinfo_inode,-24) - 1
95 IF (tpn < 1 ) THEN
96 tpn = 1
97 ELSE IF (tpn.GE.4) THEN
98 tpn = 2
99 ENDIF
100 ELSE
101 IF (procinfo_inode <= k199 ) THEN
102 tpn = 1
103 ELSE
104 tpn = (procinfo_inode-1+2*k199)/k199 - 1
105 IF ( tpn .LT. 1 ) tpn = 1
106 IF (tpn.EQ.4.OR.tpn.EQ.5.OR.tpn.EQ.6) tpn = 2
107 END IF
108 END IF
109 mumps_typenode = tpn
110 RETURN
111 END FUNCTION mumps_typenode
112 SUBROUTINE mumps_typeandprocnode( TPN,
113 & MUMPS_PROCNODE, PROCINFO_INODE, K199 )
114 INTEGER, INTENT(IN) :: K199, PROCINFO_INODE
115 INTEGER, intent(out) :: TPN, MUMPS_PROCNODE
116 IF (k199 < 0 ) THEN
117 mumps_procnode=iand(procinfo_inode,
118#if defined(MUMPS_F2003)
119 & int(b"111111111111111111111111"))
120#else
121 & 16777215)
122#endif
123 tpn = ishft(procinfo_inode,-24) - 1
124 IF (tpn < 1 ) THEN
125 tpn = 1
126 ELSE IF (tpn.GE.4) THEN
127 tpn = 2
128 ENDIF
129 ELSE
130 IF (k199 == 1) THEN
131 mumps_procnode = 0
132 IF (procinfo_inode <= k199) THEN
133 tpn = 1
134 ELSE
135 tpn = 3
136 ENDIF
137 ELSE
138 tpn = (procinfo_inode-1+2*k199)/k199-1
139 mumps_procnode = (procinfo_inode-1+2*k199)-
140 & (tpn+1)*k199
141 IF (tpn .LT. 1) THEN
142 tpn = 1
143 ELSE IF (tpn .ge. 4) THEN
144 tpn = 2
145 ENDIF
146 ENDIF
147 ENDIF
148 RETURN
149 END SUBROUTINE mumps_typeandprocnode
150 INTEGER FUNCTION mumps_procnode(PROCINFO_INODE, K199)
151 IMPLICIT NONE
152 INTEGER k199
153 INTEGER procinfo_inode
154 IF ( k199 < 0 ) THEN
155 mumps_procnode=iand(procinfo_inode,
156#if defined(MUMPS_F2003)
157 & int(b"111111111111111111111111"))
158#else
159 & 16777215 )
160#endif
161 ELSE
162 IF (k199 == 1) THEN
163 mumps_procnode = 0
164 ELSE
165 mumps_procnode=mod(2*k199+procinfo_inode-1,k199)
166 END IF
167 ENDIF
168 RETURN
169 END FUNCTION mumps_procnode
170 INTEGER FUNCTION mumps_typesplit (PROCINFO_INODE, K199)
171 IMPLICIT NONE
172 INTEGER, intent(in) :: k199
173 INTEGER procinfo_inode, tpn
174 IF (k199 < 0) THEN
175 tpn = ishft(procinfo_inode,-24) - 1
176 IF (tpn < 1 ) tpn = 1
177 ELSE
178 IF (procinfo_inode <= k199 ) THEN
179 tpn = 1
180 ELSE
181 tpn = (procinfo_inode-1+2*k199)/k199 - 1
182 IF ( tpn .LT. 1 ) tpn = 1
183 ENDIF
184 ENDIF
185 mumps_typesplit = tpn
186 RETURN
187 END FUNCTION mumps_typesplit
188 LOGICAL FUNCTION mumps_rootssarbr( PROCINFO_INODE, K199 )
189 IMPLICIT NONE
190 INTEGER k199
191 INTEGER tpn, procinfo_inode
192 IF (k199 < 0) THEN
193 tpn = ishft(procinfo_inode,-24) - 1
194 ELSE
195 tpn = (procinfo_inode-1+2*k199)/k199 - 1
196 ENDIF
197 mumps_rootssarbr = ( tpn .eq. 0 )
198 RETURN
199 END FUNCTION mumps_rootssarbr
200 LOGICAL FUNCTION mumps_inssarbr( PROCINFO_INODE, K199 )
201 IMPLICIT NONE
202 INTEGER k199
203 INTEGER TPN, procinfo_inode
204 IF (k199 < 0) THEN
205 tpn = ishft(procinfo_inode,-24) - 1
206 ELSE
207 tpn = (procinfo_inode-1+k199+k199)/k199 - 1
208 ENDIF
209 mumps_inssarbr = ( tpn .eq. -1 )
210 RETURN
211 END FUNCTION mumps_inssarbr
212 LOGICAL FUNCTION mumps_in_or_root_ssarbr
213 & ( procinfo_inode, k199 )
214 IMPLICIT NONE
215 INTEGER k199
216 INTEGER tpn, procinfo_inode
217 IF (k199 < 0) THEN
218 tpn = ishft(procinfo_inode,-24) - 1
219 ELSE
220 tpn = (procinfo_inode-1+k199+k199)/k199 - 1
221 ENDIF
222 mumps_in_or_root_ssarbr =
223 & ( tpn .eq. -1 .OR. tpn .eq. 0 )
224 RETURN
225 END FUNCTION mumps_in_or_root_ssarbr
226 SUBROUTINE mumps_set_ssarbr_dad(
227 & SSARBR, INODE, DAD, N,
228 & KEEP28,
229 & STEP, PROCNODE_STEPS, K199)
230 IMPLICIT NONE
231 INTEGER, INTENT(IN) :: N, KEEP28, K199, INODE
232 INTEGER, INTENT(IN) :: DAD(KEEP28), PROCNODE_STEPS(KEEP28)
233 INTEGER, INTENT(IN) :: STEP(N)
234 LOGICAL, INTENT(OUT) :: SSARBR
235 INTEGER :: DADINODE, TYPEDAD
236 LOGICAL, EXTERNAL :: MUMPS_INSSARBR
237 INTEGER, EXTERNAL :: MUMPS_TYPENODE
238 ssarbr = .false.
239 dadinode = dad(step(inode))
240 IF (dadinode .NE. 0) THEN
241 typedad = mumps_typenode(procnode_steps(step(dadinode)),
242 & k199)
243 IF (typedad.EQ.1) THEN
244 ssarbr=mumps_inssarbr(procnode_steps(step(dadinode)),
245 & k199)
246 ENDIF
247 ENDIF
248 RETURN
249 END SUBROUTINE mumps_set_ssarbr_dad
250 LOGICAL FUNCTION mumps_i_am_candidate( MYID, SLAVEF, INODE,
251 & NMB_PAR2, ISTEP_TO_INIV2 , K71, STEP, N,
252 & CANDIDATES, KEEP24 )
253 IMPLICIT NONE
254 INTEGER myid, slavef, inode, nmb_par2, keep24, i
255 INTEGER k71, n
256 INTEGER istep_to_iniv2 ( k71 ), step ( n )
257 INTEGER candidates(slavef+1, max(nmb_par2,1))
258 INTEGER ncand, posinode
259 mumps_i_am_candidate = .false.
260 IF (keep24 .eq. 0) RETURN
261 posinode = istep_to_iniv2( step(inode) )
262 ncand = candidates( slavef+1, posinode )
263 DO i = 1, ncand
264 IF (myid .EQ. candidates( i, posinode ))
265 & mumps_i_am_candidate = .true.
266 END DO
267 RETURN
268 END FUNCTION mumps_i_am_candidate
269 SUBROUTINE mumps_secdeb(T)
270 DOUBLE PRECISION T
271 DOUBLE PRECISION MPI_WTIME
272 EXTERNAL mpi_wtime
273 t=mpi_wtime()
274 RETURN
275 END SUBROUTINE mumps_secdeb
276 SUBROUTINE mumps_secfin(T)
277 DOUBLE PRECISION T
278 DOUBLE PRECISION MPI_WTIME
279 EXTERNAL mpi_wtime
280 t=mpi_wtime()-t
281 RETURN
282 END SUBROUTINE mumps_secfin
283 SUBROUTINE mumps_sort_doubles( N, VAL, ID )
284 INTEGER N
285 INTEGER ID( N )
286 DOUBLE PRECISION VAL( N )
287 INTEGER I, ISWAP
288 DOUBLE PRECISION SWAP
289 LOGICAL DONE
290 done = .false.
291 DO WHILE ( .NOT. done )
292 done = .true.
293 DO i = 1, n - 1
294 IF ( val( i ) .GT. val( i + 1 ) ) THEN
295 done = .false.
296 iswap = id( i )
297 id( i ) = id( i + 1 )
298 id( i + 1 ) = iswap
299 swap = val( i )
300 val( i ) = val( i + 1 )
301 val( i + 1 ) = swap
302 END IF
303 END DO
304 END DO
305 RETURN
306 END SUBROUTINE mumps_sort_doubles
307 SUBROUTINE mumps_sort_doubles_dec( N, VAL, ID )
308 INTEGER N
309 INTEGER ID( N )
310 DOUBLE PRECISION VAL( N )
311 INTEGER I, ISWAP
312 DOUBLE PRECISION SWAP
313 LOGICAL DONE
314 done = .false.
315 DO WHILE ( .NOT. done )
316 done = .true.
317 DO i = 1, n - 1
318 IF ( val( i ) .LT. val( i + 1 ) ) THEN
319 done = .false.
320 iswap = id( i )
321 id( i ) = id( i + 1 )
322 id( i + 1 ) = iswap
323 swap = val( i )
324 val( i ) = val( i + 1 )
325 val( i + 1 ) = swap
326 END IF
327 END DO
328 END DO
329 RETURN
330 END SUBROUTINE mumps_sort_doubles_dec
331#if defined (PESSL)
332 SUBROUTINE descinit( DESC, M, N, MB, NB, IRSRC, ICSRC, ICTXT,
333 & LLD, INFO )
334 INTEGER ICSRC, ICTXT, INFO, IRSRC, LLD, M, MB, N, NB
335 INTEGER DESC( * )
336 INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
337 & lld_, mb_, m_, nb_, n_, rsrc_
338# if defined(DESC8)
339 parameter( dlen_ = 8, dtype_ = 1,
340 & ctxt_ = 7, m_ = 1, n_ = 2, mb_ = 3, nb_ = 4,
341 & rsrc_ = 5, csrc_ = 6, lld_ = 8 )
342# else
343 parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
344 & ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
345 & rsrc_ = 7, csrc_ = 8, lld_ = 9 )
346# endif
347 INTEGER MYCOL, MYROW, NPCOL, NPROW
348 EXTERNAL blacs_gridinfo, PXERBLA
349 INTEGER NUMROC
350 EXTERNAL numroc
351 INTRINSIC max, min
352 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
353 info = 0
354 IF( m.LT.0 ) THEN
355 info = -2
356 ELSE IF( n.LT.0 ) THEN
357 info = -3
358 ELSE IF( mb.LT.1 ) THEN
359 info = -4
360 ELSE IF( nb.LT.1 ) THEN
361 info = -5
362 ELSE IF( irsrc.LT.0 .OR. irsrc.GE.nprow ) THEN
363 info = -6
364 ELSE IF( icsrc.LT.0 .OR. icsrc.GE.npcol ) THEN
365 info = -7
366 ELSE IF( nprow.EQ.-1 ) THEN
367 info = -8
368 ELSE IF( lld.LT.max( 1, numroc( m, mb, myrow, irsrc,
369 & nprow ) ) ) THEN
370 info = -9
371 END IF
372 IF( info.NE.0 )
373 & CALL pxerbla( ictxt, 'DESCINIT', -info )
374# ifndef DESC8
375 desc( dtype_ ) = block_cyclic_2d
376# endif
377 desc( m_ ) = max( 0, m )
378 desc( n_ ) = max( 0, n )
379 desc( mb_ ) = max( 1, mb )
380 desc( nb_ ) = max( 1, nb )
381 desc( rsrc_ ) = max( 0, min( irsrc, nprow-1 ) )
382 desc( csrc_ ) = max( 0, min( icsrc, npcol-1 ) )
383 desc( ctxt_ ) = ictxt
384 desc( lld_ ) = max( lld, max( 1, numroc( desc( m_ ), desc( mb_ ),
385 & myrow, desc( rsrc_ ), nprow ) ) )
386 RETURN
387 END SUBROUTINE descinit
388 SUBROUTINE pxerbla( ICTXT, SRNAME, INFO )
389 INTEGER ICTXT, INFO
390 CHARACTER*(*) SRNAME
391 INTEGER MYCOL, MYROW, NPCOL, NPROW
392 EXTERNAL blacs_gridinfo
393 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
394 WRITE( *, fmt = 9999 ) myrow, mycol, srname, info
395 9999 FORMAT( '{', i5, ',', i5, '}: On entry to ', a,
396 & ' parameter number', i4, ' had an illegal value' )
397 END SUBROUTINE pxerbla
398#endif
399 SUBROUTINE mumps_mem_centralize(MYID, COMM, INFO, INFOG, IRANK)
400 IMPLICIT NONE
401 INTEGER MYID, COMM, IRANK, INFO, INFOG(2)
402 include 'mpif.h'
403 INTEGER IERR_MPI, MASTER
404#if defined(WORKAROUNDINTELILP64MPI2INTEGER)
405 INTEGER(4) :: TEMP1(2),TEMP2(2)
406#else
407 INTEGER :: TEMP1(2),TEMP2(2)
408#endif
409 parameter( master = 0 )
410 CALL mpi_reduce( info, infog(1), 1, mpi_integer,
411 & mpi_max, master, comm, ierr_mpi )
412 CALL mpi_reduce( info, infog(2), 1, mpi_integer,
413 & mpi_sum, master, comm, ierr_mpi )
414 temp1(1) = info
415 temp1(2) = myid
416 CALL mpi_reduce( temp1, temp2, 1, mpi_2integer,
417 & mpi_maxloc, master, comm, ierr_mpi )
418 IF ( myid.eq. master ) THEN
419 IF ( infog(1) .ne. temp2(1) ) THEN
420 write(*,*) 'Error in MUMPS_MEM_CENTRALIZE'
421 CALL mumps_abort()
422 END IF
423 irank = temp2(2)
424 ELSE
425 irank = -1
426 END IF
427 RETURN
428 END SUBROUTINE mumps_mem_centralize
429 INTEGER FUNCTION mumps_get_pool_length
430 & (max_active_nodes,keep,keep8)
431 IMPLICIT NONE
432 INTEGER max_active_nodes
433 INTEGER keep(500)
434 INTEGER(8) keep8(150)
435 mumps_get_pool_length = max_active_nodes + 1 + 3
436 RETURN
437 END FUNCTION mumps_get_pool_length
438 SUBROUTINE mumps_init_pool_dist_bwd(N,
439 & nb_prun_roots, Pruned_Roots,
440 & MYROOT, MYID_NODES,
441 & KEEP, KEEP8, STEP, PROCNODE_STEPS,
442 & IPOOL, LPOOL )
443 IMPLICIT NONE
444 INTEGER, INTENT(IN) :: N, MYID_NODES, LPOOL, nb_prun_roots
445 INTEGER KEEP(500)
446 INTEGER(8) KEEP8(150)
447 INTEGER, INTENT(IN) :: STEP(N)
448 INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28))
449 INTEGER, INTENT(IN) :: Pruned_Roots(nb_prun_roots)
450 INTEGER, INTENT(OUT) :: MYROOT
451 INTEGER, INTENT(OUT) :: IPOOL(LPOOL)
452 INTEGER, EXTERNAL :: MUMPS_PROCNODE
453 INTEGER :: I, INODE
454 myroot = 0
455 DO i = nb_prun_roots, 1, -1
456 inode = pruned_roots(i)
457 IF (mumps_procnode(procnode_steps(step(inode)),
458 & keep(199)) .EQ. myid_nodes) THEN
459 myroot = myroot + 1
460 ipool(myroot) = inode
461 ENDIF
462 END DO
463 RETURN
464 END SUBROUTINE mumps_init_pool_dist_bwd
465 SUBROUTINE mumps_init_pool_dist_bwd_l0(N,
466 & nb_prun_roots, Pruned_Roots,
467 & MYROOT, MYID_NODES,
468 & KEEP, KEEP8, STEP, PROCNODE_STEPS,
469 & IPOOL, LPOOL, TO_PROCESS )
470 IMPLICIT NONE
471 INTEGER, INTENT(IN) :: N, MYID_NODES, LPOOL, nb_prun_roots
472 INTEGER KEEP(500)
473 INTEGER(8) KEEP8(150)
474 INTEGER, INTENT(IN) :: STEP(N)
475 INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28))
476 LOGICAL, INTENT(IN) :: TO_PROCESS(KEEP(28))
477 INTEGER, INTENT(IN) :: Pruned_Roots(nb_prun_roots)
478 INTEGER, INTENT(OUT) :: MYROOT
479 INTEGER, INTENT(OUT) :: IPOOL(LPOOL)
480 INTEGER, EXTERNAL :: MUMPS_PROCNODE
481 INTEGER :: I, INODE
482 MYROOT = 0
483 do i = nb_prun_roots, 1, -1
484 inode = pruned_roots(i)
485 IF (mumps_procnode(procnode_steps(step(inode)),
486 & keep(199)) .EQ. myid_nodes) THEN
487 IF ( to_process(step(inode)) ) THEN
488 myroot = myroot + 1
489 ipool(myroot) = inode
490 ENDIF
491 ENDIF
492 END DO
493 RETURN
494 END SUBROUTINE mumps_init_pool_dist_bwd_l0
495 SUBROUTINE mumps_init_pool_dist_na_bwd(N, MYROOT, MYID_NODES,
496 & NA, LNA, KEEP, KEEP8, STEP, PROCNODE_STEPS,
497 & IPOOL, LPOOL )
498 IMPLICIT NONE
499 INTEGER, INTENT(IN) :: N, MYID_NODES, LPOOL, LNA
500 INTEGER KEEP(500)
501 INTEGER(8) KEEP8(150)
502 INTEGER, INTENT(IN) :: STEP(N)
503 INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), NA(LNA)
504 INTEGER, INTENT(OUT) :: IPOOL(LPOOL)
505 INTEGER, INTENT(OUT) :: MYROOT
506 INTEGER, EXTERNAL :: MUMPS_PROCNODE
507 INTEGER :: NBLEAF, NBROOT, I, INODE
508 nbleaf = na(1)
509 nbroot = na(2)
510 myroot = 0
511 DO i = nbroot, 1, -1
512 inode = na(nbleaf+i+2)
513 IF (mumps_procnode(procnode_steps(step(inode)),
514 & keep(199)) .EQ. myid_nodes) THEN
515 myroot = myroot + 1
516 ipool(myroot) = inode
517 ENDIF
518 END DO
519 RETURN
520 END SUBROUTINE mumps_init_pool_dist_na_bwd
521 SUBROUTINE mumps_init_pool_dist_na_bwd_l0(N, MYROOT, MYID_NODES,
522 & NA, LNA, KEEP, KEEP8, STEP, PROCNODE_STEPS,
523 & IPOOL, LPOOL, L0_OMP_MAPPING )
524 IMPLICIT NONE
525 INTEGER, INTENT(IN) :: N, MYID_NODES, LPOOL, LNA
526 INTEGER KEEP(500)
527 INTEGER(8) KEEP8(150)
528 INTEGER, INTENT(IN) :: STEP(N)
529 INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), NA(LNA)
530 INTEGER, INTENT(IN) :: L0_OMP_MAPPING(KEEP(28))
531 INTEGER, INTENT(OUT) :: IPOOL(LPOOL)
532 INTEGER, INTENT(OUT) :: MYROOT
533 INTEGER, EXTERNAL :: MUMPS_PROCNODE
534 INTEGER :: NBLEAF, NBROOT, I, INODE
535 nbleaf = na(1)
536 nbroot = na(2)
537 myroot = 0
538 DO i = nbroot, 1, -1
539 inode = na(nbleaf+i+2)
540 IF (mumps_procnode(procnode_steps(step(inode)),
541 & keep(199)) .EQ. myid_nodes) THEN
542 IF ( l0_omp_mapping(step(inode)).EQ.0 ) THEN
543 myroot = myroot + 1
544 ipool(myroot) = inode
545 ENDIF
546 ENDIF
547 END DO
548 RETURN
549 END SUBROUTINE mumps_init_pool_dist_na_bwd_l0
550 SUBROUTINE mumps_init_pool_dist_na_bwdl0es(N, MYROOT,
551 & MYID_NODES,
552 & NA, LNA, KEEP, KEEP8, STEP, PROCNODE_STEPS,
553 & IPOOL, LPOOL, L0_OMP_MAPPING, TO_PROCESS )
554 IMPLICIT NONE
555 INTEGER, INTENT(IN) :: N, MYID_NODES, LPOOL, LNA
556 INTEGER KEEP(500)
557 INTEGER(8) KEEP8(150)
558 INTEGER, INTENT(IN) :: STEP(N)
559 INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), NA(LNA)
560 INTEGER, INTENT(IN) :: L0_OMP_MAPPING(KEEP(28))
561 INTEGER, INTENT(OUT) :: IPOOL(LPOOL)
562 INTEGER, INTENT(OUT) :: MYROOT
563 LOGICAL, INTENT(IN) :: TO_PROCESS( KEEP(28) )
564 INTEGER, EXTERNAL :: MUMPS_PROCNODE
565 INTEGER :: NBLEAF, NBROOT, I, INODE
566 nbleaf = na(1)
567 nbroot = na(2)
568 myroot = 0
569 DO i = nbroot, 1, -1
570 inode = na(nbleaf+i+2)
571 IF (mumps_procnode(procnode_steps(step(inode)),
572 & keep(199)) .EQ. myid_nodes) THEN
573 IF ( l0_omp_mapping(step(inode)).EQ.0 ) THEN
574 IF ( to_process( step(inode) ) ) THEN
575 myroot = myroot + 1
576 ipool(myroot) = inode
577 ENDIF
578 ENDIF
579 ENDIF
580 END DO
581 RETURN
582 END SUBROUTINE mumps_init_pool_dist_na_bwdl0es
583 SUBROUTINE mumps_init_pool_dist(N, LEAF,
584 & MYID_NODES,
585 & K199, NA, LNA, KEEP,KEEP8, STEP,
586 & PROCNODE_STEPS, IPOOL, LPOOL)
587 IMPLICIT NONE
588 INTEGER N, LEAF, MYID_NODES,
589 & k199, lpool, lna
590 INTEGER KEEP(500)
591 INTEGER(8) KEEP8(150)
592 INTEGER STEP(N)
593 INTEGER PROCNODE_STEPS(KEEP(28)), NA(LNA),
594 & ipool(lpool)
595 INTEGER NBLEAF, INODE, I
596 INTEGER MUMPS_PROCNODE
597 EXTERNAL MUMPS_PROCNODE
598 nbleaf = na(1)
599 leaf = 1
600 DO i = 1, nbleaf
601 inode = na(i+2)
602 IF (mumps_procnode(procnode_steps(step(inode)),keep(199))
603 & .EQ.myid_nodes) THEN
604 ipool(leaf) = inode
605 leaf = leaf + 1
606 ENDIF
607 ENDDO
608 RETURN
609 END SUBROUTINE mumps_init_pool_dist
610 SUBROUTINE mumps_init_pool_dist_nona
611 & (n, leaf, myid_nodes,
612 & lleaves, leaves, keep,keep8, step,
613 & procnode_steps, ipool, lpool)
614 IMPLICIT NONE
615 INTEGER N, LEAF, MYID_NODES,
616 & lpool, lleaves
617 INTEGER KEEP(500)
618 INTEGER(8) KEEP8(150)
619 INTEGER STEP(N)
620 INTEGER PROCNODE_STEPS(KEEP(28)), LEAVES(LLEAVES),
621 & ipool(lpool)
622 INTEGER I, INODE
623 INTEGER, EXTERNAL :: MUMPS_PROCNODE
624 leaf = 1
625 DO i = 1, lleaves
626 inode = leaves(i)
627 IF ( mumps_procnode(procnode_steps(step(inode)),keep(199))
628 & .EQ.myid_nodes ) THEN
629 ipool( leaf ) = inode
630 leaf = leaf + 1
631 ENDIF
632 ENDDO
633 RETURN
634 END SUBROUTINE mumps_init_pool_dist_nona
635 SUBROUTINE mumps_init_nroot_dist(N, NBROOT,
636 & NROOT_LOC, MYID_NODES,
637 & SLAVEF, NA, LNA, KEEP, STEP,
638 & PROCNODE_STEPS)
639 IMPLICIT NONE
640 INTEGER, INTENT( OUT ) :: NROOT_LOC
641 INTEGER, INTENT( OUT ) :: NBROOT
642 INTEGER, INTENT( IN ) :: KEEP( 500 )
643 INTEGER, INTENT( IN ) :: SLAVEF
644 INTEGER, INTENT( IN ) :: N
645 INTEGER, INTENT( IN ) :: STEP(N)
646 INTEGER, INTENT( IN ) :: LNA
647 INTEGER, INTENT( IN ) :: NA(LNA)
648 INTEGER, INTENT( IN ) :: PROCNODE_STEPS(KEEP(28))
649 INTEGER, INTENT( IN ) :: MYID_NODES
650 INTEGER, EXTERNAL :: MUMPS_PROCNODE
651 INTEGER :: INODE, I, NBLEAF
652 nbleaf = na(1)
653 nbroot = na(2)
654 nroot_loc = 0
655 DO i = 1, nbroot
656 inode = na(i+2+nbleaf)
657 IF (mumps_procnode(procnode_steps(step(inode)),
658 & keep(199)).EQ.myid_nodes) THEN
659 nroot_loc = nroot_loc + 1
660 END IF
661 ENDDO
662 RETURN
663 END SUBROUTINE mumps_init_nroot_dist
664 SUBROUTINE mumps_nblocal_roots_or_leaves
665 & (n, nbrorl, rorl_list,
666 & nrorl_loc, myid_nodes,
667 & slavef, keep, step,
668 & procnode_steps)
669 IMPLICIT NONE
670 INTEGER, INTENT( OUT ) :: NRORL_LOC
671 INTEGER, INTENT( IN ) :: NBRORL
672 INTEGER, INTENT( IN ) :: RORL_LIST(NBRORL)
673 INTEGER, INTENT( IN ) :: KEEP( 500 )
674 INTEGER, INTENT( IN ) :: SLAVEF
675 INTEGER, INTENT( IN ) :: N
676 INTEGER, INTENT( IN ) :: STEP(N)
677 INTEGER, INTENT( IN ) :: PROCNODE_STEPS(KEEP(28))
678 INTEGER, INTENT( IN ) :: MYID_NODES
679 INTEGER I, INODE
680 INTEGER, EXTERNAL :: MUMPS_PROCNODE
681 nrorl_loc = 0
682 DO i = 1, nbrorl
683 inode = rorl_list(i)
684 IF (mumps_procnode(procnode_steps(step(inode)),
685 & keep(199)).EQ.myid_nodes) THEN
686 nrorl_loc = nrorl_loc + 1
687 END IF
688 ENDDO
689 RETURN
690 END SUBROUTINE mumps_nblocal_roots_or_leaves
691 LOGICAL FUNCTION mumps_compare_tab(TAB1,TAB2,LEN1,LEN2)
692 IMPLICIT NONE
693 INTEGER len1 , len2 ,i
694 INTEGER tab1(len1)
695 INTEGER tab2(len2)
696 mumps_compare_tab=.false.
697 IF(len1 .NE. len2) THEN
698 RETURN
699 ENDIF
700 DO i=1 , len1
701 IF(tab1(i) .NE. tab2(i)) THEN
702 RETURN
703 ENDIF
704 ENDDO
705 mumps_compare_tab=.true.
706 RETURN
707 END FUNCTION mumps_compare_tab
708 SUBROUTINE mumps_sort_int( N, VAL, ID )
709 INTEGER N
710 INTEGER ID( N )
711 INTEGER VAL( N )
712 INTEGER I, ISWAP
713 INTEGER SWAP
714 LOGICAL DONE
715 done = .false.
716 DO WHILE ( .NOT. done )
717 done = .true.
718 DO i = 1, n - 1
719 IF ( val( i ) .GT. val( i + 1 ) ) THEN
720 done = .false.
721 iswap = id( i )
722 id( i ) = id( i + 1 )
723 id( i + 1 ) = iswap
724 swap = val( i )
725 val( i ) = val( i + 1 )
726 val( i + 1 ) = swap
727 END IF
728 END DO
729 END DO
730 RETURN
731 END SUBROUTINE mumps_sort_int
732 SUBROUTINE mumps_sort_int_dec( N, VAL, ID )
733 INTEGER N
734 INTEGER ID( N )
735 INTEGER VAL( N )
736 INTEGER I, ISWAP
737 INTEGER SWAP
738 LOGICAL DONE
739 done = .false.
740 DO WHILE ( .NOT. done )
741 done = .true.
742 DO i = 1, n - 1
743 IF ( val( i ) .LT. val( i + 1 ) ) THEN
744 done = .false.
745 iswap = id( i )
746 id( i ) = id( i + 1 )
747 id( i + 1 ) = iswap
748 swap = val( i )
749 val( i ) = val( i + 1 )
750 val( i + 1 ) = swap
751 END IF
752 END DO
753 END DO
754 RETURN
755 END SUBROUTINE mumps_sort_int_dec
756 SUBROUTINE mumps_sort_int8( N, VAL, ID )
757 INTEGER N
758 INTEGER ID( N )
759 INTEGER(8) :: VAL( N )
760 INTEGER I, ISWAP
761 INTEGER(8) SWAP
762 LOGICAL DONE
763 done = .false.
764 DO WHILE ( .NOT. done )
765 done = .true.
766 DO i = 1, n - 1
767 IF ( val( i ) .GT. val( i + 1 ) ) THEN
768 done = .false.
769 iswap = id( i )
770 id( i ) = id( i + 1 )
771 id( i + 1 ) = iswap
772 swap = val( i )
773 val( i ) = val( i + 1 )
774 val( i + 1 ) = swap
775 END IF
776 END DO
777 END DO
778 RETURN
779 END SUBROUTINE mumps_sort_int8
780 SUBROUTINE mumps_abort()
781#if defined(PRINT_BACKTRACE_ON_ABORT)
782#if defined(__INTEL_COMPILER)
783 USE ifcore
784#endif
785 IMPLICIT NONE
786 include 'mpif.h'
787 INTEGER IERR, IERRCODE
788#if defined(__GFORTRAN__)
789 CALL backtrace()
790#endif
791#if defined(__INTEL_COMPILER)
792!$OMP CRITICAL(MUMPS_TRACEBACKQQ)
793 CALL tracebackqq("MUMPS_ABORT calls TRACEBACKQQ:",
794 & user_exit_code=-1)
795!$OMP END CRITICAL(MUMPS_TRACEBACKQQ)
796#endif
797#else
798 IMPLICIT NONE
799 include 'mpif.h'
800 INTEGER IERR, IERRCODE
801#endif
802 ierrcode = -99
803 CALL mpi_abort(mpi_comm_world, ierrcode, ierr)
804 RETURN
805 END SUBROUTINE mumps_abort
806 SUBROUTINE mumps_get_perlu(KEEP12,ICNTL14,
807 & KEEP50,KEEP54,ICNTL6,ICNTL8)
808 IMPLICIT NONE
809 INTEGER, intent(out)::KEEP12
810 INTEGER, intent(in)::ICNTL14,KEEP50,KEEP54,ICNTL6,ICNTL8
811 KEEP12 = icntl14
812 RETURN
813 END SUBROUTINE mumps_get_perlu
814 SUBROUTINE mumps_reducei8( IN, OUT, MPI_OP, ROOT, COMM)
815 IMPLICIT NONE
816 include 'mpif.h'
817 INTEGER ROOT, COMM, MPI_OP
818 INTEGER(8) IN, OUT
819 INTEGER IERR
820 DOUBLE PRECISION DIN, DOUT
821 DIN =dble(in)
822 dout=0.0d0
823 CALL mpi_reduce(din, dout, 1, mpi_double_precision,
824 & mpi_op, root, comm, ierr)
825 out=int(dout,kind=8)
826 RETURN
827 END SUBROUTINE mumps_reducei8
828 SUBROUTINE mumps_allreducei8( IN, OUT, MPI_OP, COMM)
829 IMPLICIT NONE
830 include 'mpif.h'
831 INTEGER COMM, MPI_OP
832 INTEGER(8) IN, OUT
833 INTEGER IERR
834 DOUBLE PRECISION DIN, DOUT
835 din =dble(in)
836 dout=0.0d0
837 CALL mpi_allreduce(din, dout, 1, mpi_double_precision,
838 & mpi_op, comm, ierr)
839 out=int(dout,kind=8)
840 RETURN
841 END SUBROUTINE mumps_allreducei8
842 SUBROUTINE mumps_seti8toi4(I8, I)
843 IMPLICIT NONE
844 INTEGER , INTENT(OUT) :: I
845 INTEGER(8), INTENT(IN) :: I8
846 IF ( i8 .GT. int(huge(i),8) ) THEN
847 i = -int(i8/1000000_8,kind(i))
848 ELSE
849 i = int(i8,kind(i))
850 ENDIF
851 RETURN
852 END SUBROUTINE mumps_seti8toi4
853 SUBROUTINE mumps_abort_on_overflow(I8, STRING)
854 IMPLICIT NONE
855 INTEGER(8), INTENT(IN) :: I8
856 CHARACTER(*), INTENT(IN) :: STRING
857 INTEGER I
858 IF ( i8 .GT. int(huge(i),8)) THEN
859 WRITE(*,*) string
860 CALL mumps_abort()
861 ENDIF
862 RETURN
863 END SUBROUTINE mumps_abort_on_overflow
864 SUBROUTINE mumps_set_ierror( SIZE8, IERROR )
865 INTEGER(8), INTENT(IN) :: SIZE8
866 INTEGER, INTENT(OUT) :: IERROR
867 CALL MUMPS_SETI8TOI4(SIZE8, IERROR)
868 RETURN
869 END SUBROUTINE mumps_set_ierror
870 SUBROUTINE mumps_storei8(I8, INT_ARRAY)
871 IMPLICIT NONE
872 INTEGER(8), intent(in) :: I8
873 INTEGER, intent(out) :: INT_ARRAY(2)
874 INTEGER(kind(0_4)) :: I32
875 INTEGER(8) :: IDIV, IPAR
876 parameter(ipar=int(huge(i32),8))
877 parameter(idiv=ipar+1_8)
878 IF ( i8 .LT. idiv ) THEN
879 int_array(1) = 0
880 int_array(2) = int(i8)
881 ELSE
882 int_array(1) = int(i8 / idiv)
883 int_array(2) = int(mod(i8,idiv))
884 ENDIF
885 RETURN
886 END SUBROUTINE mumps_storei8
887 SUBROUTINE mumps_geti8(I8, INT_ARRAY)
888 IMPLICIT NONE
889 INTEGER(8), intent(out) :: I8
890 INTEGER, intent(in) :: INT_ARRAY(2)
891 INTEGER(kind(0_4)) :: I32
892 INTEGER(8) :: IDIV, IPAR
893 parameter(ipar=int(huge(i32),8))
894 parameter(idiv=ipar+1_8)
895 IF ( int_array(1) .EQ. 0 ) THEN
896 i8=int(int_array(2),8)
897 ELSE
898 i8=int(int_array(1),8)*idiv+int(int_array(2),8)
899 ENDIF
900 RETURN
901 END SUBROUTINE mumps_geti8
902 SUBROUTINE mumps_addi8toarray( INT_ARRAY, I8 )
903 IMPLICIT NONE
904 INTEGER(8), intent(in) :: I8
905 INTEGER, intent(inout) :: INT_ARRAY(2)
906 INTEGER(8) :: I8TMP
907 CALL mumps_geti8(i8tmp, int_array)
908 i8tmp = i8tmp + i8
909 CALL mumps_storei8(i8tmp, int_array)
910 RETURN
911 END SUBROUTINE mumps_addi8toarray
912 SUBROUTINE mumps_subtri8toarray( INT_ARRAY, I8 )
913 IMPLICIT NONE
914 INTEGER(8), intent(in) :: I8
915 INTEGER, intent(inout) :: INT_ARRAY(2)
916 INTEGER(8) :: I8TMP
917 CALL mumps_geti8(i8tmp, int_array)
918 i8tmp = i8tmp - i8
919 CALL mumps_storei8(i8tmp, int_array)
920 RETURN
921 END SUBROUTINE mumps_subtri8toarray
922 FUNCTION mumps_seqana_avail(ICNTL7)
923 LOGICAL :: mumps_seqana_avail
924 INTEGER, INTENT(IN) :: icntl7
925 LOGICAL :: scotch=.false.
926 LOGICAL :: metis =.false.
927#if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3)
928 metis = .true.
929#endif
930#if defined(scotch) || defined(ptscotch)
931 scotch = .true.
932#endif
933 IF ( icntl7 .LT. 0 .OR. icntl7 .GT. 7 ) THEN
934 mumps_seqana_avail = .false.
935 ELSE
936 mumps_seqana_avail = .true.
937 ENDIF
938 IF ( icntl7 .EQ. 5 ) mumps_seqana_avail = metis
939 IF ( icntl7 .EQ. 3 ) mumps_seqana_avail = scotch
940 RETURN
941 END FUNCTION mumps_seqana_avail
942 FUNCTION mumps_parana_avail(WHICH)
943 LOGICAL :: mumps_parana_avail
944 CHARACTER :: which*(*)
945 LOGICAL :: ptscotch=.false., parmetis=.false.
946#if defined(ptscotch)
947 ptscotch = .true.
948#endif
949#if defined(parmetis) || defined(parmetis3)
950 parmetis = .true.
951#endif
952 SELECT CASE(which)
953 CASE('ptscotch','ptscotch')
954 MUMPS_PARANA_AVAIL = PTSCOTCH
955 CASE('parmetis','parmetis')
956 MUMPS_PARANA_AVAIL = PARMETIS
957 CASE('both','both')
958.AND. MUMPS_PARANA_AVAIL = PTSCOTCH PARMETIS
959 CASE('any','any')
960.OR. MUMPS_PARANA_AVAIL = PTSCOTCH PARMETIS
961 CASE default
962 write(*,'("Invalid input in MUMPS_PARANA_AVAIL")')
963 END SELECT
964 RETURN
965 END FUNCTION MUMPS_PARANA_AVAIL
966 SUBROUTINE MUMPS_SORT_STEP(N,FRERE,STEP,FILS,
967 & NA,LNA,NE,ND,DAD,LDAD,USE_DAD,
968 & NSTEPS,INFO,LP,
969 & PROCNODE,SLAVEF
970 & )
971 IMPLICIT NONE
972 INTEGER N, NSTEPS, LNA, LP,LDAD
973 INTEGER FRERE(NSTEPS), FILS(N), STEP(N)
974 INTEGER NA(LNA), NE(NSTEPS), ND(NSTEPS)
975 INTEGER DAD(LDAD)
976 LOGICAL USE_DAD
977 INTEGER INFO(80)
978 INTEGER SLAVEF,PROCNODE(NSTEPS)
979 INTEGER POSTORDER,TMP_SWAP
980 INTEGER, DIMENSION (:), ALLOCATABLE :: STEP_TO_NODE
981 INTEGER, DIMENSION (:), ALLOCATABLE :: IPOOL,TNSTK
982 INTEGER I,II,allocok
983 INTEGER NBLEAF,NBROOT,LEAF,IN,INODE,IFATH
984 EXTERNAL MUMPS_TYPENODE
985 INTEGER MUMPS_TYPENODE
986 POSTORDER=1
987 NBLEAF = NA(1)
988 NBROOT = NA(2)
989 ALLOCATE( IPOOL(NBLEAF), TNSTK(NSTEPS), stat=allocok )
990 IF (allocok > 0) THEN
991.GT. IF ( LP 0 )
992 & WRITE(LP,*)'memory allocation error in mumps_sort_step'
993 INFO(1)=-7
994 INFO(2)=NSTEPS
995 RETURN
996 ENDIF
997 DO I=1,NSTEPS
998 TNSTK(I) = NE(I)
999 ENDDO
1000 ALLOCATE(STEP_TO_NODE(NSTEPS),stat=allocok)
1001 IF (allocok > 0) THEN
1002.GT. IF ( LP 0 )
1003 & WRITE(LP,*)'memory allocation error in
1004 &mumps_sort_step'
1005 INFO(1)=-7
1006 INFO(2)=NSTEPS
1007 RETURN
1008 ENDIF
1009 DO I=1,N
1010.GT. IF(STEP(I)0)THEN
1011 STEP_TO_NODE(STEP(I))=I
1012 ENDIF
1013 ENDDO
1014 IPOOL(1:NBLEAF)=NA(3:2+NBLEAF)
1015 LEAF = NBLEAF + 1
1016 91 CONTINUE
1017.NE. IF (LEAF1) THEN
1018 LEAF = LEAF -1
1019 INODE = IPOOL(LEAF)
1020 ENDIF
1021 96 CONTINUE
1022 IF (USE_DAD) THEN
1023 IFATH = DAD( STEP(INODE) )
1024 ELSE
1025 IN = INODE
1026 113 IN = FRERE(IN)
1027.GT. IF (IN0) GO TO 113
1028 IFATH = -IN
1029 ENDIF
1030 TMP_SWAP=FRERE(STEP(INODE))
1031 FRERE(STEP(INODE))=FRERE(POSTORDER)
1032 FRERE(POSTORDER)=TMP_SWAP
1033 TMP_SWAP=ND(STEP(INODE))
1034 ND(STEP(INODE))=ND(POSTORDER)
1035 ND(POSTORDER)=TMP_SWAP
1036 TMP_SWAP=NE(STEP(INODE))
1037 NE(STEP(INODE))=NE(POSTORDER)
1038 NE(POSTORDER)=TMP_SWAP
1039 TMP_SWAP=PROCNODE(STEP(INODE))
1040 PROCNODE(STEP(INODE))=PROCNODE(POSTORDER)
1041 PROCNODE(POSTORDER)=TMP_SWAP
1042 IF(USE_DAD)THEN
1043 TMP_SWAP=DAD(STEP(INODE))
1044 DAD(STEP(INODE))=DAD(POSTORDER)
1045 DAD(POSTORDER)=TMP_SWAP
1046 ENDIF
1047 TMP_SWAP=TNSTK(STEP(INODE))
1048 TNSTK(STEP(INODE))=TNSTK(POSTORDER)
1049 TNSTK(POSTORDER)=TMP_SWAP
1050 II=STEP_TO_NODE(POSTORDER)
1051 TMP_SWAP=STEP(INODE)
1052 STEP(STEP_TO_NODE(POSTORDER))=TMP_SWAP
1053 STEP(INODE)=POSTORDER
1054 STEP_TO_NODE(POSTORDER)=INODE
1055 STEP_TO_NODE(TMP_SWAP)=II
1056 IN=II
1057 101 IN = FILS(IN)
1058.GT. IF (IN 0 ) THEN
1059 STEP(IN)=-STEP(II)
1060 GOTO 101
1061 ENDIF
1062 IN=INODE
1063 102 IN = FILS(IN)
1064.GT. IF (IN 0 ) THEN
1065 STEP(IN)=-STEP(INODE)
1066 GOTO 102
1067 ENDIF
1068 POSTORDER = POSTORDER + 1
1069.EQ. IF (IFATH0) THEN
1070 NBROOT = NBROOT - 1
1071.EQ. IF (NBROOT0) GOTO 116
1072 GOTO 91
1073 ENDIF
1074 TNSTK(STEP(IFATH)) = TNSTK(STEP(IFATH)) - 1
1075.EQ. IF ( TNSTK(STEP(IFATH)) 0 ) THEN
1076 INODE = IFATH
1077 GOTO 96
1078 ELSE
1079 GOTO 91
1080 ENDIF
1081 116 CONTINUE
1082 DEALLOCATE(STEP_TO_NODE)
1083 DEALLOCATE(IPOOL,TNSTK)
1084 RETURN
1085 END SUBROUTINE MUMPS_SORT_STEP
1086 SUBROUTINE MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG)
1087 IMPLICIT NONE
1088 INTEGER, INTENT(IN) :: COMM_NODES
1089 LOGICAL, INTENT(OUT) :: EXIT_FLAG
1090 INCLUDE 'mumps_tags.h'
1091 INCLUDE 'mpif.h'
1092 INTEGER :: STATUS(MPI_STATUS_SIZE), IERR
1093 CALL MPI_IPROBE( MPI_ANY_SOURCE, TERREUR, COMM_NODES,
1094 & EXIT_FLAG, STATUS, IERR)
1095 RETURN
1096 END SUBROUTINE MUMPS_CHECK_COMM_NODES
1097 SUBROUTINE MUMPS_GET_PROC_PER_NODE(K414, MyID, NbProcs, COMM)
1098 IMPLICIT NONE
1099 INCLUDE 'mpif.h'
1100 INTEGER :: K414, MyID, NbProcs, COMM, ALLOCOK
1101 INTEGER :: ierr,MyNAME_length,MyNAME_length_RCV,i,j
1102 CHARACTER(len=MPI_MAX_PROCESSOR_NAME) :: MyNAME
1103 CHARACTER, dimension(:), allocatable :: MyNAME_TAB,MyNAME_TAB_RCV
1104 logical :: SAME_NAME
1105 call MPI_GET_PROCESSOR_NAME(MyNAME, MyNAME_length, ierr)
1106 allocate(MyNAME_TAB(MyNAME_length), STAT=ALLOCOK)
1107.LT. IF(ALLOCOK0) THEN
1108 write(*,*) "Allocation error in MUMPS_GET_PROC_PER_NODE"
1109 call MUMPS_ABORT()
1110 ENDIF
1111 DO i=1, MyNAME_length
1112 MyNAME_TAB(i) = MyNAME(i:i)
1113 ENDDO
1114 K414=0
1115 do i=0, NbProcs-1
1116.eq. if(MyID i) then
1117 MyNAME_length_RCV = MyNAME_length
1118 else
1119 MyNAME_length_RCV = 0
1120 endif
1121 call MPI_BCAST(MyNAME_length_RCV,1,MPI_INTEGER,
1122 & i,COMM,ierr)
1123 allocate(MyNAME_TAB_RCV(MyNAME_length_RCV), STAT=ALLOCOK)
1124.LT. IF(ALLOCOK0) THEN
1125 write(*,*) "Allocation error in MUMPS_GET_PROC_PER_NODE"
1126 call MUMPS_ABORT()
1127 ENDIF
1128.eq. if(MyID i) then
1129 MyNAME_TAB_RCV = MyNAME_TAB
1130 endif
1131 call MPI_BCAST(MyNAME_TAB_RCV,MyNAME_length_RCV,MPI_CHARACTER,
1132 & i,COMM,ierr)
1133 SAME_NAME=.FALSE.
1134.EQ. IF(MyNAME_length MyNAME_length_RCV) THEN
1135 DO j=1, MyNAME_length
1136.NE. IF(MyNAME_TAB(j) MyNAME_TAB_RCV(j)) THEN
1137 goto 100
1138 ENDIF
1139 ENDDO
1140 SAME_NAME=.TRUE.
1141 ENDIF
1142 100 continue
1143 IF(SAME_NAME) K414=K414+1
1144 deallocate(MyNAME_TAB_RCV)
1145 enddo
1146 deallocate(MyNAME_TAB)
1147 END SUBROUTINE MUMPS_GET_PROC_PER_NODE
1148 SUBROUTINE MUMPS_ICOPY_32TO64 (INTAB, SIZETAB, OUTTAB8)
1149 INTEGER, intent(in) :: SIZETAB
1150 INTEGER, intent(in) :: INTAB(SIZETAB)
1151 INTEGER(8), intent(out) :: OUTTAB8(SIZETAB)
1152 INTEGER :: I
1153 DO I=1,SIZETAB
1154 OUTTAB8(I) = int(INTAB(I),8)
1155 ENDDO
1156 RETURN
1157 END SUBROUTINE MUMPS_ICOPY_32TO64
1158 SUBROUTINE MUMPS_ICOPY_32TO64_64C(INTAB, SIZETAB8, OUTTAB8)
1159 INTEGER(8), intent(in) :: SIZETAB8
1160 INTEGER, intent(in) :: INTAB(SIZETAB8)
1161 INTEGER(8), intent(out) :: OUTTAB8(SIZETAB8)
1162 INTEGER(8) :: I8
1163 LOGICAL :: OMP_FLAG
1164.GE. OMP_FLAG = (SIZETAB8 500000_8 )
1165!$OMP PARALLEL DO PRIVATE(I8)
1166!$OMP& IF(OMP_FLAG)
1167 DO I8=1_8, SIZETAB8
1168 OUTTAB8(I8) = int(INTAB(I8),8)
1169 ENDDO
1170!$OMP END PARALLEL DO
1171 RETURN
1172 END SUBROUTINE MUMPS_ICOPY_32TO64_64C
1173 SUBROUTINE MUMPS_ICOPY_32TO64_64C_IP(IN_OUT_TAB48, SIZETAB)
1174 INTEGER(8), intent(in) :: SIZETAB
1175 INTEGER, intent(inout) :: IN_OUT_TAB48(2*SIZETAB)
1176 CALL MUMPS_ICOPY_32TO64_64C_IP_REC(IN_OUT_TAB48, SIZETAB)
1177 RETURN
1178 END SUBROUTINE MUMPS_ICOPY_32TO64_64C_IP
1179 RECURSIVE SUBROUTINE MUMPS_ICOPY_32TO64_64C_IP_REC(
1180 & IN_OUT_TAB48, SIZETAB)
1181 IMPLICIT NONE
1182 INTEGER(8), intent(in) :: SIZETAB
1183 INTEGER :: IN_OUT_TAB48(2*SIZETAB)
1184 INTEGER(8) :: IBEG24, IBEG28, SIZE1, SIZE2
1185.LE. IF (SIZETAB 1000_8) THEN
1186 CALL MUMPS_ICOPY_32TO64_64C_IP_C(IN_OUT_TAB48(1),
1187 & SIZETAB)
1188 ELSE
1189 SIZE2 = SIZETAB / 2
1190 SIZE1 = SIZETAB - SIZE2
1191 IBEG24 = SIZE1+1
1192 IBEG28 = 2*SIZE1+1_8
1193 CALL MUMPS_ICOPY_32TO64_64C(IN_OUT_TAB48(IBEG24),
1194 & SIZE2, IN_OUT_TAB48(IBEG28))
1195 CALL MUMPS_ICOPY_32TO64_64C_IP_REC(IN_OUT_TAB48,
1196 & SIZE1)
1197 ENDIF
1198 RETURN
1199 END SUBROUTINE MUMPS_ICOPY_32TO64_64C_IP_REC
1200 SUBROUTINE MUMPS_ICOPY_64TO32(INTAB8, SIZETAB, OUTTAB)
1201 INTEGER, intent(in) :: SIZETAB
1202 INTEGER(8), intent(in) :: INTAB8(SIZETAB)
1203 INTEGER, intent(out) :: OUTTAB(SIZETAB)
1204 INTEGER :: I
1205 DO I=1,SIZETAB
1206 OUTTAB(I) = int(INTAB8(I))
1207 ENDDO
1208 RETURN
1209 END SUBROUTINE MUMPS_ICOPY_64TO32
1210 SUBROUTINE MUMPS_ICOPY_64TO32_64C (INTAB8, SIZETAB, OUTTAB)
1211 INTEGER(8), intent(in) :: SIZETAB
1212 INTEGER(8), intent(in) :: INTAB8(SIZETAB)
1213 INTEGER, intent(out) :: OUTTAB(SIZETAB)
1214 INTEGER(8) :: I8
1215 DO I8=1_8,SIZETAB
1216 OUTTAB(I8) = int(INTAB8(I8))
1217 ENDDO
1218 RETURN
1219 END SUBROUTINE MUMPS_ICOPY_64TO32_64C
1220 SUBROUTINE MUMPS_ICOPY_64TO32_64C_IP(IN_OUT_TAB48, SIZETAB)
1221 INTEGER(8), intent(in) :: SIZETAB
1222 INTEGER, intent(inout) :: IN_OUT_TAB48(2*SIZETAB)
1223 CALL MUMPS_ICOPY_64TO32_64C_IP_REC(IN_OUT_TAB48, SIZETAB)
1224 RETURN
1225 END SUBROUTINE MUMPS_ICOPY_64TO32_64C_IP
1226 RECURSIVE SUBROUTINE MUMPS_ICOPY_64TO32_64C_IP_REC(
1227 & IN_OUT_TAB48, SIZETAB)
1228 IMPLICIT NONE
1229 INTEGER(8), intent(in) :: SIZETAB
1230 INTEGER :: IN_OUT_TAB48(2*SIZETAB)
1231 INTEGER(8) :: IBEG24, IBEG28, SIZE1, SIZE2
1232.LE. IF (SIZETAB 1000_8) THEN
1233 CALL MUMPS_ICOPY_64TO32_64C_IP_C(IN_OUT_TAB48(1),
1234 & SIZETAB)
1235 ELSE
1236 SIZE2 = SIZETAB / 2
1237 SIZE1 = SIZETAB - SIZE2
1238 IBEG24 = SIZE1 + 1
1239 IBEG28 = SIZE1 + SIZE1 + 1_8
1240 CALL MUMPS_ICOPY_64TO32_64C_IP_REC(IN_OUT_TAB48,
1241 & SIZE1)
1242 CALL MUMPS_ICOPY_64TO32_64C(IN_OUT_TAB48(IBEG28),
1243 & SIZE2, IN_OUT_TAB48(IBEG24))
1244 ENDIF
1245 RETURN
1246 END SUBROUTINE MUMPS_ICOPY_64TO32_64C_IP_REC
1247 SUBROUTINE MUMPS_GET_NNZ_INTERNAL( NNZ, NZ, NNZ_i )
1248 INTEGER , INTENT(IN) :: NZ
1249 INTEGER(8), INTENT(IN) :: NNZ
1250 INTEGER(8), INTENT(OUT) :: NNZ_i
1251 IF (NNZ > 0_8) THEN
1252 NNZ_i = NNZ
1253 ELSE
1254 NNZ_i = int(NZ, 8)
1255 ENDIF
1256 END SUBROUTINE MUMPS_GET_NNZ_INTERNAL
1257 SUBROUTINE MUMPS_NPIV_CRITICAL_PATH(
1258 & N, NSTEPS, STEP, FRERE, FILS,
1259 & NA, LNA, NE, MAXNPIVTREE )
1260 IMPLICIT NONE
1261 INTEGER, intent(in) :: N, NSTEPS, LNA
1262 INTEGER, intent(in) :: FRERE(NSTEPS), FILS(N), STEP(N)
1263 INTEGER, intent(in) :: NA(LNA), NE(NSTEPS)
1264 INTEGER, intent(out) :: MAXNPIVTREE
1265 INTEGER :: IFATH,INODE,ISON
1266 INTEGER :: NPIV,ILEAF,NBLEAF,NBROOT
1267 INTEGER, DIMENSION(:) , ALLOCATABLE :: MAXNPIV
1268 INTEGER :: I, allocok
1269 MAXNPIVTREE = -9999
1270 ALLOCATE ( MAXNPIV(NSTEPS), stat=allocok)
1271.gt. IF (allocok 0) THEN
1272 WRITE(*, *) 'allocation error in mumps_npiv_critical_path'
1273 & ,NSTEPS
1274 CALL MUMPS_ABORT()
1275 ENDIF
1276 NBLEAF = NA(1)
1277 NBROOT = NA(2)
1278 MAXNPIV = 0
1279 NBLEAF = NA(1)
1280 NBROOT = NA(2)
1281 DO ILEAF = 1, NBLEAF
1282 INODE = NA(2+ILEAF)
1283 95 CONTINUE
1284 NPIV = 0
1285 ISON = INODE
1286 100 NPIV = NPIV + 1
1287 ISON = FILS(ISON)
1288.GT. IF (ISON 0 ) GOTO 100
1289 ISON = -ISON
1290 MAXNPIV( STEP(INODE) ) = NPIV
1291 DO I = 1, NE(STEP(INODE))
1292 MAXNPIV(STEP(INODE)) = max( MAXNPIV(STEP(INODE)),
1293 & NPIV + MAXNPIV(STEP(ISON)) )
1294 ISON = FRERE(STEP(ISON))
1295 ENDDO
1296 IFATH = INODE
1297.GT. DO WHILE (IFATH 0)
1298 IFATH = FRERE(STEP(IFATH))
1299 ENDDO
1300 IFATH = -IFATH
1301.EQ. IF (IFATH0) THEN
1302 MAXNPIVTREE = max(MAXNPIVTREE, MAXNPIV(STEP(INODE)))
1303 ELSE
1304.LT. IF (FRERE(STEP(INODE)) 0) THEN
1305 INODE = IFATH
1306 GOTO 95
1307 ENDIF
1308 ENDIF
1309 ENDDO
1310 DEALLOCATE( MAXNPIV )
1311 RETURN
1312 END SUBROUTINE MUMPS_NPIV_CRITICAL_PATH
1313 SUBROUTINE MUMPS_LDLTPANEL_NBTARGET( NPIV, NB_TARGET, KEEP )
1314 IMPLICIT NONE
1315 INTEGER, INTENT(IN) :: NPIV
1316 INTEGER, INTENT(IN) :: KEEP(500)
1317 INTEGER, INTENT(OUT) :: NB_TARGET
1318 INTEGER :: NBPANELS, NBCOLMIN, NBPANELSMAX
1319.EQ. IF (NPIV 0) THEN
1320 NB_TARGET = 0
1321 ELSE
1322 NBCOLMIN = KEEP(460)
1323 NBPANELSMAX = KEEP(459)
1324 NBPANELS = min( (NPIV+NBCOLMIN-1) / NBCOLMIN, NBPANELSMAX )
1325 NB_TARGET = ( NPIV+NBPANELS-1 ) / NBPANELS
1326 ENDIF
1327 RETURN
1328 END SUBROUTINE MUMPS_LDLTPANEL_NBTARGET
1329 SUBROUTINE MUMPS_LDLTPANEL_STORAGE
1330 & ( NPIV, KEEP, IW, NB_ENTRIES )
1331 IMPLICIT NONE
1332 INTEGER, INTENT(IN) :: NPIV
1333 INTEGER, INTENT(IN) :: KEEP(500), IW(*)
1334 INTEGER(8), INTENT(OUT) :: NB_ENTRIES
1335 INTEGER :: NB_TARGET, NBCOLS_PANEL, NBROWS_PANEL
1336 INTEGER :: ICOL_BEG, ICOL_END, NBPANELS
1337 CALL MUMPS_LDLTPANEL_NBTARGET( NPIV, NB_TARGET, KEEP )
1338 NB_ENTRIES = 0_8
1339 NBROWS_PANEL = NPIV
1340 ICOL_BEG = 1
1341 NBPANELS = 0
1342.LE. DO WHILE ( ICOL_BEG NPIV )
1343 NBPANELS = NBPANELS + 1
1344 ICOL_END = min(NB_TARGET * NBPANELS, NPIV)
1345.NE. IF (IW(1) 0) THEN
1346 IF ( IW( ICOL_END ) < 0 ) THEN
1347 ICOL_END = ICOL_END + 1
1348 ENDIF
1349 ENDIF
1350 NBCOLS_PANEL = ICOL_END - ICOL_BEG + 1
1351 NB_ENTRIES = NB_ENTRIES + int(NBCOLS_PANEL,8) *
1352 & int(NBROWS_PANEL,8)
1353 NBROWS_PANEL = NBROWS_PANEL - NBCOLS_PANEL
1354 ICOL_BEG = ICOL_END + 1
1355 ENDDO
1356 RETURN
1357 END SUBROUTINE MUMPS_LDLTPANEL_STORAGE
1358 SUBROUTINE MUMPS_LDLTPANEL_PANELINFOS( NPIV, KEEP, IW,
1359 & NB_TARGET, NBPANELS, PANEL_COL, PANEL_POS, PANEL_TABSIZE,
1360 & IGNORE_K459 )
1361 IMPLICIT NONE
1362 INTEGER, INTENT(IN) :: NPIV
1363 INTEGER, INTENT(IN) :: IW( NPIV )
1364 INTEGER, INTENT(IN) :: KEEP(500)
1365 INTEGER, INTENT(IN) :: PANEL_TABSIZE
1366 INTEGER, INTENT(OUT) :: NB_TARGET, NBPANELS
1367 INTEGER, INTENT(OUT) :: PANEL_COL( PANEL_TABSIZE )
1368 INTEGER(8), INTENT(OUT) :: PANEL_POS( PANEL_TABSIZE )
1369 LOGICAL, INTENT(IN) :: IGNORE_K459
1370 INTEGER :: IPANEL, ICOL_END, NBROWS_PANEL, NBCOLS_PANEL
1371 IF ( IGNORE_K459 ) THEN
1372 NB_TARGET = NPIV
1373 ELSE
1374 CALL MUMPS_LDLTPANEL_NBTARGET( NPIV, NB_TARGET, KEEP )
1375 ENDIF
1376 PANEL_POS(1) = 1_8
1377 PANEL_COL(1) = 1
1378 NBROWS_PANEL = NPIV
1379 NBPANELS = 1
1380.GT..AND..NE..AND. IF ( KEEP(459) 1 KEEP(50) 0
1381.NE. & NB_TARGETNPIV ) THEN
1382 NBPANELS = ( NPIV + NB_TARGET -1 ) / NB_TARGET
1383.LT. IF ( PANEL_TABSIZE NBPANELS + 1 ) THEN
1384 WRITE(*,*) " Internal error in MUMPS_LDLTPANEL_PANELINFOS",
1385 & PANEL_TABSIZE, NBPANELS
1386 CALL MUMPS_ABORT()
1387 ENDIF
1388 DO IPANEL=1, NBPANELS
1389 ICOL_END = min(IPANEL*NB_TARGET, NPIV)
1390.LT. IF ( IW(ICOL_END) 0 ) THEN
1391 ICOL_END = ICOL_END + 1
1392 ENDIF
1393 NBCOLS_PANEL = ICOL_END - PANEL_COL(IPANEL) + 1
1394 PANEL_POS(IPANEL+1) = PANEL_POS(IPANEL) +
1395 & int(NBROWS_PANEL,8)*int(NBCOLS_PANEL,8)
1396 PANEL_COL(IPANEL+1) = PANEL_COL(IPANEL) + NBCOLS_PANEL
1397 NBROWS_PANEL = NBROWS_PANEL - NBCOLS_PANEL
1398 ENDDO
1399 ELSE
1400 PANEL_POS(2) = int(NPIV,8)*int(NPIV,8)+1_8
1401 PANEL_COL(2) = NPIV+1
1402 ENDIF
1403 END SUBROUTINE MUMPS_LDLTPANEL_PANELINFOS
1404 SUBROUTINE MUMPS_LDLTPANEL_SIZES
1405 & ( NPIV, KEEP, IW, PANEL_SIZES, NBPANELS )
1406 IMPLICIT NONE
1407 INTEGER, INTENT(IN) :: NPIV
1408 INTEGER, INTENT(IN) :: KEEP(500), IW(NPIV)
1409 INTEGER(8), INTENT(OUT) :: PANEL_SIZES( KEEP(459) )
1410 INTEGER, INTENT(OUT) :: NBPANELS
1411 INTEGER :: NB_TARGET
1412 INTEGER :: ICOL_BEG, ICOL_END
1413 NBPANELS = 0
1414 CALL MUMPS_LDLTPANEL_NBTARGET( NPIV, NB_TARGET, KEEP )
1415 ICOL_BEG = 1
1416 NBPANELS = 0
1417.LE. DO WHILE ( ICOL_BEG NPIV )
1418 NBPANELS = NBPANELS + 1
1419 ICOL_END = min(NB_TARGET * NBPANELS, NPIV)
1420 IF ( IW( ICOL_END ) < 0 ) THEN
1421 ICOL_END = ICOL_END + 1
1422 ENDIF
1423 PANEL_SIZES(NBPANELS) = ICOL_END-ICOL_BEG+1
1424 ICOL_BEG = ICOL_END + 1
1425 ENDDO
1426 PANEL_SIZES(NBPANELS+1:KEEP(459))=0
1427 RETURN
1428 END SUBROUTINE MUMPS_LDLTPANEL_SIZES
1429 SUBROUTINE MUMPS_BUILD_ARCH_NODE_COMM
1430 & ( COMM, NEWCOMM, NEWSIZE, NEWRANK )
1431 IMPLICIT NONE
1432 INCLUDE 'mpif.h'
1433 INTEGER, INTENT(IN) :: COMM
1434 INTEGER, INTENT(OUT) :: NEWCOMM, NEWSIZE, NEWRANK
1435 INTEGER :: SMALLEST_ID_ON_SAME_NODE, IPROC, MYID, IERR, NPROCS
1436 INTEGER :: TMPNAME_LENGTH, MYNAME_LENGTH
1437 CHARACTER(len=MPI_MAX_PROCESSOR_NAME) :: MYNAME, TMPNAME
1438 SMALLEST_ID_ON_SAME_NODE = -1
1439 CALL MPI_COMM_RANK( COMM, MYID, IERR )
1440 CALL MPI_COMM_SIZE( COMM, NPROCS, IERR )
1441 CALL MPI_GET_PROCESSOR_NAME(MYNAME, MYNAME_LENGTH, IERR )
1442 DO IPROC = 0, NPROCS - 1
1443.EQ. IF (MYID IPROC) THEN
1444 TMPNAME = MYNAME
1445 TMPNAME_LENGTH = MYNAME_LENGTH
1446 ENDIF
1447 CALL MPI_BCAST( TMPNAME_LENGTH, 1, MPI_INTEGER,
1448 & IPROC, COMM, IERR )
1449 CALL MPI_BCAST( TMPNAME, TMPNAME_LENGTH, MPI_CHARACTER,
1450 & IPROC, COMM, IERR)
1451.LT. IF (SMALLEST_ID_ON_SAME_NODE 0) THEN
1452.EQ. IF ( TMPNAME_LENGTH MYNAME_LENGTH ) THEN
1453.EQ. IF ( TMPNAME(1:TMPNAME_LENGTH) MYNAME(1:MYNAME_LENGTH) )
1454 & THEN
1455 SMALLEST_ID_ON_SAME_NODE = IPROC
1456 ENDIF
1457 ENDIF
1458 ENDIF
1459 ENDDO
1460 CALL MPI_COMM_SPLIT( COMM, SMALLEST_ID_ON_SAME_NODE, 0,
1461 & NEWCOMM, IERR )
1462 CALL MPI_COMM_RANK( NEWCOMM, NEWRANK, IERR )
1463 CALL MPI_COMM_SIZE( NEWCOMM, NEWSIZE, IERR )
1464 RETURN
1465 END SUBROUTINE MUMPS_BUILD_ARCH_NODE_COMM
1466 SUBROUTINE MUMPS_DESTROY_ARCH_NODE_COMM( ARCH_NODE_COMM )
1467 IMPLICIT NONE
1468 INTEGER :: ARCH_NODE_COMM, IERR
1469 INCLUDE 'mpif.h'
1470 CALL MPI_COMM_FREE( ARCH_NODE_COMM, IERR )
1471 RETURN
1472 END SUBROUTINE MUMPS_DESTROY_ARCH_NODE_COMM
1473 SUBROUTINE MUMPS_DM_FAC_UPD_DYN_MEMCNTS
1474 & ( MEM_COUNT_ALLOCATED, ATOMIC_UPDATES, KEEP8,
1475 & IFLAG, IERROR, K69UPD, K71UPD )
1476 IMPLICIT NONE
1477 INTEGER(8), INTENT(IN) :: MEM_COUNT_ALLOCATED
1478 INTEGER(8), INTENT(INOUT) :: KEEP8(150)
1479 LOGICAL, INTENT(IN) :: ATOMIC_UPDATES
1480 INTEGER, INTENT(INOUT) :: IFLAG, IERROR
1481 LOGICAL, INTENT(IN) :: K69UPD
1482 LOGICAL, INTENT(IN) :: K71UPD
1483 INTEGER(8) :: KEEP8TMPCOPY
1484.GT. IF (MEM_COUNT_ALLOCATED0) THEN
1485 IF (ATOMIC_UPDATES ) THEN
1486!$OMP ATOMIC CAPTURE
1487 KEEP8(73) = KEEP8(73) + MEM_COUNT_ALLOCATED
1488 KEEP8TMPCOPY = KEEP8(73)
1489!$OMP END ATOMIC
1490!$OMP ATOMIC UPDATE
1491 KEEP8(74) = max(KEEP8(74), KEEP8TMPCOPY)
1492!$OMP END ATOMIC
1493 ELSE
1494 KEEP8(73) = KEEP8(73) + MEM_COUNT_ALLOCATED
1495 KEEP8TMPCOPY = KEEP8(73)
1496 KEEP8(74) = max(KEEP8(74), KEEP8(73))
1497 ENDIF
1498.GT. IF ( KEEP8TMPCOPY KEEP8(75) ) THEN
1499 IFLAG = -19
1500 CALL MUMPS_SET_IERROR(
1501 & (KEEP8TMPCOPY-KEEP8(75)), IERROR)
1502 ENDIF
1503 IF ( K69UPD ) THEN
1504 IF ( ATOMIC_UPDATES ) THEN
1505!$OMP ATOMIC CAPTURE
1506 KEEP8(69) = KEEP8(69) + MEM_COUNT_ALLOCATED
1507 KEEP8TMPCOPY = KEEP8(69)
1508!$OMP END ATOMIC
1509!$OMP ATOMIC UPDATE
1510 KEEP8(68) = max(KEEP8(68), KEEP8TMPCOPY)
1511!$OMP END ATOMIC
1512 ELSE
1513 KEEP8(69) = KEEP8(69) + MEM_COUNT_ALLOCATED
1514 KEEP8(68) = max(KEEP8(69), KEEP8(68))
1515 ENDIF
1516 ENDIF
1517 IF ( K71UPD ) THEN
1518 IF ( ATOMIC_UPDATES ) THEN
1519!$OMP ATOMIC CAPTURE
1520 KEEP8(71) = KEEP8(71) + MEM_COUNT_ALLOCATED
1521 KEEP8TMPCOPY = KEEP8(71)
1522!$OMP END ATOMIC
1523!$OMP ATOMIC UPDATE
1524 KEEP8(70) = max(KEEP8(70), KEEP8TMPCOPY)
1525!$OMP END ATOMIC
1526 ELSE
1527 KEEP8(71) = KEEP8(71) + MEM_COUNT_ALLOCATED
1528 KEEP8(70) = max(KEEP8(71), KEEP8(70))
1529 ENDIF
1530 ENDIF
1531 ELSE
1532 IF (ATOMIC_UPDATES) THEN
1533!$OMP ATOMIC UPDATE
1534 KEEP8(73) = KEEP8(73) + MEM_COUNT_ALLOCATED
1535!$OMP END ATOMIC
1536 IF ( K69UPD ) THEN
1537!$OMP ATOMIC UPDATE
1538 KEEP8(69) = KEEP8(69) + MEM_COUNT_ALLOCATED
1539!$OMP END ATOMIC
1540 ENDIF
1541 IF ( K71UPD ) THEN
1542!$OMP ATOMIC UPDATE
1543 KEEP8(71) = KEEP8(71) + MEM_COUNT_ALLOCATED
1544!$OMP END ATOMIC
1545 ENDIF
1546 ELSE
1547 KEEP8(73) = KEEP8(73) + MEM_COUNT_ALLOCATED
1548 IF ( K69UPD ) THEN
1549 KEEP8(69) = KEEP8(69) + MEM_COUNT_ALLOCATED
1550 ENDIF
1551 IF ( K71UPD ) THEN
1552 KEEP8(71) = KEEP8(71) + MEM_COUNT_ALLOCATED
1553 ENDIF
1554 ENDIF
1555 ENDIF
1556 RETURN
1557 END SUBROUTINE MUMPS_DM_FAC_UPD_DYN_MEMCNTS
1558 SUBROUTINE MUMPS_SET_PARTI_REGULAR(
1559 & SLAVEF,
1560 & KEEP,KEEP8,
1561 & PROCS,
1562 & MEM_DISTRIB, NCB, NFRONT, NSLAVES_NODE,
1563 & TAB_POS, SLAVES_LIST, SIZE_SLAVES_LIST,MYID,INODE,
1564 & TAB_MAXS_ARG,SUP_PROC_ARG,MAX_SURF,NB_ROW_MAX
1565 & )
1566 IMPLICIT NONE
1567 INTEGER, intent(in) :: KEEP(500),SIZE_SLAVES_LIST
1568 INTEGER(8) KEEP8(150)
1569 INTEGER, intent(in) :: SLAVEF, NFRONT, NCB,MYID
1570 INTEGER, intent(in) :: PROCS(SLAVEF+1)
1571 INTEGER(8), intent(in) :: TAB_MAXS_ARG(0:SLAVEF-1)
1572 INTEGER, intent(in) :: SUP_PROC_ARG(2)
1573 INTEGER, intent(in) :: MEM_DISTRIB(0:SLAVEF-1),INODE
1574 INTEGER, intent(out):: SLAVES_LIST(SIZE_SLAVES_LIST)
1575 INTEGER, intent(out):: TAB_POS(SLAVEF+2)
1576 INTEGER, intent(out):: NSLAVES_NODE,NB_ROW_MAX
1577 INTEGER(8), intent(out):: MAX_SURF
1578 LOGICAL :: FORCE_LDLTRegular_NIV2
1579 INTEGER NSLAVES,ACC
1580 INTEGER i,J,NELIM,NB_SUP,K50,NB_ROWS(PROCS(SLAVEF+1))
1581 INTEGER TMP_NROW,X,K
1582 LOGICAL SUP,MEM_CSTR
1583 DOUBLE PRECISION MAX_LOAD,TOTAL_LOAD,VAR,TMP,A,B,C,DELTA,
1584 & LOAD_CORR
1585 INTEGER IDWLOAD(SLAVEF)
1586 INTEGER(8) MEM_CONSTRAINT(2)
1587 K50=KEEP(50)
1588 FORCE_LDLTRegular_NIV2 = .FALSE.
1589 MAX_SURF=0
1590 NB_ROW_MAX=0
1591 NELIM=NFRONT-NCB
1592 NB_SUP=0
1593 TOTAL_LOAD=0.0D0
1594 SUP=.FALSE.
1595.NE. IF(SUP_PROC_ARG(1)
1596 & 0)THEN
1597 MEM_CONSTRAINT(1)=TAB_MAXS_ARG(PROCS(1))
1598 TOTAL_LOAD=TOTAL_LOAD+dble(SUP_PROC_ARG(1))/100.0D0
1599 NB_SUP=NB_SUP+1
1600 ENDIF
1601.NE. IF(SUP_PROC_ARG(2)
1602 & 0)THEN
1603 MEM_CONSTRAINT(2)=TAB_MAXS_ARG(PROCS(PROCS(SLAVEF+1)))
1604 TOTAL_LOAD=TOTAL_LOAD+dble(SUP_PROC_ARG(2))/100.0D0
1605 NB_SUP=NB_SUP+1
1606 ENDIF
1607 TOTAL_LOAD=TOTAL_LOAD+(PROCS(SLAVEF+1)-NB_SUP)
1608.EQ. IF(K500)THEN
1609 MAX_LOAD=dble( NELIM ) * dble ( NCB ) +
1610 * dble(NCB) * dble(NELIM)*dble(2*NFRONT-NELIM-1)
1611 ELSE
1612 MAX_LOAD=dble(NELIM) * dble ( NCB ) *
1613 * dble(NFRONT+1)
1614 ENDIF
1615 TMP=min(MAX_LOAD,MAX_LOAD/TOTAL_LOAD)
1616 J=1
1617 DO i=1,PROCS(SLAVEF+1)
1618.GT..AND..EQ. IF((NB_SUP0)(i1))THEN
1619 CYCLE
1620.EQ..AND..EQ. ELSEIF((NB_SUP2)(iPROCS(SLAVEF+1)))THEN
1621 CYCLE
1622 ENDIF
1623 IDWLOAD(J)=PROCS(i)
1624 J=J+1
1625 ENDDO
1626 DO i=1,NB_SUP
1627.EQ. IF(i1)THEN
1628 IDWLOAD(J)=PROCS(1)
1629 ELSE
1630 IDWLOAD(J)=PROCS(PROCS(SLAVEF+1))
1631 ENDIF
1632 J=J+1
1633 ENDDO
1634.EQ..OR. IF ((K500)FORCE_LDLTRegular_NIV2) THEN
1635 ACC=0
1636 J=PROCS(SLAVEF+1)-NB_SUP+1
1637 DO i=1,NB_SUP
1638 VAR=dble(SUP_PROC_ARG(i))/100.0D0
1639 TMP_NROW=int(dble(MEM_CONSTRAINT(i))/dble(NFRONT))
1640 NB_ROWS(J)=int(max((VAR*dble(TMP))/
1641 & (dble(NELIM)*dble(2*NFRONT-NELIM)),
1642 & dble(1)))
1643.GT. IF(NB_ROWS(J)TMP_NROW)THEN
1644 NB_ROWS(J)=TMP_NROW
1645 ENDIF
1646.LT. IF(NCB-ACCNB_ROWS(J)) THEN
1647 NB_ROWS(J)=NCB-ACC
1648 ACC=NCB
1649 EXIT
1650 ENDIF
1651 ACC=ACC+NB_ROWS(J)
1652 J=J+1
1653 ENDDO
1654.EQ. IF(ACCNCB)THEN
1655 GOTO 777
1656 ENDIF
1657 DO i=1,PROCS(SLAVEF+1)-NB_SUP
1658 VAR=1.0D0
1659 TMP_NROW=int((dble(TAB_MAXS_ARG(IDWLOAD(i))))/dble(NFRONT))
1660 NB_ROWS(i)=int((dble(VAR)*dble(TMP))/
1661 & (dble(NELIM)*dble(2*NFRONT-NELIM)))
1662.GT. IF(NB_ROWS(i)TMP_NROW)THEN
1663 NB_ROWS(i)=TMP_NROW
1664 ENDIF
1665.LT. IF(NCB-ACCNB_ROWS(i)) THEN
1666 NB_ROWS(i)=NCB-ACC
1667 ACC=NCB
1668 EXIT
1669 ENDIF
1670 ACC=ACC+NB_ROWS(i)
1671 ENDDO
1672.NE. IF(ACCNCB)THEN
1673.EQ. IF(PROCS(SLAVEF+1)NB_SUP)THEN
1674 TMP_NROW=(NCB-ACC)/PROCS(SLAVEF+1)+1
1675 DO i=1,PROCS(SLAVEF+1)
1676 NB_ROWS(i)=NB_ROWS(i)+TMP_NROW
1677.GT. IF(ACC+TMP_NROWNCB)THEN
1678 NB_ROWS(i)=NB_ROWS(i)-TMP_NROW+NCB-ACC
1679 ACC=NCB
1680 EXIT
1681 ENDIF
1682 ACC=ACC+TMP_NROW
1683 ENDDO
1684 ELSE
1685 TMP_NROW=(NCB-ACC)/(PROCS(SLAVEF+1)-NB_SUP)+1
1686 DO i=1,PROCS(SLAVEF+1)-NB_SUP
1687 NB_ROWS(i)=NB_ROWS(i)+TMP_NROW
1688 ACC=ACC+TMP_NROW
1689.GT. IF(ACCNCB) THEN
1690 NB_ROWS(i)=NB_ROWS(i)-TMP_NROW+
1691 & (NCB-(ACC-TMP_NROW))
1692 EXIT
1693 ENDIF
1694 ENDDO
1695 ENDIF
1696 ENDIF
1697 ELSE
1698 ACC=0
1699 i=PROCS(SLAVEF+1)-NB_SUP+1
1700 X=NCB
1701 LOAD_CORR=0.0D0
1702 MEM_CSTR=.FALSE.
1703 DO J=1,NB_SUP
1704 VAR=DBLE(SUP_PROC_ARG(J))/DBLE(100)
1705 A=1.0D0
1706 B=dble(X+NELIM)
1707 C=-dble(max(MEM_CONSTRAINT(J),0_8))
1708 DELTA=((B*B)-(4*A*C))
1709 TMP_NROW=int((-B+sqrt(DELTA))/(2*A))
1710 A=dble(-NELIM)
1711 B=dble(NELIM)*(dble(-NELIM)+dble(2*(X+NELIM)+1))
1712 C=-(VAR*TMP)
1713 DELTA=(B*B-(4*A*C))
1714 NB_ROWS(i)=int((-B+sqrt(DELTA))/(2*A))
1715.GT. IF(NB_ROWS(i)TMP_NROW)THEN
1716 NB_ROWS(i)=TMP_NROW
1717 MEM_CSTR=.TRUE.
1718 ENDIF
1719.GT. IF(ACC+NB_ROWS(i)NCB)THEN
1720 NB_ROWS(i)=NCB-ACC
1721 ACC=NCB
1722 X=0
1723 EXIT
1724 ENDIF
1725 X=X-NB_ROWS(i)
1726 ACC=ACC+NB_ROWS(i)
1727 LOAD_CORR=LOAD_CORR+(dble(NELIM) * dble (NB_ROWS(i)) *
1728 * dble(2*(X+NELIM) - NELIM - NB_ROWS(i) + 1))
1729 i=i+1
1730 ENDDO
1731.EQ. IF(ACCNCB)THEN
1732 GOTO 777
1733 ENDIF
1734.NE..AND. IF((PROCS(SLAVEF+1)NB_SUP)MEM_CSTR)THEN
1735 TMP=(MAX_LOAD-LOAD_CORR)/(PROCS(SLAVEF+1)-NB_SUP)
1736 ENDIF
1737 X=ACC
1738 ACC=0
1739 DO i=1,PROCS(SLAVEF+1)-NB_SUP
1740.EQ. IF (KEEP(375) 1) THEN
1741 VAR=1.0D0
1742 A=dble(NELIM)
1743 B=dble(NELIM)*(dble(NELIM)+dble(2*ACC+1))
1744 C=-(VAR*TMP)
1745 ELSE
1746 A=1.0D0
1747 B=dble(ACC+NELIM)
1748 C=-TMP
1749 ENDIF
1750 DELTA=((B*B)-(4*A*C))
1751 NB_ROWS(i)=int((-B+sqrt(DELTA))/(2*A))
1752.LT. IF(NCB-ACC-XNB_ROWS(i))THEN
1753 NB_ROWS(i)=NCB-ACC-X
1754 ACC=NCB-X
1755 EXIT
1756 ENDIF
1757 ACC=ACC+NB_ROWS(i)
1758 ENDDO
1759 ACC=ACC+X
1760.NE. IF(ACCNCB)THEN
1761.EQ. IF(PROCS(SLAVEF+1)NB_SUP)THEN
1762 TMP_NROW=(NCB-ACC)/PROCS(SLAVEF+1)+1
1763 DO i=1,PROCS(SLAVEF+1)
1764 NB_ROWS(i)=NB_ROWS(i)+TMP_NROW
1765.GT. IF(ACC+TMP_NROWNCB)THEN
1766 NB_ROWS(i)=NB_ROWS(i)-TMP_NROW+NCB-ACC
1767 ACC=NCB
1768 EXIT
1769 ENDIF
1770 ACC=ACC+TMP_NROW
1771 ENDDO
1772 ELSE
1773 NB_ROWS(PROCS(SLAVEF+1)-NB_SUP)=
1774 & NB_ROWS(PROCS(SLAVEF+1)
1775 & -NB_SUP)+NCB-ACC
1776 ENDIF
1777 ENDIF
1778 ENDIF
1779 777 CONTINUE
1780 NSLAVES=0
1781 ACC=1
1782 J=1
1783 K=1
1784 DO i=1,PROCS(SLAVEF+1)
1785.NE. IF(NB_ROWS(i)0)THEN
1786 SLAVES_LIST(J)=IDWLOAD(i)
1787 TAB_POS(J)=ACC
1788 ACC=ACC+NB_ROWS(i)
1789 NB_ROW_MAX=max(NB_ROW_MAX,NB_ROWS(i))
1790.EQ. IF(K500)THEN
1791 MAX_SURF=max(int(NB_ROWS(i),8)*int(NCB,8),int(0,8))
1792 ELSE
1793 MAX_SURF=max(int(NB_ROWS(i),8)*int(ACC,8),int(0,8))
1794 ENDIF
1795 NSLAVES=NSLAVES+1
1796 J=J+1
1797 ELSE
1798 SLAVES_LIST(PROCS(SLAVEF+1)-K+1)=IDWLOAD(i)
1799 K=K+1
1800 ENDIF
1801 ENDDO
1802 TAB_POS(SLAVEF+2) = NSLAVES
1803 TAB_POS(NSLAVES+1)= NCB+1
1804 NSLAVES_NODE=NSLAVES
1805 END SUBROUTINE MUMPS_SET_PARTI_REGULAR
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
mpi_reduce
subroutine mpi_reduce(sendbuf, recvbuf, cnt, datatype, op, root, comm, ierr)
Definition mpi.f:120
mpi_allreduce
subroutine mpi_allreduce(sendbuf, recvbuf, cnt, datatype, operation, comm, ierr)
Definition mpi.f:103
pxerbla
subroutine pxerbla(contxt, srname, info)
Definition mpi.f:1600
descinit
subroutine descinit(desc, m, n, mb, nb, irsrc, icsrc, ictxt, lld, info)
Definition mpi.f:777
mpi_abort
subroutine mpi_abort(comm, ierrcode, ierr)
Definition mpi.f:153
mumps_nblocal_roots_or_leaves
subroutine mumps_nblocal_roots_or_leaves(n, nbrorl, rorl_list, nrorl_loc, myid_nodes, slavef, keep, step, procnode_steps)
Definition tools_common.F:669
mumps_addi8toarray
subroutine mumps_addi8toarray(int_array, i8)
Definition tools_common.F:903
mumps_secfin
subroutine mumps_secfin(t)
Definition tools_common.F:277
mumps_init_pool_dist_na_bwd_l0
subroutine mumps_init_pool_dist_na_bwd_l0(n, myroot, myid_nodes, na, lna, keep, keep8, step, procnode_steps, ipool, lpool, l0_omp_mapping)
Definition tools_common.F:524
mumps_in_or_root_ssarbr
logical function mumps_in_or_root_ssarbr(procinfo_inode, k199)
Definition tools_common.F:214
mumps_get_perlu
subroutine mumps_get_perlu(keep12, icntl14, keep50, keep54, icntl6, icntl8)
Definition tools_common.F:808
mumps_init_pool_dist
subroutine mumps_init_pool_dist(n, leaf, myid_nodes, k199, na, lna, keep, keep8, step, procnode_steps, ipool, lpool)
Definition tools_common.F:587
mumps_sort_doubles_dec
subroutine mumps_sort_doubles_dec(n, val, id)
Definition tools_common.F:308
mumps_allreducei8
subroutine mumps_allreducei8(in, out, mpi_op, comm)
Definition tools_common.F:829
mumps_seti8toi4
subroutine mumps_seti8toi4(i8, i)
Definition tools_common.F:843
mumps_rootssarbr
logical function mumps_rootssarbr(procinfo_inode, k199)
Definition tools_common.F:189
mumps_parana_avail
logical function mumps_parana_avail(which)
Definition tools_common.F:943
mumps_storei8
subroutine mumps_storei8(i8, int_array)
Definition tools_common.F:871
mumps_init_pool_dist_bwd_l0
subroutine mumps_init_pool_dist_bwd_l0(n, nb_prun_roots, pruned_roots, myroot, myid_nodes, keep, keep8, step, procnode_steps, ipool, lpool, to_process)
Definition tools_common.F:470
mumps_sort_int8
subroutine mumps_sort_int8(n, val, id)
Definition tools_common.F:757
mumps_inssarbr
logical function mumps_inssarbr(procinfo_inode, k199)
Definition tools_common.F:201
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_get_pool_length
integer function mumps_get_pool_length(max_active_nodes, keep, keep8)
Definition tools_common.F:431
mumps_init_pool_dist_bwd
subroutine mumps_init_pool_dist_bwd(n, nb_prun_roots, pruned_roots, myroot, myid_nodes, keep, keep8, step, procnode_steps, ipool, lpool)
Definition tools_common.F:443
mumps_sort_int
subroutine mumps_sort_int(n, val, id)
Definition tools_common.F:709
mumps_subtri8toarray
subroutine mumps_subtri8toarray(int_array, i8)
Definition tools_common.F:913
mumps_init_pool_dist_na_bwdl0es
subroutine mumps_init_pool_dist_na_bwdl0es(n, myroot, myid_nodes, na, lna, keep, keep8, step, procnode_steps, ipool, lpool, l0_omp_mapping, to_process)
Definition tools_common.F:554
mumps_typenode
integer function mumps_typenode(procinfo_inode, k199)
Definition tools_common.F:90
mumps_procnode
integer function mumps_procnode(procinfo_inode, k199)
Definition tools_common.F:151
mumps_set_ierror
subroutine mumps_set_ierror(size8, ierror)
Definition tools_common.F:865
mumps_init_pool_dist_nona
subroutine mumps_init_pool_dist_nona(n, leaf, myid_nodes, lleaves, leaves, keep, keep8, step, procnode_steps, ipool, lpool)
Definition tools_common.F:614
mumps_init_pool_dist_na_bwd
subroutine mumps_init_pool_dist_na_bwd(n, myroot, myid_nodes, na, lna, keep, keep8, step, procnode_steps, ipool, lpool)
Definition tools_common.F:498
mumps_typesplit
integer function mumps_typesplit(procinfo_inode, k199)
Definition tools_common.F:171
mumps_seqana_avail
logical function mumps_seqana_avail(icntl7)
Definition tools_common.F:923
mumps_set_ssarbr_dad
subroutine mumps_set_ssarbr_dad(ssarbr, inode, dad, n, keep28, step, procnode_steps, k199)
Definition tools_common.F:230
mumps_reducei8
subroutine mumps_reducei8(in, out, mpi_op, root, comm)
Definition tools_common.F:815
mumps_typenode_rough
integer function mumps_typenode_rough(procinfo_inode, k199)
Definition tools_common.F:79
mumps_geti8
subroutine mumps_geti8(i8, int_array)
Definition tools_common.F:888
mumps_mem_centralize
subroutine mumps_mem_centralize(myid, comm, info, infog, irank)
Definition tools_common.F:400
mumps_compare_tab
logical function mumps_compare_tab(tab1, tab2, len1, len2)
Definition tools_common.F:692
mumps_abort
subroutine mumps_abort()
Definition tools_common.F:781
mumps_find_unit
subroutine mumps_find_unit(iunit)
Definition tools_common.F:15
mumps_abort_on_overflow
subroutine mumps_abort_on_overflow(i8, string)
Definition tools_common.F:854
mumps_secdeb
subroutine mumps_secdeb(t)
Definition tools_common.F:270
mumps_init_nroot_dist
subroutine mumps_init_nroot_dist(n, nbroot, nroot_loc, myid_nodes, slavef, na, lna, keep, step, procnode_steps)
Definition tools_common.F:639
mumps_i_am_candidate
logical function mumps_i_am_candidate(myid, slavef, inode, nmb_par2, istep_to_iniv2, k71, step, n, candidates, keep24)
Definition tools_common.F:253
mumps_encode_tpn_iproc
integer function mumps_encode_tpn_iproc(tpn, iproc, k199)
Definition tools_common.F:70
mumps_typeandprocnode
subroutine mumps_typeandprocnode(tpn, mumps_procnode, procinfo_inode, k199)
Definition tools_common.F:114
mumps_sort_doubles
subroutine mumps_sort_doubles(n, val, id)
Definition tools_common.F:284
mumps_sort_int_dec
subroutine mumps_sort_int_dec(n, val, id)
Definition tools_common.F:733
mumps_make1root
subroutine mumps_make1root(n, frere, fils, nfsiz, theroot)
Definition tools_common.F:32
mumps_npiv_critical_path
subroutine mumps_npiv_critical_path(n, nsteps, step, frere, fils, na, lna, ne, maxnpivtree)
Definition tools_common.F:1260