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