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