cfac_asm_ELT.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 cmumps_elt_asm_s_2_s_init(
     &    NELT, FRT_PTR, FRT_ELT,
     &    N, INODE, IW, LIW, A, LA, 
     &    NBROWS, NBCOLS,
     &    OPASSW, OPELIW, STEP, PTRIST, PTRAST, ITLOC,
     &    RHS_MUMPS,
     &    FILS, PTRARW, PTRAIW, INTARR, DBLARR, 
     &    ICNTL, KEEP, KEEP8, MYID, LRGROUPS)
      USE cmumps_dynamic_memory_m, ONLY : cmumps_dm_set_dynptr
      IMPLICIT NONE
      INTEGER NELT, N,LIW
      INTEGER(8) :: LA
      INTEGER KEEP(500), ICNTL(60)
      INTEGER(8) KEEP8(150)
      INTEGER INODE, MYID
      INTEGER NBROWS, NBCOLS 
      INTEGER(8) :: PTRAST(KEEP(28))
      INTEGER IW(LIW), ITLOC(N+KEEP(253)), STEP(N),
     &        ptrist(keep(28)), fils(n)
      INTEGER(8), INTENT(IN) :: PTRARW(NELT+1), PTRAIW(NELT+1)
      COMPLEX :: RHS_MUMPS(KEEP(255))
      INTEGER INTARR(KEEP8(27))
      INTEGER FRT_PTR(N+1), FRT_ELT(NELT)
      COMPLEX :: A(LA)
      COMPLEX :: DBLARR(KEEP8(26))
      DOUBLE PRECISION OPASSW, OPELIW
      INTEGER, INTENT(IN)    :: LRGROUPS(N)
      INTEGER(8) :: POSELT
      COMPLEX, DIMENSION(:), POINTER :: A_PTR
      INTEGER(8) :: LA_PTR
      INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF,
     &        k1,k2,k,j,jpos,nass
      COMPLEX ZERO
      parameter( zero = (0.0e0,0.0e0) )
      include 'mumps_headers.h'
      ioldps  = ptrist(step(inode))
      CALL cmumps_dm_set_dynptr( iw(ioldps+xxs), a, la,
     &     ptrast(step(inode)), iw(ioldps+xxd), iw(ioldps+xxr),
     &     a_ptr, poselt, la_ptr )
      nbcolf  = iw(ioldps+keep(ixsz))
      nbrowf  = iw(ioldps+2+keep(ixsz))
      nass    = iw(ioldps+1+keep(ixsz))
      nslaves = iw(ioldps+5+keep(ixsz))
      hf      = 6 + nslaves + keep(ixsz)
      IF (nass.LT.0) THEN
          nass         = -nass
          iw(ioldps+1+keep(ixsz)) = nass
          CALL cmumps_asm_slave_elements( inode, n, nelt, iw, liw,
     &    ioldps, a_ptr(poselt), la_ptr, 1_8, keep, keep8, itloc, fils,
     &    ptraiw, ptrarw,
     &    intarr, dblarr, keep8(27), keep8(26), frt_ptr, frt_elt,
     &    rhs_mumps, lrgroups)
      ENDIF
      IF (nbrows.GT.0) THEN
          k1 = ioldps + hf + nbrowf
          k2 = k1 + nbcolf - 1
          jpos = 1
          DO k = k1, k2
           j        = iw(k)
           itloc(j) = jpos
           jpos     = jpos + 1
          ENDDO
      ENDIF
      RETURN
      END SUBROUTINE cmumps_elt_asm_s_2_s_init
      SUBROUTINE cmumps_asm_slave_elements( INODE, N, NELT, IW, LIW,
     &IOLDPS, A, LA, POSELT, KEEP, KEEP8, ITLOC, FILS, PTRAIW, PTRARW,
     &INTARR, DBLARR, LINTARR, LDBLARR, FRT_PTR, FRT_ELT, RHS_MUMPS,
     &LRGROUPS)
!$    USE OMP_LIB
      USE cmumps_ana_lr,    ONLY : get_cut
      USE cmumps_lr_core,   ONLY : max_cluster
      USE mumps_lr_common,  ONLY : compute_blr_vcs
      IMPLICIT NONE
      INTEGER, intent(in)    :: N, NELT, LIW, IOLDPS, INODE
      INTEGER(8), intent(in) :: LA, POSELT, LINTARR, LDBLARR
      INTEGER, intent(in)    :: IW(LIW)
      INTEGER, intent(in)    :: KEEP(500)
      INTEGER(8), intent(in) :: KEEP8(150)
      INTEGER, intent(inout) :: ITLOC(N+KEEP(253))
      COMPLEX, intent(inout) :: A(LA)
      COMPLEX, intent(in)    :: RHS_MUMPS(KEEP(255))
      INTEGER, intent(in)    :: INTARR(LINTARR)
      COMPLEX, intent(in)    :: DBLARR(LDBLARR)
      INTEGER, intent(in)    :: FRT_PTR(N+1), FRT_ELT(NELT)
      INTEGER, intent(in)    :: FILS(N)
      INTEGER(8), intent(in) :: PTRAIW(NELT+1), PTRARW(NELT+1)
      INTEGER, INTENT(IN)    :: LRGROUPS(N)
!$    INTEGER :: NOMP
!$    INTEGER(8) :: CHUNK8  
!$    INTEGER    :: CHUNK
      include 'mumps_headers.h'
      INTEGER    :: HF, NBROWF, NBCOLF, NASS, NSLAVES
      INTEGER    :: ILOC, IELL, ELTI, ELBEG, NUMELT
      INTEGER(8) :: SIZE_ELTI8 
      INTEGER    :: I, J, K, K1, K2
      INTEGER    :: IPOS, IPOS1, IPOS2, JPOS, IJROW
      INTEGER    :: IN
      INTEGER(8) :: II8, JJ8, J18, J28 
      INTEGER(8) :: AINPUT8
      INTEGER(8) :: AII8
      INTEGER(8) :: APOS, APOS2, ICT12
      INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LS
      INTEGER :: NB_BLR_LS, NPARTSCB, NPARTSASS, MAXI_CLUSTER, 
     &           IBCKSZ2, MINSIZE, TOPDIAG
      INTEGER(8) :: JJ3
      INTEGER    :: K1RHS, K2RHS, JFirstRHS
      COMPLEX ZERO
      PARAMETER( ZERO = (0.0E0,0.0E0) )
      NBCOLF  = IW(IOLDPS+KEEP(IXSZ))
      NBROWF  = IW(IOLDPS+2+KEEP(IXSZ))
      NASS    = IW(IOLDPS+1+KEEP(IXSZ))
      NSLAVES= IW(IOLDPS+5 + KEEP(IXSZ))
      HF      = 6 + NSLAVES + KEEP(IXSZ)
!$    NOMP = OMP_GET_MAX_THREADS()
.EQ..OR..LT.      IF (KEEP(50)  0  NBROWF  KEEP(63)) THEN
!$      CHUNK8 = int(KEEP(361),8)
!$OMP   PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8)
!$OMP&  IF (int(NBROWF,8)*int(NBCOLF,8) > int(KEEP(361),8)
.AND..GT.!$OMP&     NOMP  1)
        DO JJ8=POSELT, POSELT+int(NBROWF,8)*int(NBCOLF,8)-1_8
          A(JJ8) = ZERO
        ENDDO
!$OMP   END PARALLEL DO
      ELSE
        TOPDIAG = 0
.GE.        IF (IW(IOLDPS+XXLR)1) THEN
          CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NBROWF-1), 0,
     &                    NBROWF, LRGROUPS, NPARTSCB, 
     &                    NPARTSASS, BEGS_BLR_LS)
          NB_BLR_LS = NPARTSCB
          call MAX_CLUSTER(BEGS_BLR_LS,NB_BLR_LS+1,MAXI_CLUSTER)
          DEALLOCATE(BEGS_BLR_LS)
          CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS)
          MINSIZE = int(IBCKSZ2 / 2)
          TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1, TOPDIAG)
        ENDIF
!$      CHUNK = max( KEEP(360)/2,
!$   &               ((NBROWF+NOMP-1)/NOMP +2) / 3 )
!$OMP   PARALLEL DO PRIVATE(APOS,JJ3,JJ8) SCHEDULE(STATIC,CHUNK)
.GT..AND..GT.!$OMP&  IF (NBROWF  KEEP(360)  NOMP  1)
        DO JJ8 = 0_8, int(NBROWF-1,8)
          APOS = POSELT+ JJ8*int(NBCOLF,8)
          JJ3  = min( int(NBCOLF,8)  - 1_8, 
     &           JJ8 + int(NBCOLF-NBROWF,8) + TOPDIAG )
          A(APOS: APOS+JJ3) = ZERO
        ENDDO
!$OMP   END PARALLEL DO
      ENDIF
          K1 = IOLDPS + HF + NBROWF
          K2 = K1 + NBCOLF - 1
          JPOS = 1
          DO K = K1, K2
           J        = IW(K)
           ITLOC(J) = -JPOS
           JPOS     = JPOS + 1
          END DO
          K1 = IOLDPS + HF 
          K2 = K1 + NBROWF - 1
          JPOS = 1
.GT..AND..NE.          IF ((KEEP(253)0)(KEEP(50)0)) THEN
           K1RHS = 0
           K2RHS = -1
           DO K = K1, K2
            J        = IW(K)
            ITLOC(J) = -ITLOC(J)*NBCOLF + JPOS
.EQ..AND..GT.            IF ((K1RHS0)(JN)) THEN
             K1RHS = K
             JFirstRHS=J-N 
            ENDIF
            JPOS     = JPOS + 1
           ENDDO
.GT.           IF (K1RHS0) K2RHS=K2
.GE.           IF ( K2RHSK1RHS ) THEN
             IN = INODE
.GT.             DO WHILE (IN0) 
               IJROW = -ITLOC(IN)  
               DO K = K1RHS, K2RHS
                J    = IW(K)       
                I    = ITLOC(J)    
                ILOC = mod(I,NBCOLF) 
              APOS = POSELT+int(ILOC-1,8)*int(NBCOLF,8) + 
     &               int(IJROW-1,8) 
              A(APOS) = A(APOS) + RHS_MUMPS(
     &                 (JFirstRHS+(K-K1RHS)-1)*KEEP(254)+ IN)
             ENDDO
             IN = FILS(IN)
            ENDDO
           ENDIF
          ELSE  
           DO K = K1, K2
            J        = IW(K)
            ITLOC(J) = -ITLOC(J)*NBCOLF + JPOS
            JPOS     = JPOS + 1
           END DO
          ENDIF
          ELBEG  = FRT_PTR(INODE)
          NUMELT = FRT_PTR(INODE+1) - ELBEG
          DO IELL=ELBEG,ELBEG+NUMELT-1
           ELTI = FRT_ELT(IELL)
           J18= PTRAIW(ELTI)
           J28= PTRAIW(ELTI+1)-1_8
           AII8 = PTRARW(ELTI)
           SIZE_ELTI8 = J28 - J18 + 1_8
           DO II8=J18,J28
            I = ITLOC(INTARR(II8))
.EQ.            IF (KEEP(50)0) THEN
.LE.             IF (I0) CYCLE
             AINPUT8    = AII8 + II8 - J18
             IPOS = mod(I,NBCOLF)
             ICT12 = POSELT + int(IPOS-1,8) * int(NBCOLF,8)
             DO JJ8 = J18, J28
              JPOS = ITLOC(INTARR(JJ8))
.LE.              IF (JPOS0) THEN 
                   JPOS = -JPOS
              ELSE
                   JPOS = JPOS/NBCOLF
              END IF
              APOS2    = ICT12 + int(JPOS - 1,8)
              A(APOS2) = A(APOS2) +  DBLARR(AINPUT8)
              AINPUT8   = AINPUT8 + SIZE_ELTI8
             END DO
            ELSE
.EQ.              IF ( I  0 ) THEN 
               AII8 = AII8 + J28 - II8 + 1_8
               CYCLE
              ENDIF
.LE.              IF ( I  0 ) THEN 
               IPOS1 = -I
               IPOS2 = 0
              ELSE 
               IPOS1 = I/NBCOLF
               IPOS2 = mod(I,NBCOLF)
              END IF
              ICT12 =  POSELT + int(IPOS2-1,8)*int(NBCOLF,8)
              DO JJ8=II8,J28
               AII8 = AII8 + 1_8
               J = ITLOC(INTARR(JJ8))
.EQ.               IF ( J  0 ) CYCLE
.EQ..AND..LE.               IF ( IPOS20  J0) CYCLE
.LE.               IF ( J  0 ) THEN
                JPOS = -J
               ELSE
                JPOS = J/NBCOLF
               END IF
.GE..AND..GT.               IF ( (IPOS1JPOS)  (IPOS20) ) THEN
                 APOS2 = ICT12  + int(JPOS - 1,8)
                 A(APOS2) = A(APOS2) +  DBLARR(AII8-1_8)
               END IF
.LT..AND..GT.               IF ( (IPOS1JPOS)  (J0) ) THEN
                 IPOS = mod(J,NBCOLF)
                 JPOS = IPOS1
                 APOS2 = POSELT + int(IPOS-1,8)*int(NBCOLF,8)
     &                          + int(JPOS - 1,8)
                 A(APOS2) = A(APOS2) +  DBLARR(AII8-1_8)
               END IF
              END DO
            END IF
           END DO
          END DO
          K1 = IOLDPS + HF + NBROWF
          K2 = K1 + NBCOLF - 1
          DO K = K1, K2
           J = IW(K)
           ITLOC(J) = 0
          END DO
      END SUBROUTINE CMUMPS_ASM_SLAVE_ELEMENTS