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 ZMUMPS_PROCESS_CONTRIB_TYPE3(BUFR,LBUFR,
14     &     LBUFR_BYTES,
15     &     root, N, IW, LIW, A, LA,
16     &     NBPROCFILS, LRLU, IPTRLU, IWPOS, IWPOSCB,
17     &     PTRIST, PTLUST, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER,
18     &     COMP, LRLUS, IPOOL, LPOOL, LEAF,
19     &     FILS, MYID, PTRAIW, PTRARW, INTARR, DBLARR,
20     &     KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD,
21     &     ITLOC, RHS_MUMPS,
22     &     ND,PROCNODE_STEPS,SLAVEF )
23      USE ZMUMPS_LOAD
24      USE ZMUMPS_OOC
25      IMPLICIT NONE
26      INCLUDE 'zmumps_root.h'
27      TYPE (ZMUMPS_ROOT_STRUC ) :: root
28      INTEGER    :: KEEP( 500 )
29      INTEGER(8) :: KEEP8(150)
30      DOUBLE PRECISION       :: DKEEP(230)
31      INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS
32      INTEGER(8) :: PAMASTER(KEEP(28))
33      INTEGER(8) :: PTRAST(KEEP(28))
34      INTEGER(8) :: PTRFAC(KEEP(28))
35      INTEGER LBUFR, LBUFR_BYTES, N, LIW,
36     &        IWPOS, IWPOSCB, COMP, COMM, COMM_LOAD, IFLAG,
37     &        IERROR
38      INTEGER LPOOL, LEAF
39      INTEGER IPOOL( LEAF )
40      INTEGER PTRIST(KEEP(28))
41      INTEGER PTLUST(KEEP(28))
42      INTEGER STEP(N), PIMASTER(KEEP(28)), ITLOC( N+KEEP(253) )
43      COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255))
44      INTEGER BUFR( LBUFR_BYTES ), NBPROCFILS( KEEP(28) )
45      INTEGER IW( LIW )
46      INTEGER ND(KEEP(28)), PROCNODE_STEPS(KEEP(28)),SLAVEF
47      COMPLEX(kind=8) A( LA )
48      INTEGER   MYID
49      INTEGER FILS( N )
50      INTEGER(8), INTENT(IN) :: PTRAIW(N), PTRARW( N )
51      INTEGER INTARR(KEEP8(27))
52      COMPLEX(kind=8) DBLARR(KEEP8(26))
53        INCLUDE 'mpif.h'
54        INTEGER IERR
55        EXTERNAL MUMPS_PROCNODE
56        INTEGER MUMPS_PROCNODE
57        INTEGER POSITION, LOCAL_M, LOCAL_N, LREQI
58        INTEGER(8) :: LREQA, POS_ROOT
59        INTEGER NSUBSET_ROW, NSUBSET_COL, IROOT, ISON, NSUBSET_COL_EFF
60        INTEGER NSUPCOL_EFF
61        INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET
62        INTEGER NSUPROW, NSUPCOL, BBPCBP
63        INCLUDE 'mumps_headers.h'
64        POSITION = 0
65        CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
66     &                   ISON, 1, MPI_INTEGER, COMM, IERR )
67        CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
68     &                   NSUBSET_ROW, 1, MPI_INTEGER, COMM, IERR )
69        CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
70     &                   NSUPROW, 1, MPI_INTEGER, COMM, IERR )
71        CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
72     &                   NSUBSET_COL, 1, MPI_INTEGER, COMM, IERR )
73        CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
74     &                   NSUPCOL, 1, MPI_INTEGER, COMM, IERR )
75        CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
76     &                   NBROWS_ALREADY_SENT, 1, MPI_INTEGER,
77     &                   COMM, IERR )
78        CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
79     &                   NBROWS_PACKET, 1, MPI_INTEGER,
80     &                   COMM, IERR )
81        CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
82     &                   BBPCBP, 1, MPI_INTEGER,
83     &                   COMM, IERR )
84        IF (BBPCBP .EQ. 1) THEN
85          NSUBSET_COL_EFF = NSUBSET_COL - NSUPCOL
86          NSUPCOL_EFF = 0
87        ELSE
88          NSUBSET_COL_EFF = NSUBSET_COL
89          NSUPCOL_EFF = NSUPCOL
90        ENDIF
91        IROOT = KEEP( 38 )
92        IF ( PTRIST( STEP(IROOT) ) .NE. 0 .OR.
93     &       PTLUST( STEP(IROOT)) .NE. 0 ) THEN
94          IF (NBROWS_ALREADY_SENT + NBROWS_PACKET .EQ. NSUBSET_ROW
95     &       - NSUPROW .OR.  NSUBSET_ROW - NSUPROW.EQ.0 .OR.
96     &       NSUBSET_COL_EFF .EQ. 0)THEN
97            NBPROCFILS(STEP(IROOT)) = NBPROCFILS(STEP(IROOT))-1
98#if ! defined(NO_XXNBPR)
99            KEEP(121) = KEEP(121) - 1
100            CALL CHECK_EQUAL(NBPROCFILS(STEP(IROOT)),KEEP(121))
101            IF ( KEEP(121) .eq. 0 ) THEN
102#else
103            IF ( NBPROCFILS( STEP(IROOT) ) .eq. 0 ) THEN
104#endif
105              IF (KEEP(201).EQ.1) THEN
106                 CALL ZMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR)
107              ELSEIF (KEEP(201).EQ.2) THEN
108                 CALL ZMUMPS_FORCE_WRITE_BUF(IERR)
109              ENDIF
110              CALL ZMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL,
111     &             PROCNODE_STEPS, SLAVEF, KEEP(28), KEEP(76),
112     &             KEEP(80), KEEP(47),
113     &             STEP, IROOT + N)
114              IF (KEEP(47) .GE. 3) THEN
115                 CALL ZMUMPS_LOAD_POOL_UPD_NEW_POOL(
116     &                IPOOL, LPOOL,
117     &                PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD,
118     &                MYID, STEP, N, ND, FILS )
119              ENDIF
120            ENDIF
121          ENDIF
122        ELSE
123           IF (NBROWS_ALREADY_SENT + NBROWS_PACKET .EQ.
124     &       NSUBSET_ROW - NSUPROW .OR.
125     &        NSUBSET_ROW - NSUPROW.EQ.0 .OR.
126     &        NSUBSET_COL_EFF .EQ. 0)THEN
127             NBPROCFILS(STEP( IROOT ) ) = -1
128#if ! defined(NO_XXNBPR)
129             KEEP(121)=-1
130#endif
131           ENDIF
132           IF (KEEP(60) == 0) THEN
133            CALL ZMUMPS_ROOT_ALLOC_STATIC( root, IROOT, N,
134     &                IW, LIW, A, LA,
135     &                FILS, MYID, PTRAIW, PTRARW, INTARR, DBLARR,
136     &                LRLU, IPTRLU,
137     &                IWPOS, IWPOSCB, PTRIST, PTRAST,
138     &                STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS,
139     &                COMP, LRLUS, IFLAG, KEEP,KEEP8,DKEEP,IERROR )
140            IF ( IFLAG .LT. 0 ) RETURN
141           ELSE
142             PTRIST(STEP(IROOT)) = -55555
143           ENDIF
144        END IF
145      IF (KEEP(60) .EQ.0) THEN
146        IF ( PTRIST(STEP(IROOT)) .GE. 0 ) THEN
147          IF ( PTRIST(STEP(IROOT)) .NE. 0 ) THEN
148               LOCAL_N  = -IW( PTRIST(STEP( IROOT )) + KEEP(IXSZ)    )
149               LOCAL_M  =  IW( PTRIST(STEP( IROOT )) + 1 + KEEP(IXSZ))
150               POS_ROOT = PAMASTER(STEP( IROOT ))
151          ELSE
152               LOCAL_N = IW( PTLUST(STEP( IROOT ) ) + 1 + KEEP(IXSZ))
153               LOCAL_M = IW( PTLUST(STEP( IROOT ) ) + 2 + KEEP(IXSZ))
154               POS_ROOT = PTRFAC(IW(PTLUST(STEP(IROOT))+4+
155     &                    KEEP(IXSZ)))
156          END IF
157         ENDIF
158      ELSE
159          LOCAL_M = root%SCHUR_LLD
160          LOCAL_N = root%SCHUR_NLOC
161      ENDIF
162        IF ( (BBPCBP.EQ.1).AND. (NBROWS_ALREADY_SENT.EQ.0).AND.
163     &     (min(NSUPROW, NSUPCOL) .GT. 0)
164     &     ) THEN
165         LREQI = NSUPROW+NSUPCOL
166         LREQA = int(NSUPROW,8) * int(NSUPCOL,8)
167         IF ( (LREQA.NE.0_8) .AND.
168     &       (PTRIST(STEP(IROOT)).LT.0).AND.
169     &       KEEP(60)==0) THEN
170          WRITE(*,*) ' Error in ZMUMPS_PROCESS_CONTRIB_TYPE3'
171          CALL MUMPS_ABORT()
172         ENDIF
173         CALL ZMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE.,
174     &     MYID,N,KEEP,KEEP8,DKEEP,IW,LIW,A, LA,
175     &     LRLU, IPTRLU, IWPOS, IWPOSCB, PTRIST,
176     &     PTRAST, STEP, PIMASTER, PAMASTER,
177     &     LREQI, LREQA, -1234, S_NOTFREE, .FALSE.,
178     &     COMP, LRLUS, IFLAG, IERROR
179     &          )
180         IF ( IFLAG .LT. 0 ) RETURN
181         CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
182     &                   IW( IWPOSCB + 1 ), LREQI,
183     &                   MPI_INTEGER, COMM, IERR )
184         CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
185     &                   A( IPTRLU + 1_8 ), int(LREQA),
186     &                   MPI_DOUBLE_COMPLEX, COMM, IERR )
187         CALL ZMUMPS_ASS_ROOT( NSUPROW, NSUPCOL,
188     &                     IW( IWPOSCB + 1 ),
189     &                     IW( IWPOSCB + NSUPROW + 1 ), NSUPCOL,
190     &                     A( IPTRLU + 1_8 ),
191     &                     A( 1 ),
192     &                     LOCAL_M, LOCAL_N,
193     &                  root%RHS_ROOT(1,1), root%RHS_NLOC,
194     &                  1)
195         IWPOSCB = IWPOSCB + LREQI
196         IPTRLU  = IPTRLU  + LREQA
197         LRLU    = LRLU    + LREQA
198         LRLUS   = LRLUS   + LREQA
199         KEEP8(70) = KEEP8(70) + LREQA
200         KEEP8(71) = KEEP8(71) + LREQA
201         CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE.,
202     &                    LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLUS)
203        ENDIF
204        LREQI = NBROWS_PACKET + NSUBSET_COL_EFF
205        LREQA = int(NBROWS_PACKET,8) * int(NSUBSET_COL_EFF,8)
206        IF ( (LREQA.NE.0_8) .AND.
207     &       (PTRIST(STEP(IROOT)).LT.0).AND.
208     &       KEEP(60)==0) THEN
209         WRITE(*,*) ' Error in ZMUMPS_PROCESS_CONTRIB_TYPE3'
210         CALL MUMPS_ABORT()
211        ENDIF
212        IF (LREQA.NE.0_8) THEN
213          CALL ZMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE.,
214     &     MYID,N,KEEP,KEEP8,DKEEP,IW,LIW,A, LA,
215     &     LRLU, IPTRLU, IWPOS, IWPOSCB, PTRIST,
216     &     PTRAST, STEP, PIMASTER, PAMASTER,
217     &     LREQI, LREQA, -1234, S_NOTFREE, .FALSE.,
218     &     COMP, LRLUS, IFLAG, IERROR
219     &          )
220          IF ( IFLAG .LT. 0 ) RETURN
221          CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
222     &                   IW( IWPOSCB + 1 ), LREQI,
223     &                   MPI_INTEGER, COMM, IERR )
224          CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION,
225     &                   A( IPTRLU + 1_8 ), int(LREQA),
226     &                   MPI_DOUBLE_COMPLEX, COMM, IERR )
227          IF (KEEP(60).EQ.0) THEN
228            CALL ZMUMPS_ASS_ROOT( NBROWS_PACKET, NSUBSET_COL_EFF,
229     &                     IW( IWPOSCB + 1 ),
230     &                     IW( IWPOSCB + NBROWS_PACKET + 1 ),
231     &                     NSUPCOL_EFF,
232     &                     A( IPTRLU + 1_8 ),
233     &                     A( POS_ROOT ), LOCAL_M, LOCAL_N,
234     &                  root%RHS_ROOT(1,1), root%RHS_NLOC,
235     &                  0)
236          ELSE
237            CALL ZMUMPS_ASS_ROOT( NBROWS_PACKET, NSUBSET_COL_EFF,
238     &                     IW( IWPOSCB + 1 ),
239     &                     IW( IWPOSCB + NBROWS_PACKET + 1 ),
240     &                     NSUPCOL_EFF,
241     &                     A( IPTRLU + 1_8 ),
242     &                     root%SCHUR_POINTER(1),
243     &                     root%SCHUR_LLD , root%SCHUR_NLOC,
244     &                  root%RHS_ROOT(1,1), root%RHS_NLOC,
245     &                  0)
246          ENDIF
247          IWPOSCB = IWPOSCB + LREQI
248          IPTRLU  = IPTRLU  + LREQA
249          LRLU    = LRLU    + LREQA
250          LRLUS   = LRLUS   + LREQA
251          KEEP8(70) = KEEP8(70) + LREQA
252          KEEP8(71) = KEEP8(71) + LREQA
253          CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE.,
254     &                    LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLUS)
255        ENDIF
256      RETURN
257      END SUBROUTINE ZMUMPS_PROCESS_CONTRIB_TYPE3
258