32 IMPLICIT NONE
33 INTEGER NELT, INODE, N, IOLDPS, HF, NFRONT, NASS1, LIW, NASS,
34 & NUMSTK, NUMORG, IFSON, MYID, IFLAG,
35 & NUMELT
36 INTEGER KEEP(500)
37 INTEGER LIST_ELT(*)
38 INTEGER(8), INTENT(IN) :: PTRAIW(NELT+1)
39 INTEGER STEP(N), PIMASTER(KEEP(28)), PTRIST(KEEP(28)),
40 & ITLOC(N+KEEP(253)), FILS(N), FRERE_STEPS(KEEP(28)),
41 & PERM(N)
42 INTEGER, TARGET :: IW(LIW)
43 INTEGER, INTENT(IN), TARGET :: IWPOSCB
44 INTEGER, INTENT(IN) :: IWPOS
45 INTEGER(8), INTENT(IN) :: LINTARR
46 INTEGER :: INTARR(LINTARR)
47 LOGICAL, intent(in) :: NIV1
48 LOGICAL, intent(out) :: SON_LEVEL2
49 INTEGER, intent(out) :: NFRONT_EFF
50 INTEGER, intent(in) :: DAD (KEEP(28))
51 INTEGER, intent(in) :: PROCNODE_STEPS(KEEP(28)), SLAVEF
52 TYPE (MUMPS_TPS_T), TARGET, OPTIONAL :: MUMPS_TPS_ARR(:)
53 INTEGER, intent(in), OPTIONAL :: L0_OMP_MAPPING(:)
54 INTEGER, intent(in) :: FRT_PTR(N+1), FRT_ELT(NELT)
55 INTEGER, intent(out) :: Pos_First_NUMORG
56 INTEGER, intent(in) :: LSONROWS_PER_ROW
57 INTEGER, intent(out) :: SONROWS_PER_ROW(LSONROWS_PER_ROW)
58 INTEGER NEWEL, IOLDP2, INEW, INEW1,
59 & IN, NTOTFS, ICT11, NELIM, NPIVS, NSLSON, NCOLS,
60 & ITRANS, J, JT1, ISON, IELL, LSTK,
61 & NROWS, HS, IP1, IP2, IBROT,
62 & I, ILOC, NEWEL_SAVE, NEWEL1_SAVE,
63 & LAST_J_ASS, JMIN, MIN_PERM
64 INTEGER :: K, K1, K2, K3, KK
65 INTEGER(8) :: JJ8, J18, J28
66 LOGICAL LEVEL1_SON
67 INTEGER INBPROCFILS_SON
68 INTEGER TYPESPLIT
69 INTEGER ELTI, NUMELT_IBROT
70 include 'mumps_headers.h'
71 INTEGER :: ITHREAD
72 INTEGER, POINTER :: SON_IWPOSCB
73 INTEGER, POINTER, DIMENSION(:) :: SON_IW
74 INTEGER, POINTER, DIMENSION(:) :: PTTRI, PTLAST
75 INTEGER :: LREQ, allocok
76 INTEGER, ALLOCATABLE, TARGET :: TMP_ALLOC_ARRAY(:)
77 INTEGER MUMPS_TYPESPLIT, MUMPS_TYPENODE
79 iw(ioldps+xxnbpr) = 0
80 pos_first_numorg = 1
82 & keep(199))
83 son_level2 = .false.
84 ioldp2 = ioldps + hf - 1
85 ict11 = ioldp2 + nfront
86 nfront_eff = nass1
87 ntotfs = 0
88 IF ( (typesplit.EQ.5).OR.(typesplit.EQ.6) ) THEN
89 k2 = pimaster(step(ifson))
90 lstk = iw(k2 +keep(ixsz))
91 nelim = iw(k2 + 1+keep(ixsz))
92 npivs = iw(k2 + 3+keep(ixsz))
93 IF (npivs.LT.0) npivs = 0
94 nslson = iw(k2 + 5+keep(ixsz))
95 IF( nslson.GT.0) son_level2 = .true.
96 level1_son = nslson.EQ.0
97 ncols = npivs + lstk
98 nrows = ncols
99 itrans = nrows
100 IF (niv1) THEN
101 write(6,*) myid, ':',
102 & ' Internal error 2 in MUMPS_ELT_BUILD_SORT ',
103 & ' interior split node of type 1 '
105 ENDIF
108 & keep(199))
109 IF (level1_son.or.j.LT.4) THEN
110 write(6,*) myid, ':',
111 & ' Internal error 3 in MUMPS_ELT_BUILD_SORT ',
112 & ' son', ifson,
113 & ' of interior split node', inode, ' of type 1 ',
114 & ' NSLSON =', nslson, ' TYPE_SON=', i, 'TYPESPLIT_SON=', j
116 ENDIF
117 son_iw => iw
118 son_iwposcb => iwposcb
119 IF (keep(400) .GT. 0 ) THEN
120 IF (present( l0_omp_mapping )) THEN
121 ithread=l0_omp_mapping(step(ifson))
122 IF (ithread .GT. 0) THEN
123 son_iw => mumps_tps_arr(ithread)%IW
124 son_iwposcb => mumps_tps_arr(ithread)%IWPOSCB
125 ENDIF
126 ENDIF
127 ENDIF
128 IF (k2 .GT. son_iwposcb) THEN
129 inbprocfils_son = k2 + xxnbpr
130 ELSE
131 inbprocfils_son = ptrist(step(ifson))+xxnbpr
132 ENDIF
133 iw(ioldps+xxnbpr)=nslson
134 son_iw(inbprocfils_son) = nslson
135 sonrows_per_row(1:nfront-nass1) = 1
136 IF ( k2.GT. iwposcb ) THEN
137 nrows = iw(k2 + 2+keep(ixsz))
138 itrans = npivs + nrows
139 ENDIF
140 hs = nslson + 6 + keep(ixsz)
141 k1 = k2 + hs + nrows + npivs
142 k2 = k1 + lstk - 1
143 k3 = k1 + nelim - 1
144 IF (nelim.GT.0) THEN
145 DO kk=k1,k3
146 ntotfs = ntotfs + 1
147 jt1 = iw(kk)
148 iw(ict11 + ntotfs) = jt1
149 iw(kk) = ntotfs
150 iw(ioldp2 + ntotfs) = iw(kk - itrans)
151 ENDDO
152 ENDIF
153 DO kk =k3+1, k2
154 ntotfs = ntotfs + 1
155 jt1 = iw(kk)
156 itloc(jt1) = ntotfs
157 iw(kk) = ntotfs
158 iw(ict11 + ntotfs) = jt1
159 iw(ioldp2 + ntotfs) = jt1
160 ENDDO
161 nfront_eff = ntotfs
162 DO iell=1,numelt
163 elti = list_elt(iell)
164 j18= ptraiw(elti)
165 j28= ptraiw(elti+1)-1
166 DO jj8=j18,j28
167 j = intarr(jj8)
168 intarr(jj8) = itloc(j)
169 ENDDO
170 ENDDO
171 pos_first_numorg = itloc(inode)
172 k1 = ioldps+hf
173 DO kk=k1+nelim,k1+nfront_eff-1
174 itloc(iw(kk)) = 0
175 ENDDO
176 RETURN
177 ENDIF
178 lreq= 2*numstk
179 IF ((iwpos + lreq -1) .GT. iwposcb) THEN
180 ALLOCATE(tmp_alloc_array(lreq), stat=allocok)
181 IF (allocok .GT. 0) THEN
182 iflag = -13
183 GOTO 800
184 ENDIF
185 pttri => tmp_alloc_array(1:numstk)
186 ptlast => tmp_alloc_array(numstk+1:lreq)
187 ELSE
188 pttri => iw(iwpos:iwpos+numstk-1)
189 ptlast => iw(iwpos+numstk:iwpos+lreq)
190 ENDIF
191 IF (.NOT. niv1) sonrows_per_row(1:nfront-nass1) = 0
192 in = inode
193 inew = ioldps + hf
194 inew1 = 1
195 DO WHILE (in.GT.0)
196 itloc(in) = inew1
197 iw(inew) = in
198 iw(inew+nfront) = in
199 inew1 = inew1 + 1
200 inew = inew + 1
201 in = fils(in)
202 END DO
203 ntotfs = numorg
204 IF (numstk .NE. 0) THEN
205 ison = ifson
206 DO iell = 1, numstk
207 k2 = pimaster(step(ison))
208 son_iw => iw
209 son_iwposcb => iwposcb
210 IF ( keep(400) .GT. 0 ) THEN
211 IF (present( l0_omp_mapping )) THEN
212 ithread=l0_omp_mapping(step(ison))
213 IF (ithread .GT. 0) THEN
214 son_iw => mumps_tps_arr(ithread)%IW
215 son_iwposcb => mumps_tps_arr(ithread)%IWPOSCB
216 ENDIF
217 ENDIF
218 ENDIF
219 lstk = son_iw(k2 +keep(ixsz))
220 nelim = son_iw(k2 + 1+keep(ixsz))
221 npivs = son_iw(k2 + 3+keep(ixsz))
222 IF (npivs.LT.0) npivs = 0
223 nslson = son_iw(k2 + 5+keep(ixsz))
224 IF( nslson.GT.0) son_level2 = .true.
225 level1_son = nslson.EQ.0
226 ncols = npivs + lstk
227 nrows = ncols
228 itrans = nrows
229 IF (k2 .GT. son_iwposcb) THEN
230 inbprocfils_son = k2+xxnbpr
231 ELSE
232 inbprocfils_son = ptrist(step(ison))+xxnbpr
233 ENDIF
234 IF (niv1) THEN
235 son_iw(inbprocfils_son) = nslson
236 iw(ioldps+xxnbpr) = iw(ioldps+xxnbpr) + nslson
237 ELSE
238 IF (level1_son) THEN
239 son_iw(inbprocfils_son) = 1
240 ELSE
241 son_iw(inbprocfils_son) = nslson
242 ENDIF
243 iw(ioldps+xxnbpr) = iw(ioldps+xxnbpr) +
244 & son_iw(inbprocfils_son)
245 ENDIF
246 IF (k2.GT.son_iwposcb) THEN
247 nrows = son_iw(k2 + 2+keep(ixsz))
248 itrans = npivs + nrows
249 ENDIF
250 hs = nslson + 6 + keep(ixsz)
251 k1 = k2 + hs + nrows + npivs
252 k2 = k1 + lstk - 1 - keep(253)
253 k3 = k1 + nelim - 1
254 IF (nelim .NE. 0) THEN
255 DO kk = k1, k3
256 ntotfs = ntotfs + 1
257 jt1 = son_iw(kk)
258 iw(ict11 + ntotfs) = jt1
259 itloc(jt1) = ntotfs
260 son_iw(kk) = ntotfs
261 iw(ioldp2 + ntotfs) = son_iw(kk - itrans)
262 ENDDO
263 ENDIF
264 pttri(iell) = k2+1
265 ptlast(iell) = k2
266 k1 = k3 + 1
267 IF (nass1 .NE. nfront - keep(253)) THEN
268 DO kk = k1, k2
269 j = son_iw(kk)
270 IF (itloc(j) .EQ. 0) THEN
271 pttri(iell) = kk
272 EXIT
273 ENDIF
274 ENDDO
275 ELSE
276 DO kk = k1, k2
277 son_iw(kk) = itloc(son_iw(kk))
278 ENDDO
279 DO kk=k2+1, k2+keep(253)
280 son_iw(kk)=nfront-keep(253)+kk-k2
281 ENDDO
282 ENDIF
283 ison = frere_steps(step(ison))
284 ENDDO
285 ENDIF
286 IF (nfront-keep(253).EQ.nass1) GOTO 500
287 min_perm = n + 1
288 IF (keep(400) .GT. 0) THEN
289 ison = ifson
290 ENDIF
291 jmin = -1
292 DO iell = 1, numstk
293 son_iw => iw
294 IF ( keep(400) .GT. 0 ) THEN
295 IF (present( mumps_tps_arr )) THEN
296 ithread = l0_omp_mapping(step(ison))
297 IF (ithread .GT. 0) THEN
298 son_iw => mumps_tps_arr(ithread)%IW
299 ENDIF
300 ENDIF
301 ENDIF
302 iloc = pttri( iell )
303 IF ( iloc .LE. ptlast( iell ) ) THEN
304 IF ( perm( son_iw( iloc ) ) .LT. min_perm ) THEN
305 jmin = son_iw( iloc )
306 min_perm = perm( jmin )
307 END IF
308 END IF
309 IF (keep(400) .GT. 0) THEN
310 ison = frere_steps(step(ison))
311 ENDIF
312 END DO
313 newel = ioldp2 + nass1 + nfront
314 DO WHILE ( min_perm .NE. n + 1 )
315 newel = newel + 1
316 nfront_eff = nfront_eff + 1
317 iw( newel ) = jmin
318 itloc( jmin ) = nfront_eff
319 last_j_ass = jmin
320 min_perm = n + 1
321 IF (keep(400) .GT. 0) THEN
322 ison = ifson
323 ENDIF
324 DO iell = 1, numstk
325 son_iw => iw
326 IF (keep(400) .GT. 0) THEN
327 IF (present( mumps_tps_arr )) THEN
328 ithread=l0_omp_mapping(step(ison))
329 IF (ithread .GT. 0) THEN
330 son_iw => mumps_tps_arr(ithread)%IW
331 ENDIF
332 ENDIF
333 ENDIF
334 IF ( pttri( iell ) .LE. ptlast( iell ) ) THEN
335 IF ( son_iw( pttri( iell ) ) .eq. last_j_ass )
336 & pttri( iell ) = pttri( iell ) + 1
337 ENDIF
338 IF ( pttri( iell ) .LE. ptlast( iell ) ) THEN
339 IF ( perm(son_iw( pttri( iell )) ) .LT. min_perm ) THEN
340 jmin = son_iw( pttri( iell ) )
341 min_perm = perm( jmin )
342 END IF
343 END IF
344 IF (keep(400).GT.0) THEN
345 ison = frere_steps(step(ison))
346 ENDIF
347 END DO
348 END DO
349 newel_save = newel
350 newel1_save = nfront_eff
351 IF (newel1_save.LT.nfront - keep(253)) THEN
352 DO iell = 1,numelt
353 elti = list_elt(iell)
354 j18= ptraiw(elti)
355 j28= ptraiw(elti+1)-1_8
356 DO jj8=j18,j28
357 j = intarr( jj8 )
358 IF ( itloc( j ) .eq. 0 ) THEN
359 newel = newel + 1
360 nfront_eff = nfront_eff + 1
361 iw( newel ) = j
362 itloc( j ) = nfront_eff
363 END IF
364 ENDDO
365 ENDDO
366 IF ( (typesplit.EQ.4).AND.
367 & (nfront_eff.LT.nfront-keep(253)) ) THEN
368 ibrot = inode
369 DO WHILE
370 & (
372 & (procnode_steps(step(dad(step(ibrot)))),keep(199))
373 & .EQ.5
374 & )
375 & .OR.
377 & (procnode_steps(step(dad(step(ibrot)))),keep(199))
378 & .EQ.6
379 & )
380 & )
381 ibrot = dad(step(ibrot))
382 numelt_ibrot = frt_ptr(ibrot+1) - frt_ptr(ibrot)
383 IF (numelt_ibrot.EQ.0) cycle
384 DO iell = frt_ptr(ibrot), frt_ptr(ibrot+1)
385 elti = frt_elt(iell)
386 j18= ptraiw(elti)
387 j28= ptraiw(elti+1)-1
388 DO jj8 = j18, j28
389 j = intarr( jj8 )
390 IF ( itloc( j ) .eq. 0 ) THEN
391 newel = newel + 1
392 nfront_eff = nfront_eff + 1
393 iw( newel ) = j
394 itloc( j ) = nfront_eff
395 END IF
396 ENDDO
397 ENDDO
398 IF (nfront_eff.EQ.nfront-keep(253)) EXIT
399 ENDDO
400 IF (nfront_eff.NE.nfront-keep(253) .AND.
401 & .NOT. (keep(376).EQ.1 .AND. keep(79) .GE.1)) THEN
402 write(6,*) myid, ': INODE', inode, ' of type 4 ',
403 & ' not yet fully assembled ',
404 & ' NFRONT_EFF, NFRONT =', nfront_eff, nfront
406 ENDIF
407 ENDIF
408 ENDIF
409 IF ( newel1_save .eq. nfront_eff ) THEN
410 DO kk=nass1+1, nfront_eff
411 iw( ioldp2+kk ) = iw( ict11+kk )
412 ENDDO
413 ELSE
415 & iw( newel_save + 1 ), nfront_eff - newel1_save )
417 & iw( newel_save + 1), nfront_eff - newel1_save,
418 & iw( ict11 + nass1 + 1 ), newel1_save - nass1,
419 & iw( ioldp2 + nass1 + 1 ), nfront_eff - nass1 )
420 DO kk = nass1+1, nfront_eff
421 iw(ict11 + kk) = iw(ioldp2+kk)
422 ENDDO
423 END IF
424 500 CONTINUE
425 IF ( keep(253).GT.0) THEN
426 ip1 = ioldps + hf + nfront_eff
427 ip2 = ioldps + hf + nfront + nfront_eff
428 DO i= 1, keep(253)
429 iw(ip1+i-1) = n+i
430 iw(ip2+i-1) = n+i
431 itloc(n+i) = nfront_eff + i
432 ENDDO
433 nfront_eff = nfront_eff + keep(253)
434 ENDIF
435 IF (nfront.GT.nfront_eff) THEN
436 ip1 = ioldps + nfront + hf
437 ip2 = ioldps + nfront_eff + hf
438 DO i=1, nfront_eff
439 iw(ip2+i-1)=iw(ip1+i-1)
440 ENDDO
441 ELSE IF (nfront .LT. nfront_eff) THEN
442 WRITE(*,*) "Internal error in MUMPS_ELT_BUILD_SORT",
443 & nfront, nfront_eff
444 iflag = -53
445 GOTO 800
446 ENDIF
447 IF ( (numstk .NE.0)
448 & .AND. (nfront-keep(253).GT.nass1 )
449 & ) THEN
450 ison = ifson
451 DO iell = 1, numstk
452 k2 = pimaster(step(ison))
453 son_iw => iw
454 son_iwposcb => iwposcb
455 IF (keep(400).GT.0) THEN
456 IF (present( mumps_tps_arr )) THEN
457 ithread=l0_omp_mapping(step(ison))
458 IF (ithread .GT. 0) THEN
459 son_iw => mumps_tps_arr(ithread)%IW
460 son_iwposcb => mumps_tps_arr(ithread)%IWPOSCB
461 ENDIF
462 ENDIF
463 ENDIF
464 lstk = son_iw(k2+keep(ixsz))
465 nelim = son_iw(k2 + 1 +keep(ixsz))
466 npivs = son_iw(k2 + 3 +keep(ixsz))
467 IF (npivs.LT.0) npivs = 0
468 nslson = son_iw(k2 + 5 +keep(ixsz))
469 level1_son = (nslson .EQ. 0)
470 ncols = npivs + lstk
471 nrows = ncols
472 IF (k2.GT.son_iwposcb) THEN
473 nrows = son_iw(k2 + 2+keep(ixsz))
474 ENDIF
475 hs = nslson + 6 +keep(ixsz)
476 k1 = k2 + hs + nrows + npivs
477 k2 = k1 + lstk - 1
478 k3 = k1 + nelim - 1
479 k1 = k3 + 1
480 IF (nfront-keep(253).GT.nass1) THEN
481 DO kk = k1, k2
482 j = son_iw(kk)
483 son_iw(kk) = itloc(j)
484 IF (niv1 .AND. nslson.EQ.0) THEN
485 ELSE
486 IF (son_iw(kk) .LE. nass1 .OR. niv1) THEN
487 ELSE
488 sonrows_per_row(son_iw(kk)-nass1) =
489 & sonrows_per_row(son_iw(kk)-nass1) + 1
490 ENDIF
491 ENDIF
492 ENDDO
493 ELSE
494 IF (.not. niv1) THEN
495 WRITE(*,*) "Internal error 1 in MUMPS_ELT_BUILD_SORT"
497 ENDIF
498 IF (.not.level1_son) THEN
499 ENDIF
500 ENDIF
501 ison = frere_steps(step(ison))
502 ENDDO
503 ENDIF
504 DO iell=1,numelt
505 elti = list_elt(iell)
506 j18 = ptraiw(elti)
507 j28 = ptraiw(elti+1)-1
508 DO jj8=j18,j28
509 j = intarr(jj8)
510 intarr(jj8) = itloc(j)
511 ENDDO
512 ENDDO
513 k1 = ioldps + hf + numorg
514 k2 = k1 + nfront_eff - 1 + nass
515 DO k = k1, k2
516 i = iw(k)
517 itloc(i) = 0
518 ENDDO
519 800 CONTINUE
520 IF (allocated(tmp_alloc_array)) DEALLOCATE(tmp_alloc_array)
521 RETURN
subroutine mumps_sort(n, perm, iw, liw)
subroutine mumps_sorted_merge(n, nass1, perm, itloc, small, lsmall, large, llarge, merge, lmerge)
1.15.0