← Back to branch summary

~ubuntu-branches/ubuntu/trusty/nwchem/trusty-proposed

« back to all changes in this revision

Viewing changes to src/tools/ga-5-1/armci/src/xfer/caccumulate.c

  • Committer: Package Import Robot
  • Author(s): Michael Banck, Daniel Leidert, Andreas Tille, Michael Banck
  • Date: 2013-07-04 12:14:55 UTC
  • mfrom: (1.1.2)
  • Revision ID: package-import@ubuntu.com-20130704121455-5tvsx2qabor3nrui
Tags: 6.3-1
http://bugs.debian.org/696361
* New upstream release.
* Fixes anisotropic properties (Closes: #696361).
* New features include:
  + Multi-reference coupled cluster (MRCC) approaches
  + Hybrid DFT calculations with short-range HF 
  + New density-functionals including Minnesota (M08, M11) and HSE hybrid
    functionals
  + X-ray absorption spectroscopy (XAS) with TDDFT
  + Analytical gradients for the COSMO solvation model
  + Transition densities from TDDFT 
  + DFT+U and Electron-Transfer (ET) methods for plane wave calculations
  + Exploitation of space group symmetry in plane wave geometry optimizations
  + Local density of states (LDOS) collective variable added to Metadynamics
  + Various new XC functionals added for plane wave calculations, including
    hybrid and range-corrected ones
  + Electric field gradients with relativistic corrections 
  + Nudged Elastic Band optimization method
  + Updated basis sets and ECPs 

[ Daniel Leidert ]
* debian/watch: Fixed.

[ Andreas Tille ]
* debian/upstream: References

[ Michael Banck ]
* debian/upstream (Name): New field.
* debian/patches/02_makefile_flags.patch: Refreshed.
* debian/patches/06_statfs_kfreebsd.patch: Likewise.
* debian/patches/07_ga_target_force_linux.patch: Likewise.
* debian/patches/05_avoid_inline_assembler.patch: Removed, no longer needed.
* debian/patches/09_backported_6.1.1_fixes.patch: Likewise.
* debian/control (Build-Depends): Added gfortran-4.7 and gcc-4.7.
* debian/patches/10_force_gcc-4.7.patch: New patch, explicitly sets
  gfortran-4.7 and gcc-4.7, fixes test suite hang with gcc-4.8 (Closes:
  #701328, #713262).
* debian/testsuite: Added tests for COSMO analytical gradients and MRCC.
* debian/rules (MRCC_METHODS): New variable, required to enable MRCC methods.

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/tools/ga-5-1/armci/src/xfer/caccumulate.c
1
 
/***************************************************************************
2
 
 
3
 
                  COPYRIGHT
4
 
 
5
 
The following is a notice of limited availability of the code, and disclaimer
6
 
which must be included in the prologue of the code and in all source listings
7
 
of the code.
8
 
 
9
 
Copyright Notice
10
 
 + 2009 University of Chicago
11
 
 
12
 
Permission is hereby granted to use, reproduce, prepare derivative works, and
13
 
to redistribute to others.  This software was authored by:
14
 
 
15
 
Jeff R. Hammond
16
 
Leadership Computing Facility
17
 
Argonne National Laboratory
18
 
Argonne IL 60439 USA
19
 
phone: (630) 252-5381
20
 
e-mail: jhammond@anl.gov
21
 
 
22
 
                  GOVERNMENT LICENSE
23
 
 
24
 
Portions of this material resulted from work developed under a U.S.
25
 
Government Contract and are subject to the following license: the Government
26
 
is granted for itself and others acting on its behalf a paid-up, nonexclusive,
27
 
irrevocable worldwide license in this computer software to reproduce, prepare
28
 
derivative works, and perform publicly and display publicly.
29
 
 
30
 
                  DISCLAIMER
31
 
 
32
 
This computer code material was prepared, in part, as an account of work
33
 
sponsored by an agency of the United States Government.  Neither the United
34
 
States, nor the University of Chicago, nor any of their employees, makes any
35
 
warranty express or implied, or assumes any legal liability or responsibility
36
 
for the accuracy, completeness, or usefulness of any information, apparatus,
37
 
product, or process disclosed, or represents that its use would not infringe
38
 
privately owned rights.
39
 
 
40
 
 ***************************************************************************/
41
 
 
42
 
/***********************************************************************
43
 
 *     accumulate operation for the following datatypes:
44
 
 *            real, double precision, complex, double complex, integer
45
 
 *
46
 
 *     WARNING: This file must be compiled WITH optimization under AIX.
47
 
 *              IBM fortran compilers generate bad code with -g option. 
48
 
 *
49
 
 *     Two versions of each routine are provided: 
50
 
 *         original and unrolled loops.
51
 
 *
52
 
 ***********************************************************************/
53
 
#if HAVE_CONFIG_H
54
 
#   include "config.h"
55
 
#endif
56
 
 
57
 
#include "acc.h"
58
 
 
59
 
#if 0
60
 
      subroutine d_accumulate_1d(alpha,  A,  B, rows)
61
 
      integer rows, r
62
 
      double precision A(*), B(*), alpha
63
 
ccdir$ no_cache_alloc a,b
64
 
         do r = 1, rows
65
 
            A(r) = A(r)+ alpha*B(r)
66
 
         enddo
67
 
      end
68
 
#endif
69
 
 
70
 
void c_d_accumulate_1d_(const double* const restrict alpha,
71
 
                              double* restrict A,
72
 
                        const double* const restrict B,
73
 
                        const int*    const restrict rows)
74
 
{
75
 
    int i;
76
 
    for ( i = 0 ; i < (*rows) ; i++ ){
77
 
        A[i] += (*alpha) * B[i];
78
 
    }
79
 
    return;
80
 
}
81
 
 
82
 
 
83
 
#if 0
84
 
      subroutine d_accumulate_2d(alpha, rows, cols, A, ald, B, bld)
85
 
      integer rows, cols
86
 
      integer c, r, ald, bld
87
 
      double precision A(ald,*), B(bld,*), alpha
88
 
ccdir$ no_cache_alloc a,b
89
 
      do c = 1, cols
90
 
         do r = 1, rows
91
 
            A(r,c) = A(r,c)+ alpha*B(r,c)
92
 
         enddo
93
 
      enddo
94
 
      end
95
 
#endif
96
 
 
97
 
void c_d_accumulate_2d_(const double* const alpha,
98
 
                        const int* const rows,
99
 
                        const int* const cols,
100
 
                        double* restrict A,
101
 
                        const int* const ald,
102
 
                        const double* const B,
103
 
                        const int* const bld)
104
 
{
105
 
    int r, c;
106
 
    for ( c = 0 ; c < (*cols) ; c++ ){
107
 
        for ( r = 0 ; r < (*rows) ; r++ ){
108
 
            A[ c * (*ald) + r ] += (*alpha) * B[ c * (*bld) + r ];
109
 
        }
110
 
    }
111
 
    return;
112
 
}
113
 
 
114
 
#if 0
115
 
      subroutine f_accumulate_1d(alpha,  A,  B, rows)
116
 
      integer rows, r
117
 
      real A(*), B(*), alpha
118
 
         do r = 1, rows
119
 
            A(r) = A(r)+ alpha*B(r)
120
 
         enddo
121
 
      end
122
 
#endif
123
 
 
124
 
void c_f_accumulate_1d_(const float* const restrict alpha,
125
 
                              float* const restrict A,
126
 
                        const float* const restrict B,
127
 
                        const int*   const restrict rows)
128
 
{
129
 
    int i;
130
 
    for ( i = 0 ; i < (*rows) ; i++ ){
131
 
        A[i] += (*alpha) * B[i];
132
 
    }
133
 
    return;
134
 
}
135
 
 
136
 
#if 0
137
 
      subroutine f_accumulate_2d(alpha, rows, cols, A, ald, B, bld)
138
 
      integer rows, cols
139
 
      integer c, r, ald, bld
140
 
      real A(ald,*), B(bld,*), alpha
141
 
      do c = 1, cols
142
 
         do r = 1, rows
143
 
            A(r,c) = A(r,c)+ alpha*B(r,c)
144
 
         enddo
145
 
      enddo
146
 
      end
147
 
#endif
148
 
 
149
 
void c_f_accumulate_2d_(const float* const alpha,
150
 
                        const int* const rows,
151
 
                        const int* const cols,
152
 
                        float* restrict A,
153
 
                        const int* const ald,
154
 
                        const float* const B,
155
 
                        const int* const bld)
156
 
{
157
 
    int r, c;
158
 
    for ( c = 0 ; c < (*cols) ; c++ ){
159
 
        for ( r = 0 ; r < (*rows) ; r++ ){
160
 
            A[ c * (*ald) + r ] += (*alpha) * B[ c * (*bld) + r ];
161
 
        }
162
 
    }
163
 
    return;
164
 
}
165
 
 
166
 
#if 0
167
 
      subroutine z_accumulate_1d(alpha,  A,  B, rows)
168
 
      integer rows, r
169
 
      double complex  A(*), B(*), alpha
170
 
         do r = 1, rows
171
 
            A(r) = A(r)+ alpha*B(r)
172
 
         enddo
173
 
      end
174
 
#endif
175
 
 
176
 
void c_c_accumulate_1d_(const complex_t* const restrict alpha,
177
 
                              complex_t* const restrict A,
178
 
                        const complex_t* const restrict B,
179
 
                        const int*       const restrict rows)
180
 
{
181
 
    int i;
182
 
    for ( i = 0 ; i < (*rows) ; i++ ){
183
 
        A[i].real += (*alpha).real * B[i].real - (*alpha).imag * B[i].imag;
184
 
        A[i].imag += (*alpha).imag * B[i].real + (*alpha).real * B[i].imag;
185
 
    }
186
 
    return;
187
 
}
188
 
 
189
 
#if 0
190
 
      subroutine z_accumulate_2d(alpha, rows, cols, A, ald, B, bld)
191
 
      integer rows, cols
192
 
      integer c, r, ald, bld
193
 
      double complex A(ald,*), B(bld,*), alpha
194
 
      do c = 1, cols
195
 
         do r = 1, rows
196
 
            A(r,c) = A(r,c)+ alpha*B(r,c)
197
 
         enddo
198
 
      enddo
199
 
      end
200
 
#endif
201
 
 
202
 
void c_c_accumulate_2d_(const complex_t* const alpha,
203
 
                        const int* const rows,
204
 
                        const int* const cols,
205
 
                        complex_t* restrict A,
206
 
                        const int* const ald,
207
 
                        const complex_t* const B,
208
 
                        const int* const bld)
209
 
{
210
 
    int r, c;
211
 
    for ( c = 0 ; c < (*cols) ; c++ ) {
212
 
        for ( r = 0 ; r < (*rows) ; r++ ) {
213
 
            A[ c * (*ald) + r ].real += (*alpha).real * B[ c * (*bld) + r ].real - (*alpha).imag * B[ c * (*bld) + r ].imag;
214
 
            A[ c * (*ald) + r ].imag += (*alpha).imag * B[ c * (*bld) + r ].real + (*alpha).real * B[ c * (*bld) + r ].imag;
215
 
        }
216
 
    }
217
 
    return;
218
 
}
219
 
 
220
 
#if 0
221
 
      subroutine c_accumulate_1d(alpha,  A,  B, rows)
222
 
      integer rows, r
223
 
      complex  A(*), B(*), alpha
224
 
         do r = 1, rows
225
 
            A(r) = A(r)+ alpha*B(r)
226
 
         enddo
227
 
      end
228
 
#endif
229
 
 
230
 
void c_z_accumulate_1d_(const dcomplex_t* const restrict alpha,
231
 
                              dcomplex_t* const restrict A,
232
 
                        const dcomplex_t* const restrict B,
233
 
                        const int*        const restrict rows)
234
 
{
235
 
    int i;
236
 
    for ( i = 0 ; i < (*rows) ; i++ ){
237
 
        A[i].real += (*alpha).real * B[i].real - (*alpha).imag * B[i].imag;
238
 
        A[i].imag += (*alpha).imag * B[i].real + (*alpha).real * B[i].imag;
239
 
    }
240
 
    return;
241
 
}
242
 
 
243
 
#if 0
244
 
      subroutine c_accumulate_2d(alpha, rows, cols, A, ald, B, bld)
245
 
      integer rows, cols
246
 
      integer c, r, ald, bld
247
 
      complex A(ald,*), B(bld,*), alpha
248
 
      do c = 1, cols
249
 
         do r = 1, rows
250
 
            A(r,c) = A(r,c)+ alpha*B(r,c)
251
 
         enddo
252
 
      enddo
253
 
      end
254
 
#endif
255
 
 
256
 
void c_z_accumulate_2d_(const dcomplex_t* const alpha,
257
 
                        const int* const rows,
258
 
                        const int* const cols,
259
 
                        dcomplex_t* restrict A,
260
 
                        const int* const ald,
261
 
                        const dcomplex_t* const B,
262
 
                        const int* const bld)
263
 
{
264
 
    int r, c;
265
 
    for ( c = 0 ; c < (*cols) ; c++ ) {
266
 
        for ( r = 0 ; r < (*rows) ; r++ ) {
267
 
            A[ c * (*ald) + r ].real += (*alpha).real * B[ c * (*bld) + r ].real - (*alpha).imag * B[ c * (*bld) + r ].imag;
268
 
            A[ c * (*ald) + r ].imag += (*alpha).imag * B[ c * (*bld) + r ].real + (*alpha).real * B[ c * (*bld) + r ].imag;
269
 
        }
270
 
    }
271
 
    return;
272
 
}
273
 
 
274
 
#if 0
275
 
      subroutine i_accumulate_2d(alpha, rows, cols, A, ald, B, bld)
276
 
      integer rows, cols
277
 
      integer c, r, ald, bld
278
 
      integer A(ald,*), B(bld,*), alpha
279
 
      do c = 1, cols
280
 
         do r = 1, rows
281
 
            A(r,c) = A(r,c)+ alpha*B(r,c)
282
 
         enddo
283
 
      enddo
284
 
      end
285
 
#endif
286
 
 
287
 
void c_i_accumulate_1d_(const int* const restrict alpha,
288
 
                              int* const restrict A,
289
 
                        const int* const restrict B,
290
 
                        const int* const restrict rows)
291
 
{
292
 
    int i;
293
 
    for ( i = 0 ; i < (*rows) ; i++ ){
294
 
        A[i] += (*alpha) * B[i];
295
 
    }
296
 
    return;
297
 
}
298
 
 
299
 
void c_l_accumulate_1d_(const long* const restrict alpha,
300
 
                              long* const restrict A,
301
 
                        const long* const restrict B,
302
 
                        const int*  const restrict rows)
303
 
{
304
 
    int i;
305
 
    for ( i = 0 ; i < (*rows) ; i++ ){
306
 
        A[i] += (*alpha) * B[i];
307
 
    }
308
 
    return;
309
 
}
310
 
 
311
 
void c_ll_accumulate_1d_(const long long* const restrict alpha,
312
 
                               long long* const restrict A,
313
 
                         const long long* const restrict B,
314
 
                         const int*       const restrict rows)
315
 
{
316
 
    int i;
317
 
    for ( i = 0 ; i < (*rows) ; i++ ){
318
 
        A[i] += (*alpha) * B[i];
319
 
    }
320
 
    return;
321
 
}
322
 
 
323
 
#if 0
324
 
      subroutine i_accumulate_1d(alpha,  A,  B, rows)
325
 
      integer rows, r
326
 
      integer A(*), B(*), alpha
327
 
         do r = 1, rows
328
 
            A(r) = A(r)+ alpha*B(r)
329
 
         enddo
330
 
      end
331
 
#endif
332
 
 
333
 
void c_i_accumulate_2d_(const int* const alpha,
334
 
                        const int* const rows,
335
 
                        const int* const cols,
336
 
                        int* restrict A,
337
 
                        const int* const ald,
338
 
                        const int* const B,
339
 
                        const int* const bld)
340
 
{
341
 
    int r, c;
342
 
    for ( c = 0 ; c < (*cols) ; c++ ){
343
 
        for ( r = 0 ; r < (*rows) ; r++ ){
344
 
            A[ c * (*ald) + r ] += (*alpha) * B[ c * (*bld) + r ];
345
 
        }
346
 
    }
347
 
    return;
348
 
}
349
 
 
350
 
void c_l_accumulate_2d_(const long* const alpha,
351
 
                        const int* const rows,
352
 
                        const int* const cols,
353
 
                        long* restrict A,
354
 
                        const int* const ald,
355
 
                        const long* const B,
356
 
                        const int* const bld)
357
 
{
358
 
    int r, c;
359
 
    for ( c = 0 ; c < (*cols) ; c++ ){
360
 
        for ( r = 0 ; r < (*rows) ; r++ ){
361
 
            A[ c * (*ald) + r ] += (*alpha) * B[ c * (*bld) + r ];
362
 
        }
363
 
    }
364
 
    return;
365
 
}
366
 
 
367
 
void c_ll_accumulate_2d_(const long long* const alpha,
368
 
                        const int* const rows,
369
 
                        const int* const cols,
370
 
                        long long* restrict A,
371
 
                        const int* const ald,
372
 
                        const long long* const B,
373
 
                        const int* const bld)
374
 
{
375
 
    int r, c;
376
 
    for ( c = 0 ; c < (*cols) ; c++ ){
377
 
        for ( r = 0 ; r < (*rows) ; r++ ){
378
 
            A[ c * (*ald) + r ] += (*alpha) * B[ c * (*bld) + r ];
379
 
        }
380
 
    }
381
 
    return;
382
 
}
383
 
 
384
 
#if 0
385
 
      subroutine d_accumulate_2d_u(alpha, rows, cols, A, ald, B, bld)
386
 
      integer rows, cols
387
 
      integer c, r, ald, bld
388
 
      double precision A(ald,*), B(bld,*), alpha
389
 
      integer r1
390
 
      doubleprecision d1, d2, d3, d4
391
 
      do c = 1, cols
392
 
        r1 = iand(max0(rows,0),3)
393
 
        do r = 1, r1
394
 
            a(r,c) = a(r,c) + alpha*b(r,c)
395
 
        end do
396
 
        do r = r1 + 1, rows, 4
397
 
            d1 = a(r,c) + alpha*b(r,c)
398
 
            d2 = a(r+1,c) + alpha*b(r+1,c)
399
 
            d3 = a(r+2,c) + alpha*b(r+2,c)
400
 
            d4 = a(r+3,c) + alpha*b(r+3,c)
401
 
            a(r,c) = d1
402
 
            a(r+1,c) = d2
403
 
            a(r+2,c) = d3
404
 
            a(r+3,c) = d4
405
 
        enddo
406
 
      enddo
407
 
      end
408
 
#endif
409
 
 
410
 
void c_d_accumulate_2d_u_(const double* const alpha,
411
 
                          const int* const rows,
412
 
                          const int* const cols,
413
 
                          double* restrict A,
414
 
                          const int* const ald,
415
 
                          const double* const B,
416
 
                          const int* const bld)
417
 
{
418
 
    int r, c;
419
 
    int m = (*rows) - ((*rows)%4);
420
 
    for ( c = 0 ; c < (*cols) ; c++ ){
421
 
        for ( r = 0 ; r < m ; r+=4 ){
422
 
            A[ c * (*ald) + r   ] += (*alpha) * B[ c * (*bld) + r   ];
423
 
            A[ c * (*ald) + r+1 ] += (*alpha) * B[ c * (*bld) + r+1 ];
424
 
            A[ c * (*ald) + r+2 ] += (*alpha) * B[ c * (*bld) + r+2 ];
425
 
            A[ c * (*ald) + r+3 ] += (*alpha) * B[ c * (*bld) + r+3 ];
426
 
        }
427
 
        for ( r = m ; r < (*rows) ; r++ ){
428
 
            A[ c * (*ald) + r ] += (*alpha) * B[ c * (*bld) + r ];
429
 
        }
430
 
    }
431
 
    return;
432
 
}
433
 
 
434
 
#if 0
435
 
      subroutine f_accumulate_2d_u(alpha, rows, cols, A, ald, B, bld)
436
 
      integer rows, cols
437
 
      integer c, r, ald, bld
438
 
      real A(ald,*), B(bld,*), alpha
439
 
      integer r1
440
 
      real d1, d2, d3, d4
441
 
      do c = 1, cols
442
 
      r1 = iand(max0(rows,0),3)
443
 
      do r = 1, r1
444
 
         a(r,c) = a(r,c) + alpha*b(r,c)
445
 
      end do
446
 
      do r = r1 + 1, rows, 4
447
 
         d1 = a(r,c) + alpha*b(r,c)
448
 
         d2 = a(r+1,c) + alpha*b(r+1,c)
449
 
         d3 = a(r+2,c) + alpha*b(r+2,c)
450
 
         d4 = a(r+3,c) + alpha*b(r+3,c)
451
 
         a(r,c) = d1
452
 
         a(r+1,c) = d2
453
 
         a(r+2,c) = d3
454
 
         a(r+3,c) = d4
455
 
      enddo
456
 
      enddo
457
 
      end
458
 
#endif
459
 
 
460
 
void c_f_accumulate_2d_u_(const float* const alpha,
461
 
                          const int* const rows,
462
 
                          const int* const cols,
463
 
                          float* restrict A,
464
 
                          const int* const ald,
465
 
                          const float* const B,
466
 
                          const int* const bld)
467
 
{
468
 
    int r, c;
469
 
    int m = (*rows) - ((*rows)%4);
470
 
    for ( c = 0 ; c < (*cols) ; c++ ){
471
 
        for ( r = 0 ; r < m ; r+=4 ){
472
 
            A[ c * (*ald) + r   ] += (*alpha) * B[ c * (*bld) + r   ];
473
 
            A[ c * (*ald) + r+1 ] += (*alpha) * B[ c * (*bld) + r+1 ];
474
 
            A[ c * (*ald) + r+2 ] += (*alpha) * B[ c * (*bld) + r+2 ];
475
 
            A[ c * (*ald) + r+3 ] += (*alpha) * B[ c * (*bld) + r+3 ];
476
 
        }
477
 
        for ( r = m ; r < (*rows) ; r++ ){
478
 
            A[ c * (*ald) + r ] += (*alpha) * B[ c * (*bld) + r ];
479
 
        }
480
 
    }
481
 
    return;
482
 
}
483
 
 
484
 
#if 0
485
 
      subroutine z_accumulate_2d_u(alpha, rows, cols, A, ald, B, bld)
486
 
      integer rows, cols
487
 
      integer c, r, ald, bld
488
 
      double complex A(ald,*), B(bld,*), alpha
489
 
      integer r1
490
 
      double complex x1, x2, x3, x4
491
 
      do c = 1, cols
492
 
      r1 = iand(max0(rows,0),3)
493
 
      do r = 1, r1
494
 
         a(r,c) = a(r,c) + alpha*b(r,c)
495
 
      end do
496
 
      do r = r1 + 1, rows, 4
497
 
         x1 = a(r,c) + alpha*b(r,c)
498
 
         x2 = a(r+1,c) + alpha*b(r+1,c)
499
 
         x3 = a(r+2,c) + alpha*b(r+2,c)
500
 
         x4 = a(r+3,c) + alpha*b(r+3,c)
501
 
         a(r,c) = x1
502
 
         a(r+1,c) = x2
503
 
         a(r+2,c) = x3
504
 
         a(r+3,c) = x4
505
 
      enddo
506
 
      enddo
507
 
      end
508
 
#endif
509
 
 
510
 
void c_c_accumulate_2d_u_(const complex_t* const alpha,
511
 
                          const int* const rows,
512
 
                          const int* const cols,
513
 
                          complex_t* restrict A,
514
 
                          const int* const ald,
515
 
                          const complex_t* const B,
516
 
                          const int* const bld)
517
 
{
518
 
    int r, c;
519
 
    int jA, jB;
520
 
    int m = (*rows) - ((*rows)%4);
521
 
    for ( c = 0 ; c < (*cols) ; c++ ){
522
 
        for ( r = 0 ; r < m ; r+=4 ){
523
 
            jA = c * (*ald) + r;
524
 
            jB = c * (*bld) + r;
525
 
            A[ jA   ].real += (*alpha).real * B[ jB   ].real - (*alpha).imag * B[ jB   ].imag;
526
 
            A[ jA   ].imag += (*alpha).imag * B[ jB   ].real + (*alpha).real * B[ jB   ].imag;
527
 
            A[ jA+1 ].real += (*alpha).real * B[ jB+1 ].real - (*alpha).imag * B[ jB+1 ].imag;
528
 
            A[ jA+1 ].imag += (*alpha).imag * B[ jB+1 ].real + (*alpha).real * B[ jB+1 ].imag;
529
 
            A[ jA+2 ].real += (*alpha).real * B[ jB+2 ].real - (*alpha).imag * B[ jB+2 ].imag;
530
 
            A[ jA+2 ].imag += (*alpha).imag * B[ jB+2 ].real + (*alpha).real * B[ jB+2 ].imag;
531
 
            A[ jA+3 ].real += (*alpha).real * B[ jB+3 ].real - (*alpha).imag * B[ jB+3 ].imag;
532
 
            A[ jA+3 ].imag += (*alpha).imag * B[ jB+3 ].real + (*alpha).real * B[ jB+3 ].imag;
533
 
        }
534
 
        for ( r = m ; r < (*rows) ; r++ ){
535
 
            A[ c * (*ald) + r ].real += (*alpha).real * B[ c * (*bld) + r ].real - (*alpha).imag * B[ c * (*bld) + r ].imag;
536
 
            A[ c * (*ald) + r ].imag += (*alpha).imag * B[ c * (*bld) + r ].real + (*alpha).real * B[ c * (*bld) + r ].imag;
537
 
        }
538
 
    }
539
 
    return;
540
 
}
541
 
 
542
 
#if 0
543
 
      subroutine c_accumulate_2d_u(alpha, rows, cols, A, ald, B, bld)
544
 
      integer rows, cols
545
 
      integer c, r, ald, bld
546
 
      complex A(ald,*), B(bld,*), alpha
547
 
      integer r1
548
 
      complex x1, x2, x3, x4
549
 
      do c = 1, cols
550
 
      r1 = iand(max0(rows,0),3)
551
 
      do r = 1, r1
552
 
         a(r,c) = a(r,c) + alpha*b(r,c)
553
 
      end do
554
 
      do r = r1 + 1, rows, 4
555
 
         x1 = a(r,c) + alpha*b(r,c)
556
 
         x2 = a(r+1,c) + alpha*b(r+1,c)
557
 
         x3 = a(r+2,c) + alpha*b(r+2,c)
558
 
         x4 = a(r+3,c) + alpha*b(r+3,c)
559
 
         a(r,c) = x1
560
 
         a(r+1,c) = x2
561
 
         a(r+2,c) = x3
562
 
         a(r+3,c) = x4
563
 
      enddo
564
 
      enddo
565
 
      end
566
 
#endif
567
 
 
568
 
void c_z_accumulate_2d_u_(const dcomplex_t* const alpha,
569
 
                          const int* const rows,
570
 
                          const int* const cols,
571
 
                          dcomplex_t* restrict A,
572
 
                          const int* const ald,
573
 
                          const dcomplex_t* const B,
574
 
                          const int* const bld)
575
 
{
576
 
    int r, c;
577
 
    int jA, jB;
578
 
    int m = (*rows) - ((*rows)%4);
579
 
    for ( c = 0 ; c < (*cols) ; c++ ){
580
 
        for ( r = 0 ; r < m ; r+=4 ){
581
 
            jA = c * (*ald) + r;
582
 
            jB = c * (*bld) + r;
583
 
            A[ jA   ].real += (*alpha).real * B[ jB   ].real - (*alpha).imag * B[ jB   ].imag;
584
 
            A[ jA   ].imag += (*alpha).imag * B[ jB   ].real + (*alpha).real * B[ jB   ].imag;
585
 
            A[ jA+1 ].real += (*alpha).real * B[ jB+1 ].real - (*alpha).imag * B[ jB+1 ].imag;
586
 
            A[ jA+1 ].imag += (*alpha).imag * B[ jB+1 ].real + (*alpha).real * B[ jB+1 ].imag;
587
 
            A[ jA+2 ].real += (*alpha).real * B[ jB+2 ].real - (*alpha).imag * B[ jB+2 ].imag;
588
 
            A[ jA+2 ].imag += (*alpha).imag * B[ jB+2 ].real + (*alpha).real * B[ jB+2 ].imag;
589
 
            A[ jA+3 ].real += (*alpha).real * B[ jB+3 ].real - (*alpha).imag * B[ jB+3 ].imag;
590
 
            A[ jA+3 ].imag += (*alpha).imag * B[ jB+3 ].real + (*alpha).real * B[ jB+3 ].imag;
591
 
        }
592
 
        for ( r = m ; r < (*rows) ; r++ ){
593
 
            A[ c * (*ald) + r ].real += (*alpha).real * B[ c * (*bld) + r ].real - (*alpha).imag * B[ c * (*bld) + r ].imag;
594
 
            A[ c * (*ald) + r ].imag += (*alpha).imag * B[ c * (*bld) + r ].real + (*alpha).real * B[ c * (*bld) + r ].imag;
595
 
        }
596
 
    }
597
 
    return;
598
 
}
599
 
 
600
 
#if 0
601
 
      subroutine i_accumulate_2d_u(alpha, rows, cols, A, ald, B, bld)
602
 
      integer rows, cols
603
 
      integer c, r, ald, bld
604
 
      integer A(ald,*), B(bld,*), alpha
605
 
 
606
 
      integer r1, j2, j3, j4, j5
607
 
      do c = 1, cols
608
 
      r1 = iand(max0(rows,0),3)
609
 
      do r = 1, r1
610
 
         a(r,c) = a(r,c) + alpha*b(r,c)
611
 
      end do
612
 
      do r = r1 + 1, rows, 4
613
 
         j2 = a(r,c) + alpha*b(r,c)
614
 
         j3 = a(r+1,c) + alpha*b(r+1,c)
615
 
         j4 = a(r+2,c) + alpha*b(r+2,c)
616
 
         j5 = a(r+3,c) + alpha*b(r+3,c)
617
 
         a(r,c) = j2
618
 
         a(r+1,c) = j3
619
 
         a(r+2,c) = j4
620
 
         a(r+3,c) = j5
621
 
      enddo
622
 
      enddo
623
 
      end
624
 
#endif
625
 
 
626
 
void c_i_accumulate_2d_u_(const int* const alpha,
627
 
                          const int* const rows,
628
 
                          const int* const cols,
629
 
                          int* restrict A,
630
 
                          const int* const ald,
631
 
                          const int* const B,
632
 
                          const int* const bld)
633
 
{
634
 
    int r, c;
635
 
    int m = (*rows) - ((*rows)%4);
636
 
    for ( c = 0 ; c < (*cols) ; c++ ){
637
 
        for ( r = 0 ; r < m ; r+=4 ){
638
 
            A[ c * (*ald) + r   ] += (*alpha) * B[ c * (*bld) + r   ];
639
 
            A[ c * (*ald) + r+1 ] += (*alpha) * B[ c * (*bld) + r+1 ];
640
 
            A[ c * (*ald) + r+2 ] += (*alpha) * B[ c * (*bld) + r+2 ];
641
 
            A[ c * (*ald) + r+3 ] += (*alpha) * B[ c * (*bld) + r+3 ];
642
 
        }
643
 
        for ( r = m ; r < (*rows) ; r++ ){
644
 
            A[ c * (*ald) + r ] += (*alpha) * B[ c * (*bld) + r ];
645
 
        }
646
 
    }
647
 
    return;
648
 
}
649
 
 
650
 
void c_l_accumulate_2d_u_(const long* const alpha,
651
 
                          const int* const rows,
652
 
                          const int* const cols,
653
 
                          long* restrict A,
654
 
                          const int* const ald,
655
 
                          const long* const B,
656
 
                          const int* const bld)
657
 
{
658
 
    int r, c;
659
 
    int m = (*rows) - ((*rows)%4);
660
 
    for ( c = 0 ; c < (*cols) ; c++ ){
661
 
        for ( r = 0 ; r < m ; r+=4 ){
662
 
            A[ c * (*ald) + r   ] += (*alpha) * B[ c * (*bld) + r   ];
663
 
            A[ c * (*ald) + r+1 ] += (*alpha) * B[ c * (*bld) + r+1 ];
664
 
            A[ c * (*ald) + r+2 ] += (*alpha) * B[ c * (*bld) + r+2 ];
665
 
            A[ c * (*ald) + r+3 ] += (*alpha) * B[ c * (*bld) + r+3 ];
666
 
        }
667
 
        for ( r = m ; r < (*rows) ; r++ ){
668
 
            A[ c * (*ald) + r ] += (*alpha) * B[ c * (*bld) + r ];
669
 
        }
670
 
    }
671
 
    return;
672
 
}
673
 
 
674
 
void c_ll_accumulate_2d_u_(const long long* const alpha,
675
 
                           const int* const rows,
676
 
                           const int* const cols,
677
 
                           long long* restrict A,
678
 
                           const int* const ald,
679
 
                           const long long* const B,
680
 
                           const int* const bld)
681
 
{
682
 
    int r, c;
683
 
    int m = (*rows) - ((*rows)%4);
684
 
    for ( c = 0 ; c < (*cols) ; c++ ){
685
 
        for ( r = 0 ; r < m ; r+=4 ){
686
 
            A[ c * (*ald) + r   ] += (*alpha) * B[ c * (*bld) + r   ];
687
 
            A[ c * (*ald) + r+1 ] += (*alpha) * B[ c * (*bld) + r+1 ];
688
 
            A[ c * (*ald) + r+2 ] += (*alpha) * B[ c * (*bld) + r+2 ];
689
 
            A[ c * (*ald) + r+3 ] += (*alpha) * B[ c * (*bld) + r+3 ];
690
 
        }
691
 
        for ( r = m ; r < (*rows) ; r++ ){
692
 
            A[ c * (*ald) + r ] += (*alpha) * B[ c * (*bld) + r ];
693
 
        }
694
 
    }
695
 
    return;
696
 
}
697
 
 
698
 
#if 0
699
 
c---------- operations used in armci gops --------------
700
 
c
701
 
      subroutine fort_dadd(n, x, work)
702
 
      integer n,i
703
 
      double precision x(n), work(n)
704
 
      do i= 1,n
705
 
         x(i) = x(i) + work(i)
706
 
      enddo
707
 
      end
708
 
#endif
709
 
 
710
 
void c_dadd_(const int*    const restrict n,
711
 
                   double* const restrict x,
712
 
             const double* const restrict work)
713
 
{
714
 
    int i;
715
 
    for ( i = 0 ; i < (*n) ; i++ ){
716
 
        x[i] += work[i];
717
 
    }
718
 
    return;
719
 
}
720
 
 
721
 
#if 0
722
 
      subroutine fort_dadd2(n, x, work, work2)
723
 
      integer n,i
724
 
      double precision x(n), work(n), work2(n)
725
 
      do i= 1,n
726
 
         x(i) = work(i) + work2(i)
727
 
      enddo
728
 
      end
729
 
#endif
730
 
 
731
 
void c_dadd2_(const int*    const restrict n,
732
 
                    double* const restrict x,
733
 
              const double* const restrict work,
734
 
              const double* const restrict work2)
735
 
{
736
 
    int i;
737
 
    for ( i = 0 ; i < (*n) ; i++ ){
738
 
        x[i] = work[i] + work2[i];
739
 
    }
740
 
    return;
741
 
}
742
 
 
743
 
#if 0
744
 
      subroutine fort_dmult(n, x, work)
745
 
      integer n,i
746
 
      double precision x(n), work(n)
747
 
      do i= 1,n
748
 
         x(i) = x(i) * work(i)
749
 
      enddo
750
 
      end
751
 
#endif
752
 
 
753
 
void c_dmult_(const int*    const restrict n,
754
 
                    double* const restrict x,
755
 
              const double* const restrict work)
756
 
{
757
 
    int i;
758
 
    for ( i = 0 ; i < (*n) ; i++ ){
759
 
        x[i] *= work[i];
760
 
    }
761
 
    return;
762
 
}
763
 
 
764
 
#if 0
765
 
      subroutine fort_dmult2(n, x, work,work2)
766
 
      integer n,i
767
 
      double precision x(n), work(n)
768
 
      do i= 1,n
769
 
         x(i) = work(i)*work2(i)
770
 
      enddo
771
 
      end
772
 
#endif
773
 
 
774
 
void c_dmult2_(const int*    const restrict n,
775
 
                     double* const restrict x,
776
 
               const double* const restrict work,
777
 
               const double* const restrict work2)
778
 
{
779
 
    int i;
780
 
    for ( i = 0 ; i < (*n) ; i++ ){
781
 
        x[i] = work[i] * work2[i];
782
 
    }
783
 
    return;
784
 
}