File: zfac_process_root2slave.F

package info (click to toggle)
mumps 5.1.2-5
  • links: PTS, VCS
  • area: main
  • in suites: sid
  • size: 15,704 kB
  • sloc: fortran: 310,672; ansic: 12,364; xml: 521; makefile: 469
file content (307 lines) | stat: -rw-r--r-- 11,362 bytes parent folder | download | duplicates (2)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
C
C  This file is part of MUMPS 5.1.2, released
C  on Mon Oct  2 07:37:01 UTC 2017
C
C
C  Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria,
C  University of Bordeaux.
C
C  This version of MUMPS is provided to you free of charge. It is
C  released under the CeCILL-C license:
C  http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html
C
      SUBROUTINE ZMUMPS_PROCESS_ROOT2SLAVE( TOT_ROOT_SIZE,
     &    TOT_CONT_TO_RECV, root,
     &    BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC,
     &    IWPOS, IWPOSCB, IPTRLU,
     &    LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST,
     &    PTLUST, PTRFAC,
     &    PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP,
     &    IFLAG, IERROR, COMM, COMM_LOAD,
     &    NBPROCFILS,
     &    IPOOL, LPOOL, LEAF,
     &    NBFIN, MYID, SLAVEF,
     &
     &    OPASSW, OPELIW, ITLOC, RHS_MUMPS,
     &    FILS, PTRARW, PTRAIW,
     &    INTARR, DBLARR, ICNTL, KEEP, KEEP8, DKEEP, ND)
      USE ZMUMPS_LOAD
      USE ZMUMPS_OOC        
      IMPLICIT NONE
      INCLUDE 'mpif.h'
      INCLUDE 'zmumps_root.h'
      TYPE (ZMUMPS_ROOT_STRUC) :: root
      INTEGER KEEP(500), ICNTL(40)
      INTEGER(8) KEEP8(150)
      DOUBLE PRECISION DKEEP(230)
      INTEGER TOT_ROOT_SIZE, TOT_CONT_TO_RECV
      INTEGER LBUFR, LBUFR_BYTES
      INTEGER BUFR( LBUFR )
      INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA, POSFAC
      INTEGER(8) :: PTRFAC(KEEP(28)), PTRAST(KEEP(28))
      INTEGER(8) :: PAMASTER(KEEP(28))
      INTEGER IWPOS, IWPOSCB
      INTEGER N, LIW
      INTEGER IW( LIW )
      COMPLEX(kind=8) A( LA )
      INTEGER PTRIST(KEEP(28)), PTLUST(KEEP(28))
      INTEGER STEP(N), PIMASTER(KEEP(28))
      INTEGER COMP
      INTEGER NSTK_S( KEEP(28) ), PROCNODE_STEPS( KEEP(28) )
      INTEGER NBPROCFILS( KEEP(28) ), ND( KEEP(28) )
      INTEGER IFLAG, IERROR, COMM, COMM_LOAD
      INTEGER LPOOL, LEAF
      INTEGER IPOOL( LPOOL )
      INTEGER MYID, SLAVEF, NBFIN
      DOUBLE PRECISION OPASSW, OPELIW
      INTEGER ITLOC(N+KEEP(253)), FILS(N)
      INTEGER(8), INTENT(IN) :: PTRARW(N), PTRAIW(N)
      COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255))
      INTEGER INTARR(KEEP8(27))
      COMPLEX(kind=8) DBLARR(KEEP8(26))
      INTEGER ::  allocok
      COMPLEX(kind=8), DIMENSION(:,:), POINTER :: TMP
      INTEGER NEW_LOCAL_M, NEW_LOCAL_N
      INTEGER OLD_LOCAL_M, OLD_LOCAL_N
      INTEGER I, J
      INTEGER LREQI, IROOT
      INTEGER(8) :: LREQA
      INTEGER POSHEAD, IPOS_SON,IERR
      LOGICAL MASTER_OF_ROOT
      COMPLEX(kind=8) ZERO
      PARAMETER( ZERO = (0.0D0,0.0D0) )
      INCLUDE 'mumps_headers.h'
      INTEGER numroc, MUMPS_PROCNODE
      EXTERNAL numroc, MUMPS_PROCNODE
      IROOT = KEEP( 38 )
      root%TOT_ROOT_SIZE = TOT_ROOT_SIZE
      MASTER_OF_ROOT = ( MYID .EQ. 
     &                   MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IROOT)),
     &                   SLAVEF ) )
      NEW_LOCAL_M  = numroc( TOT_ROOT_SIZE, root%MBLOCK,
     &               root%MYROW, 0, root%NPROW )
      NEW_LOCAL_M  = max( 1, NEW_LOCAL_M )
      NEW_LOCAL_N  = numroc( TOT_ROOT_SIZE, root%NBLOCK,
     &               root%MYCOL, 0, root%NPCOL )
      IF ( PTRIST(STEP( IROOT )).GT.0) THEN
        OLD_LOCAL_N = -IW( PTRIST(STEP( IROOT )) + KEEP(IXSZ) )
        OLD_LOCAL_M =  IW( PTRIST(STEP( IROOT )) + 1  + KEEP(IXSZ))
      ELSE
        OLD_LOCAL_N = 0
        OLD_LOCAL_M = NEW_LOCAL_M
      ENDIF
      IF (KEEP(60) .NE. 0) THEN
        IF (root%yes) THEN
        IF ( NEW_LOCAL_M .NE. root%SCHUR_MLOC .OR.
     &       NEW_LOCAL_N .NE. root%SCHUR_NLOC ) THEN
          WRITE(*,*) "Internal error 1 in ZMUMPS_PROCESS_ROOT2SLAVE"
          CALL MUMPS_ABORT()
        ENDIF
        ENDIF
        PTLUST(STEP(IROOT)) = -4444
        PTRFAC(STEP(IROOT)) = -4445_8
        PTRIST(STEP(IROOT)) = 0
        IF ( MASTER_OF_ROOT ) THEN
          LREQI=6+2*TOT_ROOT_SIZE+KEEP(IXSZ)
          LREQA=0_8
          IF ( IWPOS + LREQI - 1. GT. IWPOSCB ) THEN
           CALL ZMUMPS_COMPRE_NEW( N, KEEP(28), IW, LIW, A, LA,
     &           LRLU, IPTRLU,
     &           IWPOS, IWPOSCB, PTRIST, PTRAST,
     &           STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS,
     &           KEEP(IXSZ),COMP,DKEEP(97),MYID )
           IF ( LRLU .NE. LRLUS ) THEN
                  WRITE(*,*) 'PB1 compress root2slave:LRLU,LRLUS=',
     &            LRLU, LRLUS
                  IFLAG = -9
                  CALL MUMPS_SET_IERROR(LREQA-LRLUS, IERROR)
                  GOTO 700
           END IF
          ENDIF
          IF ( IWPOS + LREQI - 1. GT. IWPOSCB ) THEN
            IFLAG = -8
            IERROR = IWPOS + LREQI - 1 - IWPOSCB
            GOTO 700
          ENDIF
          PTLUST(STEP(IROOT))= IWPOS
          IWPOS = IWPOS + LREQI
          POSHEAD = PTLUST( STEP(IROOT))
          IW( POSHEAD + XXI )=LREQI
          CALL MUMPS_STOREI8( LREQA, IW(POSHEAD + XXR))
          IW( POSHEAD + XXS )=-9999
          IW(POSHEAD+XXS+1:POSHEAD+KEEP(IXSZ)-1)=-99999
          IW( POSHEAD +KEEP(IXSZ)) = 0
          IW( POSHEAD + 1 +KEEP(IXSZ)) = -1
          IW( POSHEAD + 2 +KEEP(IXSZ)) = -1
          IW( POSHEAD + 4 +KEEP(IXSZ)) = STEP(IROOT)
          IW( POSHEAD + 5 +KEEP(IXSZ)) = 0
          IW( POSHEAD + 3 +KEEP(IXSZ)) = TOT_ROOT_SIZE
        ENDIF
        GOTO 100
      ENDIF
      IF ( MASTER_OF_ROOT ) THEN
        LREQI = 6 + 2 * TOT_ROOT_SIZE+KEEP(IXSZ)
      ELSE
        LREQI = 6+KEEP(IXSZ)
      END IF
      LREQA = int(NEW_LOCAL_M, 8) * int(NEW_LOCAL_N, 8)
      IF ( LRLU . LT. LREQA .OR.
     &     IWPOS + LREQI - 1. GT. IWPOSCB )THEN
           IF ( LRLUS .LT. LREQA ) THEN
             IFLAG  = -9
             CALL MUMPS_SET_IERROR(LREQA - LRLUS, IERROR)
             GOTO 700
           END IF
           CALL ZMUMPS_COMPRE_NEW( N, KEEP(28), IW, LIW, A, LA,
     &           LRLU, IPTRLU,
     &           IWPOS, IWPOSCB, PTRIST, PTRAST,
     &           STEP, PIMASTER, PAMASTER, KEEP(216), LRLUS,
     &           KEEP(IXSZ), COMP, DKEEP(97), MYID )
           IF ( LRLU .NE. LRLUS ) THEN
                  WRITE(*,*) 'PB2 compress root2slave:LRLU,LRLUS=',
     &            LRLU, LRLUS
                  IFLAG = -9
                  CALL MUMPS_SET_IERROR(LREQA - LRLUS, IERROR)
                  GOTO 700
           END IF
           IF ( IWPOS + LREQI - 1 .GT. IWPOSCB ) THEN
              IFLAG  = -8
              IERROR = IWPOS + LREQI - 1 - IWPOSCB
              GOTO 700
           END IF
      END IF
      PTLUST(STEP( IROOT )) = IWPOS
      IWPOS           = IWPOS + LREQI
      IF (LREQA.EQ.0_8) THEN
        PTRAST (STEP(IROOT)) = POSFAC
        PTRFAC (STEP(IROOT)) = POSFAC
      ELSE
        PTRAST (STEP(IROOT)) = POSFAC
        PTRFAC (STEP(IROOT)) = POSFAC
      ENDIF
      POSFAC           = POSFAC + LREQA
      LRLU   = LRLU  - LREQA
      LRLUS  = LRLUS - LREQA
      KEEP8(67) = min(KEEP8(67), LRLUS)
      KEEP8(70) = KEEP8(70) - LREQA
      KEEP8(68) = min(KEEP8(70), KEEP8(68))
      KEEP8(71) = KEEP8(71) - LREQA
      KEEP8(69) = min(KEEP8(71), KEEP8(69))
      CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE.,
     &          LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLUS)
      POSHEAD = PTLUST( STEP(IROOT))
      IW( POSHEAD + XXI )     = LREQI
      CALL MUMPS_STOREI8( LREQA, IW(POSHEAD + XXR))
      IW( POSHEAD + XXS ) = S_NOTFREE
      IW(POSHEAD+XXS+1:POSHEAD+KEEP(IXSZ)-1)=-99999
      IW( POSHEAD + KEEP(IXSZ) ) = 0
      IW( POSHEAD + 1 + KEEP(IXSZ) ) = NEW_LOCAL_N
      IW( POSHEAD + 2 + KEEP(IXSZ) ) = NEW_LOCAL_M
      IW( POSHEAD + 4 + KEEP(IXSZ) ) = STEP(IROOT)
      IW( POSHEAD + 5 + KEEP(IXSZ) ) = 0
      IF ( MASTER_OF_ROOT ) THEN
        IW( POSHEAD + 3 + KEEP(IXSZ) ) = TOT_ROOT_SIZE
      ELSE
        IW( POSHEAD + 3 + KEEP(IXSZ) ) = 0
      ENDIF
      IF ( PTRIST(STEP( IROOT )) .LE. 0 ) THEN
        PTRIST(STEP( IROOT ))            = 0
        PAMASTER(STEP( IROOT ))          = 0_8
        IF (LREQA.GT.0_8) A(PTRAST(STEP(IROOT)):
     &    PTRAST(STEP(IROOT))+LREQA-1_8) = ZERO
      ELSE
        OLD_LOCAL_N = -IW( PTRIST(STEP( IROOT )) + KEEP(IXSZ) )
        OLD_LOCAL_M =  IW( PTRIST(STEP( IROOT )) + 1  + KEEP(IXSZ))
        IF ( TOT_ROOT_SIZE .eq. root%ROOT_SIZE ) THEN
          IF ( LREQA .NE. int(OLD_LOCAL_M,8) * int(OLD_LOCAL_N,8) )
     &    THEN
             write(*,*) 'error 1 in PROCESS_ROOT2SLAVE',
     &       OLD_LOCAL_M, OLD_LOCAL_N
             CALL MUMPS_ABORT()
          END IF
          CALL ZMUMPS_COPYI8SIZE(LREQA,
     &                          A( PAMASTER(STEP(IROOT)) ),
     &                          A( PTRAST  (STEP(IROOT)) ) )
        ELSE
          CALL ZMUMPS_COPY_ROOT( A( PTRAST(STEP(IROOT))), 
     &        NEW_LOCAL_M,
     &        NEW_LOCAL_N, A( PAMASTER( STEP(IROOT)) ), OLD_LOCAL_M,
     &        OLD_LOCAL_N )
        END IF
        IF ( PTRIST( STEP( IROOT ) ) .GT. 0 ) THEN
           IPOS_SON= PTRIST( STEP(IROOT))
           CALL ZMUMPS_FREE_BLOCK_CB(.FALSE., MYID, N, IPOS_SON,
     &          PAMASTER(STEP(IROOT)),
     &          IW, LIW, LRLU, LRLUS, IPTRLU,
     &          IWPOSCB, LA, KEEP,KEEP8, .FALSE.
     &         )
           PTRIST(STEP( IROOT ))   = 0
           PAMASTER(STEP( IROOT )) = 0_8
        END IF
      END IF
       IF (NEW_LOCAL_M.GT.OLD_LOCAL_M) THEN
          TMP => root%RHS_ROOT
          NULLIFY(root%RHS_ROOT)
          ALLOCATE (root%RHS_ROOT(NEW_LOCAL_M, root%RHS_NLOC), 
     &                stat=allocok)
          IF ( allocok.GT.0) THEN
              IFLAG=-13
              IERROR = NEW_LOCAL_M*root%RHS_NLOC
              GOTO 700
          ENDIF
          DO J = 1, root%RHS_NLOC
            DO I = 1, OLD_LOCAL_M
              root%RHS_ROOT(I,J)=TMP(I,J)
            ENDDO
            DO I = OLD_LOCAL_M+1, NEW_LOCAL_M
              root%RHS_ROOT(I,J) = ZERO
            ENDDO
          ENDDO
          DEALLOCATE(TMP)
          NULLIFY(TMP) 
       ENDIF
 100  CONTINUE
      NBPROCFILS(STEP(IROOT))=NBPROCFILS(STEP(IROOT)) + TOT_CONT_TO_RECV
#if ! defined(NO_XXNBPR)
      KEEP(121) = KEEP(121) + TOT_CONT_TO_RECV
#endif
#if ! defined(NO_XXNBPR)
      CALL CHECK_EQUAL(NBPROCFILS(STEP(IROOT)), KEEP(121))
      IF ( KEEP(121) .eq. 0 ) THEN
#else
      IF ( NBPROCFILS(STEP(IROOT)) .eq. 0 ) THEN
#endif
         IF (KEEP(201).EQ.1) THEN 
            CALL ZMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR)
         ELSE IF (KEEP(201).EQ.2) THEN 
            CALL ZMUMPS_FORCE_WRITE_BUF(IERR)              
         ENDIF
        CALL ZMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, PROCNODE_STEPS,
     &       SLAVEF, KEEP(28), KEEP(76), KEEP(80), KEEP(47),
     &       STEP, IROOT + N )
        IF (KEEP(47) .GE. 3) THEN
           CALL ZMUMPS_LOAD_POOL_UPD_NEW_POOL(
     &          IPOOL, LPOOL, 
     &          PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD,
     &          MYID, STEP, N, ND, FILS )
        ENDIF
      END IF
      RETURN
 700  CONTINUE
      CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP )
      RETURN
      END SUBROUTINE ZMUMPS_PROCESS_ROOT2SLAVE
      SUBROUTINE ZMUMPS_COPY_ROOT
     &( NEW, M_NEW, N_NEW,OLD, M_OLD, N_OLD )
      INTEGER M_NEW, N_NEW, M_OLD, N_OLD
      COMPLEX(kind=8) NEW( M_NEW, N_NEW ), OLD( M_OLD, N_OLD )
      INTEGER J
      COMPLEX(kind=8) ZERO
      PARAMETER( ZERO = (0.0D0,0.0D0) )
      DO J = 1, N_OLD
        NEW( 1: M_OLD, J ) = OLD( 1: M_OLD, J )
        NEW( M_OLD + 1: M_NEW, J ) = ZERO
      END DO
      NEW( 1: M_NEW,N_OLD + 1: N_NEW ) = ZERO
      RETURN
      END SUBROUTINE ZMUMPS_COPY_ROOT