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