Actual source code: ilu.h
1: /*
2: Kernels used in sparse ILU (and LU) and in the resulting triangular
3: solves. These are for block algorithms where the block sizes are on
4: the order of 2-6+.
6: There are TWO versions of the macros below.
7: 1) standard for MatScalar == PetscScalar use the standard BLAS for
8: block size larger than 7 and
9: 2) handcoded Fortran single precision for the matrices, since BLAS
10: does not have some arguments in single and some in double.
12: */
16: #include petscblaslapack.h
18: /*
19: These are C kernels,they are contained in
20: src/mat/impls/baij/seq
21: */
23: EXTERN PetscErrorCode LINPACKdgefa(MatScalar*,PetscInt,PetscInt*);
24: EXTERN PetscErrorCode LINPACKdgedi(MatScalar*,PetscInt,PetscInt*,MatScalar*);
25: EXTERN PetscErrorCode Kernel_A_gets_inverse_A_2(MatScalar*);
26: EXTERN PetscErrorCode Kernel_A_gets_inverse_A_3(MatScalar*);
28: #define Kernel_A_gets_inverse_A_4_nopivot(mat) 0;\
29: {\
30: MatScalar d, di;\
31: \
32: di = mat[0];\
33: mat[0] = d = 1.0 / di;\
34: mat[4] *= -d;\
35: mat[8] *= -d;\
36: mat[12] *= -d;\
37: mat[1] *= d;\
38: mat[2] *= d;\
39: mat[3] *= d;\
40: mat[5] += mat[4] * mat[1] * di;\
41: mat[6] += mat[4] * mat[2] * di;\
42: mat[7] += mat[4] * mat[3] * di;\
43: mat[9] += mat[8] * mat[1] * di;\
44: mat[10] += mat[8] * mat[2] * di;\
45: mat[11] += mat[8] * mat[3] * di;\
46: mat[13] += mat[12] * mat[1] * di;\
47: mat[14] += mat[12] * mat[2] * di;\
48: mat[15] += mat[12] * mat[3] * di;\
49: di = mat[5];\
50: mat[5] = d = 1.0 / di;\
51: mat[1] *= -d;\
52: mat[9] *= -d;\
53: mat[13] *= -d;\
54: mat[4] *= d;\
55: mat[6] *= d;\
56: mat[7] *= d;\
57: mat[0] += mat[1] * mat[4] * di;\
58: mat[2] += mat[1] * mat[6] * di;\
59: mat[3] += mat[1] * mat[7] * di;\
60: mat[8] += mat[9] * mat[4] * di;\
61: mat[10] += mat[9] * mat[6] * di;\
62: mat[11] += mat[9] * mat[7] * di;\
63: mat[12] += mat[13] * mat[4] * di;\
64: mat[14] += mat[13] * mat[6] * di;\
65: mat[15] += mat[13] * mat[7] * di;\
66: di = mat[10];\
67: mat[10] = d = 1.0 / di;\
68: mat[2] *= -d;\
69: mat[6] *= -d;\
70: mat[14] *= -d;\
71: mat[8] *= d;\
72: mat[9] *= d;\
73: mat[11] *= d;\
74: mat[0] += mat[2] * mat[8] * di;\
75: mat[1] += mat[2] * mat[9] * di;\
76: mat[3] += mat[2] * mat[11] * di;\
77: mat[4] += mat[6] * mat[8] * di;\
78: mat[5] += mat[6] * mat[9] * di;\
79: mat[7] += mat[6] * mat[11] * di;\
80: mat[12] += mat[14] * mat[8] * di;\
81: mat[13] += mat[14] * mat[9] * di;\
82: mat[15] += mat[14] * mat[11] * di;\
83: di = mat[15];\
84: mat[15] = d = 1.0 / di;\
85: mat[3] *= -d;\
86: mat[7] *= -d;\
87: mat[11] *= -d;\
88: mat[12] *= d;\
89: mat[13] *= d;\
90: mat[14] *= d;\
91: mat[0] += mat[3] * mat[12] * di;\
92: mat[1] += mat[3] * mat[13] * di;\
93: mat[2] += mat[3] * mat[14] * di;\
94: mat[4] += mat[7] * mat[12] * di;\
95: mat[5] += mat[7] * mat[13] * di;\
96: mat[6] += mat[7] * mat[14] * di;\
97: mat[8] += mat[11] * mat[12] * di;\
98: mat[9] += mat[11] * mat[13] * di;\
99: mat[10] += mat[11] * mat[14] * di;\
100: }
102: EXTERN PetscErrorCode Kernel_A_gets_inverse_A_4(MatScalar *);
103: # if defined(PETSC_HAVE_SSE)
104: EXTERN PetscErrorCode Kernel_A_gets_inverse_A_4_SSE(MatScalar *);
105: # endif
106: EXTERN PetscErrorCode Kernel_A_gets_inverse_A_5(MatScalar *);
107: EXTERN PetscErrorCode Kernel_A_gets_inverse_A_6(MatScalar *);
108: EXTERN PetscErrorCode Kernel_A_gets_inverse_A_7(MatScalar *);
110: /*
111: A = inv(A) A_gets_inverse_A
113: A - square bs by bs array stored in column major order
114: pivots - integer work array of length bs
115: W - bs by 1 work array
116: */
117: #define Kernel_A_gets_inverse_A(bs,A,pivots,W) (LINPACKdgefa((A),(bs),(pivots)) || LINPACKdgedi((A),(bs),(pivots),(W)))
119: /* -----------------------------------------------------------------------*/
121: #if !defined(PETSC_USE_MAT_SINGLE)
122: /*
123: Version that calls the BLAS directly
124: */
125: /*
126: A = A * B A_gets_A_times_B
128: A, B - square bs by bs arrays stored in column major order
129: W - square bs by bs work array
131: */
132: #define Kernel_A_gets_A_times_B(bs,A,B,W) \
133: { \
134: PetscBLASInt _bbs = (PetscBLASInt)bs;\
135: PetscScalar _one = 1.0,_zero = 0.0; \
136: PetscErrorCode _ierr; \
137: _PetscMemcpy((W),(A),(bs)*(bs)*sizeof(MatScalar));CHKERRQ(_ierr); \
138: BLASgemm_("N","N",&(_bbs),&(_bbs),&(_bbs),&_one,(W),&(_bbs),(B),&(_bbs),&_zero,(A),&(_bbs));\
139: }
141: /*
143: A = A - B * C A_gets_A_minus_B_times_C
145: A, B, C - square bs by bs arrays stored in column major order
146: */
147: #define Kernel_A_gets_A_minus_B_times_C(bs,A,B,C) \
148: { \
149: PetscBLASInt _bbs = (PetscBLASInt)bs;\
150: PetscScalar _mone = -1.0,_one = 1.0; \
151: BLASgemm_("N","N",&(_bbs),&(_bbs),&(_bbs),&_mone,(B),&(_bbs),(C),&(_bbs),&_one,(A),&(_bbs));\
152: }
154: /*
156: A = A + B^T * C A_gets_A_plus_Btranspose_times_C
158: A, B, C - square bs by bs arrays stored in column major order
159: */
160: #define Kernel_A_gets_A_plus_Btranspose_times_C(bs,A,B,C) \
161: { \
162: PetscBLASInt _bbs = (PetscBLASInt)bs;\
163: PetscScalar _one = 1.0; \
164: BLASgemm_("T","N",&(_bbs),&(_bbs),&(_bbs),&_one,(B),&(_bbs),(C),&(_bbs),&_one,(A),&(_bbs));\
165: }
167: /*
168: v = v + A^T w v_gets_v_plus_Atranspose_times_w
170: v - array of length bs
171: A - square bs by bs array
172: w - array of length bs
173: */
174: #define Kernel_v_gets_v_plus_Atranspose_times_w(bs,v,A,w) \
175: { \
176: PetscScalar _one = 1.0; \
177: PetscBLASInt _bbs = (PetscBLASInt)bs, _ione = 1; \
178: BLASgemv_("T",&(_bbs),&(_bbs),&_one,A,&(_bbs),w,&_ione,&_one,v,&_ione); \
179: }
181: /*
182: v = v - A w v_gets_v_minus_A_times_w
184: v - array of length bs
185: A - square bs by bs array
186: w - array of length bs
187: */
188: #define Kernel_v_gets_v_minus_A_times_w(bs,v,A,w) \
189: { \
190: PetscScalar _mone = -1.0,_one = 1.0; \
191: PetscBLASInt _bbs = (PetscBLASInt)bs, _ione = 1; \
192: BLASgemv_("N",&(_bbs),&(_bbs),&_mone,A,&(_bbs),w,&_ione,&_one,v,&_ione); \
193: }
195: /*
196: v = v + A w v_gets_v_plus_A_times_w
198: v - array of length bs
199: A - square bs by bs array
200: w - array of length bs
201: */
202: #define Kernel_v_gets_v_plus_A_times_w(bs,v,A,w) \
203: { \
204: PetscScalar _one = 1.0; \
205: PetscBLASInt _bbs = (PetscBLASInt)bs,_ione = 1; \
206: BLASgemv_("N",&(_bbs),&(_bbs),&_one,A,&(_bbs),w,&_ione,&_one,v,&_ione); \
207: }
209: /*
210: v = v + A w v_gets_v_plus_Ar_times_w
212: v - array of length bs
213: A - square bs by bs array
214: w - array of length bs
215: */
216: #define Kernel_w_gets_w_plus_Ar_times_v(bs,ncols,v,A,w) \
217: { \
218: PetscScalar _one = 1.0; \
219: PetscBLASInt _bbs = (PetscBLASInt)bs,_bncols = (PetscBLASInt)ncols,_ione = 1; \
220: BLASgemv_("N",&(_bbs),&(_bncols),&_one,A,&(_bbs),v,&_ione,&_one,w,&_ione); \
221: }
223: /*
224: w = A v w_gets_A_times_v
226: v - array of length bs
227: A - square bs by bs array
228: w - array of length bs
229: */
230: #define Kernel_w_gets_A_times_v(bs,v,A,w) \
231: { \
232: PetscScalar _zero = 0.0,_one = 1.0; \
233: PetscBLASInt _bbs = (PetscBLASInt)bs,_ione = 1; \
234: BLASgemv_("N",&(_bbs),&(_bbs),&_one,A,&(_bbs),v,&_ione,&_zero,w,&_ione); \
235: }
237: /*
238: z = A*x
239: */
240: #define Kernel_w_gets_Ar_times_v(bs,ncols,x,A,z) \
241: { \
242: PetscScalar _one = 1.0,_zero = 0.0; \
243: PetscBLASInt _bbs = (PetscBLASInt)bs,_bncols = (PetscBLASInt)ncols,_ione = 1; \
244: BLASgemv_("N",&(_bbs),&_bncols,&_one,A,&(_bbs),x,&_ione,&_zero,z,&_ione); \
245: }
247: /*
248: z = trans(A)*x
249: */
250: #define Kernel_w_gets_w_plus_trans_Ar_times_v(bs,ncols,x,A,z) \
251: { \
252: PetscScalar _one = 1.0; \
253: PetscBLASInt _bbs = (PetscBLASInt)bs,_bncols = (PetscBLASInt)ncols,_ione = 1; \
254: BLASgemv_("T",&_bbs,&_bncols,&_one,A,&_bbs,x,&_ione,&_one,z,&_ione); \
255: }
257: #else
258: /*
259: Version that calls Fortran routines; can handle different precision
260: of matrix (array) and vectors
261: */
262: /*
263: These are Fortran kernels: They replace certain BLAS routines but
264: have some arguments that may be single precision,rather than double
265: These routines are provided in src/fortran/kernels/sgemv.F
266: They are pretty pitiful but get the job done. The intention is
267: that for important block sizes (currently 1,2,3,4,5,6,7) custom inlined
268: code is used.
269: */
270: #ifdef PETSC_HAVE_FORTRAN_CAPS
271: #define msgemv_ MSGEMV
272: #define msgemvp_ MSGEMVP
273: #define msgemvm_ MSGEMVM
274: #define msgemvt_ MSGEMVT
275: #define msgemmi_ MSGEMMI
276: #define msgemm_ MSGEMM
277: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
278: #define msgemv_ msgemv
279: #define msgemvp_ msgemvp
280: #define msgemvm_ msgemvm
281: #define msgemvt_ msgemvt
282: #define msgemmi_ msgemmi
283: #define msgemm_ msgemm
284: #endif
286: EXTERN void msgemv_(PetscInt*,PetscInt *,MatScalar*,PetscScalar*,PetscScalar*);
287: EXTERN void msgemvp_(PetscInt*,PetscInt *,MatScalar*,PetscScalar*,PetscScalar*);
288: EXTERN void msgemvm_(PetscInt*,PetscInt *,MatScalar*,PetscScalar*,PetscScalar*);
289: EXTERN void msgemvt_(PetscInt*,PetscInt *,MatScalar*,PetscScalar*,PetscScalar*);
290: EXTERN void msgemmi_(PetscInt*,MatScalar*,MatScalar*,MatScalar*);
291: EXTERN void msgemm_(PetscInt*,MatScalar*,MatScalar*,MatScalar*);
294: /*
295: A = A * B A_gets_A_times_B
297: A, B - square bs by bs arrays stored in column major order
298: W - square bs by bs work array
300: */
301: #define Kernel_A_gets_A_times_B(bs,A,B,W) \
302: { \
303: PetscErrorCode _PetscMemcpy((W),(A),(bs)*(bs)*sizeof(MatScalar));CHKERRQ(_ierr); \
304: msgemmi_(&bs,A,B,W); \
305: }
307: /*
309: A = A - B * C A_gets_A_minus_B_times_C
311: A, B, C - square bs by bs arrays stored in column major order
312: */
313: #define Kernel_A_gets_A_minus_B_times_C(bs,A,B,C) \
314: { \
315: msgemm_(&bs,A,B,C); \
316: }
318: /*
319: v = v - A w v_gets_v_minus_A_times_w
321: v - array of length bs
322: A - square bs by bs array
323: w - array of length bs
324: */
325: #define Kernel_v_gets_v_minus_A_times_w(bs,v,A,w) \
326: { \
327: msgemvm_(&bs,&bs,A,w,v); \
328: }
330: /*
331: v = v + A w v_gets_v_plus_A_times_w
333: v - array of length bs
334: A - square bs by bs array
335: w - array of length bs
336: */
337: #define Kernel_v_gets_v_plus_A_times_w(bs,v,A,w) \
338: { \
339: msgemvp_(&bs,&bs,A,w,v);\
340: }
342: /*
343: v = v + A w v_gets_v_plus_Ar_times_w
345: v - array of length bs
346: A - square bs by bs array
347: w - array of length bs
348: */
349: #define Kernel_w_gets_w_plus_Ar_times_v(bs,ncol,v,A,w) \
350: { \
351: msgemvp_(&bs,&ncol,A,v,w);\
352: }
354: /*
355: w = A v w_gets_A_times_v
357: v - array of length bs
358: A - square bs by bs array
359: w - array of length bs
360: */
361: #define Kernel_w_gets_A_times_v(bs,v,A,w) \
362: { \
363: msgemv_(&bs,&bs,A,v,w);\
364: }
365:
366: /*
367: z = A*x
368: */
369: #define Kernel_w_gets_Ar_times_v(bs,ncols,x,A,z) \
370: { \
371: msgemv_(&bs,&ncols,A,x,z);\
372: }
374: /*
375: z = trans(A)*x
376: */
377: #define Kernel_w_gets_w_plus_trans_Ar_times_v(bs,ncols,x,A,z) \
378: { \
379: msgemvt_(&bs,&ncols,A,x,z);\
380: }
382: /* These do not work yet */
383: #define Kernel_A_gets_A_plus_Btranspose_times_C(bs,A,B,C)
384: #define Kernel_v_gets_v_plus_Atranspose_times_w(bs,v,A,w)
387: #endif
389: #endif