OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
dana_LDLT_preprocess.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 dmumps_set_constraints(
15 & N,PIV,FRERE,FILS,NFSIZ,IKEEP,
16 & NCST,KEEP,KEEP8, ROWSCA
17 & )
18 USE dmumps_struc_def
19 IMPLICIT NONE
20 INTEGER, INTENT(IN) :: N
21 INTEGER, INTENT(OUT) :: NCST
22 INTEGER :: PIV(N),FRERE(N),FILS(N),NFSIZ(N),IKEEP(N)
23 INTEGER :: KEEP(500)
24 INTEGER(8) :: KEEP8(150)
25 DOUBLE PRECISION :: ROWSCA(N)
26 INTEGER I,P11,P1,P2,K1,K2,NLOCKED
27 LOGICAL V1,V2
28 ncst = 0
29 nlocked = 0
30 p11 = keep(93)
31 DO i=keep(93)-1,1,-2
32 p1 = piv(i)
33 p2 = piv(i+1)
34 k1 = ikeep(p1)
35 IF (k1 .NE. 0) THEN
36 v1 = (k1+2*exponent(rowsca(p1)) .GE. -3)
37 ELSE
38 v1 = .false.
39 ENDIF
40 k2 = ikeep(p2)
41 IF (k2 .NE. 0) THEN
42 v2 = (k2+exponent(rowsca(p2)**2) .GE. -3)
43 ELSE
44 v2 = .false.
45 ENDIF
46 IF(v1 .AND. v2) THEN
47 piv(p11) = p1
48 p11 = p11 - 1
49 piv(p11) = p2
50 p11 = p11 - 1
51 ELSE IF(v1) THEN
52 ncst = ncst+1
53 frere(ncst) = p1
54 ncst = ncst+1
55 frere(ncst) = p2
56 ELSE IF(v2) THEN
57 ncst = ncst+1
58 frere(ncst) = p2
59 ncst = ncst+1
60 frere(ncst) = p1
61 ELSE
62 nlocked = nlocked + 1
63 fils(nlocked) = p1
64 nlocked = nlocked + 1
65 fils(nlocked) = p2
66 ENDIF
67 ENDDO
68 DO i=1,nlocked
69 piv(i) = fils(i)
70 ENDDO
71 keep(94) = keep(94) + keep(93) - nlocked
72 keep(93) = nlocked
73 DO i=1,ncst
74 nlocked = nlocked + 1
75 piv(nlocked) = frere(i)
76 ENDDO
77 DO i=1,keep(93)/2
78 nfsiz(i) = 0
79 ENDDO
80 DO i=(keep(93)/2)+1,(keep(93)/2)+ncst,2
81 nfsiz(i) = i+1
82 nfsiz(i+1) = -1
83 ENDDO
84 DO i=(keep(93)/2)+ncst+1,(keep(93)/2)+keep(94)
85 nfsiz(i) = 0
86 ENDDO
87 END SUBROUTINE dmumps_set_constraints
88 SUBROUTINE dmumps_expand_permutation(N,NCMP,N11,N22,PIV,
89 & INVPERM,PERM)
90 IMPLICIT NONE
91 INTEGER N11,N22,N,NCMP
92 INTEGER, intent(in) :: PIV(N),PERM(N)
93 INTEGER, intent (out):: INVPERM(N)
94 INTEGER CMP_POS,EXP_POS,I,J,N2,K
95 n2 = n22/2
96 exp_pos = 1
97 DO cmp_pos=1,ncmp
98 j = perm(cmp_pos)
99 IF(j .LE. n2) THEN
100 k = 2*j-1
101 i = piv(k)
102 invperm(i) = exp_pos
103 exp_pos = exp_pos+1
104 k = k+1
105 i = piv(k)
106 invperm(i) = exp_pos
107 exp_pos = exp_pos+1
108 ELSE
109 k = n2 + j
110 i = piv(k)
111 invperm(i) = exp_pos
112 exp_pos = exp_pos+1
113 ENDIF
114 ENDDO
115 DO k=n22+n11+1,n
116 i = piv(k)
117 invperm(i) = exp_pos
118 exp_pos = exp_pos+1
119 ENDDO
120 RETURN
121 END SUBROUTINE dmumps_expand_permutation
122 SUBROUTINE dmumps_ldlt_compress(
123 & N,NZ, IRN, ICN, PIV,
124 & NCMP, IW, LW, IPE, LEN, IQ,
125 & FLAG, ICMP, IWFR,
126 & IERROR, KEEP,KEEP8, ICNTL,INPLACE64_GRAPH_COPY)
127 IMPLICIT NONE
128 INTEGER, intent(in) :: N
129 INTEGER(8), intent(in) :: NZ, LW
130 INTEGER, intent(in) :: IRN(NZ), ICN(NZ), PIV(N)
131 INTEGER, intent(in) :: ICNTL(60)
132 INTEGER, intent(in) :: KEEP(500)
133 INTEGER(8), intent(in) :: KEEP8(150)
134 INTEGER, intent(out) :: NCMP, IERROR
135 INTEGER(8), intent(out) :: IWFR, IPE(N+1)
136 INTEGER, intent(out) :: IW(LW)
137 INTEGER, intent(out) :: LEN(N)
138 INTEGER(8), intent(out) :: IQ(N)
139 INTEGER, intent(out) :: FLAG(N), ICMP(N)
140 LOGICAL, intent(inout) :: INPLACE64_GRAPH_COPY
141 INTEGER :: MP, N11, N22
142 INTEGER :: I, J, N1, K
143 INTEGER(8) :: NDUP, L, K8, K1, K2, LAST
144 mp = icntl(2)
145 ierror = 0
146 n22 = keep(93)
147 n11 = keep(94)
148 ncmp = n22/2 + n11
149 DO i=1,ncmp
150 ipe(i) = 0
151 ENDDO
152 k = 1
153 DO i=1,n22/2
154 j = piv(k)
155 icmp(j) = i
156 k = k + 1
157 j = piv(k)
158 icmp(j) = i
159 k = k + 1
160 ENDDO
161 k = n22/2 + 1
162 DO i=n22+1,n22+n11
163 j = piv(i)
164 icmp(j) = k
165 k = k + 1
166 ENDDO
167 DO i=n11+n22+1,n
168 j = piv(i)
169 icmp(j) = 0
170 ENDDO
171 DO k8=1,nz
172 i = irn(k8)
173 j = icn(k8)
174 IF ((i.GT.n).OR.(j.GT.n).OR.(i.LT.1)
175 & .OR.(j.LT.1)) THEN
176 ierror = ierror + 1
177 ELSE
178 i = icmp(i)
179 j = icmp(j)
180 IF ((i.NE.0).AND.(j.NE.0).AND.(i.NE.j)) THEN
181 ipe(i) = ipe(i) + 1_8
182 ipe(j) = ipe(j) + 1_8
183 ENDIF
184 ENDIF
185 ENDDO
186 iq(1) = 1_8
187 n1 = ncmp - 1
188 IF (n1.GT.0) THEN
189 DO i=1,n1
190 iq(i+1) = ipe(i) + iq(i)
191 ENDDO
192 ENDIF
193 last = max(ipe(ncmp)+iq(ncmp)-1_8,iq(ncmp))
194 DO i = 1,ncmp
195 flag(i) = 0
196 ipe(i) = iq(i)
197 ENDDO
198 iw(1:last) = 0
199 iwfr = last + 1_8
200 DO k8=1,nz
201 i = irn(k8)
202 j = icn(k8)
203 IF ((i.GT.n).OR.(j.GT.n).OR.(i.LT.1)
204 & .OR.(j.LT.1)) cycle
205 i = icmp(i)
206 j = icmp(j)
207 IF (i.NE.j) THEN
208 IF (i.LT.j) THEN
209 IF ((i.GE.1).AND.(j.LE.n)) THEN
210 iw(iq(i)) = -j
211 iq(i) = iq(i) + 1_8
212 ENDIF
213 ELSE
214 IF ((j.GE.1).AND.(i.LE.n)) THEN
215 iw(iq(j)) = -i
216 iq(j) = iq(j) + 1_8
217 ENDIF
218 ENDIF
219 ENDIF
220 ENDDO
221 ndup = 0_8
222 DO i=1,ncmp
223 k1 = ipe(i)
224 k2 = iq(i) -1_8
225 IF (k1.GT.k2) THEN
226 len(i) = 0
227 ELSE
228 DO k8=k1,k2
229 j = -iw(k8)
230 IF (j.LE.0) GO TO 250
231 l = iq(j)
232 iq(j) = l + 1_8
233 IF (flag(j).EQ.i) THEN
234 ndup = ndup + 1_8
235 iw(l) = 0
236 iw(k8) = 0
237 ELSE
238 iw(l) = i
239 iw(k8) = j
240 flag(j) = i
241 ENDIF
242 ENDDO
243 250 len(i) = int(iq(i) - ipe(i))
244 ENDIF
245 ENDDO
246 IF (ndup.NE.0_8) THEN
247 iwfr = 1_8
248 DO i=1,ncmp
249 k1 = ipe(i)
250 IF (len(i).EQ.0) THEN
251 ipe(i) = iwfr
252 cycle
253 ENDIF
254 k2 = k1 + len(i) - 1
255 l = iwfr
256 ipe(i) = iwfr
257 DO k8=k1,k2
258 IF (iw(k8).NE.0) THEN
259 iw(iwfr) = iw(k8)
260 iwfr = iwfr + 1_8
261 ENDIF
262 ENDDO
263 len(i) = int(iwfr - l)
264 ENDDO
265 ENDIF
266 ipe(ncmp+1) = ipe(ncmp) + int(len(ncmp),8)
267 iwfr = ipe(ncmp+1)
268 inplace64_graph_copy = (lw.GE.2*(iwfr-1_8))
269 RETURN
270 END SUBROUTINE dmumps_ldlt_compress
271 SUBROUTINE dmumps_sym_mwm(
272 & N, NE, IP, IRN, SCALING,LSC,CPERM, DIAG,
273 & ICNTL, WEIGHT,MARKED,FLAG,
274 & PIV_OUT, INFO)
275 IMPLICIT NONE
276 INTEGER, INTENT(IN) :: N
277 INTEGER(8), INTENT(IN) :: NE
278 INTEGER :: ICNTL(10), INFO(10),LSC
279 INTEGER :: CPERM(N),PIV_OUT(N), IRN(NE), DIAG(N)
280 INTEGER(8), INTENT(IN) :: IP(N+1)
281 DOUBLE PRECISION :: SCALING(LSC),WEIGHT(N+2)
282 INTEGER :: MARKED(N),FLAG(N)
283 INTEGER :: NUM1,NUM2,NUMTOT,PATH_LENGTH,NLAST
284 INTEGER :: I,BEST_BEG, CUR_EL,CUR_EL_PATH,CUR_EL_PATH_NEXT
285 INTEGER :: L1,L2,TUP,T22
286 INTEGER(8) :: PTR_SET1,PTR_SET2
287 DOUBLE PRECISION :: BEST_SCORE,CUR_VAL,TMP,VAL
288 DOUBLE PRECISION INITSCORE, DMUMPS_UPDATESCORE,
289 & dmumps_update_inverse, dmumps_metric2x2
290 LOGICAL VRAI,FAUX,MAX_CARD_DIAG,USE_SCALING
291 INTEGER SUM
292 DOUBLE PRECISION ZERO,ONE
293 parameter(sum = 1, vrai = .true., faux = .false.)
294 parameter(zero = 0.0d0, one = 1.0d0)
295 max_card_diag = .true.
296 num1 = 0
297 num2 = 0
298 numtot = 0
299 nlast = n
300 info = 0
301 marked = 1
302 flag = 0
303 val = one
304 IF(lsc .GT. 1) THEN
305 use_scaling = .true.
306 ELSE
307 use_scaling = .false.
308 ENDIF
309 tup = icntl(2)
310 IF(tup .EQ. sum) THEN
311 initscore = zero
312 ELSE
313 initscore = one
314 ENDIF
315 IF(icntl(2) .GT. 2 .OR. icntl(2) .LE. 0) THEN
316 WRITE(*,*)
317 & 'ERROR: WRONG VALUE FOR ICNTL(2) = ',icntl(2)
318 info(1) = -1
319 RETURN
320 ENDIF
321 t22 = icntl(1)
322 IF(icntl(1) .LT. 0 .OR. icntl(1) .GT. 2) THEN
323 WRITE(*,*)
324 & 'error: wrong VALUE for icntl(1) = ',ICNTL(1)
325 INFO(1) = -1
326 RETURN
327 ENDIF
328 DO CUR_EL=1,N
329.LE. IF(MARKED(CUR_EL) 0) THEN
330 CYCLE
331 ENDIF
332.LT. IF(CPERM(CUR_EL) 0) THEN
333 MARKED(CUR_EL) = -1
334 CYCLE
335 ENDIF
336 PATH_LENGTH = 2
337 CUR_EL_PATH = CPERM(CUR_EL)
338.EQ. IF(CUR_EL_PATH CUR_EL) THEN
339 MARKED(CUR_EL) = -1
340 CYCLE
341 ENDIF
342 MARKED(CUR_EL) = 0
343 WEIGHT(1) = INITSCORE
344 WEIGHT(2) = INITSCORE
345 L1 = int(IP(CUR_EL+1)-IP(CUR_EL))
346 L2 = int(IP(CUR_EL_PATH+1)-IP(CUR_EL_PATH))
347 PTR_SET1 = IP(CUR_EL)
348 PTR_SET2 = IP(CUR_EL_PATH)
349 IF(USE_SCALING) THEN
350 VAL = -SCALING(CUR_EL_PATH) - SCALING(CUR_EL+N)
351 ENDIF
352 CUR_VAL = DMUMPS_METRIC2x2(
353 & CUR_EL,CUR_EL_PATH,
354 & IRN(PTR_SET1),IRN(PTR_SET2),
355 & L1,L2,
356 & VAL,DIAG,N,FLAG,FAUX,T22)
357 WEIGHT(PATH_LENGTH+1) =
358 & DMUMPS_UPDATESCORE(WEIGHT(1),CUR_VAL,TUP)
359 DO
360.EQ. IF(CUR_EL_PATH CUR_EL) EXIT
361 PATH_LENGTH = PATH_LENGTH+1
362 MARKED(CUR_EL_PATH) = 0
363 CUR_EL_PATH_NEXT = CPERM(CUR_EL_PATH)
364 L1 = int(IP(CUR_EL_PATH+1)-IP(CUR_EL_PATH))
365 L2 = int(IP(CUR_EL_PATH_NEXT+1)-IP(CUR_EL_PATH_NEXT))
366 PTR_SET1 = IP(CUR_EL_PATH)
367 PTR_SET2 = IP(CUR_EL_PATH_NEXT)
368 IF(USE_SCALING) THEN
369 VAL = -SCALING(CUR_EL_PATH_NEXT)
370 & - SCALING(CUR_EL_PATH+N)
371 ENDIF
372 CUR_VAL = DMUMPS_METRIC2x2(
373 & CUR_EL_PATH,CUR_EL_PATH_NEXT,
374 & IRN(PTR_SET1),IRN(PTR_SET2),
375 & L1,L2,
376 & VAL,DIAG,N,FLAG,VRAI,T22)
377 WEIGHT(PATH_LENGTH+1) =
378 & DMUMPS_UPDATESCORE(WEIGHT(PATH_LENGTH-1),CUR_VAL,TUP)
379 CUR_EL_PATH = CUR_EL_PATH_NEXT
380 ENDDO
381.EQ. IF(mod(PATH_LENGTH,2) 1) THEN
382.GE. IF(WEIGHT(PATH_LENGTH+1) WEIGHT(PATH_LENGTH)) THEN
383 CUR_EL_PATH = CPERM(CUR_EL)
384 ELSE
385 CUR_EL_PATH = CUR_EL
386 ENDIF
387 DO I=1,(PATH_LENGTH-1)/2
388 NUM2 = NUM2+1
389 PIV_OUT(NUM2) = CUR_EL_PATH
390 CUR_EL_PATH = CPERM(CUR_EL_PATH)
391 NUM2 = NUM2+1
392 PIV_OUT(NUM2) = CUR_EL_PATH
393 CUR_EL_PATH = CPERM(CUR_EL_PATH)
394 ENDDO
395 NUMTOT = NUMTOT + PATH_LENGTH - 1
396 ELSE
397 IF(MAX_CARD_DIAG) THEN
398 CUR_EL_PATH = CPERM(CUR_EL)
399.NE. IF(DIAG(CUR_EL) 0) THEN
400 BEST_BEG = CUR_EL_PATH
401 GOTO 1000
402 ENDIF
403 DO I=1,(PATH_LENGTH/2)
404 CUR_EL_PATH_NEXT = CPERM(CUR_EL_PATH)
405.NE. IF(DIAG(CUR_EL_PATH) 0) THEN
406 BEST_BEG = CUR_EL_PATH_NEXT
407 GOTO 1000
408 ENDIF
409 ENDDO
410 ENDIF
411 BEST_BEG = CUR_EL
412 BEST_SCORE = WEIGHT(PATH_LENGTH-1)
413 CUR_EL_PATH = CPERM(CUR_EL)
414 DO I=1,(PATH_LENGTH/2)-1
415 TMP = DMUMPS_UPDATESCORE(WEIGHT(PATH_LENGTH),
416 & WEIGHT(2*I-1),TUP)
417 TMP = DMUMPS_UPDATE_INVERSE(TMP,WEIGHT(2*I),TUP)
418.GT. IF(TMP BEST_SCORE) THEN
419 BEST_SCORE = TMP
420 BEST_BEG = CUR_EL_PATH
421 ENDIF
422 CUR_EL_PATH = CPERM(CUR_EL_PATH)
423 TMP = DMUMPS_UPDATESCORE(WEIGHT(PATH_LENGTH+1),
424 & WEIGHT(2*I),TUP)
425 TMP = DMUMPS_UPDATE_INVERSE(TMP,WEIGHT(2*I+1),TUP)
426.GT. IF(TMP BEST_SCORE) THEN
427 BEST_SCORE = TMP
428 BEST_BEG = CUR_EL_PATH
429 ENDIF
430 CUR_EL_PATH = CPERM(CUR_EL_PATH)
431 ENDDO
432 1000 CUR_EL_PATH = BEST_BEG
433 DO I=1,(PATH_LENGTH/2)-1
434 NUM2 = NUM2+1
435 PIV_OUT(NUM2) = CUR_EL_PATH
436 CUR_EL_PATH = CPERM(CUR_EL_PATH)
437 NUM2 = NUM2+1
438 PIV_OUT(NUM2) = CUR_EL_PATH
439 CUR_EL_PATH = CPERM(CUR_EL_PATH)
440 ENDDO
441 NUMTOT = NUMTOT + PATH_LENGTH - 2
442 MARKED(CUR_EL_PATH) = -1
443 ENDIF
444 ENDDO
445 DO I=1,N
446.LT. IF(MARKED(I) 0) THEN
447.EQ. IF(DIAG(I) 0) THEN
448 PIV_OUT(NLAST) = I
449 NLAST = NLAST - 1
450 ELSE
451 NUM1 = NUM1 + 1
452 PIV_OUT(NUM2+NUM1) = I
453 NUMTOT = NUMTOT + 1
454 ENDIF
455 ENDIF
456 ENDDO
457 INFO(2) = NUMTOT
458 INFO(3) = NUM1
459 INFO(4) = NUM2
460 RETURN
461 END SUBROUTINE DMUMPS_SYM_MWM
462 FUNCTION DMUMPS_UPDATESCORE(A,B,T)
463 IMPLICIT NONE
464 DOUBLE PRECISION DMUMPS_UPDATESCORE
465 DOUBLE PRECISION A,B
466 INTEGER T
467 INTEGER SUM
468 PARAMETER(SUM = 1)
469.EQ. IF(T SUM) THEN
470 DMUMPS_UPDATESCORE = A+B
471 ELSE
472 DMUMPS_UPDATESCORE = A*B
473 ENDIF
474 END FUNCTION DMUMPS_UPDATESCORE
475 FUNCTION DMUMPS_UPDATE_INVERSE(A,B,T)
476 IMPLICIT NONE
477 DOUBLE PRECISION DMUMPS_UPDATE_INVERSE
478 DOUBLE PRECISION A,B
479 INTEGER T
480 INTEGER SUM
481 PARAMETER(SUM = 1)
482.EQ. IF(T SUM) THEN
483 DMUMPS_UPDATE_INVERSE = A-B
484 ELSE
485 DMUMPS_UPDATE_INVERSE = A/B
486 ENDIF
487 END FUNCTION DMUMPS_UPDATE_INVERSE
488 FUNCTION DMUMPS_METRIC2x2(CUR_EL,CUR_EL_PATH,
489 & SET1,SET2,L1,L2,VAL,DIAG,N,FLAG,FLAGON,T)
490 IMPLICIT NONE
491 DOUBLE PRECISION DMUMPS_METRIC2x2
492 INTEGER CUR_EL,CUR_EL_PATH,L1,L2,N
493 INTEGER SET1(L1),SET2(L2),DIAG(N),FLAG(N)
494 DOUBLE PRECISION VAL
495 LOGICAL FLAGON
496 INTEGER T
497 INTEGER I,INTER,MERGE
498 INTEGER STRUCT,MA47
499 PARAMETER(STRUCT=0,MA47=1)
500.EQ. IF(T STRUCT) THEN
501.NOT. IF( FLAGON) THEN
502 DO I=1,L1
503 FLAG(SET1(I)) = CUR_EL
504 ENDDO
505 ENDIF
506 INTER = 0
507 DO I=1,L2
508.EQ. IF(FLAG(SET2(I)) CUR_EL) THEN
509 INTER = INTER + 1
510 FLAG(SET2(I)) = CUR_EL_PATH
511 ENDIF
512 ENDDO
513 MERGE = L1 + L2 - INTER
514 DMUMPS_METRIC2x2 = dble(INTER) / dble(MERGE)
515.EQ. ELSE IF (T MA47) THEN
516 MERGE = 3
517.NE. IF(DIAG(CUR_EL) 0) MERGE = 2
518.NE. IF(DIAG(CUR_EL_PATH) 0) MERGE = MERGE - 2
519.EQ. IF(MERGE 0) THEN
520 DMUMPS_METRIC2x2 = dble(L1+L2-2)
521 DMUMPS_METRIC2x2 = -(DMUMPS_METRIC2x2**2)/2.0D0
522.EQ. ELSE IF(MERGE 1) THEN
523 DMUMPS_METRIC2x2 = - dble(L1+L2-4) * dble(L1-2)
524.EQ. ELSE IF(MERGE 2) THEN
525 DMUMPS_METRIC2x2 = - dble(L1+L2-4) * dble(L2-2)
526 ELSE
527 DMUMPS_METRIC2x2 = - dble(L1-2) * dble(L2-2)
528 ENDIF
529 ELSE
530 DMUMPS_METRIC2x2 = VAL
531 ENDIF
532 RETURN
533 END FUNCTION
534 SUBROUTINE DMUMPS_EXPAND_PERM_SCHUR(NA, NCMP,
535 & INVPERM,PERM,
536 & LISTVAR_SCHUR, SIZE_SCHUR, AOTOA)
537 IMPLICIT NONE
538 INTEGER, INTENT(IN):: SIZE_SCHUR, LISTVAR_SCHUR(SIZE_SCHUR)
539 INTEGER, INTENT(IN):: NA, NCMP
540 INTEGER, INTENT(IN):: AOTOA(NCMP), PERM(NCMP)
541 INTEGER, INTENT(OUT):: INVPERM(NA)
542 INTEGER CMP_POS, IO, I, K, IPOS
543 DO CMP_POS=1, NCMP
544 IO = PERM(CMP_POS)
545 INVPERM(AOTOA(IO)) = CMP_POS
546 ENDDO
547 IPOS = NCMP
548 DO K =1, SIZE_SCHUR
549 I = LISTVAR_SCHUR(K)
550 IPOS = IPOS+1
551 INVPERM(I) = IPOS
552 ENDDO
553 RETURN
554 END SUBROUTINE DMUMPS_EXPAND_PERM_SCHUR
555 SUBROUTINE DMUMPS_GNEW_SCHUR
556 & (NA, N, NZ, IRN, ICN, IW, LW, IPE, LEN,
557 & IQ, FLAG, IWFR,
558 & NRORM, NIORM, IFLAG,IERROR, ICNTL,
559 & symmetry, SYM, NBQD, AvgDens,
560 & KEEP264, KEEP265,
561 & LISTVAR_SCHUR, SIZE_SCHUR, ATOAO, AOTOA,
562 & INPLACE64_GRAPH_COPY
563 & )
564 IMPLICIT NONE
565 INTEGER, intent(in) :: NA
566 INTEGER, intent(in) :: N, SYM
567 INTEGER(8), intent(in) :: NZ, LW
568 INTEGER, intent(in) :: ICNTL(60)
569 INTEGER, intent(in) :: IRN(NZ), ICN(NZ)
570 INTEGER, INTENT(IN) :: SIZE_SCHUR, LISTVAR_SCHUR(SIZE_SCHUR)
571 INTEGER, intent(out) :: IERROR, symmetry
572 INTEGER, intent(out) :: NBQD, AvgDens
573 INTEGER, intent(out) :: LEN(N), IW(LW)
574 INTEGER(8), intent(out):: IWFR
575 INTEGER(8), intent(out):: NRORM, NIORM
576 INTEGER(8), intent(out):: IPE(N+1)
577 INTEGER, INTENT(OUT) :: AOTOA(N)
578 INTEGER, INTENT(OUT) :: ATOAO(NA)
579 INTEGER, intent(inout) :: IFLAG, KEEP264
580 INTEGER, intent(in) :: KEEP265
581 INTEGER(8), intent(out):: IQ(N)
582 INTEGER, intent(out) :: FLAG(N)
583 LOGICAL, intent(inout) :: INPLACE64_GRAPH_COPY
584 INTEGER :: MP, MPG, I, J, N1
585 INTEGER :: NBERR, THRESH, IAO
586 INTEGER(8) :: K8, K1, K2, LAST, NDUP
587 INTEGER(8) :: NZOFFA, NDIAGA, L, N8
588 DOUBLE PRECISION :: RSYM
589 INTRINSIC nint
590 MP = ICNTL(2)
591 MPG= ICNTL(3)
592 ATOAO(1:NA) = 0
593 DO I = 1, SIZE_SCHUR
594 ATOAO(LISTVAR_SCHUR(I)) = -1
595 ENDDO
596 IAO = 0
597 DO I= 1, NA
598.LT. IF (ATOAO(I)0) CYCLE
599 IAO = IAO +1
600 ATOAO(I) = IAO
601 AOTOA(IAO) = I
602 ENDDO
603 NZOFFA = 0_8
604 NDIAGA = 0
605 IERROR = 0
606 N8 = int(N,8)
607 DO I=1,N+1
608 IPE(I) = 0_8
609 ENDDO
610.EQ. IF (KEEP2640) THEN
611.EQ..AND..EQ. IF ((SYM0)(KEEP265-1)) THEN
612 DO K8=1_8,NZ
613 I = IRN(K8)
614 J = ICN(K8)
615.GT..OR..GT..OR..LT. IF ((INA)(JNA)(I1)
616.OR..LT. & (J1)) THEN
617 IERROR = IERROR + 1
618 ELSE
619 I = ATOAO(I)
620 J = ATOAO(J)
621.LT..OR..LT. IF ((I0)(J0)) CYCLE
622.NE. IF (IJ) THEN
623 IPE(I) = IPE(I) + 1_8
624 NZOFFA = NZOFFA + 1_8
625 ELSE
626 NDIAGA = NDIAGA + 1_8
627 ENDIF
628 ENDIF
629 ENDDO
630 ELSE
631 DO K8=1_8,NZ
632 I = IRN(K8)
633 J = ICN(K8)
634.GT..OR..GT..OR..LT. IF ((INA)(JNA)(I1)
635.OR..LT. & (J1)) THEN
636 IERROR = IERROR + 1
637 ELSE
638 I = ATOAO(I)
639 J = ATOAO(J)
640.LT..OR..LT. IF ((I0)(J0)) CYCLE
641.NE. IF (IJ) THEN
642 IPE(I) = IPE(I) + 1_8
643 IPE(J) = IPE(J) + 1_8
644 NZOFFA = NZOFFA + 1_8
645 ELSE
646 NDIAGA = NDIAGA + 1_8
647 ENDIF
648 ENDIF
649 ENDDO
650 ENDIF
651.GE. IF (IERROR1) THEN
652 KEEP264 = 0
653 ELSE
654 KEEP264 = 1
655 ENDIF
656 ELSE
657.EQ..AND..EQ. IF ((SYM0)(KEEP265-1)) THEN
658 DO K8=1_8,NZ
659 I = IRN(K8)
660 J = ICN(K8)
661 I = ATOAO(I)
662 J = ATOAO(J)
663.LT..OR..LT. IF ((I0)(J0)) CYCLE
664.EQ. IF (IJ) THEN
665 NDIAGA = NDIAGA + 1_8
666 ELSE
667 IPE(I) = IPE(I) + 1_8
668 NZOFFA = NZOFFA + 1_8
669 ENDIF
670 ENDDO
671 ELSE
672 DO K8=1_8,NZ
673 I = IRN(K8)
674 J = ICN(K8)
675 I = ATOAO(I)
676 J = ATOAO(J)
677.LT..OR..LT. IF ((I0)(J0)) CYCLE
678.NE. IF (IJ) THEN
679 IPE(I) = IPE(I) + 1_8
680 IPE(J) = IPE(J) + 1_8
681 NZOFFA = NZOFFA + 1_8
682 ELSE
683 NDIAGA = NDIAGA + 1_8
684 ENDIF
685 ENDDO
686 ENDIF
687 ENDIF
688 NIORM = NZOFFA + 3_8*N8
689.GE. IF (IERROR1) THEN
690 NBERR = 0
691.EQ. IF (mod(IFLAG,2) 0) IFLAG = IFLAG+1
692.GT..AND..GE. IF ((MP0)(ICNTL(4)2)) THEN
693 WRITE (MP,99999)
694 DO 70 K8=1_8,NZ
695 I = IRN(K8)
696 J = ICN(K8)
697.GT..OR..GT..OR..LT. IF ((INA)(JNA)(I1)
698.OR..LT. & (J1)) THEN
699 NBERR = NBERR + 1
700.LE. IF (NBERR10) THEN
701.GT..OR..EQ..OR. IF (mod(K8,10_8)3_8 mod(K8,10_8)0_8
702.LE..AND..LE. & (10_8K8 K820_8)) THEN
703 WRITE (MP,'(i16,a,i10,a,i10,a)')
704 & K8,'th entry(in row',I,' and column',J,') ignored'
705 ELSE
706.EQ. IF (mod(K8,10_8)1_8)
707 & WRITE(MP,'(i16,a,i10,a,i10,a)')
708 & K8,'st entry(in row',I,' and column',J,') ignored'
709.EQ. IF (mod(K8,10_8)2_8)
710 & WRITE(MP,'(i16,a,i10,a,i10,a)')
711 & K8,'nd entry(in row',I,' and column',J,') ignored'
712.EQ. IF (mod(K8,10_8)3_8)
713 & WRITE(MP,'(i16,a,i10,a,i10,a)')
714 & K8,'rd entry(in row',I,' and column',J,') ignored'
715 ENDIF
716 ELSE
717 GO TO 100
718 ENDIF
719 ENDIF
720 70 CONTINUE
721 ENDIF
722 ENDIF
723 100 NRORM = NIORM - 2_8*N8
724 IQ(1) = 1_8
725 N1 = N - 1
726.GT. IF (N10) THEN
727 DO I=1,N1
728 IQ(I+1) = IPE(I) + IQ(I)
729 ENDDO
730 ENDIF
731 LAST = max(IPE(N)+IQ(N)-1,IQ(N))
732 FLAG(1:N) = 0
733 IPE(1:N) = IQ(1:N)
734 IW(1:LAST) = 0
735 IWFR = LAST + 1_8
736.EQ. IF (KEEP264 0) THEN
737.EQ..AND..EQ. IF ((SYM0)(KEEP265-1)) THEN
738 DO K8=1_8,NZ
739 I = IRN(K8)
740 J = ICN(K8)
741.GT..OR..GT..OR..LT. IF ((INA)(JNA)(I1)
742.OR..LT. & (J1)) CYCLE
743 I = ATOAO(I)
744 J = ATOAO(J)
745.LT..OR..LT. IF ((I0)(J0)) CYCLE
746.NE. IF (IJ) THEN
747.GE..AND..LE. IF ((J1)(IN)) THEN
748 IW(IQ(I)) = J
749 IQ(I) = IQ(I) + 1
750 ENDIF
751 ENDIF
752 ENDDO
753.EQ. ELSE IF (KEEP2651) THEN
754 DO K8=1_8,NZ
755 I = IRN(K8)
756 J = ICN(K8)
757.GT..OR..GT..OR..LT. IF ((INA)(JNA)(I1)
758.OR..LT. & (J1)) CYCLE
759 I = ATOAO(I)
760 J = ATOAO(J)
761.LT..OR..LT. IF ((I0)(J0)) CYCLE
762.NE. IF (IJ) THEN
763.GE..AND..LE. IF ((J1)(IN)) THEN
764 IW(IQ(J)) = I
765 IQ(J) = IQ(J) + 1
766 IW(IQ(I)) = J
767 IQ(I) = IQ(I) + 1
768 ENDIF
769 ENDIF
770 ENDDO
771 ELSE
772 DO K8=1_8,NZ
773 I = IRN(K8)
774 J = ICN(K8)
775.GT..OR..GT..OR..LT. IF ((INA)(JNA)(I1)
776.OR..LT. & (J1)) CYCLE
777 I = ATOAO(I)
778 J = ATOAO(J)
779.LT..OR..LT. IF ((I0)(J0)) CYCLE
780.NE. IF (IJ) THEN
781.LT. IF (IJ) THEN
782.GE..AND..LE. IF ((I1)(JN)) THEN
783 IW(IQ(I)) = -J
784 IQ(I) = IQ(I) + 1
785 ENDIF
786 ELSE
787.GE..AND..LE. IF ((J1)(IN)) THEN
788 IW(IQ(J)) = -I
789 IQ(J) = IQ(J) + 1
790 ENDIF
791 ENDIF
792 ENDIF
793 ENDDO
794 ENDIF
795 ELSE
796.EQ..AND..EQ. IF ((SYM0)(KEEP265-1)) THEN
797 DO K8=1_8,NZ
798 I = IRN(K8)
799 J = ICN(K8)
800 I = ATOAO(I)
801 J = ATOAO(J)
802.LT..OR..LT. IF ((I0)(J0)) CYCLE
803.NE. IF (IJ) THEN
804 IW(IQ(I)) = J
805 IQ(I) = IQ(I) + 1
806 ENDIF
807 ENDDO
808.EQ. ELSE IF (KEEP2651) THEN
809 DO K8=1_8,NZ
810 I = IRN(K8)
811 J = ICN(K8)
812 I = ATOAO(I)
813 J = ATOAO(J)
814.LT..OR..LT. IF ((I0)(J0)) CYCLE
815.NE. IF (IJ) THEN
816 IW(IQ(J)) = I
817 IQ(J) = IQ(J) + 1
818 IW(IQ(I)) = J
819 IQ(I) = IQ(I) + 1
820 ENDIF
821 ENDDO
822 ELSE
823 DO K8=1_8,NZ
824 I = IRN(K8)
825 J = ICN(K8)
826 I = ATOAO(I)
827 J = ATOAO(J)
828.LT..OR..LT. IF ((I0)(J0)) CYCLE
829.NE. IF (IJ) THEN
830.LT. IF (IJ) THEN
831 IW(IQ(I)) = -J
832 IQ(I) = IQ(I) + 1
833 ELSE
834 IW(IQ(J)) = -I
835 IQ(J) = IQ(J) + 1
836 ENDIF
837 ENDIF
838 ENDDO
839 ENDIF
840 ENDIF
841.EQ. IF (KEEP2650) THEN
842 NDUP = 0_8
843 DO I=1,N
844 K1 = IPE(I)
845 K2 = IQ(I) - 1_8
846.GT. IF (K1K2) THEN
847 LEN(I) = 0
848 ELSE
849 DO K8=K1,K2
850 J = -IW(K8)
851.LE. IF (J0) EXIT
852.EQ. IF (FLAG(J)I) THEN
853 NDUP = NDUP + 1_8
854 IW(K8) = 0
855 ELSE
856 L = IQ(J)
857 IQ(J) = L + 1
858 IW(L) = I
859 IW(K8) = J
860 FLAG(J) = I
861 ENDIF
862 END DO
863 LEN(I) = int(IQ(I) - IPE(I))
864 ENDIF
865 ENDDO
866.NE. IF (NDUP0_8) THEN
867 IWFR = 1_8
868 DO I=1,N
869.EQ. IF (LEN(I)0) THEN
870 IPE(I) = IWFR
871 CYCLE
872 ENDIF
873 K1 = IPE(I)
874 K2 = K1 + LEN(I) - 1
875 L = IWFR
876 IPE(I) = IWFR
877 DO 270 K8=K1,K2
878.NE. IF (IW(K8)0) THEN
879 IW(IWFR) = IW(K8)
880 IWFR = IWFR + 1_8
881 ENDIF
882 270 CONTINUE
883 LEN(I) = int(IWFR - L)
884 ENDDO
885 ENDIF
886 IPE(N+1) = IPE(N) + int(LEN(N),8)
887 IWFR = IPE(N+1)
888 ELSE
889 IPE(1) = 1_8
890 DO I = 1, N
891 LEN(I) = int(IQ(I) - IPE(I))
892 ENDDO
893 DO I = 1, N
894 IPE(I+1) = IPE(I) + int(LEN(I),8)
895 ENDDO
896 IWFR = IPE(N+1)
897 ENDIF
898 symmetry = 100
899.EQ. IF (SYM0) THEN
900 RSYM = dble(NDIAGA+2_8*NZOFFA - (IWFR-1_8))/
901 & dble(NZOFFA+NDIAGA)
902.EQ..AND..EQ. IF ((KEEP2650) (NZOFFA - (IWFR-1_8))0_8) THEN
903 ENDIF
904 symmetry = nint (100.0D0*RSYM)
905.GT..AND..GE. IF ((MPG 0)(ICNTL(4)2) )
906 & write(MPG,'(a,a,i5)')
907 & ' Case of schur:',
908 & ' structural symmetry(in percent) of interior block=',
909 & symmetry
910.GT..AND..NE..AND..GE. IF (MP0 MPGMP (ICNTL(4)2) )
911 & write(MP,'(a,a,i5)')
912 & ' Case of schur:',
913 & ' structural symmetry(in percent) of interior block=',
914 & symmetry
915 ELSE
916 symmetry = 100
917 ENDIF
918.GE. INPLACE64_GRAPH_COPY = (LW2*(IWFR-1))
919 AvgDens = nint(dble(IWFR-1_8)/dble(N))
920 THRESH = AvgDens*50 - AvgDens/10 + 1
921 NBQD = 0
922.GT. IF (N2) THEN
923 DO I= 1, N
924 J = max(LEN(I),1)
925.GT. IF (JTHRESH) NBQD = NBQD+1
926 ENDDO
927 ENDIF
928.GT..AND..GE. IF (MPG 0(ICNTL(4)2))
929 & write(MPG,'(a,1i5)')
930 & ' average density of rows/columns =', AvgDens
931.GT..AND..NE..AND..GE. IF (MP0 MPGMP(ICNTL(4)2))
932 & write(MPG,'(a,1i5)')
933 & ' average density of rows/columns =', AvgDens
934 RETURN
93599999 FORMAT (/'*** warning message from analysis routine ***')
936 END SUBROUTINE DMUMPS_GNEW_SCHUR
937 SUBROUTINE DMUMPS_GET_PERM_FROM_PE(N,PE,INVPERM,NFILS,WORK)
938 IMPLICIT NONE
939 INTEGER N
940 INTEGER PE(N),INVPERM(N),NFILS(N),WORK(N)
941 INTEGER I,FATHER,STKLEN,STKPOS,PERMPOS,CURVAR
942 NFILS = 0
943 DO I=1,N
944 FATHER = -PE(I)
945.NE. IF(FATHER 0) NFILS(FATHER) = NFILS(FATHER) + 1
946 ENDDO
947 STKLEN = 0
948 PERMPOS = 1
949 DO I=1,N
950.EQ. IF(NFILS(I) 0) THEN
951 STKLEN = STKLEN + 1
952 WORK(STKLEN) = I
953 INVPERM(I) = PERMPOS
954 PERMPOS = PERMPOS + 1
955 ENDIF
956 ENDDO
957 DO STKPOS = 1,STKLEN
958 CURVAR = WORK(STKPOS)
959 FATHER = -PE(CURVAR)
960 DO
961.EQ. IF(FATHER 0) EXIT
962.EQ. IF(NFILS(FATHER) 1) THEN
963 INVPERM(FATHER) = PERMPOS
964 FATHER = -PE(FATHER)
965 PERMPOS = PERMPOS + 1
966 ELSE
967 NFILS(FATHER) = NFILS(FATHER) - 1
968 EXIT
969 ENDIF
970 ENDDO
971 ENDDO
972 RETURN
973 END SUBROUTINE DMUMPS_GET_PERM_FROM_PE
974 SUBROUTINE DMUMPS_GET_ELIM_TREE(N,PE,NV,WORK)
975 IMPLICIT NONE
976 INTEGER N
977 INTEGER PE(N),NV(N),WORK(N)
978 INTEGER I,FATHER,LEN,NEWSON,NEWFATHER
979 DO I=1,N
980.GT. IF(NV(I) 0) CYCLE
981 LEN = 1
982 WORK(LEN) = I
983 FATHER = -PE(I)
984 DO
985.GT. IF(NV(FATHER) 0) THEN
986 NEWSON = FATHER
987 EXIT
988 ENDIF
989 LEN = LEN + 1
990 WORK(LEN) = FATHER
991 NV(FATHER) = 1
992 FATHER = -PE(FATHER)
993 ENDDO
994 NEWFATHER = -PE(FATHER)
995 PE(WORK(LEN)) = -NEWFATHER
996 PE(NEWSON) = -WORK(1)
997 ENDDO
998 END SUBROUTINE DMUMPS_GET_ELIM_TREE
dmumps_expand_permutation
subroutine dmumps_expand_permutation(n, ncmp, n11, n22, piv, invperm, perm)
Definition dana_LDLT_preprocess.F:90
dmumps_set_constraints
subroutine dmumps_set_constraints(n, piv, frere, fils, nfsiz, ikeep, ncst, keep, keep8, rowsca)
Definition dana_LDLT_preprocess.F:18
dmumps_sym_mwm
subroutine dmumps_sym_mwm(n, ne, ip, irn, scaling, lsc, cperm, diag, icntl, weight, marked, flag, piv_out, info)
Definition dana_LDLT_preprocess.F:275
dmumps_metric2x2
double precision function dmumps_metric2x2(cur_el, cur_el_path, set1, set2, l1, l2, val, diag, n, flag, flagon, t)
Definition dana_LDLT_preprocess.F:490
dmumps_ldlt_compress
subroutine dmumps_ldlt_compress(n, nz, irn, icn, piv, ncmp, iw, lw, ipe, len, iq, flag, icmp, iwfr, ierror, keep, keep8, icntl, inplace64_graph_copy)
Definition dana_LDLT_preprocess.F:127
dmumps_update_inverse
double precision function dmumps_update_inverse(a, b, t)
Definition dana_LDLT_preprocess.F:476
max
#define max(a, b)
Definition macros.h:21
for
for(i8=*sizetab-1;i8 >=0;i8--)
Definition mumps_common.c:91
dmumps_struc_def
Definition dmumps_struc_def.F:14