dfac_process_band.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
      SUBROUTINE dmumps_process_desc_bande( MYID, BUFR, LBUFR, 
     &     LBUFR_BYTES,
     &     IWPOS, IWPOSCB,
     &     IPTRLU, LRLU, LRLUS,
     &     N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD,
     &     PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP,
     &     KEEP,KEEP8, DKEEP, ITLOC, RHS_MUMPS, ISTEP_TO_INIV2,
#if ! defined(NO_FDM_DESCBAND)
     &     iwhandler_in,
#endif
     &     iflag, ierror )
      USE dmumps_load
      USE dmumps_lr_data_m, ONLY: dmumps_blr_init_front,
     &                            dmumps_blr_save_nfs4father
#if ! defined(NO_FDM_DESCBAND)
      USE mumps_fac_descband_data_m
#endif
      IMPLICIT NONE
      INTEGER MYID
      INTEGER KEEP(500)
      INTEGER(8) KEEP8(150)
      DOUBLE PRECISION DKEEP(230)
      INTEGER LBUFR, LBUFR_BYTES
      INTEGER BUFR( LBUFR )
      INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA
      INTEGER IWPOS, IWPOSCB, N, LIW
      INTEGER IW( LIW )
      DOUBLE PRECISION A( LA )
      INTEGER, INTENT(IN) :: SLAVEF
      INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28))
      INTEGER(8) :: PAMASTER(KEEP(28))
      INTEGER(8) :: PTRAST(KEEP(28))
      INTEGER PTRIST(KEEP(28)), STEP(N), 
     & pimaster(keep(28)), 
     & itloc( n + keep(253) )
      DOUBLE PRECISION :: RHS_MUMPS(KEEP(255))
      INTEGER :: ISTEP_TO_INIV2(KEEP(71))
#if ! defined(NO_FDM_DESCBAND)
      INTEGER IWHANDLER_IN
#endif
      INTEGER COMP, IFLAG, IERROR
      INTEGER INODE, NBPROCFILS, NCOL, NROW, NASS, NSLAVES
      INTEGER NSLAVES_HDR, NFRONT
      INTEGER LREQ
      INTEGER :: IBUFR
      INTEGER(8) :: LREQCB
#if ! defined(NO_FDM_DESCBAND)
      INTEGER :: IWHANDLER_LOC
#endif
      DOUBLE PRECISION FLOP1
      include 'mumps_headers.h'
#if ! defined(NO_FDM_DESCBAND)
      INTEGER :: INFO_TMP(2)
#else
#endif
      INTEGER :: LRSTATUS
      INTEGER :: ESTIM_NFS4FATHER_ATSON
      LOGICAL :: LR_ACTIVATED, COMPRESS_CB
      DOUBLE PRECISION, POINTER, DIMENSION(:) :: DYNAMIC_CB
      INTEGER(8) :: TMP_ADDRESS
      INTEGER :: allocok
      INODE = bufr( 2 )
      nbprocfils = bufr( 3 )
      nrow        = bufr( 4 )
      ncol        = bufr( 5 )
      nass        = bufr( 6 )
      nfront      = bufr( 7 )
      nslaves_hdr = bufr( 8 )
      nslaves     = bufr( 9 )
      lrstatus    = bufr(10 )
      estim_nfs4father_atson = bufr(11)
      ibufr    = 12
#if ! defined(NO_FDM_DESCBAND)
      iwhandler_loc = iwhandler_in
      IF ((iwhandler_in .LE. 0) .AND.
     &   (inode .NE. inode_waited_for)) THEN
        info_tmp=0
        CALL mumps_fdbd_save_descband(inode, bufr(1), bufr,
     &                                iwhandler_loc, info_tmp)
        IF (info_tmp(1) < 0) THEN
          iflag = info_tmp(1)
          ierror = info_tmp(2)
          RETURN
        ENDIF
        GOTO 555
      ENDIF
#endif
      IF ( keep(50) .eq. 0 ) THEN
         flop1 = dble( nass * nrow ) +
     &     dble(nrow*nass)*dble(2*ncol-nass-1)
      ELSE
         flop1 = dble( nass ) * dble( nrow )
     &            * dble( 2 * ncol - nrow - nass + 1)
      END IF
      CALL dmumps_load_update(1,.true.,flop1, keep,keep8)
      IF ( keep(50) .eq. 0 ) THEN
        nslaves = nslaves_hdr + xtra_slaves_unsym
      ELSE
        nslaves = nslaves_hdr + xtra_slaves_sym   
      END IF
      lreq   = nrow + ncol + 6 + nslaves + keep(ixsz)
      lreqcb = int(ncol,8) * int(nrow,8)
      IF ( lreqcb .GT. lrlus .AND. keep(101) .EQ. 0 .AND.
     &     keep8(73) + lreqcb .LE. keep8(75) ) THEN
        CALL dmumps_alloc_cb(.false., 0_8, .false.,.true.,
     &       myid,n, keep, keep8, dkeep, iw, liw, a, la,
     &       lrlu, iptrlu,iwpos,iwposcb, slavef, procnode_steps, dad,
     &       ptrist,ptrast, step, pimaster,pamaster,
     &       lreq, 0_8, 
     &       inode, s_active, .true.,
     &       comp, lrlus, keep8(67), iflag, ierror
     &     )
        IF ( iflag .LT. 0 ) RETURN
#if defined(MUMPS_ALLOC_FROM_C)
        CALL mumps_malloc_c( tmp_address,
     &      lreqcb * int(keep(35),8) )
        IF (tmp_address .EQ. 0_8) THEN
          allocok=1 
        ELSE 
          allocok=0
        ENDIF
#else
        ALLOCATE(dynamic_cb(lreqcb), stat=allocok)
#endif
        IF (allocok .GT. 0) THEN
          CALL dmumps_free_block_cb_static( .false., myid, n,
     &    iwposcb + 1, iw, liw, lrlu, lrlus, iptrlu, iwposcb,
     &    la, keep, keep8, .false. )
        ELSE
          CALL mumps_dm_fac_upd_dyn_memcnts( lreqcb,
     &    keep(405).EQ.1, 
     &    keep8, iflag, ierror,
     &    .true., 
     &    .false. ) 
#if ! defined(MUMPS_ALLOC_FROM_C)
          CALL mumps_addr_c( dynamic_cb(1), tmp_address )
#endif
          CALL mumps_storei8(lreqcb, iw(iwposcb+1+xxd))
          ptrist(step(inode)) = iwposcb + 1
          ptrast(step(inode)) = tmp_address
        ENDIF
      ENDIF
      IF ( ptrist(step(inode)) .EQ. 0 ) THEN
        CALL dmumps_alloc_cb(.false., 0_8, .false.,.true.,
     &     myid,n, keep, keep8, dkeep, iw, liw, a, la,
     &     lrlu, iptrlu,iwpos,iwposcb, slavef, procnode_steps, dad,
     &     ptrist,ptrast, step, pimaster,pamaster,
     &     lreq, lreqcb, inode, s_active, .true.,
     &     comp, lrlus, keep8(67), iflag, ierror
     &     )
        IF ( iflag .LT. 0 ) RETURN
        ptrist(step(inode)) = iwposcb + 1
        ptrast(step(inode)) = iptrlu  + 1_8
      ENDIF
#     if ! defined(NO_FDM_DESCBAND)
 555  CONTINUE
#     endif
#     if ! defined(NO_FDM_DESCBAND)
        IF ((iwhandler_in .LE. 0) .AND.
     &     (inode .NE. inode_waited_for)) THEN
          RETURN
        ENDIF
        iw(iwposcb+1+xxa) = iwhandler_loc
#     endif
        iw(iwposcb+1+xxf) = -9999
      iw( iwposcb + 1+keep(ixsz) ) = ncol
      iw( iwposcb + 2+keep(ixsz) ) = - nass
      iw( iwposcb + 3+keep(ixsz) ) = nrow
      iw( iwposcb + 4+keep(ixsz) ) = 0
      iw( iwposcb + 5+keep(ixsz) ) = nass
      iw( iwposcb + 6+keep(ixsz) ) = nslaves
      iw( iwposcb + 7+keep(ixsz)+nslaves : 
     &           iwposcb + 6+keep(ixsz)+nslaves + nrow + ncol )
     &= bufr( ibufr + nslaves_hdr :
     &        ibufr + nslaves_hdr + nrow + ncol - 1 )
      IF ( keep(50) .eq. 0 ) THEN
        iw( iwposcb + 7+keep(ixsz) ) = s_rootband_init
        IF (nslaves_hdr.GT.0) THEN
          write(6,*) " Internal error in DMUMPS_PROCESS_DESC_BANDE "
          CALL mumps_abort()
        ENDIF
      ELSE
        iw( iwposcb+7+keep(ixsz) ) = huge(iw(iwposcb+7+keep(ixsz)))
        iw( iwposcb + 8+keep(ixsz) ) = nfront
        iw( iwposcb + 9+keep(ixsz) ) = s_rootband_init
        iw( iwposcb + 7+xtra_slaves_sym+keep(ixsz):
     &      iwposcb + 6+xtra_slaves_sym+keep(ixsz)+nslaves_hdr ) =
     &       bufr( ibufr: ibufr - 1 + nslaves_hdr )
      END IF
      iw(iwposcb+1+xxnbpr)=nbprocfils
      iw(iwposcb+1+xxlr)=lrstatus
      compress_cb    = ((lrstatus.EQ.1).OR.
     &                  (lrstatus.EQ.3))
      lr_activated   = (lrstatus.GT.0)
      IF (lr_activated.AND.
     &       (keep(480).NE.0
     &       .OR.
     &       (
     &         (keep(486).EQ.2) 
     &       )
     &       .OR.compress_cb
     &       )) THEN
         info_tmp=0
         CALL dmumps_blr_init_front (iw(iwposcb+1+xxf), info_tmp) 
         IF (info_tmp(1).LT.0)  THEN
          iflag = info_tmp(1)
          ierror = info_tmp(2)
          RETURN
         ENDIF
         IF (compress_cb.AND.
     &     (keep(219).NE.0).AND.(keep(50).EQ.2).AND.
     &     (estim_nfs4father_atson.GE.0)
     &    ) THEN
            CALL dmumps_blr_save_nfs4father ( iw(iwposcb+1+xxf),
     &             estim_nfs4father_atson )
         ENDIF
      ENDIF
      IF (nbprocfils .EQ. 0) THEN
      ENDIF
      RETURN
      END SUBROUTINE dmumps_process_desc_bande
      RECURSIVE SUBROUTINE dmumps_treat_descband( INODE,
     &    COMM_LOAD, ASS_IRECV,
     &    BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC,
     &    IWPOS, IWPOSCB, IPTRLU,
     &    LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST,
     &    PTLUST, PTRFAC,
     &    PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP,
     &    IFLAG, IERROR, COMM, PERM,
     &    IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF,
     &
     &    root, OPASSW, OPELIW, ITLOC, RHS_MUMPS,
     &    FILS, DAD, PTRARW, PTRAIW,
     &    INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE,
     &    LPTRAR, NELT, FRTPTR, FRTELT,
     &
     &    ISTEP_TO_INIV2, TAB_POS_IN_PERE,
     &    STACK_RIGHT_AUTHORIZED
     &    , LRGROUPS
     & )
#     if ! defined(NO_FDM_DESCBAND)
      USE mumps_fac_descband_data_m
#     endif
      USE dmumps_struc_def, ONLY : dmumps_root_struc
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: inode  
      TYPE (dmumps_root_struc) :: root
      INTEGER keep(500), icntl(60)
      INTEGER(8) keep8(150)
      DOUBLE PRECISION       dkeep(230)
      INTEGER lbufr, lbufr_bytes
      INTEGER comm_load, ass_irecv
      INTEGER bufr( lbufr )
      INTEGER(8) :: la, posfac, iptrlu, lrlu, lrlus
      INTEGER iwpos, iwposcb
      INTEGER n, liw
      INTEGER iw( liw )
      DOUBLE PRECISION a( la )
      INTEGER, intent(in) :: lrgroups(n)
      INTEGER(8) :: ptrast(keep(28))
      INTEGER(8) :: ptrfac(keep(28))
      INTEGER(8) :: pamaster(keep(28))
      INTEGER ptrist( keep(28) ),
     &        ptlust(keep(28))
      INTEGER step(n),
     & pimaster(keep(28))
      INTEGER comp
      INTEGER nstk_s(KEEP(28)), procnode_steps( keep(28) )
      INTEGER perm(n)
      INTEGER iflag, ierror, comm
      INTEGER lpool, leaf
      INTEGER ipool( lpool )
      INTEGER myid, slavef, nbfin
      DOUBLE PRECISION opassw, opeliw
      INTEGER nelt, lptrar
      INTEGER frtptr( n+1 ), frtelt( nelt )
      INTEGER itloc( n + KEEP(253) ), fils( N ), dad( keep(28) )
      DOUBLE PRECISION :: rhs_mumps(keep(255))
      INTEGER(8), INTENT(IN) :: ptrarw( lptrar ), ptraiw( lptrar )
      INTEGER nd( keep(28) ), frere( keep(28) )
      INTEGER istep_to_iniv2(keep(71)),
     &        tab_pos_in_pere(slavef+2,max(1,keep(56)))
      DOUBLE PRECISION dblarr( keep8(26) )
      INTEGER intarr( keep8(27) )
      LOGICAL, intent(in) :: stack_right_authorized
      include 'mpif.h'
      INCLUDE 'mumps_tags.h'
      INCLUDE 'mumps_headers.h'
      LOGICAL :: BLOCKING, SET_IRECV, MESSAGE_RECEIVED
      INTEGER :: STATUS(MPI_STATUS_SIZE)
      INTEGER :: SRC_DESCBAND
#if ! defined(NO_FDM_DESCBAND)
      INTEGER :: IWHANDLER
      TYPE(DESCBAND_STRUC_T), POINTER :: DESCBAND_STRUC
#endif
      INTEGER MUMPS_PROCNODE
      EXTERNAL MUMPS_PROCNODE
      SRC_DESCBAND = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)),
     &           KEEP(199) )
#     if ! defined(NO_FDM_DESCBAND)
      IF (MUMPS_FDBD_IS_DESCBAND_STORED( INODE, IWHANDLER )) THEN 
        CALL MUMPS_FDBD_RETRIEVE_DESCBAND(IWHANDLER, DESCBAND_STRUC)
        CALL DMUMPS_PROCESS_DESC_BANDE( MYID, DESCBAND_STRUC%BUFR(1),
     &       DESCBAND_STRUC%LBUFR,
     &       LBUFR_BYTES,
     &       IWPOS, IWPOSCB,
     &       IPTRLU, LRLU, LRLUS,
     &       N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD,
     &       PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP,
     &       KEEP, KEEP8, DKEEP, ITLOC, RHS_MUMPS, ISTEP_TO_INIV2,
     &       IWHANDLER,
     &       IFLAG, IERROR )
.LT.        IF (IFLAG  0) GOTO 500 
        CALL MUMPS_FDBD_FREE_DESCBAND_STRUC(IW(PTRIST(STEP(INODE))+XXA))
      ELSE 
.GT.         IF (INODE_WAITED_FOR0) THEN
          WRITE(*,*) " Internal error 1 in DMUMPS_TREAT_DESCBAND",
     &    INODE, INODE_WAITED_FOR
          CALL MUMPS_ABORT()
        ENDIF
        INODE_WAITED_FOR = INODE
#     endif
.EQ.      DO WHILE (PTRIST(STEP(INODE))  0)
        BLOCKING = .TRUE.
        SET_IRECV = .FALSE.
        MESSAGE_RECEIVED = .FALSE.
        CALL DMUMPS_TRY_RECVTREAT(COMM_LOAD,
     &    ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED,
     &    SRC_DESCBAND, MAITRE_DESC_BANDE,
     &    STATUS, 
     &    BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC,
     &    IWPOS, IWPOSCB, IPTRLU,
     &    LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST,
     &    PTLUST, PTRFAC,
     &    PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP,
     &    IFLAG, IERROR, COMM,
     &    PERM, IPOOL, LPOOL, LEAF,
     &    NBFIN, MYID, SLAVEF,
     &    root, OPASSW, OPELIW, ITLOC, RHS_MUMPS,
     &    FILS, DAD, PTRARW, PTRAIW,
     &    INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE,
     &    LPTRAR, NELT, FRTPTR, FRTELT, 
     &    ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. 
     &    , LRGROUPS
     &    )
.LT.        IF (IFLAG  0) THEN
          RETURN
        ENDIF
      ENDDO
#     if ! defined(NO_FDM_DESCBAND)
        INODE_WAITED_FOR = -1
      ENDIF
#     endif
      RETURN
 500  CONTINUE
      CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP )
      RETURN
      END SUBROUTINE DMUMPS_TREAT_DESCBAND