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