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_NODE( MYID,KEEP,KEEP8,DKEEP,
14     &           BUFR, LBUFR, LBUFR_BYTES,
15     &           IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS,
16     &           N, IW, LIW, A, LA,
17     &           PTRIST, PTRAST, STEP, PIMASTER, PAMASTER,
18     &           NSTK_S, COMP,
19     &           FPERE, FLAG, IFLAG, IERROR, COMM,
20     &           ITLOC, RHS_MUMPS )
21      IMPLICIT NONE
22      INCLUDE 'mpif.h'
23      INTEGER IERR
24      INTEGER MYID
25      INTEGER LBUFR, LBUFR_BYTES
26      INTEGER KEEP(500), BUFR( LBUFR )
27      INTEGER(8) KEEP8(150)
28      DOUBLE PRECISION DKEEP(230)
29      INTEGER(8) :: LA, IPTRLU, LRLU, LRLUS
30      INTEGER IWPOS, IWPOSCB
31      INTEGER N, LIW
32      INTEGER IW( LIW )
33      COMPLEX(kind=8) A( LA )
34      INTEGER(8) :: PTRAST  (KEEP(28))
35      INTEGER(8) :: PAMASTER(KEEP(28))
36      INTEGER PTRIST( KEEP(28) )
37      INTEGER STEP(N), PIMASTER(KEEP(28))
38      INTEGER COMP, FPERE
39      LOGICAL FLAG
40      INTEGER NSTK_S( KEEP(28) ), ITLOC( N + KEEP(253) )
41      COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255))
42      INTEGER IFLAG, IERROR, COMM
43      INTEGER POSITION, FINODE, FLCONT, LREQ
44      INTEGER(8) :: LREQCB
45      INTEGER(8) :: IPOS_NODE, ISHIFT_PACKET
46      INTEGER SIZE_PACKET
47      INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET
48      INCLUDE 'mumps_headers.h'
49      LOGICAL COMPRESSCB
50      FLAG = .FALSE.
51      POSITION = 0
52      CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION,
53     &                FINODE, 1, MPI_INTEGER,
54     &                COMM, IERR)
55      CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION,
56     &                FPERE, 1, MPI_INTEGER,
57     &                COMM, IERR)
58      CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION,
59     &                FLCONT, 1, MPI_INTEGER,
60     &                COMM, IERR)
61      CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION,
62     &                NBROWS_ALREADY_SENT, 1, MPI_INTEGER,
63     &                COMM, IERR)
64      CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION,
65     &                NBROWS_PACKET, 1, MPI_INTEGER,
66     &                COMM, IERR)
67      COMPRESSCB = (FLCONT.LT.0)
68      IF (COMPRESSCB) THEN
69        FLCONT   = -FLCONT
70        LREQCB  = (int(FLCONT,8) * int(FLCONT+1,8)) / 2_8
71      ELSE
72        LREQCB  = int(FLCONT,8) * int(FLCONT,8)
73      ENDIF
74      IF (NBROWS_ALREADY_SENT == 0) THEN
75        LREQ    = 2 * FLCONT + 6 + KEEP(IXSZ)
76        IF (IPTRLU.LT.0_8) WRITE(*,*) 'before alloc_cb:IPTRLU = ',IPTRLU
77        CALL ZMUMPS_ALLOC_CB( .FALSE., 0_8, .FALSE.,.FALSE.,
78     &  MYID,N, KEEP,KEEP8, DKEEP, IW, LIW, A, LA,
79     &  LRLU, IPTRLU,IWPOS,IWPOSCB,
80     &  PTRIST,PTRAST,STEP, PIMASTER, PAMASTER,
81     &  LREQ, LREQCB, FINODE, S_NOTFREE, .TRUE.,
82     &  COMP, LRLUS, IFLAG, IERROR
83     &     )
84        IF (IPTRLU.LT.0_8) WRITE(*,*) 'after alloc_cb:IPTRLU = ',IPTRLU
85        IF ( IFLAG .LT. 0 ) RETURN
86        PIMASTER(STEP( FINODE )) = IWPOSCB + 1
87        PAMASTER(STEP( FINODE )) = IPTRLU  + 1_8
88        IF (COMPRESSCB)  IW(IWPOSCB + 1 + XXS ) = S_CB1COMP
89        CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION,
90     &        IW(IWPOSCB + 1+KEEP(IXSZ)), LREQ-KEEP(IXSZ),
91     &        MPI_INTEGER, COMM, IERR)
92      ENDIF
93      IF (COMPRESSCB) THEN
94        ISHIFT_PACKET = int(NBROWS_ALREADY_SENT,8) *
95     &                  int(NBROWS_ALREADY_SENT+1,8) / 2_8
96        SIZE_PACKET = (NBROWS_PACKET * (NBROWS_PACKET+1))/2 +
97     &                 NBROWS_ALREADY_SENT * NBROWS_PACKET
98      ELSE
99        ISHIFT_PACKET = int(NBROWS_ALREADY_SENT,8) * int(FLCONT,8)
100        SIZE_PACKET = NBROWS_PACKET * FLCONT
101      ENDIF
102      IF (NBROWS_PACKET.NE.0) THEN
103        IF ( LREQCB .ne. 0_8 ) THEN
104        IPOS_NODE = PAMASTER(STEP(FINODE))-1_8
105        CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION,
106     &        A(IPOS_NODE + 1_8 + ISHIFT_PACKET),
107     &        SIZE_PACKET, MPI_DOUBLE_COMPLEX, COMM, IERR)
108        END IF
109      ENDIF
110      IF (NBROWS_ALREADY_SENT+NBROWS_PACKET == FLCONT) THEN
111        NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1
112        IF ( NSTK_S(STEP(FPERE)).EQ.0 ) THEN
113          FLAG = . TRUE.
114        END IF
115      ENDIF
116      RETURN
117      END SUBROUTINE ZMUMPS_PROCESS_NODE
118