OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
zfac_scalings.F File Reference

Go to the source code of this file.

Functions/Subroutines

subroutine zmumps_fac_a (n, nz8, nsca, aspk, irn, icn, colsca, rowsca, wk, lwk8, wk_real, lwk_real, icntl, info)
subroutine zmumps_rowcol (n, nz8, irn, icn, val, rnor, cnor, colsca, rowsca, mprint)
subroutine zmumps_fac_y (n, nz8, val, irn, icn, cnor, colsca, mprint)
subroutine zmumps_fac_v (n, nz8, val, irn, icn, colsca, rowsca, mprint)
subroutine zmumps_fac_x (nsca, n, nz8, irn, icn, val, rnor, rowsca, mprint)
subroutine zmumps_anorminf (id, anorminf, lscal, eff_size_schur)

Function/Subroutine Documentation

◆ zmumps_anorminf()

subroutine zmumps_anorminf ( type(zmumps_struc), target id,
double precision, intent(out) anorminf,
logical, intent(in) lscal,
integer, intent(in) eff_size_schur )

Definition at line 272 of file zfac_scalings.F.

274 USE zmumps_struc_def
275 IMPLICIT NONE
276 include 'mpif.h'
277 INTEGER MASTER, IERR
278 parameter( master = 0 )
279 TYPE(ZMUMPS_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 COMPLEX(kind=8) 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 zmumps_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 zmumps_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 zmumps_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 zmumps_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 zmumps_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 zmumps_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
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
id
initmumps id
Definition multiplerhs_example.m:4
zmumps_struc_def
Definition zmumps_struc_def.F:14
zmumps_scal_x
subroutine zmumps_scal_x(a, nz8, n, irn, icn, z, keep, keep8, colsca, eff_size_schur, sym_perm)
Definition zsol_aux.F:174
zmumps_sol_x
subroutine zmumps_sol_x(a, nz8, n, irn, icn, z, keep, keep8, eff_size_schur, sym_perm)
Definition zsol_aux.F:88
zmumps_sol_x_elt
subroutine zmumps_sol_x_elt(mtype, n, nelt, eltptr, leltvar, eltvar, na_elt8, a_elt, w, keep, keep8)
Definition zsol_aux.F:530
zmumps_sol_scalx_elt
subroutine zmumps_sol_scalx_elt(mtype, n, nelt, eltptr, leltvar, eltvar, na_elt8, a_elt, w, keep, keep8, colsca)
Definition zsol_aux.F:589

◆ zmumps_fac_a()

subroutine zmumps_fac_a ( integer n,
integer(8), intent(in) nz8,
integer nsca,
complex(kind=8), dimension(nz8), intent(in) aspk,
integer, dimension(nz8) irn,
integer, dimension(nz8) icn,
double precision, dimension(*) colsca,
double precision, dimension(*) rowsca,
complex(kind=8), dimension(lwk8) wk,
integer(8), intent(in) lwk8,
double precision, dimension(lwk_real) wk_real,
integer lwk_real,
integer, dimension(60) icntl,
integer, dimension(80) info )

Definition at line 14 of file zfac_scalings.F.

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 COMPLEX(kind=8), INTENT(IN) :: ASPK(NZ8)
23 DOUBLE PRECISION COLSCA(*), ROWSCA(*)
24 INTEGER(8), INTENT(IN) :: LWK8
25 INTEGER LWK_REAL
26 COMPLEX(kind=8) 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 zmumps_fac_v(n,nz8,aspk,irn,icn,
62 & colsca,rowsca,mpg)
63 ELSEIF (nsca.EQ.3) THEN
64 CALL zmumps_fac_y(n,nz8,aspk,irn,icn,wk_real(iwnor),
65 & colsca, mpg)
66 ELSEIF (nsca.EQ.4) THEN
67 CALL zmumps_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
zmumps_rowcol
subroutine zmumps_rowcol(n, nz8, irn, icn, val, rnor, cnor, colsca, rowsca, mprint)
Definition zfac_scalings.F:81
zmumps_fac_y
subroutine zmumps_fac_y(n, nz8, val, irn, icn, cnor, colsca, mprint)
Definition zfac_scalings.F:151
zmumps_fac_v
subroutine zmumps_fac_v(n, nz8, val, irn, icn, colsca, rowsca, mprint)
Definition zfac_scalings.F:191

◆ zmumps_fac_v()

subroutine zmumps_fac_v ( integer, intent(in) n,
integer(8), intent(in) nz8,
complex(kind=8), dimension(nz8), intent(in) val,
integer, dimension(nz8), intent(in) irn,
integer, dimension(nz8), intent(in) icn,
double precision, dimension(n), intent(out) colsca,
double precision, dimension(n), intent(out) rowsca,
integer, intent(in) mprint )

Definition at line 189 of file zfac_scalings.F.

191 INTEGER , INTENT(IN) :: N
192 INTEGER(8), INTENT(IN) :: NZ8
193 COMPLEX(kind=8) , 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

◆ zmumps_fac_x()

subroutine zmumps_fac_x ( integer, intent(in) nsca,
integer, intent(in) n,
integer(8), intent(in) nz8,
integer, dimension(nz8), intent(in) irn,
integer, dimension(nz8), intent(in) icn,
complex(kind=8), dimension(nz8) val,
double precision, dimension(n) rnor,
double precision, dimension(n) rowsca,
integer mprint )

Definition at line 223 of file zfac_scalings.F.

225 INTEGER, INTENT(IN) :: N, NSCA
226 INTEGER(8), INTENT(IN) :: NZ8
227 INTEGER, INTENT(IN) :: IRN(NZ8), ICN(NZ8)
228 COMPLEX(kind=8) 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
min
#define min(a, b)
Definition macros.h:20

◆ zmumps_fac_y()

subroutine zmumps_fac_y ( integer, intent(in) n,
integer(8), intent(in) nz8,
complex(kind=8), dimension(nz8), intent(in) val,
integer, dimension(nz8), intent(in) irn,
integer, dimension(nz8), intent(in) icn,
double precision, dimension(n), intent(out) cnor,
double precision, dimension(n), intent(inout) colsca,
integer, intent(in) mprint )

Definition at line 149 of file zfac_scalings.F.

151 INTEGER, INTENT(IN) :: N
152 INTEGER(8), INTENT(IN) :: NZ8
153 COMPLEX(kind=8), 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

◆ zmumps_rowcol()

subroutine zmumps_rowcol ( integer, intent(in) n,
integer(8), intent(in) nz8,
integer, dimension(nz8) irn,
integer, dimension(nz8) icn,
complex(kind=8), dimension(nz8) val,
double precision, dimension(n) rnor,
double precision, dimension(n) cnor,
double precision, dimension(n) colsca,
double precision, dimension(n) rowsca,
integer mprint )

Definition at line 79 of file zfac_scalings.F.

81 INTEGER, INTENT(IN) :: N
82 INTEGER(8), INTENT(IN) :: NZ8
83 COMPLEX(kind=8) 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