← 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/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-1/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