1 subroutine print_exndcf(msg) 2 implicit none 3c $Id$ 4#include "nwc_const.fh" 5#include "basP.fh" 6#include "util.fh" 7 character *(*) msg 8 integer i,j 9 write(6,*)'<<<< print_exndcf: ',msg,' >>>>' 10 do i = 1, nbasis_bsmx 11 write(6,10000)i,(exndcf(j,i), j=1,3) 12 enddo 1310000 format(' basis:',i2,' handle :',i10,/ 14 & ' ', ' index :',i10,/ 15 & ' ', ' size :',i10/) 16 end 17*..................................................................... 18 logical function bas_add_ucnt_init(basisin) 19 implicit none 20#include "errquit.fh" 21#include "mafdecls.fh" 22#include "nwc_const.fh" 23#include "basP.fh" 24#include "bas_exndcf_dec.fh" 25 integer basisin 26c::local 27 integer input_size 28 parameter(input_size = 10000) 29 integer basis, h_tmp, k_tmp 30c 31#include "bas_exndcf_sfn.fh" 32c 33 basis = basisin + BASIS_HANDLE_OFFSET 34c 35 bas_add_ucnt_init = ma_alloc_get( 36 & mt_dbl,input_size,' input for basis heap ', 37 & h_tmp,k_tmp) 38 exndcf(H_exndcf,basis) = h_tmp 39 exndcf(K_exndcf,basis)= k_tmp 40 if (.not. bas_add_ucnt_init) call errquit 41 & ('bas_add_unct_init: error allocating input heap space',911, 42 & MEM_ERR) 43 call dfill(input_size,0.0d00,dbl_mb(k_tmp),1) 44 exndcf(SZ_exndcf,basis) = input_size 45 end 46*..................................................................... 47 logical function bas_add_ucnt_tidy(basisin) 48 implicit none 49#include "errquit.fh" 50#include "mafdecls.fh" 51#include "nwc_const.fh" 52#include "basP.fh" 53#include "bas_exndcf_dec.fh" 54 integer basisin 55c::local 56 integer basis 57 integer h_tmp 58c 59#include "bas_exndcf_sfn.fh" 60c 61 basis = basisin + BASIS_HANDLE_OFFSET 62c 63 h_tmp = exndcf(H_exndcf,basis) 64 bas_add_ucnt_tidy = ma_free_heap(h_tmp) 65 if (.not.bas_add_ucnt_tidy) call errquit 66 & ('bas_add_unct_tidy: error freeing heap',911, MEM_ERR) 67 exndcf(H_exndcf ,basis) = -1 68 exndcf(K_exndcf ,basis) = 0 69 exndcf(SZ_exndcf,basis) = 0 70 bas_add_ucnt_tidy = .true. 71 end 72*..................................................................... 73 logical function bas_set_ecp_basis(basis) 74 implicit none 75#include "basdeclsP.fh" 76#include "nwc_const.fh" 77#include "basP.fh" 78 logical bas_check_handle 79 external bas_check_handle 80c 81 integer basis 82c 83 integer bas 84c 85 bas_set_ecp_basis = bas_check_handle(basis,'bas_set_ecp_basis') 86 if (.not. bas_set_ecp_basis) return 87 bas = basis + BASIS_HANDLE_OFFSET 88c 89 infbs_head(Head_ECP,bas) = 1 90 end 91*..................................................................... 92 logical function bas_set_so_basis(basis) 93 implicit none 94#include "basdeclsP.fh" 95#include "nwc_const.fh" 96#include "basP.fh" 97 logical bas_check_handle 98 external bas_check_handle 99c 100 integer basis 101c 102 integer bas 103c 104 bas_set_so_basis = bas_check_handle(basis,'bas_set_so_basis') 105 if (.not. bas_set_so_basis) return 106 bas = basis + BASIS_HANDLE_OFFSET 107c 108 infbs_head(Head_ECP,bas) = 2 109 end 110*..................................................................... 111 logical function ecp_set_num_elec(ecpid,tag,num_elec,stdtag) 112 implicit none 113#include "basdeclsP.fh" 114#include "nwc_const.fh" 115#include "basP.fh" 116*functions:: 117 logical ecp_check_handle 118 logical bas_add_utag 119 external ecp_check_handle 120 external bas_add_utag 121*passed:: 122 integer ecpid ! [input] basis set handle 123 character*16 tag ! [input] tag to set number of electrons for 124 integer num_elec ! [input] number of electrons ecp replaces 125 character*(*) stdtag ! [input] name associated with ecp on tag 126c 127*local:: 128 integer ecp_indx 129 integer itag 130c 131c sets the number of electrons replaced by the ecp on the 132c specified tag. If the tag is not present it will also add 133c that by calling bas_add_utag 134c 135 ecp_set_num_elec = ecp_check_handle(ecpid,'ecp_set_num_elec') 136 if (.not. ecp_set_num_elec) return 137 ecp_indx = ecpid + BASIS_HANDLE_OFFSET 138c 139c Make sure that the tag is in the list 140c 141 ecp_set_num_elec = bas_add_utag(ecpid, tag, stdtag, itag) 142 if (.not. ecp_set_num_elec) return 143 infbs_tags(Tag_Nelec,itag,ecp_indx) = num_elec 144c 145 end 146*..................................................................... 147 logical function ecp_get_num_elec(ecpid,tag,num_elec) 148 implicit none 149#include "basdeclsP.fh" 150#include "nwc_const.fh" 151#include "basP.fh" 152#include "stdio.fh" 153*functions:: 154 logical ecp_check_handle 155 external ecp_check_handle 156*passed:: 157 integer ecpid ! [input] basis set handle 158 character*16 tag ! [input] tag to get number of electrons for 159 integer num_elec ! [input] number of electrons ecp replaces 160c 161*local:: 162 integer ecp_indx 163 integer itag, ntag 164c 165c gets the number of electrons replaced by the ecp on the 166c specified tag. If the tag is not present it will error 167* 168c 169 ecp_get_num_elec = ecp_check_handle(ecpid,'ecp_get_num_elec') 170 if (.not.ecp_get_num_elec) return 171 ecp_indx = ecpid + BASIS_HANDLE_OFFSET 172c 173 ntag = infbs_head(Head_Ntags,ecp_indx) 174 do itag = 1,ntag 175 if (tag.eq.bs_tags(itag,ecp_indx)) then 176 num_elec = infbs_tags(Tag_Nelec,itag,ecp_indx) 177 ecp_get_num_elec = .true. 178 return 179 endif 180 enddo 181c 182 num_elec = 0 183 ecp_get_num_elec = .false. 184c 185 end 186*..................................................................... 187 logical function bas_add_utag(basisin, tag, stdtag, itag) 188 implicit none 189#include "basdeclsP.fh" 190#include "nwc_const.fh" 191#include "basP.fh" 192#include "inp.fh" 193 integer basisin ! [input] basis handle 194 character*(*) tag ! [input] name of tag 195 character*(*) stdtag ! [input] name of basis set on tag 196 integer itag ! [output] index of tag 197c 198 integer basis ! [local] index into basis arrays 199 logical bas_check_handle 200 external bas_check_handle 201 integer tmp 202c 203c Add the unique tag to the list of tags in the basis, 204c incrementing the no. of tags if necessary. 205c Return in itag the index of the unique tag 206c 207 bas_add_utag = bas_check_handle(basisin, 'bas_add_utag') 208 if (.not. bas_add_utag) return 209 basis = basisin + BASIS_HANDLE_OFFSET 210c 211 do itag = 1, infbs_head(HEAD_NTAGS,basis) 212 if (bs_tags(itag,basis) .eq. tag) then 213 if (bs_stdname(itag,basis).eq.'unknown') then 214 bs_stdname(itag,basis) = stdtag 215 else if (bs_stdname(itag,basis) .ne. stdtag) then 216 if (.not.(bs_stdname(itag,basis)(1:9).eq.'modified:')) then 217 tmp = inp_strlen(bs_stdname(itag,basis)) 218 bs_stdname(itag,basis) = 219 & 'modified:'//bs_stdname(itag,basis)(1:tmp) 220 endif 221 endif 222 return 223 endif 224 enddo 225c 226c No match found ... append new tag to the list 227c 228 itag = infbs_head(HEAD_NTAGS,basis) + 1 229 if (itag .gt. ntags_bsmx) then 230 write(6,*) 'bas_add_utag: too many tags', itag 231 bas_add_utag = .false. 232 return 233 endif 234c 235 infbs_head(HEAD_NTAGS,basis) = itag 236 bs_tags(itag,basis) = tag 237 bs_stdname(itag,basis) = stdtag 238c 239 end 240*..................................................................... 241 subroutine bas_err_info(info) 242 implicit none 243#include "nwc_const.fh" 244#include "basP.fh" 245c 246 character*(*) info ! [input] 247 integer bas,basin 248 integer nbas 249 logical status 250c 251c For internal use of the basis set routines only: print out 252c info of known basis sets to aid in diagnosing a problem 253c 254c::function 255 logical bas_print 256 external bas_print 257c 258 nbas = 0 259 do 00100 bas = 1, nbasis_bsmx 260 if (bsactive(bas)) nbas = nbas + 1 26100100 continue 262 write(6,'(1x,a,a,i2)') 263 & info, ': open basis sets:',nbas 264c 265 nbas = 0 266 do 00200 bas = 1, nbasis_bsmx 267 if (bsactive(bas)) then 268 basin = bas - BASIS_HANDLE_OFFSET 269 status = bas_print(basin) 270 endif 27100200 continue 272c 273 if (nbasis_rtdb .gt. 0) then 274 write(6,'(1x,a,a,i3)') 275 & info,': basis sets in current rtdb ',nbasis_rtdb 276 do 00300 bas = 1, nbasis_rtdb 277 write(6,'(1x,a,1x,i3,3x,a,1x,a)') 278 & 'number:',bas, 279 & 'basis set name:', 280 & bs_names_rtdb(bas)(1:len_bs_rtdb(bas)) 28100300 continue 282 endif 283c 284 end 285*..................................................................... 286 logical function bas_ucontinfo(basisin,icont,itype, 287 & nprimo,ngeno,sphcart) 288 implicit none 289#include "nwc_const.fh" 290#include "basP.fh" 291#include "geobasmapP.fh" 292#include "basdeclsP.fh" 293c::function 294 logical bas_check_handle 295 external bas_check_handle 296c::passed 297 integer basisin, icont, nprimo, ngeno, sphcart, itype 298c::local 299 integer basis,myucont,icontmax 300c 301 nprimo = -123 302 ngeno = -456 303 sphcart = -789 304c 305 bas_ucontinfo = bas_check_handle(basisin,'bas_ucontinfo') 306 if (.not.bas_ucontinfo) return 307 308 basis = basisin + BASIS_HANDLE_OFFSET 309c 310 icontmax = infbs_head(HEAD_NCONT,basis) 311c 312 if (.not.(icont.gt.0.and.icont.le.icontmax)) then 313 write(6,*)' bas_continfo: ERROR ' 314 write(6,*)' unique contraction range for basis is 1:', 315 & icontmax 316 write(6,*)' information requested for contraction:',icont 317 bas_ucontinfo = .false. 318 return 319 endif 320c 321 myucont = icont 322 if (bas_spherical(basis)) then 323 sphcart = 1 324 else 325 sphcart = 0 326 endif 327 itype = infbs_cont(CONT_TYPE,myucont,basis) 328 nprimo = infbs_cont(CONT_NPRIM,myucont,basis) 329 ngeno = infbs_cont(CONT_NGEN,myucont,basis) 330 bas_ucontinfo=.true. 331 return 332 end 333*..................................................................... 334 logical function bas_unumcont(basisin,numcont) 335 implicit none 336#include "nwc_const.fh" 337#include "basP.fh" 338#include "geobasmapP.fh" 339#include "basdeclsP.fh" 340c::function 341 logical bas_check_handle 342 external bas_check_handle 343c::passed 344 integer basisin,numcont 345c::local 346 integer basis 347c 348 numcont = -6589 349 bas_unumcont = bas_check_handle(basisin,'bas_numcont') 350 if (.not.bas_unumcont) return 351 352 basis = basisin + BASIS_HANDLE_OFFSET 353 354 numcont = infbs_head(HEAD_NCONT,basis) 355 356 bas_unumcont = .true. 357 return 358 end 359*..................................................................... 360 block data basis_data 361c 362c Block data structure to initialize the common block variables in the 363c internal basis set object data structures 364c 365 implicit none 366#include "nwc_const.fh" 367#include "basP.fh" 368c 369 data nbasis_rtdb /0/ 370 data bsactive /nbasis_bsmx*.false./ 371 data bas_spherical /nbasis_bsmx*.false./ 372 data angular_bs /nbasis_bsmx*-565/ 373 data bas_norm_id /nbasis_bsmx*-565/ 374 data nbfmax_bs /nbasis_bsmx*-565/ 375 data bsversion /5.00d00/ 376* version 5 includes so stuff 377c 378 end 379*..................................................................... 380 integer function nbf_from_ucont(ucont,basisin) 381c 382c function that returns the number of basis functions in a contraction 383c 384c types 0->S, 1->P, 2->D, 3->F etc. -1->SP -2->SPD 385c 386 implicit none 387#include "errquit.fh" 388#include "nwc_const.fh" 389#include "basP.fh" 390#include "basdeclsP.fh" 391c:: function 392 logical bas_check_handle 393 external bas_check_handle 394c:: passed 395 integer ucont ! [input] unique contraction 396 integer basisin ! [input] basis set handle 397c:: local 398 integer type 399 integer basis 400 integer ngen 401c 402 if(.not.bas_check_handle(basisin,'nbf_from_ucont')) 403 & call errquit('nbf_from_ucont: bad basis handle',basisin, 404 & BASIS_ERR) 405c 406 basis = basisin + BASIS_HANDLE_OFFSET 407c 408 type = infbs_cont(CONT_TYPE,ucont,basis) 409 ngen = infbs_cont(CONT_NGEN,ucont,basis) 410 if (type.ge.0) then 411 if (bas_spherical(basis)) then 412 nbf_from_ucont = ngen*(2*type+1) 413 else 414 nbf_from_ucont = ngen*(type+1)*(type+2)/2 415 endif 416 else if (type.eq.-1) then 417 nbf_from_ucont = ngen*2 418 else if (type.eq.-2) then 419 if (bas_spherical(basis)) then 420 nbf_from_ucont = ngen*9/3 421 else 422 nbf_from_ucont = ngen*10/3 423 endif 424 else 425 call errquit('nbf_from_ucont: bad cont type',type, BASIS_ERR) 426 endif 427 end 428*..................................................................... 429 logical function bas_set_spherical(basisin, ospherical) 430 implicit none 431#include "nwc_const.fh" 432#include "basP.fh" 433#include "basdeclsP.fh" 434c 435 integer basisin ! [input] basis set handle 436 logical ospherical ! [input] logical for spherical setting 437c 438 integer basis 439c 440 bas_set_spherical = .false. 441c 442 basis = basisin + BASIS_HANDLE_OFFSET 443 if (ospherical) then 444 infbs_head(HEAD_SPH,basis) = 1 445 bas_spherical(basis) = .true. 446 else 447 infbs_head(HEAD_SPH,basis) = 0 448 bas_spherical(basis) = .false. 449 endif 450 bas_set_spherical = .true. 451 end 452*..................................................................... 453 logical function bas_get_spherical(basisin, is_spherical) 454 implicit none 455#include "nwc_const.fh" 456#include "basP.fh" 457#include "basdeclsP.fh" 458c 459 integer basisin ! [input] basis get handle 460 logical is_spherical ! [output] logical for spherical getting 461c 462 integer basis 463c 464 bas_get_spherical = .false. 465c 466 basis = basisin + BASIS_HANDLE_OFFSET 467 if (infbs_head(head_sph,basis).eq.1) then 468 is_spherical = .true. 469 else 470 is_spherical = .false. 471 endif 472 bas_get_spherical = .true. 473 end 474*..................................................................... 475 logical function bas_name_exist_rtdb(rtdb,name) 476 implicit none 477#include "errquit.fh" 478* 479* function to determin if "name" has been stored on the 480* current rtdb in actual or translated by a set directive. 481* 482#include "mafdecls.fh" 483#include "rtdb.fh" 484#include "context.fh" 485#include "inp.fh" 486#include "nwc_const.fh" 487#include "basP.fh" 488c::functions 489 logical bas_rtdb_in 490 external bas_rtdb_in 491c::passed 492 integer rtdb ! [input] run time data base handle 493 character*(*) name ! [input] test name 494c::local 495 integer index 496 character*256 trans_name 497c 498 bas_name_exist_rtdb = bas_rtdb_in(rtdb) 499 if (.not.bas_name_exist_rtdb) call errquit 500 & ('bas_name_exist_rtdb: bas_rtdb_in failed',911, RTDB_ERR) 501c 502 bas_name_exist_rtdb = .false. 503 if (inp_match 504 & (nbasis_rtdb,.false.,name,bs_names_rtdb,index)) then 505 bas_name_exist_rtdb = .true. 506 return 507 endif 508 if (context_rtdb_match(rtdb,name,trans_name)) then 509 if (inp_match 510 & (nbasis_rtdb,.false.,trans_name,bs_names_rtdb,index)) then 511 bas_name_exist_rtdb = .true. 512 return 513 endif 514 endif 515 end 516