1C> \ingroup task
2C> @{
3      logical function task_check_sum(rtdb)
4C$Id$
5      implicit none
6      integer rtdb
7c
8      call do_int_chk_sum(rtdb,'geometry','ao basis',
9     &    'ri basis',1.0d-10)
10      task_check_sum = .true.
11      end
12C> @}
13      subroutine do_int_chk_sum(rtdb,geom_name, basis_name,
14     &    fit_basis_name, tol2e)
15      implicit none
16#include "geom.fh"
17#include "errquit.fh"
18#include "bas.fh"
19#include "mafdecls.fh"
20#include "global.fh"
21#include "rtdb.fh"
22#include "util.fh"
23#include "stdio.fh"
24c
25      integer rtdb
26      integer basis, geom, ribasis
27      integer bases(2)
28      double precision cpu, wall
29      double precision tol2e
30      character*(*) geom_name, basis_name, fit_basis_name
31c
32      logical doitcs_all
33      logical doitcs_1e
34      logical doitcs_ov
35      logical doitcs_ke
36      logical doitcs_pe
37      logical doitcs_h1
38      logical doitcs_3ov
39      logical doitcs_2e
40      logical doitcs_b2e4c
41      logical doitcs_2e4c
42      logical doitcs_2e3c
43      logical doitcs_2e2c
44
45      logical doitcs_any
46
47      logical ribasis_exist
48      logical dummyL
49c
50      logical int_normalize
51*--      logical int_norm_2c
52      external int_normalize
53*--      external int_norm_2c
54c
55      write(luout,*)' do_int_chk_sum:rtdb          :',rtdb
56      write(luout,*)' do_int_chk_sum:geom_name     : <',geom_name,'>'
57      write(luout,*)' do_int_chk_sum:basis_name    : <',basis_name,'>'
58      write(luout,*)' do_int_chk_sum:fit_basis_name: <',
59     &    fit_basis_name,'>'
60c
61      if (.not.rtdb_parallel(.true.))
62     &     call errquit('do_int_chk_sum: rtdb_parallel failed?', 0,
63     &             RTDB_ERR)
64      if (.not. geom_create(geom, geom_name))
65     &     call errquit('do_int_chk_sum: geom_create failed?', 0,
66     &                GEOM_ERR)
67      if (.not. geom_rtdb_load(rtdb, geom, geom_name))
68     &     call errquit('do_int_chk_sum: geom_load failed', 0,
69     &                GEOM_ERR)
70      if (.not. bas_create(basis, basis_name))
71     &     call errquit('do_int_chk_sum: basis create failed', 0,
72     &            BASIS_ERR)
73      if (.not. bas_rtdb_load(rtdb, geom, basis, basis_name))
74     &      call errquit('do_int_chk_sum: basis load failed', 0,
75     &            BASIS_ERR)
76      if (.not. bas_create(ribasis, fit_basis_name))
77     &     call errquit('do_int_chk_sum: basis create failed', 0,
78     &              BASIS_ERR)
79      if (.not.bas_rtdb_load(rtdb, geom, ribasis, fit_basis_name)) then
80        if (.not.bas_destroy(ribasis)) call errquit
81     &      ('do_int_chk_sum:failed to destroy ribasis handle',911,
82     &           INT_ERR)
83        ribasis = -1
84        ribasis_exist = .false.
85      else
86        ribasis_exist = .true.
87      endif
88c
89      if (ga_nodeid().eq.0) then
90        if (.not. geom_print(geom))
91     &      call errquit('do_int_chk_sum: geom_print failed', 0,
92     &             GEOM_ERR)
93        if (.not. bas_print(basis))
94     &      call errquit('do_int_chk_sum: basis print failed', 0,
95     &             BASIS_ERR)
96        if (.not. gbs_map_print(basis))
97     &      call errquit('do_int_chk_sum: gbs_map_print failed', 0,
98     &             BASIS_ERR)
99        if (ribasis_exist) then
100          if (.not. bas_print(ribasis))
101     &        call errquit('do_int_chk_sum: fit basis print failed', 0,
102     &             BASIS_ERR)
103          if (.not. gbs_map_print(ribasis))
104     &        call errquit('do_int_chk_sum: gbs_map_print failed', 0,
105     &              BASIS_ERR)
106        endif
107      endif
108*----------------------------------
109#define NORMFIRST
110#if defined(NORMFIRST)
111c
112c normalize basis set
113c
114      if (.not.int_normalize(rtdb,basis))
115     &       call errquit('do_int_chk_sum: basis norm. failed', 0,
116     &             BASIS_ERR)
117*--      if (.not.int_norm_2c(rtdb,basis))
118*--     &       call errquit('do_int_chk_sum: basis norm. failed', 0)
119*--      if (.not. bas_print(basis))
120*--     &    call errquit('do_int_chk_sum: basis print failed', 0)
121c
122      bases(1) = basis
123      bases(2) = ribasis
124c
125      if (ribasis_exist) then
126        call int_init(rtdb,2,bases)
127      else
128        call int_init(rtdb,1,bases)
129      endif
130      call int_acc_set(tol2e)
131#else
132      bases(1) = basis
133      bases(2) = ribasis
134c
135      if (ribasis_exist) then
136        call int_init(rtdb,2,bases)
137      else
138        call int_init(rtdb,1,bases)
139      endif
140      call int_acc_set(tol2e)
141c
142c normalize basis set
143c
144      if (.not.int_normalize(rtdb,basis))
145     &       call errquit('do_int_chk_sum: basis norm. failed', 0)
146*--      if (.not.int_norm_2c(rtdb,basis))
147*--     &       call errquit('do_int_chk_sum: basis norm. failed', 0)
148*--      if (.not. bas_print(basis))
149*--     &    call errquit('do_int_chk_sum: basis print failed', 0)
150c
151#endif
152*
153* check flags on rtdb to see what is to be done.
154* *default is to do nothing
155* computational flags:
156* intcsum:all
157* intcsum:1e
158* intcsum:ov
159* intcsum:ke
160* intcsum:pe
161* intcsum:h1
162* intcsum:3ov
163* intcsum:2e
164* intcsum:b2e4c
165* intcsum:2e4c
166* intcsum:2e3c
167* intcsum:2e2c
168*
169* print flags
170* intcsum:ovprint
171* intcsum:keprint
172* intcsum:peprint
173* intcsum:h1print
174* intcsum:3ovprint
175* intcsum:b2e4cprint
176* intcsum:2e4cprint
177* intcsum:2e3cprint
178* intcsum:2e2cprint
179*
180c determine computational flag setup
181      doitcs_all   = .false.
182      doitcs_1e    = .false.
183      doitcs_ov    = .false.
184      doitcs_ke    = .false.
185      doitcs_pe    = .false.
186      doitcs_h1    = .false.
187      doitcs_3ov   = .false.
188      doitcs_2e    = .false.
189      doitcs_b2e4c = .false.
190      doitcs_2e4c  = .false.
191      doitcs_2e3c  = .false.
192      doitcs_2e2c  = .false.
193c
194      dummyL = .false.
195      if (rtdb_get(rtdb,'intcsum:all',MT_LOG,1,dummyL)) then
196        doitcs_all = dummyL
197      endif
198      dummyL = .false.
199      if (rtdb_get(rtdb,'intcsum:1e',MT_LOG,1,dummyL)) then
200        doitcs_1e = dummyL
201      endif
202      dummyL = .false.
203      if (rtdb_get(rtdb,'intcsum:2e',MT_LOG,1,dummyL)) then
204        doitcs_2e = dummyL
205      endif
206c
207      if (doitcs_all) then
208        doitcs_ov    = .true.
209        doitcs_ke    = .true.
210        doitcs_pe    = .true.
211        doitcs_h1    = .true.
212        doitcs_3ov   = .true.
213        doitcs_b2e4c = .true.
214        doitcs_2e4c  = .true.
215        doitcs_2e3c  = .true.
216        doitcs_2e2c  = .true.
217      endif
218      if (doitcs_1e) then
219        doitcs_ov    = .true.
220        doitcs_ke    = .true.
221        doitcs_pe    = .true.
222        doitcs_3ov   = .true.
223      endif
224      if (doitcs_2e) then
225        doitcs_b2e4c = .true.
226        doitcs_2e4c  = .true.
227        doitcs_2e3c  = .true.
228        doitcs_2e2c  = .true.
229      endif
230c
231      dummyL = .false.
232      if (rtdb_get(rtdb,'intcsum:ov',MT_LOG,1,dummyL)) then
233        doitcs_ov = dummyL
234      endif
235      dummyL = .false.
236      if (rtdb_get(rtdb,'intcsum:ke',MT_LOG,1,dummyL)) then
237        doitcs_ke = dummyL
238      endif
239      dummyL = .false.
240      if (rtdb_get(rtdb,'intcsum:pe',MT_LOG,1,dummyL)) then
241        doitcs_pe = dummyL
242      endif
243      dummyL = .false.
244      if (rtdb_get(rtdb,'intcsum:h1',MT_LOG,1,dummyL)) then
245        doitcs_h1 = dummyL
246      endif
247      dummyL = .false.
248      if (rtdb_get(rtdb,'intcsum:3ov',MT_LOG,1,dummyL)) then
249        doitcs_3ov = dummyL
250      endif
251      dummyL = .false.
252      if (rtdb_get(rtdb,'intcsum:b2e4c',MT_LOG,1,dummyL)) then
253        doitcs_b2e4c = dummyL
254      endif
255      dummyL = .false.
256      if (rtdb_get(rtdb,'intcsum:2e4c',MT_LOG,1,dummyL)) then
257        doitcs_2e4c = dummyL
258      endif
259      dummyL = .false.
260      if (rtdb_get(rtdb,'intcsum:2e3c',MT_LOG,1,dummyL)) then
261        doitcs_2e3c = dummyL
262      endif
263      dummyL = .false.
264      if (rtdb_get(rtdb,'intcsum:2e2c',MT_LOG,1,dummyL)) then
265        doitcs_2e2c = dummyL
266      endif
267c
268      doitcs_any = doitcs_ov.or.doitcs_ke.or.doitcs_pe.or.doitcs_h1
269      doitcs_any = doitcs_any.or.doitcs_3ov.or.doitcs_b2e4c
270      doitcs_any = doitcs_any.or.doitcs_2e4c.or.doitcs_2e3c
271      doitcs_any = doitcs_any.or.doitcs_2e2c
272      if (.not.doitcs_any) then
273        write(luout,*)' no specified tasks for checksum'
274        write(luout,*)' add one of the following set directives ',
275     &      'to your input deck'
276        write(luout,*)' '
277        write(luout,*)' computational flags:'
278        write(luout,*)' set intcsum:all logical true'
279        write(luout,*)' set intcsum:1e logical true'
280        write(luout,*)' set intcsum:2e logical true'
281        write(luout,*)' set intcsum:ov logical true'
282        write(luout,*)' set intcsum:ke logical true'
283        write(luout,*)' set intcsum:pe logical true'
284        write(luout,*)' set intcsum:h1 logical true'
285        write(luout,*)' set intcsum:3ov logical true'
286        write(luout,*)' set intcsum:b2e4c logical true'
287        write(luout,*)' set intcsum:2e4c logical true'
288        write(luout,*)' set intcsum:2e3c logical true'
289        write(luout,*)' set intcsum:2e2c logical true'
290        write(luout,*)' '
291        write(luout,*)' '
292        write(luout,*)' print flags:'
293        write(luout,*)' set intcsum:ovprint logical true'
294        write(luout,*)' set intcsum:keprint logical true'
295        write(luout,*)' set intcsum:peprint logical true'
296        write(luout,*)' set intcsum:h1print logical true'
297        write(luout,*)' set intcsum:3ovprint logical true'
298        write(luout,*)' set intcsum:b2e4cprint logical true'
299        write(luout,*)' set intcsum:2e4cprint logical true'
300        write(luout,*)' set intcsum:2e3cprint logical true'
301        write(luout,*)' set intcsum:2e2cprint logical true'
302        write(luout,*)' '
303        write(luout,*)' '
304      endif
305c
306      cpu  = util_cpusec()
307      wall = util_wallsec()
308
309      if (doitcs_ov) then
310        call int_chk_sum_ov(rtdb,basis,.false.)
311      endif
312      if (doitcs_ke) then
313        call int_chk_sum_ke(rtdb,basis,.false.)
314      endif
315      if (doitcs_pe) then
316        call int_chk_sum_pe(rtdb,basis,.false.)
317      endif
318      if (doitcs_h1) then
319        call int_chk_sum_h1(rtdb,basis,.false.)
320      endif
321      if (doitcs_3ov) then
322        call int_chk_sum_3ov(rtdb,basis,ribasis,.false.)
323      endif
324      if (doitcs_2e2c) then
325        call int_chk_sum_2e2c(rtdb,basis,ribasis,.false.)
326      endif
327      if (doitcs_2e3c) then
328        call int_chk_sum_2e3c(rtdb,basis,ribasis,.false.)
329      endif
330      if (doitcs_2e4c) then
331        call int_chk_sum_2e4c(rtdb,basis,.false.)
332      endif
333      if (doitcs_b2e4c) then
334        call intb_chk_sum(rtdb,basis,.false.)
335      endif
336*      call int_chk_sum(rtdb,basis,.false.)
337*--      call int_chk_sum(rtdb,basis,.true.)
338      cpu  = util_cpusec() - cpu
339      wall = util_wallsec() - wall
340c
341      write(luout,'(1x,a,f10.2)')
342     &    'checksum cpu  time:',cpu
343      write(luout,'(1x,a,f10.2)')
344     &    'checksum wall time:',wall
345c
346      call int_terminate()
347c
348      if (ribasis_exist) then
349        if (.not.(bas_destroy(ribasis)))
350     &      call errquit('rak:error destroying ribasis ',0,
351     &              BASIS_ERR)
352      endif
353      if (.not.(bas_destroy(basis)))
354     &    call errquit('rak:error destroying basis',0,
355     &            BASIS_ERR)
356      if (.not.(geom_destroy(geom)))
357     &    call errquit('rak:error destroying geometry',0, BASIS_ERR)
358      if (ga_nodeid().eq.0) call MA_summarize_allocated_blocks()
359c
360      end
361