1! 2! Copyright (c) 2012-2018, NVIDIA CORPORATION. All rights reserved. 3! 4! Licensed under the Apache License, Version 2.0 (the "License"); 5! you may not use this file except in compliance with the License. 6! You may obtain a copy of the License at 7! 8! http://www.apache.org/licenses/LICENSE-2.0 9! 10! Unless required by applicable law or agreed to in writing, software 11! distributed under the License is distributed on an "AS IS" BASIS, 12! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13! See the License for the specific language governing permissions and 14! limitations under the License. 15! 16 17 18#include "mmul_dir.h" 19 20 21subroutine ftn_vmmul_real4( tb, n, k, alpha, a, b, ldb, beta, c ) 22 implicit none 23 integer*8 :: n, k, ldb 24 integer :: tb 25 real*4, dimension (ldb, * ) :: b 26 real*4, dimension ( * ) :: a, c 27 real*4 :: alpha, beta 28 29! local variables 30 integer*8 :: i, j, kk 31 real*4 :: temp 32 33 if( beta .ne. 0.0 )then 34 do i = 1, n 35 c( i ) = beta * c( i ) 36 enddo 37 else 38 do i = 1, n 39 c( i ) = 0.0 40 enddo 41 end if 42 if( tb .eq. 0 ) then !b is normally oriented 43 if( alpha .eq. 1.0 )then 44 do j = 1, n 45 do kk = 1, k 46 c( j ) = c( j ) + a( kk ) * b( kk, j ) 47 enddo 48 enddo 49 elseif( alpha .eq. -1.0 )then 50 do j = 1, n 51 do kk = 1, k 52 c( j ) = c( j ) - a( kk ) * b( kk, j ) 53 enddo 54 enddo 55 else 56 do j = 1, n 57 do kk = 1, k 58 c( j ) = c( j ) + alpha * a( kk ) * b( kk, j ) 59 enddo 60 enddo 61 endif 62 else 63 do kk = 1, k 64 temp = alpha * a( kk ) 65 do j = 1, n 66 c( j ) = c( j ) + temp * b( j, kk ) 67 enddo 68 enddo 69 endif 70 return 71end subroutine ftn_vmmul_real4 72