multrec_filtering_s Subroutine

private subroutine multrec_filtering_s(filter_eps, nblks, rowi, coli, blkp, rbs, cbs, nze, DATA)

Applying in-place filtering on the workspace. \brief Use Frobenius norm

Arguments

Type IntentOptional Attributes Name
real(kind=real_8), intent(in) :: filter_eps
integer, intent(inout) :: nblks
integer, intent(inout), DIMENSION(1:nblks) :: rowi
integer, intent(inout), DIMENSION(1:nblks) :: coli
integer, intent(inout), DIMENSION(1:nblks) :: blkp
integer, intent(in), DIMENSION(:) :: rbs
integer, intent(in), DIMENSION(:) :: cbs
integer, intent(inout) :: nze
real(kind=real_4), intent(inout), DIMENSION(:) :: DATA

Source Code

      SUBROUTINE multrec_filtering_s (filter_eps, nblks, rowi, coli, blkp, &
                                                  rbs, cbs, nze, DATA)
     !! Applying in-place filtering on the workspace.
     !! \brief Use Frobenius norm

         REAL(kind=real_8), INTENT(IN)              :: filter_eps
         INTEGER, INTENT(INOUT)                     :: nblks, nze
         INTEGER, DIMENSION(1:nblks), INTENT(INOUT) :: rowi, coli, blkp
         INTEGER, DIMENSION(:), INTENT(IN)          :: rbs, cbs
         REAL(kind=real_4), DIMENSION(:), &
            INTENT(INOUT)                            :: DATA

         INTEGER                                    :: blk, lastblk, blk_nze, blk_p
         REAL(kind=real_8)                          :: nrm

         REAL(KIND=real_8), EXTERNAL                :: DZNRM2, DDOT
#if defined (__ACCELERATE)
         REAL(KIND=real_8), EXTERNAL                :: SCNRM2, SDOT
#else
         REAL(KIND=real_4), EXTERNAL                :: SCNRM2, SDOT
#endif

         REAL(kind=real_8)                          :: filter_eps_opt

# 719 "/__w/dbcsr/dbcsr/src/mm/dbcsr_mm_multrec.F"
            ! Avoid square root
            filter_eps_opt = filter_eps**2
# 724 "/__w/dbcsr/dbcsr/src/mm/dbcsr_mm_multrec.F"

         lastblk = 0
         nze = 0
         !
         DO blk = 1, nblks
            blk_p = blkp(blk)
            IF (blk_p .EQ. 0) CYCLE
            blk_nze = rbs(rowi(blk))*cbs(coli(blk))
            IF (blk_nze .EQ. 0) CYCLE ! Skip empty blocks
            nrm = REAL((SDOT (blk_nze, data(blk_p), 1, data(blk_p), 1)), KIND = real_8)
            IF (nrm .GE. filter_eps_opt) THEN
               ! Keep block
               lastblk = lastblk + 1
               IF (lastblk .LT. blk) THEN
                  rowi(lastblk) = rowi(blk)
                  coli(lastblk) = coli(blk)
                  blkp(lastblk) = blkp(blk)
               END IF
               nze = nze + blk_nze
            END IF
         END DO
         !
         nblks = lastblk

      END SUBROUTINE multrec_filtering_s