← Back to branch summary

~ubuntu-branches/ubuntu/utopic/nwchem/utopic

« back to all changes in this revision

Viewing changes to src/tools/ga-5-2/pario/dra/ntest.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/pario/dra/ntest.F
 
1
#if HAVE_CONFIG_H
 
2
#   include "config.fh"
 
3
#endif
 
4
c
 
5
c FNAME - filename for test program
 
6
c
 
7
#define BASE_NAME 'dra.file'
 
8
#ifdef  HPIODIR
 
9
#  define FNAME   HPIODIR//BASE_NAME
 
10
#else
 
11
#  define FNAME   BASE_NAME
 
12
#endif
 
13
 
 
14
      program io
 
15
#include "mafdecls.fh"
 
16
#include "global.fh"
 
17
#include "dra.fh"
 
18
      integer status, me
 
19
      integer max_arrays
 
20
      integer stack, heap
 
21
      double precision max_sz, max_disk, max_mem 
 
22
      data max_arrays, max_sz, max_disk, max_mem /10,1d8,1d10, 1d6/
 
23
      data stack, heap /80000, 80000/
 
24
c
 
25
#include "mp3.fh"
 
26
      if(ma_init(MT_F_DBL, stack, heap) ) then
 
27
        call ga_initialize()
 
28
        me    = ga_nodeid()
 
29
        if(dra_init(max_arrays, max_sz, max_disk, max_mem).ne.0)then
 
30
                call ga_error('dra_init failed: ',0)
 
31
        endif
 
32
        if (me.eq.0) print*,' '
 
33
        if(me.eq.0)print *, 'TESTING INTEGERS'
 
34
        if (me.eq.0) print*,' '
 
35
        call test_io_int()
 
36
        if (me.eq.0) print*,' '
 
37
        if(me.eq.0)print *, 'TESTING DOUBLES'
 
38
        if (me.eq.0) print*,' '
 
39
        call test_io_dbl()
 
40
        status = dra_terminate()
 
41
        call ga_terminate()
 
42
      else
 
43
        print *,'ma_init failed'
 
44
      endif
 
45
c     if(me.eq.0)print *, 'all done ...'
 
46
      call MP_FINALIZE()
 
47
      end
 
48
 
 
49
 
 
50
 
 
51
      subroutine test_io_int
 
52
      implicit none
 
53
#include "mafdecls.fh"
 
54
#include "global.fh"
 
55
#include "dra.fh"
 
56
      integer n,m
 
57
      parameter (n = 20)
 
58
      parameter (m = 2*n)
 
59
      integer a(n,n,n)
 
60
      integer g_a, g_b, d_a
 
61
      integer i,j,k, err, type
 
62
      integer me, nproc, dims(3), req(3), ndim
 
63
      integer chunk(3), lo(3), hi(3), ld(3)
 
64
      logical status
 
65
      character*1 filename(200)
 
66
      character*80 name
 
67
c    
 
68
      nproc = ga_nnodes()
 
69
      me    = ga_nodeid()
 
70
      call init_char(name,100, ' ')
 
71
      call init_char(filename,200, ' ')
 
72
c    
 
73
c     a() is a local copy of what the l array should start as
 
74
c
 
75
      do k = 1, n
 
76
        do j = 1, n
 
77
          do i = 1, n
 
78
            a(i,j,k) = i-1 + (j-1)*n + (k-1)*n*n
 
79
          enddo
 
80
        enddo
 
81
      enddo
 
82
c
 
83
      if (me.eq.0) print *, 'Creating global arrays'
 
84
      call ga_sync()
 
85
      do i = 1, 3
 
86
        dims(i) = n
 
87
        chunk(i) = 1
 
88
        ld(i) = n
 
89
      end do
 
90
      if(.not. nga_create(MT_INT, 3, dims, 'a', chunk, g_a))
 
91
     &         call ga_error('nga_create failed: a', 0)
 
92
      if(.not. nga_create(MT_INT, 3, dims, 'b', chunk, g_b))
 
93
     &         call ga_error('nga_create failed: b', 0)
 
94
c
 
95
*     call nga_zero(g_a)
 
96
*     call nga_zero(g_b)
 
97
c
 
98
      write(6,*) 'Imediately before nga_put'
 
99
      do j = 1+me, n, nproc
 
100
        lo(1) = 1
 
101
        lo(2) = 1
 
102
        lo(3) = j
 
103
        hi(1) = n
 
104
        hi(2) = n
 
105
        hi(3) = j
 
106
        call nga_put(g_a, lo, hi, a(1,1,j), ld)
 
107
      enddo
 
108
c
 
109
      if(me.eq.0) print *, 'Creating Disk Array ',n,' x',n,' x',n
 
110
      dims(1) = n
 
111
      dims(2) = n
 
112
      dims(3) = n
 
113
      req(1) = n
 
114
      req(2) = n
 
115
      req(3) = 1
 
116
      ndim = 3
 
117
      if(ndra_create(MT_INT, ndim, dims, 'array A', 
 
118
     &   FNAME, 
 
119
     &   DRA_RW,    req, d_a).ne.0)
 
120
     $   CALL ga_error('ndra_create failed: ',0)
 
121
      if (me.eq.0) print *,'OK'
 
122
      if (me.eq.0) print*,' '
 
123
c
 
124
      if(me.eq.0) print *, 'Writing Global Array to Disk Array'
 
125
      if(ndra_write(g_a, d_a,req).ne.0)
 
126
     $   CALL ga_error('ndra_write failed:',0)
 
127
      if(dra_wait(req).ne.0)call ga_error('dra_wait failed: ' ,req)
 
128
      if (me.eq.0) print *,'OK'
 
129
      if (me.eq.0) print*,' '
 
130
      if(me.eq.0) print *, 'Closing Disk Array'
 
131
      if(dra_close(d_a).ne.0)call ga_error('dra_close failed: ',d_a)
 
132
      if (me.eq.0) print *,'OK'
 
133
      if (me.eq.0) print*,' '
 
134
c
 
135
      if(me.eq.0) print *, 'Opening Existing Disk Array'
 
136
      if(dra_open(FNAME ,DRA_R, d_a).ne.0)
 
137
     &            call ga_error('dra_open failed',0)
 
138
c     
 
139
      if(ndra_inquire(d_a, type, ndim, dims, name, filename).ne.0)
 
140
     &            call ga_error('ndra_inquire failed',0)
 
141
      if(dims(1).ne.n) call ga_error('dim1 error',dims(1))
 
142
      if(dims(2).ne.n) call ga_error('dim2 error',dims(2))
 
143
      if(dims(3).ne.n) call ga_error('dim3 error',dims(3))
 
144
      if(type.ne.MT_INT) call ga_error('type error',type)
 
145
      if(me.eq.0) print *, 'array name read from disk is:',name
 
146
      call ga_sync()
 
147
      if (me.eq.0) print *,'OK'
 
148
      if (me.eq.0) print*,' '
 
149
c
 
150
      if(me.eq.0) print *, 'Checking ndra_read'
 
151
c     call dra_set_mode(1)
 
152
      write(6,*) 'About to perform ndra_read'
 
153
      if(ndra_read(g_b, d_a, req).ne.0)
 
154
     $   CALL ga_error('ndra_read failed:',0)
 
155
      write(6,*) 'Finished performing ndra_read'
 
156
      call ffflush(6)
 
157
      if(dra_wait(req).ne.0) call ga_error('dra_wait failed: ' ,req)
 
158
c
 
159
c     error checking: (g_a - g_b)^2
 
160
c
 
161
c     call ga_print(g_a)
 
162
c     call ga_print(g_b)
 
163
      call ga_add(1, g_a, -1, g_b, g_b) 
 
164
      err = ga_idot(g_b, g_b) 
 
165
c
 
166
      if(err.ne.0 )then
 
167
          if( me.eq.0) call ga_error('failed', err) 
 
168
      else
 
169
          if (me.eq.0) print *,'OK'
 
170
      endif 
 
171
      if (me.eq.0) print*,' '
 
172
c
 
173
      if(me.eq.0) print *, 'Checking dra_delete'
 
174
      if(dra_delete(d_a).ne.0)
 
175
     &            call ga_error('dra_delete failed',0)
 
176
      if (me.eq.0) print *,'OK'
 
177
      if (me.eq.0) print*,' '
 
178
      status = ga_destroy(g_a)
 
179
      status = ga_destroy(g_b)
 
180
      end
 
181
 
 
182
 
 
183
 
 
184
 
 
185
      subroutine test_io_dbl
 
186
      implicit none
 
187
#include "mafdecls.fh"
 
188
#include "global.fh"
 
189
#include "dra.fh"
 
190
      integer n,m
 
191
      parameter (n = 20)
 
192
      parameter (m = 2*n)
 
193
      double precision a(n,n,n),  err
 
194
      integer g_a, g_b,  d_a
 
195
      double precision drand
 
196
      integer i,j,k, loop
 
197
      integer dlo(3),dhi(3)
 
198
      integer glo(3),ghi(3)
 
199
      integer elem
 
200
      integer me, nproc
 
201
      integer iran, ndim, dims(3), req(3), chunk(3), ld(3)
 
202
      logical status
 
203
      external  drand
 
204
      intrinsic int, dble
 
205
      iran(i) = int(drand(0)*dble(i-1)) + 1
 
206
c    
 
207
      loop  = 30
 
208
      nproc = ga_nnodes()
 
209
      me    = ga_nodeid()
 
210
c    
 
211
c     a() is a local copy of what the l array should start as
 
212
c
 
213
      do k = 1, n
 
214
        do j = 1, n
 
215
          do i = 1, n
 
216
            a(i,j,k) = dble(i-1 + (j-1)*n + (k-1)*n*n)
 
217
          enddo
 
218
        enddo
 
219
      end do
 
220
c
 
221
      call ga_sync()
 
222
      ndim = 3
 
223
      do i = 1, ndim
 
224
        dims(i) = n
 
225
        chunk(i) = 1
 
226
        ld(i) = n
 
227
      end do
 
228
      write(6,*) 'Creating global arrays'
 
229
      write(6,*)
 
230
      if(.not. nga_create(MT_DBL, ndim, dims, 'a', chunk, g_a))
 
231
     &         call ga_error('ga_create failed: a', 0)
 
232
      if(.not. nga_create(MT_DBL, ndim, dims, 'b', chunk, g_b))
 
233
     &         call ga_error('ga_create failed: b', 0)
 
234
c
 
235
      write(6,*) 'Zeroing global arrays'
 
236
      write(6,*)
 
237
      call ga_zero(g_a)
 
238
      call ga_zero(g_b)
 
239
c
 
240
      do j = 1+me, n, nproc
 
241
        dlo(1) = 1
 
242
        dlo(2) = 1
 
243
        dlo(3) = j
 
244
        dhi(1) = n
 
245
        dhi(2) = n
 
246
        dhi(3) = j
 
247
        call nga_put(g_a, dlo, dhi, a(1, 1, j), ld)
 
248
      enddo
 
249
c
 
250
      if (me.eq.0) print*, 'Creating Disk Array ',n,' x',n,' x',n
 
251
      req(1) = n
 
252
      req(2) = n
 
253
      req(3) = 3
 
254
      if(ndra_create(MT_DBL, ndim, dims, 'A', 
 
255
     &      FNAME, 
 
256
     &      DRA_RW, req, d_a).ne.0)
 
257
     $   CALL ga_error('ndra_create failed: ',0)
 
258
c
 
259
      if(me.eq.0) print *, 'Writing Global Array to Disk Array'
 
260
      if(ndra_write(g_a, d_a,req).ne.0)
 
261
     $   CALL ga_error('ndra_write failed:',0)
 
262
      if (me.eq.0) print*,' '
 
263
      if(dra_wait(req).ne.0) call ga_error('dra_wait failed: ' ,req)
 
264
c
 
265
      if(dra_close(d_a).ne.0)call ga_error('dra_close failed: ',d_a)
 
266
c
 
267
      if(me.eq.0) print *, 'Checking ndra_read'
 
268
      if(dra_open(FNAME,DRA_R, d_a).ne.0)
 
269
     &            call ga_error('dra_open failed',0)
 
270
      if(ndra_read(g_b, d_a, req).ne.0)
 
271
     $   CALL ga_error('ndra_read failed:',0)
 
272
      if(dra_wait(req).ne.0) call ga_error('dra_wait failed: ' ,req)
 
273
c
 
274
c     error checking: (g_a - g_b)^2
 
275
c
 
276
c     call ga_print(g_a)
 
277
c     call ga_print(g_b)
 
278
      call ga_add(1d0, g_a, -1d0, g_b, g_b) 
 
279
      err = ga_ddot(g_b, g_b) 
 
280
      if(err.ne.0) then
 
281
          if (me.eq.0) print *,'error =', err 
 
282
      else
 
283
          if (me.eq.0) print *,'OK'
 
284
      endif 
 
285
      if (me.eq.0) print*,' '
 
286
c
 
287
      if(me.eq.0) print *, 'Checking ndra_read_section'
 
288
c
 
289
      call ga_zero(g_b)
 
290
      do j = 1, loop
 
291
         do i = 1, ndim
 
292
           dlo(i) = iran(n)
 
293
           dhi(i) = iran(n)
 
294
           if (dlo(i).gt.dhi(i)) call swap(dlo(i),dhi(i))
 
295
           elem = dhi(i) - dlo(i) + 1
 
296
           glo(i) = iran(n-elem) + 1
 
297
           ghi(i) = glo(i) + elem - 1
 
298
         end do
 
299
c
 
300
         if(me.eq.0) then
 
301
            write(6,100) (glo(i),ghi(i),i=1,3),(dlo(i),dhi(i),i=1,3)
 
302
100         format(1x,'reading  global[',3(i4,':',i4),
 
303
     &                ']  from  disk[',3(i4,':',i4),']')
 
304
            call ffflush(6)
 
305
         endif
 
306
c
 
307
*        call ga_print(g_b,1)
 
308
 
 
309
         if(ndra_read_section(.false.,   g_b, glo, ghi,
 
310
     &                      d_a, dlo, dhi, req).ne.0)
 
311
     &      call ga_error('ndra_read failed:',0)
 
312
         if(dra_wait(req).ne.0) call ga_error('dra_wait failed:',req)
 
313
*        call ga_print(g_b,1)
 
314
*        call ga_print_patch(g_a, dilo, dihi, djlo, djhi,1)
 
315
*        call ga_print_patch(g_b, gilo, gihi, gjlo, gjhi,1)
 
316
c
 
317
         call nga_add_patch(1d0, g_a, dlo, dhi, -1d0, g_b, glo, ghi,
 
318
     &                           g_b, glo, ghi) 
 
319
         err = nga_ddot_patch(g_b,'n', glo, ghi, g_b,'n', glo, ghi) 
 
320
         if(err.ne.0 .and. me.eq.0)then
 
321
            print *,'error =', err
 
322
            call ga_error('failed',0)
 
323
         endif
 
324
      enddo
 
325
      if (me.eq.0) print*,' OK'
 
326
      if (me.eq.0) print*,' '
 
327
      if(dra_delete(d_a).ne.0)
 
328
     &            call ga_error('dra_delete failed',0)
 
329
c
 
330
c***  now d_a is 4 times larger than g_a
 
331
c
 
332
      if (me.eq.0) print*, 'Creating New Disk Array ',m,' x',m,' x',m
 
333
      dims(1) = m
 
334
      dims(2) = m
 
335
      dims(3) = m
 
336
      req(1) = n
 
337
      req(2) = n
 
338
      req(3) = 2
 
339
      if(ndra_create(MT_DBL, ndim, dims, 'A', 
 
340
     &      FNAME, 
 
341
     &      DRA_RW, req, d_a).ne.0)
 
342
     $   CALL ga_error('dra_create failed: ',0)
 
343
      if (me.eq.0) print*,' OK'
 
344
      if (me.eq.0) print*,' '
 
345
c
 
346
c   
 
347
c     call ga_print(g_a)
 
348
c     call ga_zero(g_b)
 
349
      if (me.eq.0) print*,'Testing ndra_write_section'
 
350
      do j = 1, loop
 
351
        do i = 1, ndim
 
352
          glo(i) = iran(n)
 
353
          if(glo(i).gt.ghi(i)) call swap(glo(i),ghi(i))
 
354
          elem = ghi(i) - glo(i) +1
 
355
          dlo(i) = iran(m-elem)+1
 
356
          dhi(i) = dlo(i)+elem-1
 
357
        end do
 
358
c
 
359
         if(me.eq.0) then
 
360
            write(6,200) (glo(i),ghi(i),i=1,3),(dlo(i),dhi(i),i=1,3)
 
361
200         format(1x,'writing  global[',3(i4,':',i4),
 
362
     &                ']  to  disk[',3(i4,':',i4),']') 
 
363
            call ffflush(6)
 
364
         endif
 
365
c
 
366
c        call dra_set_mode(0)
 
367
c         if(dra_write_section(.false.,  g_a, gilo, gihi, gjlo, gjhi,
 
368
c     &                      d_a, dilo, dihi, djlo, djhi, req).ne.0)
 
369
         if(ndra_write_section(.false., g_a, glo, ghi,
 
370
     &                        d_a, dlo, dhi, req).ne.0)
 
371
     &      call ga_error('dra_write failed:',0)
 
372
         if(dra_wait(req).ne.0) call ga_error('dra_wait failed:',req)
 
373
c
 
374
c***     dra_read was tested already and we use it for testing ndra_write_section
 
375
c
 
376
c        call dra_set_mode(1)
 
377
         if(ndra_read_section(.false.,   g_b, glo, ghi,
 
378
     &                      d_a, dlo, dhi, req).ne.0)
 
379
     &      call ga_error('ndra_read failed:',0)
 
380
         if(dra_wait(req).ne.0) call ga_error('dra_wait failed:',req)
 
381
c
 
382
         call nga_add_patch(1d0, g_a, glo, ghi, -1d0, g_b, glo, ghi,
 
383
     &                           g_b, glo, ghi)
 
384
         err = nga_ddot_patch(g_b,'n', glo, ghi, g_b,'n', glo, ghi)
 
385
cbjp         if(err.ne.0d0 )then
 
386
cbjp            call ga_print_patch(g_a, gilo, gihi,gjlo,gjhi,1)
 
387
cbjp            call ga_print_patch(g_b, gilo, gihi,gjlo,gjhi,1)
 
388
cbjp         endif
 
389
         if(err.ne.0d0 .and. me.eq.0)then
 
390
            print *,'error =', err
 
391
            call ga_error('error in ndra_write_section',0)
 
392
         endif
 
393
      enddo
 
394
      if (me.eq.0) print*,' OK'
 
395
c
 
396
      if(dra_delete(d_a).ne.0)
 
397
     &            call ga_error('dra_delete failed',0)
 
398
      status = ga_destroy(g_a)
 
399
      status = ga_destroy(g_b)
 
400
      end
 
401
 
 
402
 
 
403
 
 
404
      subroutine swap(a,b)
 
405
      integer a, b, temp
 
406
         temp = a
 
407
         a = b
 
408
         b = temp
 
409
      end
 
410
 
 
411
 
 
412
      subroutine init_char(str, len, char)
 
413
      integer len, i
 
414
#if defined(CRAY_T3D) || defined(CRAY_T3E)
 
415
      character*1 str(len)
 
416
#else
 
417
      character*(*) str
 
418
#endif
 
419
      character*1 char
 
420
      do i = 1, len -1 
 
421
         str(i:i+1) = char
 
422
      enddo
 
423
      end
 
424
          
 
425