OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
fac_asm_build_sort_index_ELT_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_elt_m
15 CONTAINS
16 SUBROUTINE mumps_elt_build_sort(
17 & NUMELT, LIST_ELT,
18 & MYID, INODE, N, IOLDPS,
19 & HF, NFRONT, NFRONT_EFF, PERM,
20 & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS,
21 & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, NELT,
22 & IW, LIW,
23 & INTARR, LINTARR, ITLOC,
24 & FILS, FRERE_STEPS,
25 & KEEP, SON_LEVEL2, NIV1, IFLAG,
26 & DAD, PROCNODE_STEPS, SLAVEF,
27 & FRT_PTR, FRT_ELT, Pos_First_NUMORG,
28 & SONROWS_PER_ROW, LSONROWS_PER_ROW
29 & , MUMPS_TPS_ARR, L0_OMP_MAPPING
30 & )
31 USE mumps_tps_m
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
78 EXTERNAL mumps_typesplit, mumps_typenode
79 iw(ioldps+xxnbpr) = 0
80 pos_first_numorg = 1
81 typesplit = mumps_typesplit(procnode_steps(step(inode)),
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 '
104 CALL mumps_abort()
105 ENDIF
106 i= mumps_typenode(procnode_steps(step(ifson)),keep(199))
107 j= mumps_typesplit(procnode_steps(step(ifson)),
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
115 CALL mumps_abort()
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 & (
371 & ( mumps_typesplit
372 & (procnode_steps(step(dad(step(ibrot)))),keep(199))
373 & .EQ.5
374 & )
375 & .OR.
376 & ( mumps_typesplit
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
405 CALL mumps_abort()
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
414 CALL mumps_sort( n, perm,
415 & iw( newel_save + 1 ), nfront_eff - newel1_save )
416 CALL mumps_sorted_merge( n, nass1, perm, itloc,
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"
496 CALL mumps_abort()
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
522 END SUBROUTINE mumps_elt_build_sort
523 END MODULE mumps_build_sort_index_elt_m
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_elt_m
Definition fac_asm_build_sort_index_ELT_m.F:14
mumps_build_sort_index_elt_m::mumps_elt_build_sort
subroutine mumps_elt_build_sort(numelt, list_elt, myid, inode, n, ioldps, hf, nfront, nfront_eff, perm, nass1, nass, numstk, numorg, iwposcb, iwpos, ifson, step, pimaster, ptrist, ptraiw, nelt, iw, liw, intarr, lintarr, itloc, fils, frere_steps, keep, son_level2, niv1, iflag, dad, procnode_steps, slavef, frt_ptr, frt_elt, pos_first_numorg, sonrows_per_row, lsonrows_per_row, mumps_tps_arr, l0_omp_mapping)
Definition fac_asm_build_sort_index_ELT_m.F:31
mumps_tps_m
Definition omp_tps_common_m.F:14