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 CMUMPS_SOL_R(N, A, LA, IW, LIW, WCB, LWCB,
14     &    NRHS,
15     &    PTRICB, IWCB, LIWCB,
16     &    RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD,
17     &    NE_STEPS, NA, LNA, STEP,
18     &    FRERE, DAD, FILS,
19     &    NSTK_S, IPOOL, LPOOL, PTRIST, PTRFAC, MYLEAF, INFO,
20     &    KEEP, KEEP8, DKEEP,
21     &    PROCNODE_STEPS,
22     &    SLAVEF, COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,
23     &    RHS_ROOT, LRHS_ROOT, MTYPE,
24     &
25     &    ISTEP_TO_INIV2, TAB_POS_IN_PERE
26     &    , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP
27     &    )
28      USE CMUMPS_OOC
29      IMPLICIT NONE
30      INTEGER MTYPE
31      INTEGER(8), INTENT(IN) :: LA, LWCB
32      INTEGER, INTENT(IN) :: N, LIW, LPOOL, LIWCB, LNA
33      INTEGER SLAVEF, MYLEAF, COMM, MYID
34      INTEGER INFO( 40 ), KEEP(500)
35      INTEGER(8) KEEP8(150)
36      REAL, INTENT(INOUT) :: DKEEP(230)
37      INTEGER PROCNODE_STEPS( KEEP(28) )
38      INTEGER NRHS
39      COMPLEX A( LA ), WCB( LWCB )
40      INTEGER(8), intent(in) :: LRHS_ROOT
41      COMPLEX RHS_ROOT( LRHS_ROOT )
42      INTEGER LBUFR, LBUFR_BYTES
43      INTEGER BUFR( LBUFR )
44      INTEGER NA( LNA ), NE_STEPS( KEEP(28) )
45      INTEGER STEP( N ), FRERE( KEEP(28) ), FILS( N ),
46     &        DAD( KEEP(28) )
47      INTEGER NSTK_S(KEEP(28)), IPOOL( LPOOL )
48      INTEGER PTRIST(KEEP(28))
49      INTEGER(8) :: PTRFAC(KEEP(28))
50      INTEGER PTRICB( KEEP(28) )
51      LOGICAL, intent(in) :: DO_NBSPARSE
52      INTEGER, intent(in) :: LRHS_BOUNDS
53      INTEGER, intent(in) :: RHS_BOUNDS(LRHS_BOUNDS)
54      INTEGER IW( LIW ), IWCB( LIWCB )
55      INTEGER ISTEP_TO_INIV2(KEEP(71)),
56     &        TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56)))
57      INTEGER, intent(in) ::  POSINRHSCOMP_FWD(N), LRHSCOMP
58#if defined(RHSCOMP_BYROWS)
59      COMPLEX, intent(inout) :: RHSCOMP(NRHS,LRHSCOMP)
60#else
61      COMPLEX, intent(inout) :: RHSCOMP(LRHSCOMP,NRHS)
62#endif
63      LOGICAL, intent(in) :: FROM_PP
64      INCLUDE 'mpif.h'
65      INCLUDE 'mumps_tags.h'
66      INTEGER MSGTAG, MSGSOU, DUMMY(1)
67      LOGICAL FLAG
68      INTEGER NBFIN, MYROOT
69      INTEGER POSIWCB
70      INTEGER(8) :: POSWCB, PLEFTWCB
71      INTEGER INODE
72      INTEGER I
73      INTEGER III, NBROOT,LEAF
74      LOGICAL BLOQ
75      EXTERNAL MUMPS_PROCNODE
76      INTEGER MUMPS_PROCNODE
77      DUMMY(1) = 1
78      KEEP(266)=0
79      POSIWCB = LIWCB
80      POSWCB  = LWCB
81      PLEFTWCB= 1_8
82      DO I = 1, KEEP(28)
83        NSTK_S(I)   = NE_STEPS(I)
84      ENDDO
85      PTRICB = 0
86      CALL MUMPS_INIT_POOL_DIST(N, LEAF, MYID,
87     &     SLAVEF, NA, LNA, KEEP,KEEP8, STEP,
88     &     PROCNODE_STEPS, IPOOL, LPOOL)
89      CALL MUMPS_INIT_NROOT_DIST(N, NBROOT, MYROOT, MYID,
90     &     SLAVEF, NA, LNA, KEEP, STEP,
91     &     PROCNODE_STEPS)
92      NBFIN = SLAVEF
93      IF ( MYROOT .EQ. 0 ) THEN
94        NBFIN = NBFIN - 1
95        CALL CMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID, COMM,
96     &       RACINE_SOLVE, SLAVEF, KEEP)
97        IF (NBFIN.EQ.0) GOTO 260
98      END IF
99      MYLEAF = LEAF - 1
100      III    = 1
101   50 CONTINUE
102      IF (SLAVEF .EQ. 1) THEN
103         CALL CMUMPS_GET_INODE_FROM_POOL
104     &        ( IPOOL(1), LPOOL, III, LEAF, INODE,
105     &          KEEP(208) )
106        GOTO 60
107      ENDIF
108      BLOQ = ( ( III .EQ. LEAF )
109     &     )
110      CALL CMUMPS_SOLVE_RECV_AND_TREAT( BLOQ, FLAG,
111     &     BUFR, LBUFR, LBUFR_BYTES,
112     &     MYID, SLAVEF, COMM,
113     &     N, NRHS, IPOOL, LPOOL, III, LEAF,
114     &     NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, PTRFAC,
115     &     IWCB, LIWCB,
116     &     WCB, LWCB, POSWCB,
117     &     PLEFTWCB, POSIWCB,
118     &     PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP,
119     &     PROCNODE_STEPS,
120     &     RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD
121     &     , FROM_PP )
122      IF ( INFO( 1 ) .LT. 0 .OR. NBFIN .EQ. 0 ) GOTO 260
123      IF (.not. FLAG) THEN
124         IF (III .NE. LEAF) THEN
125            CALL CMUMPS_GET_INODE_FROM_POOL
126     &           (IPOOL(1), LPOOL, III, LEAF, INODE,
127     &           KEEP(208) )
128            GOTO 60
129         ENDIF
130      ENDIF
131      GOTO 50
132 60   CONTINUE
133      CALL CMUMPS_SOLVE_NODE( INODE, BUFR, LBUFR, LBUFR_BYTES,
134     &        MSGTAG, MSGSOU, MYID, SLAVEF, COMM,  N,
135     &        IPOOL, LPOOL, III, LEAF, NBFIN, NSTK_S,
136     &        IWCB, LIWCB, WCB, LWCB, A, LA,
137     &        IW, LIW, NRHS,
138     &        POSWCB, PLEFTWCB, POSIWCB,
139     &        PTRICB, PTRIST, PTRFAC, PROCNODE_STEPS,
140     &        FILS, STEP, FRERE, DAD,
141     &        MYROOT, INFO, KEEP,KEEP8, DKEEP, RHS_ROOT, MTYPE,
142     &        RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD,
143     &        ISTEP_TO_INIV2, TAB_POS_IN_PERE
144     &        , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE
145     &     , FROM_PP )
146      IF ( INFO( 1 ) .LT. 0 .OR. NBFIN .EQ. 0 ) GOTO 260
147      GOTO 50
148  260 CONTINUE
149      CALL CMUMPS_CLEAN_PENDING(INFO(1), KEEP, BUFR, LBUFR,LBUFR_BYTES,
150     &     COMM, DUMMY(1),
151     &     SLAVEF, .TRUE., .FALSE.)
152      RETURN
153      END SUBROUTINE CMUMPS_SOL_R
154