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