fac_descband_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_descband_data_m
       IMPLICIT NONE
#if ! defined(NO_FDM_DESCBAND)
       INTEGER, SAVE :: inode_waited_for
       PRIVATE
       PUBLIC :: descband_struc_t, mumps_fdbd_init, mumps_fdbd_end,
     &         mumps_fdbd_save_descband, mumps_fdbd_is_descband_stored,
     &         mumps_fdbd_retrieve_descband,
     &         mumps_fdbd_free_descband_struc,
     &         inode_waited_for
       TYPE descband_struc_t
         INTEGER :: inode, lbufr
         INTEGER, POINTER, DIMENSION(:) :: bufr
       END TYPE descband_struc_t
       TYPE (descband_struc_t), POINTER, DIMENSION(:), SAVE::fdbd_array
       CONTAINS
       SUBROUTINE mumps_fdbd_init( INITIAL_SIZE, INFO )
       INTEGER, INTENT(IN) :: initial_size
       INTEGER, INTENT(INOUT) :: info(2)
       INTEGER :: i, ierr
       ALLOCATE(fdbd_array( initial_size ), stat=ierr)
       IF (ierr > 0 ) THEN
         info(1)=-13
         info(2)=initial_size
         RETURN
       ENDIF
       DO i=1, initial_size
         fdbd_array(i)%INODE=-9999
         fdbd_array(i)%LBUFR=-9999
         NULLIFY(fdbd_array(i)%BUFR)
       ENDDO
       inode_waited_for = -1
       RETURN
       END SUBROUTINE mumps_fdbd_init
       FUNCTION mumps_fdbd_is_descband_stored( INODE, IWHANDLER )
       LOGICAL :: mumps_fdbd_is_descband_stored 
       INTEGER, INTENT(IN) :: inode
       INTEGER, INTENT(OUT) :: iwhandler
       INTEGER :: i
       DO i = 1, size(fdbd_array)
         IF (fdbd_array(i)%INODE .EQ. inode) THEN
           iwhandler = i
           mumps_fdbd_is_descband_stored = .true.
           RETURN
         ENDIF
       ENDDO
       mumps_fdbd_is_descband_stored = .false.
       RETURN
       END FUNCTION mumps_fdbd_is_descband_stored
       SUBROUTINE mumps_fdbd_save_descband(INODE, LBUFR, BUFR,
     &                                     IWHANDLER, INFO)
       USE mumps_front_data_mgt_m, ONLY : mumps_fdm_start_idx
       INTEGER, INTENT(IN) :: inode, lbufr, bufr(lbufr)
       INTEGER, INTENT(INOUT) :: info(2)
       INTEGER, INTENT(OUT) :: iwhandler
       TYPE(descband_struc_t), POINTER, DIMENSION(:) :: fdbd_array_tmp
       INTEGER :: old_size, new_size, I, ierr
       iwhandler = -1
       CALL mumps_fdm_start_idx('A', 'DESCBAND', iwhandler, info)
       IF (info(1) .LT. 0) RETURN
       IF (iwhandler > size(fdbd_array)) THEN
         old_size = size(fdbd_array)
         new_size = max( (old_size * 3) / 2 + 1, iwhandler)
         ALLOCATE(fdbd_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
           fdbd_array_tmp(i)=fdbd_array(i)
         ENDDO
         DO i=old_size+1, new_size
           fdbd_array_tmp(i)%INODE = -9999
           fdbd_array_tmp(i)%LBUFR = -9999
           NULLIFY(fdbd_array_tmp(i)%BUFR)
         ENDDO
         DEALLOCATE(fdbd_array)
         fdbd_array=>fdbd_array_tmp
         NULLIFY(fdbd_array_tmp)
       ENDIF
       fdbd_array(iwhandler)%INODE = inode
       fdbd_array(iwhandler)%LBUFR = lbufr
       ALLOCATE(fdbd_array(iwhandler)%BUFR(lbufr), stat=ierr)
       IF (ierr > 0 ) THEN
         info(1)=-13
         info(2)=lbufr
         RETURN
       ENDIF
       fdbd_array(iwhandler)%BUFR = bufr
       RETURN
       END SUBROUTINE mumps_fdbd_save_descband
       SUBROUTINE mumps_fdbd_retrieve_descband(IWHANDLER,DESCBAND_STRUC)
       INTEGER, INTENT(IN) :: iwhandler
#if defined(MUMPS_F2003)
       TYPE (descband_struc_t), POINTER, INTENT(OUT) :: descband_struc
#else
       TYPE (descband_struc_t), POINTER :: descband_struc
#endif
       descband_struc => fdbd_array(iwhandler)
       RETURN
       END SUBROUTINE mumps_fdbd_retrieve_descband
       SUBROUTINE mumps_fdbd_free_descband_struc(IWHANDLER)
       USE mumps_front_data_mgt_m, ONLY : mumps_fdm_end_idx
       INTEGER, INTENT(INOUT) :: iwhandler
       TYPE (descband_struc_t), POINTER :: descband_struc
       descband_struc => fdbd_array(iwhandler)
       descband_struc%INODE = -7777 
       descband_struc%LBUFR = -7777
       DEALLOCATE(descband_struc%BUFR)
       NULLIFY(descband_struc%BUFR)
       CALL mumps_fdm_end_idx('A', 'DESCBAND', iwhandler)
       RETURN
       END SUBROUTINE mumps_fdbd_free_descband_struc
       SUBROUTINE mumps_fdbd_end(INFO1)
       INTEGER, INTENT(IN) :: info1
       INTEGER :: i, iwhandler
       IF (.NOT. associated(fdbd_array)) THEN
         WRITE(*,*) "Internal error 1 in MUMPS_FAC_FDBD_END"
         CALL mumps_abort()
       ENDIF
       DO i=1, size(fdbd_array)
         IF (fdbd_array(i)%INODE .GE. 0) THEN
           IF (info1 .GE.0) THEN
             WRITE(*,*) "Internal error 2 in MUMPS_FAC_FDBD_END",i
             CALL mumps_abort()
           ELSE
             iwhandler=i
             CALL mumps_fdbd_free_descband_struc(iwhandler)
           ENDIF
         ENDIF
       ENDDO
       DEALLOCATE(fdbd_array)
       RETURN
       END SUBROUTINE mumps_fdbd_end
#endif
       END MODULE mumps_fac_descband_data_m