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 SMUMPS_PROCESS_CONTRIB_TYPE2( COMM_LOAD, ASS_IRECV,
14     &   MSGLEN, BUFR, LBUFR,
15     &   LBUFR_BYTES, PROCNODE_STEPS,
16     &   SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, POSFAC,
17     &   N, IW, LIW, A, LA, PTRIST, PTLUST, PTRFAC, PTRAST,
18     &   STEP, PIMASTER, PAMASTER, NBPROCFILS,
19     &   COMP, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, NSTK_S,
20     &   FILS, PTRARW, PTRAIW, INTARR, DBLARR, NBFIN,
21     &   MYID, COMM, ICNTL, KEEP,KEEP8,DKEEP, IFLAG, IERROR,
22     &   IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, LPTRAR, NELT,
23     &   FRTPTR, FRTELT,
24     &   ISTEP_TO_INIV2, TAB_POS_IN_PERE
25     &               , LRGROUPS
26     &   )
27      USE SMUMPS_LOAD
28      USE SMUMPS_BUF
29      IMPLICIT NONE
30      INCLUDE 'smumps_root.h'
31      TYPE (SMUMPS_ROOT_STRUC) :: root
32      INTEGER ICNTL( 40 ), KEEP( 500 )
33      INTEGER(8) KEEP8(150)
34      REAL    DKEEP(230)
35      INTEGER LBUFR, LBUFR_BYTES
36      INTEGER COMM_LOAD, ASS_IRECV, MSGLEN
37      INTEGER BUFR( LBUFR )
38      INTEGER(8) :: LRLU, IPTRLU, LRLUS, LA, POSFAC
39      INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW
40      INTEGER NBFIN
41      INTEGER COMP
42      INTEGER NELT, LPTRAR
43      INTEGER PROCNODE_STEPS( KEEP(28) ), PTRIST(KEEP(28))
44      INTEGER(8) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28))
45      INTEGER(8) :: PTRFAC(KEEP(28))
46      INTEGER STEP(N), PIMASTER(KEEP(28))
47      INTEGER PTLUST( KEEP(28) )
48      INTEGER NBPROCFILS( KEEP(28) )
49      INTEGER IW( LIW )
50      REAL A( LA )
51      INTEGER, intent(in) :: LRGROUPS(N)
52      INTEGER ITLOC( N + KEEP(253)), NSTK_S( KEEP(28) ), FILS( N )
53      REAL :: RHS_MUMPS(KEEP(255))
54      INTEGER ND(KEEP(28)), FRERE_STEPS( KEEP(28) )
55      INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR )
56      INTEGER INTARR( KEEP8(27) )
57      REAL DBLARR( KEEP8(26) )
58      DOUBLE PRECISION OPASSW, OPELIW
59      INTEGER COMM, MYID, IFLAG, IERROR
60      INTEGER LEAF, LPOOL
61      INTEGER IPOOL( LPOOL )
62      INTEGER FRTPTR(N+1), FRTELT( NELT )
63      INTEGER ISTEP_TO_INIV2(KEEP(71)),
64     &        TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56)))
65      INTEGER NFS4FATHER
66      INCLUDE 'mumps_headers.h'
67      INCLUDE 'mpif.h'
68      INCLUDE 'mumps_tags.h'
69      INTEGER MUMPS_PROCNODE, MUMPS_TYPESPLIT
70      EXTERNAL MUMPS_PROCNODE, MUMPS_TYPESPLIT
71      INTEGER IERR
72      INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET
73      INTEGER I, INODE, ISON, POSITION, NBROW, LROW, IROW, INDCOL
74      INTEGER LREQI
75      INTEGER(8) :: LREQA, POSCONTRIB
76      INTEGER ROW_LENGTH
77      INTEGER MASTER
78      INTEGER ISTCHK
79      LOGICAL SAME_PROC
80      LOGICAL SLAVE_NODE
81      LOGICAL IS_ofType5or6
82      INTEGER ISHIFT_BUFR, LBUFR_LOC, LBUFR_BYTES_LOC
83      INTEGER TYPESPLIT
84      INTEGER DECR
85#if ! defined(NO_XXNBPR)
86      INTEGER :: INBPROCFILS_SON
87#endif
88      POSITION = 0
89      CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, INODE, 1,
90     &                 MPI_INTEGER, COMM, IERR )
91      CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, ISON, 1,
92     &                 MPI_INTEGER, COMM, IERR )
93      CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NBROW, 1,
94     &                 MPI_INTEGER, COMM, IERR )
95      CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, LROW, 1,
96     &                 MPI_INTEGER, COMM, IERR )
97      CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
98     &                 NBROWS_ALREADY_SENT, 1,
99     &                 MPI_INTEGER, COMM, IERR )
100      CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
101     &                 NBROWS_PACKET, 1,
102     &                 MPI_INTEGER, COMM, IERR )
103      MASTER     = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)),SLAVEF)
104      SLAVE_NODE = MASTER .NE. MYID
105      TYPESPLIT = MUMPS_TYPESPLIT(PROCNODE_STEPS(STEP(INODE)),
106     &                  SLAVEF)
107      IS_ofType5or6 = ((TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6))
108      IF (SLAVE_NODE .AND. PTRIST(STEP(INODE)) ==0) THEN
109        ISHIFT_BUFR     = ( MSGLEN + KEEP(34) ) / KEEP(34)
110        LBUFR_LOC       = LBUFR - ISHIFT_BUFR + 1
111        LBUFR_BYTES_LOC = LBUFR_LOC * KEEP(34)
112          CALL SMUMPS_TREAT_DESCBAND( INODE, COMM_LOAD, ASS_IRECV,
113     &     BUFR(ISHIFT_BUFR), LBUFR_LOC, LBUFR_BYTES_LOC,
114     &     PROCNODE_STEPS, POSFAC,
115     &     IWPOS, IWPOSCB, IPTRLU,
116     &     LRLU, LRLUS, N, IW, LIW, A, LA,
117     &     PTRIST, PTLUST, PTRFAC,
118     &     PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP,
119     &     IFLAG, IERROR, COMM,
120     &     NBPROCFILS, IPOOL, LPOOL, LEAF,
121     &     NBFIN, MYID, SLAVEF,
122     &
123     &     root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS,
124     &     PTRARW, PTRAIW,
125     &     INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS,
126     &     LPTRAR, NELT, FRTPTR, FRTELT,
127     &     ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE.
128     &               , LRGROUPS
129     &     )
130          IF (IFLAG.LT.0) RETURN
131      ENDIF
132      IF ( SLAVE_NODE ) THEN
133         LREQI = LROW + NBROWS_PACKET
134      ELSE
135         LREQI = NBROWS_PACKET
136      END IF
137         LREQA = int(LROW,8)
138         IF ( LRLU .LT. LREQA .OR. IWPOS + LREQI
139     &        - 1 .GT. IWPOSCB ) THEN
140            IF ( LRLUS .LT. LREQA ) THEN
141               IFLAG = -9
142               CALL MUMPS_SET_IERROR( LREQA - LRLUS, IERROR )
143               CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP )
144               RETURN
145            END IF
146            CALL SMUMPS_COMPRE_NEW(N, KEEP(28), IW, LIW, A, LA,
147     &           LRLU, IPTRLU,
148     &           IWPOS, IWPOSCB, PTRIST, PTRAST,
149     &           STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS,
150     &           KEEP(IXSZ), COMP, DKEEP(97), MYID )
151            IF ( LRLU .NE. LRLUS ) THEN
152               WRITE(*,*) 'PB compress SMUMPS_PROCESS_CONTRIB_TYPE2'
153               WRITE(*,*) 'LRLU,LRLUS=',LRLU,LRLUS
154               IFLAG = -9
155               CALL MUMPS_SET_IERROR( LREQA - LRLUS, IERROR )
156               CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP )
157               RETURN
158            END IF
159            IF ( IWPOS + LREQI - 1 .GT. IWPOSCB ) THEN
160               IFLAG  = -8
161               IERROR = IWPOS + LREQI - 1 - IWPOSCB
162               CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP )
163               RETURN
164            END IF
165         END IF
166         LRLU  = LRLU - LREQA
167         LRLUS = LRLUS - LREQA
168         POSCONTRIB = POSFAC
169         POSFAC = POSFAC + LREQA
170         KEEP8(67) = min(LRLUS, KEEP8(67))
171         KEEP8(70) = KEEP8(70) - LREQA
172         KEEP8(68) = min(KEEP8(70), KEEP8(68))
173         KEEP8(71) = KEEP8(71) - LREQA
174         KEEP8(69) = min(KEEP8(71), KEEP8(69))
175         CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE.,
176     &        LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLUS)
177         IF  ( SLAVE_NODE ) THEN
178            IROW   = IWPOS
179            INDCOL = IWPOS + NBROWS_PACKET
180         ELSE
181            IROW   = IWPOS
182            INDCOL = -1
183         END IF
184         IWPOS = IWPOS + LREQI
185         IF ( SLAVE_NODE ) THEN
186            CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
187     &           IW( INDCOL ), LROW, MPI_INTEGER,
188     &           COMM, IERR )
189         END IF
190         DO I = 1, NBROWS_PACKET
191            CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
192     &           IW( IROW + I - 1 ), 1, MPI_INTEGER,
193     &           COMM, IERR )
194         END DO
195         IF ( SLAVE_NODE ) THEN
196            IF ( NBROWS_ALREADY_SENT + NBROWS_PACKET == NBROW ) THEN
197              NBPROCFILS(STEP(INODE))=NBPROCFILS(STEP(INODE))-NBROW
198#if ! defined(NO_XXNBPR)
199              IW(PTRIST(STEP(INODE))+XXNBPR) =
200     &        IW(PTRIST(STEP(INODE))+XXNBPR) - NBROW
201#endif
202            ENDIF
203            IF ( KEEP(55) .eq. 0 ) THEN
204               CALL SMUMPS_ASM_SLAVE_TO_SLAVE_INIT
205     &              (N, INODE, IW, LIW, A, LA,
206     &              NBROW, LROW,
207     &              OPASSW, OPELIW, STEP, PTRIST, PTRAST,
208     &              ITLOC, RHS_MUMPS,
209     &              FILS, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL,
210     &              KEEP,KEEP8, MYID )
211            ELSE
212               CALL SMUMPS_ELT_ASM_S_2_S_INIT(
213     &              NELT, FRTPTR, FRTELT,
214     &              N, INODE, IW, LIW, A, LA,
215     &              NBROW, LROW,
216     &              OPASSW, OPELIW, STEP, PTRIST, PTRAST,
217     &              ITLOC, RHS_MUMPS,
218     &              FILS, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL,
219     &              KEEP,KEEP8, MYID )
220            ENDIF
221            DO I=1,NBROWS_PACKET
222               IF(KEEP(50).NE.0)THEN
223                  CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
224     &                 ROW_LENGTH,
225     &                 1,
226     &                 MPI_INTEGER,
227     &                 COMM, IERR )
228               ELSE
229                 ROW_LENGTH=LROW
230               ENDIF
231               CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
232     &              A(POSCONTRIB),
233     &              ROW_LENGTH,
234     &              MPI_REAL,
235     &              COMM, IERR )
236               CALL SMUMPS_ASM_SLAVE_TO_SLAVE(N, INODE, IW, LIW, A, LA,
237     &              1, ROW_LENGTH, IW( IROW+I-1 ),IW(INDCOL),
238     &              A(POSCONTRIB),
239     &              OPASSW, OPELIW, STEP, PTRIST, PTRAST,
240     &              ITLOC, RHS_MUMPS,
241     &              FILS, ICNTL, KEEP,KEEP8, MYID, IS_ofType5or6,
242     &              ROW_LENGTH )
243            ENDDO
244            CALL SMUMPS_ASM_SLAVE_TO_SLAVE_END
245     &           (N, INODE, IW, LIW,
246     &           NBROWS_PACKET, STEP, PTRIST,
247     &           ITLOC, RHS_MUMPS,KEEP,KEEP8)
248         ELSE
249            DO I=1,NBROWS_PACKET
250               IF(KEEP(50).NE.0)THEN
251                  CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
252     &                 ROW_LENGTH,
253     &                 1,
254     &                 MPI_INTEGER,
255     &                 COMM, IERR )
256               ELSE
257                 ROW_LENGTH=LROW
258               ENDIF
259               CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
260     &              A(POSCONTRIB),
261     &              ROW_LENGTH,
262     &              MPI_REAL,
263     &              COMM, IERR )
264               CALL SMUMPS_ASM_SLAVE_MASTER(N, INODE, IW, LIW, A, LA,
265     &              ISON, 1, ROW_LENGTH, IW( IROW +I-1 ),
266     &              A(POSCONTRIB), PTLUST, PTRAST,
267     &              STEP, PIMASTER, OPASSW,
268     &              IWPOSCB, MYID, KEEP,KEEP8,
269     &              IS_ofType5or6, ROW_LENGTH
270     &)
271            ENDDO
272          IF (NBROWS_ALREADY_SENT .EQ. 0) THEN
273          IF (KEEP(219).NE.0) THEN
274            IF(KEEP(50) .EQ. 2) THEN
275               CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
276     &              NFS4FATHER,
277     &              1,
278     &              MPI_INTEGER,
279     &              COMM, IERR )
280               IF(NFS4FATHER .GT. 0) THEN
281                  CALL SMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR)
282                  IF (IERR .NE. 0) THEN
283                      IERROR         = BUF_LMAX_ARRAY
284                      IFLAG          = -13
285                      CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP )
286                      RETURN
287                  ENDIF
288                  CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
289     &                 BUF_MAX_ARRAY,
290     &                 NFS4FATHER,
291     &                 MPI_REAL,
292     &                 COMM, IERR )
293                  CALL SMUMPS_ASM_MAX(N, INODE, IW, LIW, A, LA,
294     &                 ISON, NFS4FATHER,
295     &                 BUF_MAX_ARRAY, PTLUST, PTRAST,
296     &                 STEP, PIMASTER, OPASSW,
297     &                 IWPOSCB, MYID, KEEP,KEEP8)
298               ENDIF
299            ENDIF
300          ENDIF
301          ENDIF
302          IF (NBROWS_ALREADY_SENT + NBROWS_PACKET == NBROW ) THEN
303            DECR = 1
304            NBPROCFILS(STEP(INODE)) = NBPROCFILS(STEP(INODE)) - DECR
305            NBPROCFILS(STEP(ISON))  = NBPROCFILS(STEP(ISON)) - DECR
306            ISTCHK = PIMASTER(STEP(ISON))
307            SAME_PROC = ISTCHK .LT. IWPOSCB
308#if ! defined(NO_XXNBPR)
309            IW(PTLUST(STEP(INODE))+XXNBPR) =
310     &      IW(PTLUST(STEP(INODE))+XXNBPR) - DECR
311            IF (SAME_PROC) THEN
312              INBPROCFILS_SON = PTRIST(STEP(ISON))+XXNBPR
313            ELSE
314              INBPROCFILS_SON = PIMASTER(STEP(ISON))+XXNBPR
315            ENDIF
316            IW(INBPROCFILS_SON) = IW(INBPROCFILS_SON) - DECR
317#endif
318#if ! defined(NO_XXNBPR)
319            IF ( IW(INBPROCFILS_SON) .EQ. 0 ) THEN
320#else
321            IF ( NBPROCFILS(STEP(ISON)) .EQ. 0 ) THEN
322#endif
323               IF (SAME_PROC) THEN
324                  CALL SMUMPS_RESTORE_INDICES(N, ISON, INODE, IWPOSCB,
325     &                 PIMASTER, PTLUST, IW, LIW, STEP, KEEP,KEEP8)
326               ENDIF
327               IF (SAME_PROC) THEN
328                  ISTCHK = PTRIST(STEP(ISON))
329                  PTRIST(STEP( ISON) ) = -99999999
330               ELSE
331                  PIMASTER(STEP( ISON )) = -99999999
332               ENDIF
333               CALL SMUMPS_FREE_BLOCK_CB(.FALSE., MYID, N, ISTCHK,
334     &              PAMASTER(STEP(ISON)),
335     &              IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB,
336     &              LA, KEEP,KEEP8, .FALSE.
337     &              )
338            ENDIF
339#if ! defined(NO_XXNBPR)
340            IF (IW(PTLUST(STEP(INODE))+XXNBPR) .EQ. 0) THEN
341#else
342            IF ( NBPROCFILS(STEP(INODE)) .EQ. 0 ) THEN
343#endif
344               CALL SMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL,
345     &              PROCNODE_STEPS,
346     &              SLAVEF, KEEP(28), KEEP(76), KEEP(80),
347     &              KEEP(47), STEP, INODE+N )
348               IF (KEEP(47) .GE. 3) THEN
349                  CALL SMUMPS_LOAD_POOL_UPD_NEW_POOL(
350     &          IPOOL, LPOOL,
351     &                 PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD,
352     &                 MYID, STEP, N, ND, FILS )
353               ENDIF
354            ENDIF
355          ENDIF
356      END IF
357         IWPOS = IWPOS - LREQI
358         LRLU = LRLU + LREQA
359         LRLUS = LRLUS + LREQA
360         KEEP8(70) = KEEP8(70) + LREQA
361         KEEP8(71) = KEEP8(71) + LREQA
362         POSFAC = POSFAC - LREQA
363         CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE.,
364     &        LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLUS)
365      RETURN
366      END SUBROUTINE SMUMPS_PROCESS_CONTRIB_TYPE2
367