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 CMUMPS_LR_DATA_M 14 USE CMUMPS_LR_TYPE 15 IMPLICIT NONE 16 PRIVATE 17 PUBLIC :: CMUMPS_BLR_END_FRONT, 18 & CMUMPS_BLR_INIT_MODULE, CMUMPS_BLR_END_MODULE, 19 & CMUMPS_BLR_INIT_FRONT, 20 & CMUMPS_BLR_SAVE_PANEL_LORU, 21 & CMUMPS_BLR_RETRIEVE_BEGS_BLR_L, 22 & CMUMPS_BLR_RETRIEVE_BEGS_BLR_C, 23 & CMUMPS_BLR_RETRIEVE_PANEL_L, 24 & CMUMPS_BLR_RETRIEVE_PANEL_LORU, 25 & CMUMPS_BLR_DEC_AND_TRYFREE_L, 26 & CMUMPS_BLR_TRY_FREE_PANEL, 27 & CMUMPS_BLR_FREE_ALL_PANELS, 28 & CMUMPS_BLR_FREE_PANEL 29 TYPE blr_panel_type 30 integer :: NB_ACCESSES_LEFT 31 type(lrb_type), pointer :: LRB_PANEL(:) 32 END TYPE blr_panel_type 33 TYPE BLR_STRUC_T 34 LOGICAL :: IsSYM, IsT2, IsSLAVE 35 TYPE(blr_panel_type), DIMENSION (:), POINTER :: PANELS_L 36 TYPE(blr_panel_type), DIMENSION (:), POINTER :: PANELS_U 37 INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_L 38 INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_COL 39 INTEGER :: NB_ACCESSES_INIT 40 INTEGER :: NB_PANELS 41 END TYPE BLR_STRUC_T 42 type(BLR_STRUC_T), POINTER, DIMENSION(:), SAVE :: BLR_ARRAY 43 INTEGER BLR_ARRAY_FREE, PANELS_NOTUSED, PANELS_FREED, 44 & NB_PANELS_NOTINIT 45 PARAMETER (BLR_ARRAY_FREE=-9999, 46 & PANELS_NOTUSED=-1111, PANELS_FREED=-2222, 47 & NB_PANELS_NOTINIT=-3333) 48 CONTAINS 49 SUBROUTINE CMUMPS_BLR_INIT_MODULE(INITIAL_SIZE, INFO) 50 INTEGER, INTENT(IN) :: INITIAL_SIZE 51 INTEGER, INTENT(INOUT) :: INFO(2) 52 INTEGER :: I, IERR 53 ALLOCATE(BLR_ARRAY( INITIAL_SIZE ), stat=IERR) 54 IF (IERR > 0 ) THEN 55 INFO(1)=-13 56 INFO(2)=INITIAL_SIZE 57 RETURN 58 ENDIF 59 DO I=1, INITIAL_SIZE 60 NULLIFY(BLR_ARRAY(I)%PANELS_L) 61 NULLIFY(BLR_ARRAY(I)%PANELS_U) 62 BLR_ARRAY(I)%NB_ACCESSES_INIT = BLR_ARRAY_FREE 63 BLR_ARRAY(I)%NB_PANELS = NB_PANELS_NOTINIT 64 NULLIFY(BLR_ARRAY(I)%BEGS_BLR_L) 65 NULLIFY(BLR_ARRAY(I)%BEGS_BLR_COL) 66 ENDDO 67 RETURN 68 END SUBROUTINE CMUMPS_BLR_INIT_MODULE 69 SUBROUTINE CMUMPS_BLR_END_MODULE(INFO1, KEEP8, IS_FACTOR) 70 INTEGER, INTENT(IN) :: INFO1 71 INTEGER(8) :: KEEP8(150) 72 LOGICAL, INTENT(IN) :: IS_FACTOR 73 INTEGER :: I, ILOOP 74 IF (.NOT. associated(BLR_ARRAY)) THEN 75 WRITE(*,*) "Internal error 1 in CMUMPS_BLR_END_MODULE" 76 CALL MUMPS_ABORT() 77 ENDIF 78 ILOOP=0 79 DO I=1, size(BLR_ARRAY) 80 ILOOP= ILOOP+1 81 IF (associated(BLR_ARRAY(I)%PANELS_L).OR. 82 & associated(BLR_ARRAY(I)%PANELS_U)) THEN 83 IF (INFO1 .GE.0) THEN 84 WRITE(*,*) "Internal error 2 in MUMPS_BLR_END_MODULE ", 85 & " IWHANDLER=", I 86 CALL MUMPS_ABORT() 87 ELSE 88 CALL CMUMPS_BLR_END_FRONT(ILOOP, INFO1, KEEP8, IS_FACTOR) 89 ENDIF 90 ENDIF 91 ENDDO 92 DEALLOCATE(BLR_ARRAY) 93 NULLIFY(BLR_ARRAY) 94 RETURN 95 END SUBROUTINE CMUMPS_BLR_END_MODULE 96 SUBROUTINE CMUMPS_BLR_INIT_FRONT(IWHANDLER, 97 & IsSYM, IsT2, IsSLAVE, 98 & NB_PANELS, 99 & BEGS_BLR_L, BEGS_BLR_COL, 100 & NB_ACCESSES_INIT, INFO) 101 USE MUMPS_FRONT_DATA_MGT_M, ONLY : MUMPS_FDM_START_IDX 102 LOGICAL, INTENT(IN) :: IsSYM, IsT2, IsSLAVE 103 INTEGER, INTENT(IN) :: NB_PANELS 104 INTEGER, INTENT(INOUT) :: IWHANDLER, INFO(2) 105 INTEGER, INTENT(IN) :: NB_ACCESSES_INIT 106 INTEGER, INTENT(IN), DIMENSION(:) :: BEGS_BLR_L 107 INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_COL 108 TYPE(BLR_STRUC_T), POINTER, DIMENSION(:) :: BLR_ARRAY_TMP 109 INTEGER :: OLD_SIZE, NEW_SIZE 110 INTEGER :: I 111 INTEGER :: IERR 112 IF (NB_PANELS.EQ.0) THEN 113 WRITE(6,*) " Internal error in CMUMPS_BLR_INIT_FRONT ", 114 & NB_PANELS 115 ENDIF 116 CALL MUMPS_FDM_START_IDX('F', 'INITF', IWHANDLER, INFO) 117 IF (IWHANDLER > size(BLR_ARRAY)) THEN 118 OLD_SIZE = size(BLR_ARRAY) 119 NEW_SIZE = max( (OLD_SIZE * 3) / 2 + 1, IWHANDLER) 120 ALLOCATE(BLR_ARRAY_TMP(NEW_SIZE),stat=IERR) 121 IF (IERR.GT.0) THEN 122 INFO(1)=-13 123 INFO(2)=NEW_SIZE 124 RETURN 125 ENDIF 126 DO I=1, OLD_SIZE 127 BLR_ARRAY_TMP(I)=BLR_ARRAY(I) 128 ENDDO 129 DO I=OLD_SIZE+1, NEW_SIZE 130 NULLIFY(BLR_ARRAY_TMP(I)%PANELS_L) 131 NULLIFY(BLR_ARRAY_TMP(I)%PANELS_U) 132 ENDDO 133 DEALLOCATE(BLR_ARRAY) 134 BLR_ARRAY => BLR_ARRAY_TMP 135 NULLIFY(BLR_ARRAY_TMP) 136 ENDIF 137 IF (NB_ACCESSES_INIT.EQ.0) THEN 138 NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_L) 139 NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_U) 140 IF (IsSYM.and.IsT2.and.IsSLAVE.and. 141 & associated(BEGS_BLR_COL)) THEN 142 ALLOCATE( 143 & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), 144 & BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(size(BEGS_BLR_COL)), 145 & stat=IERR) 146 ELSE 147 ALLOCATE( 148 & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), 149 & stat=IERR) 150 ENDIF 151 IF (IERR .GT. 0) THEN 152 INFO(1)=-13 153 IF (associated(BEGS_BLR_COL)) THEN 154 INFO(2)=size(BEGS_BLR_L)+size(BEGS_BLR_COL) 155 ELSE 156 INFO(2)=size(BEGS_BLR_L) 157 ENDIF 158 RETURN 159 ENDIF 160 ELSE 161 IF (IsSYM.and.IsT2.and.IsSLAVE.and. 162 & associated(BEGS_BLR_COL)) THEN 163 ALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_L(NB_PANELS), 164 & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), 165 & BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(size(BEGS_BLR_COL)), 166 & stat=IERR) 167 ELSE IF (IsSYM) THEN 168 ALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_L(NB_PANELS), 169 & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), 170 & stat=IERR) 171 ELSE 172 ALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_L(NB_PANELS), 173 & BLR_ARRAY(IWHANDLER)%PANELS_U(NB_PANELS), 174 & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), 175 & stat=IERR) 176 ENDIF 177 IF (IERR .GT. 0) THEN 178 INFO(1)=-13 179 IF (IsSYM.and.IsT2.and.IsSLAVE.and. 180 & associated(BEGS_BLR_COL)) THEN 181 INFO(2)=NB_PANELS+size(BEGS_BLR_L)+size(BEGS_BLR_COL) 182 ELSE IF (IsSYM) THEN 183 INFO(2)=NB_PANELS+size(BEGS_BLR_L) 184 ELSE 185 INFO(2)=NB_PANELS+NB_PANELS+size(BEGS_BLR_L) 186 ENDIF 187 RETURN 188 ENDIF 189 DO I=1,NB_PANELS 190 NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_L(I)%LRB_PANEL) 191 IF (.NOT.IsSYM) THEN 192 NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_U(I)%LRB_PANEL) 193 ENDIF 194 ENDDO 195 ENDIF 196 BLR_ARRAY(IWHANDLER)%IsSYM = IsSYM 197 BLR_ARRAY(IWHANDLER)%IsT2 = IsT2 198 BLR_ARRAY(IWHANDLER)%IsSLAVE = IsSLAVE 199 BLR_ARRAY(IWHANDLER)%NB_PANELS = NB_PANELS 200 BLR_ARRAY(IWHANDLER)%BEGS_BLR_L = BEGS_BLR_L 201 IF (NB_ACCESSES_INIT.EQ.0) THEN 202 BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT = PANELS_NOTUSED 203 ELSE 204 BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT = NB_ACCESSES_INIT 205 ENDIF 206 IF (associated(BEGS_BLR_COL)) THEN 207 DO I=1,size(BEGS_BLR_COL) 208 BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(I) = BEGS_BLR_COL(I) 209 ENDDO 210 ELSE 211 NULLIFY( BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL ) 212 ENDIF 213 RETURN 214 END SUBROUTINE CMUMPS_BLR_INIT_FRONT 215 SUBROUTINE CMUMPS_BLR_END_FRONT(IWHANDLER, INFO1, 216 & KEEP8, IS_FACTOR) 217 USE MUMPS_FRONT_DATA_MGT_M, ONLY : MUMPS_FDM_END_IDX 218 INTEGER, INTENT(INOUT) :: IWHANDLER 219 INTEGER, INTENT(IN) :: INFO1 220 INTEGER(8) :: KEEP8(150) 221 LOGICAL, INTENT(IN) :: IS_FACTOR 222 INTEGER :: IPANEL 223 TYPE(blr_panel_type), POINTER :: THEPANEL 224 IF (IWHANDLER.LE.0) THEN 225 RETURN 226 ENDIF 227 IF (IWHANDLER .GT. size(BLR_ARRAY)) THEN 228 RETURN 229 END IF 230 IF (BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.EQ.BLR_ARRAY_FREE) 231 & RETURN 232 IF (BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.NE. 233 & PANELS_NOTUSED) THEN 234 DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%PANELS_L) 235 THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) 236 IF (associated(THEPANEL%LRB_PANEL)) THEN 237 IF (INFO1 .GE. 0) THEN 238 WRITE(*,*) " Internal Error 2 in MUMPS_BLR_END_FRONT ", 239 & IWHANDLER, "NB_ACCESSES_INIT=", 240 & BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT, 241 & "Pointer to panel number ",IPANEL," still associated", 242 & "NB_ACCESSES_LEFT= ",THEPANEL%NB_ACCESSES_LEFT 243 CALL MUMPS_ABORT() 244 ELSE 245 CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, 246 & size(THEPANEL%LRB_PANEL), KEEP8, IS_FACTOR) 247 THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED 248 ENDIF 249 ENDIF 250 ENDDO 251 NULLIFY(THEPANEL%LRB_PANEL) 252 IF (associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN 253 DEALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_L) 254 NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_L) 255 ENDIF 256 IF (.NOT.BLR_ARRAY(IWHANDLER)%IsSYM) THEN 257 DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%PANELS_U) 258 THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL) 259 IF (associated(THEPANEL%LRB_PANEL)) THEN 260 IF (INFO1 .GE. 0) THEN 261 WRITE(*,*) " Internal Error 2 in MUMPS_BLR_END_FRONT ", 262 & IWHANDLER, "NB_ACCESSES_INIT=", 263 & BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT, 264 & "Pointer to panel number ",IPANEL," still associated" 265 CALL MUMPS_ABORT() 266 ELSE 267 CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, 268 & size(THEPANEL%LRB_PANEL), KEEP8, IS_FACTOR) 269 THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED 270 ENDIF 271 ENDIF 272 ENDDO 273 NULLIFY(THEPANEL%LRB_PANEL) 274 IF (associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN 275 DEALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_U) 276 NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_U) 277 ENDIF 278 ENDIF 279 ENDIF 280 IF (.NOT. associated(BLR_ARRAY(IWHANDLER)%BEGS_BLR_L)) THEN 281 WRITE(*,*) " Internal Error 3 in MUMPS_BLR_END_FRONT ", 282 & IWHANDLER 283 CALL MUMPS_ABORT() 284 ENDIF 285 DEALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_L) 286 NULLIFY(BLR_ARRAY(IWHANDLER)%BEGS_BLR_L) 287 IF (associated(BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL)) THEN 288 DEALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL) 289 NULLIFY(BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL) 290 ENDIF 291 BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT = BLR_ARRAY_FREE 292 BLR_ARRAY(IWHANDLER)%NB_PANELS = NB_PANELS_NOTINIT 293 CALL MUMPS_FDM_END_IDX('F', 'ENDF', IWHANDLER) 294 RETURN 295 END SUBROUTINE CMUMPS_BLR_END_FRONT 296 SUBROUTINE CMUMPS_BLR_SAVE_PANEL_LORU ( 297 & IWHANDLER, LORU, IPANEL, LRB_PANEL ) 298 type(lrb_type), DIMENSION(:), pointer :: LRB_PANEL 299 INTEGER, INTENT(IN) :: IWHANDLER, IPANEL 300 INTEGER, INTENT(IN) :: LORU 301 TYPE(blr_panel_type), POINTER :: THEPANEL 302 IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN 303 WRITE(*,*) "Internal error 1 in CMUMPS_BLR_SAVE_PANEL_LORU" 304 CALL MUMPS_ABORT() 305 ENDIF 306 IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) THEN 307 WRITE(*,*) "Internal error 2 in CMUMPS_BLR_SAVE_PANEL_LORU" 308 CALL MUMPS_ABORT() 309 ENDIF 310 IF (LORU.EQ.0) THEN 311 THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) 312 ELSE 313 THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL) 314 ENDIF 315 THEPANEL%NB_ACCESSES_LEFT = 316 & BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT 317 THEPANEL%LRB_PANEL => LRB_PANEL 318 RETURN 319 END SUBROUTINE CMUMPS_BLR_SAVE_PANEL_LORU 320 SUBROUTINE CMUMPS_BLR_RETRIEVE_BEGS_BLR_L 321 & ( IWHANDLER, BEGS_BLR_L ) 322 INTEGER, INTENT(IN) :: IWHANDLER 323#if defined(MUMPS_F2003) 324 INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_L 325#else 326 INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L 327#endif 328 IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN 329 WRITE(*,*) 330 & "Internal error 1 in CMUMPS_BLR_RETRIEVE_BEGS_BLR_L" 331 CALL MUMPS_ABORT() 332 ENDIF 333 BEGS_BLR_L => BLR_ARRAY(IWHANDLER)%BEGS_BLR_L 334 RETURN 335 END SUBROUTINE CMUMPS_BLR_RETRIEVE_BEGS_BLR_L 336 SUBROUTINE CMUMPS_BLR_RETRIEVE_BEGS_BLR_C 337 & ( IWHANDLER, BEGS_BLR_COL, NB_PANELS ) 338 INTEGER, INTENT(IN) :: IWHANDLER 339 INTEGER, INTENT(OUT) :: NB_PANELS 340#if defined(MUMPS_F2003) 341 INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_COL 342#else 343 INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_COL 344#endif 345 IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN 346 WRITE(*,*) 347 & "Internal error 1 in CMUMPS_BLR_RETRIEVE_BEGS_BLR_C" 348 CALL MUMPS_ABORT() 349 ENDIF 350 BEGS_BLR_COL => BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL 351 NB_PANELS = BLR_ARRAY(IWHANDLER)%NB_PANELS 352 RETURN 353 END SUBROUTINE CMUMPS_BLR_RETRIEVE_BEGS_BLR_C 354 SUBROUTINE CMUMPS_BLR_RETRIEVE_PANEL_L(IWHANDLER, IPANEL, 355 & BEGS_BLR_L, THELRBPANEL) 356 INTEGER, INTENT(IN) :: IWHANDLER 357 INTEGER, INTENT(IN) :: IPANEL 358#if defined(MUMPS_F2003) 359 INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_L 360 TYPE(LRB_TYPE), INTENT(OUT), DIMENSION(:), POINTER :: THELRBPANEL 361#else 362 INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L 363 TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: THELRBPANEL 364#endif 365 IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN 366 WRITE(*,*) "Internal error 1 in CMUMPS_BLR_RETRIEVE_PANEL_L", 367 & "IPANEL=", IPANEL 368 CALL MUMPS_ABORT() 369 ENDIF 370 IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN 371 WRITE(*,*) "Internal error 2 in CMUMPS_BLR_RETRIEVE_PANEL_L", 372 & "IPANEL=", IPANEL 373 CALL MUMPS_ABORT() 374 ENDIF 375 IF ( .NOT. 376 & associated(BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL) ) 377 & THEN 378 WRITE(*,*) "Internal error 3 in CMUMPS_BLR_RETRIEVE_PANEL_L", 379 & "IPANEL=", IPANEL 380 CALL MUMPS_ABORT() 381 ENDIF 382 CALL CMUMPS_BLR_RETRIEVE_BEGS_BLR_L( IWHANDLER, BEGS_BLR_L ) 383 THELRBPANEL => 384 & BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL 385 BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%NB_ACCESSES_LEFT = 386 & BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%NB_ACCESSES_LEFT - 1 387 RETURN 388 END SUBROUTINE CMUMPS_BLR_RETRIEVE_PANEL_L 389 SUBROUTINE CMUMPS_BLR_RETRIEVE_PANEL_LORU 390 & (IWHANDLER, LORU, IPANEL, 391 & THELRBPANEL) 392 INTEGER, INTENT(IN) :: IWHANDLER 393 INTEGER, INTENT(IN) :: LORU 394 INTEGER, INTENT(IN) :: IPANEL 395#if defined(MUMPS_F2003) 396 TYPE(LRB_TYPE), INTENT(OUT), DIMENSION(:), POINTER :: THELRBPANEL 397#else 398 TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: THELRBPANEL 399#endif 400 IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN 401 WRITE(*,*) 402 & "Internal error 1 in CMUMPS_BLR_RETRIEVE_PANEL_LORU", 403 & "IPANEL=", IPANEL 404 CALL MUMPS_ABORT() 405 ENDIF 406 IF (LORU.EQ.0) THEN 407 IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN 408 WRITE(*,*) 409 & "Internal error 2 in CMUMPS_BLR_RETRIEVE_PANEL_LORU", 410 & "IPANEL=", IPANEL 411 CALL MUMPS_ABORT() 412 ENDIF 413 IF ( .NOT. 414 & associated(BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL) ) 415 & THEN 416 WRITE(*,*) 417 & "Internal error 3 in CMUMPS_BLR_RETRIEVE_PANEL_LORU", 418 & "IPANEL=", IPANEL 419 CALL MUMPS_ABORT() 420 ENDIF 421 THELRBPANEL => 422 & BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL 423 BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%NB_ACCESSES_LEFT = 424 & BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%NB_ACCESSES_LEFT - 1 425 ELSE 426 IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN 427 WRITE(*,*) 428 & "Internal error 2 in CMUMPS_BLR_RETRIEVE_PANEL_LORU", 429 & "IPANEL=", IPANEL 430 CALL MUMPS_ABORT() 431 ENDIF 432 IF ( .NOT. 433 & associated(BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL)%LRB_PANEL) ) 434 & THEN 435 WRITE(*,*) 436 & "Internal error 3 in CMUMPS_BLR_RETRIEVE_PANEL_LORU", 437 & "IPANEL=", IPANEL 438 CALL MUMPS_ABORT() 439 ENDIF 440 THELRBPANEL => 441 & BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL)%LRB_PANEL 442 BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL)%NB_ACCESSES_LEFT = 443 & BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL)%NB_ACCESSES_LEFT - 1 444 ENDIF 445 RETURN 446 END SUBROUTINE CMUMPS_BLR_RETRIEVE_PANEL_LORU 447 SUBROUTINE CMUMPS_BLR_DEC_AND_TRYFREE_L( IWHANDLER, IPANEL, 448 & KEEP8, IS_FACTOR) 449 IMPLICIT NONE 450 INTEGER, INTENT(IN) :: IWHANDLER, IPANEL 451 INTEGER(8) :: KEEP8(150) 452 LOGICAL, INTENT(IN) :: IS_FACTOR 453 IF (IWHANDLER.LE.0) RETURN 454 IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) 455 & RETURN 456 BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%NB_ACCESSES_LEFT = 457 & BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%NB_ACCESSES_LEFT - 1 458 CALL CMUMPS_BLR_TRY_FREE_PANEL (IWHANDLER, IPANEL, 459 & KEEP8, IS_FACTOR) 460 RETURN 461 END SUBROUTINE CMUMPS_BLR_DEC_AND_TRYFREE_L 462 SUBROUTINE CMUMPS_BLR_TRY_FREE_PANEL( IWHANDLER, IPANEL, 463 & KEEP8, IS_FACTOR ) 464 IMPLICIT NONE 465 INTEGER, INTENT(IN) :: IWHANDLER, IPANEL 466 INTEGER(8) :: KEEP8(150) 467 LOGICAL, INTENT(IN) :: IS_FACTOR 468 TYPE(blr_panel_type), POINTER :: THEPANEL 469 IF (IWHANDLER.LE.0) RETURN 470 IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) 471 & RETURN 472 THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) 473 IF ( THEPANEL%NB_ACCESSES_LEFT .EQ. 0 ) THEN 474 IF (associated(THEPANEL%LRB_PANEL)) THEN 475 IF (size(THEPANEL%LRB_PANEL) .GT.0) THEN 476 CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, 477 & size(THEPANEL%LRB_PANEL), KEEP8, IS_FACTOR) 478 DEALLOCATE(THEPANEL%LRB_PANEL) 479 NULLIFY(THEPANEL%LRB_PANEL) 480 ENDIF 481 ENDIF 482 THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED 483 ENDIF 484 RETURN 485 END SUBROUTINE CMUMPS_BLR_TRY_FREE_PANEL 486 SUBROUTINE CMUMPS_BLR_FREE_ALL_PANELS ( IWHANDLER, 487 & KEEP8, IS_FACTOR ) 488 IMPLICIT NONE 489 INTEGER, INTENT(IN) :: IWHANDLER 490 INTEGER(8) :: KEEP8(150) 491 LOGICAL, INTENT(IN) :: IS_FACTOR 492 INTEGER :: IPANEL 493 TYPE(blr_panel_type), POINTER :: THEPANEL 494 IF (IWHANDLER.LE.0) RETURN 495 IF (BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.EQ. 496 & PANELS_NOTUSED) RETURN 497 DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%PANELS_L) 498 THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) 499 IF (associated(THEPANEL%LRB_PANEL)) THEN 500 IF (size(THEPANEL%LRB_PANEL) .GT.0) THEN 501 CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, 502 & size(THEPANEL%LRB_PANEL), KEEP8, IS_FACTOR) 503 DEALLOCATE(THEPANEL%LRB_PANEL) 504 ENDIF 505 NULLIFY(THEPANEL%LRB_PANEL) 506 ENDIF 507 THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED 508 ENDDO 509 IF (.NOT.BLR_ARRAY(IWHANDLER)%IsSYM) THEN 510 DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%PANELS_U) 511 THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL) 512 IF (associated(THEPANEL%LRB_PANEL)) THEN 513 IF (size(THEPANEL%LRB_PANEL) .GT.0) THEN 514 CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, 515 & size(THEPANEL%LRB_PANEL), KEEP8, IS_FACTOR) 516 DEALLOCATE(THEPANEL%LRB_PANEL) 517 ENDIF 518 NULLIFY(THEPANEL%LRB_PANEL) 519 ENDIF 520 THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED 521 ENDDO 522 ENDIF 523 RETURN 524 END SUBROUTINE CMUMPS_BLR_FREE_ALL_PANELS 525 SUBROUTINE CMUMPS_BLR_FREE_PANEL( IWHANDLER, LORU, IPANEL, 526 & KEEP8, IS_FACTOR ) 527 IMPLICIT NONE 528 INTEGER, INTENT(IN) :: IWHANDLER, IPANEL 529 INTEGER, INTENT(IN) :: LORU 530 INTEGER(8) :: KEEP8(150) 531 LOGICAL, INTENT(IN) :: IS_FACTOR 532 TYPE(blr_panel_type), POINTER :: THEPANEL 533 IF (IWHANDLER.LE.0) RETURN 534 IF (LORU.EQ.0.or.LORU.EQ.1) THEN 535 IF (LORU.EQ.0) THEN 536 THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) 537 ELSE 538 THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL) 539 ENDIF 540 IF (associated(THEPANEL%LRB_PANEL)) THEN 541 IF (size(THEPANEL%LRB_PANEL) .GT.0) THEN 542 CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, 543 & size(THEPANEL%LRB_PANEL), KEEP8, IS_FACTOR) 544 DEALLOCATE(THEPANEL%LRB_PANEL) 545 ENDIF 546 NULLIFY(THEPANEL%LRB_PANEL) 547 ENDIF 548 THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED 549 ELSE 550 THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) 551 IF (associated(THEPANEL%LRB_PANEL)) THEN 552 IF (size(THEPANEL%LRB_PANEL) .GT.0) THEN 553 CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, 554 & size(THEPANEL%LRB_PANEL), KEEP8, IS_FACTOR) 555 DEALLOCATE(THEPANEL%LRB_PANEL) 556 ENDIF 557 NULLIFY(THEPANEL%LRB_PANEL) 558 ENDIF 559 THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED 560 THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL) 561 IF (associated(THEPANEL%LRB_PANEL)) THEN 562 IF (size(THEPANEL%LRB_PANEL) .GT.0) THEN 563 CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, 564 & size(THEPANEL%LRB_PANEL), KEEP8, IS_FACTOR) 565 DEALLOCATE(THEPANEL%LRB_PANEL) 566 ENDIF 567 NULLIFY(THEPANEL%LRB_PANEL) 568 ENDIF 569 THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED 570 ENDIF 571 RETURN 572 END SUBROUTINE CMUMPS_BLR_FREE_PANEL 573 END MODULE CMUMPS_LR_DATA_M 574