OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
fac_asm_build_sort_index_m.F
Go to the documentation of this file.
1C
2C This file is part of MUMPS 5.5.1, released
3C on Tue Jul 12 13:17:24 UTC 2022
4C
5C
6C Copyright 1991-2022 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria,
7C Mumps Technologies, University of Bordeaux.
8C
9C This version of MUMPS is provided to you free of charge. It is
10C released under the CeCILL-C license
11C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and
12C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html)
13C
14 MODULE mumps_build_sort_index_m
15 CONTAINS
16 SUBROUTINE mumps_build_sort_index(
17 & MYID, INODE, N, IOLDPS, HF, LP, LPOK,
18 & NFRONT, NFRONT_EFF, PERM, DAD,
19 & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS,
20 & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, IW, LIW,
21 & INTARR, LINTARR, ITLOC, FILS, FRERE_STEPS,
22 & SON_LEVEL2, NIV1, KEEP,KEEP8, IFLAG,
23 & ISON_IN_PLACE, PROCNODE_STEPS, SLAVEF,
24 & SONROWS_PER_ROW, LSONROWS_PER_ROW
25 & , MUMPS_TPS_ARR, L0_OMP_MAPPING
26 & )
27 USE mumps_tps_m
28 IMPLICIT NONE
29 INTEGER INODE, N, IOLDPS, HF, NFRONT, NASS1, LIW, NASS,
30 & NUMSTK, NUMORG, IFSON, MYID, LP
31 LOGICAL, intent(in) :: LPOK
32 INTEGER, intent(in) :: ISON_IN_PLACE
33 INTEGER KEEP(500)
34 INTEGER(8) KEEP8(150)
35 INTEGER(8), INTENT(IN) :: PTRAIW(N)
36 INTEGER STEP(N), PIMASTER(KEEP(28)), PTRIST(KEEP(28)),
37 & itloc(n+keep(253)), fils(n), frere_steps(keep(28)),
38 & perm(n)
39 INTEGER, TARGET :: IW(LIW)
40 INTEGER, INTENT(IN), TARGET :: IWPOSCB
41 INTEGER, INTENT(IN) :: IWPOS
42 INTEGER(8), INTENT(IN) :: LINTARR
43 INTEGER :: INTARR(LINTARR)
44 LOGICAL, intent(in) :: NIV1
45 INTEGER, intent(inout) :: IFLAG
46 LOGICAL, intent(out) :: SON_LEVEL2
47 INTEGER, intent(out) :: NFRONT_EFF
48 INTEGER, intent(in) :: DAD (KEEP(28))
49 INTEGER, intent(in) :: PROCNODE_STEPS(KEEP(28)), SLAVEF
50 TYPE (MUMPS_TPS_T), TARGET, OPTIONAL :: MUMPS_TPS_ARR(:)
51 INTEGER, intent(in), OPTIONAL :: L0_OMP_MAPPING(:)
52 INTEGER, intent(in) :: LSONROWS_PER_ROW
53 INTEGER, intent(out) :: SONROWS_PER_ROW(LSONROWS_PER_ROW)
54 INTEGER NELIM_SON_IN_PLACE
55 INTEGER NEWEL, IOLDP2, INEW, INEW1,
56 & in, ntotfs, ict11, nelim, npivs, nslson, ncols,
57 & itrans, j, jt1, ison, iell, lstk,
58 & nrows, hs, ip1, ip2, ibrot, iorg,
59 & i, k, iloc, newel_save, newel1_save,
60 & last_j_ass, jmin, min_perm
61 LOGICAL LEVEL1_SON
62 INTEGER :: K1, K2, K3, KK
63 INTEGER(8) :: J18, J28, JJ8, JDEBROW8
64 INTEGER INBPROCFILS_SON
65 INTEGER TYPESPLIT
66 INCLUDE 'mumps_headers.h'
67 INTEGER :: ITHREAD
68 INTEGER, POINTER :: SON_IWPOSCB
69 INTEGER, POINTER, DIMENSION(:) :: SON_IW
70 INTEGER, POINTER, DIMENSION(:) :: PTTRI, PTLAST
71 INTEGER :: LREQ, allocok
72 INTEGER, ALLOCATABLE, TARGET :: TMP_ALLOC_ARRAY(:)
73 INTEGER MUMPS_TYPESPLIT, MUMPS_TYPENODE
74 EXTERNAL mumps_typesplit, mumps_typenode
75 iw(ioldps+xxnbpr) = 0
76 typesplit = mumps_typesplit(procnode_steps(step(inode)),
77 & keep(199))
78 son_level2 = .false.
79 ioldp2 = ioldps + hf - 1
80 ict11 = ioldp2 + nfront
81 ntotfs = 0
82 nelim_son_in_place = 0
83 IF ( (typesplit.EQ.5).OR.(typesplit.EQ.6) ) THEN
84 k2 = pimaster(step(ifson))
85 lstk = iw(k2 +keep(ixsz))
86 nelim = iw(k2 + 1+keep(ixsz))
87 IF ( ison_in_place > 0 ) THEN
88 IF (ison_in_place.NE.ifson) THEN
89 write(6,*) myid, ':',
90 & ' Internal error 1 in MUMPS_BUILD_SORT_INDEX ',
91 & ' in place node is not the first son a interior split node '
92 CALL mumps_abort()
93 ENDIF
94 nelim_son_in_place = nelim
95 ENDIF
96 npivs = iw(k2 + 3+keep(ixsz))
97 IF (npivs.LT.0) npivs = 0
98 nslson = iw(k2 + 5+keep(ixsz))
99 IF( nslson.GT.0) son_level2 = .true.
100 level1_son = nslson.EQ.0
101 ncols = npivs + lstk
102 nrows = ncols
103 itrans = nrows
104 IF (niv1) THEN
105 write(6,*) myid, ':',
106 & ' Internal error 2 in MUMPS_BUILD_SORT_INDEX ',
107 & ' interior split node of type 1 '
108 CALL mumps_abort()
109 ENDIF
110 i= mumps_typenode(procnode_steps(step(ifson)),keep(199))
111 j= mumps_typesplit(procnode_steps(step(ifson)),
112 & keep(199))
113 IF (level1_son.or.j.LT.4) THEN
114 write(6,*) myid, ':',
115 & ' Internal error 3 in MUMPS_BUILD_SORT_INDEX ',
116 & ' son', ifson,
117 & ' of interior split node', inode, ' of type 1 ',
118 & ' NSLSON =', nslson, ' TYPE_SON=', i, 'TYPESPLIT_SON=', j
119 CALL mumps_abort()
120 ENDIF
121 son_iw => iw
122 son_iwposcb => iwposcb
123 IF (keep(400) .GT. 0 ) THEN
124 IF (present( l0_omp_mapping )) THEN
125 ithread=l0_omp_mapping(step(ifson))
126 IF (ithread .GT. 0) THEN
127 son_iw => mumps_tps_arr(ithread)%IW
128 son_iwposcb => mumps_tps_arr(ithread)%IWPOSCB
129 ENDIF
130 ENDIF
131 ENDIF
132 IF (k2 .GT. son_iwposcb) THEN
133 inbprocfils_son = k2 + xxnbpr
134 ELSE
135 inbprocfils_son = ptrist(step(ifson))+xxnbpr
136 ENDIF
137 iw(ioldps+xxnbpr)=nslson
138 son_iw(inbprocfils_son) = nslson
139 sonrows_per_row(1:nfront-nass1) = 1
140 IF ( k2.GT. iwposcb ) THEN
141 nrows = iw(k2 + 2+keep(ixsz))
142 itrans = npivs + nrows
143 ENDIF
144 hs = nslson + 6 + keep(ixsz)
145 k1 = k2 + hs + nrows + npivs
146 k2 = k1 + lstk - 1
147 k3 = k1 + nelim - 1
148 IF (nelim.GT.0) THEN
149 DO kk=k1,k3
150 ntotfs = ntotfs + 1
151 jt1 = iw(kk)
152 iw(ict11 + ntotfs) = jt1
153 iw(kk) = ntotfs
154 iw(ioldp2 + ntotfs) = iw(kk - itrans)
155 ENDDO
156 ENDIF
157 DO kk =k3+1, k3+numorg
158 ntotfs = ntotfs + 1
159 jt1 = iw(kk)
160 itloc(jt1) = ntotfs
161 iw(kk) = ntotfs
162 iw(ict11 + ntotfs) = jt1
163 iw(ioldp2 + ntotfs) = jt1
164 ENDDO
165 DO kk =k3+numorg+1, k2
166 ntotfs = ntotfs + 1
167 jt1 = iw(kk)
168 itloc(jt1) = ntotfs
169 iw(kk) = ntotfs
170 iw(ict11 + ntotfs) = jt1
171 iw(ioldp2 + ntotfs) = jt1
172 ENDDO
173 nfront_eff = ntotfs
174 ibrot = inode
175 DO iorg = 1, numorg
176 j18 = ptraiw(ibrot) + 2
177 jt1 = intarr(j18)
178 intarr(j18) = itloc(jt1)
179 ibrot = fils(ibrot)
180 j28 = j18 + intarr(j18 - 2) - intarr(j18 - 1)
181 j18 = j18 + 1
182 IF (j18 .LE. j28) THEN
183 DO jj8 = j18, j28
184 j = intarr(jj8)
185 intarr(jj8) = itloc(j)
186 ENDDO
187 ENDIF
188 ENDDO
189 k1 = ioldps+hf
190 DO kk=k1+nelim,k1+nfront_eff-1
191 itloc(iw(kk)) = 0
192 ENDDO
193 RETURN
194 ENDIF
195 lreq= 2*numstk+2
196 IF ((iwpos + lreq -1) .GT. iwposcb) THEN
197 ALLOCATE(tmp_alloc_array(lreq), stat=allocok)
198 IF (allocok .GT. 0) THEN
199 iflag = -13
200 GOTO 800
201 ENDIF
202 pttri => tmp_alloc_array(1:numstk+1)
203 ptlast => tmp_alloc_array(numstk+2:lreq)
204 ELSE
205 pttri => iw(iwpos:iwpos+numstk)
206 ptlast => iw(iwpos+numstk+1:iwpos+lreq-1)
207 ENDIF
208 nfront_eff = nass1
209 IF ( ison_in_place > 0 ) THEN
210 ison = ison_in_place
211 k2 = pimaster(step(ison))
212 lstk = iw(k2 +keep(ixsz))
213 nelim = iw(k2 + 1+keep(ixsz))
214 npivs = iw(k2 + 3+keep(ixsz))
215 IF (npivs.LT.0) npivs = 0
216 nslson = iw(k2 + 5+keep(ixsz))
217 ncols = npivs + lstk
218 nrows = ncols
219 itrans = nrows
220 IF ( k2 .GT. iwposcb ) THEN
221 nrows = iw(k2 + 2+keep(ixsz))
222 itrans = npivs + nrows
223 ENDIF
224 hs = nslson + 6 + keep(ixsz)
225 k1 = k2 + hs + nrows + npivs
226 k2 = k1 + lstk - 1
227 k3 = k1 + nelim - 1
228 DO kk = k1, k3
229 ntotfs = ntotfs + 1
230 jt1 = iw(kk)
231 iw(ict11 + ntotfs) = jt1
232 itloc(jt1) = ntotfs
233 iw(kk) = ntotfs
234 iw(ioldp2 + ntotfs) = iw(kk - itrans)
235 ENDDO
236 nelim_son_in_place = ntotfs
237 ENDIF
238 IF (.NOT. niv1) sonrows_per_row(1:nfront-nass1) = 0
239 in = inode
240 inew = ioldps + hf + ntotfs
241 inew1 = ntotfs + 1
242 jdebrow8 = ptraiw(inode)+3
243 pttri(numstk+1) = 0
244 ptlast(numstk+1) = 0 + intarr(jdebrow8-3) - 1
245 50 CONTINUE
246 j18 = ptraiw(in) + 2
247 jt1 = intarr(j18)
248 intarr(j18) = inew1
249 itloc(jt1) = inew1
250 iw(inew) = jt1
251 iw(inew+nfront) = jt1
252 inew = inew + 1
253 inew1 = inew1 + 1
254 in = fils(in)
255 IF (in .GT. 0) GOTO 50
256 ntotfs = ntotfs + numorg
257 IF (numstk .NE. 0) THEN
258 ison = ifson
259 DO iell = 1, numstk
260 k2 = pimaster(step(ison))
261 son_iw => iw
262 son_iwposcb => iwposcb
263 IF ( keep(400) .GT. 0 ) THEN
264 IF (present( l0_omp_mapping )) THEN
265 ithread=l0_omp_mapping(step(ison))
266 IF (ithread .GT. 0) THEN
267 son_iw => mumps_tps_arr(ithread)%IW
268 son_iwposcb => mumps_tps_arr(ithread)%IWPOSCB
269 ENDIF
270 ENDIF
271 ENDIF
272 lstk = son_iw(k2 +keep(ixsz))
273 nelim = son_iw(k2 + 1+keep(ixsz))
274 npivs = son_iw(k2 + 3+keep(ixsz))
275 IF (npivs.LT.0) npivs = 0
276 nslson = son_iw(k2 + 5+keep(ixsz))
277 IF( nslson.GT.0) son_level2 = .true.
278 level1_son = nslson.EQ.0
279 ncols = npivs + lstk
280 nrows = ncols
281 itrans = nrows
282 IF ( k2 .GT. son_iwposcb ) THEN
283 inbprocfils_son = k2+xxnbpr
284 ELSE
285 inbprocfils_son = ptrist(step(ison))+xxnbpr
286 ENDIF
287 IF (niv1) THEN
288 son_iw(inbprocfils_son) = nslson
289 iw(ioldps+xxnbpr) = iw(ioldps+xxnbpr) + nslson
290 ELSE
291 IF (level1_son) THEN
292 son_iw(inbprocfils_son) = 1
293 ELSE
294 son_iw(inbprocfils_son) = nslson
295 ENDIF
296 iw(ioldps+xxnbpr) = iw(ioldps+xxnbpr) +
297 & son_iw(inbprocfils_son)
298 ENDIF
299 IF (k2.GT.son_iwposcb) THEN
300 nrows = son_iw(k2 + 2+keep(ixsz))
301 itrans = npivs + nrows
302 ENDIF
303 hs = nslson + 6 + keep(ixsz)
304 k1 = k2 + hs + nrows + npivs
305 k2 = k1 + lstk - 1 - keep(253)
306 k3 = k1 + nelim - 1
307 IF (nelim .NE. 0 .AND. ison.NE.ison_in_place) THEN
308 DO kk = k1, k3
309 ntotfs = ntotfs + 1
310 jt1 = son_iw(kk)
311 iw(ict11 + ntotfs) = jt1
312 itloc(jt1) = ntotfs
313 son_iw(kk) = ntotfs
314 iw(ioldp2 + ntotfs) = son_iw(kk - itrans)
315 ENDDO
316 ENDIF
317 pttri(iell) = k2+1
318 ptlast(iell) = k2
319 k1 = k3 + 1
320 IF (nass1 .NE. nfront - keep(253)) THEN
321 DO kk = k1, k2
322 j = son_iw(kk)
323 IF (itloc(j) .EQ. 0) THEN
324 pttri(iell) = kk
325 EXIT
326 ENDIF
327 ENDDO
328 ELSE
329 DO kk = k1, k2
330 son_iw(kk) = itloc(son_iw(kk))
331 ENDDO
332 DO kk=k2+1, k2+keep(253)
333 son_iw(kk)=nfront-keep(253)+kk-k2
334 ENDDO
335 ENDIF
336 ison = frere_steps(step(ison))
337 ENDDO
338 ENDIF
339 IF (nfront-keep(253).EQ.nass1) GOTO 500
340 199 CONTINUE
341 IF ( pttri( numstk + 1 ) .LE. ptlast( numstk + 1 ) ) THEN
342 IF ( itloc( intarr( jdebrow8+pttri( numstk + 1 ) ) ) .NE. 0 ) THEN
343 pttri( numstk + 1 ) = pttri( numstk + 1 ) + 1
344 GOTO 199
345 END IF
346 END IF
347 min_perm = n + 1
348 IF (keep(400) .GT. 0) THEN
349 ison = ifson
350 ENDIF
351 DO iell = 1, numstk
352 son_iw => iw
353 IF ( keep(400) .GT. 0 ) THEN
354 IF (present( mumps_tps_arr )) THEN
355 ithread = l0_omp_mapping(step(ison))
356 IF (ithread .GT. 0) THEN
357 son_iw => mumps_tps_arr(ithread)%IW
358 ENDIF
359 ENDIF
360 ENDIF
361 iloc = pttri( iell )
362 IF ( iloc .LE. ptlast( iell ) ) THEN
363 IF ( perm( son_iw( iloc ) ) .LT. min_perm ) THEN
364 jmin = son_iw( iloc )
365 min_perm = perm( jmin )
366 END IF
367 END IF
368 IF (keep(400) .GT. 0) THEN
369 ison = frere_steps(step(ison))
370 ENDIF
371 END DO
372 iell = numstk + 1
373 iloc = pttri( iell )
374 IF ( iloc .LE. ptlast( iell ) ) THEN
375 IF ( perm( intarr( jdebrow8+iloc ) ) .LT. min_perm ) THEN
376 jmin = intarr( jdebrow8+iloc )
377 min_perm = perm( jmin )
378 END IF
379 END IF
380 newel = ioldp2 + nass1 + nfront
381 DO WHILE ( min_perm .NE. n + 1 )
382 newel = newel + 1
383 nfront_eff = nfront_eff + 1
384 iw( newel ) = jmin
385 itloc( jmin ) = nfront_eff
386 last_j_ass = jmin
387 min_perm = n + 1
388 IF (keep(400) .GT. 0) THEN
389 ison = ifson
390 ENDIF
391 DO iell = 1, numstk
392 son_iw => iw
393 IF (keep(400) .GT. 0) THEN
394 IF (present( mumps_tps_arr )) THEN
395 ithread=l0_omp_mapping(step(ison))
396 IF (ithread .GT. 0) THEN
397 son_iw => mumps_tps_arr(ithread)%IW
398 ENDIF
399 ENDIF
400 ENDIF
401 IF ( pttri( iell ) .LE. ptlast( iell ) ) THEN
402 IF ( son_iw( pttri( iell ) ) .eq. last_j_ass )
403 & pttri( iell ) = pttri( iell ) + 1
404 ENDIF
405 IF ( pttri( iell ) .LE. ptlast( iell ) ) THEN
406 IF ( perm(son_iw( pttri( iell )) ) .LT. min_perm ) THEN
407 jmin = son_iw( pttri( iell ) )
408 min_perm = perm( jmin )
409 END IF
410 END IF
411 IF (keep(400).GT.0) THEN
412 ison = frere_steps(step(ison))
413 ENDIF
414 END DO
415 iell = numstk + 1
416 145 CONTINUE
417 IF ( pttri( iell ) .LE. ptlast( iell ) ) THEN
418 IF ( intarr( jdebrow8+pttri( iell ) ) .eq. last_j_ass ) THEN
419 pttri( iell ) = pttri( iell ) + 1
420 GOTO 145
421 END IF
422 END IF
423 IF ( pttri( iell ) .LE. ptlast( iell ) ) THEN
424 IF (perm(intarr( jdebrow8+pttri(iell) )) .LT. min_perm) THEN
425 jmin = intarr( jdebrow8+pttri(iell) )
426 min_perm = perm( jmin )
427 END IF
428 END IF
429 END DO
430 newel_save = newel
431 newel1_save = nfront_eff
432 IF (newel1_save.LT.nfront - keep(253)) THEN
433 ibrot = inode
434 DO iorg = 1, numorg
435 j18 = ptraiw(ibrot) + 2
436 j28 = j18 + intarr(j18 - 2) - intarr(j18-1)
437 ibrot = fils( ibrot )
438 IF ( iorg.EQ. 1) THEN
439 IF ( keep(50).NE.0 ) cycle
440 j18 = j18 + 1 + intarr(j18-2)
441 ELSE
442 j18 = j18 + 1
443 ENDIF
444 DO jj8 = j18, j28
445 j = intarr( jj8 )
446 IF ( itloc( j ) .eq. 0 ) THEN
447 newel = newel + 1
448 nfront_eff = nfront_eff + 1
449 iw( newel ) = j
450 itloc( j ) = nfront_eff
451 END IF
452 ENDDO
453 ENDDO
454 IF ( (typesplit.EQ.4).AND.
455 & (nfront_eff.LT.nfront-keep(253)) ) THEN
456 ibrot = inode
457 DO WHILE
458 & (
459 & ( mumps_typesplit
460 & (procnode_steps(step(dad(step(ibrot)))),keep(199))
461 & .EQ.5
462 & )
463 & .OR.
464 & ( mumps_typesplit
465 & (procnode_steps(step(dad(step(ibrot)))),keep(199))
466 & .EQ.6
467 & )
468 & )
469 ibrot = dad(step(ibrot))
470 in = ibrot
471 DO WHILE (in.GT.0.AND.nfront_eff.LT.nfront-keep(253))
472 j18 = ptraiw(in) + 2
473 j28 = j18 + intarr(j18 - 2) - intarr(j18-1)
474 in = fils( in )
475 DO jj8 = j18, j28
476 j = intarr( jj8 )
477 IF ( itloc( j ) .eq. 0 ) THEN
478 newel = newel + 1
479 nfront_eff = nfront_eff + 1
480 iw( newel ) = j
481 itloc( j ) = nfront_eff
482 END IF
483 ENDDO
484 ENDDO
485 IF (nfront_eff.EQ.nfront-keep(253)) EXIT
486 ENDDO
487 IF (nfront_eff.NE.nfront-keep(253) .AND.
488 & .NOT. (keep(376).EQ.1 .AND. keep(79) .GE.1)) THEN
489 write(6,*) myid, ': INODE', inode, ' of type 4 ',
490 & ' not yet fully assembled ',
491 & ' NFRONT_EFF, NFRONT =', nfront_eff, nfront
492 CALL mumps_abort()
493 ENDIF
494 ENDIF
495 ENDIF
496 IF ( newel1_save .eq. nfront_eff ) THEN
497 DO kk=nass1+1, nfront_eff
498 iw( ioldp2+kk ) = iw( ict11+kk )
499 ENDDO
500 ELSE
501 CALL mumps_sort( n, perm,
502 & iw( newel_save + 1 ), nfront_eff - newel1_save )
503 CALL mumps_sorted_merge( n, nass1, perm, itloc,
504 & iw( newel_save + 1), nfront_eff - newel1_save,
505 & iw( ict11 + nass1 + 1 ), newel1_save - nass1,
506 & iw( ioldp2 + nass1 + 1 ), nfront_eff - nass1 )
507 DO kk = nass1+1, nfront_eff
508 iw(ict11 + kk) = iw(ioldp2+kk)
509 ENDDO
510 END IF
511 500 CONTINUE
512 IF ( keep(253).GT.0) THEN
513 ip1 = ioldps + hf + nfront_eff
514 ip2 = ioldps + hf + nfront + nfront_eff
515 DO i= 1, keep(253)
516 iw(ip1+i-1) = n+i
517 iw(ip2+i-1) = n+i
518 itloc(n+i) = nfront_eff + i
519 ENDDO
520 nfront_eff = nfront_eff + keep(253)
521 ENDIF
522 IF (nfront.GT.nfront_eff) THEN
523 ip1 = ioldps + nfront + hf
524 ip2 = ioldps + nfront_eff + hf
525 DO i=1, nfront_eff
526 iw(ip2+i-1)=iw(ip1+i-1)
527 ENDDO
528 ELSE IF (nfront .LT. nfront_eff) THEN
529 IF (lpok) THEN
530 WRITE(lp,*) " Error in MUMPS_BUILD_SORT_INDEX:",
531 & " matrix structure might have changed,",
532 & " analysis (JOB=1) should be performed again ",
533 & " NFRONTexpected, NFRONTeffective=", nfront, nfront_eff
534 ENDIF
535 iflag = -53
536 GOTO 800
537 ENDIF
538 IF ( numstk .NE. 0
539 & .AND. (nfront-keep(253).GT.nass1)
540 & ) THEN
541 ison = ifson
542 DO iell = 1, numstk
543 k2 = pimaster(step(ison))
544 son_iw => iw
545 son_iwposcb => iwposcb
546 IF (keep(400).GT.0) THEN
547 IF (present( mumps_tps_arr )) THEN
548 ithread=l0_omp_mapping(step(ison))
549 IF (ithread .GT. 0) THEN
550 son_iw => mumps_tps_arr(ithread)%IW
551 son_iwposcb => mumps_tps_arr(ithread)%IWPOSCB
552 ENDIF
553 ENDIF
554 ENDIF
555 lstk = son_iw(k2+keep(ixsz))
556 nelim = son_iw(k2 + 1 +keep(ixsz))
557 npivs = son_iw(k2 + 3 +keep(ixsz))
558 IF (npivs.LT.0) npivs = 0
559 nslson = son_iw(k2 + 5 +keep(ixsz))
560 level1_son = (nslson .EQ. 0)
561 ncols = npivs + lstk
562 nrows = ncols
563 IF (k2.GT.son_iwposcb) THEN
564 nrows = son_iw(k2 + 2+keep(ixsz))
565 ENDIF
566 hs = nslson + 6 +keep(ixsz)
567 k1 = k2 + hs + nrows + npivs
568 k2 = k1 + lstk - 1
569 k3 = k1 + nelim - 1
570 k1 = k3 + 1
571 IF (nfront-keep(253).GT.nass1) THEN
572 DO kk = k1, k2
573 j = son_iw(kk)
574 son_iw(kk) = itloc(j)
575 IF (niv1 .AND. nslson.EQ.0) THEN
576 ELSE
577 IF (son_iw(kk) .LE. nass1 .OR. niv1) THEN
578 ELSE
579 sonrows_per_row(son_iw(kk)-nass1) =
580 & sonrows_per_row(son_iw(kk)-nass1) + 1
581 ENDIF
582 ENDIF
583 ENDDO
584 ELSE
585 IF (.not. niv1) THEN
586 WRITE(*,*) "Internal error 1 in MUMPS_BUILD_SORT_INDEX"
587 CALL mumps_abort()
588 ENDIF
589 IF (.not.level1_son) THEN
590 ENDIF
591 ENDIF
592 ison = frere_steps(step(ison))
593 ENDDO
594 ENDIF
595 ibrot = inode
596 DO iorg = 1, numorg
597 j18 = ptraiw(ibrot) + 2
598 ibrot = fils(ibrot)
599 j28 = j18 + intarr(j18 - 2) - intarr(j18 - 1)
600 j18 = j18 + 1
601 DO jj8 = j18, j28
602 j = intarr(jj8)
603 intarr(jj8) = itloc(j)
604 ENDDO
605 ENDDO
606 k1 = ioldps + hf
607 k2 = k1 + nfront_eff -1
608 IF (keep(50).EQ.0) k2 = k2 + nelim_son_in_place
609 DO k = k1, k2
610 i = iw(k)
611 itloc(i) = 0
612 ENDDO
613 IF (keep(50).EQ.0) THEN
614 k1 = ioldps+hf+nfront_eff+nelim_son_in_place+numorg
615 k2 = k1 + nass -nelim_son_in_place - 1
616 DO k = k1, k2
617 i = iw(k)
618 itloc(i) = 0
619 ENDDO
620 ENDIF
621 800 CONTINUE
622 IF (allocated(tmp_alloc_array)) DEALLOCATE(tmp_alloc_array)
623 RETURN
624 END SUBROUTINE mumps_build_sort_index
625 END MODULE mumps_build_sort_index_m
626 SUBROUTINE mumps_sort( N, PERM, IW, LIW )
627 IMPLICIT NONE
628 INTEGER N, LIW
629 INTEGER PERM( N ), IW( LIW )
630 INTEGER I, SWAP
631 LOGICAL DONE
632 done = .false.
633 DO WHILE ( .NOT. done )
634 done = .true.
635 DO i = 1, liw - 1
636 IF ( perm( iw( i ) ) .GT. perm( iw( i + 1 ) ) ) THEN
637 done = .false.
638 swap = iw( i + 1 )
639 iw( i + 1 ) = iw( i )
640 iw( i ) = swap
641 END IF
642 END DO
643 END DO
644 RETURN
645 END SUBROUTINE mumps_sort
646 SUBROUTINE mumps_sorted_merge( N, NASS1, PERM, ITLOC,
647 & SMALL, LSMALL,
648 & LARGE, LLARGE,
649 & MERGE, LMERGE )
650 IMPLICIT NONE
651 INTEGER N, NASS1, LSMALL, LLARGE, LMERGE
652 INTEGER PERM( N ), ITLOC( N )
653 INTEGER SMALL(LSMALL), LARGE(LLARGE), MERGE(LMERGE)
654 INTEGER PSMALL, PLARGE, PMERGE, VSMALL, VLARGE, VMERGE
655 psmall = 1
656 plarge = 1
657 pmerge = 1
658 DO WHILE ( psmall .LE. lsmall .or. plarge.LE. llarge )
659 IF ( psmall .GT. lsmall ) THEN
660 vmerge = large( plarge )
661 plarge = plarge + 1
662 ELSE IF ( plarge .GT. llarge ) THEN
663 vmerge = small( psmall )
664 psmall = psmall + 1
665 ELSE
666 vsmall = small( psmall )
667 vlarge = large( plarge )
668 IF ( perm( vsmall ) .LT. perm( vlarge ) ) THEN
669 vmerge = vsmall
670 psmall = psmall + 1
671 ELSE
672 vmerge = vlarge
673 plarge = plarge + 1
674 END IF
675 END IF
676 merge( pmerge ) = vmerge
677 itloc( vmerge ) = pmerge + nass1
678 pmerge = pmerge + 1
679 END DO
680 pmerge = pmerge - 1
681 RETURN
682 END SUBROUTINE mumps_sorted_merge
mumps_abort
#define mumps_abort
Definition VE_Metis.h:25
mumps_sort
subroutine mumps_sort(n, perm, iw, liw)
Definition fac_asm_build_sort_index_m.F:627
mumps_sorted_merge
subroutine mumps_sorted_merge(n, nass1, perm, itloc, small, lsmall, large, llarge, merge, lmerge)
Definition fac_asm_build_sort_index_m.F:650
mumps_build_sort_index_m
Definition fac_asm_build_sort_index_m.F:14
mumps_build_sort_index_m::mumps_build_sort_index
subroutine mumps_build_sort_index(myid, inode, n, ioldps, hf, lp, lpok, nfront, nfront_eff, perm, dad, nass1, nass, numstk, numorg, iwposcb, iwpos, ifson, step, pimaster, ptrist, ptraiw, iw, liw, intarr, lintarr, itloc, fils, frere_steps, son_level2, niv1, keep, keep8, iflag, ison_in_place, procnode_steps, slavef, sonrows_per_row, lsonrows_per_row, mumps_tps_arr, l0_omp_mapping)
Definition fac_asm_build_sort_index_m.F:27
mumps_tps_m
Definition omp_tps_common_m.F:14