OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
dfac_scalings.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_fac_a(N, NZ8, NSCA,
15 & ASPK, IRN, ICN, COLSCA, ROWSCA, WK, LWK8, WK_REAL,
16 & LWK_REAL, ICNTL, INFO)
17 IMPLICIT NONE
18 INTEGER N, NSCA
19 INTEGER(8), INTENT(IN) :: NZ8
20 INTEGER IRN(NZ8), ICN(NZ8)
21 INTEGER ICNTL(60), INFO(80)
22 DOUBLE PRECISION, INTENT(IN) :: ASPK(NZ8)
23 DOUBLE PRECISION COLSCA(*), ROWSCA(*)
24 INTEGER(8), INTENT(IN) :: LWK8
25 INTEGER LWK_REAL
26 DOUBLE PRECISION WK(LWK8)
27 DOUBLE PRECISION WK_REAL(LWK_REAL)
28 INTEGER MPG,LP
29 INTEGER IWNOR
30 INTEGER I
31 LOGICAL PROK
32 DOUBLE PRECISION ONE
33 parameter( one = 1.0d0 )
34 lp = icntl(1)
35 mpg = icntl(2)
36 mpg = icntl(3)
37 prok = ((mpg.GT.0).AND.(icntl(4).GE.2))
38 IF (prok) THEN
39 WRITE(mpg,101)
40 ELSE
41 mpg = 0
42 ENDIF
43 101 FORMAT(/' ****** SCALING OF ORIGINAL MATRIX '/)
44 IF (nsca.EQ.1) THEN
45 IF (prok)
46 & WRITE (mpg,*) ' DIAGONAL SCALING '
47 ELSEIF (nsca.EQ.3) THEN
48 IF (prok)
49 & WRITE (mpg,*) ' COLUMN SCALING'
50 ELSEIF (nsca.EQ.4) THEN
51 IF (prok)
52 & WRITE (mpg,*) ' ROW AND COLUMN SCALING (1 Pass)'
53 ENDIF
54 DO 10 i=1,n
55 colsca(i) = one
56 rowsca(i) = one
57 10 CONTINUE
58 IF (5*n.GT.lwk_real) GOTO 410
59 iwnor = 1
60 IF (nsca.EQ.1) THEN
61 CALL dmumps_fac_v(n,nz8,aspk,irn,icn,
62 & colsca,rowsca,mpg)
63 ELSEIF (nsca.EQ.3) THEN
64 CALL dmumps_fac_y(n,nz8,aspk,irn,icn,wk_real(iwnor),
65 & colsca, mpg)
66 ELSEIF (nsca.EQ.4) THEN
67 CALL dmumps_rowcol(n,nz8,irn,icn,aspk,
68 & wk_real(iwnor),wk_real(iwnor+n),colsca,rowsca,mpg)
69 ENDIF
70 GOTO 500
71 410 info(1) = -5
72 info(2) = 5*n-lwk_real
73 IF ((lp.GT.0).AND.(icntl(4).GE.1))
74 & WRITE(lp,*) '*** ERROR: Not enough space to scale matrix'
75 GOTO 500
76 500 CONTINUE
77 RETURN
78 END SUBROUTINE dmumps_fac_a
79 SUBROUTINE dmumps_rowcol(N,NZ8,IRN,ICN,VAL,
80 & RNOR,CNOR,COLSCA,ROWSCA,MPRINT)
81 INTEGER, INTENT(IN) :: N
82 INTEGER(8), INTENT(IN) :: NZ8
83 DOUBLE PRECISION VAL(NZ8)
84 DOUBLE PRECISION RNOR(N),CNOR(N)
85 DOUBLE PRECISION COLSCA(N),ROWSCA(N)
86 DOUBLE PRECISION CMIN,CMAX,RMIN,ARNOR,ACNOR
87 INTEGER IRN(NZ8), ICN(NZ8)
88 DOUBLE PRECISION VDIAG
89 INTEGER MPRINT
90 INTEGER I,J
91 INTEGER(8) :: K8
92 DOUBLE PRECISION ZERO, ONE
93 parameter(zero=0.0d0, one=1.0d0)
94 DO 50 j=1,n
95 cnor(j) = zero
96 rnor(j) = zero
97 50 CONTINUE
98 DO 100 k8=1_8,nz8
99 i = irn(k8)
100 j = icn(k8)
101 IF ((i.LE.0).OR.(i.GT.n).OR.
102 & (j.LE.0).OR.(j.GT.n)) GOTO 100
103 vdiag = abs(val(k8))
104 IF (vdiag.GT.cnor(j)) THEN
105 cnor(j) = vdiag
106 ENDIF
107 IF (vdiag.GT.rnor(i)) THEN
108 rnor(i) = vdiag
109 ENDIF
110 100 CONTINUE
111 IF (mprint.GT.0) THEN
112 cmin = cnor(1)
113 cmax = cnor(1)
114 rmin = rnor(1)
115 DO 111 i=1,n
116 arnor = rnor(i)
117 acnor = cnor(i)
118 IF (acnor.GT.cmax) cmax=acnor
119 IF (acnor.LT.cmin) cmin=acnor
120 IF (arnor.LT.rmin) rmin=arnor
121 111 CONTINUE
122 WRITE(mprint,*) '**** STAT. OF MATRIX PRIOR ROW&COL SCALING'
123 WRITE(mprint,*) ' MAXIMUM NORM-MAX OF COLUMNS:',cmax
124 WRITE(mprint,*) ' MINIMUM NORM-MAX OF COLUMNS:',cmin
125 WRITE(mprint,*) ' MINIMUM NORM-MAX OF ROWS :',rmin
126 ENDIF
127 DO 120 j=1,n
128 IF (cnor(j).LE.zero) THEN
129 cnor(j) = one
130 ELSE
131 cnor(j) = one / cnor(j)
132 ENDIF
133 120 CONTINUE
134 DO 130 j=1,n
135 IF (rnor(j).LE.zero) THEN
136 rnor(j) = one
137 ELSE
138 rnor(j) = one / rnor(j)
139 ENDIF
140 130 CONTINUE
141 DO 110 i=1,n
142 rowsca(i) = rowsca(i) * rnor(i)
143 colsca(i) = colsca(i) * cnor(i)
144 110 CONTINUE
145 IF (mprint.GT.0)
146 & WRITE(mprint,*) ' END OF SCALING BY MAX IN ROW AND COL'
147 RETURN
148 END SUBROUTINE dmumps_rowcol
149 SUBROUTINE dmumps_fac_y(N,NZ8,VAL,IRN,ICN,
150 & CNOR,COLSCA,MPRINT)
151 INTEGER, INTENT(IN) :: N
152 INTEGER(8), INTENT(IN) :: NZ8
153 DOUBLE PRECISION, INTENT(IN) :: VAL(NZ8)
154 DOUBLE PRECISION, INTENT(OUT) :: CNOR(N)
155 DOUBLE PRECISION, INTENT(INOUT) :: COLSCA(N)
156 INTEGER, INTENT(IN) :: IRN(NZ8), ICN(NZ8)
157 INTEGER, INTENT(IN) :: MPRINT
158 DOUBLE PRECISION VDIAG
159 INTEGER I,J
160 INTEGER(8) :: K8
161 DOUBLE PRECISION ZERO, ONE
162 parameter(zero=0.0d0,one=1.0d0)
163 DO 10 j=1,n
164 cnor(j) = zero
165 10 CONTINUE
166 DO 100 k8=1_8,nz8
167 i = irn(k8)
168 j = icn(k8)
169 IF ((i.LE.0).OR.(i.GT.n).OR.
170 & (j.LE.0).OR.(j.GT.n)) GOTO 100
171 vdiag = abs(val(k8))
172 IF (vdiag.GT.cnor(j)) THEN
173 cnor(j) = vdiag
174 ENDIF
175 100 CONTINUE
176 DO 110 j=1,n
177 IF (cnor(j).LE.zero) THEN
178 cnor(j) = one
179 ELSE
180 cnor(j) = one/cnor(j)
181 ENDIF
182 110 CONTINUE
183 DO 215 i=1,n
184 colsca(i) = colsca(i) * cnor(i)
185 215 CONTINUE
186 IF (mprint.GT.0) WRITE(mprint,*) ' END OF COLUMN SCALING'
187 RETURN
188 END SUBROUTINE dmumps_fac_y
189 SUBROUTINE dmumps_fac_v(N,NZ8,VAL,IRN,ICN,
190 & COLSCA,ROWSCA,MPRINT)
191 INTEGER , INTENT(IN) :: N
192 INTEGER(8), INTENT(IN) :: NZ8
193 DOUBLE PRECISION , INTENT(IN) :: VAL(NZ8)
194 DOUBLE PRECISION , INTENT(OUT) :: ROWSCA(N),COLSCA(N)
195 INTEGER , INTENT(IN) :: IRN(NZ8),ICN(NZ8)
196 INTEGER , INTENT(IN) :: MPRINT
197 DOUBLE PRECISION :: VDIAG
198 INTEGER :: I,J
199 INTEGER(8) :: K8
200 INTRINSIC sqrt
201 DOUBLE PRECISION ZERO, ONE
202 parameter(zero=0.0d0, one=1.0d0)
203 DO 10 i=1,n
204 rowsca(i) = one
205 10 CONTINUE
206 DO 100 k8=1_8,nz8
207 i = irn(k8)
208 IF ((i.GT.n).OR.(i.LE.0)) GOTO 100
209 j = icn(k8)
210 IF (i.EQ.j) THEN
211 vdiag = abs(val(k8))
212 IF (vdiag.GT.zero) THEN
213 rowsca(j) = one/(sqrt(vdiag))
214 ENDIF
215 ENDIF
216 100 CONTINUE
217 DO 110 i=1,n
218 colsca(i) = rowsca(i)
219 110 CONTINUE
220 IF (mprint.GT.0) WRITE(mprint,*) ' END OF DIAGONAL SCALING'
221 RETURN
222 END SUBROUTINE dmumps_fac_v
223 SUBROUTINE dmumps_fac_x(NSCA,N,NZ8,IRN,ICN,VAL,
224 & RNOR,ROWSCA,MPRINT)
225 INTEGER, INTENT(IN) :: N, NSCA
226 INTEGER(8), INTENT(IN) :: NZ8
227 INTEGER, INTENT(IN) :: IRN(NZ8), ICN(NZ8)
228 DOUBLE PRECISION VAL(NZ8)
229 DOUBLE PRECISION RNOR(N)
230 DOUBLE PRECISION ROWSCA(N)
231 INTEGER MPRINT
232 DOUBLE PRECISION VDIAG
233 INTEGER I,J
234 INTEGER(8) :: K8
235 DOUBLE PRECISION, PARAMETER :: ZERO = 0.0d0
236 DOUBLE PRECISION, PARAMETER :: ONE = 1.0d0
237 DO 50 j=1,n
238 rnor(j) = zero
239 50 CONTINUE
240 DO 100 k8=1_8,nz8
241 i = irn(k8)
242 j = icn(k8)
243 IF ((i.LE.0).OR.(i.GT.n).OR.
244 & (j.LE.0).OR.(j.GT.n)) GOTO 100
245 vdiag = abs(val(k8))
246 IF (vdiag.GT.rnor(i)) THEN
247 rnor(i) = vdiag
248 ENDIF
249 100 CONTINUE
250 DO 130 j=1,n
251 IF (rnor(j).LE.zero) THEN
252 rnor(j) = one
253 ELSE
254 rnor(j) = one/rnor(j)
255 ENDIF
256 130 CONTINUE
257 DO 110 i=1,n
258 rowsca(i) = rowsca(i)* rnor(i)
259 110 CONTINUE
260 IF ( (nsca.EQ.4) .OR. (nsca.EQ.6) ) THEN
261 DO 150 k8 = 1_8, nz8
262 i = irn(k8)
263 j = icn(k8)
264 IF (min(i,j).LT.1 .OR. i.GT.n .OR. j.GT.n) GOTO 150
265 val(k8) = val(k8) * rnor(i)
266 150 CONTINUE
267 ENDIF
268 IF (mprint.GT.0)
269 & WRITE(mprint,'(A)') ' END OF ROW SCALING'
270 RETURN
271 END SUBROUTINE dmumps_fac_x
272 SUBROUTINE dmumps_anorminf( id, ANORMINF, LSCAL,
273 & EFF_SIZE_SCHUR )
274 USE dmumps_struc_def
275 IMPLICIT NONE
276 include 'mpif.h'
277 INTEGER MASTER, IERR
278 parameter( master = 0 )
279 TYPE(dmumps_struc), TARGET :: id
280 DOUBLE PRECISION, INTENT(OUT) :: ANORMINF
281 LOGICAL, INTENT(IN) :: LSCAL
282 INTEGER, INTENT(IN) :: EFF_SIZE_SCHUR
283 INTEGER, DIMENSION (:), POINTER :: KEEP,INFO
284 INTEGER(8), DIMENSION (:), POINTER :: KEEP8
285 LOGICAL :: I_AM_SLAVE
286 DOUBLE PRECISION DUMMY(1)
287 DOUBLE PRECISION ZERO
288 parameter( zero = 0.0d0)
289 DOUBLE PRECISION, ALLOCATABLE :: SUMR(:), SUMR_LOC(:)
290 INTEGER :: allocok, MTYPE, I
291 info =>id%INFO
292 keep =>id%KEEP
293 keep8 =>id%KEEP8
294 i_am_slave = ( id%MYID .ne. master .OR.
295 & ( id%MYID .eq. master .AND.
296 & keep(46) .eq. 1 ) )
297 IF (id%MYID .EQ. master) THEN
298 ALLOCATE( sumr( id%N ), stat =allocok )
299 IF (allocok .GT.0 ) THEN
300 id%INFO(1)=-13
301 id%INFO(2)=id%N
302 RETURN
303 ENDIF
304 ENDIF
305 IF ( keep(54) .eq. 0 ) THEN
306 IF (id%MYID .EQ. master) THEN
307 IF (keep(55).EQ.0) THEN
308 IF (.NOT.lscal) THEN
309 CALL dmumps_sol_x(id%A(1),
310 & id%KEEP8(28), id%N,
311 & id%IRN(1), id%JCN(1),
312 & sumr, keep(1),keep8(1),
313 & eff_size_schur, id%SYM_PERM(1) )
314 ELSE
315 CALL dmumps_scal_x(id%A(1),
316 & id%KEEP8(28), id%N,
317 & id%IRN(1), id%JCN(1),
318 & sumr, keep(1), keep8(1),
319 & id%COLSCA(1),
320 & eff_size_schur, id%SYM_PERM(1) )
321 ENDIF
322 ELSE
323 mtype = 1
324 IF (.NOT.lscal) THEN
325 CALL dmumps_sol_x_elt(mtype, id%N,
326 & id%NELT, id%ELTPTR(1),
327 & id%LELTVAR, id%ELTVAR(1),
328 & id%KEEP8(30),
329 & id%A_ELT(1), sumr, keep(1),keep8(1) )
330 ELSE
331 CALL dmumps_sol_scalx_elt(mtype, id%N,
332 & id%NELT, id%ELTPTR(1),
333 & id%LELTVAR, id%ELTVAR(1),
334 & id%KEEP8(30),
335 & id%A_ELT(1),
336 & sumr, keep(1),keep8(1), id%COLSCA(1))
337 ENDIF
338 ENDIF
339 ENDIF
340 ELSE
341 ALLOCATE( sumr_loc( id%N ), stat =allocok )
342 IF (allocok .GT.0 ) THEN
343 id%INFO(1)=-13
344 id%INFO(2)=id%N
345 RETURN
346 ENDIF
347 IF ( i_am_slave .and.
348 & id%KEEP8(29) .NE. 0 ) THEN
349 IF (.NOT.lscal) THEN
350 CALL dmumps_sol_x(id%A_loc(1),
351 & id%KEEP8(29), id%N,
352 & id%IRN_loc(1), id%JCN_loc(1),
353 & sumr_loc, id%KEEP(1),id%KEEP8(1),
354 & eff_size_schur, id%SYM_PERM(1) )
355 ELSE
356 CALL dmumps_scal_x(id%A_loc(1),
357 & id%KEEP8(29), id%N,
358 & id%IRN_loc(1), id%JCN_loc(1),
359 & sumr_loc, id%KEEP(1),id%KEEP8(1),
360 & id%COLSCA(1),
361 & eff_size_schur, id%SYM_PERM(1) )
362 ENDIF
363 ELSE
364 sumr_loc = zero
365 ENDIF
366 IF ( id%MYID .eq. master ) THEN
367 CALL mpi_reduce( sumr_loc, sumr,
368 & id%N, mpi_double_precision,
369 & mpi_sum,master,id%COMM, ierr)
370 ELSE
371 CALL mpi_reduce( sumr_loc, dummy,
372 & id%N, mpi_double_precision,
373 & mpi_sum,master,id%COMM, ierr)
374 END IF
375 DEALLOCATE (sumr_loc)
376 ENDIF
377 IF ( id%MYID .eq. master ) THEN
378 anorminf = dble(zero)
379 IF (lscal) THEN
380 DO i = 1, id%N
381 anorminf = max(abs(id%ROWSCA(i) * sumr(i)),
382 & anorminf)
383 ENDDO
384 ELSE
385 DO i = 1, id%N
386 anorminf = max(abs(sumr(i)),
387 & anorminf)
388 ENDDO
389 ENDIF
390 ENDIF
391 CALL mpi_bcast(anorminf, 1,
392 & mpi_double_precision, master,
393 & id%COMM, ierr )
394 IF (id%MYID .eq. master) DEALLOCATE (sumr)
395 RETURN
396 END SUBROUTINE dmumps_anorminf
dmumps_fac_v
subroutine dmumps_fac_v(n, nz8, val, irn, icn, colsca, rowsca, mprint)
Definition dfac_scalings.F:191
dmumps_rowcol
subroutine dmumps_rowcol(n, nz8, irn, icn, val, rnor, cnor, colsca, rowsca, mprint)
Definition dfac_scalings.F:81
dmumps_anorminf
subroutine dmumps_anorminf(id, anorminf, lscal, eff_size_schur)
Definition dfac_scalings.F:274
dmumps_fac_x
subroutine dmumps_fac_x(nsca, n, nz8, irn, icn, val, rnor, rowsca, mprint)
Definition dfac_scalings.F:225
dmumps_fac_y
subroutine dmumps_fac_y(n, nz8, val, irn, icn, cnor, colsca, mprint)
Definition dfac_scalings.F:151
dmumps_fac_a
subroutine dmumps_fac_a(n, nz8, nsca, aspk, irn, icn, colsca, rowsca, wk, lwk8, wk_real, lwk_real, icntl, info)
Definition dfac_scalings.F:17
dmumps_sol_x_elt
subroutine dmumps_sol_x_elt(mtype, n, nelt, eltptr, leltvar, eltvar, na_elt8, a_elt, w, keep, keep8)
Definition dsol_aux.F:529
dmumps_scal_x
subroutine dmumps_scal_x(a, nz8, n, irn, icn, z, keep, keep8, colsca, eff_size_schur, sym_perm)
Definition dsol_aux.F:174
dmumps_sol_scalx_elt
subroutine dmumps_sol_scalx_elt(mtype, n, nelt, eltptr, leltvar, eltvar, na_elt8, a_elt, w, keep, keep8, colsca)
Definition dsol_aux.F:588
dmumps_sol_x
subroutine dmumps_sol_x(a, nz8, n, irn, icn, z, keep, keep8, eff_size_schur, sym_perm)
Definition dsol_aux.F:88
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_bcast
subroutine mpi_bcast(buffer, cnt, datatype, root, comm, ierr)
Definition mpi.f:205
dmumps_struc_def
Definition dmumps_struc_def.F:14