fac_maprow_data_m.F

Go to the documentation of this file.

C
C  This file is part of MUMPS 5.5.1, released
C  on Tue Jul 12 13:17:24 UTC 2022
C
C
C  Copyright 1991-2022 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria,
C  Mumps Technologies, University of Bordeaux.
C
C  This version of MUMPS is provided to you free of charge. It is
C  released under the CeCILL-C license 
C  (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and
C  https://cecill.info/licences/Licence_CeCILL-C_V1-en.html)
C
       MODULE mumps_fac_maprow_data_m
       IMPLICIT NONE
#if ! defined(NO_FDM_MAPROW)
C      =========================================
C      The MUMPS_FAC_MAPROW_DATA_M module stores
C      the MAPROW messages that arrive too early.
C      It is based on the MUMPS_FRONT_DATA_MGT_M
C      module.
C
C      An array of structures that contain MAPROW
C      information is used as a global variable in
C      this module. It is indexed by an "IWHANDLER"
C      (stored in the main IW array) that is
C      managed by the MUMPS_FRONT_DATA_MGT_M module.
C
C      The same handler can be used for other data
C      stored for active type 2 fronts (DESCBAND
C      information, typically)
C      ========================================
C
       PRIVATE
       PUBLIC :: maprow_struc_t, mumps_fmrd_init, mumps_fmrd_end,
     &           mumps_fmrd_save_maprow, mumps_fmrd_is_maprow_stored,
     &           mumps_fmrd_retrieve_maprow,
     &           mumps_fmrd_free_maprow_struc
       TYPE maprow_struc_t
         INTEGER :: inode, ison, nslaves_pere, nfront_pere,
     &              nass_pere, lmap, nfs4father
         INTEGER,POINTER, DIMENSION(:) :: slaves_pere !size NSLAVES_PERE
         INTEGER,POINTER, DIMENSION(:) :: trow        !size LMAP
       END TYPE maprow_struc_t
       TYPE (maprow_struc_t), POINTER, DIMENSION(:), SAVE :: fmrd_array
       CONTAINS
       FUNCTION mumps_fmrd_is_maprow_stored( IWHANDLER )
       LOGICAL :: mumps_fmrd_is_maprow_stored 
       INTEGER, INTENT(IN) :: iwhandler
       IF (iwhandler .LT. 0 .OR. iwhandler .GT. size(fmrd_array)) THEN
         mumps_fmrd_is_maprow_stored = .false.
       ELSE
         mumps_fmrd_is_maprow_stored =
     &                           (fmrd_array(iwhandler)%INODE .GE. 0 )
         IF (fmrd_array(iwhandler)%INODE .EQ.0) THEN
           WRITE(*,*) " Internal error 1 in MUMPS_FMRD_IS_MAPROW_STORED"
           CALL mumps_abort()
         ENDIF
       ENDIF
       RETURN
       END FUNCTION mumps_fmrd_is_maprow_stored
C
       SUBROUTINE mumps_fmrd_init( INITIAL_SIZE, INFO )
C
C      Purpose:
C      =======
C
C      Module initialization
C
C      Arguments
C      =========
C
       INTEGER, INTENT(IN) :: initial_size
       INTEGER, INTENT(INOUT) :: info(2)
c
C      Local variables
C      ===============
C
       INTEGER :: i, ierr
C
       ALLOCATE(fmrd_array( initial_size ), stat=ierr)
       IF (ierr > 0 ) THEN
         info(1)=-13
         info(2)=initial_size
         RETURN
       ENDIF
       DO i=1, initial_size
         fmrd_array(i)%INODE=-9999
         NULLIFY(fmrd_array(i)%SLAVES_PERE)
         NULLIFY(fmrd_array(i)%TROW)
       ENDDO
       RETURN
       END SUBROUTINE mumps_fmrd_init
C
       SUBROUTINE mumps_fmrd_save_maprow(
     &   IWHANDLER, 
     &   INODE, ISON, NSLAVES_PERE, NFRONT_PERE,
     &              NASS_PERE, LMAP, NFS4FATHER,
     &   SLAVES_PERE, !size NSLAVES_PERE
     &   TROW,        !size LMAP
     &   INFO)
C
C      Arguments:
C      =========
C
       INTEGER, INTENT(IN) :: inode, ison, nslaves_pere, nfront_pere,
     &                        nass_pere, lmap, nfs4father
       INTEGER, INTENT(IN) :: slaves_pere (max(1,nslaves_pere))
       INTEGER, INTENT(IN) :: trow( lmap)
       INTEGER, INTENT(INOUT) :: iwhandler, info(2)
C
C      Local variables:
C      ===============
C
       TYPE(MAPROW_STRUC_T) :: maprow_struc
C
       CALL mumps_fmrd_fill_maprow( maprow_struc,
     &   inode, ison, nslaves_pere, nfront_pere,
     &              nass_pere, lmap, nfs4father,
     &   slaves_pere, !size NSLAVES_PERE
     &   trow,        !size LMAP
     &   info)
       IF (info(1) .LT. 0) RETURN
       CALL mumps_fmrd_store_maprow(iwhandler, maprow_struc, info)
       RETURN
       END SUBROUTINE mumps_fmrd_save_maprow
C
       SUBROUTINE mumps_fmrd_store_maprow(IWHANDLER, MAPROW_STRUC, INFO)
       USE mumps_front_data_mgt_m, ONLY : mumps_fdm_start_idx
C
C      Purpose:
C      =======
C
C      Given an IWHANDLER and a MAPROW structure, store the MAPROW
C      structure into the main array of the module.
C
C      If IWHANDLER is larger than the current array size, the
C      array is reallocated.
C
C      Arguments:
C      =========
C
       INTEGER, INTENT(INOUT) :: IWHANDLER, INFO(2)
       TYPE(MAPROW_STRUC_T), INTENT(IN) :: MAPROW_STRUC
C
C      Local variables:
C      ===============
C
       TYPE(maprow_struc_t), POINTER, DIMENSION(:) :: FMRD_ARRAY_TMP
       INTEGER :: OLD_SIZE, NEW_SIZE
       INTEGER :: I
       INTEGER :: IERR
C
       CALL MUMPS_FDM_START_IDX('A', 'MAPROW', IWHANDLER, INFO)
       IF (info(1) .LT. 0) RETURN
       IF (iwhandler > size(fmrd_array)) THEN
C        Reallocate in a bigger array
         old_size = size(fmrd_array)
         new_size = max( (old_size * 3) / 2 + 1, iwhandler)
C        
         ALLOCATE(fmrd_array_tmp(new_size),stat=ierr)
         IF (ierr.GT.0) THEN
           info(1)=-13
           info(2)=new_size
           RETURN
         ENDIF
         DO i=1, old_size
           fmrd_array_tmp(i)=fmrd_array(i)
         ENDDO
C        Similar to code in MUMPS_FMRD_INIT:
         DO i=old_size+1, new_size
           fmrd_array_tmp(i)%INODE = -9999
           NULLIFY(fmrd_array_tmp(i)%SLAVES_PERE)
           NULLIFY(fmrd_array_tmp(i)%TROW)
         ENDDO
         DEALLOCATE(fmrd_array)
         fmrd_array=>fmrd_array_tmp
         NULLIFY(fmrd_array_tmp)
       ENDIF
       fmrd_array(iwhandler) = maprow_struc
       RETURN
       END SUBROUTINE mumps_fmrd_store_maprow
       SUBROUTINE mumps_fmrd_fill_maprow(MAPROW_STRUC,
     &   INODE, ISON, NSLAVES_PERE, NFRONT_PERE,
     &              NASS_PERE, LMAP, NFS4FATHER,
     &   SLAVES_PERE, !size NSLAVES_PERE
     &   TROW,        !size LMAP
     &   INFO)
C
C      Purpose:
C      =======
C      Fill the MAPROW_STRUC into
C
C      Arguments:
C      =========
C
       INTEGER, INTENT(IN) :: INODE, ISON, NSLAVES_PERE, NFRONT_PERE,
     &              NASS_PERE, LMAP, NFS4FATHER
       INTEGER, INTENT(IN) :: SLAVES_PERE(max(1,NSLAVES_PERE))
       INTEGER, INTENT(IN) :: TROW( LMAP)
       TYPE (MAPROW_STRUC_T), INTENT(OUT) :: MAPROW_STRUC
       INTEGER, INTENT(INOUT) :: INFO(2)
C
C      Local variables:
C      ===============
C
       INTEGER :: IERR, I
C
       maprow_struc%INODE        = inode
       maprow_struc%ISON         = ison
       maprow_struc%NSLAVES_PERE = nslaves_pere
       maprow_struc%NFRONT_PERE  = nfront_pere
       maprow_struc%NASS_PERE    = nass_pere
       maprow_struc%LMAP         = lmap
       maprow_struc%NFS4FATHER   = nfs4father
       ALLOCATE(maprow_struc%SLAVES_PERE(max(1,nslaves_pere)),
     &            maprow_struc%TROW(lmap), stat=ierr)
       IF (ierr .GT.0) THEN
           info(1) = -13
           info(2) = nslaves_pere + lmap
           RETURN
       ENDIF
       DO i=1, nslaves_pere
           maprow_struc%SLAVES_PERE(i) = slaves_pere(i)
       ENDDO
       DO i=1, lmap
           maprow_struc%TROW(i) = trow(i)
       ENDDO
       RETURN
       END SUBROUTINE mumps_fmrd_fill_maprow
C
       SUBROUTINE mumps_fmrd_free_maprow_struc(IWHANDLER)
       USE mumps_front_data_mgt_m, ONLY : mumps_fdm_end_idx
C
C      Purpose:
C      =======
C
C      Free internal arrays of MAPROW_STRUC.
C      Typically used after a MAPROW_STRUC has been retrieved
C      from the module and late-received message has finally
C      been processed.
C
C      MAPROW_STRUC normally corresponds to a local variable
C      of the calling routine and will not be reused.
C
C      Arguments:
C      =========
C
       INTEGER, INTENT(INOUT) :: iwhandler
C
C      Local variables:
C      ===============
C
       TYPE (maprow_struc_t), POINTER :: maprow_struc
C
       maprow_struc => fmrd_array(iwhandler)
       maprow_struc%INODE = -7777 ! Special value: negative means unused
       DEALLOCATE(maprow_struc%SLAVES_PERE, maprow_struc%TROW)
       NULLIFY     (maprow_struc%SLAVES_PERE, maprow_struc%TROW)
C      Release handler IWHANDLER and store it
C      in a new free position for future reuse
       CALL mumps_fdm_end_idx('A', 'maprow', IWHANDLER)
       RETURN
       END SUBROUTINE MUMPS_FMRD_FREE_MAPROW_STRUC
C
       SUBROUTINE MUMPS_FMRD_RETRIEVE_MAPROW(IWHANDLER, MAPROW_STRUC)
C
C      Purpose:
C      =======
C
C      Given an IWHANDLER, return a pointer to a MAPROW structure,
C      containing information on a previously received MAPROW message.
C
C      Arguments:
C      =========
C
       INTEGER, INTENT(IN) :: IWHANDLER
#if defined(MUMPS_F2003)
       TYPE (MAPROW_STRUC_T), POINTER, INTENT(OUT) :: MAPROW_STRUC
#else
       TYPE (MAPROW_STRUC_T), POINTER :: MAPROW_STRUC
#endif
       MAPROW_STRUC => FMRD_ARRAY(IWHANDLER)
       RETURN
       END SUBROUTINE MUMPS_FMRD_RETRIEVE_MAPROW
C
       SUBROUTINE MUMPS_FMRD_END(INFO1)
C
C      Purpose:
C      =======
C      Module final termination.
C
C      Arguments:
C      =========
C
       INTEGER, INTENT(IN) :: INFO1
C      Local variables:
C      ===============
       INTEGER :: I, IWHANDLER
C
.NOT.       IF ( associated(FMRD_ARRAY)) THEN
         WRITE(*,*) "Internal error 1 in MUMPS_FAC_FMRD_END"
         CALL MUMPS_ABORT()
       ENDIF
       DO I=1, size(FMRD_ARRAY)
.GE.         IF (FMRD_ARRAY(I)%INODE  0) THEN
C          Node is not free: possible only in
C          case of fatal error (INFO1 < 0)
.GE.            IF (INFO1 0) THEN
C            Should have been freed earlier while consuming MAPLIG
             WRITE(*,*) "Internal error 2 in MUMPS_FAC_FMRD_END",I
             CALL MUMPS_ABORT()
           ELSE
C            May happen in case an error has forced finishing
C            factorization before all MAPROW msgs were processed.
C            We copy the loop index I in the local variable IWHANDLER
C            because there would otherwise be a risk for the loop index
C            I to be modified by MUMPS_FMRD_FREE_MAPROW_STRUC
             IWHANDLER=I
             CALL MUMPS_FMRD_FREE_MAPROW_STRUC(IWHANDLER)
           ENDIF
         ENDIF
       ENDDO
       DEALLOCATE(FMRD_ARRAY)
       RETURN
       END SUBROUTINE MUMPS_FMRD_END
#endif
       END MODULE MUMPS_FAC_MAPROW_DATA_M