OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
mumps_memory_mod.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 MODULE mumps_memory_mod
15 INTERFACE mumps_dealloc
16 MODULE PROCEDURE mumps_idealloc
17 END INTERFACE
18 INTERFACE mumps_realloc
19 MODULE PROCEDURE mumps_irealloc
20 MODULE PROCEDURE mumps_drealloc, mumps_srealloc, mumps_zrealloc
21 MODULE PROCEDURE mumps_crealloc
22 END INTERFACE
23 INTEGER(8), PRIVATE :: isize, i8size, ssize, dsize, csize, zsize
24 CONTAINS
25 SUBROUTINE mumps_memory_set_data_sizes()
26 INTEGER :: I(2)
27 INTEGER(8) :: I8(2)
28 REAL(kind(1.e0)) :: S(2)
29 REAL(kind(1.d0)) :: D(2)
30 COMPLEX(kind(1.e0)) :: C(2)
31 COMPLEX(kind(1.d0)) :: Z(2)
32 CALL mumps_size_c(i(1), i(2), isize)
33 CALL mumps_size_c(s(1), s(2), ssize)
34 CALL mumps_size_c(d(1), d(2), dsize)
35 CALL mumps_size_c(c(1), c(2), csize)
36 CALL mumps_size_c(z(1), z(2), zsize)
37 CALL mumps_size_c(i8(1), i8(2), i8size)
38 RETURN
39 END SUBROUTINE mumps_memory_set_data_sizes
40 SUBROUTINE mumps_irealloc(ARRAY, MINSIZE, INFO, LP, FORCE, COPY,
41 & STRING, MEMCNT, ERRCODE)
42 INTEGER, POINTER :: ARRAY(:)
43 INTEGER :: INFO(:)
44 INTEGER :: MINSIZE, LP
45 LOGICAL, OPTIONAL :: FORCE
46 LOGICAL, OPTIONAL :: COPY
47 CHARACTER, OPTIONAL :: STRING*(*)
48 INTEGER, OPTIONAL :: ERRCODE
49 INTEGER(8), OPTIONAL :: MEMCNT
50 LOGICAL :: ICOPY, IFORCE
51 INTEGER, POINTER :: TEMP(:)
52 INTEGER :: I, IERR, ERRTPL(2)
53 CHARACTER(len=60) :: FMTA, FMTD
54 IF(present(copy)) THEN
55 icopy = copy
56 ELSE
57 icopy = .false.
58 END IF
59 IF (present(force)) THEN
60 iforce = force
61 ELSE
62 iforce = .false.
63 END IF
64 IF (present(string)) THEN
65 fmta = "Allocation failed inside realloc: "//string
66 fmtd = "Deallocation failed inside realloc: "//string
67 ELSE
68 fmta = "Allocation failed inside realloc: "
69 fmtd = "Deallocation failed inside realloc: "
70 END IF
71 IF (present(errcode)) THEN
72 errtpl(1) = errcode
73 errtpl(2) = minsize
74 ELSE
75 errtpl(1) = -13
76 errtpl(2) = minsize
77 END IF
78 IF(icopy) THEN
79 IF(associated(array)) THEN
80 IF ((size(array) .LT. minsize) .OR.
81 & ((size(array).NE.minsize) .AND. iforce)) THEN
82 allocate(temp(minsize), stat=ierr)
83 IF(ierr .LT. 0) THEN
84 WRITE(lp,fmta)
85 info(1:2) = errtpl
86 RETURN
87 ELSE
88 IF(present(memcnt))memcnt = memcnt+
89 & int(minsize,8)*isize
90 END IF
91 DO i=1, min(size(array), minsize)
92 temp(i) = array(i)
93 END DO
94 IF(present(memcnt))memcnt = memcnt-
95 & int(size(array),8)*isize
96 deallocate(array, stat=ierr)
97 IF(ierr .LT. 0) THEN
98 WRITE(lp,fmtd)
99 info(1:2) = errtpl
100 RETURN
101 END IF
102 NULLIFY(array)
103 array => temp
104 NULLIFY(temp)
105 END IF
106 ELSE
107 WRITE(lp,
108 & '("Input array is not associated. nothing to copy here")')
109 RETURN
110 END IF
111 ELSE
112 IF(associated(array)) THEN
113 IF ((size(array) .LT. minsize) .OR.
114 & ((size(array).NE.minsize) .AND. iforce)) THEN
115 IF(present(memcnt))memcnt = memcnt-
116 & int(size(array),8)*isize
117 deallocate(array, stat=ierr)
118 IF(ierr .LT. 0) THEN
119 WRITE(lp,fmtd)
120 info(1:2) = errtpl
121 RETURN
122 END IF
123 ELSE
124 RETURN
125 END IF
126 END IF
127 allocate(array(minsize), stat=ierr)
128 IF(ierr .LT. 0) THEN
129 WRITE(lp,fmta)
130 info(1:2) = errtpl
131 RETURN
132 ELSE
133 IF(present(memcnt)) memcnt = memcnt+
134 & minsize*isize
135 END IF
136 END IF
137 RETURN
138 END SUBROUTINE mumps_irealloc
139 SUBROUTINE mumps_i8realloc(ARRAY, MINSIZE, INFO, LP, FORCE, COPY,
140 & STRING, MEMCNT, ERRCODE)
141 INTEGER(8), POINTER :: ARRAY(:)
142 INTEGER :: INFO(:)
143 INTEGER :: MINSIZE, LP
144 LOGICAL, OPTIONAL :: FORCE
145 LOGICAL, OPTIONAL :: COPY
146 CHARACTER, OPTIONAL :: STRING*(*)
147 INTEGER, OPTIONAL :: ERRCODE
148 INTEGER(8), OPTIONAL :: MEMCNT
149 LOGICAL :: ICOPY, IFORCE
150 INTEGER(8), POINTER :: TEMP(:)
151 INTEGER :: I, IERR, ERRTPL(2)
152 CHARACTER(len=60) :: FMTA, FMTD
153 IF(present(copy)) THEN
154 icopy = copy
155 ELSE
156 icopy = .false.
157 END IF
158 IF (present(force)) THEN
159 iforce = force
160 ELSE
161 iforce = .false.
162 END IF
163 IF (present(string)) THEN
164 fmta = "Allocation failed inside realloc: "//string
165 fmtd = "Deallocation failed inside realloc: "//string
166 ELSE
167 fmta = "Allocation failed inside realloc: "
168 fmtd = "Deallocation failed inside realloc: "
169 END IF
170 IF (present(errcode)) THEN
171 errtpl(1) = errcode
172 errtpl(2) = minsize
173 ELSE
174 errtpl(1) = -13
175 errtpl(2) = minsize
176 END IF
177 IF(icopy) THEN
178 IF(associated(array)) THEN
179 IF ((size(array) .LT. minsize) .OR.
180 & ((size(array).NE.minsize) .AND. iforce)) THEN
181 allocate(temp(minsize), stat=ierr)
182 IF(ierr .LT. 0) THEN
183 WRITE(lp,fmta)
184 info(1:2) = errtpl
185 RETURN
186 ELSE
187 IF(present(memcnt))memcnt = memcnt+
188 & int(minsize,8)*i8size
189 END IF
190 DO i=1, min(size(array), minsize)
191 temp(i) = array(i)
192 END DO
193 IF(present(memcnt))memcnt = memcnt-
194 & int(size(array),8)*i8size
195 deallocate(array, stat=ierr)
196 IF(ierr .LT. 0) THEN
197 WRITE(lp,fmtd)
198 info(1:2) = errtpl
199 RETURN
200 END IF
201 NULLIFY(array)
202 array => temp
203 NULLIFY(temp)
204 END IF
205 ELSE
206 WRITE(lp,
207 & '("Input array is not associated. nothing to copy here")')
208 RETURN
209 END IF
210 ELSE
211 IF(associated(array)) THEN
212 IF ((size(array) .LT. minsize) .OR.
213 & ((size(array).NE.minsize) .AND. iforce)) THEN
214 IF(present(memcnt))memcnt = memcnt-
215 & int(size(array),8)*i8size
216 deallocate(array, stat=ierr)
217 IF(ierr .LT. 0) THEN
218 WRITE(lp,fmtd)
219 info(1:2) = errtpl
220 RETURN
221 END IF
222 ELSE
223 RETURN
224 END IF
225 END IF
226 allocate(array(minsize), stat=ierr)
227 IF(ierr .LT. 0) THEN
228 WRITE(lp,fmta)
229 info(1:2) = errtpl
230 RETURN
231 ELSE
232 IF(present(memcnt)) memcnt = memcnt+
233 & int(minsize,8)*i8size
234 END IF
235 END IF
236 RETURN
237 END SUBROUTINE mumps_i8realloc
238 SUBROUTINE mumps_irealloc8(ARRAY, MINSIZE, INFO, LP, FORCE, COPY,
239 & STRING, MEMCNT, ERRCODE)
240 INTEGER, POINTER :: ARRAY(:)
241 INTEGER :: INFO(:)
242 INTEGER :: LP
243 INTEGER(8) :: MINSIZE
244 LOGICAL, OPTIONAL :: FORCE
245 LOGICAL, OPTIONAL :: COPY
246 CHARACTER, OPTIONAL :: STRING*(*)
247 INTEGER, OPTIONAL :: ERRCODE
248 INTEGER(8), OPTIONAL :: MEMCNT
249 LOGICAL :: ICOPY, IFORCE
250 INTEGER, POINTER :: TEMP(:)
251 INTEGER(8) :: I
252 INTEGER :: IERR, ERRTPL(2)
253 CHARACTER(len=60) :: FMTA, FMTD
254 IF(present(copy)) THEN
255 icopy = copy
256 ELSE
257 icopy = .false.
258 END IF
259 IF (present(force)) THEN
260 iforce = force
261 ELSE
262 iforce = .false.
263 END IF
264 IF (present(string)) THEN
265 fmta = "Allocation failed inside realloc: "//string
266 fmtd = "Deallocation failed inside realloc: "//string
267 ELSE
268 fmta = "Allocation failed inside realloc: "
269 fmtd = "Deallocation failed inside realloc: "
270 END IF
271 IF (present(errcode)) THEN
272 errtpl(1) = errcode
273 errtpl(2) = int(min(minsize,huge(i)))
274 ELSE
275 errtpl(1) = -13
276 errtpl(2) = int(min(minsize,huge(i)))
277 END IF
278 IF(icopy) THEN
279 IF(associated(array)) THEN
280 IF ((int(size(array),8) .LT. minsize) .OR.
281 & ((int(size(array),8).NE.minsize) .AND. iforce)) THEN
282 allocate(temp(minsize), stat=ierr)
283 IF(ierr .LT. 0) THEN
284 WRITE(lp,fmta)
285 info(1:2) = errtpl
286 RETURN
287 ELSE
288 IF(present(memcnt))memcnt = memcnt+minsize*isize
289 END IF
290 DO i=1, min(int(size(array),8), minsize)
291 temp(i) = array(i)
292 END DO
293 IF(present(memcnt))memcnt = memcnt-
294 & int(size(array),8)*isize
295 deallocate(array, stat=ierr)
296 IF(ierr .LT. 0) THEN
297 WRITE(lp,fmtd)
298 info(1:2) = errtpl
299 RETURN
300 END IF
301 NULLIFY(array)
302 array => temp
303 NULLIFY(temp)
304 END IF
305 ELSE
306 WRITE(lp,
307 & '("Input array is not associated. nothing to copy here")')
308 RETURN
309 END IF
310 ELSE
311 IF(associated(array)) THEN
312 IF ((int(size(array),8) .LT. minsize) .OR.
313 & ((int(size(array),8).NE.minsize) .AND. iforce)) THEN
314 IF(present(memcnt))memcnt = memcnt-
315 & int(size(array),8)*isize
316 deallocate(array, stat=ierr)
317 IF(ierr .LT. 0) THEN
318 WRITE(lp,fmtd)
319 info(1:2) = errtpl
320 RETURN
321 END IF
322 ELSE
323 RETURN
324 END IF
325 END IF
326 allocate(array(minsize), stat=ierr)
327 IF(ierr .LT. 0) THEN
328 WRITE(lp,fmta)
329 info(1:2) = errtpl
330 RETURN
331 ELSE
332 IF(present(memcnt)) memcnt = memcnt+minsize*isize
333 END IF
334 END IF
335 RETURN
336 END SUBROUTINE mumps_irealloc8
337 SUBROUTINE mumps_i8realloc8(ARRAY, MINSIZE, INFO, LP, FORCE, COPY,
338 & STRING, MEMCNT, ERRCODE)
339 INTEGER(8), POINTER :: ARRAY(:)
340 INTEGER :: INFO(:), LP
341 INTEGER(8) :: MINSIZE
342 LOGICAL, OPTIONAL :: FORCE
343 LOGICAL, OPTIONAL :: COPY
344 CHARACTER, OPTIONAL :: STRING*(*)
345 INTEGER, OPTIONAL :: ERRCODE
346 INTEGER(8), OPTIONAL :: MEMCNT
347 LOGICAL :: ICOPY, IFORCE
348 INTEGER(8), POINTER :: TEMP(:)
349 INTEGER :: IERR, ERRTPL(2)
350 CHARACTER(len=60) :: FMTA, FMTD
351 INTEGER(8) :: ASIZE, I
352 asize = int(size(array),8)
353 IF(present(copy)) THEN
354 icopy = copy
355 ELSE
356 icopy = .false.
357 END IF
358 IF (present(force)) THEN
359 iforce = force
360 ELSE
361 iforce = .false.
362 END IF
363 IF (present(string)) THEN
364 fmta = "Allocation failed inside realloc: "//string
365 fmtd = "Deallocation failed inside realloc: "//string
366 ELSE
367 fmta = "Allocation failed inside realloc: "
368 fmtd = "Deallocation failed inside realloc: "
369 END IF
370 IF (present(errcode)) THEN
371 errtpl(1) = errcode
372 errtpl(2) = int(minsize)
373 ELSE
374 errtpl(1) = -13
375 errtpl(2) = int(minsize)
376 END IF
377 IF(icopy) THEN
378 IF(associated(array)) THEN
379 IF ((asize .LT. minsize) .OR.
380 & ((asize.NE.minsize) .AND. iforce)) THEN
381 allocate(temp(minsize), stat=ierr)
382 IF(ierr .LT. 0) THEN
383 WRITE(lp,fmta)
384 info(1:2) = errtpl
385 RETURN
386 ELSE
387 IF(present(memcnt))memcnt = memcnt+
388 & int(minsize,8)*i8size
389 END IF
390 DO i=1, min(asize, minsize)
391 temp(i) = array(i)
392 END DO
393 IF(present(memcnt))memcnt = memcnt-
394 & asize*i8size
395 deallocate(array, stat=ierr)
396 IF(ierr .LT. 0) THEN
397 WRITE(lp,fmtd)
398 info(1:2) = errtpl
399 RETURN
400 END IF
401 NULLIFY(array)
402 array => temp
403 NULLIFY(temp)
404 END IF
405 ELSE
406 WRITE(lp,
407 & '("Input array is not associated. nothing to copy here")')
408 RETURN
409 END IF
410 ELSE
411 IF(associated(array)) THEN
412 IF ((asize .LT. minsize) .OR.
413 & ((asize.NE.minsize) .AND. iforce)) THEN
414 IF(present(memcnt))memcnt = memcnt-
415 & asize*i8size
416 deallocate(array, stat=ierr)
417 IF(ierr .LT. 0) THEN
418 WRITE(lp,fmtd)
419 info(1:2) = errtpl
420 RETURN
421 END IF
422 ELSE
423 RETURN
424 END IF
425 END IF
426 allocate(array(minsize), stat=ierr)
427 IF(ierr .LT. 0) THEN
428 WRITE(lp,fmta)
429 info(1:2) = errtpl
430 RETURN
431 ELSE
432 IF(present(memcnt)) memcnt = memcnt+
433 & int(minsize,8)*i8size
434 END IF
435 END IF
436 RETURN
437 END SUBROUTINE mumps_i8realloc8
438 SUBROUTINE mumps_srealloc(ARRAY, MINSIZE, INFO, LP, FORCE, COPY,
439 & STRING, MEMCNT, ERRCODE)
440 REAL(kind(1.E0)), POINTER :: ARRAY(:)
441 INTEGER :: INFO(:)
442 INTEGER :: MINSIZE, LP
443 LOGICAL, OPTIONAL :: FORCE
444 LOGICAL, OPTIONAL :: COPY
445 CHARACTER, OPTIONAL :: STRING*(*)
446 INTEGER, OPTIONAL :: ERRCODE
447 INTEGER(8), OPTIONAL :: MEMCNT
448 LOGICAL :: ICOPY, IFORCE
449 REAL(kind(1.E0)), POINTER :: TEMP(:)
450 INTEGER :: I, IERR, ERRTPL(2)
451 CHARACTER(len=60) :: FMTA, FMTD
452 IF(present(copy)) THEN
453 icopy = copy
454 ELSE
455 icopy = .false.
456 END IF
457 IF (present(force)) THEN
458 iforce = force
459 ELSE
460 iforce = .false.
461 END IF
462 IF (present(string)) THEN
463 fmta = "Allocation failed inside realloc: "//string
464 fmtd = "Deallocation failed inside realloc: "//string
465 ELSE
466 fmta = "Allocation failed inside realloc: "
467 fmtd = "Deallocation failed inside realloc: "
468 END IF
469 IF (present(errcode)) THEN
470 errtpl(1) = errcode
471 errtpl(2) = minsize
472 ELSE
473 errtpl(1) = -13
474 errtpl(2) = minsize
475 END IF
476 IF(icopy) THEN
477 IF(associated(array)) THEN
478 IF ((size(array) .LT. minsize) .OR.
479 & ((size(array).NE.minsize) .AND. iforce)) THEN
480 allocate(temp(minsize), stat=ierr)
481 IF(ierr .LT. 0) THEN
482 WRITE(lp,fmta)
483 info(1:2) = errtpl
484 RETURN
485 ELSE
486 IF(present(memcnt))memcnt = memcnt+
487 & int(minsize,8)*ssize
488 END IF
489 DO i=1, min(size(array), minsize)
490 temp(i) = array(i)
491 END DO
492 IF(present(memcnt))memcnt = memcnt-
493 & int(size(array),8)*ssize
494 deallocate(array, stat=ierr)
495 IF(ierr .LT. 0) THEN
496 WRITE(lp,fmtd)
497 info(1:2) = errtpl
498 RETURN
499 END IF
500 NULLIFY(array)
501 array => temp
502 NULLIFY(temp)
503 END IF
504 ELSE
505 WRITE(lp,
506 & '("Input array is not associated. nothing to copy here")')
507 RETURN
508 END IF
509 ELSE
510 IF(associated(array)) THEN
511 IF ((size(array) .LT. minsize) .OR.
512 & ((size(array).NE.minsize) .AND. iforce)) THEN
513 IF(present(memcnt))memcnt = memcnt-
514 & int(size(array),8)*ssize
515 deallocate(array, stat=ierr)
516 IF(ierr .LT. 0) THEN
517 WRITE(lp,fmtd)
518 info(1:2) = errtpl
519 RETURN
520 END IF
521 ELSE
522 RETURN
523 END IF
524 END IF
525 allocate(array(minsize), stat=ierr)
526 IF(ierr .LT. 0) THEN
527 WRITE(lp,fmta)
528 info(1:2) = errtpl
529 RETURN
530 ELSE
531 IF(present(memcnt)) memcnt = memcnt+minsize*ssize
532 END IF
533 END IF
534 RETURN
535 END SUBROUTINE mumps_srealloc
536 SUBROUTINE mumps_drealloc(ARRAY, MINSIZE, INFO, LP, FORCE, COPY,
537 & STRING, MEMCNT, ERRCODE)
538 REAL(kind(1.D0)), POINTER :: ARRAY(:)
539 INTEGER :: INFO(:)
540 INTEGER :: MINSIZE, LP
541 LOGICAL, OPTIONAL :: FORCE
542 LOGICAL, OPTIONAL :: COPY
543 CHARACTER, OPTIONAL :: STRING*(*)
544 INTEGER, OPTIONAL :: ERRCODE
545 INTEGER(8), OPTIONAL :: MEMCNT
546 LOGICAL :: ICOPY, IFORCE
547 REAL(kind(1.D0)), POINTER :: TEMP(:)
548 INTEGER :: I, IERR, ERRTPL(2)
549 CHARACTER(len=60) :: FMTA, FMTD
550 IF(present(copy)) THEN
551 icopy = copy
552 ELSE
553 icopy = .false.
554 END IF
555 IF (present(force)) THEN
556 iforce = force
557 ELSE
558 iforce = .false.
559 END IF
560 IF (present(string)) THEN
561 fmta = "Allocation failed inside realloc: "//string
562 fmtd = "Deallocation failed inside realloc: "//string
563 ELSE
564 fmta = "Allocation failed inside realloc: "
565 fmtd = "Deallocation failed inside realloc: "
566 END IF
567 IF (present(errcode)) THEN
568 errtpl(1) = errcode
569 errtpl(2) = minsize
570 ELSE
571 errtpl(1) = -13
572 errtpl(2) = minsize
573 END IF
574 IF(icopy) THEN
575 IF(associated(array)) THEN
576 IF ((size(array) .LT. minsize) .OR.
577 & ((size(array).NE.minsize) .AND. iforce)) THEN
578 allocate(temp(minsize), stat=ierr)
579 IF(ierr .LT. 0) THEN
580 WRITE(lp,fmta)
581 info(1:2) = errtpl
582 RETURN
583 ELSE
584 IF(present(memcnt))memcnt = memcnt+
585 & int(minsize,8)*dsize
586 END IF
587 DO i=1, min(size(array), minsize)
588 temp(i) = array(i)
589 END DO
590 IF(present(memcnt))memcnt = memcnt-
591 & int(size(array),8)*dsize
592 deallocate(array, stat=ierr)
593 IF(ierr .LT. 0) THEN
594 WRITE(lp,fmtd)
595 info(1:2) = errtpl
596 RETURN
597 END IF
598 NULLIFY(array)
599 array => temp
600 NULLIFY(temp)
601 END IF
602 ELSE
603 WRITE(lp,
604 & '("Input array is not associated. nothing to copy here")')
605 RETURN
606 END IF
607 ELSE
608 IF(associated(array)) THEN
609 IF ((size(array) .LT. minsize) .OR.
610 & ((size(array).NE.minsize) .AND. iforce)) THEN
611 IF(present(memcnt))memcnt = memcnt-
612 & int(size(array),8)*dsize
613 deallocate(array, stat=ierr)
614 IF(ierr .LT. 0) THEN
615 WRITE(lp,fmtd)
616 info(1:2) = errtpl
617 RETURN
618 END IF
619 ELSE
620 RETURN
621 END IF
622 END IF
623 allocate(array(minsize), stat=ierr)
624 IF(ierr .LT. 0) THEN
625 WRITE(lp,fmta)
626 info(1:2) = errtpl
627 RETURN
628 ELSE
629 IF(present(memcnt)) memcnt = memcnt+
630 & int(minsize,8)*dsize
631 END IF
632 END IF
633 RETURN
634 END SUBROUTINE mumps_drealloc
635 SUBROUTINE mumps_crealloc(ARRAY, MINSIZE, INFO, LP, FORCE, COPY,
636 & STRING, MEMCNT, ERRCODE)
637 COMPLEX(kind((1.E0,1.E0))), POINTER :: ARRAY(:)
638 INTEGER :: INFO(:)
639 INTEGER :: MINSIZE, LP
640 LOGICAL, OPTIONAL :: FORCE
641 LOGICAL, OPTIONAL :: COPY
642 CHARACTER, OPTIONAL :: STRING*(*)
643 INTEGER, OPTIONAL :: ERRCODE
644 INTEGER(8), OPTIONAL :: MEMCNT
645 LOGICAL :: ICOPY, IFORCE
646 COMPLEX(kind((1.E0,1.E0))), POINTER :: TEMP(:)
647 INTEGER :: I, IERR, ERRTPL(2)
648 CHARACTER(len=60) :: FMTA, FMTD
649 IF(present(copy)) THEN
650 icopy = copy
651 ELSE
652 icopy = .false.
653 END IF
654 IF (present(force)) THEN
655 iforce = force
656 ELSE
657 iforce = .false.
658 END IF
659 IF (present(string)) THEN
660 fmta = "Allocation failed inside realloc: "//string
661 fmtd = "Deallocation failed inside realloc: "//string
662 ELSE
663 fmta = "Allocation failed inside realloc: "
664 fmtd = "Deallocation failed inside realloc: "
665 END IF
666 IF (present(errcode)) THEN
667 errtpl(1) = errcode
668 errtpl(2) = minsize
669 ELSE
670 errtpl(1) = -13
671 errtpl(2) = minsize
672 END IF
673 IF(icopy) THEN
674 IF(associated(array)) THEN
675 IF ((size(array) .LT. minsize) .OR.
676 & ((size(array).NE.minsize) .AND. iforce)) THEN
677 allocate(temp(minsize), stat=ierr)
678 IF(ierr .LT. 0) THEN
679 WRITE(lp,fmta)
680 info(1:2) = errtpl
681 RETURN
682 ELSE
683 IF(present(memcnt))memcnt = memcnt+
684 & int(minsize,8)*csize
685 END IF
686 DO i=1, min(size(array), minsize)
687 temp(i) = array(i)
688 END DO
689 IF(present(memcnt))memcnt = memcnt-
690 & int(size(array),8)*csize
691 deallocate(array, stat=ierr)
692 IF(ierr .LT. 0) THEN
693 WRITE(lp,fmtd)
694 info(1:2) = errtpl
695 RETURN
696 END IF
697 NULLIFY(array)
698 array => temp
699 NULLIFY(temp)
700 END IF
701 ELSE
702 WRITE(lp,
703 & '("Input array is not associated. nothing to copy here")')
704 RETURN
705 END IF
706 ELSE
707 IF(associated(array)) THEN
708 IF ((size(array) .LT. minsize) .OR.
709 & ((size(array).NE.minsize) .AND. iforce)) THEN
710 IF(present(memcnt))memcnt = memcnt-
711 & int(size(array),8)*csize
712 deallocate(array, stat=ierr)
713 IF(ierr .LT. 0) THEN
714 WRITE(lp,fmtd)
715 info(1:2) = errtpl
716 RETURN
717 END IF
718 ELSE
719 RETURN
720 END IF
721 END IF
722 allocate(array(minsize), stat=ierr)
723 IF(ierr .LT. 0) THEN
724 WRITE(lp,fmta)
725 info(1:2) = errtpl
726 RETURN
727 ELSE
728 IF(present(memcnt)) memcnt = memcnt+
729 & int(minsize,8)*csize
730 END IF
731 END IF
732 RETURN
733 END SUBROUTINE mumps_crealloc
734 SUBROUTINE mumps_zrealloc(ARRAY, MINSIZE, INFO, LP, FORCE, COPY,
735 & STRING, MEMCNT, ERRCODE)
736 COMPLEX(kind((1.D0,1.D0))), POINTER :: ARRAY(:)
737 INTEGER :: INFO(:)
738 INTEGER :: MINSIZE, LP
739 LOGICAL, OPTIONAL :: FORCE
740 LOGICAL, OPTIONAL :: COPY
741 CHARACTER, OPTIONAL :: STRING*(*)
742 INTEGER, OPTIONAL :: ERRCODE
743 INTEGER(8), OPTIONAL :: MEMCNT
744 LOGICAL :: ICOPY, IFORCE
745 COMPLEX(kind((1.D0,1.D0))), POINTER :: TEMP(:)
746 INTEGER :: I, IERR, ERRTPL(2)
747 CHARACTER(len=60) :: FMTA, FMTD
748 IF(present(copy)) THEN
749 icopy = copy
750 ELSE
751 icopy = .false.
752 END IF
753 IF (present(force)) THEN
754 iforce = force
755 ELSE
756 iforce = .false.
757 END IF
758 IF (present(string)) THEN
759 fmta = "Allocation failed inside realloc: "//string
760 fmtd = "Deallocation failed inside realloc: "//string
761 ELSE
762 fmta = "Allocation failed inside realloc: "
763 fmtd = "Deallocation failed inside realloc: "
764 END IF
765 IF (present(errcode)) THEN
766 errtpl(1) = errcode
767 errtpl(2) = minsize
768 ELSE
769 errtpl(1) = -13
770 errtpl(2) = minsize
771 END IF
772 IF(icopy) THEN
773 IF(associated(array)) THEN
774 IF ((size(array) .LT. minsize) .OR.
775 & ((size(array).NE.minsize) .AND. iforce)) THEN
776 allocate(temp(minsize), stat=ierr)
777 IF(ierr .LT. 0) THEN
778 WRITE(lp,fmta)
779 info(1:2) = errtpl
780 RETURN
781 ELSE
782 IF(present(memcnt))memcnt = memcnt+int(minsize,8)*16_8
783 END IF
784 DO i=1, min(size(array), minsize)
785 temp(i) = array(i)
786 END DO
787 IF(present(memcnt))memcnt =memcnt-
788 & int(size(array),8)*zsize
789 deallocate(array, stat=ierr)
790 IF(ierr .LT. 0) THEN
791 WRITE(lp,fmtd)
792 info(1:2) = errtpl
793 RETURN
794 END IF
795 NULLIFY(array)
796 array => temp
797 NULLIFY(temp)
798 END IF
799 ELSE
800 WRITE(lp,
801 & '("Input array is not associated. nothing to copy here")')
802 RETURN
803 END IF
804 ELSE
805 IF(associated(array)) THEN
806 IF ((size(array) .LT. minsize) .OR.
807 & ((size(array).NE.minsize) .AND. iforce)) THEN
808 IF(present(memcnt))memcnt =memcnt-
809 & int(size(array),8)*zsize
810 deallocate(array, stat=ierr)
811 IF(ierr .LT. 0) THEN
812 WRITE(lp,fmtd)
813 info(1:2) = errtpl
814 RETURN
815 END IF
816 ELSE
817 RETURN
818 END IF
819 END IF
820 allocate(array(minsize), stat=ierr)
821 IF(ierr .LT. 0) THEN
822 WRITE(lp,fmta)
823 info(1:2) = errtpl
824 RETURN
825 ELSE
826 IF(present(memcnt)) memcnt = memcnt+
827 & int(minsize,8)*zsize
828 END IF
829 END IF
830 RETURN
831 END SUBROUTINE mumps_zrealloc
832 SUBROUTINE mumps_idealloc(A1, A2, A3, A4, A5, A6, A7, MEMCNT)
833 INTEGER, POINTER :: A1(:)
834 INTEGER, POINTER, OPTIONAL :: A2(:), A3(:), A4(:), A5(:),
835 & A6(:), A7(:)
836 INTEGER(8), OPTIONAL :: MEMCNT
837 INTEGER(8) :: IMEMCNT
838 imemcnt = 0
839 IF(associated(a1)) THEN
840 imemcnt = imemcnt+int(size(a1),8)*isize
841 DEALLOCATE(a1)
842 NULLIFY(a1)
843 END IF
844 IF(present(a2)) THEN
845 IF(associated(a2)) THEN
846 imemcnt = imemcnt+int(size(a2),8)*isize
847 DEALLOCATE(a2)
848 NULLIFY(a2)
849 END IF
850 END IF
851 IF(present(a3)) THEN
852 IF(associated(a3)) THEN
853 imemcnt = imemcnt+int(size(a3),8)*isize
854 DEALLOCATE(a3)
855 NULLIFY(a3)
856 END IF
857 END IF
858 IF(present(a4)) THEN
859 IF(associated(a4)) THEN
860 imemcnt = imemcnt+int(size(a4),8)*isize
861 DEALLOCATE(a4)
862 NULLIFY(a4)
863 END IF
864 END IF
865 IF(present(a5)) THEN
866 IF(associated(a5)) THEN
867 imemcnt = imemcnt+int(size(a5),8)*isize
868 DEALLOCATE(a5)
869 NULLIFY(a5)
870 END IF
871 END IF
872 IF(present(a6)) THEN
873 IF(associated(a6)) THEN
874 imemcnt = imemcnt+int(size(a6),8)*isize
875 DEALLOCATE(a6)
876 NULLIFY(a6)
877 END IF
878 END IF
879 IF(present(a7)) THEN
880 IF(associated(a7)) THEN
881 imemcnt = imemcnt+int(size(a7),8)*isize
882 DEALLOCATE(a7)
883 NULLIFY(a7)
884 END IF
885 END IF
886 IF(present(memcnt)) memcnt = memcnt-imemcnt
887 RETURN
888 END SUBROUTINE mumps_idealloc
889 SUBROUTINE mumps_i8dealloc(A1, A2, A3, A4, A5, A6, A7, MEMCNT)
890 INTEGER(8), POINTER :: A1(:)
891 INTEGER(8), POINTER, OPTIONAL :: A2(:), A3(:), A4(:), A5(:),
892 & a6(:), a7(:)
893 INTEGER(8), OPTIONAL :: MEMCNT
894 INTEGER(8) :: IMEMCNT
895 imemcnt = 0
896 IF(associated(a1)) THEN
897 imemcnt = imemcnt+int(size(a1),8)*i8size
898 DEALLOCATE(a1)
899 NULLIFY(a1)
900 END IF
901 IF(present(a2)) THEN
902 IF(associated(a2)) THEN
903 imemcnt = imemcnt+int(size(a2),8)*i8size
904 DEALLOCATE(a2)
905 NULLIFY(a2)
906 END IF
907 END IF
908 IF(present(a3)) THEN
909 IF(associated(a3)) THEN
910 imemcnt = imemcnt+int(size(a3),8)*i8size
911 DEALLOCATE(a3)
912 NULLIFY(a3)
913 END IF
914 END IF
915 IF(present(a4)) THEN
916 IF(associated(a4)) THEN
917 imemcnt = imemcnt+int(size(a4),8)*i8size
918 DEALLOCATE(a4)
919 NULLIFY(a4)
920 END IF
921 END IF
922 IF(present(a5)) THEN
923 IF(associated(a5)) THEN
924 imemcnt = imemcnt+int(size(a5),8)*i8size
925 DEALLOCATE(a5)
926 NULLIFY(a5)
927 END IF
928 END IF
929 IF(present(a6)) THEN
930 IF(associated(a6)) THEN
931 imemcnt = imemcnt+int(size(a6),8)*i8size
932 DEALLOCATE(a6)
933 NULLIFY(a6)
934 END IF
935 END IF
936 IF(present(a7)) THEN
937 IF(associated(a7)) THEN
938 imemcnt = imemcnt+int(size(a7),8)*i8size
939 DEALLOCATE(a7)
940 NULLIFY(a7)
941 END IF
942 END IF
943 IF(present(memcnt)) memcnt = memcnt-imemcnt
944 RETURN
945 END SUBROUTINE mumps_i8dealloc
946 END MODULE
mumps_memory_mod::mumps_dealloc
Definition mumps_memory_mod.F:15
mumps_memory_mod::mumps_realloc
Definition mumps_memory_mod.F:18
min
#define min(a, b)
Definition macros.h:20
mumps_memory_mod
Definition mumps_memory_mod.F:14
mumps_memory_mod::mumps_memory_set_data_sizes
subroutine mumps_memory_set_data_sizes()
Definition mumps_memory_mod.F:26
mumps_memory_mod::csize
integer(8), private csize
Definition mumps_memory_mod.F:23
mumps_memory_mod::mumps_irealloc
subroutine mumps_irealloc(array, minsize, info, lp, force, copy, string, memcnt, errcode)
Definition mumps_memory_mod.F:42
mumps_memory_mod::isize
integer(8), private isize
Definition mumps_memory_mod.F:23
mumps_memory_mod::zsize
integer(8), private zsize
Definition mumps_memory_mod.F:23
mumps_memory_mod::dsize
integer(8), private dsize
Definition mumps_memory_mod.F:23
mumps_memory_mod::mumps_i8realloc8
subroutine mumps_i8realloc8(array, minsize, info, lp, force, copy, string, memcnt, errcode)
Definition mumps_memory_mod.F:339
mumps_memory_mod::mumps_crealloc
subroutine mumps_crealloc(array, minsize, info, lp, force, copy, string, memcnt, errcode)
Definition mumps_memory_mod.F:637
mumps_memory_mod::mumps_i8realloc
subroutine mumps_i8realloc(array, minsize, info, lp, force, copy, string, memcnt, errcode)
Definition mumps_memory_mod.F:141
mumps_memory_mod::ssize
integer(8), private ssize
Definition mumps_memory_mod.F:23
mumps_memory_mod::mumps_srealloc
subroutine mumps_srealloc(array, minsize, info, lp, force, copy, string, memcnt, errcode)
Definition mumps_memory_mod.F:440
mumps_memory_mod::mumps_drealloc
subroutine mumps_drealloc(array, minsize, info, lp, force, copy, string, memcnt, errcode)
Definition mumps_memory_mod.F:538
mumps_memory_mod::i8size
integer(8), private i8size
Definition mumps_memory_mod.F:23
mumps_memory_mod::mumps_idealloc
subroutine mumps_idealloc(a1, a2, a3, a4, a5, a6, a7, memcnt)
Definition mumps_memory_mod.F:833
mumps_memory_mod::mumps_i8dealloc
subroutine mumps_i8dealloc(a1, a2, a3, a4, a5, a6, a7, memcnt)
Definition mumps_memory_mod.F:890
mumps_memory_mod::mumps_zrealloc
subroutine mumps_zrealloc(array, minsize, info, lp, force, copy, string, memcnt, errcode)
Definition mumps_memory_mod.F:736
mumps_memory_mod::mumps_irealloc8
subroutine mumps_irealloc8(array, minsize, info, lp, force, copy, string, memcnt, errcode)
Definition mumps_memory_mod.F:240