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 DMUMPS_ANA_F(N, NZ8, IRN, ICN, LIW8, IKEEP,
14     &     IORD, NFSIZ, FILS, FRERE, LISTVAR_SCHUR, SIZE_SCHUR,
15     &     ICNTL, INFO, KEEP,KEEP8, NSLAVES, PIV, id)
16      USE DMUMPS_STRUC_DEF
17      USE MUMPS_ANA_ORD_WRAPPERS
18      IMPLICIT NONE
19      INTEGER, INTENT(IN)    :: N,  SIZE_SCHUR, NSLAVES
20      INTEGER(8), INTENT(IN) :: NZ8
21      INTEGER(8), INTENT(IN) :: LIW8
22      INTEGER, INTENT(IN)    :: LISTVAR_SCHUR(SIZE_SCHUR)
23      INTEGER, INTENT(IN)    :: IRN(NZ8)
24      INTEGER, INTENT(IN)    :: ICNTL(40)
25      INTEGER, INTENT(INOUT) :: ICN(NZ8)
26      INTEGER, INTENT(INOUT) :: IORD
27      INTEGER, INTENT(INOUT) :: IKEEP(N,3)
28      INTEGER, INTENT(OUT)   :: NFSIZ(N), FILS(N), FRERE(N)
29      INTEGER, INTENT(INOUT) :: INFO(40), KEEP(500)
30      INTEGER(8), INTENT(INOUT) :: KEEP8(150)
31      TYPE (DMUMPS_STRUC) :: id
32      INTEGER, DIMENSION(:), ALLOCATABLE :: IW
33      INTEGER(8), DIMENSION(:), ALLOCATABLE :: IPE
34      INTEGER(8), DIMENSION(:), ALLOCATABLE :: IPQ8
35      INTEGER, DIMENSION(:,:), ALLOCATABLE :: PTRAR
36      INTEGER, DIMENSION(:), ALLOCATABLE   :: PARENT
37      INTEGER, DIMENSION(:), ALLOCATABLE   :: IWL1
38      INTEGER NBBUCK
39      INTEGER, DIMENSION(:), ALLOCATABLE :: WTEMP
40      INTEGER IERR
41      INTEGER I, K, NCMPA, IN, IFSON
42      INTEGER(8) :: J8, I8
43      INTEGER(8) IWFR8
44      INTEGER NEMIN, LP, MP, LDIAG, ITEMP, symmetry
45      INTEGER NBQD, AvgDens
46      LOGICAL PROK, COMPRESS_SCHUR, LPOK
47#if defined(metis4) || defined(parmetis3)
48      INTEGER NUMFLAG
49#endif
50#if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3)
51      INTEGER METIS_IDX_SIZE
52      INTEGER OPT_METIS_SIZE
53      INTEGER, DIMENSION(:), ALLOCATABLE :: OPTIONS_METIS
54#endif
55#if defined(scotch) || defined(ptscotch)
56      INTEGER :: SCOTCH_INT_SIZE
57#endif
58#if defined(pord)
59      INTEGER :: PORD_INT_SIZE
60#endif
61      DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: COLSCA_TEMP
62      INTEGER THRESH, IVersion
63      LOGICAL AGG6
64      INTEGER MINSYM
65      PARAMETER (MINSYM=50)
66      INTEGER(8) :: K79REF
67      PARAMETER(K79REF=12000000_8)
68      INTEGER PIV(N)
69      INTEGER MTRANS, COMPRESS,NCMP,IERROR,J,JPERM,NCST
70      INTEGER TOTEL
71      LOGICAL IDENT,SPLITROOT
72      DOUBLE PRECISION TIMEB
73      EXTERNAL MUMPS_ANA_H, DMUMPS_ANA_J,
74     &     DMUMPS_ANA_K, DMUMPS_ANA_GNEW,
75     &     DMUMPS_ANA_LNEW, DMUMPS_ANA_M
76#if defined(OLDDFS)
77      EXTERNAL DMUMPS_ANA_L
78#endif
79      EXTERNAL DMUMPS_GNEW_SCHUR
80      EXTERNAL DMUMPS_LDLT_COMPRESS, DMUMPS_EXPAND_PERMUTATION,
81     &     DMUMPS_SET_CONSTRAINTS
82      ALLOCATE( IW (LIW8), stat = IERR )
83      IF ( IERR .GT. 0 ) THEN
84         INFO( 1 ) = -7
85         CALL MUMPS_SET_IERROR(LIW8,INFO(2))
86         GOTO 90
87      ENDIF
88      ALLOCATE( IWL1 (N), stat = IERR )
89      IF ( IERR .GT. 0 ) THEN
90         INFO( 1 ) = -7
91         INFO( 2 ) = N
92         GOTO 90
93      ENDIF
94      ALLOCATE( IPE(N+1), stat = IERR )
95      IF ( IERR .GT. 0 ) THEN
96         INFO( 1 ) = -7
97         INFO( 2 ) = (N+1)*KEEP(10)
98         GOTO 90
99      ENDIF
100      ALLOCATE( PTRAR (N,3), stat = IERR )
101      IF ( IERR .GT. 0 ) THEN
102         INFO( 1 ) = -7
103         INFO( 2 ) = 3*N
104         GOTO 90
105      ENDIF
106      LP    = ICNTL(1)
107      MP    = ICNTL(3)
108      LPOK  = ((LP.GT.0).AND.(ICNTL(4).GE.1))
109      PROK  = ((MP.GT.0).AND.(ICNTL(4).GE.2))
110      LDIAG = ICNTL(4)
111      COMPRESS_SCHUR = .FALSE.
112      IF (KEEP(1).LT.0) KEEP(1) = 0
113      NEMIN = KEEP(1)
114      IF (LDIAG.GT.2 .AND. MP.GT.0) THEN
115         WRITE (MP,99999) N, NZ8, LIW8, INFO(1)
116         J8 = min(10_8,NZ8)
117         IF (LDIAG.EQ.4) J8 = NZ8
118         IF (J8.GT.0_8) WRITE (MP,99998) (IRN(I8),ICN(I8),I8=1_8,J8)
119         K = min0(10,N)
120         IF (LDIAG.EQ.4) K = N
121         IF (IORD.EQ.1 .AND. K.GT.0) THEN
122            WRITE (MP,99997) (IKEEP(I,1),I=1,K)
123         ENDIF
124      ENDIF
125      NCMP    = N
126      IF (KEEP(60).NE.0) THEN
127         IF ((SIZE_SCHUR.LE.0 ).OR.
128     &        (SIZE_SCHUR.GE.N) ) GOTO 90
129      ENDIF
130#if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3)
131      IF  ( ( KEEP(60).NE.0).AND.(SIZE_SCHUR.GT.0)
132     &     .AND.
133     &     ((IORD.EQ.7).OR.(IORD.EQ.5))
134     &     )THEN
135         COMPRESS_SCHUR=.TRUE.
136         NCMP          = N-SIZE_SCHUR
137         ALLOCATE(IPQ8(N),stat=IERR)
138         IF ( IERR .GT. 0 ) THEN
139           INFO( 1 ) = -7
140           INFO( 2 ) = N*KEEP(10)
141         ENDIF
142         CALL DMUMPS_GNEW_SCHUR(N,NCMP,NZ8,IRN, ICN, IW(1), LIW8,
143     &        IPE, PTRAR(1,2),
144     &        IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127),
145     &        INFO(1), INFO(2), ICNTL, symmetry,
146     &        KEEP(50), NBQD, AvgDens,
147     &        KEEP(264), KEEP(265),
148     &        LISTVAR_SCHUR, SIZE_SCHUR, FRERE, FILS)
149         DEALLOCATE(IPQ8)
150         IORD = 5
151         KEEP(95) = 1
152         NBQD     = 0
153      ELSE
154#endif
155         ALLOCATE(IPQ8(N),stat=IERR)
156         IF ( IERR .GT. 0 ) THEN
157           INFO( 1 ) = -7
158           INFO( 2 ) = N*KEEP(10)
159         ENDIF
160         CALL DMUMPS_ANA_GNEW(N,NZ8,IRN, ICN, IW(1), LIW8,
161     &        IPE, PTRAR(1,2),
162     &        IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127),
163     &        INFO(1), INFO(2), ICNTL, symmetry,
164     &        KEEP(50), NBQD, AvgDens, KEEP(264), KEEP(265))
165         DEALLOCATE(IPQ8)
166#if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3)
167      ENDIF
168#endif
169      INFO(8) = symmetry
170      IF(NBQD .GT. 0) THEN
171         IF( KEEP(50) .EQ. 2 .AND. ICNTL(12) .LE. 1 ) THEN
172            IF(KEEP(95) .NE. 1) THEN
173               IF ( PROK )
174     &              WRITE( MP,*)
175     &              'Compressed/constrained ordering set OFF'
176               KEEP(95) = 1
177            ENDIF
178         ENDIF
179      ENDIF
180      IF ( (KEEP(60).NE.0) .AND. (IORD.GT.1) .AND.
181     &     .NOT. COMPRESS_SCHUR ) THEN
182         IORD = 0
183      ENDIF
184      IF ( (KEEP(50).EQ.2)
185     & .AND. (KEEP(95) .EQ. 3)
186     & .AND. (IORD .EQ. 7) ) THEN
187        IORD = 2
188      ENDIF
189      CALL MUMPS_SET_ORDERING( N, KEEP(50), NSLAVES, IORD,
190     &     symmetry, NBQD, AvgDens,
191     &     PROK, MP )
192      IF(KEEP(50) .EQ. 2) THEN
193         IF(KEEP(95) .EQ. 3 .AND. IORD .NE. 2) THEN
194            IF (PROK) WRITE(MP,*)
195     &      'WARNING: DMUMPS_ANA_F constrained ordering not '//
196     &      ' available with selected ordering. Move to' //
197     &      ' compressed ordering.'
198            KEEP(95) = 2
199         ENDIF
200         IF(KEEP(95) .EQ. 2 .AND. IORD .EQ. 0) THEN
201            IF (PROK) WRITE(MP,*)
202     &      'WARNING: DMUMPS_ANA_F AMD not available with ',
203     &      ' compressed ordering -> move to QAMD'
204            IORD = 6
205         ENDIF
206      ELSE
207         KEEP(95) = 1
208      ENDIF
209      MTRANS = KEEP(23)
210      COMPRESS = KEEP(95) - 1
211      IF(COMPRESS .GT. 0 .AND. KEEP(52) .EQ. -2) THEN
212         IF(id%CNTL(4) .GE. 0.0D0) THEN
213            IF (KEEP(1).LE.8) THEN
214               NEMIN = 16
215            ELSE
216               NEMIN = 2*KEEP(1)
217            ENDIF
218            IF (PROK)
219     &           WRITE(MP,*) 'Setting static pivoting ON, COMPRESS =',
220     &           COMPRESS
221         ENDIF
222      ENDIF
223      IF(MTRANS .GT. 0 .AND. KEEP(50) .EQ. 2) THEN
224         KEEP(23) = 0
225      ENDIF
226      IF(COMPRESS .EQ. 2) THEN
227         IF (IORD.NE.2) THEN
228            WRITE(*,*) "IORD not compatible with COMPRESS:",
229     &           IORD, COMPRESS
230            CALL MUMPS_ABORT()
231         ENDIF
232         CALL  DMUMPS_SET_CONSTRAINTS(
233     &        N,PIV,FRERE,FILS,NFSIZ,IKEEP,
234     &        NCST,KEEP,KEEP8,id)
235      ENDIF
236      IF ( IORD .NE. 1 ) THEN
237         IF(COMPRESS .GE. 1) THEN
238            ALLOCATE(IPQ8(N),stat=IERR)
239            IF ( IERR .GT. 0 ) THEN
240               INFO( 1 ) = -7
241               INFO( 2 ) = N*KEEP(10)
242            ENDIF
243            CALL DMUMPS_LDLT_COMPRESS(
244     &           N, NZ8, IRN, ICN, PIV,
245     &           NCMP, IW(1), LIW8, IPE, PTRAR(1,2), IPQ8,
246     &           IWL1, FILS, IWFR8,
247     &           IERROR, KEEP, KEEP8, ICNTL)
248            DEALLOCATE(IPQ8)
249            symmetry = 100
250         ENDIF
251         IF ( (symmetry.LT.MINSYM).AND.(KEEP(50).EQ.0) ) THEN
252            IF(KEEP(23) .EQ. 7 ) THEN
253               KEEP(23) = -5
254              GOTO 90
255            ELSE IF(KEEP(23) .EQ. -9876543) THEN
256               IDENT = .TRUE.
257               KEEP(23) = 5
258               IF (PROK) WRITE(MP,'(A)')
259     &              ' ... Apply column permutation (already computed)'
260               DO J=1,N
261                  JPERM = PIV(J)
262                  FILS(JPERM) = J
263                  IF (JPERM.NE.J) IDENT = .FALSE.
264               ENDDO
265               IF (.NOT.IDENT) THEN
266                  DO J8=1_8,NZ8
267                     J = ICN(J8)
268                     IF ((J.LE.0).OR.(J.GT.N)) CYCLE
269                     ICN(J8) = FILS(J)
270                  ENDDO
271                  ALLOCATE(COLSCA_TEMP(N), stat=IERR)
272                  IF ( IERR > 0 ) THEN
273                     INFO( 1 ) = -7
274                     INFO( 2 ) = N
275                     GOTO 90
276                  ENDIF
277                  DO J = 1, N
278                     COLSCA_TEMP(J)=id%COLSCA(J)
279                  ENDDO
280                  DO J=1, N
281                     id%COLSCA(FILS(J))=COLSCA_TEMP(J)
282                  ENDDO
283                  DEALLOCATE(COLSCA_TEMP)
284                  IF (PROK)
285     &                 WRITE(MP,'(/A)')
286     &                 ' WARNING input matrix data modified'
287                  ALLOCATE(IPQ8(N),stat=IERR)
288                  IF ( IERR .GT. 0 ) THEN
289                     INFO( 1 ) = -7
290                     INFO( 2 ) = N*KEEP(10)
291                  ENDIF
292                  CALL DMUMPS_ANA_GNEW
293     &                 (N,NZ8,IRN, ICN, IW(1), LIW8, IPE, PTRAR(1,2),
294     &                 IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127),
295     &                 INFO(1), INFO(2), ICNTL, symmetry, KEEP(50),
296     &                 NBQD, AvgDens, KEEP(264), KEEP(265))
297                  DEALLOCATE(IPQ8)
298                  INFO(8) = symmetry
299                  NCMP = N
300               ELSE
301                  KEEP(23) = 0
302               ENDIF
303            ENDIF
304         ELSE IF (KEEP(23) .EQ. 7 .OR. KEEP(23) .EQ. -9876543 ) THEN
305            IF (PROK) WRITE(MP,'(A)')
306     &           ' ... No column permutation'
307            KEEP(23) = 0
308         ENDIF
309      ENDIF
310      ALLOCATE( PARENT ( N ), stat = IERR )
311      IF ( IERR .GT. 0 ) THEN
312           INFO( 1 ) = -7
313           INFO( 2 ) = N
314           GOTO 90
315      ENDIF
316      IF (IORD.NE.1 .AND. IORD.NE.5) THEN
317         IF (PROK) THEN
318            IF (IORD.EQ.2) THEN
319               WRITE(MP,'(A)') ' Ordering based on AMF '
320#if defined(scotch) || defined(ptscotch)
321            ELSE IF (IORD.EQ.3) THEN
322               WRITE(MP,'(A)') ' Ordering based on SCOTCH '
323#endif
324#if defined(pord)
325            ELSE IF (IORD.EQ.4) THEN
326               WRITE(MP,'(A)') ' Ordering based on PORD '
327#endif
328            ELSE IF (IORD.EQ.6) THEN
329               WRITE(MP,'(A)') ' Ordering based on QAMD '
330            ELSE
331               WRITE(MP,'(A)') ' Ordering based on AMD '
332            ENDIF
333         ENDIF
334         IF ( PROK ) THEN
335            CALL MUMPS_SECDEB( TIMEB )
336         ENDIF
337         IF ( KEEP(60) .NE. 0 ) THEN
338            CALL MUMPS_HAMD(N, LIW8, IPE, IWFR8, PTRAR(1,2), IW(1),
339     &           IWL1, IKEEP,
340     &           IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), PTRAR, PTRAR(1,3),
341     &           PARENT,
342     &           LISTVAR_SCHUR, SIZE_SCHUR)
343            IF (KEEP(60)==1) THEN
344               KEEP(20) = LISTVAR_SCHUR(1)
345            ELSE
346               KEEP(38) = LISTVAR_SCHUR(1)
347            ENDIF
348         ELSE
349            IF ( .FALSE. ) THEN
350#if defined(pord)
351            ELSEIF (IORD .EQ. 4) THEN
352               CALL MUMPS_PORD_INTSIZE(PORD_INT_SIZE)
353               IF(COMPRESS .EQ. 1) THEN
354                  DO I=1,KEEP(93)/2
355                     IWL1(I) = 2
356                  ENDDO
357                  DO I=1+KEEP(93)/2,NCMP
358                     IWL1(I) = 1
359                  ENDDO
360                  IF (PORD_INT_SIZE .EQ. 64) THEN
361                    CALL MUMPS_PORDF_WND_MIXEDto64(NCMP, IWFR8-1_8,
362     &                   IPE, IW,
363     &                   IWL1, NCMPA, N, PARENT,
364     &                   INFO(1), LP, LPOK, KEEP(10))
365                  ELSE IF (PORD_INT_SIZE .EQ. 32) THEN
366                    CALL MUMPS_PORDF_WND_MIXEDto32(NCMP, IWFR8-1_8,
367     &                   IPE, IW,
368     &                   IWL1, NCMPA, N, PARENT,
369     &                   INFO(1), LP, LPOK, KEEP(10))
370                  ELSE
371                    WRITE(*,*)
372     &              "Internal error in PORD wrappers, PORD_INT_SIZE=",
373     &              PORD_INT_SIZE
374                    CALL MUMPS_ABORT()
375                  ENDIF
376                  IF ( NCMPA .NE. 0 ) THEN
377                     write(6,*) ' Out PORD, NCMPA=', NCMPA
378                     INFO( 1 ) = -9999
379                     INFO( 2 ) = 4
380                     GOTO 90
381                  ENDIF
382                  IF (INFO(1) .LT.0) GOTO 90
383                  CALL DMUMPS_GET_ELIM_TREE(NCMP,PARENT,IWL1,FILS)
384                  CALL DMUMPS_GET_PERM_FROM_PE(NCMP,PARENT,IKEEP(1,1),
385     &                 FRERE,PTRAR(1,1))
386                  DO I=1,NCMP
387                     IKEEP(IKEEP(I,1),2)=I
388                  ENDDO
389               ELSE
390                  IF (PORD_INT_SIZE.EQ.64) THEN
391                  CALL MUMPS_PORDF_MIXEDto64(NCMP, IWFR8-1_8, IPE,
392     &                 IW(1),
393     &                 IWL1, NCMPA, PARENT,
394     &                 INFO(1), LP, LPOK, KEEP(10))
395                  ELSE IF (PORD_INT_SIZE.EQ.32) THEN
396                  CALL MUMPS_PORDF_MIXEDto32(NCMP, IWFR8-1_8, IPE,
397     &                 IW(1),
398     &                 IWL1, NCMPA, PARENT,
399     &                 INFO(1), LP, LPOK, KEEP(10))
400                  ELSE
401                    WRITE(*,*)
402     &              "Internal error in PORD wrappers, PORD_INT_SIZE=",
403     &              PORD_INT_SIZE
404                    CALL MUMPS_ABORT()
405                  ENDIF
406               ENDIF
407               IF ( NCMPA .NE. 0 ) THEN
408                  write(6,*) ' Out PORD, NCMPA=', NCMPA
409                  INFO( 1 ) = -9999
410                  INFO( 2 ) = 4
411                  GOTO 90
412               ENDIF
413               IF (INFO(1) .LT. 0) GOTO 90
414#endif
415#if defined(scotch) || defined(ptscotch)
416            ELSEIF (IORD .EQ. 3) THEN
417               CALL MUMPS_SCOTCH_INTSIZE(SCOTCH_INT_SIZE)
418               IF (SCOTCH_INT_SIZE.EQ.32) THEN
419                IF (KEEP(10).EQ.1) THEN
420                 INFO(1)  = -52
421                 INFO(2) = 2
422                ELSE
423                 CALL MUMPS_SCOTCH_MIXEDto32(NCMP,
424     &              IWFR8-1_8, IPE,
425     &              PARENT, IWFR8,
426     &              PTRAR(1,2), IW(1), IWL1, IKEEP,
427     &              IKEEP(1,2), NCMPA, INFO, LP, LPOK)
428                ENDIF
429               ELSE IF (SCOTCH_INT_SIZE.EQ.64) THEN
430                 CALL MUMPS_SCOTCH_MIXEDto64(NCMP,
431     &              IWFR8-1_8, IPE,
432     &              PARENT, IWFR8,
433     &              PTRAR(1,2), IW(1), IWL1, IKEEP,
434     &              IKEEP(1,2), NCMPA, INFO, LP, LPOK, KEEP(10))
435               ELSE
436                 WRITE(*,*)
437     &           "Internal error in SCOTCH wrappers, SCOTCH_INT_SIZE=",
438     &           SCOTCH_INT_SIZE
439                 CALL MUMPS_ABORT()
440               ENDIF
441               IF (INFO(1) .LT. 0) GOTO 90
442               IF (COMPRESS .EQ. 1) THEN
443                 CALL DMUMPS_GET_ELIM_TREE(NCMP,PARENT,IWL1,FILS)
444                 CALL DMUMPS_GET_PERM_FROM_PE(NCMP,PARENT,IKEEP(1,1),
445     &                FRERE,PTRAR(1,1))
446                 DO I=1,NCMP
447                   IKEEP(IKEEP(I,1),2)=I
448                 ENDDO
449               ENDIF
450#endif
451            ELSEIF (IORD .EQ. 2) THEN
452               NBBUCK = 2*N
453               ALLOCATE( WTEMP ( 0: NBBUCK + 1), stat = IERR )
454               IF ( IERR .GT. 0 ) THEN
455                  INFO( 1 ) = -7
456                  INFO( 2 ) = NBBUCK+2
457                  GOTO 90
458               ENDIF
459               IF(COMPRESS .GE. 1) THEN
460                  DO I=1,KEEP(93)/2
461                     IWL1(I) = 2
462                  ENDDO
463                  DO I=1+KEEP(93)/2,NCMP
464                     IWL1(I) = 1
465                  ENDDO
466               ELSE
467                  IWL1(1) = -1
468               ENDIF
469               IF(COMPRESS .LE. 1) THEN
470                  CALL MUMPS_HAMF4(NCMP, NBBUCK, LIW8, IPE,
471     &                 IWFR8, PTRAR(1,2),
472     &                 IW(1), IWL1, IKEEP, IKEEP(1,2), NCMPA, FILS,
473     &                 IKEEP(1,3), PTRAR, PTRAR(1,3), WTEMP, PARENT)
474               ELSE
475                  IF(PROK) WRITE(MP,'(A)')
476     &                 ' Constrained Ordering based on AMF'
477                  CALL MUMPS_CST_AMF(NCMP, NBBUCK, LIW8, IPE,
478     &                 IWFR8, PTRAR(1,2),
479     &                 IW(1), IWL1, IKEEP, IKEEP(1,2), NCMPA, FILS,
480     &                 IKEEP(1,3), PTRAR, PTRAR(1,3), WTEMP,
481     &                 NFSIZ, FRERE, PARENT)
482               ENDIF
483               DEALLOCATE(WTEMP)
484            ELSEIF (IORD .EQ. 6) THEN
485               ALLOCATE( WTEMP ( N ), stat = IERR )
486               IF ( IERR .GT. 0 ) THEN
487                  INFO( 1 ) = -7
488                  INFO( 2 ) = N
489                  GOTO 90
490               ENDIF
491               THRESH = 1
492               IVersion = 2
493               IF(COMPRESS .EQ. 1) THEN
494                  DO I=1,KEEP(93)/2
495                     IWL1(I) = 2
496                  ENDDO
497                  DO I=1+KEEP(93)/2,NCMP
498                     IWL1(I) = 1
499                  ENDDO
500                  TOTEL = KEEP(93)+KEEP(94)
501               ELSE
502                  IWL1(1) = -1
503                  TOTEL = N
504               ENDIF
505               CALL MUMPS_QAMD(TOTEL,IVersion, THRESH, WTEMP,
506     &              NCMP, LIW8, IPE, IWFR8, PTRAR(1,2), IW(1),
507     &              IWL1, IKEEP, IKEEP(1,2), NCMPA, FILS,
508     &              IKEEP(1,3), PTRAR, PTRAR(1,3), PARENT)
509               DEALLOCATE(WTEMP)
510            ELSE
511               CALL MUMPS_ANA_H(NCMP, LIW8, IPE, IWFR8, PTRAR(1,2),
512     &              IW(1), IWL1, IKEEP, IKEEP(1,2), NCMPA, FILS,
513     &              IKEEP(1,3), PTRAR, PTRAR(1,3), PARENT)
514            ENDIF
515         ENDIF
516         IF(COMPRESS .GE. 1) THEN
517            CALL DMUMPS_EXPAND_PERMUTATION(N,NCMP,KEEP(94),KEEP(93),
518     &           PIV,IKEEP(1,1),IKEEP(1,2))
519            COMPRESS = -1
520         ENDIF
521         IF ( PROK ) THEN
522          CALL MUMPS_SECFIN( TIMEB )
523#if  defined(scotch) || defined(ptscotch)
524          IF (IORD.EQ.3) THEN
525            WRITE( MP, '(A,F12.4)' )
526     &        ' ELAPSED TIME SPENT IN SCOTCH reordering =', TIMEB
527          ENDIF
528#endif
529         ENDIF
530      ENDIF
531#if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3)
532      IF (IORD.EQ.5) THEN
533         IF (PROK) THEN
534            WRITE(MP,'(A)') ' Ordering based on METIS'
535         ENDIF
536         IF ( PROK ) THEN
537            CALL MUMPS_SECDEB( TIMEB )
538         ENDIF
539         CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE)
540         IF (KEEP(10).EQ.1.AND.METIS_IDX_SIZE.NE.64) THEN
541           INFO(1) = -52
542           INFO(2) = 1
543           GOTO 90
544         ENDIF
545#if defined(metis4) || defined(parmetis3)
546         NUMFLAG = 1
547         OPT_METIS_SIZE = 8
548         ALLOCATE( OPTIONS_METIS (OPT_METIS_SIZE ), stat = IERR )
549         IF ( IERR .GT. 0 ) THEN
550            INFO( 1 ) = -7
551            INFO( 2 ) = OPT_METIS_SIZE
552            GOTO 90
553         ENDIF
554         OPTIONS_METIS(1) = 0
555#else
556         OPT_METIS_SIZE = 40
557         OPT_METIS_SIZE = OPT_METIS_SIZE + 60
558         ALLOCATE( OPTIONS_METIS (OPT_METIS_SIZE ), stat = IERR )
559         IF ( IERR .GT. 0 ) THEN
560            INFO( 1 ) = -7
561            INFO( 2 ) = OPT_METIS_SIZE
562            GOTO 90
563         ENDIF
564         CALL METIS_SETDEFAULTOPTIONS(OPTIONS_METIS)
565         OPTIONS_METIS(18) = 1
566#endif
567         IF (COMPRESS .EQ. 1) THEN
568            DO I=1,KEEP(93)/2
569               FRERE(I) = 2
570            ENDDO
571            DO I=KEEP(93)/2+1,NCMP
572               FRERE(I) = 1
573            ENDDO
574#if defined(metis4) || defined(parmetis3)
575            IF (METIS_IDX_SIZE .EQ.32) THEN
576              CALL MUMPS_METIS_NODEWND_MIXEDto32(
577     &           NCMP, IPE, IW(1),FRERE(1),
578     &           NUMFLAG, OPTIONS_METIS, OPT_METIS_SIZE,
579     &           IKEEP(1,2), IKEEP(1,1), INFO(1), LP, LPOK )
580            ELSE IF (METIS_IDX_SIZE .EQ.64) THEN
581              CALL MUMPS_METIS_NODEWND_MIXEDto64(
582     &           NCMP, IPE, IW(1),FRERE(1),
583     &           NUMFLAG, OPTIONS_METIS, OPT_METIS_SIZE,
584     &           IKEEP(1,2), IKEEP(1,1), INFO(1), LP, LPOK, KEEP(10) )
585            ELSE
586              WRITE(*,*)
587     &        "Internal error in METIS wrappers, METIS_IDX_SIZE=",
588     &        METIS_IDX_SIZE
589              CALL MUMPS_ABORT()
590            ENDIF
591         ELSE
592            IF (METIS_IDX_SIZE .EQ.32) THEN
593              CALL MUMPS_METIS_NODEND_MIXEDto32(
594     &           NCMP, IPE, IW(1), NUMFLAG,
595     &           OPTIONS_METIS, OPT_METIS_SIZE,
596     &           IKEEP(1,2), IKEEP(1,1), INFO(1), LP, LPOK )
597            ELSE IF (METIS_IDX_SIZE .EQ.64) THEN
598              CALL MUMPS_METIS_NODEND_MIXEDto64(
599     &           NCMP, IPE, IW(1), NUMFLAG,
600     &           OPTIONS_METIS, OPT_METIS_SIZE,
601     &           IKEEP(1,2), IKEEP(1,1), INFO(1), LP,LPOK,KEEP(10))
602            ELSE
603              WRITE(*,*)
604     &        "Internal error in METIS wrappers, METIS_IDX_SIZE=",
605     &        METIS_IDX_SIZE
606              CALL MUMPS_ABORT()
607            ENDIF
608         ENDIF
609#else
610         ELSE
611            DO I=1,NCMP
612               FRERE(I) = 1
613            ENDDO
614         ENDIF
615         IF (METIS_IDX_SIZE .EQ. 32) THEN
616           CALL MUMPS_METIS_NODEND_MIXEDto32(
617     &        NCMP, IPE, IW(1),FRERE(1),
618     &        OPTIONS_METIS, OPT_METIS_SIZE,
619     &        IKEEP(1,2), IKEEP(1,1), INFO(1), LP, LPOK )
620         ELSE IF (METIS_IDX_SIZE .EQ. 64) THEN
621           CALL MUMPS_METIS_NODEND_MIXEDto64(
622     &        NCMP, IPE, IW(1),FRERE(1),
623     &        OPTIONS_METIS, OPT_METIS_SIZE,
624     &        IKEEP(1,2), IKEEP(1,1), INFO(1), LP,LPOK,KEEP(10) )
625         ELSE
626              IF (LPOK) WRITE(LP,*)
627     &        "Internal error in METIS wrappers, METIS_IDX_SIZE=",
628     &        METIS_IDX_SIZE
629              CALL MUMPS_ABORT()
630         ENDIF
631#endif
632         IF (INFO(1) .LT.0) GOTO 90
633         IF ( PROK ) THEN
634            CALL MUMPS_SECFIN( TIMEB )
635            WRITE( MP, '(A,F12.4)' )
636     &        ' ELAPSED TIME SPENT IN METIS reordering  =', TIMEB
637         ENDIF
638         DEALLOCATE (OPTIONS_METIS)
639         IF ( COMPRESS_SCHUR ) THEN
640            CALL DMUMPS_EXPAND_PERM_SCHUR(
641     &           N, NCMP, IKEEP(1,1),IKEEP(1,2),
642     &           LISTVAR_SCHUR, SIZE_SCHUR, FILS)
643            COMPRESS = -1
644         ENDIF
645         IF (COMPRESS .EQ. 1) THEN
646            CALL DMUMPS_EXPAND_PERMUTATION(N,NCMP,KEEP(94),
647     &           KEEP(93),PIV,IKEEP(1,1),IKEEP(1,2))
648            COMPRESS = -1
649         ENDIF
650      ENDIF
651#endif
652      IF (PROK) THEN
653         IF (IORD.EQ.1) THEN
654            WRITE(MP,'(A)') ' Ordering given is used'
655         ENDIF
656      ENDIF
657      IF ((IORD.EQ.1)
658     &     ) THEN
659         DO K=1,N
660            PTRAR(K,1) = 0
661         ENDDO
662         DO K=1,N
663            IF ((IKEEP(K,1).LE.0).OR.(IKEEP(K,1).GT.N))
664     &           GO TO 40
665            IF (PTRAR(IKEEP(K,1),1).EQ.1) THEN
666               GOTO 40
667            ELSE
668               PTRAR(IKEEP(K,1),1) = 1
669            ENDIF
670         ENDDO
671      ENDIF
672      IF (IORD.EQ.1 .OR. IORD.EQ.5 .OR. COMPRESS.EQ.-1) THEN
673         IF ((KEEP(106)==1).OR.(KEEP(60).NE.0)) THEN
674            IF ( COMPRESS .EQ. -1 ) THEN
675               ALLOCATE(IPQ8(N),stat=IERR)
676               IF ( IERR .GT. 0 ) THEN
677                     INFO( 1 ) = -7
678                     INFO( 2 ) = N*KEEP(10)
679               ENDIF
680               CALL DMUMPS_ANA_GNEW(N,NZ8,IRN, ICN, IW(1), LIW8,
681     &              IPE, PTRAR(1,2),
682     &              IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127),
683     &              INFO(1), INFO(2), ICNTL, symmetry, KEEP(50),
684     &              NBQD, AvgDens, KEEP(264),KEEP(265))
685               DEALLOCATE(IPQ8)
686               INFO(8) = symmetry
687            ENDIF
688            COMPRESS = 0
689            ALLOCATE( WTEMP ( 2*N ), stat = IERR )
690            IF ( IERR .GT. 0 ) THEN
691               INFO( 1 ) = -7
692               INFO( 2 ) = 2*N
693               GOTO 90
694            ENDIF
695            THRESH = -1
696            IF (KEEP(60) == 0) THEN
697               ITEMP = 0
698            ELSE
699               ITEMP = SIZE_SCHUR
700               IF (KEEP(60)==1) THEN
701                  KEEP(20) = LISTVAR_SCHUR(1)
702               ELSE
703                  KEEP(38) = LISTVAR_SCHUR(1)
704               ENDIF
705            ENDIF
706            AGG6 =.FALSE.
707            CALL MUMPS_SYMQAMD(THRESH, WTEMP,
708     &           N, LIW8, IPE, IWFR8, PTRAR(1,2), IW,
709     &           IWL1, WTEMP(N+1),
710     &           IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), PTRAR,
711     &           PTRAR(1,3),IKEEP(1,1), LISTVAR_SCHUR, ITEMP,
712     &           AGG6, PARENT)
713            DEALLOCATE(WTEMP)
714         ELSE
715            CALL DMUMPS_ANA_J(N, NZ8, IRN, ICN, IKEEP, IW(1),
716     &           LIW8, IPE,
717     &           PTRAR(1,2), IWL1, IWFR8,
718     &           INFO(1),INFO(2), MP)
719            IF (KEEP(60) .EQ. 0) THEN
720               ITEMP = 0
721            ELSE
722               ITEMP = SIZE_SCHUR
723            ENDIF
724            CALL DMUMPS_ANA_K(N, IPE, IW, LIW8, IWFR8, IKEEP,
725     &              IKEEP(1,2), IWL1,
726     &              PTRAR, NCMPA, ITEMP, PARENT)
727            IF (KEEP(60) .EQ. 0) THEN
728               IF (KEEP(60) .EQ. 1) THEN
729                  KEEP(20) = LISTVAR_SCHUR(1)
730               ELSE
731                  KEEP(38) = LISTVAR_SCHUR(1)
732               ENDIF
733            ENDIF
734         ENDIF
735      ENDIF
736#if defined(OLDDFS)
737      CALL DMUMPS_ANA_L
738     &     (N, PARENT, IWL1, IKEEP(1,1), IKEEP(1,2), IKEEP(1,3),
739     &     NFSIZ, INFO(6), FILS, FRERE, PTRAR(1,3), NEMIN, KEEP(60))
740#else
741      IF (allocated(IPE)) DEALLOCATE(IPE)
742      ALLOCATE(WTEMP(N), stat=IERR)
743      IF ( IERR .GT. 0 ) THEN
744         INFO( 1 ) = -7
745         INFO( 2 ) = N
746         GOTO 90
747      ENDIF
748      CALL DMUMPS_ANA_LNEW
749     &     (N, PARENT, IWL1, IKEEP(1,1), IKEEP(1,2), IKEEP(1,3),
750     &     NFSIZ, PTRAR, INFO(6), FILS, FRERE,
751     &     PTRAR(1,3), NEMIN, WTEMP, KEEP(60),
752     &     KEEP(20),KEEP(38),PTRAR(1,2),KEEP(104),IW(1),KEEP(50),
753     &     ICNTL(13), KEEP(37), NSLAVES, KEEP(250).EQ.1)
754      DEALLOCATE(WTEMP)
755#endif
756      IF (KEEP(60).NE.0)  THEN
757         IF (KEEP(60)==1) THEN
758            IN = KEEP(20)
759         ELSE
760            IN = KEEP(38)
761         ENDIF
762         DO WHILE (IN.GT.0)
763            IN = FILS (IN)
764         END DO
765         IFSON = -IN
766         IF (KEEP(60)==1) THEN
767            IN = KEEP(20)
768         ELSE
769            IN = KEEP(38)
770         ENDIF
771         DO I=2,SIZE_SCHUR
772            FILS(IN) = LISTVAR_SCHUR (I)
773            IN       = FILS(IN)
774            FRERE (IN) = N+1
775         ENDDO
776         FILS(IN) = -IFSON
777      ENDIF
778      CALL DMUMPS_ANA_M(IKEEP(1,2),
779     &     PTRAR(1,3), INFO(6),
780     &     INFO(5), KEEP(2), KEEP(50),
781     &     KEEP(101),KEEP(108),KEEP(5),
782     &     KEEP(6), KEEP(226), KEEP(253))
783      IF ( KEEP(53) .NE. 0 ) THEN
784         CALL MUMPS_MAKE1ROOT( N, FRERE, FILS, NFSIZ, KEEP(20) )
785      END IF
786      IF (  (KEEP(48) == 4 .AND. KEEP8(21).GT.0_8)
787     &     .OR.
788     &     (KEEP (48)==5 .AND. KEEP8(21) .GT. 0_8 )
789     &     .OR.
790     &     (KEEP(24).NE.0.AND.KEEP8(21).GT.0_8) ) THEN
791         CALL DMUMPS_SET_K821_SURFACE(KEEP8(21), KEEP(2),
792     &        KEEP(48), KEEP(50), NSLAVES)
793      END IF
794      IF (KEEP(210).LT.0.OR.KEEP(210).GT.2) KEEP(210)=0
795      IF (KEEP(210).EQ.0.AND.KEEP(201).GT.0) KEEP(210)=1
796      IF (KEEP(210).EQ.0.AND.KEEP(201).EQ.0) KEEP(210)=2
797      IF (KEEP(210).EQ.2) KEEP8(79)=huge(KEEP8(79))
798      IF (KEEP(210).EQ.1.AND.KEEP8(79).LE.0_8) THEN
799        KEEP8(79)=K79REF * int(NSLAVES,8)
800      ENDIF
801      IF ( (KEEP(79).EQ.0).OR.(KEEP(79).EQ.2).OR.
802     &     (KEEP(79).EQ.3).OR.(KEEP(79).EQ.5).OR.
803     &     (KEEP(79).EQ.6)
804     &   )  THEN
805       IF (KEEP(210).EQ.1) THEN
806        SPLITROOT = .FALSE.
807        IF ( KEEP(62).GE.1) THEN
808          CALL DMUMPS_CUTNODES(N, FRERE, FILS, NFSIZ,INFO(6),
809     &                       NSLAVES, KEEP,KEEP8, SPLITROOT,
810     &                       MP, LDIAG, INFO(1), INFO(2))
811          IF (INFO(1).LT.0) GOTO 90
812          IF (PROK) THEN
813               WRITE(MP,*) " Number of split nodes in pre-splitting=",
814     &         KEEP(61)
815          ENDIF
816        ENDIF
817       ENDIF
818      ENDIF
819      SPLITROOT = ((ICNTL(13).GT.0 .AND. NSLAVES.GT.ICNTL(13)) .OR.
820     &     ICNTL(13).EQ.-1 )
821      IF (KEEP(53) .NE. 0) THEN
822         SPLITROOT = .TRUE.
823      ENDIF
824      SPLITROOT = (SPLITROOT.AND.( (KEEP(60).EQ.0) ))
825      IF (SPLITROOT) THEN
826         CALL DMUMPS_CUTNODES(N, FRERE, FILS, NFSIZ,INFO(6),
827     &                    NSLAVES, KEEP,KEEP8, SPLITROOT,
828     &                    MP, LDIAG, INFO(1), INFO(2))
829         IF (INFO(1).LT.0) GOTO 90
830         IF ( KEEP(53) .NE. 0 ) THEN
831          CALL MUMPS_MAKE1ROOT( N, FRERE, FILS, NFSIZ, KEEP(20) )
832         ENDIF
833      ENDIF
834      IF (LDIAG.GT.2 .AND. MP.GT.0) THEN
835         K = min0(10,N)
836         IF (LDIAG.EQ.4) K = N
837         IF (K.GT.0) WRITE (MP,99987) (NFSIZ(I),I=1,K)
838         IF (K.GT.0) WRITE (MP,99989) (FILS(I),I=1,K)
839         IF (K.GT.0) WRITE (MP,99988) (FRERE(I),I=1,K)
840      ENDIF
841      GO TO 90
842 40   INFO(1) = -4
843      INFO(2) = K
844      GOTO 90
845 90   CONTINUE
846      IF (INFO(1) .NE. 0) THEN
847        IF ((LP.GT.0).AND.(ICNTL(4).GE.1))
848     &           WRITE (LP,99996) INFO(1), INFO(2)
849      ENDIF
850      IF (allocated(IW))     DEALLOCATE(IW)
851      IF (allocated(IWL1))   DEALLOCATE(IWL1)
852      IF (allocated(IPE))    DEALLOCATE(IPE)
853      IF (allocated(PTRAR))  DEALLOCATE(PTRAR)
854      IF (allocated(PARENT)) DEALLOCATE(PARENT)
855      RETURN
85699999 FORMAT (/'Entering analysis phase with ...'/
857     &     '                N        NNZ         LIW       INFO(1)'/,
858     &     9X, I8, I11, I12, I14)
85999998 FORMAT ('Matrix entries:    IRN()   ICN()'/
860     &     (I12, I7, I12, I7, I12, I7))
86199997 FORMAT ('IKEEP(.,1)=', 10I6/(12X, 10I6))
86299996 FORMAT (/'** Error return ** from Analysis *  INFO(1:2)= ',
863     &       (I3, I16))
86499989 FORMAT ('FILS (.)  =', 10I6/(12X, 10I6))
86599988 FORMAT ('FRERE(.)  =', 10I6/(12X, 10I6))
86699987 FORMAT ('NFSIZ(.)  =', 10I6/(12X, 10I6))
867      END SUBROUTINE DMUMPS_ANA_F
868      SUBROUTINE DMUMPS_ANA_K(N,IPE, IW, LW, IWFR, IPS, IPV,
869     &                           NV, FLAG,
870     &                           NCMPA, SIZE_SCHUR, PARENT)
871      IMPLICIT NONE
872      INTEGER, INTENT(IN)    :: N, SIZE_SCHUR
873      INTEGER, INTENT(IN)    :: IPS(N)
874      INTEGER(8), INTENT(IN) :: LW
875      INTEGER, INTENT(OUT)   :: NCMPA
876      INTEGER, INTENT(OUT)   :: IPV(N), NV(N), PARENT(N)
877      INTEGER(8), INTENT(INOUT) :: IWFR
878      INTEGER(8), INTENT(INOUT) :: IPE(N)
879      INTEGER, INTENT(INOUT)    :: IW(LW)
880      INTEGER, INTENT(OUT)      ::  FLAG(N)
881      INTEGER I,J,ML,MS,ME,MINJS,IE,KDUMMY
882      INTEGER LN,JS,JE
883      INTEGER(8) :: JP, JP1, JP2, LWFR, IP
884      DO 10 I=1,N
885        FLAG(I) = 0
886        NV(I) = 0
887        J = IPS(I)
888        IPV(J) = I
889   10 CONTINUE
890      NCMPA = 0
891      DO 100 ML=1,N-SIZE_SCHUR
892        MS = IPV(ML)
893        ME = MS
894        FLAG(MS) = ME
895        IP = IWFR
896        MINJS = N
897        IE = ME
898        DO 70 KDUMMY=1,N
899          JP = IPE(IE)
900          LN = 0
901          IF (JP.LE.0_8) GO TO 60
902          LN = IW(JP)
903          DO 50 JP1=1_8,int(LN,8)
904            JP = JP + 1_8
905            JS = IW(JP)
906            IF (FLAG(JS).EQ.ME) GO TO 50
907            FLAG(JS) = ME
908            IF (IWFR.LT.LW) GO TO 40
909            IPE(IE) = JP
910            IW(JP) = LN - int(JP1)
911            CALL DMUMPS_ANA_D(N, IPE, IW, IP-1_8, LWFR, NCMPA)
912            JP2 = IWFR - 1
913            IWFR = LWFR
914            IF (IP.GT.JP2) GO TO 30
915            DO 20 JP=IP,JP2
916              IW(IWFR) = IW(JP)
917              IWFR = IWFR + 1_8
918   20       CONTINUE
919   30       IP = LWFR
920            JP = IPE(IE)
921   40       IW(IWFR) = JS
922            MINJS = min0(MINJS,IPS(JS)+0)
923            IWFR = IWFR + 1_8
924   50     CONTINUE
925   60     IPE(IE) = int(-ME,8)
926          JE = NV(IE)
927          NV(IE) = LN + 1
928          IE = JE
929          IF (IE.EQ.0) GO TO 80
930   70   CONTINUE
931   80   IF (IWFR.GT.IP) GO TO 90
932        IPE(ME) = 0_8
933        NV(ME) = 1
934        GO TO 100
935   90   MINJS = IPV(MINJS)
936        NV(ME) = NV(MINJS)
937        NV(MINJS) = ME
938        IW(IWFR) = IW(IP)
939        IW(IP) = int(IWFR - IP)
940        IPE(ME) = IP
941        IWFR = IWFR + 1_8
942  100 CONTINUE
943      IF (SIZE_SCHUR == 0) GOTO 500
944      DO ML = N-SIZE_SCHUR+1,N
945        ME = IPV(ML)
946        IE = ME
947        DO KDUMMY=1,N
948          JP = IPE(IE)
949          LN = 0
950          IF (JP.LE.0_8) GO TO 160
951          LN = IW(JP)
952  160     IPE(IE) = int(-IPV(N-SIZE_SCHUR+1),8)
953          JE = NV(IE)
954          NV(IE) = LN + 1
955          IE = JE
956          IF (IE.EQ.0) GO TO 190
957        ENDDO
958  190   NV(ME) = 0
959        IPE(ME) = int(-IPV(N-SIZE_SCHUR+1),8)
960      ENDDO
961      ME = IPV(N-SIZE_SCHUR+1)
962      IPE(ME) = 0_8
963      NV(ME) = SIZE_SCHUR
964  500 DO I=1,N
965       PARENT(I) = int(IPE(I))
966      ENDDO
967      RETURN
968      END SUBROUTINE DMUMPS_ANA_K
969      SUBROUTINE DMUMPS_ANA_J(N, NZ, IRN, ICN, PERM,
970     & IW, LW, IPE, IQ, FLAG,
971     & IWFR, IFLAG, IERROR, MP)
972      INTEGER, INTENT(IN)    :: N
973      INTEGER(8), INTENT(IN) :: NZ, LW
974      INTEGER, INTENT(IN) :: IRN(NZ), ICN(NZ)
975      INTEGER, INTENT(IN) :: PERM(N)
976      INTEGER, INTENT(IN)  ::  MP
977      INTEGER(8), INTENT(OUT):: IWFR
978      INTEGER, INTENT(OUT)   :: IERROR
979      INTEGER, INTENT(OUT)   :: IQ(N)
980      INTEGER(8), INTENT(OUT) :: IPE(N)
981      INTEGER, INTENT(OUT) :: IW(LW)
982      INTEGER, INTENT(OUT) :: FLAG(N)
983      INTEGER, INTENT(INOUT) :: IFLAG
984      INTEGER  :: I,J,LBIG,IN,LEN,JDUMMY,L1
985      INTEGER(8) :: K, K1, K2, KL, KID
986      IERROR = 0
987      DO 10 I=1,N
988        IQ(I) = 0
989   10 CONTINUE
990      DO 80 K=1_8,NZ
991        I = IRN(K)
992        J = ICN(K)
993        IW(K) = -I
994        IF (I.EQ.J) GOTO 40
995        IF (I.GT.J) GOTO 30
996        IF (I.GE.1 .AND. J.LE.N) GO TO 60
997        GO TO 50
998   30   IF (J.GE.1 .AND. I.LE.N) GO TO 60
999        GO TO 50
1000   40   IW(K) = 0
1001        IF (I.GE.1 .AND. I.LE.N) GO TO 80
1002   50   IERROR = IERROR + 1
1003        IW(K) = 0
1004        IF (IERROR.LE.1 .AND. MP.GT.0) WRITE (MP,99999)
1005        IF (IERROR.LE.10 .AND. MP.GT.0) WRITE (MP,99998) K, I, J
1006        GO TO 80
1007   60   IF (PERM(J).GT.PERM(I)) GO TO 70
1008        IQ(J) = IQ(J) + 1
1009        GO TO 80
1010   70   IQ(I) = IQ(I) + 1
1011   80 CONTINUE
1012      IF (IERROR.GE.1) THEN
1013        IF (mod(IFLAG,2) .EQ. 0) IFLAG = IFLAG+1
1014      ENDIF
1015      IWFR = 1_8
1016      LBIG = 0
1017      DO 100 I=1,N
1018        L1 = IQ(I)
1019        LBIG = max0(L1,LBIG)
1020        IWFR = IWFR + int(L1,8)
1021        IPE(I) = IWFR - 1_8
1022  100 CONTINUE
1023      DO 140 K=1_8,NZ
1024        I = -IW(K)
1025        IF (I.LE.0) GO TO 140
1026        KL = K
1027        IW(K) = 0
1028        DO 130 KID=1,NZ
1029          J = ICN(KL)
1030          IF (PERM(I).LT.PERM(J)) GO TO 110
1031          KL = IPE(J)
1032          IPE(J) = KL - 1_8
1033          IN = IW(KL)
1034          IW(KL) = I
1035          GO TO 120
1036  110     KL = IPE(I)
1037          IPE(I) = KL - 1_8
1038          IN = IW(KL)
1039          IW(KL) = J
1040  120     I = -IN
1041          IF (I.LE.0) GO TO 140
1042  130   CONTINUE
1043  140 CONTINUE
1044      K = IWFR - 1_8
1045      KL = K + int(N,8)
1046      IWFR = KL + 1_8
1047      DO 170 I=1,N
1048        FLAG(I) = 0
1049        J = N + 1 - I
1050        LEN = IQ(J)
1051        IF (LEN.LE.0) GO TO 160
1052        DO 150 JDUMMY=1,LEN
1053          IW(KL) = IW(K)
1054          K = K - 1_8
1055          KL = KL - 1_8
1056  150   CONTINUE
1057  160   IPE(J) = KL
1058        KL = KL - 1_8
1059  170 CONTINUE
1060      IF (LBIG.GE.huge(N)) GO TO 190
1061      DO 180 I=1,N
1062        K = IPE(I)
1063        IW(K) = IQ(I)
1064        IF (IQ(I).EQ.0) IPE(I) = 0_8
1065  180 CONTINUE
1066      GO TO 230
1067  190 IWFR = 1_8
1068      DO 220 I=1,N
1069        K1 = IPE(I) + 1_8
1070        K2 = IPE(I) + int(IQ(I),8)
1071        IF (K1.LE.K2) GO TO 200
1072        IPE(I) = 0_8
1073        GO TO 220
1074  200   IPE(I) = IWFR
1075        IWFR = IWFR + 1_8
1076        DO 210 K=K1,K2
1077          J = IW(K)
1078          IF (FLAG(J).EQ.I) GO TO 210
1079          IW(IWFR) = J
1080          IWFR = IWFR + 1_8
1081          FLAG(J) = I
1082  210   CONTINUE
1083        K = IPE(I)
1084        IW(K) = int(IWFR - K - 1_8)
1085  220 CONTINUE
1086  230 RETURN
108799999 FORMAT (' *** WARNING MESSAGE FROM DMUMPS_ANA_J ***' )
108899998 FORMAT (I6, ' NON-ZERO (IN ROW, I6, 11H AND COLUMN ', I6,
1089     & ') IGNORED')
1090      END SUBROUTINE DMUMPS_ANA_J
1091      SUBROUTINE DMUMPS_ANA_D(N, IPE, IW, LW, IWFR,NCMPA)
1092      INTEGER, INTENT(IN)      :: N
1093      INTEGER(8), INTENT(IN)   :: LW
1094      INTEGER(8), INTENT(OUT)  :: IWFR
1095      INTEGER(8), INTENT(INOUT):: IPE(N)
1096      INTEGER, INTENT(INOUT)   :: NCMPA
1097      INTEGER, INTENT(INOUT)   :: IW(LW)
1098      INTEGER    :: I, IR
1099      INTEGER(8) :: K1, K, K2, LWFR
1100      NCMPA = NCMPA + 1
1101      DO 10 I=1,N
1102        K1 = IPE(I)
1103        IF (K1.LE.0_8) GO TO 10
1104        IPE(I) = int(IW(K1), 8)
1105        IW(K1) = -I
1106   10 CONTINUE
1107      IWFR = 1_8
1108      LWFR = IWFR
1109      DO 60 IR=1,N
1110        IF (LWFR.GT.LW) GO TO 70
1111        DO 20 K=LWFR,LW
1112          IF (IW(K).LT.0) GO TO 30
1113   20   CONTINUE
1114        GO TO 70
1115   30   I = -IW(K)
1116        IW(IWFR) = int(IPE(I))
1117        IPE(I) = int(IWFR,8)
1118        K1 = K + 1_8
1119        K2 = K + int(IW(IWFR),8)
1120        IWFR = IWFR + 1_8
1121        IF (K1.GT.K2) GO TO 50
1122        DO 40 K=K1,K2
1123          IW(IWFR) = IW(K)
1124          IWFR = IWFR + 1_8
1125   40   CONTINUE
1126   50   LWFR = K2 + 1_8
1127   60 CONTINUE
1128   70 RETURN
1129      END SUBROUTINE DMUMPS_ANA_D
1130#if defined(OLDDFS)
1131      SUBROUTINE DMUMPS_ANA_L(N, IPE, NV, IPS, NE, NA, NFSIZ,
1132     &                  NSTEPS,
1133     &                  FILS, FRERE,NDD,NEMIN, KEEP60)
1134      INTEGER N,NSTEPS
1135      INTEGER NDD(N)
1136      INTEGER FILS(N), FRERE(N)
1137      INTEGER IPS(N), NE(N), NA(N), NFSIZ(N)
1138      INTEGER IPE(N), NV(N)
1139      INTEGER NEMIN, KEEP60
1140      INTEGER I,IF,IS,NR,NR1,INS,INL,INB,INF,INFS,INSW
1141      INTEGER K,L,ISON,IN,INP,IFSON,INC,INO
1142      INTEGER INOS,IB,IL
1143      DO 10 I=1,N
1144        IPS(I) = 0
1145        NE(I) = 0
1146   10 CONTINUE
1147      DO 20 I=1,N
1148        IF (NV(I).GT.0) GO TO 20
1149        IF = -IPE(I)
1150        IS = -IPS(IF)
1151        IF (IS.GT.0) IPE(I) = IS
1152        IPS(IF) = -I
1153   20 CONTINUE
1154      NR = N + 1
1155      DO 50 I=1,N
1156        IF (NV(I).LE.0) GO TO 50
1157        IF = -IPE(I)
1158        IF (IF.NE.0) THEN
1159         IS = -IPS(IF)
1160         IF (IS.GT.0) IPE(I) = IS
1161         IPS(IF) = -I
1162        ELSE
1163         NR = NR - 1
1164         NE(NR) = I
1165        ENDIF
1166   50 CONTINUE
1167      DO 999 I=1,N
1168       FILS(I) = IPS(I)
1169 999  CONTINUE
1170      NR1 = NR
1171      INS = 0
1172 1000 IF (NR1.GT.N) GO TO 1151
1173      INS = NE(NR1)
1174      NR1 = NR1 + 1
1175 1070 INL = FILS(INS)
1176      IF (INL.LT.0) THEN
1177       INS = -INL
1178       GO TO 1070
1179      ENDIF
1180 1080 IF (IPE(INS).LT.0) THEN
1181       INS       = -IPE(INS)
1182       FILS(INS) = 0
1183       GO TO 1080
1184      ENDIF
1185      IF (IPE(INS).EQ.0) THEN
1186       INS = 0
1187       GO TO 1000
1188      ENDIF
1189      INB = IPE(INS)
1190      IF (NV(INB).EQ.0) THEN
1191       INS = INB
1192       GO TO 1070
1193      ENDIF
1194      IF (NV(INB).GE.NV(INS)) THEN
1195       INS = INB
1196       GO TO 1070
1197      ENDIF
1198      INF = INB
1199 1090 INF = IPE(INF)
1200      IF (INF.GT.0) GO TO 1090
1201      INF  = -INF
1202      INFS = -FILS(INF)
1203      IF (INFS.EQ.INS) THEN
1204       FILS(INF) = -INB
1205       IPS(INF)  = -INB
1206       IPE(INS)  = IPE(INB)
1207       IPE(INB)  = INS
1208       INS       = INB
1209       GO TO 1070
1210      ENDIF
1211      INSW = INFS
1212 1100 INFS = IPE(INSW)
1213      IF (INFS.NE.INS) THEN
1214       INSW = INFS
1215       GO TO 1100
1216      ENDIF
1217      IPE(INS) = IPE(INB)
1218      IPE(INB) = INS
1219      IPE(INSW)= INB
1220      INS      =INB
1221      GO TO 1070
1222 1151 CONTINUE
1223      DO 51 I=1,N
1224       FRERE(I) = IPE(I)
1225       FILS(I) = IPS(I)
1226 51   CONTINUE
1227      IS = 1
1228      I  = 0
1229      IL = 0
1230      DO 160 K=1,N
1231        IF (I.GT.0) GO TO 60
1232        I = NE(NR)
1233        NE(NR) = 0
1234        NR = NR + 1
1235        IL = N
1236        NA(N) = 0
1237   60   DO 70 L=1,N
1238          IF (IPS(I).GE.0) GO TO 80
1239          ISON = -IPS(I)
1240          IPS(I) = 0
1241          I = ISON
1242          IL = IL - 1
1243          NA(IL) = 0
1244   70   CONTINUE
1245   80   IPS(I) = K
1246        NE(IS) = NE(IS) + 1
1247        IF (NV(I).GT.0) GO TO 89
1248      IN = I
1249 81   IN =  FRERE(IN)
1250      IF (IN.GT.0) GO TO 81
1251      IF = -IN
1252      IN = IF
1253 82   INL = IN
1254      IN = FILS(IN)
1255      IF (IN.GT.0) GO TO 82
1256      IFSON = -IN
1257      FILS(INL) = I
1258      IN = I
1259 83   INP = IN
1260      IN = FILS(IN)
1261      IF (IN.GT.0) GO TO 83
1262      IF (IFSON .EQ. I) GO TO 86
1263      FILS(INP) = -IFSON
1264      IN = IFSON
1265 84   INC =IN
1266      IN = FRERE(IN)
1267      IF (IN.NE.I) GO TO 84
1268      FRERE(INC) = FRERE(I)
1269      GO TO 120
1270 86   IF (FRERE(I).LT.0) FILS(INP) = 0
1271      IF (FRERE(I).GT.0) FILS(INP) = -FRERE(I)
1272      GO TO 120
1273   89   IF (IL.LT.N) NA(IL+1) = NA(IL+1) + 1
1274        NA(IS) = NA(IL)
1275        NDD(IS) = NV(I)
1276        NFSIZ(I) = NV(I)
1277        IF (NA(IS).LT.1) GO TO 110
1278        IF (   (KEEP60.NE.0).AND.
1279     &         (NE(IS).EQ.NDD(IS)) ) GOTO 110
1280        IF (NDD(IS-1)-NE(IS-1).EQ.NDD(IS)) GO TO 100
1281        IF ((NE(IS-1).GE.NEMIN).AND.
1282     &         (NE(IS).GE.NEMIN) ) GO TO 110
1283        IF (2*NE(IS-1)*(NDD(IS)-NDD(IS-1)+NE(IS-1)).GE.
1284     &    ((NDD(IS)+NE(IS-1))*
1285     &    (NDD(IS)+NE(IS-1))*NEMIN/100)) GO TO 110
1286  100   NA(IS-1) = NA(IS-1) + NA(IS) - 1
1287        NDD(IS-1) = NDD(IS) + NE(IS-1)
1288        NE(IS-1) = NE(IS) + NE(IS-1)
1289        NE(IS) = 0
1290      IN=I
1291 101  INL = IN
1292      IN = FILS(IN)
1293      IF (IN.GT.0) GO TO 101
1294      IFSON = -IN
1295      IN = IFSON
1296 102  INO = IN
1297      IN =  FRERE(IN)
1298      IF (IN.GT.0) GO TO 102
1299      FILS(INL) = INO
1300      NFSIZ(I) = NDD(IS-1)
1301      IN = INO
1302 103  INP = IN
1303      IN = FILS(IN)
1304      IF (IN.GT.0) GO TO 103
1305      INOS = -IN
1306      IF (IFSON.EQ.INO) GO TO 107
1307      IN = IFSON
1308      FILS(INP) = -IFSON
1309 105  INS = IN
1310      IN =  FRERE(IN)
1311      IF (IN.NE.INO) GO TO 105
1312      IF (INOS.EQ.0) FRERE(INS) = -I
1313      IF (INOS.NE.0) FRERE(INS) =  INOS
1314      IF (INOS.EQ.0) GO TO 109
1315 107  IN = INOS
1316      IF (IN.EQ.0) GO TO 109
1317 108  INT = IN
1318      IN =  FRERE(IN)
1319      IF (IN.GT.0) GO TO 108
1320      FRERE(INT) = -I
1321 109  CONTINUE
1322        GO TO 120
1323  110   IS = IS + 1
1324  120   IB = IPE(I)
1325        IF (IB.LT.0) GOTO 150
1326        IF (IB.EQ.0) GOTO 140
1327        NA(IL) = 0
1328  140   I = IB
1329        GO TO 160
1330  150   I = -IB
1331        IL = IL + 1
1332  160 CONTINUE
1333      NSTEPS = IS - 1
1334      DO 170 I=1,N
1335        K = FILS(I)
1336        IF (K.GT.0) THEN
1337          FRERE(K)  = N + 1
1338          NFSIZ(K)  = 0
1339        ENDIF
1340 170  CONTINUE
1341      RETURN
1342      END SUBROUTINE DMUMPS_ANA_L
1343#else
1344      SUBROUTINE DMUMPS_ANA_LNEW(N, IPE, NV, IPS, NE, NA, NFSIZ,
1345     &               NODE, NSTEPS,
1346     &               FILS, FRERE, ND, NEMIN, SUBORD, KEEP60,
1347     &               KEEP20, KEEP38, NAMALG,NAMALGMAX,
1348     &               CUMUL,KEEP50, ICNTL13, KEEP37, NSLAVES,
1349     &               ALLOW_AMALG_TINY_NODES)
1350      IMPLICIT NONE
1351      INTEGER  N, NSTEPS, KEEP60, KEEP20, KEEP38, KEEP50
1352      INTEGER ND(N), NFSIZ(N)
1353      INTEGER IPE(N), FILS(N), FRERE(N), SUBORD(N)
1354      INTEGER NV(N), IPS(N), NE(N), NA(N), NODE(N)
1355      INTEGER NEMIN,AMALG_COUNT
1356      INTEGER NAMALG(N),NAMALGMAX, CUMUL(N)
1357      DOUBLE PRECISION SIZE_DADI_AMALGAMATED, PERCENT_FILL
1358      DOUBLE PRECISION ACCU, FLOPS_FATHER, FLOPS_SON,
1359     &                  FLOPS_AVANT, FLOPS_APRES
1360      INTEGER ICNTL13, KEEP37, NSLAVES
1361      LOGICAL ALLOW_AMALG_TINY_NODES
1362#if  defined(NOAMALGTOFATHER)
1363#else
1364#endif
1365      INTEGER I,IF,IS,NR,INS
1366      INTEGER K,L,ISON,IN,IFSON,INO
1367      INTEGER INOS,IB,IL
1368      INTEGER IPERM
1369      INTEGER MAXNODE
1370#if defined(NOAMALGTOFATHER)
1371      INTEGER INB,INF,INFS,INL,INSW,INT,NR1
1372#else
1373      INTEGER DADI
1374      LOGICAL AMALG_TO_father_OK
1375#endif
1376      AMALG_COUNT = 0
1377      DO 10 I=1,N
1378        CUMUL(I)= 0
1379        IPS(I)  = 0
1380        NE(I)   = 0
1381        NODE(I) = 1
1382        SUBORD(I) = 0
1383        NAMALG(I) = 0
1384   10 CONTINUE
1385      FRERE(1:N) = IPE(1:N)
1386      NR = N + 1
1387      MAXNODE = 1
1388      DO 50 I=1,N
1389        IF = -FRERE(I)
1390        IF (NV(I).EQ.0) THEN
1391          IF (SUBORD(IF).NE.0) SUBORD(I) = SUBORD(IF)
1392          SUBORD(IF) = I
1393          NODE(IF) = NODE(IF)+1
1394          MAXNODE = max(NODE(IF),MAXNODE)
1395        ELSE
1396          IF (IF.NE.0) THEN
1397            IS = -IPS(IF)
1398            IF (IS.GT.0) FRERE(I) = IS
1399            IPS(IF) = -I
1400          ELSE
1401            NR = NR - 1
1402            NE(NR) = I
1403          ENDIF
1404        ENDIF
1405   50 CONTINUE
1406        MAXNODE = int(dble(MAXNODE)*dble(NEMIN) / dble(100))
1407        MAXNODE = max(MAXNODE,2000)
1408#if defined(NOAMALGTOFATHER)
1409      DO 999 I=1,N
1410       FILS(I) = IPS(I)
1411 999  CONTINUE
1412      NR1 = NR
1413      INS = 0
1414 1000 IF (NR1.GT.N) GO TO 1151
1415      INS = NE(NR1)
1416      NR1 = NR1 + 1
1417 1070 INL = FILS(INS)
1418      IF (INL.LT.0) THEN
1419       INS = -INL
1420       GO TO 1070
1421      ENDIF
1422 1080 IF (FRERE(INS).LT.0) THEN
1423       INS       = -FRERE(INS)
1424       FILS(INS) = 0
1425       GO TO 1080
1426      ENDIF
1427      IF (FRERE(INS).EQ.0) THEN
1428       INS = 0
1429       GO TO 1000
1430      ENDIF
1431      INB = FRERE(INS)
1432      IF (NV(INB).GE.NV(INS)) THEN
1433       INS = INB
1434       GO TO 1070
1435      ENDIF
1436      INF = INB
1437 1090 INF = FRERE(INF)
1438      IF (INF.GT.0) GO TO 1090
1439      INF  = -INF
1440      INFS = -FILS(INF)
1441      IF (INFS.EQ.INS) THEN
1442        FILS(INF) = -INB
1443        IPS(INF)  = -INB
1444        FRERE(INS)  = FRERE(INB)
1445        FRERE(INB)  = INS
1446      ELSE
1447        INSW = INFS
1448 1100   INFS = FRERE(INSW)
1449        IF (INFS.NE.INS) THEN
1450          INSW = INFS
1451          GO TO 1100
1452        ENDIF
1453        FRERE(INS) = FRERE(INB)
1454        FRERE(INB) = INS
1455        FRERE(INSW)= INB
1456      ENDIF
1457        INS      = INB
1458        GO TO 1070
1459#endif
1460      DO 51 I=1,N
1461       FILS(I) = IPS(I)
1462 51   CONTINUE
1463      IS = 1
1464      I = 0
1465      IPERM = 1
1466      DO 160 K=1,N
1467        AMALG_TO_father_OK=.FALSE.
1468        IF (I.LE.0) THEN
1469         IF (NR.GT.N) EXIT
1470         I = NE(NR)
1471         NE(NR) = 0
1472         NR = NR + 1
1473         IL = N
1474         NA(N) = 0
1475        ENDIF
1476        DO 70 L=1,N
1477          IF (IPS(I).GE.0) EXIT
1478          ISON = -IPS(I)
1479          IPS(I) = 0
1480          I = ISON
1481          IL = IL - 1
1482          NA(IL) = 0
1483   70   CONTINUE
1484#if ! defined(NOAMALGTOFATHER)
1485        DADI = -IPE(I)
1486        IF ( (DADI.NE.0) .AND.
1487     &      (
1488     &       (KEEP60.EQ.0).OR.
1489     &       ( (KEEP20.NE.DADI).AND.(KEEP38.NE.DADI) )
1490     &      )
1491     &     ) THEN
1492           ACCU = dble(2)*dble(NODE(I))*dble(NV(DADI)-NV(I)+NODE(I))
1493           SIZE_DADI_AMALGAMATED =
1494     &           dble(NV(DADI)+NODE(I)) *
1495     &           dble(NV(DADI)+NODE(I))
1496           PERCENT_FILL = dble(100) * ACCU / SIZE_DADI_AMALGAMATED
1497           ACCU = ACCU + dble(CUMUL(I))
1498           AMALG_TO_father_OK =  (
1499     &           ( (NODE(I).LE.MAXNODE).AND.(NODE(DADI).LE.MAXNODE) )
1500     &         .OR.
1501     &           ( (NODE(I).LE.NEMIN.and. NODE(DADI).GT. MAXNODE)
1502     &     .OR.(NODE(DADI).LE.NEMIN .and. NODE(I).GT.MAXNODE)))
1503           AMALG_TO_father_OK = ( AMALG_TO_father_OK .AND.
1504     &       ( PERCENT_FILL < dble(NEMIN) ) )
1505           AMALG_TO_father_OK = ( AMALG_TO_father_OK .AND.
1506     &     ( ACCU / SIZE_DADI_AMALGAMATED .LE. dble(NEMIN)) )
1507           IF (AMALG_TO_father_OK) THEN
1508              CALL MUMPS_GET_FLOPS_COST(NV(I),NODE(I),NODE(I),
1509     &                                  KEEP50,1,FLOPS_SON)
1510              CALL MUMPS_GET_FLOPS_COST(NV(DADI),NODE(DADI),
1511     &                             NODE(DADI),
1512     &                             KEEP50,1,FLOPS_FATHER)
1513              FLOPS_AVANT = FLOPS_FATHER+FLOPS_SON
1514     &                      + max(dble(200.0) * dble(NV(I)-NODE(I))
1515     &                            * dble(NV(I)-NODE(I)),
1516     &                            dble(10000.0))
1517              CALL MUMPS_GET_FLOPS_COST(NV(DADI)+NODE(I),
1518     &                             NODE(DADI)+NODE(I),
1519     &                             NODE(DADI)+NODE(I),
1520     &                             KEEP50,1,FLOPS_APRES)
1521              IF (FLOPS_APRES.GT.FLOPS_AVANT*
1522     &         (dble(1)+dble(max(8,NEMIN)-8)/dble(100))) THEN
1523                 AMALG_TO_father_OK = .FALSE.
1524              ENDIF
1525           ENDIF
1526           IF ( (NV(I).GT. 50*NV(DADI)).AND. (NSLAVES.GT.1)
1527     &          .AND. (ICNTL13.LE.0)
1528     &          .AND. (NV(I).GT. KEEP37) )  THEN
1529             AMALG_TO_father_OK = .TRUE.
1530           ENDIF
1531           IF ( ALLOW_AMALG_TINY_NODES .AND.
1532     &     NODE(I) * 900 .LE. NV(DADI) - NAMALG(DADI)) THEN
1533             IF ( NAMALG(DADI) < (NV(DADI)-NAMALG(DADI))/50 ) THEN
1534                AMALG_TO_father_OK = .TRUE.
1535                NAMALG(DADI) = NAMALG(DADI) + NODE(I)
1536             ENDIF
1537           ENDIF
1538           IF ( DADI .EQ. -FRERE(I)
1539     &       .AND. -FILS(DADI).EQ.I
1540     &       ) THEN
1541             AMALG_TO_father_OK = ( AMALG_TO_father_OK .OR.
1542     &                          ( NV(I)-NODE(I).EQ.NV(DADI)) )
1543           ENDIF
1544           IF (AMALG_TO_father_OK) THEN
1545             CUMUL(DADI)=CUMUL(DADI)+nint(ACCU)
1546             NAMALG(DADI) = NAMALG(DADI) + NAMALG(I)
1547             AMALG_COUNT = AMALG_COUNT+1
1548             IN = DADI
1549 75          IF (SUBORD(IN).EQ.0) GOTO 76
1550               IN = SUBORD(IN)
1551               GOTO 75
1552 76          CONTINUE
1553             SUBORD(IN) = I
1554             NV(I)      = 0
1555             IFSON = -FILS(DADI)
1556             IF (IFSON.EQ.I) THEN
1557              IF (FILS(I).LT.0) THEN
1558                FILS(DADI) =  FILS(I)
1559                GOTO 78
1560              ELSE
1561                IF (FRERE(I).GT.0) THEN
1562                  FILS(DADI) = -FRERE(I)
1563                ELSE
1564                  FILS(DADI) = 0
1565                ENDIF
1566                GOTO 90
1567              ENDIF
1568             ENDIF
1569             IN = IFSON
1570  77         INS = IN
1571             IN = FRERE(IN)
1572             IF (IN.NE.I) GOTO 77
1573             IF (FILS(I) .LT.0) THEN
1574               FRERE(INS) = -FILS(I)
1575             ELSE
1576               FRERE(INS) = FRERE(I)
1577               GOTO 90
1578             ENDIF
1579  78         CONTINUE
1580             IN = -FILS(I)
1581  79         INO = IN
1582             IN = FRERE(IN)
1583             IF (IN.GT.0) GOTO 79
1584             FRERE(INO) = FRERE(I)
1585  90         CONTINUE
1586             NODE(DADI) = NODE(DADI)+ NODE(I)
1587             NV(DADI)   = NV(DADI) +  NODE(I)
1588             NA(IL+1)   = NA(IL+1) + NA(IL)
1589             GOTO 120
1590           ENDIF
1591        ENDIF
1592#endif
1593        NE(IS) = NE(IS) + NODE(I)
1594        IF (IL.LT.N) NA(IL+1) = NA(IL+1) + 1
1595        NA(IS) = NA(IL)
1596        ND(IS) = NV(I)
1597        NODE(I) = IS
1598        IPS(I) = IPERM
1599        IPERM = IPERM + 1
1600        IN = I
1601  777   IF (SUBORD(IN).EQ.0) GO TO 778
1602          IN = SUBORD(IN)
1603          NODE(IN) = IS
1604          IPS(IN) = IPERM
1605          IPERM = IPERM + 1
1606          GO TO 777
1607  778   IF (NA(IS).LE.0) GO TO 110
1608#if defined(NOAMALGTOFATHER)
1609        IF (   (KEEP60.NE.0).AND.
1610     &         (NE(IS).EQ.ND(IS)) ) GOTO 110
1611        IF (ND(IS-1)-NE(IS-1).EQ.ND(IS)) THEN
1612           GO TO 100
1613        ENDIF
1614        IF(NAMALG(IS-1) .GE. NAMALGMAX) THEN
1615           GOTO 110
1616        ENDIF
1617        IF ((NE(IS-1).GE.NEMIN).AND.
1618     &         (NE(IS).GE.NEMIN) ) GO TO 110
1619        IF (2*NE(IS-1)*(ND(IS)-ND(IS-1)+NE(IS-1)).GE.
1620     &    ((ND(IS)+NE(IS-1))*
1621     &    (ND(IS)+NE(IS-1))*NEMIN/100)) GO TO 110
1622        NAMALG(IS-1) = NAMALG(IS-1)+1
1623  100   NA(IS-1) = NA(IS-1) + NA(IS) - 1
1624        ND(IS-1) = ND(IS) + NE(IS-1)
1625        NE(IS-1) = NE(IS) + NE(IS-1)
1626        NE(IS) = 0
1627        NODE(I) = IS-1
1628        IFSON = -FILS(I)
1629        IN = IFSON
1630 102    INO = IN
1631        IN =  FRERE(IN)
1632        IF (IN.GT.0) GO TO 102
1633        NV(INO) = 0
1634        IN = I
1635  888   IF (SUBORD(IN).EQ.0) GO TO 889
1636        IN = SUBORD(IN)
1637        GO TO 888
1638  889   SUBORD(IN) = INO
1639      INOS = -FILS(INO)
1640      IF (IFSON.EQ.INO) THEN
1641         FILS(I) = -INOS
1642         GO TO 107
1643      ENDIF
1644      IN = IFSON
1645 105  INS = IN
1646      IN =  FRERE(IN)
1647      IF (IN.NE.INO) GO TO 105
1648        IF (INOS.EQ.0) THEN
1649          FRERE(INS) = -I
1650          GO TO 120
1651        ELSE
1652          FRERE(INS) =  INOS
1653        ENDIF
1654 107    IN = INOS
1655        IF (IN.EQ.0) GO TO 120
1656 108    INT = IN
1657        IN =  FRERE(IN)
1658        IF (IN.GT.0) GO TO 108
1659        FRERE(INT) = -I
1660        GO TO 120
1661#endif
1662  110   IS = IS + 1
1663  120   IB = FRERE(I)
1664        IF (IB.GE.0) THEN
1665          IF (IB.GT.0) NA(IL) = 0
1666          I = IB
1667        ELSE
1668          I = -IB
1669          IL = IL + 1
1670        ENDIF
1671  160 CONTINUE
1672      NSTEPS = IS - 1
1673      DO I=1, N
1674        IF (NV(I).EQ.0) THEN
1675          FRERE(I) = N+1
1676          NFSIZ(I) = 0
1677        ELSE
1678          NFSIZ(I) = ND(NODE(I))
1679          IF (SUBORD(I) .NE.0) THEN
1680           INOS = -FILS(I)
1681           INO = I
1682           DO WHILE (SUBORD(INO).NE.0)
1683             IS = SUBORD(INO)
1684             FILS(INO) = IS
1685             INO = IS
1686           END DO
1687           FILS(INO) = -INOS
1688          ENDIF
1689        ENDIF
1690      ENDDO
1691      RETURN
1692      END SUBROUTINE DMUMPS_ANA_LNEW
1693#endif
1694      SUBROUTINE DMUMPS_ANA_M(NE, ND, NSTEPS,
1695     & MAXFR, MAXELIM, K50, MAXFAC, MAXNPIV,
1696     & K5,K6,PANEL_SIZE,K253)
1697      IMPLICIT NONE
1698      INTEGER NSTEPS,MAXNPIV
1699      INTEGER MAXFR, MAXELIM, K50, MAXFAC
1700      INTEGER K5,K6,PANEL_SIZE,K253
1701      INTEGER NE(NSTEPS), ND(NSTEPS)
1702      INTEGER ITREE, NFR, NELIM
1703      INTEGER LKJIB
1704      LKJIB   = max(K5,K6)
1705      MAXFR   = 0
1706      MAXFAC  = 0
1707      MAXELIM = 0
1708      MAXNPIV = 0
1709      PANEL_SIZE = 0
1710      DO ITREE=1,NSTEPS
1711        NELIM = NE(ITREE)
1712        NFR = ND(ITREE) + K253
1713        IF (NFR.GT.MAXFR)         MAXFR   = NFR
1714        IF (NFR-NELIM.GT.MAXELIM) MAXELIM = NFR - NELIM
1715        IF (NELIM .GT. MAXNPIV) THEN
1716           MAXNPIV = NELIM
1717        ENDIF
1718        IF (K50.EQ.0) THEN
1719          MAXFAC = max(MAXFAC, (2*NFR - NELIM)*NELIM )
1720          PANEL_SIZE = max(PANEL_SIZE, NFR*(LKJIB+1))
1721        ELSE
1722         MAXFAC = max(MAXFAC, NFR * NELIM)
1723         PANEL_SIZE = max(PANEL_SIZE, NELIM*(LKJIB+1))
1724         PANEL_SIZE = max(PANEL_SIZE, (NFR-NELIM)*(LKJIB+1))
1725        ENDIF
1726      END DO
1727      RETURN
1728      END SUBROUTINE DMUMPS_ANA_M
1729      SUBROUTINE DMUMPS_ANA_R( N, FILS, FRERE,
1730     & NSTK, NA )
1731      IMPLICIT NONE
1732      INTEGER, INTENT(IN)  :: N
1733      INTEGER, INTENT(IN)  :: FILS(N), FRERE(N)
1734      INTEGER, INTENT(OUT) ::  NSTK(N), NA(N)
1735      INTEGER NBROOT, NBLEAF, ILEAF, I, IN, ISON
1736      NA   = 0
1737      NSTK = 0
1738      NBROOT  = 0
1739      ILEAF   = 1
1740      DO 11 I=1,N
1741         IF (FRERE(I).EQ. N+1) CYCLE
1742         IF (FRERE(I).EQ.0) NBROOT = NBROOT + 1
1743         IN = I
1744 12      IN = FILS(IN)
1745         IF (IN.GT.0) GO TO 12
1746         IF (IN.EQ.0) THEN
1747            NA(ILEAF) = I
1748            ILEAF     = ILEAF + 1
1749            CYCLE
1750         ENDIF
1751         ISON = -IN
1752 13      NSTK(I) = NSTK(I) + 1
1753         ISON = FRERE(ISON)
1754         IF (ISON.GT.0) GO TO 13
1755 11   CONTINUE
1756      NBLEAF = ILEAF-1
1757      IF (N.GT.1) THEN
1758         IF (NBLEAF.GT.N-2) THEN
1759            IF (NBLEAF.EQ.N-1) THEN
1760               NA(N-1) = -NA(N-1)-1
1761               NA(N)   = NBROOT
1762            ELSE
1763               NA(N) = -NA(N)-1
1764            ENDIF
1765         ELSE
1766            NA(N-1) = NBLEAF
1767            NA(N)   = NBROOT
1768         ENDIF
1769      ENDIF
1770      RETURN
1771      END SUBROUTINE DMUMPS_ANA_R
1772      SUBROUTINE DMUMPS_ANA_O( N, NZ, MTRANS, PERM,
1773     &     id, ICNTL, INFO)
1774      USE DMUMPS_STRUC_DEF
1775      IMPLICIT NONE
1776      TYPE (DMUMPS_STRUC)    :: id
1777      INTEGER, INTENT(IN)    :: N
1778      INTEGER(8), INTENT(IN) :: NZ
1779      INTEGER, INTENT(OUT)   :: PERM(N)
1780      INTEGER, INTENT(INOUT) :: MTRANS
1781      INTEGER, INTENT(IN)   :: ICNTL(40)
1782      INTEGER, INTENT(INOUT) :: INFO(40)
1783      INTEGER    :: allocok
1784      INTEGER, ALLOCATABLE, DIMENSION(:) :: IW
1785      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: S2
1786      TARGET :: S2
1787      INTEGER ICNTL64(10), INFO64(10)
1788      INTEGER ICNTL_SYM_MWM(10),INFO_SYM_MWM(10)
1789      DOUBLE PRECISION CNTL64(10)
1790      INTEGER MPRINT,LP, MP
1791      INTEGER JPERM
1792      INTEGER NUMNZ, I, J, JPOS
1793      LOGICAL PROK, IDENT, DUPPLI
1794      INTEGER K50, KER_SIZE, NZER_DIAG, MTRANSLOC,RZ_DIAG
1795      INTEGER(8) :: LIWG
1796      INTEGER(8), DIMENSION(:), ALLOCATABLE :: IPE
1797      INTEGER(8), DIMENSION(:), ALLOCATABLE :: IPQ8
1798      INTEGER    :: LSC
1799      INTEGER(8) :: NZTOT, NZREAL, IPIW, LIW, LIWMIN, NZsave,
1800     &              K, KPOS, LDW, LDWMIN, IRNW, RSPOS, CSPOS,
1801     &              LS2,J8, N8
1802      LOGICAL SCALINGLOC
1803      INTEGER,POINTER,DIMENSION(:) :: ZERODIAG
1804      INTEGER,POINTER,DIMENSION(:) :: STR_KER
1805      INTEGER,POINTER,DIMENSION(:) :: MARKED
1806      INTEGER,POINTER,DIMENSION(:) :: FLAG
1807      INTEGER,POINTER,DIMENSION(:) :: PIV_OUT
1808      DOUBLE PRECISION THEMIN, THEMAX, COLNORM,MAXDBL
1809      DOUBLE PRECISION ZERO,TWO,ONE
1810      PARAMETER(ZERO = 0.0D0,TWO = 2.0D0,ONE = 1.0D0)
1811      N8     = int(N,8)
1812      MPRINT = ICNTL(3)
1813      LP     = ICNTL(1)
1814      MP     = ICNTL(2)
1815      PROK   = ((MPRINT.GT.0).AND.(ICNTL(4).GE.2))
1816      IF (PROK) WRITE(MPRINT,101)
1817 101  FORMAT(/'****** Preprocessing of original matrix '/)
1818      K50 = id%KEEP(50)
1819      SCALINGLOC = .FALSE.
1820      IF(id%KEEP(52) .EQ. -2) THEN
1821         IF(.not.associated(id%A)) THEN
1822            INFO(1) = -22
1823            INFO(2) = 4
1824            GOTO 500
1825         ELSE
1826            SCALINGLOC = .TRUE.
1827         ENDIF
1828      ELSE IF(id%KEEP(52) .EQ. 77) THEN
1829         SCALINGLOC = .TRUE.
1830         IF(K50 .NE. 2) THEN
1831            IF( MTRANS .NE. 5 .AND. MTRANS .NE. 6
1832     &           .AND. MTRANS .NE. 7) THEN
1833               SCALINGLOC = .FALSE.
1834               IF (PROK)
1835     &              WRITE(MPRINT,*) 'Analysis: auto scaling set OFF'
1836            ENDIF
1837         ENDIF
1838         IF(.not.associated(id%A)) THEN
1839            SCALINGLOC = .FALSE.
1840            IF (PROK)
1841     &           WRITE(MPRINT,*) 'Analysis: auto scaling set OFF'
1842         ENDIF
1843      ENDIF
1844      IF(SCALINGLOC) THEN
1845         IF (PROK) WRITE(MPRINT,*)
1846     &        'Scaling will be computed during analysis'
1847      ENDIF
1848      MTRANSLOC = MTRANS
1849      IF (MTRANS.LT.0 .OR. MTRANS.GT.7) GO TO 500
1850      IF (K50 .EQ. 0) THEN
1851         IF(.NOT. SCALINGLOC .AND. MTRANS .EQ. 7) THEN
1852            GO TO 500
1853         ENDIF
1854         IF(SCALINGLOC) THEN
1855            MTRANSLOC = 5
1856         ENDIF
1857      ELSE
1858         IF (MTRANS .EQ. 7) MTRANSLOC = 5
1859      ENDIF
1860      IF(SCALINGLOC .AND. MTRANSLOC .NE. 5 .AND.
1861     &     MTRANSLOC .NE. 6 ) THEN
1862         IF (PROK) WRITE(MPRINT,*)
1863     &        'WARNING scaling required: set MTRANS option to 5'
1864         MTRANSLOC = 5
1865      ENDIF
1866      IF (N.EQ.1) THEN
1867        MTRANS=0
1868        GO TO 500
1869      ENDIF
1870      IF(K50 .NE. 0) THEN
1871         NZTOT = 2_8*NZ+N8
1872      ELSE
1873         NZTOT = NZ
1874      ENDIF
1875      ZERODIAG => id%IS1(N+1:2*N)
1876      STR_KER => id%IS1(2*N+1:3*N)
1877      CALL DMUMPS_MTRANSI(ICNTL64,CNTL64)
1878      ICNTL64(1) = ICNTL(1)
1879      ICNTL64(2) = ICNTL(2)
1880      ICNTL64(3) = ICNTL(2)
1881      ICNTL64(4) = -1
1882      IF (ICNTL(4).EQ.3) ICNTL64(4) = 0
1883      IF (ICNTL(4).EQ.4) ICNTL64(4) = 1
1884      ICNTL64(5) = -1
1885      IF (PROK) THEN
1886         WRITE(MPRINT,'(A,I3)')
1887     &     'Compute maximum matching (Maximum Transversal):',
1888     &        MTRANSLOC
1889         IF (MTRANSLOC.EQ.1)
1890     &   WRITE(MPRINT,'(A,I3)')' ... JOB =',MTRANSLOC
1891         IF (MTRANSLOC.EQ.2)
1892     &   WRITE(MPRINT,'(A,I3,A)')
1893     &     ' ... JOB =',MTRANSLOC,': BOTTLENECK THESIS'
1894         IF (MTRANSLOC.EQ.3)
1895     &   WRITE(MPRINT,'(A,I3,A)')
1896     &     ' ... JOB =',MTRANSLOC,': BOTTLENECK SIMAX'
1897         IF (MTRANSLOC.EQ.4)
1898     &   WRITE(MPRINT,'(A,I3,A)')
1899     &     ' ... JOB =',MTRANSLOC,': MAXIMIZE SUM DIAGONAL'
1900         IF (MTRANSLOC.EQ.5 .OR. MTRANSLOC.EQ.6)
1901     &   WRITE(MPRINT,'(A,I3,A)')
1902     &     ' ... JOB =',MTRANSLOC,
1903     &     ': MAXIMIZE PRODUCT DIAGONAL AND SCALE'
1904      ENDIF
1905      id%INFOG(23) = MTRANSLOC
1906      CNTL64(2) = huge(CNTL64(2))
1907      IRNW = 1
1908      IPIW = IRNW + NZTOT
1909      IF (MTRANSLOC.EQ.1) LIWMIN = 5_8*N8
1910      IF (MTRANSLOC.EQ.2) LIWMIN = 3_8*N8
1911      IF (MTRANSLOC.EQ.3) LIWMIN = 10_8*N8 + NZTOT
1912      IF (MTRANSLOC.EQ.4) LIWMIN = 2_8*N8
1913      IF (MTRANSLOC.EQ.5) LIWMIN = 5_8*N8
1914      IF (MTRANSLOC.EQ.6) LIWMIN = 5_8*N8 + NZTOT
1915      LIW = LIWMIN
1916      LIWG  = LIW + NZTOT
1917      ALLOCATE(IW(LIWG), stat=allocok)
1918      IF (allocok .GT. 0 ) GOTO 410
1919      ALLOCATE( IPQ8(N), IPE(N+1), stat = allocok )
1920      IF ( allocok .GT. 0 ) THEN
1921         INFO( 1 ) = -7
1922         INFO( 2 ) = (2*N+1)*id%KEEP(10)
1923         GOTO 500
1924      ENDIF
1925      IF (MTRANSLOC.EQ.1) THEN
1926       LDWMIN = N8+3_8
1927      ENDIF
1928      IF (MTRANSLOC.EQ.2) LDWMIN = max( N8+NZTOT , N8+3_8 )
1929      IF (MTRANSLOC.EQ.3) LDWMIN = max( NZTOT+1_8 , N8+3_8 )
1930      IF (MTRANSLOC.EQ.4) LDWMIN = 2_8 * N8 +
1931     &                             max( NZTOT , N8+3_8 )
1932      IF (MTRANSLOC.EQ.5) LDWMIN = 3_8*N8 + NZTOT
1933      IF (MTRANSLOC.EQ.6) LDWMIN = 4_8*N8 + NZTOT
1934      LDW   = LDWMIN
1935      ALLOCATE(S2(LDW), stat=allocok)
1936      IF (allocok .GT. 0 ) GOTO 430
1937      IF(MTRANSLOC .NE. 1) LDW = LDW-NZTOT
1938      RSPOS = NZTOT
1939      CSPOS = RSPOS+N8
1940      NZREAL = 0_8
1941      DO 5 J=1,N
1942        IPQ8(J) = 0_8
1943  5   CONTINUE
1944      IF(K50 .EQ. 0) THEN
1945         DO 10 K=1,NZ
1946            I = id%IRN(K)
1947            J = id%JCN(K)
1948            IF ( (J.LE.N).AND.(J.GE.1).AND.
1949     &           (I.LE.N).AND.(I.GE.1) ) THEN
1950               IPQ8(J) = IPQ8(J) + 1_8
1951               NZREAL = NZREAL + 1_8
1952            ENDIF
1953 10      CONTINUE
1954      ELSE
1955         ZERODIAG = 0
1956         NZER_DIAG = N
1957         RZ_DIAG = 0
1958         DO K=1,NZ
1959            I = id%IRN(K)
1960            J = id%JCN(K)
1961            IF ( (J.LE.N).AND.(J.GE.1).AND.
1962     &           (I.LE.N).AND.(I.GE.1) ) THEN
1963               IPQ8(J) = IPQ8(J) + 1_8
1964               NZREAL = NZREAL + 1_8
1965               IF(I .NE. J) THEN
1966                  IPQ8(I) = IPQ8(I) + 1_8
1967                  NZREAL = NZREAL + 1_8
1968               ELSE
1969                  IF(ZERODIAG(I) .EQ. 0) THEN
1970                     ZERODIAG(I) = 1
1971                     IF(associated(id%A)) THEN
1972                        IF(abs(id%A(K)) .EQ. dble(0.0D0)) THEN
1973                           RZ_DIAG = RZ_DIAG + 1
1974                        ENDIF
1975                     ENDIF
1976                     NZER_DIAG = NZER_DIAG - 1
1977                  ENDIF
1978               ENDIF
1979            ENDIF
1980         ENDDO
1981         IF(MTRANSLOC .GE. 4) THEN
1982            DO I =1, N
1983               IF(ZERODIAG(I) .EQ. 0) THEN
1984                  IPQ8(I) = IPQ8(I) + 1_8
1985                  NZREAL = NZREAL + 1_8
1986               ENDIF
1987            ENDDO
1988         ENDIF
1989      ENDIF
1990      IPE(1)   = 1
1991      DO 20 J=1,N
1992        IPE(J+1)   = IPE(J)+IPQ8(J)
1993  20  CONTINUE
1994      DO 25 J=1, N
1995        IPQ8(J ) = IPE(J)
1996  25  CONTINUE
1997      IF(K50 .EQ. 0) THEN
1998         IF (MTRANSLOC.EQ.1) THEN
1999            DO K=1,NZ
2000               I = id%IRN(K)
2001               J = id%JCN(K)
2002               IF ( (J.LE.N).AND.(J.GE.1) .AND.
2003     &              (I.LE.N).AND.(I.GE.1)) THEN
2004                  KPOS              = IPQ8(J)
2005                  IW(IRNW+KPOS-1_8) = I
2006                  IPQ8(J)   = IPQ8(J) + 1_8
2007               ENDIF
2008            END DO
2009         ELSE
2010            IF ( .not.associated(id%A)) THEN
2011               INFO(1) = -22
2012               INFO(2) = 4
2013               GOTO 500
2014            ENDIF
2015            DO K=1,NZ
2016               I = id%IRN(K)
2017               J = id%JCN(K)
2018               IF ( (J.LE.N).AND.(J.GE.1) .AND.
2019     &              (I.LE.N).AND.(I.GE.1)) THEN
2020                  KPOS            = IPQ8(J)
2021                  IW(IRNW+KPOS-1) = I
2022                  S2(KPOS)         = abs(id%A(K))
2023                  IPQ8(J)   = IPQ8(J) + 1_8
2024               ENDIF
2025            END DO
2026         ENDIF
2027      ELSE
2028         IF (MTRANSLOC.EQ.1) THEN
2029            DO K=1,NZ
2030               I = id%IRN(K)
2031               J = id%JCN(K)
2032               IF ( (J.LE.N).AND.(J.GE.1) .AND.
2033     &              (I.LE.N).AND.(I.GE.1)) THEN
2034                  KPOS            = IPQ8(J)
2035                  IW(IRNW+KPOS-1) = I
2036                  IPQ8(J)   = IPQ8(J) + 1_8
2037                  IF(I.NE.J) THEN
2038                     KPOS            = IPQ8(I)
2039                     IW(IRNW+KPOS-1) = J
2040                     IPQ8(I)   = IPQ8(I) + 1_8
2041                  ENDIF
2042               ENDIF
2043            ENDDO
2044         ELSE
2045            IF ( .not.associated(id%A)) THEN
2046               INFO(1) = -22
2047               INFO(2) = 4
2048               GOTO 500
2049            ENDIF
2050            K = 1_8
2051            THEMIN = ZERO
2052            DO
2053               IF(THEMIN .NE. ZERO) EXIT
2054               THEMIN = abs(id%A(K))
2055               K = K+1_8
2056            ENDDO
2057            THEMAX = THEMIN
2058            DO K=1,NZ
2059               I = id%IRN(K)
2060               J = id%JCN(K)
2061               IF ( (J.LE.N).AND.(J.GE.1) .AND.
2062     &              (I.LE.N).AND.(I.GE.1)) THEN
2063                  KPOS            = IPQ8(J)
2064                  IW(IRNW+KPOS-1_8) = I
2065                  S2(KPOS)          = abs(id%A(K))
2066                  IPQ8(J)   = IPQ8(J) + 1_8
2067                  IF(abs(id%A(K)) .GT. THEMAX) THEN
2068                     THEMAX = abs(id%A(K))
2069                  ELSE IF(abs(id%A(K)) .LT. THEMIN
2070     &                    .AND. abs(id%A(K)).GT. ZERO) THEN
2071                     THEMIN = abs(id%A(K))
2072                  ENDIF
2073                  IF(I.NE.J) THEN
2074                     KPOS            = IPQ8(I)
2075                     IW(IRNW+KPOS-1) = J
2076                     S2(KPOS)         = abs(id%A(K))
2077                     IPQ8(I)   = IPQ8(I) + 1_8
2078                  ENDIF
2079               ENDIF
2080            ENDDO
2081            DO I =1, N
2082               IF(ZERODIAG(I) .EQ. 0) THEN
2083                  KPOS            = IPQ8(I)
2084                  IW(IRNW+KPOS-1) = I
2085                  S2(KPOS)         = ZERO
2086                  IPQ8(I)   = IPQ8(I) + 1_8
2087               ENDIF
2088            ENDDO
2089            CNTL64(2) = (log(THEMAX/THEMIN))*(dble(N))
2090     &           - log(THEMIN) + ONE
2091         ENDIF
2092      ENDIF
2093      DUPPLI = .FALSE.
2094      NZsave = NZREAL
2095      FLAG => id%IS1(3*N+1:4*N)
2096      IF(MTRANSLOC.NE.1) THEN
2097         CALL DMUMPS_SUPPRESS_DUPPLI_VAL(N,NZREAL,IPE(1),IW(IRNW),S2,
2098     &        PERM,IPQ8(1))
2099      ELSE
2100         CALL DMUMPS_SUPPRESS_DUPPLI_STR(N,NZREAL,IPE(1),IW(IRNW),
2101     &        PERM)
2102      ENDIF
2103      IF(NZREAL .NE. NZsave) DUPPLI = .TRUE.
2104      LS2 = NZTOT
2105      IF ( MTRANSLOC .EQ. 1 ) THEN
2106         LS2 = 1_8
2107         LDW = 1_8
2108      ENDIF
2109      CALL DMUMPS_MTRANS_DRIVER(MTRANSLOC ,N, N, NZREAL,
2110     &     IPE, IW(IRNW), S2(1), LS2,
2111     &     NUMNZ, PERM, LIW, IW(IPIW), LDW, S2(LS2+1),
2112     &     IPQ8,
2113     &     ICNTL64, CNTL64, INFO64, INFO)
2114      IF (INFO(1).LT.0) THEN
2115         IF (LP.GT.0 .AND. ICNTL(4).GE.1)
2116     &        WRITE(LP,'(A,I5)')
2117     &   ' Not enough memory in MAXTRANS INFO(1)=',INFO(1)
2118         GOTO 500
2119      ENDIF
2120      IF (INFO64(1).LT.0) THEN
2121         IF (LP.GT.0 .AND. ICNTL(4).GE.1)
2122     &        WRITE(LP,'(A,I5)')
2123     &   ' INTERNAL ERROR in MAXTRANS INFO(1)=',INFO64(1)
2124         INFO(1) = -9964
2125         INFO(2) = INFO64(1)
2126         GO TO 500
2127      ENDIF
2128      IF (INFO64(1).GT.0) THEN
2129         IF (MP.GT.0 .AND. ICNTL(4).GE.2)
2130     &        WRITE(MP,'(A,I5)')
2131     &        ' WARNING in MAXTRANS INFO(1)=',INFO64(1)
2132      ENDIF
2133      KER_SIZE = 0
2134      IF(K50 .EQ. 2) THEN
2135         DO I=1,N
2136            IF(ZERODIAG(I) .EQ. 0) THEN
2137               IF(PERM(I) .EQ. I) THEN
2138                  KER_SIZE = KER_SIZE + 1
2139                  PERM(I) = -I
2140                  STR_KER(KER_SIZE) = I
2141               ENDIF
2142            ENDIF
2143         ENDDO
2144      ENDIF
2145      IF (NUMNZ.LT.N) GO TO 400
2146      IF(K50 .EQ. 0) THEN
2147         IDENT = .TRUE.
2148         IF (MTRANS .EQ. 0 ) GOTO 102
2149         DO 80 J=1,N
2150            JPERM = PERM(J)
2151            IW(IRNW+int(JPERM-1,8)) = J
2152            IF (JPERM.NE.J) IDENT = .FALSE.
2153 80      CONTINUE
2154         IF(IDENT) THEN
2155            MTRANS = 0
2156         ELSE
2157            IF(MTRANS .EQ. 7) THEN
2158               MTRANS = -9876543
2159               GOTO 102
2160            ENDIF
2161            IF (PROK) WRITE(MPRINT,'(A)')
2162     &           ' ... Apply column permutation'
2163            DO 100 K=1,NZ
2164               J = id%JCN(K)
2165               IF ((J.LE.0).OR.(J.GT.N)) GO TO 100
2166               id%JCN(K) = IW(IRNW+int(J-1,8))
2167 100        CONTINUE
2168            IF (MP.GT.0 .AND. ICNTL(4).GE.2)
2169     &           WRITE(MP,'(/A)')
2170     &           ' WARNING input matrix data modified'
2171         ENDIF
2172 102     CONTINUE
2173         IF (SCALINGLOC) THEN
2174            IF ( associated(id%COLSCA))
2175     &           DEALLOCATE( id%COLSCA )
2176            IF ( associated(id%ROWSCA))
2177     &           DEALLOCATE( id%ROWSCA )
2178            ALLOCATE( id%COLSCA(N), stat=allocok)
2179            IF (allocok .GT.0) THEN
2180               id%INFO(1)=-5
2181               id%INFO(2)=N
2182               IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN
2183                  WRITE (LP,'(/A)') '** Error in DMUMPS_ANA_O'
2184                  WRITE (LP,'(A)')
2185     &                 '** Failure during allocation of COLSCA'
2186                  GOTO 500
2187               ENDIF
2188            ENDIF
2189            ALLOCATE( id%ROWSCA(N), stat=allocok)
2190            IF (allocok .GT.0) THEN
2191               id%INFO(1)=-5
2192               id%INFO(2)=N
2193               IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN
2194                  WRITE (LP,'(/A)') '** Error in DMUMPS_ANA_O'
2195                  WRITE (LP,'(A)')
2196     &                 '** Failure during allocation of ROWSCA'
2197                  GOTO 500
2198               ENDIF
2199            ENDIF
2200            id%KEEP(52) = -2
2201            id%KEEP(74) = 1
2202            MAXDBL = log(huge(MAXDBL))
2203            DO J=1,N
2204               IF(S2(RSPOS+J) .GT. MAXDBL) THEN
2205                  S2(RSPOS+J) = ZERO
2206               ENDIF
2207               IF(S2(CSPOS+J) .GT. MAXDBL) THEN
2208                  S2(CSPOS+J)= ZERO
2209               ENDIF
2210            ENDDO
2211            DO 105 J=1,N
2212               J8 = int(J,8)
2213               id%ROWSCA(J) = exp(S2(RSPOS+J8))
2214               IF(id%ROWSCA(J) .EQ. ZERO) THEN
2215                  id%ROWSCA(J) = ONE
2216               ENDIF
2217               IF ( MTRANS .EQ.  -9876543 .OR. MTRANS.EQ. 0 ) THEN
2218                 id%COLSCA(J)= exp(S2(CSPOS+J8))
2219                 IF(id%COLSCA(J) .EQ. ZERO) THEN
2220                   id%COLSCA(J) = ONE
2221                 ENDIF
2222               ELSE
2223                 id%COLSCA(IW(IRNW+J8-1_8))= exp(S2(CSPOS+J8))
2224                 IF(id%COLSCA(IW(IRNW+J8-1_8)) .EQ. ZERO) THEN
2225                   id%COLSCA(IW(IRNW+J8-1_8)) = ONE
2226                 ENDIF
2227               ENDIF
2228 105        CONTINUE
2229         ENDIF
2230      ELSE
2231         IDENT = .FALSE.
2232         IF(SCALINGLOC) THEN
2233            IF ( associated(id%COLSCA)) DEALLOCATE( id%COLSCA )
2234            IF ( associated(id%ROWSCA)) DEALLOCATE( id%ROWSCA )
2235            ALLOCATE( id%COLSCA(N), stat=allocok)
2236            IF (allocok .GT.0) THEN
2237               id%INFO(1)=-5
2238               id%INFO(2)=N
2239               IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN
2240                  WRITE (LP,'(/A)') '** Error in DMUMPS_ANA_O'
2241                  WRITE (LP,'(A)')
2242     &                 '** Failure during allocation of COLSCA'
2243                  GOTO 500
2244               ENDIF
2245            ENDIF
2246            ALLOCATE( id%ROWSCA(N), stat=allocok)
2247            IF (allocok .GT.0) THEN
2248               id%INFO(1)=-5
2249               id%INFO(2)=N
2250               IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN
2251                  WRITE (LP,'(/A)') '** Error in DMUMPS_ANA_O'
2252                  WRITE (LP,'(A)')
2253     &                 '** Failure during allocation of ROWSCA'
2254                  GOTO 500
2255               ENDIF
2256            ENDIF
2257            id%KEEP(52) = -2
2258            id%KEEP(74) = 1
2259            MAXDBL = log(huge(MAXDBL))
2260            DO J=1,N
2261               J8 = int(J,8)
2262               IF(S2(RSPOS+J8)+S2(CSPOS+J8) .GT. MAXDBL) THEN
2263                  S2(RSPOS+J8) = ZERO
2264                  S2(CSPOS+J8)= ZERO
2265               ENDIF
2266            ENDDO
2267            DO J=1,N
2268               J8 = int(J,8)
2269               IF(PERM(J) .GT. 0) THEN
2270                  id%ROWSCA(J) =
2271     &                 exp((S2(RSPOS+J8)+S2(CSPOS+J8))/TWO)
2272                  IF(id%ROWSCA(J) .EQ. ZERO) THEN
2273                     id%ROWSCA(J) = ONE
2274                  ENDIF
2275                  id%COLSCA(J)= id%ROWSCA(J)
2276               ENDIF
2277            ENDDO
2278            DO JPOS=1,KER_SIZE
2279               I = STR_KER(JPOS)
2280               COLNORM = ZERO
2281               DO K = IPE(I),IPE(I+1) - 1
2282                  IF ( PERM( IW( IRNW+K-1_8) ) > 0 ) THEN
2283                    COLNORM = max(COLNORM,S2(J))
2284                  ENDIF
2285               ENDDO
2286               COLNORM = exp(COLNORM)
2287               id%ROWSCA(I) = ONE / COLNORM
2288               id%COLSCA(I) = id%ROWSCA(I)
2289            ENDDO
2290         ENDIF
2291         IF(MTRANS .EQ. 7 .OR. id%KEEP(95) .EQ. 0) THEN
2292            IF( (NZER_DIAG+RZ_DIAG) .LT. (N/10)
2293     &           .AND. id%KEEP(95) .EQ. 0) THEN
2294               MTRANS = 0
2295               id%KEEP(95) = 1
2296               GOTO 390
2297            ELSE
2298               IF(id%KEEP(95) .EQ. 0) THEN
2299                 IF(SCALINGLOC) THEN
2300                  id%KEEP(95) = 3
2301                 ELSE
2302                  id%KEEP(95) = 2
2303                 ENDIF
2304               ENDIF
2305               IF(MTRANS .EQ. 7) MTRANS = 5
2306            ENDIF
2307         ENDIF
2308         IF(MTRANS .EQ. 0) GOTO 390
2309         ICNTL_SYM_MWM = 0
2310         INFO_SYM_MWM = 0
2311         IF(MTRANS .EQ. 5 .OR. MTRANS .EQ. 6 .OR.
2312     &        MTRANS .EQ. 7) THEN
2313            ICNTL_SYM_MWM(1) = 0
2314            ICNTL_SYM_MWM(2) = 1
2315         ELSE IF(MTRANS .EQ. 4) THEN
2316            ICNTL_SYM_MWM(1) = 2
2317            ICNTL_SYM_MWM(2) = 1
2318         ELSE
2319            ICNTL_SYM_MWM(1) = 0
2320            ICNTL_SYM_MWM(2) = 1
2321         ENDIF
2322         MARKED => id%IS1(2*N+1:3*N)
2323         FLAG => id%IS1(3*N+1:4*N)
2324         PIV_OUT => id%IS1(4*N+1:5*N)
2325         IF(MTRANSLOC .LT. 4) THEN
2326            LSC = 1
2327         ELSE
2328            LSC = 2*N
2329         ENDIF
2330         CALL DMUMPS_SYM_MWM(
2331     &        N, NZREAL, IPE, IW(IRNW), S2(1),LSC, PERM,
2332     &        ZERODIAG(1),
2333     &        ICNTL_SYM_MWM, S2(LSC+1),MARKED(1),FLAG(1),
2334     &        PIV_OUT(1), INFO_SYM_MWM)
2335         IF(INFO_SYM_MWM(1) .NE. 0) THEN
2336            WRITE(*,*) '** Error in DMUMPS_ANA_O'
2337            RETURN
2338         ENDIF
2339         IF(INFO_SYM_MWM(3) .EQ. N) THEN
2340            IDENT = .TRUE.
2341         ELSEIF( (N-INFO_SYM_MWM(4)-INFO_SYM_MWM(3)) .GT. N/10
2342     &           ) THEN
2343            IDENT = .TRUE.
2344            id%KEEP(95) = 1
2345         ELSE
2346            DO I=1,N
2347               PERM(I) = PIV_OUT(I)
2348            ENDDO
2349         ENDIF
2350         id%KEEP(93) = INFO_SYM_MWM(4)
2351         id%KEEP(94) = INFO_SYM_MWM(3)
2352         IF (IDENT) MTRANS=0
2353      ENDIF
2354 390  IF(MTRANS .EQ. 0) THEN
2355         id%KEEP(95) = 1
2356         IF (PROK) THEN
2357           WRITE (MPRINT,'(A)')
2358     &  ' ... Column permutation not used'
2359         ENDIF
2360      ENDIF
2361      GO TO 500
2362 400  IF ((LP.GE.0).AND.(ICNTL(4).GE.1))
2363     &   WRITE (LP,'(/A)') '** Error: Matrix is structurally singular'
2364      INFO(1) = -6
2365      INFO(2) = NUMNZ
2366      GOTO 500
2367 410  IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN
2368       WRITE (LP,'(/A)') '** Error in DMUMPS_ANA_O'
2369       WRITE (LP,'(A,I14)')
2370     & '** Failure during allocation of INTEGER array of size ',
2371     & LIWG
2372      ENDIF
2373      INFO(1) = -7
2374      CALL MUMPS_SET_IERROR(LIWG,INFO(2))
2375      GOTO 500
2376 430  IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN
2377       WRITE (LP,'(/A)') '** Error in DMUMPS_ANA_O'
2378       WRITE (LP,'(A)') '** Failure during allocation of S2'
2379      ENDIF
2380      INFO(1) = -5
2381      CALL MUMPS_SET_IERROR(LDW,INFO(2))
2382 500  CONTINUE
2383      IF (allocated(IW)) DEALLOCATE(IW)
2384      IF (allocated(S2)) DEALLOCATE(S2)
2385      IF (allocated(IPE)) DEALLOCATE(IPE)
2386      IF (allocated(IPQ8)) DEALLOCATE(IPQ8)
2387      RETURN
2388      END SUBROUTINE DMUMPS_ANA_O
2389      SUBROUTINE DMUMPS_DIAG_ANA
2390     &( MYID, COMM, KEEP,KEEP8, INFO, INFOG, RINFO, RINFOG, ICNTL )
2391      IMPLICIT NONE
2392      INTEGER COMM, MYID, KEEP(500), INFO(40), ICNTL(40), INFOG(40)
2393      INTEGER(8) KEEP8(150)
2394      DOUBLE PRECISION RINFO(40), RINFOG(40)
2395      INCLUDE 'mpif.h'
2396      INTEGER MASTER, MPG
2397      PARAMETER( MASTER = 0 )
2398      MPG = ICNTL(3)
2399      IF ( MYID.eq.MASTER.and.MPG.GT.0.AND.ICNTL(4).GE.2) THEN
2400       WRITE(MPG, 99992) INFO(1), INFO(2),
2401     &  KEEP8(109), KEEP8(111), INFOG(4),
2402     &  INFOG(5), KEEP(28), INFOG(32), INFOG(7), KEEP(23), ICNTL(7),
2403     &  KEEP(12), KEEP(56), KEEP(61), RINFOG(1)
2404       IF (KEEP(95).GT.1)
2405     &      WRITE(MPG, 99993) KEEP(95)
2406       IF (KEEP(54).GT.0) WRITE(MPG, 99994) KEEP(54)
2407       IF (KEEP(60).GT.0) WRITE(MPG, 99995) KEEP(60)
2408       IF (KEEP(253).GT.0)  WRITE(MPG, 99996) KEEP(253)
2409      ENDIF
2410      RETURN
241199992 FORMAT(/'Leaving analysis phase with  ...'/
2412     &       'INFOG(1)                                       =',I16/
2413     &       'INFOG(2)                                       =',I16/
2414     &       ' -- (20) Number of entries in factors (estim.) =',I16/
2415     &       ' --  (3) Storage of factors  (REAL, estimated) =',I16/
2416     &       ' --  (4) Storage of factors  (INT , estimated) =',I16/
2417     &       ' --  (5) Maximum frontal size      (estimated) =',I16/
2418     &       ' --  (6) Number of nodes in the tree           =',I16/
2419     &       ' -- (32) Type of analysis effectively used     =',I16/
2420     &       ' --  (7) Ordering option effectively used      =',I16/
2421     &       'ICNTL(6) Maximum transversal option            =',I16/
2422     &       'ICNTL(7) Pivot order option                    =',I16/
2423     &       'Percentage of memory relaxation (effective)    =',I16/
2424     &       'Number of level 2 nodes                        =',I16/
2425     &       'Number of split nodes                          =',I16/
2426     &   'RINFOG(1) Operations during elimination (estim)=  ',1PD10.3)
242799993 FORMAT('Ordering compressed/constrained (ICNTL(12))    =',I16)
242899994 FORMAT('Distributed matrix entry format (ICNTL(18))    =',I16)
242999995 FORMAT('Effective Schur option (ICNTL(19))             =',I16)
243099996 FORMAT('Forward solution during factorization, NRHS    =',I16)
2431      END SUBROUTINE DMUMPS_DIAG_ANA
2432      SUBROUTINE DMUMPS_CUTNODES
2433     &           ( N, FRERE, FILS, NFSIZ, NSTEPS, NSLAVES,
2434     &             KEEP, KEEP8, SPLITROOT, MP, LDIAG, INFO1, INFO2 )
2435      IMPLICIT NONE
2436      INTEGER N, NSTEPS, NSLAVES, KEEP(500)
2437      INTEGER(8) KEEP8(150)
2438      INTEGER FRERE( N ), FILS( N ), NFSIZ( N )
2439      LOGICAL SPLITROOT
2440      INTEGER MP, LDIAG
2441      INTEGER INFO1, INFO2
2442      INTEGER, DIMENSION(:), ALLOCATABLE :: IPOOL
2443      INTEGER INODE, DEPTH, I, IBEG, IEND, IIPOOL, NROOT
2444      INTEGER MAX_DEPTH, ISON, TOT_CUT, MAX_CUT, STRAT
2445      INTEGER(8) :: K79
2446      INTEGER NFRONT, K82, allocok
2447      K79  = KEEP8(79)
2448      K82  = abs(KEEP(82))
2449      STRAT= KEEP(62)
2450      IF (KEEP(210).EQ.1) THEN
2451        MAX_DEPTH = 2*NSLAVES*K82
2452        STRAT     = STRAT/4
2453      ELSE
2454        IF (( NSLAVES .eq. 1 ).AND. (.NOT. SPLITROOT) ) RETURN
2455        IF (NSLAVES.EQ.1) THEN
2456          MAX_DEPTH=1
2457        ELSE
2458          MAX_DEPTH = int( log( dble( NSLAVES - 1 ) )
2459     &                 / log(2.0D0) )
2460        ENDIF
2461      ENDIF
2462      ALLOCATE(IPOOL(NSTEPS+1), stat=allocok)
2463      IF (allocok.GT.0) THEN
2464        INFO1= -7
2465        INFO2= NSTEPS+1
2466        RETURN
2467      ENDIF
2468      NROOT = 0
2469      DO INODE = 1, N
2470        IF ( FRERE(INODE) .eq. 0 ) THEN
2471          NROOT = NROOT + 1
2472          IPOOL( NROOT ) = INODE
2473        END IF
2474      END DO
2475      IBEG = 1
2476      IEND = NROOT
2477      IIPOOL   = NROOT + 1
2478      IF (SPLITROOT) THEN
2479         MAX_DEPTH=0
2480      ENDIF
2481      DO DEPTH = 1, MAX_DEPTH
2482        DO I = IBEG, IEND
2483          INODE = IPOOL( I )
2484          ISON = INODE
2485          DO WHILE ( ISON .GT. 0 )
2486            ISON = FILS( ISON )
2487          END DO
2488          ISON = - ISON
2489          DO WHILE ( ISON .GT. 0 )
2490            IPOOL( IIPOOL ) = ISON
2491            IIPOOL = IIPOOL + 1
2492            ISON = FRERE( ISON )
2493          END DO
2494        END DO
2495        IPOOL( IBEG ) = -IPOOL( IBEG )
2496        IBEG = IEND + 1
2497        IEND = IIPOOL - 1
2498      END DO
2499      IPOOL( IBEG ) = -IPOOL( IBEG )
2500      TOT_CUT = 0
2501      IF (SPLITROOT) THEN
2502        MAX_CUT = NROOT*max(K82,2)
2503        INODE = abs(IPOOL(1))
2504        NFRONT = NFSIZ( INODE )
2505        K79 = max(
2506     &         int(NFRONT,8)*int(NFRONT,8)/(int(K82+1,8)*int(K82+1,8)),
2507     &         1_8)
2508        IF (KEEP(53).NE.0) THEN
2509          MAX_CUT =  NFRONT
2510          K79 = 121_8*121_8
2511        ELSE
2512          K79 = min(2000_8*2000_8,K79)
2513        ENDIF
2514      ELSE
2515         MAX_CUT = 2 * NSLAVES
2516         IF (KEEP(210).EQ.1) THEN
2517            MAX_CUT = 4 * (MAX_CUT + 4)
2518         ENDIF
2519      ENDIF
2520      DEPTH   = -1
2521      DO I = 1, IIPOOL - 1
2522        INODE = IPOOL( I )
2523        IF ( INODE .LT. 0 ) THEN
2524          INODE = -INODE
2525          DEPTH = DEPTH + 1
2526        END IF
2527        CALL DMUMPS_SPLIT_1NODE
2528     &           ( INODE, N, FRERE, FILS, NFSIZ, NSTEPS, NSLAVES,
2529     &             KEEP,KEEP8, TOT_CUT, STRAT, DEPTH,
2530     &             K79, SPLITROOT, MP, LDIAG )
2531        IF ( TOT_CUT > MAX_CUT )  EXIT
2532      END DO
2533      KEEP(61) = TOT_CUT
2534      DEALLOCATE(IPOOL)
2535      RETURN
2536      END SUBROUTINE DMUMPS_CUTNODES
2537      RECURSIVE SUBROUTINE DMUMPS_SPLIT_1NODE
2538     & ( INODE, N, FRERE, FILS, NFSIZ, NSTEPS, NSLAVES, KEEP,KEEP8,
2539     &   TOT_CUT, STRAT, DEPTH, K79, SPLITROOT, MP, LDIAG )
2540      IMPLICIT NONE
2541      INTEGER(8) :: K79
2542      INTEGER INODE, N, NSTEPS, NSLAVES, KEEP(500), STRAT,
2543     &        DEPTH, TOT_CUT, MP, LDIAG
2544      INTEGER(8) KEEP8(150)
2545      INTEGER FRERE( N ), FILS( N ), NFSIZ( N )
2546      LOGICAL SPLITROOT
2547      INTEGER I, IN, NPIV, NFRONT, NSLAVES_ESTIM
2548      DOUBLE PRECISION WK_SLAVE, WK_MASTER
2549      INTEGER INODE_SON, INODE_FATH, IN_SON, IN_FATH, IN_GRANDFATH
2550      INTEGER NPIV_SON, NPIV_FATH
2551      INTEGER NCB, NSLAVESMIN, NSLAVESMAX
2552      INTEGER  MUMPS_BLOC2_GET_NSLAVESMIN,
2553     &         MUMPS_BLOC2_GET_NSLAVESMAX
2554      EXTERNAL  MUMPS_BLOC2_GET_NSLAVESMIN,
2555     &         MUMPS_BLOC2_GET_NSLAVESMAX
2556      IF  ( (KEEP(210).EQ.1.AND.KEEP(60).EQ.0) .OR.
2557     &       (SPLITROOT) ) THEN
2558        IF ( FRERE ( INODE ) .eq. 0 ) THEN
2559          NFRONT = NFSIZ( INODE )
2560          NPIV = NFRONT
2561          NCB = 0
2562          IF ( int(NFRONT,8)*int(NFRONT,8).GT.K79
2563     &    ) THEN
2564           GOTO 333
2565          ENDIF
2566        ENDIF
2567      ENDIF
2568      IF ( FRERE ( INODE ) .eq. 0 ) RETURN
2569      NFRONT = NFSIZ( INODE )
2570      IN = INODE
2571      NPIV = 0
2572      DO WHILE( IN > 0 )
2573        IN = FILS( IN )
2574        NPIV = NPIV + 1
2575      END DO
2576      NCB = NFRONT - NPIV
2577      IF ( (NFRONT - (NPIV/2)) .LE. KEEP(9)) RETURN
2578      IF ((KEEP(50) == 0.and.int(NFRONT,8) * int(NPIV,8) > K79 ) .OR.
2579     &(KEEP(50) .NE.0.and.int(NPIV,8) * int(NPIV,8) > K79 )) GOTO 333
2580      IF (KEEP(210).EQ.1) THEN
2581        NSLAVESMIN    = 1
2582        NSLAVESMAX    = 64
2583        NSLAVES_ESTIM = 32+NSLAVES
2584      ELSE
2585        NSLAVESMIN = MUMPS_BLOC2_GET_NSLAVESMIN
2586     &         ( NSLAVES, KEEP(48), KEEP8(21), KEEP(50),
2587     &         NFRONT, NCB, KEEP(375))
2588        NSLAVESMAX = MUMPS_BLOC2_GET_NSLAVESMAX
2589     &        ( NSLAVES, KEEP(48), KEEP8(21), KEEP(50),
2590     &          NFRONT, NCB, KEEP(375))
2591        NSLAVES_ESTIM = max (1,
2592     &   nint( dble(NSLAVESMAX-NSLAVESMIN)/dble(3) )
2593     &                    )
2594        NSLAVES_ESTIM = min (NSLAVES_ESTIM, NSLAVES-1)
2595      ENDIF
2596      IF ( KEEP(50) .eq. 0 ) THEN
2597       WK_MASTER = 0.6667D0 *
2598     &                dble(NPIV)*dble(NPIV)*dble(NPIV) +
2599     &                dble(NPIV)*dble(NPIV)*dble(NCB)
2600       WK_SLAVE  = dble( NPIV ) * dble( NCB ) *
2601     &         ( 2.0D0 * dble(NFRONT) - dble(NPIV) )
2602     &         / dble(NSLAVES_ESTIM)
2603      ELSE
2604       WK_MASTER = dble(NPIV)*dble(NPIV)*dble(NPIV) / dble(3)
2605       WK_SLAVE  =
2606     &           (dble(NPIV)*dble(NCB)*dble(NFRONT))
2607     &           / dble(NSLAVES_ESTIM)
2608      ENDIF
2609      IF (KEEP(210).EQ.1) THEN
2610        IF ( dble( 100 + STRAT )
2611     &        * WK_SLAVE / dble(100) .GE. WK_MASTER ) RETURN
2612      ELSE
2613        IF ( dble( 100 + STRAT * max( DEPTH-1, 1 ) )
2614     &        * WK_SLAVE / dble(100) .GE. WK_MASTER ) RETURN
2615      ENDIF
2616 333  CONTINUE
2617      IF (NPIV .LE. 1 ) RETURN
2618       NSTEPS  = NSTEPS + 1
2619       TOT_CUT = TOT_CUT + 1
2620       NPIV_SON  = max(NPIV/2,1)
2621       NPIV_FATH = NPIV - NPIV_SON
2622       IF (SPLITROOT) THEN
2623         IF (NCB .NE .0) THEN
2624           WRITE(*,*) "Error splitting"
2625           CALL MUMPS_ABORT()
2626         ENDIF
2627         NPIV_FATH = min(int(sqrt(dble(K79))), int(NPIV/2))
2628         NPIV_SON  = NPIV - NPIV_FATH
2629       ENDIF
2630       INODE_SON = INODE
2631       IN_SON = INODE
2632       DO I = 1, NPIV_SON - 1
2633         IN_SON = FILS( IN_SON )
2634       END DO
2635       INODE_FATH = FILS( IN_SON )
2636       IF ( INODE_FATH .LT. 0 ) THEN
2637       write(*,*) 'Error: INODE_FATH < 0 ', INODE_FATH
2638       END IF
2639       IN_FATH = INODE_FATH
2640       DO WHILE ( FILS( IN_FATH ) > 0 )
2641         IN_FATH = FILS( IN_FATH )
2642       END DO
2643       FRERE( INODE_FATH ) = FRERE( INODE_SON )
2644       FRERE( INODE_SON  ) = - INODE_FATH
2645       FILS ( IN_SON     ) = FILS( IN_FATH )
2646       FILS ( IN_FATH    ) = - INODE_SON
2647       IN = FRERE( INODE_FATH )
2648       DO WHILE ( IN > 0 )
2649           IN = FRERE( IN )
2650       END DO
2651       IF ( IN .eq. 0 )  GO TO 10
2652       IN = -IN
2653       DO WHILE ( FILS( IN ) > 0 )
2654           IN = FILS( IN )
2655       END DO
2656       IN_GRANDFATH = IN
2657       IF ( FILS( IN_GRANDFATH ) .eq. - INODE_SON ) THEN
2658           FILS( IN_GRANDFATH ) = -INODE_FATH
2659       ELSE
2660           IN = IN_GRANDFATH
2661           IN = - FILS ( IN )
2662           DO WHILE ( FRERE( IN ) > 0 )
2663             IF ( FRERE( IN ) .eq. INODE_SON ) THEN
2664               FRERE( IN ) = INODE_FATH
2665               GOTO 10
2666             END IF
2667             IN = FRERE( IN )
2668           END DO
2669           WRITE(*,*) 'ERROR 2 in SPLIT NODE',
2670     &          IN_GRANDFATH, IN, FRERE(IN)
2671       END IF
2672 10    CONTINUE
2673       NFSIZ(INODE_SON) = NFRONT
2674       NFSIZ(INODE_FATH) = NFRONT - NPIV_SON
2675       KEEP(2) = max( KEEP(2), NFRONT - NPIV_SON )
2676       IF (SPLITROOT) THEN
2677         RETURN
2678       ENDIF
2679        CALL DMUMPS_SPLIT_1NODE
2680     &  ( INODE_FATH, N, FRERE, FILS, NFSIZ, NSTEPS,
2681     &   NSLAVES, KEEP,KEEP8, TOT_CUT, STRAT, DEPTH,
2682     &   K79, SPLITROOT, MP, LDIAG )
2683      IF (.NOT. SPLITROOT) THEN
2684        CALL DMUMPS_SPLIT_1NODE
2685     &   ( INODE_SON, N, FRERE, FILS, NFSIZ, NSTEPS,
2686     &   NSLAVES, KEEP,KEEP8, TOT_CUT, STRAT, DEPTH,
2687     &   K79, SPLITROOT, MP, LDIAG )
2688      ENDIF
2689      RETURN
2690      END SUBROUTINE DMUMPS_SPLIT_1NODE
2691      SUBROUTINE DMUMPS_ANA_GNEW
2692     & (N, NZ, IRN, ICN, IW, LW, IPE, LEN,
2693     & IQ, FLAG, IWFR,
2694     & NRORM, NIORM, IFLAG,IERROR, ICNTL,
2695     & symmetry, SYM, NBQD, AvgDens,
2696     & KEEP264, KEEP265)
2697      IMPLICIT NONE
2698      INTEGER, intent(in)    :: N, SYM
2699      INTEGER(8), intent(in) :: LW
2700      INTEGER(8), intent(in) :: NZ
2701      INTEGER, intent(in)    :: ICNTL(40)
2702      INTEGER, intent(in)    :: IRN(NZ), ICN(NZ)
2703      INTEGER, intent(out)   :: IERROR, symmetry
2704      INTEGER, intent(out)   :: NBQD, AvgDens
2705      INTEGER, intent(out)   :: LEN(N), IW(LW)
2706      INTEGER(8), intent(out):: IWFR
2707      INTEGER(8), intent(out):: NRORM, NIORM
2708      INTEGER(8), intent(out):: IPE(N+1)
2709      INTEGER, intent(inout) :: IFLAG, KEEP264, KEEP265
2710      INTEGER(8), intent(out):: IQ(N)
2711      INTEGER, intent(out)   :: FLAG(N)
2712      INTEGER    :: MP, MPG, I, J, N1
2713      INTEGER    :: NBERR, THRESH
2714      INTEGER(8) :: K8, K1, K2, LAST, NDUP
2715      INTEGER(8) :: NZOFFA, NDIAGA, L, N8
2716      DOUBLE PRECISION       :: RSYM
2717      INTRINSIC nint
2718      MP = ICNTL(2)
2719      MPG= ICNTL(3)
2720      NZOFFA = 0_8
2721      NDIAGA = 0
2722      IERROR = 0
2723      N8     = int(N,8)
2724      DO I=1,N+1
2725        IPE(I) = 0_8
2726      ENDDO
2727      IF (KEEP264.EQ.0) THEN
2728       IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN
2729        DO K8=1_8,NZ
2730         I = IRN(K8)
2731         J = ICN(K8)
2732         IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1)
2733     &                          .OR.(J.LT.1)) THEN
2734           IERROR = IERROR + 1
2735         ELSE
2736          IF (I.NE.J) THEN
2737           IPE(I) = IPE(I) + 1_8
2738           NZOFFA  = NZOFFA + 1_8
2739          ELSE
2740           NDIAGA = NDIAGA + 1_8
2741          ENDIF
2742         ENDIF
2743        ENDDO
2744       ELSE
2745        DO K8=1_8,NZ
2746         I = IRN(K8)
2747         J = ICN(K8)
2748         IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1)
2749     &                          .OR.(J.LT.1)) THEN
2750           IERROR = IERROR + 1
2751         ELSE
2752          IF (I.NE.J) THEN
2753           IPE(I) = IPE(I) + 1_8
2754           IPE(J) = IPE(J) + 1_8
2755           NZOFFA  = NZOFFA + 1_8
2756          ELSE
2757           NDIAGA = NDIAGA + 1_8
2758          ENDIF
2759         ENDIF
2760        ENDDO
2761       ENDIF
2762       IF (IERROR.GE.1) THEN
2763        KEEP264 = 0
2764       ELSE
2765        KEEP264 = 1
2766       ENDIF
2767      ELSE
2768       IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN
2769        DO K8=1_8,NZ
2770         I = IRN(K8)
2771         J = ICN(K8)
2772         IF (I.EQ.J) THEN
2773           NDIAGA = NDIAGA + 1_8
2774         ELSE
2775           IPE(I) = IPE(I) + 1_8
2776           NZOFFA = NZOFFA + 1_8
2777         ENDIF
2778        ENDDO
2779       ELSE
2780        DO K8=1_8,NZ
2781         I = IRN(K8)
2782         J = ICN(K8)
2783         IF (I.NE.J) THEN
2784           IPE(I) = IPE(I) + 1_8
2785           IPE(J) = IPE(J) + 1_8
2786           NZOFFA  = NZOFFA + 1_8
2787         ELSE
2788           NDIAGA = NDIAGA + 1_8
2789         ENDIF
2790        ENDDO
2791       ENDIF
2792      ENDIF
2793      NIORM  = NZOFFA + 3_8*N8
2794      IF (IERROR.GE.1) THEN
2795         NBERR  = 0
2796         IF (mod(IFLAG,2) .EQ. 0) IFLAG = IFLAG+1
2797         IF ((MP.GT.0).AND.(ICNTL(4).GE.2))  THEN
2798          WRITE (MP,99999)
2799          DO 70 K8=1_8,NZ
2800           I = IRN(K8)
2801           J = ICN(K8)
2802           IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1)
2803     &                            .OR.(J.LT.1)) THEN
2804            NBERR = NBERR + 1
2805            IF (NBERR.LE.10)  THEN
2806               IF (mod(K8,10_8).GT.3_8 .OR. mod(K8,10_8).EQ.0_8 .OR.
2807     &             (10_8.LE.K8 .AND. K8.LE.20_8)) THEN
2808                 WRITE (MP,'(I16,A,I10,A,I10,A)')
2809     &             K8,'th entry (in row',I,' and column',J,') ignored'
2810               ELSE
2811                 IF (mod(K8,10_8).EQ.1_8)
2812     &             WRITE(MP,'(I16,A,I10,A,I10,A)')
2813     &             K8,'st entry (in row',I,' and column',J,') ignored'
2814                 IF (mod(K8,10_8).EQ.2_8)
2815     &             WRITE(MP,'(I16,A,I10,A,I10,A)')
2816     &             K8,'nd entry (in row',I,' and column',J,') ignored'
2817                 IF (mod(K8,10_8).EQ.3_8)
2818     &             WRITE(MP,'(I16,A,I10,A,I10,A)')
2819     &             K8,'rd entry (in row',I,' and column',J,') ignored'
2820               ENDIF
2821            ELSE
2822               GO TO 100
2823            ENDIF
2824           ENDIF
2825   70     CONTINUE
2826         ENDIF
2827      ENDIF
2828  100 NRORM = NIORM - 2_8*N8
2829      IQ(1) = 1_8
2830      N1 = N - 1
2831      IF (N1.GT.0) THEN
2832        DO I=1,N1
2833            IQ(I+1) = IPE(I) + IQ(I)
2834        ENDDO
2835      ENDIF
2836      LAST = max(IPE(N)+IQ(N)-1,IQ(N))
2837      FLAG(1:N) = 0
2838      IPE(1:N)  = IQ(1:N)
2839      IW(1:LAST) = 0
2840      IWFR = LAST + 1_8
2841      IF (KEEP264 .EQ. 0) THEN
2842       IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN
2843        DO K8=1_8,NZ
2844          I = IRN(K8)
2845          J = ICN(K8)
2846          IF (I.NE.J) THEN
2847              IF ((J.GE.1).AND.(I.LE.N)) THEN
2848                IW(IQ(I)) = J
2849                IQ(I)     = IQ(I) + 1
2850              ENDIF
2851          ENDIF
2852        ENDDO
2853       ELSE IF (KEEP265.EQ.1) THEN
2854        DO K8=1_8,NZ
2855          I = IRN(K8)
2856          J = ICN(K8)
2857          IF (I.NE.J) THEN
2858              IF ((J.GE.1).AND.(I.LE.N)) THEN
2859                IW(IQ(J)) = I
2860                IQ(J)     = IQ(J) + 1
2861                IW(IQ(I)) = J
2862                IQ(I)     = IQ(I) + 1
2863              ENDIF
2864          ENDIF
2865        ENDDO
2866       ELSE
2867        DO K8=1_8,NZ
2868          I = IRN(K8)
2869          J = ICN(K8)
2870          IF (I.NE.J) THEN
2871            IF (I.LT.J) THEN
2872              IF ((I.GE.1).AND.(J.LE.N)) THEN
2873                IW(IQ(I)) = -J
2874                IQ(I)     = IQ(I) + 1
2875              ENDIF
2876            ELSE
2877              IF ((J.GE.1).AND.(I.LE.N)) THEN
2878                IW(IQ(J)) = -I
2879                IQ(J)     = IQ(J) + 1
2880              ENDIF
2881            ENDIF
2882          ENDIF
2883        ENDDO
2884       ENDIF
2885      ELSE
2886       IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN
2887        DO K8=1_8,NZ
2888          I = IRN(K8)
2889          J = ICN(K8)
2890          IF (I.NE.J) THEN
2891               IW(IQ(I)) = J
2892               IQ(I)     = IQ(I) + 1
2893          ENDIF
2894        ENDDO
2895       ELSE IF (KEEP265.EQ.1) THEN
2896        DO K8=1_8,NZ
2897          I = IRN(K8)
2898          J = ICN(K8)
2899          IF (I.NE.J) THEN
2900               IW(IQ(J)) = I
2901               IQ(J)     = IQ(J) + 1
2902               IW(IQ(I)) = J
2903               IQ(I)     = IQ(I) + 1
2904          ENDIF
2905        ENDDO
2906       ELSE
2907        DO K8=1_8,NZ
2908          I = IRN(K8)
2909          J = ICN(K8)
2910          IF (I.NE.J) THEN
2911            IF (I.LT.J) THEN
2912              IW(IQ(I)) = -J
2913              IQ(I)     = IQ(I) + 1
2914            ELSE
2915              IW(IQ(J)) = -I
2916              IQ(J)     = IQ(J) + 1
2917            ENDIF
2918          ENDIF
2919        ENDDO
2920       ENDIF
2921      ENDIF
2922      IF (KEEP265.EQ.0) THEN
2923       NDUP = 0_8
2924       DO I=1,N
2925        K1 = IPE(I)
2926        K2 = IQ(I) - 1_8
2927        IF (K1.GT.K2) THEN
2928         LEN(I) = 0
2929        ELSE
2930         DO K8=K1,K2
2931           J     = -IW(K8)
2932           IF (J.LE.0) EXIT
2933           L     = IQ(J)
2934           IQ(J) = L + 1
2935           IF (FLAG(J).EQ.I) THEN
2936            NDUP = NDUP + 1_8
2937            IW(K8) = 0
2938           ELSE
2939            IW(L)   = I
2940            IW(K8)  = J
2941            FLAG(J) = I
2942           ENDIF
2943         END DO
2944         LEN(I) = int((IQ(I) - IPE(I)))
2945        ENDIF
2946       ENDDO
2947       IF (NDUP.NE.0_8) THEN
2948        IWFR = 1_8
2949        DO I=1,N
2950         IF (LEN(I).EQ.0) THEN
2951            IPE(I) = IWFR
2952            CYCLE
2953         ENDIF
2954         K1 = IPE(I)
2955         K2 = K1 + LEN(I) - 1
2956         L = IWFR
2957         IPE(I) = IWFR
2958         DO 270 K8=K1,K2
2959           IF (IW(K8).NE.0) THEN
2960            IW(IWFR) = IW(K8)
2961            IWFR     = IWFR + 1_8
2962           ENDIF
2963  270    CONTINUE
2964         LEN(I) = int(IWFR - L)
2965        ENDDO
2966       ELSE
2967         KEEP265   = 1
2968       ENDIF
2969       IPE(N+1) = IPE(N) + int(LEN(N),8)
2970       IWFR = IPE(N+1)
2971      ELSE
2972       IPE(1) = 1_8
2973       DO I = 1, N
2974        LEN(I) = int(IQ(I) - IPE(I))
2975       ENDDO
2976       DO I = 1, N
2977        IPE(I+1) = IPE(I) + int(LEN(I),8)
2978       ENDDO
2979       IWFR = IPE(N+1)
2980      ENDIF
2981      symmetry = 100
2982      IF (SYM.EQ.0) THEN
2983      RSYM =  dble(NDIAGA+2_8*NZOFFA - (IWFR-1_8))/
2984     &            dble(NZOFFA+NDIAGA)
2985      IF ((KEEP265.EQ.0) .AND. (NZOFFA - (IWFR-1_8)).EQ.0_8) THEN
2986         KEEP265 = -1
2987      ENDIF
2988      symmetry = min(nint (100.0D0*RSYM), 100)
2989         IF ((MPG .GT. 0).AND.(ICNTL(4).GE.2) )
2990     &  write(MPG,'(A,I5)')
2991     &  ' ... Structural symmetry (in percent)=', symmetry
2992        IF (MP.GT.0 .AND. MPG.NE.MP.AND. (ICNTL(4).GE.2) )
2993     &  write(MP,'(A,I5)')
2994     &  ' ... Structural symmetry (in percent)=', symmetry
2995      ELSE
2996       symmetry = 100
2997      ENDIF
2998      AvgDens = nint(dble(IWFR-1_8)/dble(N))
2999      THRESH  = AvgDens*50 - AvgDens/10 + 1
3000      NBQD    = 0
3001      IF (N.GT.2) THEN
3002        DO I= 1, N
3003          J = max(LEN(I),1)
3004          IF (J.GT.THRESH) NBQD = NBQD+1
3005        ENDDO
3006      ENDIF
3007      IF (MPG .GT. 0.AND.(ICNTL(4).GE.2))
3008     &  write(MPG,'(A,1I5)')
3009     &  ' Average density of rows/columns =', AvgDens
3010        IF (MP.GT.0 .AND. MPG.NE.MP.AND.(ICNTL(4).GE.2))
3011     &  write(MP,'(A,1I5)')
3012     &  ' Average density of rows/columns =', AvgDens
3013      RETURN
301499999 FORMAT (/'*** Warning message from analysis routine ***')
3015      END SUBROUTINE DMUMPS_ANA_GNEW
3016      SUBROUTINE DMUMPS_SET_K821_SURFACE
3017     &     (KEEP821, KEEP2, KEEP48 ,KEEP50, NSLAVES)
3018      IMPLICIT NONE
3019      INTEGER NSLAVES, KEEP2, KEEP48, KEEP50
3020      INTEGER (8) :: KEEP821
3021      INTEGER(8) KEEP2_SQUARE, NSLAVES8
3022      NSLAVES8= int(NSLAVES,8)
3023      KEEP2_SQUARE = int(KEEP2,8) * int(KEEP2,8)
3024      KEEP821 = max(KEEP821*int(KEEP2,8),1_8)
3025#if defined(t3e)
3026      KEEP821 = min(1500000_8, KEEP821)
3027#elif defined(SP_)
3028      KEEP821 = min(3000000_8, KEEP821)
3029#else
3030      KEEP821 = min(2000000_8, KEEP821)
3031#endif
3032#if defined(t3e)
3033      IF (NSLAVES .GT. 64) THEN
3034         KEEP821 =
3035     &        min(8_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821)
3036      ELSE
3037         KEEP821 =
3038     &        min(4_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821)
3039      ENDIF
3040#else
3041      IF (NSLAVES.GT.64) THEN
3042         KEEP821 =
3043     &        min(6_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821)
3044      ELSE
3045         KEEP821 =
3046     &        min(4_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821)
3047      ENDIF
3048#endif
3049         IF (KEEP50 .EQ. 0 ) THEN
3050            KEEP821 = max(KEEP821,(7_8*KEEP2_SQUARE /
3051     &          4_8 / int(max(NSLAVES-1,1),8)) + int(KEEP2,8))
3052         ELSE
3053            KEEP821 = max(KEEP821,(7_8*KEEP2_SQUARE /
3054     &          4_8 / int(max(NSLAVES-1,1),8)) + int(KEEP2,8))
3055         ENDIF
3056      IF (KEEP50 .EQ. 0 ) THEN
3057#if defined(t3e)
3058         KEEP821 = max(KEEP821,200000_8)
3059#else
3060         KEEP821 = max(KEEP821,300000_8)
3061#endif
3062      ELSE
3063#if defined(t3e)
3064         KEEP821 = max(KEEP821,40000_8)
3065#else
3066         KEEP821 = max(KEEP821,80000_8)
3067#endif
3068      ENDIF
3069      KEEP821 = -KEEP821
3070      RETURN
3071      END SUBROUTINE DMUMPS_SET_K821_SURFACE
3072      SUBROUTINE DMUMPS_MTRANS_DRIVER(JOB,M,N,NE,
3073     &     IP,IRN,A,LA,NUM,PERM,LIW,IW,LDW,DW,
3074     &     IPQ8,
3075     &     ICNTL,CNTL,INFO, INFOMUMPS)
3076      IMPLICIT NONE
3077      INTEGER :: NICNTL, NCNTL, NINFO, INFOMUMPS(40)
3078      PARAMETER (NICNTL=10, NCNTL=10, NINFO=10)
3079      INTEGER :: JOB,M,N,NUM
3080      INTEGER(8), INTENT(IN) :: NE, LIW,LDW, LA
3081      INTEGER(8)             :: IP(N+1), IPQ8(N)
3082      INTEGER :: IRN(NE),PERM(M),IW(LIW)
3083      INTEGER :: ICNTL(NICNTL),INFO(NINFO)
3084      DOUBLE PRECISION :: A(LA)
3085      DOUBLE PRECISION :: DW(LDW),CNTL(NCNTL)
3086      INTEGER(8), DIMENSION(:), ALLOCATABLE :: IWtemp8
3087      INTEGER    :: allocok
3088      INTEGER    :: I,J,WARN1,WARN2,WARN4
3089      INTEGER(8) :: K
3090      DOUBLE PRECISION       :: FACT,ZERO,ONE,RINF,RINF2,RINF3
3091      PARAMETER (ZERO=0.0D+00,ONE=1.0D+0)
3092      EXTERNAL DMUMPS_MTRANSZ,DMUMPS_MTRANSB,DMUMPS_MTRANSR,
3093     &         DMUMPS_MTRANSS,DMUMPS_MTRANSW
3094      INTRINSIC abs,log
3095      RINF = CNTL(2)
3096      RINF2 = huge(RINF2)/dble(2*N)
3097      RINF3 = 0.0D0
3098      WARN1 = 0
3099      WARN2 = 0
3100      WARN4 = 0
3101      IF (JOB.LT.1 .OR. JOB.GT.6) THEN
3102         INFO(1) = -1
3103         INFO(2) = JOB
3104         IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'JOB',JOB
3105         GO TO 99
3106      ENDIF
3107      IF (M.LT.1 .OR. M.LT.N) THEN
3108         INFO(1) = -2
3109         INFO(2) = M
3110         IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'M',M
3111         GO TO 99
3112      ENDIF
3113      IF (N.LT.1) THEN
3114         INFO(1) = -2
3115         INFO(2) = N
3116         IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'N',N
3117         GO TO 99
3118      ENDIF
3119      IF (NE.LT.1) THEN
3120         INFO(1) = -3
3121         CALL MUMPS_SET_IERROR(NE,INFO(2))
3122         IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'NE',NE
3123         GO TO 99
3124      ENDIF
3125      IF (JOB.EQ.1) K = int(4*N +   M,8)
3126      IF (JOB.EQ.2) K = int(N + 2*M,8)
3127      IF (JOB.EQ.3) K = int(8*N + 2*M + NE,8)
3128      IF (JOB.EQ.4) K = int(N + M,8)
3129      IF (JOB.EQ.5) K = int(3*N + 2*M,8)
3130      IF (JOB.EQ.6) K = int(3*N + 2*M + NE,8)
3131      IF (LIW.LT.K) THEN
3132         INFO(1) = -4
3133         CALL MUMPS_SET_IERROR(K,INFO(2))
3134         IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9004) INFO(1),K
3135         GO TO 99
3136      ENDIF
3137      IF (JOB.GT.1) THEN
3138         IF (JOB.EQ.2) K = int(      M,8)
3139         IF (JOB.EQ.3) K = int(1,8)
3140         IF (JOB.EQ.4) K = int(    2*M,8)
3141         IF (JOB.EQ.5) K = int(N + 2*M,8)
3142         IF (JOB.EQ.6) K = int(N + 3*M,8)
3143         IF (LDW .LT. K) THEN
3144            INFO(1) = -5
3145            CALL MUMPS_SET_IERROR(K,INFO(2))
3146            IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9005) INFO(1),K
3147            GO TO 99
3148         ENDIF
3149      ENDIF
3150      IF (ICNTL(5).EQ.0) THEN
3151         DO 3 I = 1,M
3152            IW(I) = 0
3153 3       CONTINUE
3154         DO 6 J = 1,N
3155            DO 4 K = IP(J),IP(J+1)-1_8
3156               I = IRN(K)
3157               IF (I.LT.1 .OR. I.GT.M) THEN
3158                  INFO(1) = -6
3159                  INFO(2) = J
3160                  IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9006) INFO(1),J,I
3161                  GO TO 99
3162               ENDIF
3163               IF (IW(I).EQ.J) THEN
3164                  INFO(1) = -7
3165                  INFO(2) = J
3166                  IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9007) INFO(1),J,I
3167                  GO TO 99
3168               ELSE
3169                  IW(I) = J
3170               ENDIF
3171 4          CONTINUE
3172 6       CONTINUE
3173      ENDIF
3174      IF (ICNTL(3).GE.0) THEN
3175         IF (ICNTL(4).EQ.0 .OR. ICNTL(4).EQ.1) THEN
3176            WRITE(ICNTL(3),9020) JOB,M,N,NE
3177            IF (ICNTL(4).EQ.0) THEN
3178               WRITE(ICNTL(3),9021) (IP(J),J=1,min(10,N+1))
3179               WRITE(ICNTL(3),9022) (IRN(K),K=1_8,min(10_8,NE))
3180               IF (JOB.GT.1) WRITE(ICNTL(3),9023)
3181     &                              (A(K),K=1_8,min(10_8,NE))
3182            ELSEIF (ICNTL(4).EQ.1) THEN
3183               WRITE(ICNTL(3),9021) (IP(J),J=1,N+1)
3184               WRITE(ICNTL(3),9022) (IRN(K),K=1_8,NE)
3185               IF (JOB.GT.1) WRITE(ICNTL(3),9023) (A(K),K=1_8,NE)
3186            ENDIF
3187            WRITE(ICNTL(3),9024) (ICNTL(J),J=1,NICNTL)
3188            WRITE(ICNTL(3),9025) (CNTL(J),J=1,NCNTL)
3189         ENDIF
3190      ENDIF
3191      DO 8 I=1,NINFO
3192         INFO(I) = 0
3193    8 CONTINUE
3194      IF (JOB.EQ.1) THEN
3195         DO 10 J = 1,N
3196            IW(J) = int(IP(J+1) - IP(J))
3197 10      CONTINUE
3198         CALL DMUMPS_MTRANSZ(M,N,IRN,NE,IP,IW(1),PERM,NUM,
3199     &        IW(N+1),IW(2*N+1),IW(3*N+1),IW(3*N+M+1))
3200         GO TO 90
3201      ENDIF
3202      IF (JOB.EQ.2) THEN
3203         DW(1) = max(ZERO,CNTL(1))
3204         CALL DMUMPS_MTRANSB(M,N,NE,IP,IRN,A,PERM,NUM,
3205     &        IW(1),IPQ8,IW(N+1),IW(N+M+1),DW,RINF2)
3206         GO TO 90
3207      ENDIF
3208      IF (JOB.EQ.3) THEN
3209         DO 20 K = 1,NE
3210            IW(K) = IRN(K)
3211 20      CONTINUE
3212         CALL DMUMPS_MTRANSR(N,NE,IP,IW,A)
3213         FACT = max(ZERO,CNTL(1))
3214         CALL DMUMPS_MTRANSS(M,N,NE,IP,IW(1),A,PERM,NUM,IW(NE+1),
3215     &        IW(NE+N+1),IW(NE+2*N+1),IW(NE+3*N+1),IW(NE+4*N+1),
3216     &        IW(NE+5*N+1),IW(NE+5*N+M+1),FACT,RINF2)
3217         GO TO 90
3218      ENDIF
3219      IF ((JOB.EQ.4).OR.(JOB.EQ.5).or.(JOB.EQ.6)) THEN
3220           ALLOCATE(IWtemp8(M+N+N), stat=allocok)
3221           IF (allocok.GT.0) THEN
3222             INFOMUMPS(1) = -7
3223             INFOMUMPS(2) = M+N+N
3224             GOTO 90
3225           ENDIF
3226      ENDIF
3227      IF (JOB.EQ.4) THEN
3228         DO 50 J = 1,N
3229            FACT = ZERO
3230            DO 30 K = IP(J),IP(J+1)-1_8
3231               IF (abs(A(K)).GT.FACT) FACT = abs(A(K))
3232 30         CONTINUE
3233            IF(FACT .GT. RINF3) RINF3 = FACT
3234            DO 40 K = IP(J),IP(J+1)-1_8
3235               A(K) = FACT - abs(A(K))
3236 40         CONTINUE
3237 50      CONTINUE
3238         DW(1)      = max(ZERO,CNTL(1))
3239         DW(2)      = RINF3
3240         IWtemp8(1) = int(JOB,8)
3241         CALL DMUMPS_MTRANSW(M,N,NE,IP,IRN,A,PERM,NUM,
3242     &        IWtemp8(1),IW(1),IWtemp8(N+1),IPQ8,IW(N+1),
3243     &        IWtemp8(2*N+1),
3244     &        DW(1),DW(M+1),RINF2)
3245         DEALLOCATE(IWtemp8)
3246         GO TO 90
3247      ENDIF
3248      IF (JOB.EQ.5 .or. JOB.EQ.6) THEN
3249         RINF3=ONE
3250         IF (JOB.EQ.5) THEN
3251            DO 75 J = 1,N
3252               FACT = ZERO
3253               DO 60 K = IP(J),IP(J+1)-1_8
3254                  IF (A(K).GT.FACT) FACT = A(K)
3255 60            CONTINUE
3256               DW(2*M+J) = FACT
3257               IF (FACT.NE.ZERO) THEN
3258                  FACT = log(FACT)
3259                  IF(FACT .GT. RINF3) RINF3=FACT
3260                  DO 70 K = IP(J),IP(J+1)-1_8
3261                     IF (A(K).NE.ZERO) THEN
3262                        A(K) = FACT - log(A(K))
3263                        IF(A(K) .GT. RINF3) RINF3=A(K)
3264                     ELSE
3265                        A(K) = FACT + RINF
3266                     ENDIF
3267 70               CONTINUE
3268               ELSE
3269                  DO 71 K = IP(J),IP(J+1)-1_8
3270                     A(K) = ONE
3271 71               CONTINUE
3272               ENDIF
3273 75         CONTINUE
3274         ENDIF
3275         IF (JOB.EQ.6) THEN
3276            DO 175 K = 1,NE
3277               IW(3*N+2*M+K) = IRN(K)
3278 175        CONTINUE
3279            DO 61 I = 1,M
3280               DW(2*M+N+I) = ZERO
3281 61         CONTINUE
3282            DO 63 J = 1,N
3283               DO 62 K = IP(J),IP(J+1)-1_8
3284                  I = IRN(K)
3285                  IF (A(K).GT.DW(2*M+N+I)) THEN
3286                     DW(2*M+N+I) = A(K)
3287                  ENDIF
3288 62            CONTINUE
3289 63         CONTINUE
3290            DO 64 I = 1,M
3291               IF (DW(2*M+N+I).NE.ZERO) THEN
3292                  DW(2*M+N+I) = 1.0D0/DW(2*M+N+I)
3293               ENDIF
3294 64         CONTINUE
3295            DO 66 J = 1,N
3296               DO 65 K = IP(J),IP(J+1)-1
3297                  I = IRN(K)
3298                  A(K) = DW(2*M+N+I) * A(K)
3299 65            CONTINUE
3300 66         CONTINUE
3301            CALL DMUMPS_MTRANSR(N,NE,IP,IW(3*N+2*M+1),A)
3302            DO 176 J = 1,N
3303               IF (IP(J).NE.IP(J+1)) THEN
3304                  FACT = A(IP(J))
3305               ELSE
3306                  FACT = ZERO
3307               ENDIF
3308               DW(2*M+J) = FACT
3309               IF (FACT.NE.ZERO) THEN
3310                  FACT = log(FACT)
3311                  DO 170 K = IP(J),IP(J+1)-1_8
3312                     IF (A(K).NE.ZERO) THEN
3313                        A(K) = FACT - log(A(K))
3314                        IF(A(K) .GT. RINF3) RINF3=A(K)
3315                     ELSE
3316                        A(K) = FACT + RINF
3317                     ENDIF
3318 170              CONTINUE
3319               ELSE
3320                  DO 171 K = IP(J),IP(J+1)-1_8
3321                     A(K) = ONE
3322 171              CONTINUE
3323               ENDIF
3324 176        CONTINUE
3325         ENDIF
3326         DW(1) = max(ZERO,CNTL(1))
3327         RINF3 = RINF3+ONE
3328         DW(2) = RINF3
3329         IWtemp8(1) = int(JOB,8)
3330          IF (JOB.EQ.5) THEN
3331         CALL DMUMPS_MTRANSW(M,N,NE,IP,IRN,A,PERM,NUM,
3332     &        IWtemp8(1),IW(1),IWtemp8(N+1),IPQ8,IW(N+1),
3333     &        IWtemp8(2*N+1),
3334     &        DW(1),DW(M+1),RINF2)
3335         ENDIF
3336         IF (JOB.EQ.6) THEN
3337         CALL DMUMPS_MTRANSW(M,N,NE,IP,IW(3*N+2*M+1),A,PERM,NUM,
3338     &        IWtemp8(1),IW(1),IWtemp8(N+1),IPQ8,IW(N+1),
3339     &        IWtemp8(2*N+1),
3340     &        DW(1),DW(M+1),RINF2)
3341         ENDIF
3342         IF ((JOB.EQ.5).or.(JOB.EQ.6)) THEN
3343          DEALLOCATE(IWtemp8)
3344         ENDIF
3345         IF (JOB.EQ.6) THEN
3346            DO 79 I = 1,M
3347               IF (DW(2*M+N+I).NE.0.0D0) THEN
3348                  DW(I) = DW(I) + log(DW(2*M+N+I))
3349               ENDIF
3350 79         CONTINUE
3351         ENDIF
3352         IF (NUM.EQ.N) THEN
3353            DO 80 J = 1,N
3354               IF (DW(2*M+J).NE.ZERO) THEN
3355                  DW(M+J) = DW(M+J) - log(DW(2*M+J))
3356               ELSE
3357                  DW(M+J) = ZERO
3358               ENDIF
3359 80         CONTINUE
3360         ENDIF
3361         FACT = 0.5D0*log(RINF2)
3362         DO 86 I = 1,M
3363            IF (DW(I).LT.FACT) GO TO 86
3364            WARN2 = 2
3365            GO TO 90
3366 86      CONTINUE
3367         DO 87 J = 1,N
3368            IF (DW(M+J).LT.FACT) GO TO 87
3369            WARN2 = 2
3370            GO TO 90
3371 87      CONTINUE
3372      ENDIF
3373 90   IF (INFOMUMPS(1).LT.0) RETURN
3374      IF (NUM.LT.N) WARN1 = 1
3375      IF (JOB.EQ.4 .OR. JOB.EQ.5 .OR. JOB.EQ.6) THEN
3376         IF (CNTL(1).LT.ZERO) WARN4 = 4
3377      ENDIF
3378      IF (INFO(1).EQ.0) THEN
3379         INFO(1) = WARN1 + WARN2 + WARN4
3380         IF (INFO(1).GT.0 .AND. ICNTL(2).GT.0) THEN
3381            WRITE(ICNTL(2),9010) INFO(1)
3382            IF (WARN1.EQ.1) WRITE(ICNTL(2),9011)
3383            IF (WARN2.EQ.2) WRITE(ICNTL(2),9012)
3384            IF (WARN4.EQ.4) WRITE(ICNTL(2),9014)
3385         ENDIF
3386      ENDIF
3387      IF (ICNTL(3).GE.0) THEN
3388         IF (ICNTL(4).EQ.0 .OR. ICNTL(4).EQ.1) THEN
3389            WRITE(ICNTL(3),9030) (INFO(J),J=1,2)
3390            WRITE(ICNTL(3),9031) NUM
3391            IF (ICNTL(4).EQ.0) THEN
3392               WRITE(ICNTL(3),9032) (PERM(J),J=1,min(10,M))
3393               IF (JOB.EQ.5 .OR. JOB.EQ.6) THEN
3394                  WRITE(ICNTL(3),9033) (DW(J),J=1,min(10,M))
3395                  WRITE(ICNTL(3),9034) (DW(M+J),J=1,min(10,N))
3396               ENDIF
3397            ELSEIF (ICNTL(4).EQ.1) THEN
3398               WRITE(ICNTL(3),9032) (PERM(J),J=1,M)
3399               IF (JOB.EQ.5 .OR. JOB.EQ.6) THEN
3400                  WRITE(ICNTL(3),9033) (DW(J),J=1,M)
3401                  WRITE(ICNTL(3),9034) (DW(M+J),J=1,N)
3402               ENDIF
3403            ENDIF
3404         ENDIF
3405      ENDIF
3406 99   RETURN
3407 9001 FORMAT (' ****** Error in DMUMPS_MTRANSA. INFO(1) = ',I2,
3408     &     ' because ',(A),' = ',I14)
3409 9004 FORMAT (' ****** Error in DMUMPS_MTRANSA. INFO(1) = ',I2/
3410     &     '        LIW too small, must be at least ',I14)
3411 9005 FORMAT (' ****** Error in DMUMPS_MTRANSA. INFO(1) = ',I2/
3412     &     '        LDW too small, must be at least ',I14)
3413 9006 FORMAT (' ****** Error in DMUMPS_MTRANSA. INFO(1) = ',I2/
3414     &     '        Column ',I8,
3415     &     ' contains an entry with invalid row index ',I8)
3416 9007 FORMAT (' ****** Error in DMUMPS_MTRANSA. INFO(1) = ',I2/
3417     &     '        Column ',I8,
3418     &     ' contains two or more entries with row index ',I8)
3419 9010 FORMAT (' ****** Warning from DMUMPS_MTRANSA. INFO(1) = ',I2)
3420 9011 FORMAT ('        - The matrix is structurally singular.')
3421 9012 FORMAT ('        - Some scaling factors may be too large.')
3422 9014 FORMAT ('        - CNTL(1) is negative and was treated as zero.')
3423 9020 FORMAT (' ****** Input parameters for DMUMPS_MTRANSA:'/
3424     &     ' JOB =',I10/' M   =',I10/' N   =',I10/' NE  =',I14)
3425 9021 FORMAT (' IP(1:N+1)   = ',8I8/(15X,8I8))
3426 9022 FORMAT (' IRN(1:NE)   = ',8I8/(15X,8I8))
3427 9023 FORMAT (' A(1:NE)     = ',4(1PD14.4)/(15X,4(1PD14.4)))
3428 9024 FORMAT (' ICNTL(1:10) = ',8I8/(15X,2I8))
3429 9025 FORMAT (' CNTL(1:10)  = ',4(1PD14.4)/(15X,4(1PD14.4)))
3430 9030 FORMAT (' ****** Output parameters for DMUMPS_MTRANSA:'/
3431     &     ' INFO(1:2)   = ',2I8)
3432 9031 FORMAT (' NUM         = ',I8)
3433 9032 FORMAT (' PERM(1:M)   = ',8I8/(15X,8I8))
3434 9033 FORMAT (' DW(1:M)     = ',5(F11.3)/(15X,5(F11.3)))
3435 9034 FORMAT (' DW(M+1:M+N) = ',5(F11.3)/(15X,5(F11.3)))
3436      END SUBROUTINE DMUMPS_MTRANS_DRIVER
3437      SUBROUTINE DMUMPS_SUPPRESS_DUPPLI_VAL(N,NZ,IP,IRN,A,FLAG,POSI)
3438      IMPLICIT NONE
3439      INTEGER, INTENT(IN)       :: N
3440      INTEGER(8), INTENT(INOUT) :: NZ
3441      INTEGER(8), INTENT(INOUT) :: IP(N+1)
3442      INTEGER, INTENT(INOUT)    :: IRN(NZ)
3443      DOUBLE PRECISION, INTENT(INOUT)       :: A(NZ)
3444      INTEGER, INTENT(OUT)         :: FLAG(N)
3445      INTEGER(8), INTENT(OUT)      :: POSI(N)
3446      INTEGER    :: ROW, COL
3447      INTEGER(8) :: K, WR_POS, BEG_COL, SV_POS
3448      FLAG = 0
3449      WR_POS = 1_8
3450      DO COL=1,N
3451         BEG_COL = WR_POS
3452         DO K=IP(COL),IP(COL+1)-1_8
3453            ROW = IRN(K)
3454            IF(FLAG(ROW) .NE. COL) THEN
3455               IRN(WR_POS) = ROW
3456               A(WR_POS) = A(K)
3457               FLAG(ROW) = COL
3458               POSI(ROW) = WR_POS
3459               WR_POS = WR_POS+1
3460            ELSE
3461               SV_POS = POSI(ROW)
3462               A(SV_POS) = A(SV_POS) + A(K)
3463            ENDIF
3464         ENDDO
3465         IP(COL) = BEG_COL
3466      ENDDO
3467      IP(N+1) = WR_POS
3468      NZ = WR_POS-1_8
3469      RETURN
3470      END SUBROUTINE DMUMPS_SUPPRESS_DUPPLI_VAL
3471      SUBROUTINE DMUMPS_SUPPRESS_DUPPLI_STR(N,NZ,IP,IRN,FLAG)
3472      IMPLICIT NONE
3473      INTEGER, INTENT(IN)       :: N
3474      INTEGER(8), INTENT(INOUT) :: NZ
3475      INTEGER(8), INTENT(INOUT) :: IP(N+1)
3476      INTEGER, INTENT(INOUT)    :: IRN(NZ)
3477      INTEGER, INTENT(OUT)         :: FLAG(N)
3478      INTEGER    :: ROW, COL
3479      INTEGER(8) :: K, WR_POS, BEG_COL
3480      FLAG = 0
3481      WR_POS = 1_8
3482      DO COL=1,N
3483         BEG_COL = WR_POS
3484         DO K=IP(COL),IP(COL+1)-1_8
3485            ROW = IRN(K)
3486            IF(FLAG(ROW) .NE. COL) THEN
3487               IRN(WR_POS) = ROW
3488               FLAG(ROW) = COL
3489               WR_POS = WR_POS+1_8
3490            ENDIF
3491         ENDDO
3492         IP(COL) = BEG_COL
3493      ENDDO
3494      IP(N+1) = WR_POS
3495      NZ = WR_POS-1_8
3496      RETURN
3497      END SUBROUTINE DMUMPS_SUPPRESS_DUPPLI_STR
3498      SUBROUTINE DMUMPS_SORT_PERM( N, NA, LNA, NE_STEPS,
3499     &          PERM, FILS,
3500     &          DAD_STEPS, STEP, NSTEPS, INFO)
3501      IMPLICIT NONE
3502      INTEGER, INTENT(IN)  ::  N, NSTEPS, LNA
3503      INTEGER, INTENT(IN)  ::  FILS( N ), STEP(N), NA(LNA)
3504      INTEGER, INTENT(IN)  ::  DAD_STEPS ( NSTEPS ), NE_STEPS (NSTEPS)
3505      INTEGER, INTENT(INOUT) :: INFO(40)
3506      INTEGER, INTENT(OUT) ::  PERM( N )
3507      INTEGER  :: IPERM, INODE, IN
3508      INTEGER  :: INBLEAF, INBROOT, allocok
3509      INTEGER, ALLOCATABLE, DIMENSION (:) :: POOL, NSTK
3510      INBLEAF = NA(1)
3511      INBROOT = NA(2)
3512      ALLOCATE(POOL(INBLEAF), NSTK(NSTEPS), stat=allocok)
3513      IF (allocok > 0 ) THEN
3514        INFO(1) = -7
3515        INFO(2) = INBLEAF + NSTEPS
3516        RETURN
3517      ENDIF
3518      POOL(1:INBLEAF) = NA(3:2+INBLEAF)
3519      NSTK(1:NSTEPS) = NE_STEPS(1:NSTEPS)
3520      IPERM = 1
3521      DO WHILE ( INBLEAF .NE. 0 )
3522        INODE = POOL( INBLEAF )
3523        INBLEAF = INBLEAF - 1
3524        IN = INODE
3525        DO WHILE ( IN .GT. 0 )
3526          PERM ( IN ) = IPERM
3527          IPERM = IPERM + 1
3528          IN = FILS( IN )
3529        END DO
3530        IN = DAD_STEPS(STEP( INODE ))
3531        IF ( IN .eq. 0 ) THEN
3532          INBROOT = INBROOT - 1
3533        ELSE
3534          NSTK( STEP(IN) ) = NSTK( STEP(IN) ) - 1
3535          IF ( NSTK( STEP(IN) ) .eq. 0 ) THEN
3536            INBLEAF = INBLEAF + 1
3537            POOL( INBLEAF ) = IN
3538          END IF
3539        END IF
3540      END DO
3541      DEALLOCATE(POOL, NSTK)
3542      RETURN
3543      END SUBROUTINE DMUMPS_SORT_PERM
3544      SUBROUTINE DMUMPS_ANA_N_PAR( id, PTRAR )
3545      USE DMUMPS_STRUC_DEF
3546      IMPLICIT NONE
3547      include 'mpif.h'
3548      TYPE(DMUMPS_STRUC), INTENT(IN), TARGET :: id
3549      INTEGER(8), INTENT(OUT), TARGET        :: PTRAR(id%N,2)
3550      INTEGER          :: IERR
3551      INTEGER          :: IOLD, JOLD, INEW, JNEW
3552      INTEGER(8)       :: K, INZ
3553      INTEGER, POINTER :: IIRN(:), IJCN(:)
3554      INTEGER(8), POINTER :: IWORK1(:), IWORK2(:)
3555      LOGICAL          :: IDO
3556      IF(id%KEEP(54) .EQ. 3) THEN
3557            IIRN => id%IRN_loc
3558            IJCN => id%JCN_loc
3559            INZ = id%KEEP8(29)
3560            IWORK1 => PTRAR(1:id%N,2)
3561            allocate(IWORK2(id%N))
3562            IDO = .TRUE.
3563      ELSE
3564            IIRN => id%IRN
3565            IJCN => id%JCN
3566            INZ  =  id%KEEP8(28)
3567            IWORK1 => PTRAR(1:id%N,1)
3568            IWORK2 => PTRAR(1:id%N,2)
3569            IDO = id%MYID .EQ. 0
3570      END IF
3571      DO 50 IOLD=1,id%N
3572         IWORK1(IOLD) = 0_8
3573         IWORK2(IOLD) = 0_8
3574 50   CONTINUE
3575      IF(IDO) THEN
3576         DO 70 K=1_8,INZ
3577            IOLD = IIRN(K)
3578            JOLD = IJCN(K)
3579            IF ( (IOLD.GT.id%N).OR.(JOLD.GT.id%N).OR.(IOLD.LT.1)
3580     &           .OR.(JOLD.LT.1) ) GOTO 70
3581            IF (IOLD.NE.JOLD) THEN
3582               INEW = id%SYM_PERM(IOLD)
3583               JNEW = id%SYM_PERM(JOLD)
3584               IF ( id%KEEP( 50 ) .EQ. 0 ) THEN
3585                  IF (INEW.LT.JNEW) THEN
3586                     IWORK2(IOLD) = IWORK2(IOLD) + 1_8
3587                  ELSE
3588                     IWORK1(JOLD) = IWORK1(JOLD) + 1_8
3589                  ENDIF
3590               ELSE
3591                  IF ( INEW .LT. JNEW ) THEN
3592                     IWORK1( IOLD ) = IWORK1( IOLD ) + 1_8
3593                  ELSE
3594                     IWORK1( JOLD ) = IWORK1( JOLD ) + 1_8
3595                  END IF
3596               ENDIF
3597            ENDIF
3598 70      CONTINUE
3599      END IF
3600      IF (id%KEEP(54) .EQ. 3) THEN
3601         CALL MPI_ALLREDUCE(IWORK1(1), PTRAR(1,1), id%N, MPI_INTEGER8,
3602     &        MPI_SUM, id%COMM, IERR )
3603         CALL MPI_ALLREDUCE(IWORK2(1), PTRAR(1,2), id%N, MPI_INTEGER8,
3604     &        MPI_SUM, id%COMM, IERR )
3605         deallocate(IWORK2)
3606      ELSE
3607         CALL MPI_BCAST( PTRAR, 2*id%N, MPI_INTEGER8,
3608     &        0, id%COMM, IERR )
3609      END IF
3610      RETURN
3611      END SUBROUTINE DMUMPS_ANA_N_PAR
3612      SUBROUTINE DMUMPS_DIST_AVOID_COPIES(N,NSLAVES,
3613     &     ICNTL,INFOG, NE, NFSIZ,
3614     &     FRERE, FILS,
3615     &     KEEP,KEEP8,PROCNODE,
3616     &     SSARBR,NBSA,PEAK,IERR
3617     &     )
3618      USE MUMPS_STATIC_MAPPING
3619      IMPLICIT NONE
3620      INTEGER N, NSLAVES, NBSA, IERR
3621      INTEGER ICNTL(40),INFOG(40),KEEP(500)
3622      INTEGER(8) KEEP8(150)
3623      INTEGER NE(N),NFSIZ(N),FRERE(N),FILS(N),PROCNODE(N)
3624      INTEGER SSARBR(N)
3625      DOUBLE PRECISION PEAK
3626      CALL MUMPS_DISTRIBUTE(N,NSLAVES,
3627     &     ICNTL,INFOG, NE, NFSIZ,
3628     &     FRERE, FILS,
3629     &     KEEP,KEEP8,PROCNODE,
3630     &     SSARBR,NBSA,dble(PEAK),IERR
3631     &     )
3632      RETURN
3633      END SUBROUTINE DMUMPS_DIST_AVOID_COPIES
3634      SUBROUTINE DMUMPS_SET_PROCNODE(INODE, PROCNODE, VALUE, FILS, N)
3635      INTEGER, intent(in) :: INODE, N, VALUE
3636      INTEGER, intent(in) :: FILS(N)
3637      INTEGER, intent(inout) :: PROCNODE(N)
3638      INTEGER IN
3639      IN=INODE
3640      DO WHILE ( IN > 0 )
3641         PROCNODE( IN ) = VALUE
3642         IN=FILS( IN )
3643      ENDDO
3644      RETURN
3645      END SUBROUTINE DMUMPS_SET_PROCNODE
3646