1C
2C  This file is part of MUMPS 5.1.2, released
3C  on Mon Oct  2 07:37:01 UTC 2017
4C
5C
6C  Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria,
7C  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  http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html
12C
13       SUBROUTINE CMUMPS_FAC_A(N, NZ8, NSCA,
14     &      ASPK, IRN, ICN, COLSCA, ROWSCA, WK, LWK8, WK_REAL,
15     &      LWK_REAL, ICNTL, INFO)
16       IMPLICIT NONE
17      INTEGER N, NSCA
18      INTEGER(8), INTENT(IN) :: NZ8
19      INTEGER IRN(NZ8), ICN(NZ8)
20      INTEGER ICNTL(40), INFO(40)
21      COMPLEX, INTENT(IN) :: ASPK(NZ8)
22      REAL COLSCA(*), ROWSCA(*)
23      INTEGER(8), INTENT(IN) :: LWK8
24      INTEGER LWK_REAL
25      COMPLEX    WK(LWK8)
26      REAL WK_REAL(LWK_REAL)
27      INTEGER MPG,LP
28      INTEGER IWNOR
29      INTEGER I
30      LOGICAL PROK
31      REAL ONE
32      PARAMETER( ONE = 1.0E0 )
33      LP      = ICNTL(1)
34      MPG     = ICNTL(2)
35      MPG    = ICNTL(3)
36      PROK   = ((MPG.GT.0).AND.(ICNTL(4).GE.2))
37      IF (PROK) THEN
38        WRITE(MPG,101)
39      ELSE
40        MPG = 0
41      ENDIF
42 101    FORMAT(/' ****** SCALING OF ORIGINAL MATRIX '/)
43        IF (NSCA.EQ.1) THEN
44         IF (PROK)
45     &    WRITE (MPG,*) ' DIAGONAL SCALING '
46        ELSEIF (NSCA.EQ.3) THEN
47         IF (PROK)
48     &   WRITE (MPG,*) ' COLUMN SCALING'
49        ELSEIF (NSCA.EQ.4) THEN
50         IF (PROK)
51     &   WRITE (MPG,*) ' ROW AND COLUMN SCALING (1 Pass)'
52       ENDIF
53        DO 10 I=1,N
54            COLSCA(I) = ONE
55            ROWSCA(I) = ONE
56 10     CONTINUE
57        IF (5*N.GT.LWK_REAL) GOTO 410
58        IWNOR = 1
59          IF (NSCA.EQ.1) THEN
60            CALL CMUMPS_FAC_V(N,NZ8,ASPK,IRN,ICN,
61     &        COLSCA,ROWSCA,MPG)
62          ELSEIF (NSCA.EQ.3) THEN
63            CALL CMUMPS_FAC_Y(N,NZ8,ASPK,IRN,ICN,WK_REAL(IWNOR),
64     &      COLSCA, MPG)
65          ELSEIF (NSCA.EQ.4) THEN
66            CALL CMUMPS_ROWCOL(N,NZ8,IRN,ICN,ASPK,
67     &      WK_REAL(IWNOR),WK_REAL(IWNOR+N),COLSCA,ROWSCA,MPG)
68          ENDIF
69      GOTO 500
70 410  INFO(1) = -5
71      INFO(2) = 5*N-LWK_REAL
72      IF ((LP.GT.0).AND.(ICNTL(4).GE.1))
73     & WRITE(LP,*) '*** ERROR: Not enough space to scale matrix'
74      GOTO 500
75 500  CONTINUE
76      RETURN
77      END SUBROUTINE CMUMPS_FAC_A
78      SUBROUTINE CMUMPS_ROWCOL(N,NZ8,IRN,ICN,VAL,
79     &    RNOR,CNOR,COLSCA,ROWSCA,MPRINT)
80      INTEGER,    INTENT(IN) :: N
81      INTEGER(8), INTENT(IN) :: NZ8
82      COMPLEX    VAL(NZ8)
83      REAL    RNOR(N),CNOR(N)
84      REAL    COLSCA(N),ROWSCA(N)
85      REAL    CMIN,CMAX,RMIN,ARNOR,ACNOR
86      INTEGER IRN(NZ8), ICN(NZ8)
87      REAL    VDIAG
88      INTEGER MPRINT
89      INTEGER I,J
90      INTEGER(8) :: K8
91      REAL ZERO, ONE
92      PARAMETER(ZERO=0.0E0, ONE=1.0E0)
93      DO 50 J=1,N
94       CNOR(J)   = ZERO
95       RNOR(J)   = ZERO
96  50  CONTINUE
97      DO 100 K8=1_8,NZ8
98          I = IRN(K8)
99          J = ICN(K8)
100          IF ((I.LE.0).OR.(I.GT.N).OR.
101     &        (J.LE.0).OR.(J.GT.N)) GOTO 100
102            VDIAG = abs(VAL(K8))
103            IF (VDIAG.GT.CNOR(J)) THEN
104              CNOR(J) =     VDIAG
105            ENDIF
106            IF (VDIAG.GT.RNOR(I)) THEN
107              RNOR(I) =     VDIAG
108            ENDIF
109 100   CONTINUE
110      IF (MPRINT.GT.0) THEN
111       CMIN = CNOR(1)
112       CMAX = CNOR(1)
113       RMIN = RNOR(1)
114       DO 111 I=1,N
115        ARNOR = RNOR(I)
116        ACNOR = CNOR(I)
117        IF (ACNOR.GT.CMAX) CMAX=ACNOR
118        IF (ACNOR.LT.CMIN) CMIN=ACNOR
119        IF (ARNOR.LT.RMIN) RMIN=ARNOR
120 111   CONTINUE
121       WRITE(MPRINT,*) '**** STAT. OF MATRIX PRIOR ROW&COL SCALING'
122       WRITE(MPRINT,*) ' MAXIMUM NORM-MAX OF COLUMNS:',CMAX
123       WRITE(MPRINT,*) ' MINIMUM NORM-MAX OF COLUMNS:',CMIN
124       WRITE(MPRINT,*) ' MINIMUM NORM-MAX OF ROWS   :',RMIN
125      ENDIF
126      DO 120 J=1,N
127       IF (CNOR(J).LE.ZERO) THEN
128         CNOR(J)   = ONE
129       ELSE
130         CNOR(J)   = ONE / CNOR(J)
131       ENDIF
132 120  CONTINUE
133      DO 130 J=1,N
134       IF (RNOR(J).LE.ZERO) THEN
135         RNOR(J)   = ONE
136       ELSE
137         RNOR(J)   = ONE / RNOR(J)
138       ENDIF
139 130  CONTINUE
140       DO 110 I=1,N
141        ROWSCA(I) = ROWSCA(I) * RNOR(I)
142        COLSCA(I) = COLSCA(I) * CNOR(I)
143 110   CONTINUE
144      IF (MPRINT.GT.0)
145     &  WRITE(MPRINT,*) ' END OF SCALING BY MAX IN ROW AND COL'
146      RETURN
147      END SUBROUTINE CMUMPS_ROWCOL
148      SUBROUTINE CMUMPS_FAC_Y(N,NZ8,VAL,IRN,ICN,
149     &       CNOR,COLSCA,MPRINT)
150      INTEGER,    INTENT(IN)  :: N
151      INTEGER(8), INTENT(IN)  :: NZ8
152      COMPLEX,    INTENT(IN)  :: VAL(NZ8)
153      REAL,       INTENT(OUT) :: CNOR(N)
154      REAL,       INTENT(OUT) :: COLSCA(N)
155      INTEGER,    INTENT(IN)  :: IRN(NZ8), ICN(NZ8)
156      INTEGER,    INTENT(IN)  :: MPRINT
157      REAL VDIAG
158      INTEGER I,J
159      INTEGER(8) :: K8
160      REAL ZERO, ONE
161      PARAMETER (ZERO=0.0E0,ONE=1.0E0)
162      DO 10 J=1,N
163       CNOR(J)   = ZERO
164  10  CONTINUE
165      DO 100 K8=1_8,NZ8
166        I = IRN(K8)
167        J = ICN(K8)
168        IF ((I.LE.0).OR.(I.GT.N).OR.
169     &      (J.LE.0).OR.(J.GT.N)) GOTO 100
170        VDIAG = abs(VAL(K8))
171        IF (VDIAG.GT.CNOR(J)) THEN
172           CNOR(J) =     VDIAG
173        ENDIF
174 100  CONTINUE
175      DO 110 J=1,N
176       IF (CNOR(J).LE.ZERO) THEN
177         CNOR(J)   = ONE
178       ELSE
179         CNOR(J)   = ONE/CNOR(J)
180       ENDIF
181 110  CONTINUE
182       DO 215 I=1,N
183        COLSCA(I) = COLSCA(I) * CNOR(I)
184 215   CONTINUE
185      IF (MPRINT.GT.0) WRITE(MPRINT,*) ' END OF COLUMN SCALING'
186      RETURN
187      END SUBROUTINE CMUMPS_FAC_Y
188      SUBROUTINE CMUMPS_FAC_V(N,NZ8,VAL,IRN,ICN,
189     &      COLSCA,ROWSCA,MPRINT)
190      INTEGER   , INTENT(IN)  :: N
191      INTEGER(8), INTENT(IN)  :: NZ8
192      COMPLEX   , INTENT(IN)  :: VAL(NZ8)
193      REAL      , INTENT(OUT) :: ROWSCA(N),COLSCA(N)
194      INTEGER   , INTENT(IN)  :: IRN(NZ8),ICN(NZ8)
195      INTEGER   , INTENT(IN)  :: MPRINT
196      REAL       :: VDIAG
197      INTEGER    :: I,J
198      INTEGER(8) :: K8
199      INTRINSIC sqrt
200      REAL ZERO, ONE
201      PARAMETER(ZERO=0.0E0, ONE=1.0E0)
202      DO 10 I=1,N
203       ROWSCA(I)   = ONE
204  10  CONTINUE
205      DO 100 K8=1_8,NZ8
206          I = IRN(K8)
207          IF ((I.GT.N).OR.(I.LE.0)) GOTO 100
208          J = ICN(K8)
209          IF (I.EQ.J) THEN
210            VDIAG = abs(VAL(K8))
211            IF (VDIAG.GT.ZERO) THEN
212              ROWSCA(J) = ONE/(sqrt(VDIAG))
213            ENDIF
214          ENDIF
215 100   CONTINUE
216       DO 110 I=1,N
217        COLSCA(I) = ROWSCA(I)
218 110   CONTINUE
219      IF (MPRINT.GT.0) WRITE(MPRINT,*) ' END OF DIAGONAL SCALING'
220      RETURN
221      END SUBROUTINE CMUMPS_FAC_V
222      SUBROUTINE CMUMPS_FAC_X(NSCA,N,NZ8,IRN,ICN,VAL,
223     &    RNOR,ROWSCA,MPRINT)
224      INTEGER,    INTENT(IN) :: N, NSCA
225      INTEGER(8), INTENT(IN) :: NZ8
226      INTEGER,    INTENT(IN) :: IRN(NZ8), ICN(NZ8)
227      COMPLEX VAL(NZ8)
228      REAL RNOR(N)
229      REAL ROWSCA(N)
230      INTEGER MPRINT
231      REAL VDIAG
232      INTEGER I,J
233      INTEGER(8) :: K8
234      REAL, PARAMETER :: ZERO = 0.0E0
235      REAL, PARAMETER :: ONE  = 1.0E0
236      DO 50 J=1,N
237       RNOR(J)   = ZERO
238  50  CONTINUE
239      DO 100 K8=1_8,NZ8
240          I = IRN(K8)
241          J = ICN(K8)
242          IF ((I.LE.0).OR.(I.GT.N).OR.
243     &        (J.LE.0).OR.(J.GT.N)) GOTO 100
244            VDIAG = abs(VAL(K8))
245            IF (VDIAG.GT.RNOR(I)) THEN
246              RNOR(I) =  VDIAG
247            ENDIF
248 100   CONTINUE
249      DO 130 J=1,N
250       IF (RNOR(J).LE.ZERO) THEN
251         RNOR(J)   = ONE
252       ELSE
253         RNOR(J)   = ONE/RNOR(J)
254       ENDIF
255 130  CONTINUE
256      DO 110 I=1,N
257        ROWSCA(I) = ROWSCA(I)* RNOR(I)
258 110  CONTINUE
259      IF ( (NSCA.EQ.4) .OR. (NSCA.EQ.6) ) THEN
260        DO 150 K8 = 1_8, NZ8
261          I   = IRN(K8)
262          J   = ICN(K8)
263          IF (min(I,J).LT.1 .OR. I.GT.N .OR. J.GT.N) GOTO 150
264          VAL(K8) = VAL(K8) * RNOR(I)
265 150    CONTINUE
266      ENDIF
267      IF (MPRINT.GT.0)
268     &  WRITE(MPRINT,'(A)') '  END OF ROW SCALING'
269      RETURN
270      END SUBROUTINE CMUMPS_FAC_X
271      SUBROUTINE CMUMPS_ANORMINF( id,  ANORMINF, LSCAL )
272      USE CMUMPS_STRUC_DEF
273      IMPLICIT NONE
274      INCLUDE 'mpif.h'
275      INTEGER MASTER, IERR
276      PARAMETER( MASTER = 0 )
277      TYPE(CMUMPS_STRUC), TARGET :: id
278      REAL, INTENT(OUT) :: ANORMINF
279      LOGICAL :: LSCAL
280      INTEGER, DIMENSION (:), POINTER :: KEEP,INFO
281      INTEGER(8), DIMENSION (:), POINTER :: KEEP8
282      LOGICAL :: I_AM_SLAVE
283      COMPLEX DUMMY(1)
284      REAL ZERO
285      PARAMETER( ZERO = 0.0E0)
286      REAL, ALLOCATABLE :: SUMR(:), SUMR_LOC(:)
287      INTEGER :: allocok, MTYPE, I
288      INFO =>id%INFO
289      KEEP =>id%KEEP
290      KEEP8 =>id%KEEP8
291      I_AM_SLAVE = ( id%MYID .ne. MASTER  .OR.
292     &             ( id%MYID .eq. MASTER .AND.
293     &               KEEP(46) .eq. 1 ) )
294      IF (id%MYID .EQ. MASTER) THEN
295       ALLOCATE( SUMR( id%N ), stat =allocok )
296       IF (allocok .GT.0 ) THEN
297        id%INFO(1)=-13
298        id%INFO(2)=id%N
299        RETURN
300       ENDIF
301      ENDIF
302      IF ( KEEP(54) .eq. 0 ) THEN
303          IF (id%MYID .EQ. MASTER) THEN
304            IF (KEEP(55).EQ.0) THEN
305             IF (.NOT.LSCAL) THEN
306              CALL CMUMPS_SOL_X(id%A(1),
307     &          id%KEEP8(28), id%N,
308     &          id%IRN(1), id%JCN(1),
309     &          SUMR, KEEP(1),KEEP8(1) )
310             ELSE
311              CALL CMUMPS_SCAL_X(id%A(1),
312     &          id%KEEP8(28), id%N,
313     &          id%IRN(1), id%JCN(1),
314     &          SUMR, KEEP(1), KEEP8(1),
315     &          id%COLSCA(1))
316             ENDIF
317            ELSE
318             MTYPE = 1
319             IF (.NOT.LSCAL) THEN
320              CALL CMUMPS_SOL_X_ELT(MTYPE, id%N,
321     &           id%NELT, id%ELTPTR(1),
322     &           id%LELTVAR, id%ELTVAR(1),
323     &           id%KEEP8(30),
324     &           id%A_ELT(1), SUMR, KEEP(1),KEEP8(1) )
325             ELSE
326              CALL CMUMPS_SOL_SCALX_ELT(MTYPE, id%N,
327     &           id%NELT, id%ELTPTR(1),
328     &           id%LELTVAR, id%ELTVAR(1),
329     &           id%KEEP8(30),
330     &           id%A_ELT(1),
331     &           SUMR, KEEP(1),KEEP8(1), id%COLSCA(1))
332             ENDIF
333            ENDIF
334          ENDIF
335      ELSE
336          ALLOCATE( SUMR_LOC( id%N ), stat =allocok )
337          IF (allocok .GT.0 ) THEN
338             id%INFO(1)=-13
339             id%INFO(2)=id%N
340             RETURN
341          ENDIF
342          IF ( I_AM_SLAVE .and.
343     &           id%KEEP8(29) .NE. 0 ) THEN
344           IF (.NOT.LSCAL) THEN
345              CALL CMUMPS_SOL_X(id%A_loc(1),
346     &          id%KEEP8(29), id%N,
347     &          id%IRN_loc(1), id%JCN_loc(1),
348     &          SUMR_LOC, id%KEEP(1),id%KEEP8(1) )
349           ELSE
350              CALL CMUMPS_SCAL_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     &          id%COLSCA(1))
355           ENDIF
356          ELSE
357           SUMR_LOC = ZERO
358          ENDIF
359          IF ( id%MYID .eq. MASTER ) THEN
360              CALL MPI_REDUCE( SUMR_LOC, SUMR,
361     &        id%N, MPI_REAL,
362     &        MPI_SUM,MASTER,id%COMM, IERR)
363          ELSE
364              CALL MPI_REDUCE( SUMR_LOC, DUMMY,
365     &        id%N, MPI_REAL,
366     &        MPI_SUM,MASTER,id%COMM, IERR)
367          END IF
368        DEALLOCATE (SUMR_LOC)
369      ENDIF
370      IF ( id%MYID .eq. MASTER ) THEN
371       ANORMINF = real(ZERO)
372        IF (LSCAL) THEN
373         DO I = 1, id%N
374          ANORMINF = max(abs(id%ROWSCA(I) * SUMR(I)),
375     &                  ANORMINF)
376         ENDDO
377        ELSE
378         DO I = 1, id%N
379          ANORMINF = max(abs(SUMR(I)),
380     &                  ANORMINF)
381         ENDDO
382        ENDIF
383      ENDIF
384      CALL MPI_BCAST(ANORMINF, 1,
385     &              MPI_REAL, MASTER,
386     &              id%COMM, IERR )
387      IF (id%MYID .eq. MASTER) DEALLOCATE (SUMR)
388      RETURN
389      END SUBROUTINE CMUMPS_ANORMINF
390