← 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/testsolve.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/testsolve.F
 
1
#if HAVE_CONFIG_H
 
2
#   include "config.fh"
 
3
#endif
 
4
c $Id: testsolve.F,v 1.11 2006/03/20 20:02:29 manoj Exp $
 
5
      program test
 
6
      implicit none
 
7
#include "mafdecls.fh"
 
8
#include "global.fh"
 
9
      integer heap, stack
 
10
#define BLOCK_CYCLIC 0
 
11
c
 
12
c***  Intitialize a message passing library
 
13
c
 
14
#include "mp3.fh"
 
15
c
 
16
c     Intitialize the GA package
 
17
c
 
18
      call ga_initialize()
 
19
c     if(ga_nodeid().eq.0)print *,ga_nnodes(),' nodes'
 
20
c
 
21
c     Initialize the MA package
 
22
c
 
23
      heap = 190000
 
24
      stack= 190000
 
25
      if (.not. ma_init(MT_DBL, heap, stack))
 
26
     $    call ga_error("ma init failed",heap+stack) 
 
27
c
 
28
c
 
29
      call testit()
 
30
c
 
31
      if(ga_nodeid().eq.0) print *,'All tests successful '
 
32
c
 
33
      call ga_terminate()
 
34
c
 
35
      call MP_FINALIZE()
 
36
      end
 
37
 
 
38
 
 
39
c-----------------
 
40
 
 
41
      subroutine testit()
 
42
      implicit none
 
43
#include "mafdecls.fh"
 
44
#include "global.fh"
 
45
c     
 
46
      integer n
 
47
      parameter (n = 100)
 
48
      double precision a(n,n), b(n,n), c(n,n)
 
49
      integer g_a,g_b,g_c,g_d, g_e, g_f, g_g
 
50
      integer g_aa,g_bb,g_cc,g_dd, g_ee, g_ff, g_gg
 
51
      integer  i, j
 
52
      integer ndim, dims(2), block(2), proc_grid(2), g1, g2
 
53
      integer nproc, me
 
54
      double precision dsin, sum
 
55
      logical status
 
56
c     
 
57
      nproc = ga_nnodes()
 
58
      me    = ga_nodeid()
 
59
c     
 
60
c     a() is a local copy of what the global array should start as
 
61
c
 
62
      do j = 1, n
 
63
         do i = 1, n
 
64
            a(i,j) = 1d0 * (i+j)  
 
65
            b(i,j) = DSIN(1d0* (i+j))   
 
66
        if(i.eq.j) then
 
67
               b(i,j) = 2d0 *n
 
68
               a(i,j) = i
 
69
            endif
 
70
        if(i.le.j)then
 
71
               c(i,j) = a(i,j)
 
72
            else
 
73
               c(i,j) = 0d0
 
74
            endif
 
75
         enddo
 
76
      enddo
 
77
#if 0
 
78
      if (me.eq.0) then
 
79
        open(unit=7,file='amat.dat',status='unknown')
 
80
        do  i = 1, min(20,n)
 
81
          write(7,128) (a(i,j),j=1,min(20,n))
 
82
  128     format(20f6.1)
 
83
        end do
 
84
      endif
 
85
#endif
 
86
c
 
87
c***  Create global arrays
 
88
#if BLOCK_CYCLIC
 
89
      if (me.eq.0) then
 
90
        write(6,*) '*'
 
91
        write(6,*) '* Creating Block-Cyclic Arrays'
 
92
        write(6,*) '*'
 
93
      endif
 
94
      dims(1) = n
 
95
      dims(2) = n
 
96
      block(1) = 2
 
97
      block(2) = 2
 
98
      call factor(nproc,g1,g2)
 
99
      proc_grid(1) = g1
 
100
      proc_grid(2) = g2
 
101
      g_a = ga_create_handle()
 
102
      call ga_set_data(g_a,2,dims,MT_DBL)
 
103
      call ga_set_block_cyclic_proc_grid(g_a,block,proc_grid)
 
104
      status = ga_allocate(g_a)
 
105
      g_b = ga_create_handle()
 
106
      call ga_set_data(g_b,2,dims,MT_DBL)
 
107
      call ga_set_block_cyclic_proc_grid(g_b,block,proc_grid)
 
108
      status = ga_allocate(g_b)
 
109
      g_c = ga_create_handle()
 
110
      call ga_set_data(g_c,2,dims,MT_DBL)
 
111
      call ga_set_block_cyclic_proc_grid(g_c,block,proc_grid)
 
112
      status = ga_allocate(g_c)
 
113
      g_d = ga_create_handle()
 
114
      call ga_set_data(g_d,2,dims,MT_DBL)
 
115
      call ga_set_block_cyclic_proc_grid(g_d,block,proc_grid)
 
116
      status = ga_allocate(g_d)
 
117
      dims(2) = 1
 
118
      g_e = ga_create_handle()
 
119
      call ga_set_data(g_e,2,dims,MT_DBL)
 
120
      call ga_set_block_cyclic_proc_grid(g_e,block,proc_grid)
 
121
      status = ga_allocate(g_e)
 
122
      g_f = ga_create_handle()
 
123
      call ga_set_data(g_f,2,dims,MT_DBL)
 
124
      call ga_set_block_cyclic_proc_grid(g_f,block,proc_grid)
 
125
      status = ga_allocate(g_f)
 
126
      g_g = ga_create_handle()
 
127
      call ga_set_data(g_g,2,dims,MT_DBL)
 
128
      call ga_set_block_cyclic_proc_grid(g_g,block,proc_grid)
 
129
      status = ga_allocate(g_g)
 
130
      g_aa = ga_create_handle()
 
131
      dims(2) = n
 
132
      call ga_set_data(g_aa,2,dims,MT_DBL)
 
133
      status = ga_allocate(g_aa)
 
134
      g_bb = ga_create_handle()
 
135
      call ga_set_data(g_bb,2,dims,MT_DBL)
 
136
      status = ga_allocate(g_bb)
 
137
      g_cc = ga_create_handle()
 
138
      call ga_set_data(g_cc,2,dims,MT_DBL)
 
139
      status = ga_allocate(g_cc)
 
140
      g_dd = ga_create_handle()
 
141
      call ga_set_data(g_dd,2,dims,MT_DBL)
 
142
      status = ga_allocate(g_dd)
 
143
      dims(2) = 1
 
144
      g_ee = ga_create_handle()
 
145
      call ga_set_data(g_ee,2,dims,MT_DBL)
 
146
      status = ga_allocate(g_ee)
 
147
      g_ff = ga_create_handle()
 
148
      call ga_set_data(g_ff,2,dims,MT_DBL)
 
149
      status = ga_allocate(g_ff)
 
150
      g_gg = ga_create_handle()
 
151
      call ga_set_data(g_gg,2,dims,MT_DBL)
 
152
      status = ga_allocate(g_gg)
 
153
#else
 
154
      if (.not. ga_create(MT_DBL, n, n, 'a', 1, 1, g_a))
 
155
     $     call ga_error(' ga_create failed ',2)
 
156
      if (.not. ga_create(MT_DBL, n, n, 'b', 1, 1, g_b))
 
157
     $     call ga_error(' ga_create failed ',2)
 
158
      if (.not. ga_create(MT_DBL, n, n, 'c', 1, 1, g_c))
 
159
     $     call ga_error(' ga_create failed ',2)
 
160
      if (.not. ga_create(MT_DBL, n, n, 'd', 1, 1, g_d))
 
161
     $     call ga_error(' ga_create failed ',2)
 
162
      if (.not. ga_create(MT_DBL, n, 1, 'e', 1, 1, g_e))
 
163
     $     call ga_error(' ga_create failed ',2)
 
164
      if (.not. ga_create(MT_DBL, n, 1, 'f', 1, 1, g_f))
 
165
     $     call ga_error(' ga_create failed ',2)
 
166
      if (.not. ga_create(MT_DBL, n, 1, 'g', 1, 1, g_g))
 
167
     $     call ga_error(' ga_create failed ',2)
 
168
#endif
 
169
c     
 
170
c     
 
171
c***  Fill in arrays A & B
 
172
      if (me .eq. 0) then
 
173
         print *,  ' filling in A and B  '
 
174
         call ffflush(6)
 
175
         call ga_put(g_e, 1,n, 1,1, b(1,1),n)
 
176
         call ga_put(g_f, 1,n, 1,1, b(1,1),n)
 
177
      endif
 
178
      do j = 1+me, n, nproc 
 
179
        call ga_put(g_a, 1,n, j,j, a(1,j),n)
 
180
        call ga_put(g_b, 1,n, j,j, b(1,j),n)
 
181
        call ga_put(g_c, 1,n, j,j, b(1,j),n)
 
182
      enddo
 
183
      call ga_sync()
 
184
c
 
185
c     call ga_copy(g_b,g_c)
 
186
c
 
187
      if (me .eq. 0) then
 
188
        print *,' '
 
189
        print *, '>Test of the LU-based solver with nxn rhs '
 
190
        print *,' '
 
191
        call ffflush(6)
 
192
      endif
 
193
#ifndef HAVE_SCALAPACK
 
194
      call ga_lu_solve_seq('n', g_a, g_b)
 
195
#else
 
196
#if BLOCK_CYCLIC
 
197
      call ga_copy(g_a,g_aa)
 
198
#endif
 
199
      call ga_lu_solve('n', g_a, g_b)
 
200
#if BLOCK_CYCLIC
 
201
      call ga_copy(g_aa,g_a)
 
202
#endif
 
203
#endif
 
204
#if BLOCK_CYCLIC
 
205
c      call print_block(g_b)
 
206
      call ga_copy(g_b,g_bb)
 
207
      call ga_copy(g_c,g_cc)
 
208
      call ga_copy(g_d,g_dd)
 
209
      call ga_dgemm('n','n',n,n,n, 1d0, g_aa, g_bb, 0d0, g_dd) ! d := a*b
 
210
      call ga_add(1d0, g_dd, -1d0, g_cc, g_cc) 
 
211
      sum = ga_ddot(g_cc,g_cc)
 
212
#else
 
213
c      call print_rblock(g_b)
 
214
      call ga_dgemm('n','n',n,n,n, 1d0, g_a, g_b, 0d0, g_d) ! d := a*b
 
215
      call ga_add(1d0, g_d, -1d0, g_c, g_c) 
 
216
      sum = ga_ddot(g_c,g_c)
 
217
#endif
 
218
      if (me .eq. 0) then
 
219
        print *,' '
 
220
        print *, ' dsqrt(sum) = ', dsqrt(sum)
 
221
        print *, ' n = ', n
 
222
        print *, ' norm = ', dsqrt(sum)/n
 
223
        if(dsqrt(sum)/n.lt.1d-10) then
 
224
           print *, ' test passed '
 
225
        else
 
226
           call ga_error(' test failed ',3)
 
227
        endif
 
228
        print *,' '
 
229
        call ffflush(6)
 
230
      endif
 
231
c
 
232
      if (me .eq. 0) then
 
233
        print *,' '
 
234
        print *,'>Test of the LU-based solver with a single vector rhs'
 
235
        print *,' '
 
236
        call ffflush(6)
 
237
      endif
 
238
c
 
239
#ifndef HAVE_SCALAPACK
 
240
      call ga_lu_solve_seq('n', g_a, g_e)
 
241
#else
 
242
#if BLOCK_CYCLIC
 
243
      call ga_copy(g_a,g_aa)
 
244
#endif
 
245
      call ga_lu_solve('n', g_a, g_e)
 
246
#endif
 
247
c
 
248
#if BLOCK_CYCLIC
 
249
      call ga_copy(g_e,g_ee)
 
250
      call ga_copy(g_f,g_ff)
 
251
      call ga_copy(g_g,g_gg)
 
252
      call ga_dgemm('n','n',n,1,n, 1d0, g_aa, g_ee, 0d0, g_gg) ! g := a*e
 
253
      call ga_add(1d0, g_gg, -1d0, g_ff, g_ff) 
 
254
      sum = ga_ddot(g_ff,g_ff)
 
255
#else
 
256
      call ga_dgemm('n','n',n,1,n, 1d0, g_a, g_e, 0d0, g_g) ! g := a*e
 
257
      call ga_add(1d0, g_g, -1d0, g_f, g_f) 
 
258
      sum = ga_ddot(g_f,g_f)
 
259
#endif
 
260
      if (me .eq. 0) then
 
261
        print *,' '
 
262
        print *, ' norm = ', dsqrt(sum)/n
 
263
        if(dsqrt(sum)/n.lt.1d-10) then
 
264
           print *, ' test passed '
 
265
        else
 
266
           call ga_error(' test failed ',4)
 
267
        endif           
 
268
        print *,' '
 
269
        call ffflush(6)
 
270
      endif
 
271
      end
 
272
c
 
273
      subroutine factor(p,idx,idy)
 
274
      implicit none
 
275
      integer i,j,p,idx,idy,it
 
276
      integer ip,ifac,pmax,prime(1280)
 
277
      integer fac(1280)
 
278
c
 
279
      i = 1
 
280
      ip = p
 
281
c
 
282
c    factor p completely
 
283
c    first, find all prime numbers less than or equal to p
 
284
c
 
285
      pmax = 0
 
286
      do i = 2, p
 
287
        do j = 1, pmax
 
288
          if (mod(i,prime(j)).eq.0) go to 100
 
289
        end do
 
290
        pmax = pmax + 1
 
291
        prime(pmax) = i
 
292
  100   continue
 
293
      end do
 
294
c
 
295
c    find all prime factors of p
 
296
c
 
297
      ifac = 0
 
298
      do i = 1, pmax
 
299
  200   if (mod(ip,prime(i)).eq.0) then
 
300
          ifac = ifac + 1
 
301
          fac(ifac) = prime(i)
 
302
          ip = ip/prime(i)
 
303
          go to 200
 
304
        endif
 
305
      end do
 
306
c
 
307
c    determine two factors of p of approximately the
 
308
c    same size
 
309
c
 
310
      idx = 1
 
311
      idy = 1
 
312
      do i = ifac, 1, -1
 
313
        if (idx.le.idy) then
 
314
          idx = fac(i)*idx
 
315
        else
 
316
          idy = fac(i)*idy
 
317
        endif
 
318
      end do
 
319
      return
 
320
      end
 
321
c
 
322
      subroutine print_block(g_a)
 
323
      implicit none
 
324
#include "mafdecls.fh"
 
325
#include "global.fh"
 
326
      integer g_a, i, j, istride, jstride
 
327
      integer idx, ld, me
 
328
      me = ga_nodeid()
 
329
      istride = 10
 
330
      if (me.eq.0) then
 
331
      jstride = 6
 
332
      else
 
333
      jstride = 4
 
334
      endif
 
335
      call nga_access_block_segment(g_a,me,idx,ld)
 
336
      do i = 1, istride
 
337
        write(6,733) me,(dbl_mb(idx+(j-1)*istride+i-1),j=1,jstride)
 
338
      end do
 
339
  733 format(i8,8f12.6)
 
340
      return
 
341
      end
 
342
c
 
343
      subroutine print_rblock(g_a)
 
344
      implicit none
 
345
#include "mafdecls.fh"
 
346
#include "global.fh"
 
347
      integer g_a, i, j, istride, jstride
 
348
      integer idx, ld, me, lo(2), hi(2)
 
349
      me = ga_nodeid()
 
350
      istride = 10
 
351
      jstride = 5
 
352
      call nga_distribution(g_a,me,lo,hi)
 
353
      call nga_access(g_a,lo,hi,idx,ld)
 
354
      do i = 1, istride
 
355
        write(6,733) me,(dbl_mb(idx+(j-1)*istride+i-1),j=1,jstride)
 
356
      end do
 
357
  733 format(i8,8f12.6)
 
358
      return
 
359
      end