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_LAST_RTNELIND( COMM_LOAD, ASS_IRECV,
14     &    root, FRERE, IROOT,
15     &    BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC,
16     &    IWPOS, IWPOSCB, IPTRLU,
17     &    LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST,
18     &    PTLUST_S, PTRFAC,
19     &    PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP,
20     &    IFLAG, IERROR, COMM,
21     &    NBPROCFILS,
22     &    IPOOL, LPOOL, LEAF,
23     &    NBFIN, MYID, SLAVEF,
24     &
25     &    OPASSW, OPELIW, ITLOC, RHS_MUMPS,
26     &    FILS, PTRARW, PTRAIW,
27     &    INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,
28     &    LPTRAR, NELT, FRTPTR, FRTELT,
29     &    ISTEP_TO_INIV2, TAB_POS_IN_PERE
30     &               , LRGROUPS
31     &     )
32      USE DMUMPS_BUF
33      IMPLICIT NONE
34      INCLUDE 'dmumps_root.h'
35      INCLUDE 'mpif.h'
36      TYPE (DMUMPS_ROOT_STRUC) :: root
37      INTEGER IROOT
38      INTEGER ICNTL( 40 ), KEEP( 500 )
39      INTEGER(8) KEEP8(150)
40      DOUBLE PRECISION    DKEEP(230)
41      INTEGER COMM_LOAD, ASS_IRECV
42      INTEGER LBUFR, LBUFR_BYTES
43      INTEGER BUFR( LBUFR )
44      INTEGER(8) :: POSFAC,IPTRLU, LRLU, LRLUS
45      INTEGER IWPOS, IWPOSCB
46      INTEGER(8) :: LA
47      INTEGER N, LIW
48      INTEGER IW( LIW )
49      DOUBLE PRECISION A( LA )
50      INTEGER, intent(in) :: LRGROUPS(N)
51      INTEGER(8) :: PTRAST(KEEP(28))
52      INTEGER(8) :: PTRFAC(KEEP(28))
53      INTEGER(8) :: PAMASTER(KEEP(28))
54      INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28))
55      INTEGER STEP(N), PIMASTER(KEEP(28))
56      INTEGER COMP
57      INTEGER NSTK_S( KEEP(28) ), PROCNODE_STEPS( KEEP(28) )
58      INTEGER NBPROCFILS( KEEP(28) )
59      INTEGER IFLAG, IERROR, COMM
60      INTEGER LPTRAR, NELT
61      INTEGER FRTPTR( N+1 ), FRTELT( NELT )
62      INTEGER LPOOL, LEAF
63      INTEGER IPOOL( LPOOL )
64      INTEGER MYID, SLAVEF, NBFIN
65      INTEGER ISTEP_TO_INIV2(KEEP(71)),
66     &        TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56)))
67      DOUBLE PRECISION OPASSW, OPELIW
68      INTEGER ITLOC( N+KEEP(253) ), FILS( N )
69      DOUBLE PRECISION :: RHS_MUMPS(KEEP(255))
70      INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR )
71      INTEGER ND(KEEP(28)), FRERE(KEEP(28))
72      DOUBLE PRECISION DBLARR( KEEP8(26) )
73      INTEGER INTARR( KEEP8(27) )
74      INTEGER I, NELIM, NB_CONTRI_GLOBAL, NUMORG,
75     &        NFRONT, IROW, JCOL, PDEST, HF, IOLDPS,
76     &        IN, DEB_ROW, ILOC_ROW, IFSON, ILOC_COL,
77     &        IPOS_SON, NELIM_SON, NSLAVES_SON, HS,
78     &        IROW_SON, ICOL_SON, ISLAVE, IERR,
79     &        NELIM_SENT, IPOS_STATREC, TYPE_SON
80      INTEGER MUMPS_PROCNODE
81      EXTERNAL MUMPS_PROCNODE
82      INCLUDE 'mumps_headers.h'
83      INCLUDE 'mumps_tags.h'
84      NB_CONTRI_GLOBAL = KEEP(41)
85      NUMORG    = root%ROOT_SIZE
86      NELIM     = KEEP(42)
87      NFRONT    = NUMORG + KEEP(42)
88      DO IROW = 0, root%NPROW - 1
89        DO JCOL = 0, root%NPCOL - 1
90            PDEST = IROW * root%NPCOL + JCOL
91          IF ( PDEST .NE. MYID ) THEN
92           CALL DMUMPS_BUF_SEND_ROOT2SLAVE(NFRONT,
93     &     NB_CONTRI_GLOBAL, PDEST, COMM, KEEP, IERR)
94              if (IERR.lt.0) then
95                write(6,*) ' error detected by ',
96     &          'DMUMPS_BUF_SEND_ROOT2SLAVE'
97                CALL MUMPS_ABORT()
98               endif
99           ENDIF
100        END DO
101      END DO
102      CALL  DMUMPS_PROCESS_ROOT2SLAVE( NFRONT,
103     &    NB_CONTRI_GLOBAL, root,
104     &    BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC,
105     &    IWPOS, IWPOSCB, IPTRLU,
106     &    LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST,
107     &    PTLUST_S, PTRFAC,
108     &    PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP,
109     &    IFLAG, IERROR, COMM, COMM_LOAD,
110     &    NBPROCFILS,
111     &    IPOOL, LPOOL, LEAF,
112     &    NBFIN, MYID, SLAVEF,
113     &
114     &    OPASSW, OPELIW, ITLOC, RHS_MUMPS,
115     &    FILS, PTRARW, PTRAIW,
116     &    INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND )
117       IF (IFLAG < 0 ) RETURN
118      HF = 6 + KEEP(IXSZ)
119      IOLDPS = PTLUST_S(STEP(IROOT))
120      IN = IROOT
121      DEB_ROW = IOLDPS + HF
122      ILOC_ROW    = DEB_ROW
123      DO WHILE (IN.GT.0)
124       IW(ILOC_ROW)           = IN
125       IW(ILOC_ROW+NFRONT)    = IN
126       ILOC_ROW = ILOC_ROW + 1
127       IN = FILS(IN)
128      END DO
129      IFSON = -IN
130      ILOC_ROW    = IOLDPS + HF + NUMORG
131      ILOC_COL    = ILOC_ROW + NFRONT
132      IF ( NELIM.GT.0 ) THEN
133        IN = IFSON
134        DO WHILE (IN.GT.0)
135          IPOS_SON  = PIMASTER(STEP(IN))
136          IF (IPOS_SON .EQ. 0) GOTO 100
137          NELIM_SON   = IW(IPOS_SON+1+KEEP(IXSZ))
138              if (NELIM_SON.eq.0) then
139                write(6,*) ' error 1 in process_last_rtnelind'
140                CALL MUMPS_ABORT()
141              endif
142          NSLAVES_SON = IW(IPOS_SON+5+KEEP(IXSZ))
143          HS          = 6 + NSLAVES_SON + KEEP(IXSZ)
144          IROW_SON    = IPOS_SON + HS
145          ICOL_SON    = IROW_SON + NELIM_SON
146          DO I = 1, NELIM_SON
147            IW( ILOC_ROW+I-1 ) = IW( IROW_SON+I-1 )
148          ENDDO
149          DO I = 1, NELIM_SON
150            IW( ILOC_COL+I-1 ) = IW( ICOL_SON+I-1 )
151          ENDDO
152          NELIM_SENT = ILOC_ROW - IOLDPS - HF + 1
153          DO ISLAVE = 0,NSLAVES_SON
154            IF (ISLAVE.EQ.0) THEN
155             PDEST= MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IN)),SLAVEF)
156            ELSE
157             PDEST = IW(IPOS_SON + 5 + ISLAVE+KEEP(IXSZ))
158            ENDIF
159            IF (PDEST.NE.MYID) THEN
160             CALL DMUMPS_BUF_SEND_ROOT2SON(IN, NELIM_SENT,
161     &        PDEST, COMM, KEEP, IERR )
162               if (IERR.lt.0) then
163                write(6,*) ' error detected by ',
164     &          'DMUMPS_BUF_SEND_ROOT2SLAVE'
165                CALL MUMPS_ABORT()
166               endif
167            ELSE
168             CALL DMUMPS_PROCESS_ROOT2SON( COMM_LOAD, ASS_IRECV,
169     &       IN, NELIM_SENT, root,
170     &
171     &       BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC,
172     &       IWPOS, IWPOSCB, IPTRLU,
173     &       LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST,
174     &       PTLUST_S, PTRFAC,
175     &       PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP,
176     &       IFLAG, IERROR, COMM,
177     &       NBPROCFILS,
178     &       IPOOL, LPOOL, LEAF,
179     &       NBFIN, MYID, SLAVEF,
180     &
181     &       OPASSW, OPELIW, ITLOC, RHS_MUMPS,
182     &       FILS, PTRARW, PTRAIW,
183     &       INTARR, DBLARR, ICNTL, KEEP, KEEP8, DKEEP, ND, FRERE,
184     &       LPTRAR, NELT, FRTPTR, FRTELT,
185     &       ISTEP_TO_INIV2, TAB_POS_IN_PERE
186     &               , LRGROUPS
187     &       )
188             IF ( ISLAVE .NE. 0 ) THEN
189               IF (KEEP(50) .EQ. 0) THEN
190                IPOS_STATREC = PTRIST(STEP(IN))+6+KEEP(IXSZ)
191               ELSE
192                IPOS_STATREC = PTRIST(STEP(IN))+8+KEEP(IXSZ)
193               ENDIF
194               IF (IW(IPOS_STATREC).EQ. S_REC_CONTSTATIC) THEN
195                  IW(IPOS_STATREC) = S_ROOT2SON_CALLED
196               ELSE
197                IF (NSLAVES_SON .EQ. 0) THEN
198                  TYPE_SON = 1
199                ELSE
200                  TYPE_SON = 2
201                ENDIF
202                CALL DMUMPS_FREE_BAND( N, IN, PTRIST, PTRAST,
203     &          IW, LIW, A, LA, LRLU, LRLUS, IWPOSCB,
204     &          IPTRLU, STEP, MYID, KEEP, KEEP8, TYPE_SON
205     &        )
206               ENDIF
207             ENDIF
208             IPOS_SON  = PIMASTER(STEP(IN))
209            ENDIF
210          END DO
211          CALL  DMUMPS_FREE_BLOCK_CB( .FALSE.,MYID,N, IPOS_SON,
212     &       PTRAST(STEP(IN)),
213     &       IW, LIW,
214     &       LRLU, LRLUS, IPTRLU,
215     &       IWPOSCB, LA, KEEP,KEEP8, .FALSE.
216     &         )
217          ILOC_ROW = ILOC_ROW + NELIM_SON
218          ILOC_COL = ILOC_COL + NELIM_SON
219 100      CONTINUE
220          IN = FRERE(STEP(IN))
221        ENDDO
222      ENDIF
223      RETURN
224      END SUBROUTINE DMUMPS_LAST_RTNELIND
225