← 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-2/global/testing/blktest.F

  • 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-2/global/testing/blktest.F
 
1
#if HAVE_CONFIG_H
 
2
#   include "config.fh"
 
3
#endif
 
4
c vector boxes lack arithmetic precision 
 
5
#ifdef CRAY_YMP
 
6
# define THRESH 1d-10
 
7
#elif defined(FUJITSU)
 
8
# define THRESH 1d-12
 
9
# define THRESHF 1e-5
 
10
#else
 
11
# define THRESH 1d-13
 
12
# define THRESHF 1e-5
 
13
#endif
 
14
#define MISMATCH(x,y) abs(x-y)/max(1d0,abs(x)).gt.THRESH
 
15
#define MISMATCHF(x,y) abs(x-y)/max(1.0,abs(x)).gt.THRESHF
 
16
 
 
17
#define USE_SCALAPACK 0
 
18
#define SMALL_TEST 1
 
19
 
 
20
      program main
 
21
      implicit none
 
22
#include "mafdecls.fh"
 
23
#include "global.fh"
 
24
#include "testutil.fh"
 
25
      integer heap, stack, fudge, ma_heap, me
 
26
      integer nmax, DIM
 
27
#if SMALL_TEST
 
28
      parameter (nmax = 8, DIM = 2)
 
29
#else
 
30
      parameter (nmax = 2375, DIM = 2)
 
31
#endif
 
32
      integer ndim, nprocs, type, length
 
33
      integer g_a, g_b, g_c, g_d, g_e, g_f, g_h, g_i, g_j, inode
 
34
      MA_ACCESS_INDEX_TYPE index
 
35
      integer i, j, k, nb, dims(7)
 
36
      integer lo(7), hi(7), tlo(7), thi(7), t2lo(7), t2hi(7)
 
37
      integer block_list(10000), block_map(10000), nblock
 
38
      integer chunk(7), ld(7), block(7), proc_grid(7)
 
39
      integer a(nmax, nmax),b(nmax,nmax),e(nmax,nmax),f(nmax,nmax)
 
40
      integer skip(7), i_one, ialpha, ibeta, check_int
 
41
      double precision c(nmax,nmax),d(nmax,nmax), one, ddot
 
42
      double precision alpha, beta
 
43
      logical status
 
44
      parameter (heap=400*400*4, fudge=100, stack=400*400*4)
 
45
c
 
46
c***  Intitialize a message passing library
 
47
c
 
48
#include "mp3.fh"
 
49
c
 
50
c***  Initialize GA
 
51
c
 
52
      call ga_initialize()
 
53
      me = ga_nodeid()
 
54
c
 
55
      ma_heap = heap + fudge 
 
56
c
 
57
      if(me.eq.0)then
 
58
        write(6,100)
 
59
        call ffflush(6)
 
60
  100   format(' GA initialized')
 
61
      endif
 
62
c
 
63
c***  Initialize the MA package
 
64
c     MA must be initialized before any global array is allocated
 
65
c
 
66
      status = ma_init(MT_DBL, stack, ma_heap)
 
67
      if (.not. status) call ga_error('ma_init failed',-1) 
 
68
c
 
69
      if(me.eq.0)then
 
70
        write(6,101) ga_nnodes()
 
71
        call ffflush(6)
 
72
  101   format(' Using ',i3,' process(es)')
 
73
      endif
 
74
c
 
75
c  Create GA
 
76
c
 
77
      ndim = DIM
 
78
      do i = 1, ndim
 
79
        dims(i) = nmax
 
80
        ld(i) = nmax
 
81
        lo(i) = 1
 
82
        hi(i) = nmax
 
83
        chunk(i) = -1
 
84
#if SMALL_TEST
 
85
        block(i) = 2 
 
86
#else
 
87
        block(i) = 87
 
88
#endif
 
89
      end do
 
90
      proc_grid(1) = 2
 
91
      proc_grid(2) = ga_nnodes()/2
 
92
c
 
93
      g_a = ga_create_handle() 
 
94
      call ga_set_data(g_a, ndim, dims, MT_F_INT)
 
95
      call ga_set_chunk(g_a, chunk)
 
96
#if USE_SCALAPACK
 
97
      call ga_set_block_cyclic_proc_grid(g_a, block, proc_grid)
 
98
#else
 
99
      call ga_set_block_cyclic(g_a, block)
 
100
#endif
 
101
      status = ga_allocate(g_a)
 
102
      call ga_zero(g_a)
 
103
c
 
104
      g_b = ga_create_handle() 
 
105
      call ga_set_data(g_b, ndim, dims, MT_F_DBL)
 
106
      call ga_set_chunk(g_b, chunk)
 
107
#if USE_SCALAPACK
 
108
      call ga_set_block_cyclic_proc_grid(g_b, block, proc_grid)
 
109
#else
 
110
      call ga_set_block_cyclic(g_b, block)
 
111
#endif
 
112
      status = ga_allocate(g_b)
 
113
      call ga_zero(g_b)
 
114
c
 
115
      g_c = ga_create_handle() 
 
116
      call ga_set_data(g_c, ndim, dims, MT_F_INT)
 
117
      call ga_set_chunk(g_c, chunk)
 
118
      status = ga_allocate(g_c)
 
119
      call ga_zero(g_c)
 
120
c
 
121
      g_d = ga_create_handle() 
 
122
      call ga_set_data(g_d, ndim, dims, MT_F_INT)
 
123
      call ga_set_chunk(g_d, chunk)
 
124
#if USE_SCALAPACK
 
125
      call ga_set_block_cyclic_proc_grid(g_d, block, proc_grid)
 
126
#else
 
127
      call ga_set_block_cyclic(g_d, block)
 
128
#endif
 
129
      status = ga_allocate(g_d)
 
130
      call ga_zero(g_d)
 
131
c
 
132
      g_e = ga_create_handle() 
 
133
      call ga_set_data(g_e, ndim, dims, MT_F_DBL)
 
134
      call ga_set_chunk(g_e, chunk)
 
135
#if USE_SCALAPACK
 
136
      call ga_set_block_cyclic_proc_grid(g_e, block, proc_grid)
 
137
#else
 
138
      call ga_set_block_cyclic(g_e, block)
 
139
#endif
 
140
      status = ga_allocate(g_e)
 
141
      call ga_zero(g_e)
 
142
c
 
143
      g_f = ga_create_handle() 
 
144
      call ga_set_data(g_f, ndim, dims, MT_F_DBL)
 
145
      call ga_set_chunk(g_f, chunk)
 
146
#if USE_SCALAPACK
 
147
      call ga_set_block_cyclic_proc_grid(g_f, block, proc_grid)
 
148
#else
 
149
      call ga_set_block_cyclic(g_f, block)
 
150
#endif
 
151
      status = ga_allocate(g_f)
 
152
      call ga_zero(g_f)
 
153
c
 
154
      g_h = ga_create_handle() 
 
155
      call ga_set_data(g_h, ndim, dims, MT_F_DBL)
 
156
      call ga_set_chunk(g_h, chunk)
 
157
      status = ga_allocate(g_h)
 
158
      call ga_zero(g_h)
 
159
c
 
160
      g_i = ga_create_handle() 
 
161
      call ga_set_data(g_i, ndim, dims, MT_F_DBL)
 
162
      call ga_set_chunk(g_i, chunk)
 
163
      status = ga_allocate(g_i)
 
164
      call ga_zero(g_i)
 
165
c
 
166
      g_j = ga_create_handle() 
 
167
      call ga_set_data(g_j, ndim, dims, MT_F_DBL)
 
168
      call ga_set_chunk(g_j, chunk)
 
169
      status = ga_allocate(g_j)
 
170
      call ga_zero(g_j)
 
171
c
 
172
      if(me.eq.0)then
 
173
        write(6,102)
 
174
        call ffflush(6)
 
175
  102   format(' Completed allocation of GAs')
 
176
      endif
 
177
c
 
178
c  Initialize local arrays
 
179
c
 
180
#if SMALL_TEST
 
181
      tlo(1) = 3
 
182
      thi(1) = 4
 
183
      tlo(2) = 4
 
184
      thi(2) = 7
 
185
      t2lo(1) = 4
 
186
      t2hi(1) = 5
 
187
      t2lo(2) = 5
 
188
      t2hi(2) = 8
 
189
#else
 
190
      tlo(1) = 3
 
191
      thi(1) = 2277
 
192
      tlo(2) = 4
 
193
      thi(2) = 1832
 
194
      t2lo(1) = 4
 
195
      t2hi(1) = 2278
 
196
      t2lo(2) = 5
 
197
      t2hi(2) = 1833
 
198
#endif
 
199
c
 
200
      one = 1.0d00
 
201
      i_one = 1
 
202
      k = 1
 
203
      do i = 1, nmax
 
204
        do j = 1, nmax
 
205
          a(i,j) = k
 
206
          b(i,j) = 0
 
207
          c(i,j) = dble(k)
 
208
          d(i,j) = 0.0d00
 
209
          e(i,j) = 0
 
210
          f(i,j) = 0
 
211
          k = k + 1
 
212
        end do
 
213
      end do
 
214
c
 
215
c  Test PUT and GET
 
216
c
 
217
      if (me.eq.0) then
 
218
        write(6,*)
 
219
        write(6,*) 'Testing GA_Put and GA_Get...'
 
220
        write(6,*)
 
221
      endif
 
222
c
 
223
c  Copy data from local array to global array
 
224
c
 
225
      if (me.eq.0) then
 
226
        call nga_put(g_a,lo,hi,a,ld)
 
227
      endif
 
228
c
 
229
c  Copy data from global array back to local array
 
230
c
 
231
      call ga_sync
 
232
      call nga_get(g_a,lo,hi,e,ld)
 
233
      call ga_sync
 
234
c
 
235
      do j = 1, nmax
 
236
        do i = 1, nmax
 
237
          if (a(i,j).ne.e(i,j)) then
 
238
            write(6,103) me,a(i,j),e(i,j)
 
239
            call ga_error('GA PUT and GET failed',me)
 
240
          endif
 
241
          e(i,j) = 0
 
242
        end do
 
243
      end do
 
244
  103 format('proc: ',i4,' a(i,j): ',i8,' e(i,j): ',i8)
 
245
      if (me.eq.0) then
 
246
        write(6,*)
 
247
        write(6,*) 'GA_Put and GA_Get are OK'
 
248
        write(6,*)
 
249
      endif
 
250
c
 
251
c  Test ga_add
 
252
c
 
253
      if (me.eq.0) then
 
254
        write(6,*)
 
255
        write(6,*) 'Testing GA_Add...'
 
256
        write(6,*)
 
257
      endif
 
258
      if (me.eq.0) then
 
259
        call nga_put(g_c,lo,hi,a,ld)
 
260
      endif
 
261
      ialpha = 1
 
262
      ibeta = -1
 
263
      call ga_add(ialpha, g_a, ibeta, g_c, g_c)
 
264
      if (ga_idot(g_c,g_c).eq.0) then
 
265
        if(me.eq.0)then
 
266
          write(6,*)
 
267
          write(6,*) 'GA_Add operation for regular and block-cyclic',
 
268
     +               ' arrays is OK'
 
269
          write(6,*)
 
270
          call ffflush(6)
 
271
        endif
 
272
      else
 
273
        if(me.eq.0)then
 
274
          write(6,*)
 
275
          write(6,*) 'GA_Add operation for regular and block-cyclic',
 
276
     +               ' arrays is not OK'
 
277
          write(6,*)
 
278
          call ga_error('exiting', 1)
 
279
          call ffflush(6)
 
280
        endif
 
281
      endif
 
282
c
 
283
c   Check add between two block-cyclic arrays
 
284
c
 
285
      if (me.eq.0) then
 
286
        call nga_put(g_d,lo,hi,a,ld)
 
287
      endif
 
288
      call ga_add(ialpha, g_a, ialpha, g_d, g_d)
 
289
c
 
290
c   Copy data to local buffer and then back to regular array
 
291
c
 
292
      call nga_get(g_d,lo,hi,b,ld)
 
293
      if (me.eq.0) then
 
294
        call nga_get(g_c,lo,hi,b,ld)
 
295
      endif
 
296
      call ga_sync
 
297
      if (ga_idot(g_c,g_c).eq.0) then
 
298
        if(me.eq.0)then
 
299
          write(6,*)
 
300
          write(6,*) 'GA_Add operation for two block-cyclic',
 
301
     +               ' arrays is OK'
 
302
          write(6,*)
 
303
          call ffflush(6)
 
304
        endif
 
305
      else
 
306
        if(me.eq.0)then
 
307
          write(6,*)
 
308
          write(6,*) 'GA_Add operation for two block-cyclic arrays',
 
309
     +               ' is not OK'
 
310
          write(6,*)
 
311
          call ga_error('exiting', 1)
 
312
          call ffflush(6)
 
313
        endif
 
314
      endif
 
315
c
 
316
c  Check to find which blocks correspond to local patch
 
317
c
 
318
#if SMALL_TEST
 
319
      if (me.eq.0) then
 
320
        write(6,*)
 
321
        write(6,*) 'Check nga_locate_region and nga_locate_num_blocks'
 
322
        write(6,*) 'functions'
 
323
        write(6,*)
 
324
        write(6,*) 'Printing original matrix'
 
325
        do i = 1, min(nmax,8)
 
326
          write(6,200) (a(i,j),j=1,min(nmax,8))
 
327
        end do
 
328
      endif
 
329
      status=nga_locate_region(g_a,tlo,thi,block_map,block_list,nblock)
 
330
      nb = nga_locate_num_blocks(g_a,tlo,thi)
 
331
      if (me.eq.0) then
 
332
        write(6,*)
 
333
        write(6,111) nb
 
334
        do i = 1, nblock
 
335
          write(6,110) i,block_list(i),block_map(4*(i-1)+1),
 
336
     +      block_map(4*(i-1)+3),block_map(4*(i-1)+2),
 
337
     +      block_map(4*(i-1)+4)
 
338
        end do
 
339
      endif
 
340
  110 format(i3,' block(',i3,') tlo(1): ',i3,' thi(1): ',i3,
 
341
     +                        ' tlo(2): ',i3,' thi(2): ',i3)
 
342
  111 format(' Number of blocks: ',i3)
 
343
      if (me.eq.0) then
 
344
        call nga_access_block_segment(g_a,me,index,length)
 
345
        call print_block(int_mb(index),length)
 
346
      endif
 
347
#endif
 
348
c
 
349
c  Check onesided accumulate
 
350
c
 
351
      if (me.eq.0) then
 
352
        write(6,*)
 
353
        write(6,*) 'Testing GA_Acc...'
 
354
        write(6,*)
 
355
      endif
 
356
      if (me.eq.0) then
 
357
        call nga_acc(g_b,lo,hi,c,ld,one)
 
358
      endif
 
359
      call ga_sync
 
360
      if (me.eq.0) then
 
361
        call nga_acc(g_b,lo,hi,c,ld,one)
 
362
      endif
 
363
      call ga_sync
 
364
      if (me.eq.0) then
 
365
        call nga_put(g_h,lo,hi,c,ld)
 
366
      endif
 
367
      alpha = 1.0
 
368
      beta = -2.0
 
369
      call ga_add(alpha,g_b,beta,g_h,g_h)
 
370
      if (ga_ddot(g_h,g_h).eq.0.0d00) then
 
371
        if (me.eq.0) then
 
372
          write(6,*)
 
373
          write(6,*) 'GA_Acc is OK'
 
374
          write(6,*)
 
375
        endif
 
376
      else
 
377
        if (me.eq.0) then
 
378
          write(6,*)
 
379
          write(6,*) 'GA_Acc is not OK'
 
380
          write(6,*)
 
381
          call ga_error('exiting', 1)
 
382
        endif
 
383
      endif
 
384
 
 
385
c
 
386
c  Check copy
 
387
c
 
388
      if (me.eq.0) then
 
389
        write(6,*)
 
390
        write(6,*) 'Testing GA_Copy...'
 
391
        write(6,*)
 
392
      endif
 
393
      call ga_copy(g_a, g_c)
 
394
      call ga_copy(g_c, g_d)
 
395
      call ga_add(ialpha,g_a,ibeta,g_d,g_c)
 
396
      if (ga_idot(g_c,g_c).eq.0) then
 
397
        if (me.eq.0) then
 
398
          write(6,*)
 
399
          write(6,*) 'GA_Copy is OK'
 
400
          write(6,*)
 
401
        endif
 
402
      else
 
403
        if (me.eq.0) then
 
404
          write(6,*)
 
405
          write(6,*) 'GA_Copy is not OK'
 
406
          write(6,*)
 
407
          call ga_error('exiting', 1)
 
408
        endif
 
409
      endif
 
410
c
 
411
c  Check zero
 
412
c
 
413
      if (me.eq.0) then
 
414
        write(6,*)
 
415
        write(6,*) 'Testing GA_Zero...'
 
416
        write(6,*)
 
417
        call nga_get(g_a,lo,hi,a,ld)
 
418
      endif
 
419
      call ga_sync
 
420
      call ga_zero(g_a)
 
421
      call ga_copy(g_a,g_c)
 
422
      if (ga_idot(g_c,g_c).eq.0) then
 
423
        if (me.eq.0) then
 
424
          write(6,*)
 
425
          write(6,*) 'GA_Zero is OK'
 
426
          write(6,*)
 
427
        endif
 
428
      else
 
429
        if (me.eq.0) then
 
430
          write(6,*)
 
431
          write(6,*) 'GA_Zero is not OK'
 
432
          write(6,*)
 
433
          call ga_error('exiting', 1)
 
434
        endif
 
435
      endif
 
436
c
 
437
c  Check scale
 
438
c
 
439
      if (me.eq.0) then
 
440
        write(6,*)
 
441
        write(6,*) 'Testing GA_Scale...'
 
442
        write(6,*)
 
443
      endif
 
444
      if (me.eq.0) then
 
445
        call nga_put(g_b,lo,hi,c,ld)
 
446
        call nga_put(g_h,lo,hi,c,ld)
 
447
      endif
 
448
      call ga_scale(g_b,2.0d00)
 
449
      call ga_scale(g_h,2.0d00)
 
450
      alpha = 1.0d00
 
451
      beta = -1.0d00
 
452
      call ga_add(alpha,g_b,beta,g_h,g_h)
 
453
      if (ga_ddot(g_h,g_h).eq.0.0d00) then
 
454
        if (me.eq.0) then
 
455
          write(6,*)
 
456
          write(6,*) 'GA_Scale is OK'
 
457
          write(6,*)
 
458
        endif
 
459
      else
 
460
        if (me.eq.0) then
 
461
          write(6,*)
 
462
          write(6,*) 'GA_Scale is not OK'
 
463
          write(6,*)
 
464
          call ga_error('exiting', 1)
 
465
        endif
 
466
      endif
 
467
c
 
468
c  Check fill
 
469
c
 
470
      if (me.eq.0) then
 
471
        write(6,*)
 
472
        write(6,*) 'Testing GA_Fill...'
 
473
        write(6,*)
 
474
      endif
 
475
      call ga_fill(g_a,1)
 
476
      call ga_fill(g_c,1)
 
477
      call ga_add(ialpha,g_a,ibeta,g_c,g_c)
 
478
      if (ga_idot(g_c,g_c).eq.0) then
 
479
        if (me.eq.0) then
 
480
          write(6,*)
 
481
          write(6,*) 'GA_Fill is OK'
 
482
          write(6,*)
 
483
        endif
 
484
      else
 
485
        if (me.eq.0) then
 
486
          write(6,*)
 
487
          write(6,*) 'GA_Fill is not OK'
 
488
          write(6,*)
 
489
          call ga_error('exiting', 1)
 
490
        endif
 
491
      endif
 
492
c
 
493
c  Check zero_patch
 
494
c
 
495
      if (me.eq.0) then
 
496
        write(6,*)
 
497
        write(6,*) 'Testing GA_Zero_patch...'
 
498
        write(6,*)
 
499
      endif
 
500
      call ga_copy(g_a,g_c)
 
501
      call nga_zero_patch(g_a,tlo,thi)
 
502
      call nga_zero_patch(g_c,tlo,thi)
 
503
      call ga_add(ialpha,g_a,ibeta,g_c,g_c)
 
504
      if (ga_idot(g_c,g_c).eq.0) then
 
505
        if (me.eq.0) then
 
506
          write(6,*)
 
507
          write(6,*) 'GA_Zero_patch is OK'
 
508
          write(6,*)
 
509
        endif
 
510
      else
 
511
        if (me.eq.0) then
 
512
          write(6,*)
 
513
          write(6,*) 'GA_Zero_patch is not OK'
 
514
          write(6,*)
 
515
          call ga_error('exiting', 1)
 
516
        endif
 
517
      endif
 
518
c
 
519
c  Check fill_patch
 
520
c
 
521
      if (me.eq.0) then
 
522
        write(6,*)
 
523
        write(6,*) 'Testing GA_Fill_patch...'
 
524
        write(6,*)
 
525
      endif
 
526
      call ga_copy(g_a,g_c)
 
527
      call nga_fill_patch(g_a,tlo,thi,2)
 
528
      call nga_fill_patch(g_c,tlo,thi,2)
 
529
      call ga_add(ialpha,g_a,ibeta,g_c,g_c)
 
530
      if (ga_idot(g_c,g_c).eq.0) then
 
531
        if (me.eq.0) then
 
532
          write(6,*)
 
533
          write(6,*) 'GA_Fill_patch is OK'
 
534
          write(6,*)
 
535
        endif
 
536
      else
 
537
        if (me.eq.0) then
 
538
          write(6,*)
 
539
          write(6,*) 'GA_Fill_patch is not OK'
 
540
          write(6,*)
 
541
          call ga_error('exiting', 1)
 
542
        endif
 
543
      endif
 
544
c
 
545
c  Check scale_patch
 
546
c
 
547
      if (me.eq.0) then
 
548
        write(6,*)
 
549
        write(6,*) 'Testing GA_Scale_patch...'
 
550
        write(6,*)
 
551
      endif
 
552
      call ga_copy(g_a,g_c)
 
553
      call nga_scale_patch(g_a,tlo,thi,2)
 
554
      call nga_scale_patch(g_c,tlo,thi,2)
 
555
      call ga_add(ialpha,g_a,ibeta,g_c,g_c)
 
556
      if (ga_idot(g_c,g_c).eq.0) then
 
557
        if (me.eq.0) then
 
558
          write(6,*)
 
559
          write(6,*) 'GA_Scale_patch is OK'
 
560
          write(6,*)
 
561
        endif
 
562
      else
 
563
        if (me.eq.0) then
 
564
          write(6,*)
 
565
          write(6,*) 'GA_Scale_patch is not OK'
 
566
          write(6,*)
 
567
          call ga_error('exiting', 1)
 
568
        endif
 
569
      endif
 
570
c
 
571
c  Check copy_patch
 
572
c
 
573
      if (me.eq.0) then
 
574
        write(6,*)
 
575
        write(6,*) 'Testing GA_Copy_patch...'
 
576
        write(6,*)
 
577
      endif
 
578
      call ga_fill(g_a,1)
 
579
      call ga_fill(g_c,1)
 
580
      call nga_fill_patch(g_a,tlo,thi,2)
 
581
      call nga_copy_patch('n',g_a,tlo,thi,g_c,t2lo,t2hi)
 
582
      call ga_fill(g_a,1)
 
583
      call nga_fill_patch(g_a,t2lo,t2hi,2)
 
584
      call ga_add(ialpha,g_a,ibeta,g_c,g_c)
 
585
      if (ga_idot(g_c,g_c).eq.0) then
 
586
        if (me.eq.0) then
 
587
          write(6,*)
 
588
          write(6,*) 'GA_Copy_patch from block-cyclic to regular is OK'
 
589
          write(6,*)
 
590
        endif
 
591
      else
 
592
        if (me.eq.0) then
 
593
          write(6,*)
 
594
          write(6,*) 'GA_Copy_patch from block-cyclic to regular is',
 
595
     +               ' not OK'
 
596
          write(6,*)
 
597
          call ga_error('exiting', 1)
 
598
        endif
 
599
      endif
 
600
      call ga_fill(g_a,1)
 
601
      call ga_fill(g_c,1)
 
602
      call nga_fill_patch(g_c,tlo,thi,2)
 
603
      call nga_copy_patch('n',g_c,tlo,thi,g_a,t2lo,t2hi)
 
604
      call ga_fill(g_c,1)
 
605
      call nga_fill_patch(g_c,t2lo,t2hi,2)
 
606
      call ga_add(ialpha,g_a,ibeta,g_c,g_c)
 
607
      if (ga_idot(g_c,g_c).eq.0) then
 
608
        if (me.eq.0) then
 
609
          write(6,*)
 
610
          write(6,*) 'GA_Copy_patch from regular to block-cyclic is OK'
 
611
          write(6,*)
 
612
        endif
 
613
      else
 
614
        if (me.eq.0) then
 
615
          write(6,*)
 
616
          write(6,*) 'GA_Copy_patch from regular to block-cyclic is',
 
617
     +               ' not OK'
 
618
          write(6,*)
 
619
          call ga_error('exiting', 1)
 
620
        endif
 
621
      endif
 
622
c
 
623
c   test ga_add_patch
 
624
c
 
625
      if (me.eq.0) then
 
626
        write(6,*)
 
627
        write(6,*) 'Testing GA_Add_patch...'
 
628
        write(6,*)
 
629
      endif
 
630
      call ga_zero(g_b)
 
631
      call ga_zero(g_e)
 
632
      call ga_zero(g_f)
 
633
      call ga_zero(g_h)
 
634
      call ga_zero(g_i)
 
635
      call ga_zero(g_j)
 
636
      if (me.eq.0) then
 
637
        call nga_put(g_e,t2lo,t2hi,c,ld)
 
638
        call nga_put(g_f,t2lo,t2hi,c,ld)
 
639
        call nga_put(g_i,t2lo,t2hi,c,ld)
 
640
        call nga_put(g_j,t2lo,t2hi,c,ld)
 
641
      endif
 
642
      call ga_sync
 
643
      call nga_add_patch(one,g_e,t2lo,t2hi,one,g_f,tlo,thi,g_b,tlo,thi)
 
644
      call nga_add_patch(one,g_i,t2lo,t2hi,one,g_j,tlo,thi,g_h,tlo,thi)
 
645
      call ga_add(alpha,g_b,beta,g_h,g_i)
 
646
      if (ga_ddot(g_i,g_i).eq.0.0d00) then
 
647
        if (me.eq.0) then
 
648
          write(6,*)
 
649
          write(6,*) 'GA_Add_patch is OK'
 
650
          write(6,*)
 
651
        endif
 
652
      else
 
653
        if (me.eq.0) then
 
654
          write(6,*)
 
655
          write(6,*) 'GA_Add_patch is not OK'
 
656
          write(6,*)
 
657
          call ga_error('exiting', 1)
 
658
        endif
 
659
      endif
 
660
c
 
661
c   test ga_ddot
 
662
c
 
663
      if (me.eq.0) then
 
664
        write(6,*)
 
665
        write(6,*) 'Testing GA_Ddot...'
 
666
        write(6,*)
 
667
      endif
 
668
      call ga_fill(g_b, 2.0d00)
 
669
      call ga_fill(g_b, 2.0d00)
 
670
      ddot = ga_ddot(g_b, g_b)
 
671
      if (me.eq.0) then
 
672
        write(6,112) ddot,dble(nmax*nmax*4)
 
673
      endif
 
674
  112 format(' Value of DDOT: ',f12.2,' Expected value: ',f12.2)
 
675
      if (me.eq.0) write(6,*)
 
676
c
 
677
c   test ga_ddot_patch
 
678
c
 
679
      if (me.eq.0) then
 
680
        write(6,*)
 
681
        write(6,*) 'Testing GA_Ddot_patch...'
 
682
        write(6,*)
 
683
      endif
 
684
      ddot = nga_ddot_patch(g_b, 'n', tlo, thi, g_b, 'n', tlo, thi)
 
685
      if (me.eq.0) then
 
686
        write(6,113) ddot,dble((thi(1)-tlo(1)+1)*(thi(2)-tlo(2)+1)*4)
 
687
      endif
 
688
  113 format(' Value of DDOT_PATCH: ',f12.2,' Expected value: ',f12.2)
 
689
c
 
690
c   test ga_abs_value_patch
 
691
c
 
692
      if (me.eq.0) then
 
693
        write(6,*)
 
694
        write(6,*) 'Testing GA_Abs_patch...'
 
695
        write(6,*)
 
696
      endif
 
697
      call ga_fill(g_a,-1)
 
698
      call ga_abs_value_patch(g_a, tlo, thi)
 
699
      call ga_fill(g_c,-1)
 
700
      call ga_abs_value_patch(g_c, tlo, thi)
 
701
      call ga_add(ialpha,g_a,ibeta,g_c,g_c)
 
702
      if (ga_idot(g_c,g_c).eq.0) then
 
703
        if (me.eq.0) then
 
704
          write(6,*)
 
705
          write(6,*) 'GA_Abs_value_patch is OK'
 
706
          write(6,*)
 
707
        endif
 
708
      else
 
709
        if (me.eq.0) then
 
710
          write(6,*)
 
711
          write(6,*) 'GA_Abs_value_patch is not OK'
 
712
          write(6,*)
 
713
          call ga_error('exiting', 1)
 
714
        endif
 
715
      endif
 
716
c
 
717
c   test ga_elem_multiply
 
718
c
 
719
      if (me.eq.0) then
 
720
        write(6,*)
 
721
        write(6,*) 'Testing GA_Elem_multiply...'
 
722
        write(6,*)
 
723
      endif
 
724
      call ga_fill(g_b, 2.0d00)
 
725
      call ga_fill(g_e, 3.0d00)
 
726
      call ga_zero(g_f)
 
727
      call ga_elem_multiply(g_b, g_e, g_f)
 
728
      call ga_fill(g_h, 2.0d00)
 
729
      call ga_fill(g_i, 3.0d00)
 
730
      call ga_zero(g_j)
 
731
      call ga_elem_multiply(g_h, g_i, g_j)
 
732
      call ga_add(alpha,g_f,beta,g_j,g_h)
 
733
      if (ga_ddot(g_h,g_h).eq.0.0d00) then
 
734
        if (me.eq.0) then
 
735
          write(6,*)
 
736
          write(6,*) 'GA_Elem_multiply is OK'
 
737
          write(6,*)
 
738
        endif
 
739
      else
 
740
        if (me.eq.0) then
 
741
          write(6,*)
 
742
          write(6,*) 'GA_Elem_multiply is not OK'
 
743
          write(6,*)
 
744
          call ga_error('exiting', 1)
 
745
        endif
 
746
      endif
 
747
c
 
748
c   test ga_elem_divide_patch
 
749
c
 
750
      if (me.eq.0) then
 
751
        write(6,*)
 
752
        write(6,*) 'Testing GA_Elem_divide_patch...'
 
753
        write(6,*)
 
754
      endif
 
755
      call ga_fill(g_b, 3.0d00)
 
756
      call ga_elem_divide_patch(g_f,t2lo,t2hi,g_e,tlo,thi,g_b,tlo,thi)
 
757
      call ga_fill(g_h, 3.0d00)
 
758
      call ga_elem_divide_patch(g_j,t2lo,t2hi,g_i,tlo,thi,g_h,tlo,thi)
 
759
      call ga_add(alpha,g_b,beta,g_h,g_h)
 
760
      if (ga_ddot(g_h,g_h).eq.0.0d00) then
 
761
        if (me.eq.0) then
 
762
          write(6,*)
 
763
          write(6,*) 'GA_Elem_divide_patch is OK'
 
764
          write(6,*)
 
765
        endif
 
766
      else
 
767
        if (me.eq.0) then
 
768
          write(6,*)
 
769
          write(6,*) 'GA_Elem_divide_patch is not OK'
 
770
          write(6,*)
 
771
          call ga_error('exiting', 1)
 
772
        endif
 
773
      endif
 
774
c
 
775
c    test strided get
 
776
c
 
777
      if (me.eq.0) then
 
778
        write(6,*)
 
779
        write(6,*) 'Testing GA_Strided_get...'
 
780
        write(6,*)
 
781
      endif
 
782
      skip(1) = 2
 
783
      skip(2) = 2
 
784
      call ga_zero(g_a)
 
785
      call ga_zero(g_c)
 
786
      call nga_get(g_a,lo,hi,a,ld)
 
787
      call nga_get(g_c,lo,hi,b,ld)
 
788
      call ga_fill(g_a, 1)
 
789
      call ga_fill(g_c, 1)
 
790
      if (me.eq.0) then
 
791
        call nga_strided_get(g_a,lo,hi,skip,a,ld)
 
792
        call nga_strided_get(g_c,lo,hi,skip,b,ld)
 
793
      endif
 
794
      call ga_sync
 
795
      nb = 0
 
796
      if (me.eq.0) then
 
797
        do i = 1, nmax
 
798
          do j = 1, nmax
 
799
            if (a(i,j).ne.b(i,j)) nb = nb + 1
 
800
          end do
 
801
        end do
 
802
        if (nb.eq.0) then
 
803
          if (me.eq.0) then
 
804
            write(6,*)
 
805
            write(6,*) 'GA_Strided_get is OK'
 
806
            write(6,*)
 
807
          endif
 
808
        else
 
809
          if (me.eq.0) then
 
810
            write(6,*)
 
811
            write(6,*) 'GA_Strided_get is not OK'
 
812
            write(6,*)
 
813
            call ga_error('exiting', 1)
 
814
          endif
 
815
        endif
 
816
      endif
 
817
c
 
818
c    test strided put
 
819
c
 
820
      if (me.eq.0) then
 
821
        write(6,*)
 
822
        write(6,*) 'Testing GA_Strided_put...'
 
823
        write(6,*)
 
824
      endif
 
825
      call ga_fill(g_a, 1)
 
826
      if (me.eq.0) call nga_get(g_a,lo,hi,a,ld)
 
827
      call ga_zero(g_a)
 
828
      call ga_fill(g_c, 1)
 
829
      if (me.eq.0) call nga_get(g_c,lo,hi,b,ld)
 
830
      call ga_zero(g_c)
 
831
      if (me.eq.0) then
 
832
        call nga_strided_put(g_a,lo,hi,skip,a,ld)
 
833
        call nga_strided_put(g_c,lo,hi,skip,b,ld)
 
834
      endif
 
835
      call ga_sync
 
836
      call ga_add(ialpha,g_a,ibeta,g_c,g_c)
 
837
      if (ga_idot(g_c,g_c).eq.0) then
 
838
        if (me.eq.0) then
 
839
          write(6,*)
 
840
          write(6,*) 'GA_Strided_put is OK'
 
841
          write(6,*)
 
842
        endif
 
843
      else
 
844
        if (me.eq.0) then
 
845
          write(6,*)
 
846
          write(6,*) 'GA_Strided_put is not OK'
 
847
          write(6,*)
 
848
          call ga_error('exiting', 1)
 
849
        endif
 
850
      endif
 
851
c
 
852
c    test strided accumulate
 
853
c
 
854
      if (me.eq.0) then
 
855
        write(6,*)
 
856
        write(6,*) 'Testing GA_Strided_acc...'
 
857
        write(6,*)
 
858
      endif
 
859
      call ga_fill(g_b, 1.0d00)
 
860
      call nga_get(g_b,lo,hi,c,ld)
 
861
      call ga_fill(g_h, 1.0d00)
 
862
      call nga_get(g_h,lo,hi,d,ld)
 
863
      call ga_sync
 
864
      if (me.eq.0) then
 
865
        call nga_strided_acc(g_b,lo,hi,skip,c,ld,one)
 
866
        call nga_strided_acc(g_h,lo,hi,skip,d,ld,one)
 
867
      endif
 
868
      call ga_sync
 
869
      call ga_add(alpha,g_b,beta,g_h,g_h)
 
870
      if (ga_ddot(g_h,g_h).eq.0.0d00) then
 
871
        if (me.eq.0) then
 
872
          write(6,*)
 
873
          write(6,*) 'GA_Strided_acc is OK'
 
874
          write(6,*)
 
875
        endif
 
876
      else
 
877
        if (me.eq.0) then
 
878
          write(6,*)
 
879
          write(6,*) 'GA_Strided_acc is not OK'
 
880
          write(6,*)
 
881
          call ga_error('exiting', 1)
 
882
        endif
 
883
      endif
 
884
c
 
885
c    test transpose
 
886
c
 
887
      if (me.eq.0) then
 
888
        write(6,*)
 
889
        write(6,*) 'Testing GA_transpose...'
 
890
        write(6,*)
 
891
      endif
 
892
      k = 0
 
893
      do i = 1, nmax
 
894
        do j = 1, nmax
 
895
          k = k+1
 
896
          c(i,j) = dble(k)
 
897
        end do
 
898
      end do
 
899
      if (me.eq.0) then
 
900
        call nga_put(g_b,lo,hi,c,ld)
 
901
        call nga_put(g_h,lo,hi,c,ld)
 
902
      endif
 
903
      call ga_sync
 
904
      call ga_transpose(g_b,g_i)
 
905
      call ga_transpose(g_h,g_j)
 
906
      call ga_add(alpha,g_i,beta,g_j,g_h)
 
907
      if (ga_ddot(g_h,g_h).eq.0.0d00) then
 
908
        if (me.eq.0) then
 
909
          write(6,*)
 
910
          write(6,*) 'GA_Transpose is OK'
 
911
          write(6,*)
 
912
        endif
 
913
      else
 
914
        if (me.eq.0) then
 
915
          write(6,*)
 
916
          write(6,*) 'GA_Transpose is not OK'
 
917
          write(6,*)
 
918
          call ga_error('exiting', 1)
 
919
        endif
 
920
      endif
 
921
c
 
922
c    test symmetrize
 
923
c
 
924
      if (me.eq.0) then
 
925
        write(6,*)
 
926
        write(6,*) 'Testing GA_symmetrize...'
 
927
        write(6,*)
 
928
      endif
 
929
      if (me.eq.0) then
 
930
        call nga_put(g_b,lo,hi,c,ld)
 
931
        call nga_put(g_h,lo,hi,c,ld)
 
932
      endif
 
933
      call ga_sync
 
934
      call ga_symmetrize(g_b)
 
935
      call ga_symmetrize(g_h)
 
936
      call ga_add(alpha,g_b,beta,g_h,g_h)
 
937
      if (ga_ddot(g_h,g_h).eq.0.0d00) then
 
938
        if (me.eq.0) then
 
939
          write(6,*)
 
940
          write(6,*) 'GA_Symmetrize is OK'
 
941
          write(6,*)
 
942
        endif
 
943
      else
 
944
        if (me.eq.0) then
 
945
          write(6,*)
 
946
          write(6,*) 'GA_Symmetrize is not OK'
 
947
          write(6,*)
 
948
          call ga_error('exiting', 1)
 
949
        endif
 
950
      endif
 
951
c
 
952
c    test periodic get
 
953
c
 
954
      if (me.eq.0) then
 
955
        write(6,*)
 
956
        write(6,*) 'Testing GA_Periodic_get...'
 
957
        write(6,*)
 
958
      endif
 
959
      tlo(1) = lo(1) + 2
 
960
      thi(1) = hi(1) + 2
 
961
      tlo(2) = lo(2) + 2
 
962
      thi(2) = hi(2) + 2
 
963
      k = 0
 
964
      do i = 1, nmax
 
965
        do j = 1, nmax
 
966
          k = k + 1
 
967
          a(i,j) = k
 
968
        end do
 
969
      end do
 
970
      if (me.eq.0) then
 
971
        call nga_put(g_a,lo,hi,a,ld)
 
972
        call nga_put(g_c,lo,hi,a,ld)
 
973
      endif
 
974
      call ga_sync
 
975
      if (me.eq.0) then
 
976
        call nga_periodic_get(g_a,tlo,thi,a,ld)
 
977
        call nga_periodic_get(g_c,tlo,thi,b,ld)
 
978
      endif
 
979
      call ga_sync
 
980
      nb = 0
 
981
      if (me.eq.0) then
 
982
        do i = 1, nmax
 
983
          do j = 1, nmax
 
984
            if (a(i,j).ne.b(i,j)) nb = nb + 1
 
985
          end do
 
986
        end do
 
987
        if (nb.eq.0) then
 
988
          if (me.eq.0) then
 
989
            write(6,*)
 
990
            write(6,*) 'GA_Periodic_get is OK'
 
991
            write(6,*)
 
992
          endif
 
993
        else
 
994
          if (me.eq.0) then
 
995
            write(6,*)
 
996
            write(6,*) 'GA_Periodic_get is not OK'
 
997
            write(6,*)
 
998
            call ga_error('exiting', 1)
 
999
          endif
 
1000
        endif
 
1001
      endif
 
1002
c
 
1003
c    test periodic put
 
1004
c
 
1005
      if (me.eq.0) then
 
1006
        write(6,*)
 
1007
        write(6,*) 'Testing GA_Periodic_put...'
 
1008
        write(6,*)
 
1009
      endif
 
1010
      k = 0
 
1011
      do i = 1, nmax
 
1012
        do j = 1, nmax
 
1013
          k = k + 1
 
1014
          a(i,j) = k
 
1015
        end do
 
1016
      end do
 
1017
      if (me.eq.0) then
 
1018
        call nga_periodic_put(g_a,tlo,thi,a,ld)
 
1019
        call nga_periodic_put(g_c,tlo,thi,a,ld)
 
1020
      endif
 
1021
      call ga_sync
 
1022
      call ga_add(ialpha,g_a,ibeta,g_c,g_c)
 
1023
      if (ga_idot(g_c,g_c).eq.0) then
 
1024
        if (me.eq.0) then
 
1025
          write(6,*)
 
1026
          write(6,*) 'GA_Periodic_put is OK'
 
1027
          write(6,*)
 
1028
        endif
 
1029
      else
 
1030
        if (me.eq.0) then
 
1031
          write(6,*)
 
1032
          write(6,*) 'GA_Periodic_put is not OK'
 
1033
          write(6,*)
 
1034
          call ga_error('exiting', 1)
 
1035
        endif
 
1036
      endif
 
1037
c
 
1038
c    test periodic accumulate
 
1039
c
 
1040
      if (me.eq.0) then
 
1041
        write(6,*)
 
1042
        write(6,*) 'Testing GA_Periodic_acc...'
 
1043
        write(6,*)
 
1044
      endif
 
1045
      call ga_fill(g_b, 1.0d00)
 
1046
      call ga_fill(g_h, 1.0d00)
 
1047
      call ga_sync
 
1048
      if (me.eq.0) then
 
1049
        call nga_periodic_acc(g_b,tlo,thi,c,ld,one)
 
1050
        call nga_periodic_acc(g_h,tlo,thi,c,ld,one)
 
1051
      endif
 
1052
      call ga_sync
 
1053
      call ga_add(alpha,g_b,beta,g_h,g_h)
 
1054
      if (ga_ddot(g_h,g_h).eq.0.0d00) then
 
1055
        if (me.eq.0) then
 
1056
          write(6,*)
 
1057
          write(6,*) 'GA_Periodic_acc is OK'
 
1058
          write(6,*)
 
1059
        endif
 
1060
      else
 
1061
        if (me.eq.0) then
 
1062
          write(6,*)
 
1063
          write(6,*) 'GA_Periodic_acc is not OK'
 
1064
          write(6,*)
 
1065
          call ga_error('exiting', 1)
 
1066
        endif
 
1067
      endif
 
1068
      
 
1069
  200 format(8i8)
 
1070
c 300 format(8f8.1)
 
1071
      if (me.eq.0) then
 
1072
        write(6,302)
 
1073
      endif
 
1074
  302 format(' Finished tests: success')
 
1075
      status = ga_destroy(g_a)
 
1076
      status = ga_destroy(g_b)
 
1077
      status = ga_destroy(g_c)
 
1078
      status = ga_destroy(g_d)
 
1079
      status = ga_destroy(g_e)
 
1080
      status = ga_destroy(g_f)
 
1081
      call ga_terminate()
 
1082
c
 
1083
c***  Tidy up after message-passing library
 
1084
c
 
1085
      call MP_FINALIZE()
 
1086
c
 
1087
      stop
 
1088
      end
 
1089
c
 
1090
      subroutine print_block(a,length)
 
1091
      implicit none
 
1092
#include "mafdecls.fh"
 
1093
#include "global.fh"
 
1094
      integer length, i, j
 
1095
      integer a(length)
 
1096
      write(6,*)
 
1097
      write(6,200)
 
1098
      do i=1, 4
 
1099
        write(6,100) (a(4*(j-1)+i), j=1,4)
 
1100
  100   format(8i8)
 
1101
      end do
 
1102
  200 format(' Write contents of processor')
 
1103
      return
 
1104
      end