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_DESC_BANDE( MYID, BUFR, LBUFR,
14     &     LBUFR_BYTES,
15     &     IWPOS, IWPOSCB,
16     &     IPTRLU, LRLU, LRLUS,
17     &     TNBPROCFILS, N, IW, LIW, A, LA,
18     &     PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP,
19     &     KEEP,KEEP8, DKEEP, ITLOC, RHS_MUMPS, ISTEP_TO_INIV2,
20#if ! defined(NO_FDM_DESCBAND)
21     &     IWHANDLER_IN,
22#endif
23     &     IFLAG, IERROR )
24      USE ZMUMPS_LOAD
25#if ! defined(NO_FDM_DESCBAND)
26      USE MUMPS_FAC_DESCBAND_DATA_M
27#endif
28      IMPLICIT NONE
29      INTEGER MYID
30      INTEGER KEEP(500)
31      INTEGER(8) KEEP8(150)
32      DOUBLE PRECISION DKEEP(230)
33      INTEGER LBUFR, LBUFR_BYTES
34      INTEGER BUFR( LBUFR )
35      INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA
36      INTEGER IWPOS, IWPOSCB, N, LIW
37      INTEGER IW( LIW )
38      COMPLEX(kind=8) A( LA )
39      INTEGER(8) :: PAMASTER(KEEP(28))
40      INTEGER(8) :: PTRAST(KEEP(28))
41      INTEGER PTRIST(KEEP(28)), STEP(N),
42     & PIMASTER(KEEP(28)),
43     & TNBPROCFILS( KEEP(28) ), ITLOC( N + KEEP(253) )
44      COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255))
45      INTEGER :: ISTEP_TO_INIV2(KEEP(71))
46#if ! defined(NO_FDM_DESCBAND)
47      INTEGER IWHANDLER_IN
48#endif
49      INTEGER COMP, IFLAG, IERROR
50      INTEGER INODE, NBPROCFILS, NCOL, NROW, NASS, NSLAVES
51      INTEGER NSLAVES_RECU, NFRONT
52      INTEGER LREQ
53      INTEGER :: IBUFR
54      INTEGER(8) :: LREQCB
55#if ! defined(NO_FDM_DESCBAND)
56      INTEGER :: IWHANDLER_LOC
57#endif
58      DOUBLE PRECISION FLOP1
59      INCLUDE 'mumps_headers.h'
60#if ! defined(NO_FDM_DESCBAND)
61      INTEGER :: INFO_TMP(2)
62#else
63#endif
64      INTEGER :: LRSTATUS
65      INODE = BUFR( 2 )
66      NBPROCFILS = BUFR( 3 )
67      NROW = BUFR( 4 )
68      NCOL = BUFR( 5 )
69      NASS = BUFR( 6 )
70      NFRONT = BUFR( 7 )
71      NSLAVES_RECU = BUFR( 8 )
72      LRSTATUS =  BUFR( 9 )
73      IBUFR    = 10
74#if ! defined(NO_FDM_DESCBAND)
75      IWHANDLER_LOC = IWHANDLER_IN
76      IF ((IWHANDLER_IN .LE. 0) .AND.
77     &   (INODE .NE. INODE_WAITED_FOR)) THEN
78        INFO_TMP=0
79        CALL MUMPS_FDBD_SAVE_DESCBAND(INODE, BUFR(1), BUFR,
80     &                                IWHANDLER_LOC, INFO_TMP)
81        IF (INFO_TMP(1) < 0) THEN
82          IFLAG = INFO_TMP(1)
83          IERROR = INFO_TMP(2)
84          RETURN
85        ENDIF
86        GOTO 555
87      ENDIF
88#endif
89      IF ( KEEP(50) .eq. 0 ) THEN
90         FLOP1 = dble( NASS * NROW ) +
91     &     dble(NROW*NASS)*dble(2*NCOL-NASS-1)
92      ELSE
93         FLOP1 = dble( NASS ) * dble( NROW )
94     &            * dble( 2 * NCOL - NROW - NASS + 1)
95      END IF
96      CALL ZMUMPS_LOAD_UPDATE(1,.TRUE.,FLOP1, KEEP,KEEP8)
97      IF ( KEEP(50) .eq. 0 ) THEN
98        NSLAVES = NSLAVES_RECU + XTRA_SLAVES_UNSYM
99      ELSE
100        NSLAVES = NSLAVES_RECU + XTRA_SLAVES_SYM
101      END IF
102      LREQ   = NROW + NCOL + 6 + NSLAVES + KEEP(IXSZ)
103      LREQCB = int(NCOL,8) * int(NROW,8)
104      CALL ZMUMPS_ALLOC_CB(.FALSE., 0_8, .FALSE.,.TRUE.,
105     &   MYID,N, KEEP, KEEP8, DKEEP, IW, LIW, A, LA,
106     &   LRLU, IPTRLU,IWPOS,IWPOSCB,
107     &   PTRIST,PTRAST, STEP, PIMASTER,PAMASTER,
108     &   LREQ, LREQCB, INODE, S_ACTIVE, .TRUE.,
109     &   COMP, LRLUS, IFLAG, IERROR
110     &     )
111      IF ( IFLAG .LT. 0 ) RETURN
112      PTRIST(STEP(INODE)) = IWPOSCB + 1
113      PTRAST(STEP(INODE)) = IPTRLU  + 1_8
114#     if ! defined(NO_FDM_DESCBAND)
115 555  CONTINUE
116#     endif
117#     if ! defined(NO_FDM_DESCBAND)
118        IF ((IWHANDLER_IN .LE. 0) .AND.
119     &     (INODE .NE. INODE_WAITED_FOR)) THEN
120          RETURN
121        ENDIF
122        IW(IWPOSCB+1+XXA) = IWHANDLER_LOC
123#     endif
124      IW( IWPOSCB + 1+KEEP(IXSZ) ) = NCOL
125      IW( IWPOSCB + 2+KEEP(IXSZ) ) = - NASS
126      IW( IWPOSCB + 3+KEEP(IXSZ) ) = NROW
127      IW( IWPOSCB + 4+KEEP(IXSZ) ) = 0
128      IW( IWPOSCB + 5+KEEP(IXSZ) ) = NASS
129      IW( IWPOSCB + 6+KEEP(IXSZ) ) = NSLAVES
130      IW( IWPOSCB + 7+KEEP(IXSZ)+NSLAVES :
131     &           IWPOSCB + 6+KEEP(IXSZ)+NSLAVES + NROW + NCOL )
132     &= BUFR( IBUFR + NSLAVES_RECU :
133     &        IBUFR + NSLAVES_RECU + NROW + NCOL - 1 )
134      IF ( KEEP(50) .eq. 0 ) THEN
135        IW( IWPOSCB + 7+KEEP(IXSZ) ) = S_ROOTBAND_INIT
136        IF (NSLAVES_RECU.GT.0) THEN
137          write(6,*) " Internal error in ZMUMPS_PROCESS_DESC_BANDE "
138          CALL MUMPS_ABORT()
139        ENDIF
140      ELSE
141        IW( IWPOSCB+7+KEEP(IXSZ) ) = huge(IW(IWPOSCB+7+KEEP(IXSZ)))
142        IW( IWPOSCB + 8+KEEP(IXSZ) ) = NFRONT
143        IW( IWPOSCB + 9+KEEP(IXSZ) ) = S_ROOTBAND_INIT
144        IW( IWPOSCB + 7+XTRA_SLAVES_SYM+KEEP(IXSZ):
145     &      IWPOSCB + 6+XTRA_SLAVES_SYM+KEEP(IXSZ)+NSLAVES_RECU ) =
146     &       BUFR( IBUFR: IBUFR - 1 + NSLAVES_RECU )
147      END IF
148      TNBPROCFILS(STEP( INODE )) = NBPROCFILS
149#     if ! defined(NO_XXNBPR)
150      IW(IWPOSCB+1+XXNBPR)=NBPROCFILS
151#     endif
152      IW(IWPOSCB+1+XXLR)=LRSTATUS
153      IF (NBPROCFILS .EQ. 0) THEN
154      ENDIF
155      RETURN
156      END SUBROUTINE ZMUMPS_PROCESS_DESC_BANDE
157      RECURSIVE SUBROUTINE ZMUMPS_TREAT_DESCBAND( INODE,
158     &    COMM_LOAD, ASS_IRECV,
159     &    BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC,
160     &    IWPOS, IWPOSCB, IPTRLU,
161     &    LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST,
162     &    PTLUST, PTRFAC,
163     &    PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP,
164     &    IFLAG, IERROR, COMM, NBPROCFILS,
165     &    IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF,
166     &
167     &    root, OPASSW, OPELIW, ITLOC, RHS_MUMPS,
168     &    FILS, PTRARW, PTRAIW,
169     &    INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE,
170     &    LPTRAR, NELT, FRTPTR, FRTELT,
171     &
172     &    ISTEP_TO_INIV2, TAB_POS_IN_PERE,
173     &    STACK_RIGHT_AUTHORIZED
174     &    , LRGROUPS
175     & )
176#     if ! defined(NO_FDM_DESCBAND)
177      USE MUMPS_FAC_DESCBAND_DATA_M
178#     endif
179      IMPLICIT NONE
180      INCLUDE 'zmumps_root.h'
181      INTEGER, INTENT(IN) :: INODE
182      TYPE (ZMUMPS_ROOT_STRUC) :: root
183      INTEGER KEEP(500), ICNTL(40)
184      INTEGER(8) KEEP8(150)
185      DOUBLE PRECISION       DKEEP(230)
186      INTEGER LBUFR, LBUFR_BYTES
187      INTEGER COMM_LOAD, ASS_IRECV
188      INTEGER BUFR( LBUFR )
189      INTEGER(8) :: LA, POSFAC, IPTRLU, LRLU, LRLUS
190      INTEGER IWPOS, IWPOSCB
191      INTEGER N, LIW
192      INTEGER IW( LIW )
193      COMPLEX(kind=8) A( LA )
194      INTEGER, intent(in) :: LRGROUPS(N)
195      INTEGER(8) :: PTRAST(KEEP(28))
196      INTEGER(8) :: PTRFAC(KEEP(28))
197      INTEGER(8) :: PAMASTER(KEEP(28))
198      INTEGER PTRIST( KEEP(28) ),
199     &        PTLUST(KEEP(28))
200      INTEGER STEP(N),
201     & PIMASTER(KEEP(28))
202      INTEGER COMP
203      INTEGER NSTK_S(KEEP(28)), PROCNODE_STEPS( KEEP(28) )
204      INTEGER NBPROCFILS( KEEP(28) )
205      INTEGER IFLAG, IERROR, COMM
206      INTEGER LPOOL, LEAF
207      INTEGER IPOOL( LPOOL )
208      INTEGER MYID, SLAVEF, NBFIN
209      DOUBLE PRECISION OPASSW, OPELIW
210      INTEGER NELT, LPTRAR
211      INTEGER FRTPTR( N+1 ), FRTELT( NELT )
212      INTEGER ITLOC( N + KEEP(253) ), FILS( N )
213      COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255))
214      INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR )
215      INTEGER ND( KEEP(28) ), FRERE( KEEP(28) )
216      INTEGER ISTEP_TO_INIV2(KEEP(71)),
217     &        TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56)))
218      COMPLEX(kind=8) DBLARR( KEEP8(26) )
219      INTEGER INTARR( KEEP8(27) )
220      LOGICAL, intent(in) :: STACK_RIGHT_AUTHORIZED
221      INCLUDE 'mpif.h'
222      INCLUDE 'mumps_tags.h'
223      INCLUDE 'mumps_headers.h'
224      LOGICAL :: BLOCKING, SET_IRECV, MESSAGE_RECEIVED
225      INTEGER :: STATUS(MPI_STATUS_SIZE)
226      INTEGER :: SRC_DESCBAND
227#if ! defined(NO_FDM_DESCBAND)
228      INTEGER :: IWHANDLER
229      TYPE(DESCBAND_STRUC_T), POINTER :: DESCBAND_STRUC
230#endif
231      INTEGER MUMPS_PROCNODE
232      EXTERNAL MUMPS_PROCNODE
233      SRC_DESCBAND = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)),
234     &           SLAVEF )
235#     if ! defined(NO_FDM_DESCBAND)
236      IF (MUMPS_FDBD_IS_DESCBAND_STORED( INODE, IWHANDLER )) THEN
237        CALL MUMPS_FDBD_RETRIEVE_DESCBAND(IWHANDLER, DESCBAND_STRUC)
238        CALL ZMUMPS_PROCESS_DESC_BANDE( MYID, DESCBAND_STRUC%BUFR(1),
239     &       DESCBAND_STRUC%LBUFR,
240     &       LBUFR_BYTES,
241     &       IWPOS, IWPOSCB,
242     &       IPTRLU, LRLU, LRLUS,
243     &       NBPROCFILS, N, IW, LIW, A, LA,
244     &       PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP,
245     &       KEEP, KEEP8, DKEEP, ITLOC, RHS_MUMPS, ISTEP_TO_INIV2,
246     &       IWHANDLER,
247     &       IFLAG, IERROR )
248        IF (IFLAG .LT. 0) GOTO 500
249        CALL MUMPS_FDBD_FREE_DESCBAND_STRUC(IW(PTRIST(STEP(INODE))+XXA))
250      ELSE
251        IF (INODE_WAITED_FOR.GT.0) THEN
252          WRITE(*,*) " Internal error 1 in ZMUMPS_TREAT_DESCBAND",
253     &    INODE, INODE_WAITED_FOR
254          CALL MUMPS_ABORT()
255        ENDIF
256        INODE_WAITED_FOR = INODE
257#     endif
258      DO WHILE (PTRIST(STEP(INODE)) .EQ. 0)
259        BLOCKING = .TRUE.
260        SET_IRECV = .FALSE.
261        MESSAGE_RECEIVED = .FALSE.
262        CALL ZMUMPS_TRY_RECVTREAT(COMM_LOAD,
263     &    ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED,
264     &    SRC_DESCBAND, MAITRE_DESC_BANDE,
265     &    STATUS,
266     &    BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC,
267     &    IWPOS, IWPOSCB, IPTRLU,
268     &    LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST,
269     &    PTLUST, PTRFAC,
270     &    PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP,
271     &    IFLAG, IERROR, COMM,
272     &    NBPROCFILS, IPOOL, LPOOL, LEAF,
273     &    NBFIN, MYID, SLAVEF,
274     &    root, OPASSW, OPELIW, ITLOC, RHS_MUMPS,
275     &    FILS, PTRARW, PTRAIW,
276     &    INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE,
277     &    LPTRAR, NELT, FRTPTR, FRTELT,
278     &    ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE.
279     &    , LRGROUPS
280     &    )
281        IF (IFLAG .LT. 0) THEN
282          RETURN
283        ENDIF
284      ENDDO
285#     if ! defined(NO_FDM_DESCBAND)
286        INODE_WAITED_FOR = -1
287      ENDIF
288#     endif
289      RETURN
290 500  CONTINUE
291      CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP )
292      RETURN
293      END SUBROUTINE ZMUMPS_TREAT_DESCBAND
294