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