LAPACK 3.12.0 LAPACK: Linear Algebra PACKage
Searching...
No Matches

## ◆ cmake()

 subroutine cmake ( character*2 type, character*1 uplo, character*1 diag, integer m, integer n, complex, dimension( nmax, * ) a, integer nmax, complex, dimension( * ) aa, integer lda, integer kl, integer ku, logical reset, complex transl )

Definition at line 2742 of file cblat2.f.

2744*
2745* Generates values for an M by N matrix A within the bandwidth
2746* defined by KL and KU.
2747* Stores the values in the array AA in the data structure required
2748* by the routine, with unwanted elements set to rogue value.
2749*
2750* TYPE is 'GE', 'GB', 'HE', 'HB', 'HP', 'TR', 'TB' OR 'TP'.
2751*
2752* Auxiliary routine for test program for Level 2 Blas.
2753*
2754* -- Written on 10-August-1987.
2755* Richard Hanson, Sandia National Labs.
2756* Jeremy Du Croz, NAG Central Office.
2757*
2758* .. Parameters ..
2759 COMPLEX ZERO, ONE
2760 parameter( zero = ( 0.0, 0.0 ), one = ( 1.0, 0.0 ) )
2761 COMPLEX ROGUE
2762 parameter( rogue = ( -1.0e10, 1.0e10 ) )
2763 REAL RZERO
2764 parameter( rzero = 0.0 )
2765 REAL RROGUE
2766 parameter( rrogue = -1.0e10 )
2767* .. Scalar Arguments ..
2768 COMPLEX TRANSL
2769 INTEGER KL, KU, LDA, M, N, NMAX
2770 LOGICAL RESET
2771 CHARACTER*1 DIAG, UPLO
2772 CHARACTER*2 TYPE
2773* .. Array Arguments ..
2774 COMPLEX A( NMAX, * ), AA( * )
2775* .. Local Scalars ..
2776 INTEGER I, I1, I2, I3, IBEG, IEND, IOFF, J, JJ, KK
2777 LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER
2778* .. External Functions ..
2779 COMPLEX CBEG
2780 EXTERNAL cbeg
2781* .. Intrinsic Functions ..
2782 INTRINSIC cmplx, conjg, max, min, real
2783* .. Executable Statements ..
2784 gen = TYPE( 1: 1 ).EQ.'G'
2785 sym = TYPE( 1: 1 ).EQ.'H'
2786 tri = TYPE( 1: 1 ).EQ.'T'
2787 upper = ( sym.OR.tri ).AND.uplo.EQ.'U'
2788 lower = ( sym.OR.tri ).AND.uplo.EQ.'L'
2789 unit = tri.AND.diag.EQ.'U'
2790*
2791* Generate data in array A.
2792*
2793 DO 20 j = 1, n
2794 DO 10 i = 1, m
2795 IF( gen.OR.( upper.AND.i.LE.j ).OR.( lower.AND.i.GE.j ) )
2796 \$ THEN
2797 IF( ( i.LE.j.AND.j - i.LE.ku ).OR.
2798 \$ ( i.GE.j.AND.i - j.LE.kl ) )THEN
2799 a( i, j ) = cbeg( reset ) + transl
2800 ELSE
2801 a( i, j ) = zero
2802 END IF
2803 IF( i.NE.j )THEN
2804 IF( sym )THEN
2805 a( j, i ) = conjg( a( i, j ) )
2806 ELSE IF( tri )THEN
2807 a( j, i ) = zero
2808 END IF
2809 END IF
2810 END IF
2811 10 CONTINUE
2812 IF( sym )
2813 \$ a( j, j ) = cmplx( real( a( j, j ) ), rzero )
2814 IF( tri )
2815 \$ a( j, j ) = a( j, j ) + one
2816 IF( unit )
2817 \$ a( j, j ) = one
2818 20 CONTINUE
2819*
2820* Store elements in array AS in data structure required by routine.
2821*
2822 IF( type.EQ.'GE' )THEN
2823 DO 50 j = 1, n
2824 DO 30 i = 1, m
2825 aa( i + ( j - 1 )*lda ) = a( i, j )
2826 30 CONTINUE
2827 DO 40 i = m + 1, lda
2828 aa( i + ( j - 1 )*lda ) = rogue
2829 40 CONTINUE
2830 50 CONTINUE
2831 ELSE IF( type.EQ.'GB' )THEN
2832 DO 90 j = 1, n
2833 DO 60 i1 = 1, ku + 1 - j
2834 aa( i1 + ( j - 1 )*lda ) = rogue
2835 60 CONTINUE
2836 DO 70 i2 = i1, min( kl + ku + 1, ku + 1 + m - j )
2837 aa( i2 + ( j - 1 )*lda ) = a( i2 + j - ku - 1, j )
2838 70 CONTINUE
2839 DO 80 i3 = i2, lda
2840 aa( i3 + ( j - 1 )*lda ) = rogue
2841 80 CONTINUE
2842 90 CONTINUE
2843 ELSE IF( type.EQ.'HE'.OR.type.EQ.'TR' )THEN
2844 DO 130 j = 1, n
2845 IF( upper )THEN
2846 ibeg = 1
2847 IF( unit )THEN
2848 iend = j - 1
2849 ELSE
2850 iend = j
2851 END IF
2852 ELSE
2853 IF( unit )THEN
2854 ibeg = j + 1
2855 ELSE
2856 ibeg = j
2857 END IF
2858 iend = n
2859 END IF
2860 DO 100 i = 1, ibeg - 1
2861 aa( i + ( j - 1 )*lda ) = rogue
2862 100 CONTINUE
2863 DO 110 i = ibeg, iend
2864 aa( i + ( j - 1 )*lda ) = a( i, j )
2865 110 CONTINUE
2866 DO 120 i = iend + 1, lda
2867 aa( i + ( j - 1 )*lda ) = rogue
2868 120 CONTINUE
2869 IF( sym )THEN
2870 jj = j + ( j - 1 )*lda
2871 aa( jj ) = cmplx( real( aa( jj ) ), rrogue )
2872 END IF
2873 130 CONTINUE
2874 ELSE IF( type.EQ.'HB'.OR.type.EQ.'TB' )THEN
2875 DO 170 j = 1, n
2876 IF( upper )THEN
2877 kk = kl + 1
2878 ibeg = max( 1, kl + 2 - j )
2879 IF( unit )THEN
2880 iend = kl
2881 ELSE
2882 iend = kl + 1
2883 END IF
2884 ELSE
2885 kk = 1
2886 IF( unit )THEN
2887 ibeg = 2
2888 ELSE
2889 ibeg = 1
2890 END IF
2891 iend = min( kl + 1, 1 + m - j )
2892 END IF
2893 DO 140 i = 1, ibeg - 1
2894 aa( i + ( j - 1 )*lda ) = rogue
2895 140 CONTINUE
2896 DO 150 i = ibeg, iend
2897 aa( i + ( j - 1 )*lda ) = a( i + j - kk, j )
2898 150 CONTINUE
2899 DO 160 i = iend + 1, lda
2900 aa( i + ( j - 1 )*lda ) = rogue
2901 160 CONTINUE
2902 IF( sym )THEN
2903 jj = kk + ( j - 1 )*lda
2904 aa( jj ) = cmplx( real( aa( jj ) ), rrogue )
2905 END IF
2906 170 CONTINUE
2907 ELSE IF( type.EQ.'HP'.OR.type.EQ.'TP' )THEN
2908 ioff = 0
2909 DO 190 j = 1, n
2910 IF( upper )THEN
2911 ibeg = 1
2912 iend = j
2913 ELSE
2914 ibeg = j
2915 iend = n
2916 END IF
2917 DO 180 i = ibeg, iend
2918 ioff = ioff + 1
2919 aa( ioff ) = a( i, j )
2920 IF( i.EQ.j )THEN
2921 IF( unit )
2922 \$ aa( ioff ) = rogue
2923 IF( sym )
2924 \$ aa( ioff ) = cmplx( real( aa( ioff ) ), rrogue )
2925 END IF
2926 180 CONTINUE
2927 190 CONTINUE
2928 END IF
2929 RETURN
2930*
2931* End of CMAKE
2932*
complex function cbeg(reset)
Definition cblat2.f:3156
Here is the caller graph for this function: