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 SMUMPS_PROCESS_ROOT2SLAVE( TOT_ROOT_SIZE,
14     &    TOT_CONT_TO_RECV, root,
15     &    BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC,
16     &    IWPOS, IWPOSCB, IPTRLU,
17     &    LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST,
18     &    PTLUST, PTRFAC,
19     &    PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP,
20     &    IFLAG, IERROR, COMM, COMM_LOAD,
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      USE SMUMPS_LOAD
29      USE SMUMPS_OOC
30      IMPLICIT NONE
31      INCLUDE 'mpif.h'
32      INCLUDE 'smumps_root.h'
33      TYPE (SMUMPS_ROOT_STRUC) :: root
34      INTEGER KEEP(500), ICNTL(40)
35      INTEGER(8) KEEP8(150)
36      REAL DKEEP(230)
37      INTEGER TOT_ROOT_SIZE, TOT_CONT_TO_RECV
38      INTEGER LBUFR, LBUFR_BYTES
39      INTEGER BUFR( LBUFR )
40      INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA, POSFAC
41      INTEGER(8) :: PTRFAC(KEEP(28)), PTRAST(KEEP(28))
42      INTEGER(8) :: PAMASTER(KEEP(28))
43      INTEGER IWPOS, IWPOSCB
44      INTEGER N, LIW
45      INTEGER IW( LIW )
46      REAL A( LA )
47      INTEGER PTRIST(KEEP(28)), PTLUST(KEEP(28))
48      INTEGER STEP(N), PIMASTER(KEEP(28))
49      INTEGER COMP
50      INTEGER NSTK_S( KEEP(28) ), PROCNODE_STEPS( KEEP(28) )
51      INTEGER NBPROCFILS( KEEP(28) ), ND( KEEP(28) )
52      INTEGER IFLAG, IERROR, COMM, COMM_LOAD
53      INTEGER LPOOL, LEAF
54      INTEGER IPOOL( LPOOL )
55      INTEGER MYID, SLAVEF, NBFIN
56      DOUBLE PRECISION OPASSW, OPELIW
57      INTEGER ITLOC(N+KEEP(253)), FILS(N)
58      INTEGER(8), INTENT(IN) :: PTRARW(N), PTRAIW(N)
59      REAL :: RHS_MUMPS(KEEP(255))
60      INTEGER INTARR(KEEP8(27))
61      REAL DBLARR(KEEP8(26))
62      INTEGER ::  allocok
63      REAL, DIMENSION(:,:), POINTER :: TMP
64      INTEGER NEW_LOCAL_M, NEW_LOCAL_N
65      INTEGER OLD_LOCAL_M, OLD_LOCAL_N
66      INTEGER I, J
67      INTEGER LREQI, IROOT
68      INTEGER(8) :: LREQA
69      INTEGER POSHEAD, IPOS_SON,IERR
70      LOGICAL MASTER_OF_ROOT
71      REAL ZERO
72      PARAMETER( ZERO = 0.0E0 )
73      INCLUDE 'mumps_headers.h'
74      INTEGER numroc, MUMPS_PROCNODE
75      EXTERNAL numroc, MUMPS_PROCNODE
76      IROOT = KEEP( 38 )
77      root%TOT_ROOT_SIZE = TOT_ROOT_SIZE
78      MASTER_OF_ROOT = ( MYID .EQ.
79     &                   MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IROOT)),
80     &                   SLAVEF ) )
81      NEW_LOCAL_M  = numroc( TOT_ROOT_SIZE, root%MBLOCK,
82     &               root%MYROW, 0, root%NPROW )
83      NEW_LOCAL_M  = max( 1, NEW_LOCAL_M )
84      NEW_LOCAL_N  = numroc( TOT_ROOT_SIZE, root%NBLOCK,
85     &               root%MYCOL, 0, root%NPCOL )
86      IF ( PTRIST(STEP( IROOT )).GT.0) THEN
87        OLD_LOCAL_N = -IW( PTRIST(STEP( IROOT )) + KEEP(IXSZ) )
88        OLD_LOCAL_M =  IW( PTRIST(STEP( IROOT )) + 1  + KEEP(IXSZ))
89      ELSE
90        OLD_LOCAL_N = 0
91        OLD_LOCAL_M = NEW_LOCAL_M
92      ENDIF
93      IF (KEEP(60) .NE. 0) THEN
94        IF (root%yes) THEN
95        IF ( NEW_LOCAL_M .NE. root%SCHUR_MLOC .OR.
96     &       NEW_LOCAL_N .NE. root%SCHUR_NLOC ) THEN
97          WRITE(*,*) "Internal error 1 in SMUMPS_PROCESS_ROOT2SLAVE"
98          CALL MUMPS_ABORT()
99        ENDIF
100        ENDIF
101        PTLUST(STEP(IROOT)) = -4444
102        PTRFAC(STEP(IROOT)) = -4445_8
103        PTRIST(STEP(IROOT)) = 0
104        IF ( MASTER_OF_ROOT ) THEN
105          LREQI=6+2*TOT_ROOT_SIZE+KEEP(IXSZ)
106          LREQA=0_8
107          IF ( IWPOS + LREQI - 1. GT. IWPOSCB ) THEN
108           CALL SMUMPS_COMPRE_NEW( N, KEEP(28), IW, LIW, A, LA,
109     &           LRLU, IPTRLU,
110     &           IWPOS, IWPOSCB, PTRIST, PTRAST,
111     &           STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS,
112     &           KEEP(IXSZ),COMP,DKEEP(97),MYID )
113           IF ( LRLU .NE. LRLUS ) THEN
114                  WRITE(*,*) 'PB1 compress root2slave:LRLU,LRLUS=',
115     &            LRLU, LRLUS
116                  IFLAG = -9
117                  CALL MUMPS_SET_IERROR(LREQA-LRLUS, IERROR)
118                  GOTO 700
119           END IF
120          ENDIF
121          IF ( IWPOS + LREQI - 1. GT. IWPOSCB ) THEN
122            IFLAG = -8
123            IERROR = IWPOS + LREQI - 1 - IWPOSCB
124            GOTO 700
125          ENDIF
126          PTLUST(STEP(IROOT))= IWPOS
127          IWPOS = IWPOS + LREQI
128          POSHEAD = PTLUST( STEP(IROOT))
129          IW( POSHEAD + XXI )=LREQI
130          CALL MUMPS_STOREI8( LREQA, IW(POSHEAD + XXR))
131          IW( POSHEAD + XXS )=-9999
132          IW(POSHEAD+XXS+1:POSHEAD+KEEP(IXSZ)-1)=-99999
133          IW( POSHEAD +KEEP(IXSZ)) = 0
134          IW( POSHEAD + 1 +KEEP(IXSZ)) = -1
135          IW( POSHEAD + 2 +KEEP(IXSZ)) = -1
136          IW( POSHEAD + 4 +KEEP(IXSZ)) = STEP(IROOT)
137          IW( POSHEAD + 5 +KEEP(IXSZ)) = 0
138          IW( POSHEAD + 3 +KEEP(IXSZ)) = TOT_ROOT_SIZE
139        ENDIF
140        GOTO 100
141      ENDIF
142      IF ( MASTER_OF_ROOT ) THEN
143        LREQI = 6 + 2 * TOT_ROOT_SIZE+KEEP(IXSZ)
144      ELSE
145        LREQI = 6+KEEP(IXSZ)
146      END IF
147      LREQA = int(NEW_LOCAL_M, 8) * int(NEW_LOCAL_N, 8)
148      IF ( LRLU . LT. LREQA .OR.
149     &     IWPOS + LREQI - 1. GT. IWPOSCB )THEN
150           IF ( LRLUS .LT. LREQA ) THEN
151             IFLAG  = -9
152             CALL MUMPS_SET_IERROR(LREQA - LRLUS, IERROR)
153             GOTO 700
154           END IF
155           CALL SMUMPS_COMPRE_NEW( N, KEEP(28), IW, LIW, A, LA,
156     &           LRLU, IPTRLU,
157     &           IWPOS, IWPOSCB, PTRIST, PTRAST,
158     &           STEP, PIMASTER, PAMASTER, KEEP(216), LRLUS,
159     &           KEEP(IXSZ), COMP, DKEEP(97), MYID )
160           IF ( LRLU .NE. LRLUS ) THEN
161                  WRITE(*,*) 'PB2 compress root2slave:LRLU,LRLUS=',
162     &            LRLU, LRLUS
163                  IFLAG = -9
164                  CALL MUMPS_SET_IERROR(LREQA - LRLUS, IERROR)
165                  GOTO 700
166           END IF
167           IF ( IWPOS + LREQI - 1 .GT. IWPOSCB ) THEN
168              IFLAG  = -8
169              IERROR = IWPOS + LREQI - 1 - IWPOSCB
170              GOTO 700
171           END IF
172      END IF
173      PTLUST(STEP( IROOT )) = IWPOS
174      IWPOS           = IWPOS + LREQI
175      IF (LREQA.EQ.0_8) THEN
176        PTRAST (STEP(IROOT)) = POSFAC
177        PTRFAC (STEP(IROOT)) = POSFAC
178      ELSE
179        PTRAST (STEP(IROOT)) = POSFAC
180        PTRFAC (STEP(IROOT)) = POSFAC
181      ENDIF
182      POSFAC           = POSFAC + LREQA
183      LRLU   = LRLU  - LREQA
184      LRLUS  = LRLUS - LREQA
185      KEEP8(67) = min(KEEP8(67), LRLUS)
186      KEEP8(70) = KEEP8(70) - LREQA
187      KEEP8(68) = min(KEEP8(70), KEEP8(68))
188      KEEP8(71) = KEEP8(71) - LREQA
189      KEEP8(69) = min(KEEP8(71), KEEP8(69))
190      CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE.,
191     &          LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLUS)
192      POSHEAD = PTLUST( STEP(IROOT))
193      IW( POSHEAD + XXI )     = LREQI
194      CALL MUMPS_STOREI8( LREQA, IW(POSHEAD + XXR))
195      IW( POSHEAD + XXS ) = S_NOTFREE
196      IW(POSHEAD+XXS+1:POSHEAD+KEEP(IXSZ)-1)=-99999
197      IW( POSHEAD + KEEP(IXSZ) ) = 0
198      IW( POSHEAD + 1 + KEEP(IXSZ) ) = NEW_LOCAL_N
199      IW( POSHEAD + 2 + KEEP(IXSZ) ) = NEW_LOCAL_M
200      IW( POSHEAD + 4 + KEEP(IXSZ) ) = STEP(IROOT)
201      IW( POSHEAD + 5 + KEEP(IXSZ) ) = 0
202      IF ( MASTER_OF_ROOT ) THEN
203        IW( POSHEAD + 3 + KEEP(IXSZ) ) = TOT_ROOT_SIZE
204      ELSE
205        IW( POSHEAD + 3 + KEEP(IXSZ) ) = 0
206      ENDIF
207      IF ( PTRIST(STEP( IROOT )) .LE. 0 ) THEN
208        PTRIST(STEP( IROOT ))            = 0
209        PAMASTER(STEP( IROOT ))          = 0_8
210        IF (LREQA.GT.0_8) A(PTRAST(STEP(IROOT)):
211     &    PTRAST(STEP(IROOT))+LREQA-1_8) = ZERO
212      ELSE
213        OLD_LOCAL_N = -IW( PTRIST(STEP( IROOT )) + KEEP(IXSZ) )
214        OLD_LOCAL_M =  IW( PTRIST(STEP( IROOT )) + 1  + KEEP(IXSZ))
215        IF ( TOT_ROOT_SIZE .eq. root%ROOT_SIZE ) THEN
216          IF ( LREQA .NE. int(OLD_LOCAL_M,8) * int(OLD_LOCAL_N,8) )
217     &    THEN
218             write(*,*) 'error 1 in PROCESS_ROOT2SLAVE',
219     &       OLD_LOCAL_M, OLD_LOCAL_N
220             CALL MUMPS_ABORT()
221          END IF
222          CALL SMUMPS_COPYI8SIZE(LREQA,
223     &                          A( PAMASTER(STEP(IROOT)) ),
224     &                          A( PTRAST  (STEP(IROOT)) ) )
225        ELSE
226          CALL SMUMPS_COPY_ROOT( A( PTRAST(STEP(IROOT))),
227     &        NEW_LOCAL_M,
228     &        NEW_LOCAL_N, A( PAMASTER( STEP(IROOT)) ), OLD_LOCAL_M,
229     &        OLD_LOCAL_N )
230        END IF
231        IF ( PTRIST( STEP( IROOT ) ) .GT. 0 ) THEN
232           IPOS_SON= PTRIST( STEP(IROOT))
233           CALL SMUMPS_FREE_BLOCK_CB(.FALSE., MYID, N, IPOS_SON,
234     &          PAMASTER(STEP(IROOT)),
235     &          IW, LIW, LRLU, LRLUS, IPTRLU,
236     &          IWPOSCB, LA, KEEP,KEEP8, .FALSE.
237     &         )
238           PTRIST(STEP( IROOT ))   = 0
239           PAMASTER(STEP( IROOT )) = 0_8
240        END IF
241      END IF
242       IF (NEW_LOCAL_M.GT.OLD_LOCAL_M) THEN
243          TMP => root%RHS_ROOT
244          NULLIFY(root%RHS_ROOT)
245          ALLOCATE (root%RHS_ROOT(NEW_LOCAL_M, root%RHS_NLOC),
246     &                stat=allocok)
247          IF ( allocok.GT.0) THEN
248              IFLAG=-13
249              IERROR = NEW_LOCAL_M*root%RHS_NLOC
250              GOTO 700
251          ENDIF
252          DO J = 1, root%RHS_NLOC
253            DO I = 1, OLD_LOCAL_M
254              root%RHS_ROOT(I,J)=TMP(I,J)
255            ENDDO
256            DO I = OLD_LOCAL_M+1, NEW_LOCAL_M
257              root%RHS_ROOT(I,J) = ZERO
258            ENDDO
259          ENDDO
260          DEALLOCATE(TMP)
261          NULLIFY(TMP)
262       ENDIF
263 100  CONTINUE
264      NBPROCFILS(STEP(IROOT))=NBPROCFILS(STEP(IROOT)) + TOT_CONT_TO_RECV
265#if ! defined(NO_XXNBPR)
266      KEEP(121) = KEEP(121) + TOT_CONT_TO_RECV
267#endif
268#if ! defined(NO_XXNBPR)
269      CALL CHECK_EQUAL(NBPROCFILS(STEP(IROOT)), KEEP(121))
270      IF ( KEEP(121) .eq. 0 ) THEN
271#else
272      IF ( NBPROCFILS(STEP(IROOT)) .eq. 0 ) THEN
273#endif
274         IF (KEEP(201).EQ.1) THEN
275            CALL SMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR)
276         ELSE IF (KEEP(201).EQ.2) THEN
277            CALL SMUMPS_FORCE_WRITE_BUF(IERR)
278         ENDIF
279        CALL SMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, PROCNODE_STEPS,
280     &       SLAVEF, KEEP(28), KEEP(76), KEEP(80), KEEP(47),
281     &       STEP, IROOT + N )
282        IF (KEEP(47) .GE. 3) THEN
283           CALL SMUMPS_LOAD_POOL_UPD_NEW_POOL(
284     &          IPOOL, LPOOL,
285     &          PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD,
286     &          MYID, STEP, N, ND, FILS )
287        ENDIF
288      END IF
289      RETURN
290 700  CONTINUE
291      CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP )
292      RETURN
293      END SUBROUTINE SMUMPS_PROCESS_ROOT2SLAVE
294      SUBROUTINE SMUMPS_COPY_ROOT
295     &( NEW, M_NEW, N_NEW,OLD, M_OLD, N_OLD )
296      INTEGER M_NEW, N_NEW, M_OLD, N_OLD
297      REAL NEW( M_NEW, N_NEW ), OLD( M_OLD, N_OLD )
298      INTEGER J
299      REAL ZERO
300      PARAMETER( ZERO = 0.0E0 )
301      DO J = 1, N_OLD
302        NEW( 1: M_OLD, J ) = OLD( 1: M_OLD, J )
303        NEW( M_OLD + 1: M_NEW, J ) = ZERO
304      END DO
305      NEW( 1: M_NEW,N_OLD + 1: N_NEW ) = ZERO
306      RETURN
307      END SUBROUTINE SMUMPS_COPY_ROOT
308