program main c*********************************************************************72 c cc blas2_c_test() tests blas2_c(). c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 17 January 2014 c c Author: c c John Burkardt c implicit none call timestamp ( ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'blas2_c_test():' write ( *, '(a)' ) ' FORTRAN77 version' write ( *, '(a)' ) ' Test blas2_c().' call test01 ( ) c c Terminate. c write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'blas2_c_test():' write ( *, '(a)' ) ' Normal end of execution.' write ( *, '(a)' ) ' ' call timestamp ( ) stop end subroutine test01 ( ) c*********************************************************************72 c cc TEST01 tests CGEMV. c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 17 January 2014 c c Author: c c John Burkardt c implicit none integer m parameter ( m = 5 ) integer n parameter ( n = 5 ) complex a(m,n) complex alpha complex beta integer i integer incx integer incy integer j integer lda character trans complex x(n) real x1 real x2 complex y(m) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST01' write ( *, '(a)' ) ' For a general matrix A,' write ( *, '(a)' ) & ' CGEMV computes y := alpha * A * x + beta * y' trans = 'N' alpha = ( 10.0E+00, 1.0E+00 ) lda = m incx = 1 beta = 3.0E+00 incy = 1 do i = 1, m do j = 1, n if ( i .eq. j ) then a(i,j) = ( 2.0E+00, 0.0E+00 ) else if ( i .eq. j - 1 .or. i .eq. j + 1 ) then a(i,j) = ( -1.0E+00, 0.0E+00 ) else a(i,j) = ( 0.0E+00, 0.0E+00 ) end if end do end do x1 = 0.0E+00 x2 = real ( n ) do i = 1, n x(i) = cmplx ( x1, x2 ) x1 = x1 + 1.0E+00 x2 = x2 - 2.0E+00 end do do i = 1, m y(i) = ( 100.0E+00, 1.0E+00 ) end do call cgemv ( trans, m, n, alpha, a, lda, x, incx, beta, y, incy ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Result vector Y = ' write ( *, '(a)' ) ' ' do i = 1, m write ( *, '(2x,2g14.6)' ) y(i) end do return end function lsame ( ca, cb ) c*********************************************************************72 c cc lsame() returns TRUE if CA is the same letter as CB regardless of case. c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 09 February 2014 c c Author: c c Original FORTRAN77 version by Jack Dongarra. c This version by John Burkardt. c c Reference: c c Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart, c LINPACK User's Guide, c SIAM, 1979, c ISBN13: 978-0-898711-72-1, c LC: QA214.L56. c c Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh, c Basic Linear Algebra Subprograms for FORTRAN usage, c ACM Transactions on Mathematical Software, c Volume 5, Number 3, pages 308-323, 1979. c c Parameters: c c Input, character CA, CB, the character to compare. c c Output, logical LSAME, is TRUE if the characters are equal, c disregarding case. c implicit none character ca character cb intrinsic ichar integer inta integer intb logical lsame integer zcode c c Test if the characters are equal. c lsame = ca .eq. cb if ( lsame ) then return end if c c Now test for equivalence if both characters are alphabetic. c zcode = ichar ( 'Z' ) c c Use 'Z' rather than 'A' so that ASCII can be detected on Prime c machines, on which ICHAR returns a value with bit 8 set. c ICHAR('A') on Prime machines returns 193 which is the same as c ICHAR('A') on an EBCDIC machine. c inta = ichar ( ca ) intb = ichar ( cb ) c c ASCII is assumed. c ZCODE is the ASCII code of either lower or upper case 'Z'. c if ( zcode .eq. 90 .or. zcode .eq. 122 ) then if ( inta .ge. 97 .and. inta .le. 122 ) then inta = inta - 32 end if if ( intb .ge. 97 .and. intb .le. 122 ) then intb = intb - 32 end if c c EBCDIC is assumed. c ZCODE is the EBCDIC code of either lower or upper case 'Z'. c else if ( zcode .eq. 233 .or. zcode .eq. 169 ) then if ( inta .ge. 129 .and. inta .le. 137 .or. & inta .ge. 145 .and. inta .le. 153 .or. & inta .ge. 162 .and. inta .le. 169 ) then inta = inta + 64 end if if ( intb .ge. 129 .and. intb .le. 137 .or. & intb .ge. 145 .and. intb .le. 153 .or. & intb .ge. 162 .and. intb .le. 169 ) then intb = intb + 64 end if c c ASCII is assumed, on Prime machines. c ZCODE is the ASCII code plus 128 of either lower or upper case 'Z'. c else if ( zcode .eq. 218 .or. zcode .eq. 250 ) then if ( inta .ge. 225 .and. inta .le. 250 ) then inta = inta - 32 end if if ( intb .ge. 225 .and. intb .le. 250 ) then intb = intb - 32 end if end if lsame = inta .eq. intb return end subroutine timestamp ( ) c*********************************************************************72 c cc timestamp() prints the YMDHMS date as a timestamp. c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 12 June 2014 c c Author: c c John Burkardt c implicit none character * ( 8 ) ampm integer d character * ( 8 ) date integer h integer m integer mm character * ( 9 ) month(12) integer n integer s character * ( 10 ) time integer y save month data month / & 'January ', 'February ', 'March ', 'April ', & 'May ', 'June ', 'July ', 'August ', & 'September', 'October ', 'November ', 'December ' / call date_and_time ( date, time ) read ( date, '(i4,i2,i2)' ) y, m, d read ( time, '(i2,i2,i2,1x,i3)' ) h, n, s, mm if ( h .lt. 12 ) then ampm = 'AM' else if ( h .eq. 12 ) then if ( n .eq. 0 .and. s .eq. 0 ) then ampm = 'Noon' else ampm = 'PM' end if else h = h - 12 if ( h .lt. 12 ) then ampm = 'PM' else if ( h .eq. 12 ) then if ( n .eq. 0 .and. s .eq. 0 ) then ampm = 'Midnight' else ampm = 'AM' end if end if end if write ( *, & '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, & trim ( ampm ) return end subroutine xerbla ( srname, info ) c*********************************************************************72 c cc xerbla() is an error handler. c c Discussion: c c XERBLA is called if an input parameter has an invalid value. c A message is printed and execution stops. c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 09 February 2014 c c Author: c c Original FORTRAN77 version by Jack Dongarra. c This version by John Burkardt. c c Reference: c c Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart, c LINPACK User's Guide, c SIAM, 1979, c ISBN13: 978-0-898711-72-1, c LC: QA214.L56. c c Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh, c Basic Linear Algebra Subprograms for FORTRAN usage, c ACM Transactions on Mathematical Software, c Volume 5, Number 3, pages 308-323, 1979. c c Parameters: c c Input, character * ( * ) SRNAME, the name of the routine c which called XERBLA. c c Input, integer INFO, the position of the invalid parameter in the c parameter list of the calling routine. c implicit none integer info character * ( * ) srname write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'XERBLA - Fatal error!' write ( *, '(a)' ) ' On entry to routine ' // trim ( srname ) write ( *, '(a)' ) ' an illegal value was detected for' write ( *, '(a,i6)' ) ' parameter number ', info stop 1 end