1#ifdef USE_SIMINT 2 subroutine nwcsim_init(rtdb,nbas,bases,num_der) 3 use nwcsim_shell 4 implicit none 5#include "bas.fh" 6#include "geom.fh" 7#include "basP.fh" 8#include "basdeclsP.fh" 9#include "geomP.fh" 10#include "geobasmapP.fh" 11#include "apiP.fh" 12#include "errquit.fh" 13#include "mafdecls.fh" 14#include "global.fh" 15#include "rtdb.fh" 16#include "stdio.fh" 17#include "nwcsim.fh" 18c use iso_c_binding 19 integer rtdb,nbas,bases(3) 20 integer :: num_der 21c type(c_simint_multi_shellpair), target :: msh 22 double precision :: alpha(3), coef(3) 23 integer :: ibasis,basis,bas 24 logical cart_2_sphe 25 integer :: geom, natoms 26 integer :: max_der, max_ang 27 integer :: mxmx 28 integer :: iat,icset,ic1,ic2, nprim 29 integer :: l, ncontr, isphere 30 character*16 tag 31 integer l_coef,k_coef,l_exp,k_exp 32 double precision coord(3) 33 double precision q 34 integer nwcsim_maxam 35 external nwcsim_maxam 36 character*14 pname 37 pname="nwcsim_f90init" 38c fetch stuff from rtdb 39 if (.not.rtdb_get(rtdb,'int:smnt_screen_tol',MT_DBL,1, 40 s smnt_screen_tol)) smnt_screen_tol=1d-22 41#define SIMINT_SCREEN_NONE 0 42#define SIMINT_SCREEN_SCHWARZ 1 43#define SIMINT_SCREEN_FASTSCHWARZ 2 44 if (.not.rtdb_get(rtdb,'int:smnt_screen_method',MT_INT,1, 45 s smnt_screen_method)) smnt_screen_method= 46 S SIMINT_SCREEN_FASTSCHWARZ 47c reset screen_tol when screening is off 48 if(smnt_screen_method.eq.SIMINT_SCREEN_NONE)smnt_screen_tol=0d0 49 50c stick to nbas>=2 for now 51 if(nbas.gt.2) call errquit( 52 C ' simint interface not ready for no basis gt 2',0,0) 53c init 54 max_der=0 55#ifdef SIMINT_GRADIENT 56 max_der=1 57#endif 58 if(num_der.gt.max_der) call errquit( 59 C ' simint interface not ready for derivative ', 60 D num_der,0) 61 if(.not.nwcsim_initialized) then 62 call simint_init() 63c needed for 1-e integrals 64 call igamma_init() 65 66 nwcsim_initialized=.true. 67c 68c create shells simint structure 69c 70 nwcsim_nbas=nbas 71 do ibasis=1,nbas 72 basis = bases(ibasis) 73 bas = basis + BASIS_HANDLE_OFFSET 74 nwcsim_bas(ibasis)=bas 75c offset=-565 76 cart_2_sphe=bas_spherical(bas) 77 if (.not.bas_nprim_cn_max(basis, mxmx)) 78 C call errquit(' bas_nprim_cn_max failed ',0,BASIS_ERR) 79 if (.not. MA_Push_Get(MT_Dbl,mxmx,'simexp',l_exp,k_exp)) 80 C call errquit(' simint wrk ',mxmx,MA_ERR) 81 if (.not. MA_Push_Get(MT_Dbl,mxmx,'simcoef',l_coef,k_coef)) 82 C call errquit(' simint wrk ',mxmx, MA_ERR) 83 geom = ibs_geom(bas) 84c 85 natoms = ncenter(geom) 86 nwcsim_noshell(bas)=0 87 max_ang=0 88 do iat=1,natoms 89 if (.not.bas_ce2cnr(basis,iat,ic1,ic2)) 90 & call errquit(pname//'Exiting ',11, BASIS_ERR) 91 do icset = ic1,ic2 92 if (.not.bas_continfo(basis, icset, 93 & l, nprim, ncontr, isphere)) 94 & call errquit(pname//'Exiting ',3, BASIS_ERR) 95 if(l.gt.nwcsim_maxam()) call errquit( 96 p pname//' simint library maxam too small ', 97 p nwcsim_maxam(),BASIS_ERR) 98 max_ang=max(l,max_ang) 99 if (.not.bas_get_exponent(basis, icset, dbl_mb(k_exp))) 100 & call errquit(pname//'Exiting ',7, BASIS_ERR) 101 if(.not. bas_get_coeff(basis,icset,dbl_mb(k_coef))) 102 & call errquit(pname//'Exiting ',8, BASIS_ERR) 103 if (.not. geom_cent_get(geom, iat, tag, 104 & coord, q))call errquit 105 nwcsim_noshell(bas)=nwcsim_noshell(bas)+1 106 call simint_initialize_shell( 107 S smnt_sh(nwcsim_noshell(bas),bas)) 108 109 call simint_create_shell(nprim, l , 110 C coord(1), coord(2), coord(3), 111 & dbl_mb(k_exp), dbl_mb(k_coef), 112 L smnt_sh(nwcsim_noshell(bas),bas)) 113c dummy shell for 3c- 114 dbl_mb(k_exp)=0d0 115 dbl_mb(k_coef)=1d0 116 call simint_create_shell(1, 0 , 117 C coord(1), coord(2), coord(3), 118 & dbl_mb(k_exp), dbl_mb(k_coef), 119 L zero_sh(nwcsim_noshell(bas),bas)) 120 enddo 121 enddo 122 if(.not.ma_chop_stack(l_exp)) call errquit( 123 E ' pop stack failed ',l_exp,0) 124c 125c memory allocation 126c 127 isz_2e4c = max(isz_2e4c, 128 S simint_eri_worksize(num_der, max_ang)) 129 mem_2e4c = max(mem_2e4c, 130 S simint_eri_workmem(num_der, max_ang)) 131 enddo ! basis loop 132 endif 133c 134c normalization not needed since nwchem and simint use the same 135cedo call simint_normalize_shells(nwcsim_noshell,smnt_sh) 136c SIMINT_PRIM_SCREEN_STAT needs 4 more doubles 137c isz_2e4c = isz_2e4c + 4 138c 139 call util_align(isz_2e4c,SIMINT_SIMD_LEN) 140 call util_align(mem_2e4c,SIMINT_SIMD_LEN) 141c 142 iszb_2e4c=isz_2e4c 143 144 if(num_der.eq.1) then 145 memb_2e4c = mem_2e4c + mem_2e4c/5 146 else 147 memb_2e4c = mem_2e4c + mem_2e4c/10 ! +10% to be safe 148 endif 149 call util_align(memb_2e4c,SIMINT_SIMD_LEN) 150 mem_2e3c = mem_2e4c 151 mem_2e2c = mem_2e4c 152 if(ga_nodeid().eq.0) then 153 write(luout,*) 154 write(luout,*) ' Using Simint Integral package' 155 write(luout,*) ' num_der',num_der 156 write(luout,*) ' simint: mem_2e4c ',mem_2e4c 157 write(luout,*) ' simint: memb_2e4c ',memb_2e4c 158 write(luout,*) ' simint: isz_2e4c ',isz_2e4c 159 write(luout,*) ' simint: iszb_2e4c ',iszb_2e4c 160 write(luout,*) ' screen_method ',smnt_screen_method 161 write(luout,*) ' screen_tol ',smnt_screen_tol 162 write(luout,*) 163 call util_flush(luout) 164 endif 165 166 return 167 end 168 subroutine nwcsim_terminate() 169 use nwcsim_shell 170 implicit none 171#include "errquit.fh" 172 integer nbas ! [in] 173 integer bases(3) ! [in] 174c 175 integer icsh,ibasis,bas 176 character*14 pname 177 pname="nwcsim_termina" 178c 179 if(nwcsim_initialized) then 180 do ibasis=1,nwcsim_nbas 181 bas=nwcsim_bas(ibasis) 182 do icsh=1,nwcsim_noshell(bas) 183 call simint_free_shell(smnt_sh(icsh,bas)) 184 call simint_free_shell(zero_sh(icsh,bas)) 185 enddo 186 enddo 187 endif 188 call simint_finalize() 189 nwcsim_initialized=.false. 190 return 191 end 192 integer function nwcsim_maxam() 193 implicit none 194c 195 nwcsim_maxam=SIMINT_MAXAM 196 return 197 end 198 logical function nwcsim_initdone() 199 use nwcsim_shell 200 implicit none 201c 202 nwcsim_initdone=nwcsim_initialized 203 return 204 end 205#else 206c 207c stubs when simint is not used 208c 209 subroutine nwcsim_init(rtdb,nbas,bases) 210 implicit none 211#include "errquit.fh" 212 integer rtdb,nbas,bases 213 return 214 end 215 subroutine nwcsim_terminate(nbas,bases) 216 implicit none 217#include "errquit.fh" 218 integer nbas,bases 219 return 220 end 221 logical function nwcsim_initdone() 222 implicit none 223c 224 nwcsim_initdone=.false. 225 return 226 end 227 integer function nwcsim_maxam() 228 implicit none 229c 230 nwcsim_maxam=-1 231 return 232 end 233#endif 234 logical function int_forcenwints(rtdb,rtdb_errmsg) 235 implicit none 236#include "rtdb.fh" 237#include "mafdecls.fh" 238#include "errquit.fh" 239#include "stdio.fh" 240#include "global.fh" 241 integer rtdb 242 character*(*) rtdb_errmsg 243c 244 logical out1 245c 246 int_forcenwints=.false. 247c Force texas integrals to false for CAM calculations 248 if (.not.rtdb_put(rtdb,'int:cando_txs',mt_log,1,.false.)) 249 & then 250 rtdb_errmsg='cannot set int:cando_txs' 251 return 252 endif 253c unset cando_nw if defined to avoid Simint 254 if (rtdb_get(rtdb,'int:cando_nw',mt_log,1,out1)) then 255 if (.not.rtdb_delete(rtdb,'int:cando_nw')) then 256 rtdb_errmsg='cannot del int:cando_nw' 257 return 258 endif 259 if(ga_nodeid().eq.0) write(luout,*) ' cando_nw unset' 260 endif 261 int_forcenwints=.true. 262 call ga_sync() 263 return 264 end 265 logical function int_disablesim(rtdb,rtdb_errmsg) 266 implicit none 267#include "rtdb.fh" 268#include "mafdecls.fh" 269#include "errquit.fh" 270#include "stdio.fh" 271#include "global.fh" 272 integer rtdb 273 character*(*) rtdb_errmsg 274c 275 logical cando_txs,cando_nw 276c 277 int_disablesim=.false. 278c 279c check if simint is enabled: 280c cando_nw=f & cando_txs=f 281c not needed if Simint is not enabled 282c 283#ifdef USE_SIMINT 284 if (.not.rtdb_get(rtdb,'int:cando_txs',mt_log,1,cando_txs)) 285 & cando_txs=.true. 286 if (.not.rtdb_get(rtdb,'int:cando_nw',mt_log,1,cando_txs)) 287 & cando_nw=.true. 288c unset cando_nw if defined to avoid Simint 289 if((.not.cando_txs).and.(.not.cando_nw)) then 290 if (.not.rtdb_delete(rtdb,'int:cando_nw')) then 291 rtdb_errmsg='cannot del int:cando_nw' 292 return 293 endif 294 if(ga_nodeid().eq.0) write(luout,*) ' cando_nw unset' 295 if (.not.rtdb_delete(rtdb,'int:cando_txs')) then 296 rtdb_errmsg='cannot del int:cando_txs' 297 return 298 endif 299 if(ga_nodeid().eq.0) write(luout,*) ' cando_txs unset' 300 endif 301#endif 302 int_disablesim=.true. 303 call ga_sync() 304 return 305 end 306 307