OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
cfac_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 cmumps_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 COMPLEX, INTENT(IN) :: ASPK(NZ8)
23 REAL COLSCA(*), ROWSCA(*)
24 INTEGER(8), INTENT(IN) :: LWK8
25 INTEGER LWK_REAL
26 COMPLEX WK(LWK8)
27 REAL WK_REAL(LWK_REAL)
28 INTEGER MPG,LP
29 INTEGER IWNOR
30 INTEGER I
31 LOGICAL PROK
32 REAL ONE
33 parameter( one = 1.0e0 )
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 cmumps_fac_v(n,nz8,aspk,irn,icn,
62 & colsca,rowsca,mpg)
63 ELSEIF (nsca.EQ.3) THEN
64 CALL cmumps_fac_y(n,nz8,aspk,irn,icn,wk_real(iwnor),
65 & colsca, mpg)
66 ELSEIF (nsca.EQ.4) THEN
67 CALL cmumps_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 CMUMPS_FAC_A
79 SUBROUTINE CMUMPS_ROWCOL(N,NZ8,IRN,ICN,VAL,
80 & RNOR,CNOR,COLSCA,ROWSCA,MPRINT)
81 INTEGER, INTENT(IN) :: N
82 INTEGER(8), INTENT(IN) :: NZ8
83 COMPLEX VAL(NZ8)
84 REAL RNOR(N),CNOR(N)
85 REAL COLSCA(N),ROWSCA(N)
86 REAL CMIN,CMAX,RMIN,ARNOR,ACNOR
87 INTEGER IRN(NZ8), ICN(NZ8)
88 REAL VDIAG
89 INTEGER MPRINT
90 INTEGER I,J
91 INTEGER(8) :: K8
92 REAL ZERO, ONE
93 PARAMETER(ZERO=0.0E0, ONE=1.0E0)
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.LE..OR..GT..OR. IF ((I0)(IN)
102.LE..OR..GT. & (J0)(JN)) GOTO 100
103 VDIAG = abs(VAL(K8))
104.GT. IF (VDIAGCNOR(J)) THEN
105 CNOR(J) = VDIAG
106 ENDIF
107.GT. IF (VDIAGRNOR(I)) THEN
108 RNOR(I) = VDIAG
109 ENDIF
110 100 CONTINUE
111.GT. IF (MPRINT0) 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.GT. IF (ACNORCMAX) CMAX=ACNOR
119.LT. IF (ACNORCMIN) CMIN=ACNOR
120.LT. IF (ARNORRMIN) 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.LE. IF (CNOR(J)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.LE. IF (RNOR(J)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.GT. IF (MPRINT0)
146 & WRITE(MPRINT,*) ' END OF SCALING BY MAX IN ROW AND COL'
147 RETURN
148 END SUBROUTINE CMUMPS_ROWCOL
149 SUBROUTINE CMUMPS_FAC_Y(N,NZ8,VAL,IRN,ICN,
150 & CNOR,COLSCA,MPRINT)
151 INTEGER, INTENT(IN) :: N
152 INTEGER(8), INTENT(IN) :: NZ8
153 COMPLEX, INTENT(IN) :: VAL(NZ8)
154 REAL, INTENT(OUT) :: CNOR(N)
155 REAL, INTENT(INOUT) :: COLSCA(N)
156 INTEGER, INTENT(IN) :: IRN(NZ8), ICN(NZ8)
157 INTEGER, INTENT(IN) :: MPRINT
158 REAL VDIAG
159 INTEGER I,J
160 INTEGER(8) :: K8
161 REAL ZERO, ONE
162 PARAMETER (ZERO=0.0E0,ONE=1.0E0)
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.LE..OR..GT..OR. IF ((I0)(IN)
170.LE..OR..GT. & (J0)(JN)) GOTO 100
171 VDIAG = abs(VAL(K8))
172.GT. IF (VDIAGCNOR(J)) THEN
173 CNOR(J) = VDIAG
174 ENDIF
175 100 CONTINUE
176 DO 110 J=1,N
177.LE. IF (CNOR(J)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.GT. IF (MPRINT0) WRITE(MPRINT,*) ' END OF COLUMN SCALING'
187 RETURN
188 END SUBROUTINE CMUMPS_FAC_Y
189 SUBROUTINE CMUMPS_FAC_V(N,NZ8,VAL,IRN,ICN,
190 & COLSCA,ROWSCA,MPRINT)
191 INTEGER , INTENT(IN) :: N
192 INTEGER(8), INTENT(IN) :: NZ8
193 COMPLEX , INTENT(IN) :: VAL(NZ8)
194 REAL , INTENT(OUT) :: ROWSCA(N),COLSCA(N)
195 INTEGER , INTENT(IN) :: IRN(NZ8),ICN(NZ8)
196 INTEGER , INTENT(IN) :: MPRINT
197 REAL :: VDIAG
198 INTEGER :: I,J
199 INTEGER(8) :: K8
200 INTRINSIC sqrt
201 REAL ZERO, ONE
202 PARAMETER(ZERO=0.0E0, ONE=1.0E0)
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.GT..OR..LE. IF ((IN)(I0)) GOTO 100
209 J = ICN(K8)
210.EQ. IF (IJ) THEN
211 VDIAG = abs(VAL(K8))
212.GT. IF (VDIAGZERO) 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.GT. IF (MPRINT0) WRITE(MPRINT,*) ' END OF DIAGONAL SCALING'
221 RETURN
222 END SUBROUTINE CMUMPS_FAC_V
223 SUBROUTINE CMUMPS_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 COMPLEX VAL(NZ8)
229 REAL RNOR(N)
230 REAL ROWSCA(N)
231 INTEGER MPRINT
232 REAL VDIAG
233 INTEGER I,J
234 INTEGER(8) :: K8
235 REAL, PARAMETER :: ZERO = 0.0E0
236 REAL, PARAMETER :: ONE = 1.0E0
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.LE..OR..GT..OR. IF ((I0)(IN)
244.LE..OR..GT. & (J0)(JN)) GOTO 100
245 VDIAG = abs(VAL(K8))
246.GT. IF (VDIAGRNOR(I)) THEN
247 RNOR(I) = VDIAG
248 ENDIF
249 100 CONTINUE
250 DO 130 J=1,N
251.LE. IF (RNOR(J)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.EQ..OR..EQ. IF ( (NSCA4) (NSCA6) ) THEN
261 DO 150 K8 = 1_8, NZ8
262 I = IRN(K8)
263 J = ICN(K8)
264.LT..OR..GT..OR..GT. IF (min(I,J)1 IN JN) GOTO 150
265 VAL(K8) = VAL(K8) * RNOR(I)
266 150 CONTINUE
267 ENDIF
268.GT. IF (MPRINT0)
269 & WRITE(MPRINT,'(A)') ' END OF ROW SCALING'
270 RETURN
271 END SUBROUTINE CMUMPS_FAC_X
272 SUBROUTINE CMUMPS_ANORMINF( id, ANORMINF, LSCAL,
273 & EFF_SIZE_SCHUR )
274 USE CMUMPS_STRUC_DEF
275 IMPLICIT NONE
276 INCLUDE 'mpif.h'
277 INTEGER MASTER, IERR
278 PARAMETER( MASTER = 0 )
279 TYPE(CMUMPS_STRUC), TARGET :: id
280 REAL, 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 DUMMY(1)
287 REAL ZERO
288 PARAMETER( ZERO = 0.0E0)
289 REAL, ALLOCATABLE :: SUMR(:), SUMR_LOC(:)
290 INTEGER :: allocok, MTYPE, I
291 INFO =>id%INFO
292 KEEP =>id%KEEP
293 KEEP8 =>id%KEEP8
294.ne..OR. I_AM_SLAVE = ( id%MYID MASTER
295.eq..AND. & ( id%MYID MASTER
296.eq. & KEEP(46) 1 ) )
297.EQ. IF (id%MYID MASTER) THEN
298 ALLOCATE( SUMR( id%N ), stat =allocok )
299.GT. IF (allocok 0 ) THEN
300 id%INFO(1)=-13
301 id%INFO(2)=id%N
302 RETURN
303 ENDIF
304 ENDIF
305.eq. IF ( KEEP(54) 0 ) THEN
306.EQ. IF (id%MYID MASTER) THEN
307.EQ. IF (KEEP(55)0) THEN
308.NOT. IF (LSCAL) THEN
309 CALL CMUMPS_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 CMUMPS_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.NOT. IF (LSCAL) THEN
325 CALL CMUMPS_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 CMUMPS_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.GT. IF (allocok 0 ) THEN
343 id%INFO(1)=-13
344 id%INFO(2)=id%N
345 RETURN
346 ENDIF
347.and. IF ( I_AM_SLAVE
348.NE. & id%KEEP8(29) 0 ) THEN
349.NOT. IF (LSCAL) THEN
350 CALL CMUMPS_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 CMUMPS_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.eq. IF ( id%MYID MASTER ) THEN
367 CALL MPI_REDUCE( SUMR_LOC, SUMR,
368 & id%N, MPI_REAL,
369 & MPI_SUM,MASTER,id%COMM, IERR)
370 ELSE
371 CALL MPI_REDUCE( SUMR_LOC, DUMMY,
372 & id%N, MPI_REAL,
373 & MPI_SUM,MASTER,id%COMM, IERR)
374 END IF
375 DEALLOCATE (SUMR_LOC)
376 ENDIF
377.eq. IF ( id%MYID MASTER ) THEN
378 ANORMINF = real(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_REAL, MASTER,
393 & id%COMM, IERR )
394.eq. IF (id%MYID MASTER) DEALLOCATE (SUMR)
395 RETURN
396 END SUBROUTINE CMUMPS_ANORMINF
cmumps_fac_y
subroutine cmumps_fac_y(n, nz8, val, irn, icn, cnor, colsca, mprint)
Definition cfac_scalings.F:151
cmumps_fac_a
subroutine cmumps_fac_a(n, nz8, nsca, aspk, irn, icn, colsca, rowsca, wk, lwk8, wk_real, lwk_real, icntl, info)
Definition cfac_scalings.F:17
cmumps_rowcol
subroutine cmumps_rowcol(n, nz8, irn, icn, val, rnor, cnor, colsca, rowsca, mprint)
Definition cfac_scalings.F:81
cmumps_fac_v
subroutine cmumps_fac_v(n, nz8, val, irn, icn, colsca, rowsca, mprint)
Definition cfac_scalings.F:191
norm
norm(diag(diag(diag(inv(mat))) -id.SOL), 2) % destroy mumps instance id.JOB
max
#define max(a, b)
Definition macros.h:21