144
146 IMPLICIT NONE
147 INTEGER, INTENT(in) :: STRATEGY
148 INTEGER(8), INTENT(in) :: SIZER_NEEDED
149 LOGICAL, INTENT(in) :: SKIP_TOP_STACK
150 INTEGER, INTENT(in) :: N, SLAVEF, KEEP(500)
151 INTEGER, INTENT(in) :: MYID
152 INTEGER(8), INTENT(inout) :: KEEP8(150)
153 INTEGER :: IWPOS, IWPOSCB, LIW
154 INTEGER, INTENT(inout) :: IW( LIW )
155 INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS
156 COMPLEX, INTENT(in) :: A( LA )
157 INTEGER, INTENT(in) :: STEP(N)
158 INTEGER(8), INTENT(inout) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28))
159 INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28))
160 INTEGER, INTENT(inout) :: IFLAG, IERROR
161 include 'mumps_headers.h'
162 INTEGER :: ICURRENT, INODE, TYPEINODE, CB_STATE
163 INTEGER(8) :: RCURRENT, RCURRENT_SIZE, SIZEHOLE
164 INTEGER(8) :: KEEP8TMPCOPY
165 LOGICAL :: MOVE2DYNAMIC
166 LOGICAL :: SSARBRDAD
167 INTEGER(8) :: TMP_ADDRESS, ITMP8
168 INTEGER(8) :: I8
169 COMPLEX, DIMENSION(:), POINTER :: DYNAMIC_CB
170 LOGICAL :: IS_PAMASTER, IS_PTRAST
171 INTEGER :: allocok
172
173
174
175 LOGICAL :: IFLAG_M13_OCCURED, IFLAG_M19_OCCURED
176 INTEGER(8) :: MIN_SIZE_M13, MIN_SIZE_M19
177 INTEGER, EXTERNAL :: MUMPS_TYPENODE
178 IF ( strategy .EQ. 0 ) THEN
179 IF (lrlus.LT.sizer_needed) THEN
180 iflag = -9
182 ENDIF
183 RETURN
184 ENDIF
185 iflag_m13_occured = .false.
186 min_size_m13 = huge(min_size_m13)
187 iflag_m19_occured = .false.
188 min_size_m19 = huge(min_size_m19)
189
190 icurrent = iwposcb + 1
191 rcurrent = iptrlu + 1
192 IF (strategy.EQ.1 .AND. sizer_needed.LE.lrlus) GOTO 500
193 IF (( keep8(73) + sizer_needed-lrlus).GT.
194 & keep8(75)) THEN
195 iflag = -19
197 & (keep8(73) + sizer_needed-lrlus-keep8(75), ierror)
198 GOTO 500
199 ENDIF
200 DO WHILE (icurrent .NE. liw-keep(ixsz)+1)
201 inode = iw(icurrent+xxn)
202 cb_state = iw(icurrent+xxs)
204 CALL cmumps_dm_pamasterorptrast( n, slavef,
myid, keep(28),
205 & keep(199), inode, cb_state,
206 & iw(icurrent+xxd:icurrent+xxd+1),
207 & step, dad, procnode_steps,
208 & rcurrent, pamaster, ptrast,
209 & is_pamaster, is_ptrast )
210 IF ( cb_state .NE. s_free .AND.
211 & .NOT. cmumps_dm_is_dynamic(iw(icurrent+xxd)) ) THEN
213 & keep(199))
214 IF (strategy .EQ. -1) THEN
215 move2dynamic = .false.
216 move2dynamic = move2dynamic .OR.
217 & cb_state .EQ. s_nolcbcontig .OR.
218 & cb_state .EQ. s_nolcbnocontig .OR.
219 & cb_state .EQ. s_nolcleaned .OR.
220 & cb_state .EQ. s_all .OR.
221 & cb_state .EQ. s_active
222 ELSE IF (strategy .EQ. 2 .OR. strategy .EQ. 3) THEN
223 move2dynamic = .true.
224 move2dynamic = move2dynamic .AND. (typeinode.NE.3)
225 ELSE IF (strategy .EQ. 1) THEN
226 move2dynamic = .false.
227 IF (lrlus.GT.sizer_needed) GOTO 500
228 IF (typeinode.EQ.3) GOTO 100
229 move2dynamic = move2dynamic.OR..true.
230 ELSE
231 WRITE(*,*) "Internal error in CMUMPS_DM_CBSTATIC2DYNAMIC",
232 & move2dynamic
234 ENDIF
235 move2dynamic = move2dynamic .AND. (rcurrent_size .NE. 0_8)
236 move2dynamic = move2dynamic .AND.
237 & .NOT. ((icurrent.EQ.iwposcb + 1).AND.(skip_top_stack))
238 IF (strategy .NE. 3) THEN
239 IF ( keep(405) .EQ. 1 ) THEN
240
241 keep8tmpcopy = keep8(73)
242
243 ELSE
244 keep8tmpcopy = keep8(73)
245 ENDIF
246 IF ( rcurrent_size + keep8tmpcopy .GT. keep8(75) ) THEN
247 iflag_m19_occured= .true.
248 min_size_m19 =
min( min_size_m19,
249 & rcurrent_size+keep8(73)-keep8(75) )
250 move2dynamic = .false.
251 ENDIF
252 ENDIF
253 IF ( move2dynamic ) THEN
254#if defined(MUMPS_ALLOC_FROM_C)
255 CALL mumps_malloc_c( tmp_address,
256 & rcurrent_size * keep(35) )
257 IF (tmp_address .EQ. 0_8) THEN
258 allocok=1
259 ELSE
260 allocok=0
261 ENDIF
262#else
263 ALLOCATE(dynamic_cb(rcurrent_size), stat=allocok)
264#endif
265 IF (allocok .GT. 0) THEN
266 IF ( (strategy .NE. 1).OR.
267 & (sizer_needed-lrlus).GE.rcurrent_size) THEN
268 iflag = -13
270 GOTO 500
271 ENDIF
272 iflag_m13_occured = .true.
273 min_size_m13 =
min(min_size_m13, rcurrent_size)
274 GOTO 100
275 ENDIF
276 sizehole=0_8
277 IF (keep(216).NE.3) THEN
279 & liw-icurrent+1, sizehole, keep(ixsz))
280 ENDIF
282#if defined(MUMPS_ALLOC_FROM_C)
283 CALL cmumps_dm_set_ptr( tmp_address, rcurrent_size,
284 & dynamic_cb )
285#else
286 CALL mumps_addr_c(dynamic_cb(1), tmp_address)
287#endif
288 IF (is_ptrast) THEN
289 ptrast(step(inode)) = tmp_address
290 ELSE IF (is_pamaster) THEN
291 pamaster(step(inode)) = tmp_address
292 ELSE
293 WRITE(*,*)
294 & "Internal error 3 in CMUMPS_DM_CBSTATIC2DYNAMIC",
295 & rcurrent, ptrast(step(inode)), pamaster(step(inode))
297 ENDIF
298 itmp8 = (rcurrent_size-sizehole)
299 lrlus = lrlus + itmp8
300 IF (keep(405).EQ.1) THEN
301 IF (sizehole .NE. 0_8) THEN
302
303 keep8(69) = keep8(69) + sizehole
304 keep8tmpcopy = keep8(69)
305
306
307 keep8(68) =
max( keep8(68), keep8tmpcopy )
308
309 ENDIF
310 ELSE
311 keep8(69) = keep8(69) + sizehole
312 keep8(68) =
max( keep8(68), keep8(69) )
313 ENDIF
315 & dad, n, keep(28),
316 & step, procnode_steps, keep(199))
318 & la - lrlus, 0_8, -(rcurrent_size-sizehole),
319 & keep, keep8, lrlus)
320 IF (icurrent .EQ. iwposcb+1) THEN
321 iptrlu = iptrlu + rcurrent_size
322 lrlu = lrlu + rcurrent_size
324 ENDIF
325 IF (strategy .NE. 3) THEN
327 & rcurrent_size, keep(405).EQ.1, keep8,
328 & iflag, ierror, .false., .false.)
329 IF (iflag.LT.0) GOTO 500
330 ENDIF
331
332
333
334
335
336
337
338 DO i8=1_8, rcurrent_size
339 dynamic_cb(i8) = a(rcurrent+i8-1_8)
340 ENDDO
341
342 ENDIF
343 ENDIF
344 100 CONTINUE
345 rcurrent = rcurrent + rcurrent_size
346 icurrent = icurrent + iw(icurrent+xxi)
347 END DO
348 IF (lrlus.LT.sizer_needed) THEN
349 IF (iflag_m19_occured) THEN
350 iflag = -19
352 ELSE IF (iflag_m13_occured) THEN
353 iflag = -13
355 ELSE
356 iflag = -9
358 ENDIF
359 ENDIF
360 500 CONTINUE
361 RETURN
subroutine cmumps_sizefreeinrec(iw, lrec, size_free, xsize)
integer, save, private myid
subroutine, public cmumps_load_mem_update(ssarbr, process_bande_arg, mem_value, new_lu, inc_mem_arg, keep, keep8, lrlus)