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_MAPROW_DATA_M
14       IMPLICIT NONE
15#if ! defined(NO_FDM_MAPROW)
16C      =========================================
17C      The MUMPS_FAC_MAPROW_DATA_M module stores
18C      the MAPROW messages that arrive too early.
19C      It is based on the MUMPS_FRONT_DATA_MGT_M
20C      module.
21C
22C      An array of structures that contain MAPROW
23C      information is used as a global variable in
24C      this module. It is indexed by an "IWHANDLER"
25C      (stored in the main IW array) that is
26C      managed by the MUMPS_FRONT_DATA_MGT_M module.
27C
28C      The same handler can be used for other data
29C      stored for active type 2 fronts (DESCBAND
30C      information, typically)
31C      ========================================
32C
33       PRIVATE
34       PUBLIC :: MAPROW_STRUC_T, MUMPS_FMRD_INIT, MUMPS_FMRD_END,
35     &           MUMPS_FMRD_SAVE_MAPROW, MUMPS_FMRD_IS_MAPROW_STORED,
36     &           MUMPS_FMRD_RETRIEVE_MAPROW,
37     &           MUMPS_FMRD_FREE_MAPROW_STRUC
38       TYPE MAPROW_STRUC_T
39         INTEGER :: INODE, ISON, NSLAVES_PERE, NFRONT_PERE,
40     &              NASS_PERE, LMAP, NFS4FATHER
41         INTEGER,POINTER, DIMENSION(:) :: SLAVES_PERE !size NSLAVES_PERE
42         INTEGER,POINTER, DIMENSION(:) :: TROW        !size LMAP
43       END TYPE MAPROW_STRUC_T
44       TYPE (MAPROW_STRUC_T), POINTER, DIMENSION(:), SAVE :: FMRD_ARRAY
45       CONTAINS
46       FUNCTION MUMPS_FMRD_IS_MAPROW_STORED( IWHANDLER )
47       LOGICAL :: MUMPS_FMRD_IS_MAPROW_STORED
48       INTEGER, INTENT(IN) :: IWHANDLER
49       IF (IWHANDLER .LT. 0 .OR. IWHANDLER .GT. size(FMRD_ARRAY)) THEN
50         MUMPS_FMRD_IS_MAPROW_STORED = .FALSE.
51       ELSE
52         MUMPS_FMRD_IS_MAPROW_STORED =
53     &                           (FMRD_ARRAY(IWHANDLER)%INODE .GE. 0 )
54         IF (FMRD_ARRAY(IWHANDLER)%INODE .EQ.0) THEN
55           WRITE(*,*) " Internal error 1 in MUMPS_FMRD_IS_MAPROW_STORED"
56           CALL MUMPS_ABORT()
57         ENDIF
58       ENDIF
59       RETURN
60       END FUNCTION MUMPS_FMRD_IS_MAPROW_STORED
61C
62       SUBROUTINE MUMPS_FMRD_INIT( INITIAL_SIZE, INFO )
63C
64C      Purpose:
65C      =======
66C
67C      Module initialization
68C
69C      Arguments
70C      =========
71C
72       INTEGER, INTENT(IN) :: INITIAL_SIZE
73       INTEGER, INTENT(INOUT) :: INFO(2)
74C
75C      Local variables
76C      ===============
77C
78       INTEGER :: I, IERR
79C
80       ALLOCATE(FMRD_ARRAY( INITIAL_SIZE ), stat=IERR)
81       IF (IERR > 0 ) THEN
82         INFO(1)=-13
83         INFO(2)=INITIAL_SIZE
84         RETURN
85       ENDIF
86       DO I=1, INITIAL_SIZE
87         FMRD_ARRAY(I)%INODE=-9999
88         NULLIFY(FMRD_ARRAY(I)%SLAVES_PERE)
89         NULLIFY(FMRD_ARRAY(I)%TROW)
90       ENDDO
91       RETURN
92       END SUBROUTINE MUMPS_FMRD_INIT
93C
94       SUBROUTINE MUMPS_FMRD_SAVE_MAPROW(
95     &   IWHANDLER,
96     &   INODE, ISON, NSLAVES_PERE, NFRONT_PERE,
97     &              NASS_PERE, LMAP, NFS4FATHER,
98     &   SLAVES_PERE, !size NSLAVES_PERE
99     &   TROW,        !size LMAP
100     &   INFO)
101C
102C      Arguments:
103C      =========
104C
105       INTEGER, INTENT(IN) :: INODE, ISON, NSLAVES_PERE, NFRONT_PERE,
106     &                        NASS_PERE, LMAP, NFS4FATHER
107       INTEGER, INTENT(IN) :: SLAVES_PERE (max(1,NSLAVES_PERE))
108       INTEGER, INTENT(IN) :: TROW( LMAP)
109       INTEGER, INTENT(INOUT) :: IWHANDLER, INFO(2)
110C
111C      Local variables:
112C      ===============
113C
114       TYPE(MAPROW_STRUC_T) :: MAPROW_STRUC
115C
116       CALL MUMPS_FMRD_FILL_MAPROW( MAPROW_STRUC,
117     &   INODE, ISON, NSLAVES_PERE, NFRONT_PERE,
118     &              NASS_PERE, LMAP, NFS4FATHER,
119     &   SLAVES_PERE, !size NSLAVES_PERE
120     &   TROW,        !size LMAP
121     &   INFO)
122       IF (INFO(1) .LT. 0) RETURN
123       CALL MUMPS_FMRD_STORE_MAPROW(IWHANDLER, MAPROW_STRUC, INFO)
124       RETURN
125       END SUBROUTINE MUMPS_FMRD_SAVE_MAPROW
126C
127       SUBROUTINE MUMPS_FMRD_STORE_MAPROW(IWHANDLER, MAPROW_STRUC, INFO)
128       USE MUMPS_FRONT_DATA_MGT_M, ONLY : MUMPS_FDM_START_IDX
129C
130C      Purpose:
131C      =======
132C
133C      Given an IWHANDLER and a MAPROW structure, store the MAPROW
134C      structure into the main array of the module.
135C
136C      If IWHANDLER is larger than the current array size, the
137C      array is reallocated.
138C
139C      Arguments:
140C      =========
141C
142       INTEGER, INTENT(INOUT) :: IWHANDLER, INFO(2)
143       TYPE(MAPROW_STRUC_T), INTENT(IN) :: MAPROW_STRUC
144C
145C      Local variables:
146C      ===============
147C
148       TYPE(MAPROW_STRUC_T), POINTER, DIMENSION(:) :: FMRD_ARRAY_TMP
149       INTEGER :: OLD_SIZE, NEW_SIZE
150       INTEGER :: I
151       INTEGER :: IERR
152C
153       CALL MUMPS_FDM_START_IDX('A', 'MAPROW', IWHANDLER, INFO)
154       IF (INFO(1) .LT. 0) RETURN
155       IF (IWHANDLER > size(FMRD_ARRAY)) THEN
156C        Reallocate in a bigger array
157         OLD_SIZE = size(FMRD_ARRAY)
158         NEW_SIZE = max( (OLD_SIZE * 3) / 2 + 1, IWHANDLER)
159C
160         ALLOCATE(FMRD_ARRAY_TMP(NEW_SIZE),stat=IERR)
161         IF (IERR.GT.0) THEN
162           INFO(1)=-13
163           INFO(2)=NEW_SIZE
164           RETURN
165         ENDIF
166         DO I=1, OLD_SIZE
167           FMRD_ARRAY_TMP(I)=FMRD_ARRAY(I)
168         ENDDO
169C        Similar to code in MUMPS_FMRD_INIT:
170         DO I=OLD_SIZE+1, NEW_SIZE
171           FMRD_ARRAY_TMP(I)%INODE = -9999
172           NULLIFY(FMRD_ARRAY_TMP(I)%SLAVES_PERE)
173           NULLIFY(FMRD_ARRAY_TMP(I)%TROW)
174         ENDDO
175         DEALLOCATE(FMRD_ARRAY)
176         FMRD_ARRAY=>FMRD_ARRAY_TMP
177         NULLIFY(FMRD_ARRAY_TMP)
178       ENDIF
179       FMRD_ARRAY(IWHANDLER) = MAPROW_STRUC
180       RETURN
181       END SUBROUTINE MUMPS_FMRD_STORE_MAPROW
182       SUBROUTINE MUMPS_FMRD_FILL_MAPROW(MAPROW_STRUC,
183     &   INODE, ISON, NSLAVES_PERE, NFRONT_PERE,
184     &              NASS_PERE, LMAP, NFS4FATHER,
185     &   SLAVES_PERE, !size NSLAVES_PERE
186     &   TROW,        !size LMAP
187     &   INFO)
188C
189C      Purpose:
190C      =======
191C      Fill the MAPROW_STRUC into
192C
193C      Arguments:
194C      =========
195C
196       INTEGER, INTENT(IN) :: INODE, ISON, NSLAVES_PERE, NFRONT_PERE,
197     &              NASS_PERE, LMAP, NFS4FATHER
198       INTEGER, INTENT(IN) :: SLAVES_PERE(max(1,NSLAVES_PERE))
199       INTEGER, INTENT(IN) :: TROW( LMAP)
200       TYPE (MAPROW_STRUC_T), INTENT(OUT) :: MAPROW_STRUC
201       INTEGER, INTENT(INOUT) :: INFO(2)
202C
203C      Local variables:
204C      ===============
205C
206       INTEGER :: IERR, I
207C
208       MAPROW_STRUC%INODE        = INODE
209       MAPROW_STRUC%ISON         = ISON
210       MAPROW_STRUC%NSLAVES_PERE = NSLAVES_PERE
211       MAPROW_STRUC%NFRONT_PERE  = NFRONT_PERE
212       MAPROW_STRUC%NASS_PERE    = NASS_PERE
213       MAPROW_STRUC%LMAP         = LMAP
214       MAPROW_STRUC%NFS4FATHER   = NFS4FATHER
215       ALLOCATE(MAPROW_STRUC%SLAVES_PERE(max(1,NSLAVES_PERE)),
216     &            MAPROW_STRUC%TROW(LMAP), stat=IERR)
217       IF (IERR .GT.0) THEN
218           INFO(1) = -13
219           INFO(2) = NSLAVES_PERE + LMAP
220           RETURN
221       ENDIF
222       DO I=1, NSLAVES_PERE
223           MAPROW_STRUC%SLAVES_PERE(I) = SLAVES_PERE(I)
224       ENDDO
225       DO I=1, LMAP
226           MAPROW_STRUC%TROW(I) = TROW(I)
227       ENDDO
228       RETURN
229       END SUBROUTINE MUMPS_FMRD_FILL_MAPROW
230C
231       SUBROUTINE MUMPS_FMRD_FREE_MAPROW_STRUC(IWHANDLER)
232       USE MUMPS_FRONT_DATA_MGT_M, ONLY : MUMPS_FDM_END_IDX
233C
234C      Purpose:
235C      =======
236C
237C      Free internal arrays of MAPROW_STRUC.
238C      Typically used after a MAPROW_STRUC has been retrieved
239C      from the module and late-received message has finally
240C      been processed.
241C
242C      MAPROW_STRUC normally corresponds to a local variable
243C      of the calling routine and will not be reused.
244C
245C      Arguments:
246C      =========
247C
248       INTEGER, INTENT(INOUT) :: IWHANDLER
249C
250C      Local variables:
251C      ===============
252C
253       TYPE (MAPROW_STRUC_T), POINTER :: MAPROW_STRUC
254C
255       MAPROW_STRUC => FMRD_ARRAY(IWHANDLER)
256       MAPROW_STRUC%INODE = -7777 ! Special value: negative means unused
257       DEALLOCATE(MAPROW_STRUC%SLAVES_PERE, MAPROW_STRUC%TROW)
258       NULLIFY     (MAPROW_STRUC%SLAVES_PERE, MAPROW_STRUC%TROW)
259C      Release handler IWHANDLER and store it
260C      in a new free position for future reuse
261       CALL MUMPS_FDM_END_IDX('A', 'MAPROW', IWHANDLER)
262       RETURN
263       END SUBROUTINE MUMPS_FMRD_FREE_MAPROW_STRUC
264C
265       SUBROUTINE MUMPS_FMRD_RETRIEVE_MAPROW(IWHANDLER, MAPROW_STRUC)
266C
267C      Purpose:
268C      =======
269C
270C      Given an IWHANDLER, return a pointer to a MAPROW structure,
271C      containing information on a previously received MAPROW message.
272C
273C      Arguments:
274C      =========
275C
276       INTEGER, INTENT(IN) :: IWHANDLER
277#if defined(MUMPS_F2003)
278       TYPE (MAPROW_STRUC_T), POINTER, INTENT(OUT) :: MAPROW_STRUC
279#else
280       TYPE (MAPROW_STRUC_T), POINTER :: MAPROW_STRUC
281#endif
282       MAPROW_STRUC => FMRD_ARRAY(IWHANDLER)
283       RETURN
284       END SUBROUTINE MUMPS_FMRD_RETRIEVE_MAPROW
285C
286       SUBROUTINE MUMPS_FMRD_END(INFO1)
287C
288C      Purpose:
289C      =======
290C      Module final termination.
291C
292C      Arguments:
293C      =========
294C
295       INTEGER, INTENT(IN) :: INFO1
296C      Local variables:
297C      ===============
298       INTEGER :: I, IWHANDLER
299C
300       IF (.NOT. associated(FMRD_ARRAY)) THEN
301         WRITE(*,*) "Internal error 1 in MUMPS_FAC_FMRD_END"
302         CALL MUMPS_ABORT()
303       ENDIF
304       DO I=1, size(FMRD_ARRAY)
305         IF (FMRD_ARRAY(I)%INODE .GE. 0) THEN
306C          Node is not free: possible only in
307C          case of fatal error (INFO1 < 0)
308           IF (INFO1 .GE.0) THEN
309C            Should have been freed earlier while consuming MAPLIG
310             WRITE(*,*) "Internal error 2 in MUMPS_FAC_FMRD_END",I
311             CALL MUMPS_ABORT()
312           ELSE
313C            May happen in case an error has forced finishing
314C            factorization before all MAPROW msgs were processed.
315C            We copy the loop index I in the local variable IWHANDLER
316C            because there would otherwise be a risk for the loop index
317C            I to be modified by MUMPS_FMRD_FREE_MAPROW_STRUC
318             IWHANDLER=I
319             CALL MUMPS_FMRD_FREE_MAPROW_STRUC(IWHANDLER)
320           ENDIF
321         ENDIF
322       ENDDO
323       DEALLOCATE(FMRD_ARRAY)
324       RETURN
325       END SUBROUTINE MUMPS_FMRD_END
326#endif
327       END MODULE MUMPS_FAC_MAPROW_DATA_M
328