OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
zfac_mem_compress_cb.F
Go to the documentation of this file.
1C
2C This file is part of MUMPS 5.5.1, released
3C on Tue Jul 12 13:17:24 UTC 2022
4C
5C
6C Copyright 1991-2022 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria,
7C Mumps Technologies, 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 (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and
12C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html)
13C
14 SUBROUTINE zmumps_sizefreeinrec(IW,LREC,SIZE_FREE,XSIZE)
15 IMPLICIT NONE
16 INTEGER, intent(in) :: LREC, XSIZE
17 INTEGER, intent(in) :: IW(LREC)
18 INTEGER(8), intent(out):: SIZE_FREE
19 INTEGER(8) :: SIZE_STA, SIZE_DYN
20 include 'mumps_headers.h'
21 CALL mumps_geti8( size_sta,iw(1+xxr) )
22 CALL mumps_geti8( size_dyn,iw(1+xxd) )
23 IF ( size_dyn .GT. 0) THEN
24 size_free = size_sta
25 ELSE IF (iw(1+xxs).EQ.s_nolcbcontig .OR.
26 & iw(1+xxs).EQ.s_nolcbnocontig) THEN
27 size_free=int(iw(1+xsize+2),8)*int(iw(1+xsize+3),8)
28 ELSE IF (iw(1+xxs).EQ.s_nolcbcontig38 .OR.
29 & iw(1+xxs).EQ.s_nolcbnocontig38) THEN
30 size_free=int(iw(1+xsize+2),8)*int(iw(1+xsize)+
31 & iw(1+xsize + 3) -
32 & ( iw(1+xsize + 4)
33 & - iw(1+xsize + 3) ), 8)
34 ELSE IF (iw(1+xxs).EQ.s_nolnocb) THEN
35 size_free = size_sta
36 ELSE
37 size_free=0_8
38 ENDIF
39 RETURN
40 END SUBROUTINE zmumps_sizefreeinrec
41 SUBROUTINE zmumps_can_record_be_compressed(
42 & RECORD_CAN_BE_COMPRESSED, IW, XSIZE, KEEP216)
43 IMPLICIT NONE
44 LOGICAL, INTENT(out) :: RECORD_CAN_BE_COMPRESSED
45 INTEGER, INTENT(in) :: XSIZE, KEEP216
46 INTEGER, INTENT(in) :: IW(XSIZE)
47 include 'mumps_headers.h'
48 INTEGER(8) :: SIZE_DYN, SIZE_STA
49 CALL mumps_geti8( size_sta, iw(1+xxr))
50 CALL mumps_geti8( size_dyn, iw(1+xxd))
51 IF (iw(1+xxs) .EQ. s_free) THEN
52 record_can_be_compressed = .true.
53 ELSE IF ( size_dyn .GT. 0_8 .AND. size_sta .GT. 0_8) THEN
54 record_can_be_compressed = .true.
55 ELSE IF ( iw(1+xxs) .EQ. s_nolnocb) THEN
56 record_can_be_compressed = .true.
57 ELSE
58 record_can_be_compressed =
59 & ( iw(1+xxs) .EQ. s_nolcbnocontig .OR.
60 & iw(1+xxs) .EQ. s_nolcbcontig .OR.
61 & iw(1+xxs) .EQ. s_nolcbnocontig38 .OR.
62 & iw(1+xxs) .EQ. s_nolcbcontig38 )
63 & .AND. keep216.NE.3
64 ENDIF
65 RETURN
66 END SUBROUTINE zmumps_can_record_be_compressed
67 SUBROUTINE zmumps_movetonextrecord
68 &(iw,liw,ixxp,icurrent,next, rcurrent,isize2shift)
69 IMPLICIT NONE
70 include 'mumps_headers.h'
71 INTEGER(8) :: RCURRENT
72 INTEGER LIW,IXXP,ICURRENT,NEXT,ISIZE2SHIFT
73 INTEGER IW(LIW)
74 INTEGER(8) :: RSIZE
75 icurrent=next
76 CALL mumps_geti8( rsize, iw(icurrent + xxr) )
77 rcurrent = rcurrent - rsize
78 next=iw(icurrent+xxp)
79 iw(ixxp)=icurrent+isize2shift
80 ixxp=icurrent+xxp
81 RETURN
82 END SUBROUTINE zmumps_movetonextrecord
83 SUBROUTINE zmumps_ishift(IW,LIW,BEG2SHIFT,END2SHIFT,ISIZE2SHIFT)
84 IMPLICIT NONE
85 INTEGER LIW, BEG2SHIFT, END2SHIFT, ISIZE2SHIFT
86 INTEGER IW(LIW)
87 INTEGER I
88 IF (isize2shift.GT.0) THEN
89 DO i=end2shift,beg2shift,-1
90 iw(i+isize2shift)=iw(i)
91 ENDDO
92 ELSE IF (isize2shift.LT.0) THEN
93 DO i=beg2shift,end2shift
94 iw(i+isize2shift)=iw(i)
95 ENDDO
96 ENDIF
97 RETURN
98 END SUBROUTINE zmumps_ishift
99 SUBROUTINE zmumps_rshift(A, LA, BEG2SHIFT, END2SHIFT, RSIZE2SHIFT)
100 IMPLICIT NONE
101 INTEGER(8) :: LA, BEG2SHIFT, END2SHIFT, RSIZE2SHIFT
102 COMPLEX(kind=8) A(LA)
103 INTEGER(8) :: I
104 IF (rsize2shift.GT.0_8) THEN
105 DO i=end2shift,beg2shift,-1_8
106 a(i+rsize2shift)=a(i)
107 ENDDO
108 ELSE IF (rsize2shift.LT.0_8) THEN
109 DO i=beg2shift,end2shift
110 a(i+rsize2shift)=a(i)
111 ENDDO
112 ENDIF
113 RETURN
114 END SUBROUTINE zmumps_rshift
115 SUBROUTINE zmumps_compre_new(N,KEEP,IW,LIW,A,LA,
116 & LRLU,IPTRLU,IWPOS,
117 & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER,
118 & LRLUS,XSIZE, COMP, ACC_TIME, MYID,
119 & SLAVEF, PROCNODE_STEPS, DAD)
120 USE zmumps_dynamic_memory_m, ONLY: zmumps_dm_pamasterorptrast
121 IMPLICIT NONE
122 INTEGER, INTENT(in) :: N, LIW, XSIZE
123 INTEGER, INTENT(in) :: KEEP(500)
124 INTEGER(8), INTENT(in) :: LA
125 INTEGER(8), INTENT(inout):: LRLU, IPTRLU, LRLUS
126 INTEGER, INTENT(inout) :: IWPOSCB
127 INTEGER :: IWPOS
128 INTEGER(8), INTENT(inout) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28))
129 INTEGER, INTENT(inout) :: IW(LIW),PTRIST(KEEP(28)),
130 & pimaster(keep(28))
131 INTEGER, INTENT(in) :: STEP(N), SLAVEF
132 INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28))
133 COMPLEX(kind=8), INTENT(inout) :: A(LA)
134 INTEGER, INTENT(inout) :: COMP
135 DOUBLE PRECISION, INTENT(inout) :: ACC_TIME
136 INTEGER, INTENT(in) :: MYID
137 include 'mumps_headers.h'
138 INTEGER ICURRENT, NEXT, STATE_NEXT
139 INTEGER(8) :: RCURRENT
140 INTEGER ISIZE2SHIFT
141 INTEGER(8) :: RSIZE2SHIFT
142 INTEGER IBEGCONTIG
143 INTEGER(8) :: RBEGCONTIG
144 INTEGER(8) :: RBEG2SHIFT, REND2SHIFT
145 INTEGER INODE
146 LOGICAL :: IS_PAMASTER, IS_PTRAST
147 INTEGER(8) :: FREE_IN_REC
148 INTEGER(8) :: RCURRENT_SIZE, DYN_SIZE
149 LOGICAL :: RECORD_CAN_BE_COMPRESSED
150 INTEGER IXXP
151 INTEGER, EXTERNAL :: MUMPS_TYPENODE
152 INTEGER, EXTERNAL :: MUMPS_PROCNODE
153 LOGICAL, EXTERNAL :: ZMUMPS_ISBAND
154 EXTERNAL mpi_wtime
155 DOUBLE PRECISION MPI_WTIME
156 DOUBLE PRECISION TIME_STRT, TIME_COMP
157 time_strt = mpi_wtime()
158 isize2shift=0
159 rsize2shift=0_8
160 icurrent = liw-xsize+1
161 rcurrent = la+1_8
162 ibegcontig = -999999
163 rbegcontig = -999999_8
164 next = iw(icurrent+xxp)
165 IF (next.EQ.top_of_stack) GOTO 120
166 comp=comp+1
167 state_next = iw(next+xxs)
168 ixxp = icurrent+xxp
169 10 CONTINUE
170 CALL zmumps_can_record_be_compressed(
171 & record_can_be_compressed,
172 & iw(next), xsize, keep(216))
173 IF ( .NOT. record_can_be_compressed ) THEN
174 CALL zmumps_movetonextrecord(iw,liw,
175 & ixxp, icurrent, next, rcurrent, isize2shift)
176 CALL mumps_geti8(dyn_size, iw(icurrent+xxd))
177 CALL mumps_geti8(rcurrent_size, iw(icurrent+xxr))
178 IF (ibegcontig < 0) THEN
179 ibegcontig=icurrent+iw(icurrent+xxi)-1
180 ENDIF
181 IF (rbegcontig < 0_8) THEN
182 rbegcontig=rcurrent+rcurrent_size-1_8
183 ENDIF
184 inode=iw(icurrent+xxn)
185 IF ( dyn_size .EQ. 0_8 ) THEN
186 IF (rsize2shift .NE. 0_8) THEN
187 CALL zmumps_dm_pamasterorptrast( n, slavef, myid,
188 & keep(28), keep(199),
189 & inode, iw(icurrent+xxs),
190 & iw(icurrent+xxd:icurrent+xxd+1), step,
191 & dad, procnode_steps, rcurrent, pamaster, ptrast,
192 & is_pamaster, is_ptrast )
193 IF (is_ptrast) THEN
194 ptrast(step(inode))=
195 & ptrast(step(inode))+rsize2shift
196 ELSE IF (is_pamaster) THEN
197 pamaster(step(inode))=
198 & pamaster(step(inode))+rsize2shift
199 ENDIF
200 ENDIF
201 ENDIF
202 IF (isize2shift .NE. 0) THEN
203 IF (ptrist(step(inode)).EQ.icurrent)
204 & ptrist(step(inode))=
205 & ptrist(step(inode))+isize2shift
206 IF (pimaster(step(inode)).EQ.icurrent)
207 & pimaster(step(inode))=
208 & pimaster(step(inode))+isize2shift
209 ENDIF
210 IF (next .NE. top_of_stack) THEN
211 state_next=iw(next+xxs)
212 GOTO 10
213 ENDIF
214 ENDIF
215 20 CONTINUE
216 IF (ibegcontig.NE.0 .AND. isize2shift .NE. 0) THEN
217 CALL zmumps_ishift(iw,liw,icurrent,ibegcontig,isize2shift)
218 IF (ixxp .LE.ibegcontig) THEN
219 ixxp=ixxp+isize2shift
220 ENDIF
221 ENDIF
222 ibegcontig=-9999
223 25 CONTINUE
224 IF (rbegcontig .GT.0_8 .AND. rsize2shift .NE. 0_8) THEN
225 CALL zmumps_rshift(a,la,rcurrent,rbegcontig,rsize2shift)
226 ENDIF
227 rbegcontig=-99999_8
228 30 CONTINUE
229 IF (next.EQ. top_of_stack) GOTO 100
230 CALL zmumps_can_record_be_compressed(
231 & record_can_be_compressed, iw(next), xsize, keep(216))
232 IF ( state_next .NE. s_free .AND.
233 & record_can_be_compressed ) THEN
234 IF (rbegcontig > 0_8) GOTO 25
235 CALL zmumps_movetonextrecord
236 & (iw,liw,ixxp,icurrent,next, rcurrent,isize2shift)
237 IF (ibegcontig < 0 ) THEN
238 ibegcontig=icurrent+iw(icurrent+xxi)-1
239 ENDIF
240 CALL zmumps_sizefreeinrec(iw(icurrent),
241 & liw-icurrent+1,
242 & free_in_rec,
243 & xsize)
244 CALL mumps_geti8(dyn_size, iw(icurrent+xxd))
245 IF (dyn_size .GT. 0_8) THEN
246 ELSE IF (state_next .EQ. s_nolcbnocontig) THEN
247 CALL zmumps_makecbcontig(a,la,rcurrent,
248 & iw(icurrent+xsize+2),
249 & iw(icurrent+xsize),
250 & iw(icurrent+xsize)+iw(icurrent+xsize+3), 0,
251 & iw(icurrent+xxs),rsize2shift)
252 iw(icurrent+xxs) = s_nolcleaned
253 ELSE IF (state_next .EQ. s_nolcbnocontig38) THEN
254 CALL zmumps_makecbcontig(a,la,rcurrent,
255 & iw(icurrent+xsize+2),
256 & iw(icurrent+xsize),
257 & iw(icurrent+xsize)+iw(icurrent+xsize+3),
258 & iw(icurrent+xsize+4)-iw(icurrent+xsize+3),
259 & iw(icurrent+xxs),rsize2shift)
260 iw(icurrent+xxs) = s_nolcleaned38
261 ELSE IF (state_next.EQ.s_nolnocb) THEN
262 iw(icurrent+xxs) = s_nolnocbcleaned
263 ELSE IF (state_next .EQ. s_nolcbcontig .OR.
264 & state_next .EQ. s_nolcbcontig38) THEN
265 IF (state_next .EQ. s_nolcbcontig) THEN
266 iw(icurrent+xxs) = s_nolcleaned
267 ELSE IF (state_next .EQ. s_nolcbcontig38) THEN
268 iw(icurrent+xxs) = s_nolcleaned38
269 ENDIF
270 IF (rsize2shift .GT.0_8) THEN
271 rbeg2shift = rcurrent + free_in_rec
272 CALL mumps_geti8(rcurrent_size, iw(icurrent+xxr))
273 rend2shift = rcurrent + rcurrent_size - 1_8
274 CALL zmumps_rshift(a, la,
275 & rbeg2shift, rend2shift,
276 & rsize2shift)
277 ENDIF
278 ELSE
279 WRITE(*,*) "Internal error 3 in ZMUMPS_COMPRE_NEW",
280 & state_next, dyn_size, free_in_rec
281 CALL mumps_abort()
282 ENDIF
283 inode = iw(icurrent+xxn)
284 IF ( dyn_size .GT. 0_8 ) THEN
285 IF (ptrist(step(inode)).EQ.icurrent)
286 & ptrist(step(inode))=
287 & ptrist(step(inode))+isize2shift
288 IF (pimaster(step(inode)).EQ.icurrent)
289 & pimaster(step(inode))=
290 & pimaster(step(inode))+isize2shift
291 ELSE IF (state_next .EQ. s_nolcbcontig .OR.
292 & state_next .EQ. s_nolcbnocontig .OR.
293 & state_next .EQ. s_nolcbcontig38 .OR.
294 & state_next .EQ. s_nolcbnocontig38 .OR.
295 & state_next .EQ. s_nolnocb ) THEN
296 IF (isize2shift.NE.0) THEN
297 ptrist(step(inode))=ptrist(step(inode))+isize2shift
298 ENDIF
299 ptrast(step(inode))=ptrast(step(inode))+rsize2shift+
300 & free_in_rec
301 ELSE
302 WRITE(*,*) "Internal error 4 in ZMUMPS_COMPRE_NEW",
303 & state_next
304 CALL mumps_abort()
305 ENDIF
306 CALL mumps_subtri8toarray(iw(icurrent+xxr),free_in_rec)
307 rsize2shift=rsize2shift+free_in_rec
308 rbegcontig=-9999_8
309 IF (next.EQ.top_of_stack) THEN
310 GOTO 20
311 ELSE
312 state_next=iw(next+xxs)
313 ENDIF
314 GOTO 30
315 ENDIF
316 IF (ibegcontig.GT.0) THEN
317 GOTO 20
318 ENDIF
319 40 CONTINUE
320 IF (state_next == s_free) THEN
321 icurrent = next
322 CALL mumps_geti8( rcurrent_size, iw(icurrent + xxr) )
323 isize2shift = isize2shift + iw(icurrent+xxi)
324 rsize2shift = rsize2shift + rcurrent_size
325 rcurrent = rcurrent - rcurrent_size
326 next=iw(icurrent+xxp)
327 IF (next.EQ.top_of_stack) THEN
328 WRITE(*,*) "Internal error 1 in ZMUMPS_COMPRE_NEW"
329 CALL mumps_abort()
330 ENDIF
331 state_next = iw(next+xxs)
332 GOTO 40
333 ENDIF
334 GOTO 10
335 100 CONTINUE
336 iwposcb = iwposcb + isize2shift
337 lrlu = lrlu + rsize2shift
338 iptrlu = iptrlu + rsize2shift
339 120 CONTINUE
340 time_comp = mpi_wtime() - time_strt
341 acc_time = acc_time + time_comp
342 RETURN
343 END SUBROUTINE zmumps_compre_new
344 SUBROUTINE zmumps_get_sizehole(IREC, IW, LIW,
345 & ISIZEHOLE, RSIZEHOLE)
346 IMPLICIT NONE
347 INTEGER, intent(in) :: IREC, LIW
348 INTEGER, intent(in) :: IW(LIW)
349 INTEGER, intent(out):: ISIZEHOLE
350 INTEGER(8), intent(out) :: RSIZEHOLE
351 INTEGER IRECLOC
352 INTEGER(8) :: RECLOC_SIZE
353 include 'mumps_headers.h'
354 isizehole=0
355 rsizehole=0_8
356 irecloc = irec + iw( irec+xxi )
357 10 CONTINUE
358 CALL mumps_geti8(recloc_size, iw(irecloc+xxr))
359 IF (iw(irecloc+xxs).EQ.s_free) THEN
360 isizehole=isizehole+iw(irecloc+xxi)
361 rsizehole=rsizehole+recloc_size
362 irecloc=irecloc+iw(irecloc+xxi)
363 GOTO 10
364 ENDIF
365 RETURN
366 END SUBROUTINE zmumps_get_sizehole
367 SUBROUTINE zmumps_makecbcontig(A, LA, RCURRENT,
368 & NROW, NCB, LD, NELIM, NODESTATE, ISHIFT)
369 IMPLICIT NONE
370 include 'mumps_headers.h'
371 INTEGER LD, NROW, NCB, NELIM, NODESTATE
372 INTEGER(8) :: ISHIFT
373 INTEGER(8) :: LA, RCURRENT
374 COMPLEX(kind=8) A(LA)
375 INTEGER I,J
376 INTEGER(8) :: IOLD,INEW
377 LOGICAL NELIM_ROOT
378 nelim_root=.true.
379 IF (nodestate.EQ. s_nolcbnocontig) THEN
380 nelim_root=.false.
381 IF (nelim.NE.0) THEN
382 WRITE(*,*) "Internal error 1 IN ZMUMPS_MAKECBCONTIG"
383 CALL mumps_abort()
384 ENDIF
385 ELSE IF (nodestate .NE. s_nolcbnocontig38) THEN
386 WRITE(*,*) "Internal error 2 in ZMUMPS_MAKECBCONTIG"
387 & ,nodestate
388 CALL mumps_abort()
389 ENDIF
390 IF (ishift .LT.0_8) THEN
391 WRITE(*,*) "Internal error 3 in ZMUMPS_MAKECBCONTIG",ishift
392 CALL mumps_abort()
393 ENDIF
394 IF (nelim_root) THEN
395 iold=rcurrent+int(ld,8)*int(nrow,8)+int(nelim-1-ncb,8)
396 ELSE
397 iold = rcurrent+int(ld,8)*int(nrow,8)-1_8
398 ENDIF
399 inew = rcurrent+int(ld,8)*int(nrow,8)+ishift-1_8
400 DO i = nrow, 1, -1
401 IF (i.EQ.nrow .AND. ishift.EQ.0_8.AND.
402 & .NOT. nelim_root) THEN
403 iold=iold-int(ld,8)
404 inew=inew-int(ncb,8)
405 cycle
406 ENDIF
407 IF (nelim_root) THEN
408 DO j=1,nelim
409 a( inew ) = a( iold + int(- j + 1,8))
410 inew = inew - 1_8
411 ENDDO
412 ELSE
413 DO j=1, ncb
414 a( inew ) = a( iold + int(- j + 1, 8))
415 inew = inew - 1_8
416 ENDDO
417 ENDIF
418 iold = iold - int(ld,8)
419 ENDDO
420 IF (nelim_root) THEN
421 nodestate=s_nolcbcontig38
422 ELSE
423 nodestate=s_nolcbcontig
424 ENDIF
425 RETURN
426 END SUBROUTINE zmumps_makecbcontig
427 SUBROUTINE zmumps_get_size_needed(
428 & SIZEI_NEEDED, SIZER_NEEDED, SKIP_TOP_STACK,
429 & KEEP, KEEP8,
430 & N,IW,LIW,A,LA,
431 & LRLU,IPTRLU,IWPOS,
432 & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER,
433 & LRLUS,XSIZE, COMP, ACC_TIME, MYID,
434 & SLAVEF, PROCNODE_STEPS, DAD,
435 & IFLAG, IERROR
436 & )
437#if ! defined(NODYNAMICCB)
438 USE zmumps_dynamic_memory_m, ONLY: zmumps_dm_cbstatic2dynamic
439#endif
440 IMPLICIT NONE
441 INTEGER, INTENT(in) :: SIZEI_NEEDED
442 INTEGER(8), INTENT(in) :: SIZER_NEEDED
443 LOGICAL, INTENT(in) :: SKIP_TOP_STACK
444 INTEGER, INTENT(in) :: KEEP(500)
445 INTEGER(8), INTENT(inout):: KEEP8(150)
446 INTEGER, INTENT(in) :: N, LIW, XSIZE
447 INTEGER(8), INTENT(in) :: LA
448 INTEGER(8), INTENT(inout):: LRLU, IPTRLU, LRLUS
449 INTEGER, INTENT(inout) :: IWPOSCB
450 INTEGER, INTENT(inout) :: IWPOS
451 INTEGER(8), INTENT(inout) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28))
452 INTEGER, INTENT(inout) :: IW(LIW),PTRIST(KEEP(28)),
453 & PIMASTER(KEEP(28))
454 INTEGER, INTENT(in) :: STEP(N), SLAVEF
455 INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28))
456 COMPLEX(kind=8), INTENT(inout) :: A(LA)
457 INTEGER, INTENT(inout) :: COMP
458 DOUBLE PRECISION, INTENT(inout) :: ACC_TIME
459 INTEGER, INTENT(iN) :: MYID
460 INTEGER, INTENT(inout) :: IFLAG, IERROR
461 LOGICAL ZMUMPS_COMPRE_NEW_CALLED
462 zmumps_compre_new_called = .false.
463 IF (iwposcb-iwpos+1 .LT. sizei_needed) THEN
464 CALL zmumps_compre_new(n,keep,iw,liw,a,la,
465 & lrlu,iptrlu,iwpos,
466 & iwposcb,ptrist,ptrast,step,pimaster,pamaster,
467 & lrlus,xsize, comp, acc_time, myid,
468 & slavef, procnode_steps, dad)
469 IF ( lrlu .NE. lrlus ) THEN
470 WRITE(*,*) 'Internal error 1 in ZMUMPS_GET_SIZE_NEEDED ',
471 & 'PB compress... ZMUMPS_ALLOC_CB ',
472 & 'LRLU,LRLUS=',lrlu,lrlus
473 iflag = -9
474 GOTO 500
475 END IF
476 zmumps_compre_new_called = .true.
477 IF (iwposcb-iwpos+1 .LT. sizei_needed) THEN
478 iflag = -8
479 ierror = sizei_needed
480 GOTO 500
481 ENDIF
482 ENDIF
483 IF ( .NOT.zmumps_compre_new_called.AND.
484 & (lrlu.LT.sizer_needed).AND.
485 & (lrlus.GE.sizer_needed).AND.
486 & (lrlu.NE.lrlus)
487 & ) THEN
488 CALL zmumps_compre_new(n,keep,iw,liw,a,la,
489 & lrlu,iptrlu,iwpos,
490 & iwposcb,ptrist,ptrast,step,pimaster,pamaster,
491 & lrlus,xsize, comp, acc_time, myid,
492 & slavef, procnode_steps, dad)
493 zmumps_compre_new_called = .true.
494 IF ( lrlu .NE. lrlus ) THEN
495 WRITE(*,*) 'Internal error 2 ',
496 & 'in ZMUMPS_GET_SIZE_NEEDED ',
497 & 'PB compress... ZMUMPS_ALLOC_CB ',
498 & 'LRLU,LRLUS=',lrlu,lrlus
499 iflag = -9
500 GOTO 500
501 END IF
502 ENDIF
503 IF (lrlus.LT.sizer_needed) THEN
504#if ! defined(NODYNAMICCB)
505 IF (.NOT. zmumps_compre_new_called) THEN
506 CALL zmumps_compre_new(n,keep,iw,liw,a,la,
507 & lrlu,iptrlu,iwpos,
508 & iwposcb,ptrist,ptrast,step,pimaster,pamaster,
509 & lrlus,xsize, comp, acc_time, myid,
510 & slavef, procnode_steps, dad)
511 IF ( lrlu .NE. lrlus ) THEN
512 WRITE(*,*) 'Internal error 2 ',
513 & 'in ZMUMPS_GET_SIZE_NEEDED ',
514 & 'PB compress... ZMUMPS_ALLOC_CB ',
515 & 'LRLU,LRLUS=',lrlu,lrlus
516 iflag = -9
517 GOTO 500
518 END IF
519 ENDIF
520 CALL zmumps_dm_cbstatic2dynamic(keep(141),
521 & sizer_needed, skip_top_stack,
522 & myid, n, slavef,
523 & keep, keep8,
524 & iw, liw, iwposcb, iwpos,
525 & a, la, lrlu, iptrlu, lrlus,
526 & step, ptrast, pamaster,
527 & procnode_steps, dad, iflag, ierror)
528 IF (iflag.LT.0) GOTO 500
529 IF (lrlu.LT.sizer_needed) THEN
530 CALL zmumps_compre_new(n,keep,iw,liw,a,la,
531 & lrlu,iptrlu,iwpos,
532 & iwposcb,ptrist,ptrast,step,pimaster,pamaster,
533 & lrlus,xsize, comp, acc_time, myid,
534 & slavef, procnode_steps, dad)
535 IF ( lrlu .NE. lrlus ) THEN
536 WRITE(*,*) 'Internal error 4 ',
537 & 'in ZMUMPS_GET_SIZE_NEEDED ',
538 & 'PB compress... ZMUMPS_ALLOC_CB ',
539 & 'LRLU,LRLUS=',lrlu,lrlus
540 iflag = -9
541 GOTO 500
542 END IF
543 ENDIF
544#else
545 iflag = -9
546 CALL mumps_set_ierror(sizer_needed-lrlus, ierror)
547 GOTO 500
548#endif
549 ENDIF
550500 CONTINUE
551 RETURN
552 END SUBROUTINE zmumps_get_size_needed
mumps_abort
#define mumps_abort
Definition VE_Metis.h:25
mpi_wtime
double precision function mpi_wtime()
Definition mpi.f:561
zmumps_dynamic_memory_m
Definition zfac_mem_dynamic.F:14
zmumps_dynamic_memory_m::zmumps_dm_cbstatic2dynamic
subroutine zmumps_dm_cbstatic2dynamic(strategy, sizer_needed, skip_top_stack, myid, n, slavef, keep, keep8, iw, liw, iwposcb, iwpos, a, la, lrlu, iptrlu, lrlus, step, ptrast, pamaster, procnode_steps, dad, iflag, ierror)
Definition zfac_mem_dynamic.F:144
zmumps_dynamic_memory_m::zmumps_dm_pamasterorptrast
subroutine zmumps_dm_pamasterorptrast(n, slavef, myid, keep28, keep199, inode, cb_state, ixxd, step, dad, procnode_steps, rcurrent, pamaster, ptrast, is_pamaster, is_ptrast)
Definition zfac_mem_dynamic.F:46
mumps_subtri8toarray
subroutine mumps_subtri8toarray(int_array, i8)
Definition tools_common.F:913
mumps_set_ierror
subroutine mumps_set_ierror(size8, ierror)
Definition tools_common.F:865
mumps_geti8
subroutine mumps_geti8(i8, int_array)
Definition tools_common.F:888
zmumps_makecbcontig
subroutine zmumps_makecbcontig(a, la, rcurrent, nrow, ncb, ld, nelim, nodestate, ishift)
Definition zfac_mem_compress_cb.F:369
zmumps_movetonextrecord
subroutine zmumps_movetonextrecord(iw, liw, ixxp, icurrent, next, rcurrent, isize2shift)
Definition zfac_mem_compress_cb.F:69
zmumps_get_size_needed
subroutine zmumps_get_size_needed(sizei_needed, sizer_needed, skip_top_stack, keep, keep8, n, iw, liw, a, la, lrlu, iptrlu, iwpos, iwposcb, ptrist, ptrast, step, pimaster, pamaster, lrlus, xsize, comp, acc_time, myid, slavef, procnode_steps, dad, iflag, ierror)
Definition zfac_mem_compress_cb.F:437
zmumps_rshift
subroutine zmumps_rshift(a, la, beg2shift, end2shift, rsize2shift)
Definition zfac_mem_compress_cb.F:100
zmumps_get_sizehole
subroutine zmumps_get_sizehole(irec, iw, liw, isizehole, rsizehole)
Definition zfac_mem_compress_cb.F:346
zmumps_ishift
subroutine zmumps_ishift(iw, liw, beg2shift, end2shift, isize2shift)
Definition zfac_mem_compress_cb.F:84
zmumps_can_record_be_compressed
subroutine zmumps_can_record_be_compressed(record_can_be_compressed, iw, xsize, keep216)
Definition zfac_mem_compress_cb.F:43
zmumps_sizefreeinrec
subroutine zmumps_sizefreeinrec(iw, lrec, size_free, xsize)
Definition zfac_mem_compress_cb.F:15
zmumps_compre_new
subroutine zmumps_compre_new(n, keep, iw, liw, a, la, lrlu, iptrlu, iwpos, iwposcb, ptrist, ptrast, step, pimaster, pamaster, lrlus, xsize, comp, acc_time, myid, slavef, procnode_steps, dad)
Definition zfac_mem_compress_cb.F:120