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_FAC_DESCBAND_DATA_M
14       IMPLICIT NONE
15#if ! defined(NO_FDM_DESCBAND)
16       INTEGER, SAVE :: INODE_WAITED_FOR
17       PRIVATE
18       PUBLIC :: DESCBAND_STRUC_T, MUMPS_FDBD_INIT, MUMPS_FDBD_END,
19     &         MUMPS_FDBD_SAVE_DESCBAND, MUMPS_FDBD_IS_DESCBAND_STORED,
20     &         MUMPS_FDBD_RETRIEVE_DESCBAND,
21     &         MUMPS_FDBD_FREE_DESCBAND_STRUC,
22     &         INODE_WAITED_FOR
23       TYPE DESCBAND_STRUC_T
24         INTEGER :: INODE, LBUFR
25         INTEGER, POINTER, DIMENSION(:) :: BUFR
26       END TYPE DESCBAND_STRUC_T
27       TYPE (DESCBAND_STRUC_T), POINTER, DIMENSION(:), SAVE::FDBD_ARRAY
28       CONTAINS
29       SUBROUTINE MUMPS_FDBD_INIT( INITIAL_SIZE, INFO )
30       INTEGER, INTENT(IN) :: INITIAL_SIZE
31       INTEGER, INTENT(INOUT) :: INFO(2)
32       INTEGER :: I, IERR
33       ALLOCATE(FDBD_ARRAY( INITIAL_SIZE ), stat=IERR)
34       IF (IERR > 0 ) THEN
35         INFO(1)=-13
36         INFO(2)=INITIAL_SIZE
37         RETURN
38       ENDIF
39       DO I=1, INITIAL_SIZE
40         FDBD_ARRAY(I)%INODE=-9999
41         FDBD_ARRAY(I)%LBUFR=-9999
42         NULLIFY(FDBD_ARRAY(I)%BUFR)
43       ENDDO
44       INODE_WAITED_FOR = -1
45       RETURN
46       END SUBROUTINE MUMPS_FDBD_INIT
47       FUNCTION MUMPS_FDBD_IS_DESCBAND_STORED( INODE, IWHANDLER )
48       LOGICAL :: MUMPS_FDBD_IS_DESCBAND_STORED
49       INTEGER, INTENT(IN) :: INODE
50       INTEGER, INTENT(OUT) :: IWHANDLER
51       INTEGER :: I
52       DO I = 1, size(FDBD_ARRAY)
53         IF (FDBD_ARRAY(I)%INODE .EQ. INODE) THEN
54           IWHANDLER = I
55           MUMPS_FDBD_IS_DESCBAND_STORED = .TRUE.
56           RETURN
57         ENDIF
58       ENDDO
59       MUMPS_FDBD_IS_DESCBAND_STORED = .FALSE.
60       RETURN
61       END FUNCTION MUMPS_FDBD_IS_DESCBAND_STORED
62       SUBROUTINE MUMPS_FDBD_SAVE_DESCBAND(INODE, LBUFR, BUFR,
63     &                                     IWHANDLER, INFO)
64       USE MUMPS_FRONT_DATA_MGT_M, ONLY : MUMPS_FDM_START_IDX
65       INTEGER, INTENT(IN) :: INODE, LBUFR, BUFR(LBUFR)
66       INTEGER, INTENT(INOUT) :: INFO(2)
67       INTEGER, INTENT(OUT) :: IWHANDLER
68       TYPE(DESCBAND_STRUC_T), POINTER, DIMENSION(:) :: FDBD_ARRAY_TMP
69       INTEGER :: OLD_SIZE, NEW_SIZE, I, IERR
70       IWHANDLER = -1
71       CALL MUMPS_FDM_START_IDX('A', 'DESCBAND', IWHANDLER, INFO)
72       IF (INFO(1) .LT. 0) RETURN
73       IF (IWHANDLER > size(FDBD_ARRAY)) THEN
74         OLD_SIZE = size(FDBD_ARRAY)
75         NEW_SIZE = max( (OLD_SIZE * 3) / 2 + 1, IWHANDLER)
76         ALLOCATE(FDBD_ARRAY_TMP(NEW_SIZE),stat=IERR)
77         IF (IERR.GT.0) THEN
78           INFO(1)=-13
79           INFO(2)=NEW_SIZE
80           RETURN
81         ENDIF
82         DO I=1, OLD_SIZE
83           FDBD_ARRAY_TMP(I)=FDBD_ARRAY(I)
84         ENDDO
85         DO I=OLD_SIZE+1, NEW_SIZE
86           FDBD_ARRAY_TMP(I)%INODE = -9999
87           FDBD_ARRAY_TMP(I)%LBUFR = -9999
88           NULLIFY(FDBD_ARRAY_TMP(I)%BUFR)
89         ENDDO
90         DEALLOCATE(FDBD_ARRAY)
91         FDBD_ARRAY=>FDBD_ARRAY_TMP
92         NULLIFY(FDBD_ARRAY_TMP)
93       ENDIF
94       FDBD_ARRAY(IWHANDLER)%INODE = INODE
95       FDBD_ARRAY(IWHANDLER)%LBUFR = LBUFR
96       ALLOCATE(FDBD_ARRAY(IWHANDLER)%BUFR(LBUFR), stat=IERR)
97       IF (IERR > 0 ) THEN
98         INFO(1)=-13
99         INFO(2)=LBUFR
100         RETURN
101       ENDIF
102       FDBD_ARRAY(IWHANDLER)%BUFR = BUFR
103       RETURN
104       END SUBROUTINE MUMPS_FDBD_SAVE_DESCBAND
105       SUBROUTINE MUMPS_FDBD_RETRIEVE_DESCBAND(IWHANDLER,DESCBAND_STRUC)
106       INTEGER, INTENT(IN) :: IWHANDLER
107#if defined(MUMPS_F2003)
108       TYPE (DESCBAND_STRUC_T), POINTER, INTENT(OUT) :: DESCBAND_STRUC
109#else
110       TYPE (DESCBAND_STRUC_T), POINTER :: DESCBAND_STRUC
111#endif
112       DESCBAND_STRUC => FDBD_ARRAY(IWHANDLER)
113       RETURN
114       END SUBROUTINE MUMPS_FDBD_RETRIEVE_DESCBAND
115       SUBROUTINE MUMPS_FDBD_FREE_DESCBAND_STRUC(IWHANDLER)
116       USE MUMPS_FRONT_DATA_MGT_M, ONLY : MUMPS_FDM_END_IDX
117       INTEGER, INTENT(INOUT) :: IWHANDLER
118       TYPE (DESCBAND_STRUC_T), POINTER :: DESCBAND_STRUC
119       DESCBAND_STRUC => FDBD_ARRAY(IWHANDLER)
120       DESCBAND_STRUC%INODE = -7777
121       DESCBAND_STRUC%LBUFR = -7777
122       DEALLOCATE(DESCBAND_STRUC%BUFR)
123       NULLIFY(DESCBAND_STRUC%BUFR)
124       CALL MUMPS_FDM_END_IDX('A', 'DESCBAND', IWHANDLER)
125       RETURN
126       END SUBROUTINE MUMPS_FDBD_FREE_DESCBAND_STRUC
127       SUBROUTINE MUMPS_FDBD_END(INFO1)
128       INTEGER, INTENT(IN) :: INFO1
129       INTEGER :: I, IWHANDLER
130       IF (.NOT. associated(FDBD_ARRAY)) THEN
131         WRITE(*,*) "Internal error 1 in MUMPS_FAC_FDBD_END"
132         CALL MUMPS_ABORT()
133       ENDIF
134       DO I=1, size(FDBD_ARRAY)
135         IF (FDBD_ARRAY(I)%INODE .GE. 0) THEN
136           IF (INFO1 .GE.0) THEN
137             WRITE(*,*) "Internal error 2 in MUMPS_FAC_FDBD_END",I
138             CALL MUMPS_ABORT()
139           ELSE
140             IWHANDLER=I
141             CALL MUMPS_FDBD_FREE_DESCBAND_STRUC(IWHANDLER)
142           ENDIF
143         ENDIF
144       ENDDO
145       DEALLOCATE(FDBD_ARRAY)
146       RETURN
147       END SUBROUTINE MUMPS_FDBD_END
148#endif
149       END MODULE MUMPS_FAC_DESCBAND_DATA_M
150